Codebase list cafeobj / f323ba7
Delte additional unused functions for record/class constructs. tswd 5 years ago
3 changed file(s) with 72 addition(s) and 367 deletion(s). Raw diff Collapse all Expand all
+2
-30
chaos/construct/sort.lisp less more
8484 force)
8585 (declare (ignore force))
8686 (setq sort-id-symbol (make-sort-id sort-id-symbol))
87 (let ((pre (find-sort-in module sort-id-symbol))
88 #||
89 (if force
90 nil
91 (simple-find-sort-in-local module sort-id-symbol))
92 ||#
93 )
94 #||
95 (when (and (not force) pre)
96 (with-output-chaos-warning ()
97 (format t "sort ~s is already declared in the module "
98 sort-id-symbol)
99 (print-mod-name (sort-module pre))
100 (print-next)
101 (princ "...ignored.")
102 (return-from define-sort nil)))
103 ||#
87 (let ((pre (find-sort-in module sort-id-symbol)))
10488 (if (and pre (eq (sort-type pre) type))
10589 (progn
10690 (setf (sort-hidden pre) hidden)
10892 ;;
10993 (let (sort)
11094 (case type
111 (record-sort
112 (setf sort (new-record-sort sort-id-symbol module hidden)))
113 (class-sort
114 (setf sort (new-class-sort sort-id-symbol module hidden)))
11595 (sort
11696 (setf sort (new-general-sort sort-id-symbol module hidden)))
11797 (and-sort
121101 (t (with-output-panic-message ()
122102 (format t "Unsupported type of sort ~s!" type)
123103 (chaos-error 'panic))))
124 ;; (register-sort sort)
125104 sort))))
126105
127106 ;;; DEFINE-BUILTIN-SORT
222201 ;;
223202 (setf (sort-derived-from new-sort) sort)
224203 ;;
225 (cond ((memq (sort-type sort) '(class-sort record-sort))
226 ;;
227 (setf (crsort-is-a-copy new-sort) t)
228 ;; obsolate values, but for the future.....
229 (with-output-panic-message ()
230 (princ "sorry, but copying record/class sort is not yet properly supported!"))
231 )
232 ((eq (sort-type sort) 'and-sort)
204 (cond ((eq (sort-type sort) 'and-sort)
233205 (setf (and-sort-components new-sort)
234206 (mapcar #'(lambda (s) (%copy-sort s module))
235207 (and-sort-components sort)))
+70
-285
chaos/primitives/bsort.lisp less more
118118 `(sort-constructor ,_sort-body))
119119
120120 (defun sort-is-derived-from (sort)
121 (declare (type sort* sort)
122 (optimize (speed 3) (safety 0)))
121123 (let ((df (sort-derived-from sort)))
122124 (if df
123125 (or (sort-is-derived-from df)
125127 nil)))
126128
127129 (defun get-original-sort (sort)
130 (declare (type sort* sort)
131 (optimize (speed 3) (safety 0)))
128132 (let ((res sort))
129133 (loop (if (null (sort-derived-from res))
130134 (return nil)
143147 (values symbol))
144148 (if (sort-is-hidden sort)
145149 :h
146 :v))
150 :v))
147151
148152 (defun print-sort-object (obj stream &rest ignore)
149153 (declare (ignore ignore))
156160 (defun new-general-sort (id module &optional hidden)
157161 (declare (type symbol id)
158162 (type module module)
159 (type (or null t) hidden))
163 (optimize (speed 3) (safety 0)))
160164 (let ((sort (sort* id hidden)))
161165 (setf (sort-module sort) module)
162166 (set-object-context-module sort module)
168172 (defun get-sort-named (sort-name module)
169173 (declare (type symbol sort-name)
170174 (type module module)
171 (values (or null sort-struct)))
175 (optimize (speed 3) (safety 0)))
172176 (find-in-assoc-table *sort-table* (cons sort-name module)))
173177
174178 (defun clear-tmp-sort-cache () (setq *sort-table* nil))
175179 (defun register-sort-cache (sort)
176180 (declare (type sort-struct sort)
177 (values t))
181 (optimize (speed 3) (safety 0)))
178182 (add-to-assoc-table *sort-table* (cons (sort-id sort)
179183 (sort-module sort))
180184 sort))
181
182 ;;; ************
183 ;;; RECORD&CLASS________________
184 ;;; ************
185 ;;; structure of instances of record or classe sorts. inherits %sort.
186 ;;;
187 ;;; additional slots:
188 ;;; slots : slot information
189 ;;; idconstr : class/record id constructor,
190 ;;; a pair of (method . pattern-variable).
191 ;;; constr : class/record constructor method.
192 ;;; maker : list of methods for make.Foo operations.
193 ;;;
194 ;;; slot information is a list of slot-info, which is a 6-tuple
195 ;;; (slot-name sort default attribute-constructor reader writer), where
196 ;;; 0 slot-name : slots' name, a string.
197 ;;; 1 sort : the sort of the slot's value.
198 ;;; 2 default : the default value (pre-term, i.e., string or sequence of
199 ;;; tokens.)
200 ;;; 3 attribute-id : the attribute name constructor,
201 ;;; a pair of (method . pattern-variable).
202 ;;; 4 reader : attribute reader method.
203 ;;; 5 writer : attribute writer method.
204 ;;;
205 ;;; * NOTE * `pattern-variable's are used for constructing record/class
206 ;;; template term (generalizing constructor terms in axioms).
207 ;;;
208
209 (defstruct (crsort (:include sort* (-type 'crsort))
210 (:copier nil)
211 (:constructor make-crsort)
212 (:constructor crsort* (id &optional hidden))
213 (:print-function print-cr-sort-object))
214 (slots nil :type list) ; slot informations.
215 (idconstr nil :type list) ; id constructor info.
216 (constr nil :type t) ; term constructor method.
217 (maker nil :type list) ; list of methods for `make.Foo'
218 ; operations.
219 (copy nil :type (or null t)) ; t iff the sort is a copy.
220 )
221
222 (eval-when (:execute :load-toplevel)
223 (setf (get 'crsort :print) 'print-sort-internal)
224 (setf (symbol-function 'is-crsort) (symbol-function 'crsort-p))
225 (setf (get 'crsort :type-predicate) (symbol-function 'crsort-p))
226 )
227
228 (defun print-cr-sort-object (obj stream &rest ignore)
229 (print-sort-object obj stream ignore))
230
231 ;;; Class sort _________________
232 ;;;
233
234 (defstruct (class-sort (:include crsort (-type 'class-sort))
235 (:copier nil)
236 (:constructor make-class-sort)
237 (:constructor class-sort* (id &optional hidden))
238 (:print-function print-class-sort-object))
239 )
240
241 (eval-when (:execute :load-toplevel)
242 (setf (get 'class-sort :type-predicate) (symbol-function 'class-sort-p))
243 (setf (symbol-function 'is-class-sort) (symbol-function 'class-sort-p))
244 (setf (get 'class-sort :print) 'print-sort-internal))
245
246 (defun print-class-sort-object (obj stream &rest ignore)
247 (print-sort-object obj stream ignore))
248
249 ;;; Record sort ________________
250
251 (defstruct (record-sort (:include crsort (-type 'record-sort))
252 (:constructor make-record-sort)
253 (:constructor record-sort* (id &optional hidden))
254 (:print-function print-record-sort-object)
255 (:copier nil))
256 )
257
258 (eval-when (:execute :load-toplevel)
259 (setf (get 'record-sort :type-predicate)
260 (symbol-function 'record-sort-p))
261 (setf (get 'record-sort :print) 'print-sort-internal)
262 (setf (symbol-function 'is-record-sort)
263 (symbol-function 'record-sort-p)))
264
265 (defun print-record-sort-object (obj stream &rest ignore)
266 (print-sort-object obj stream ignore))
267
268 ;;; Primitive structure accessors ----------------------------------------------
269
270 ;;; (defmacro crsort-slots (_s) `(%crsort-slots ,_s))
271 ;;; (defmacro crsort-id (_s) `(crsort-idconstr ,_s))
272 ;;; (defmacro crsort-constr (_s) `(crsort-constr ,_s))
273 (defmacro crsort-constr-method (_s) `(crsort-constr ,_s)) ; synonym
274 (defmacro crsort-id-method (_s) `(car (crsort-idconstr ,_s)))
275 (defmacro crsort-id-variable (_s) `(cdr (crsort-idconstr ,_s)))
276 ;;; (defmacro crsort-maker (_s) `(%crsort-maker ,_s))
277 (defmacro crsort-make-1 (_s) `(car (crsort-maker ,_s)))
278 (defmacro crsort-make-2 (_s) `(cadr (crsort-maker ,_s)))
279 ;;; (defmacro crsort-copy (_s) `(crsort-copy ,_s))
280 (defmacro crsort-is-a-copy (_s) `(crsort-copy ,_s))
281
282 ;;; the following two are only for class sort
283 (defmacro crsort-make-3 (_s) `(caddr (crsort-maker ,_s)))
284 (defmacro crsort-make-4 (_s) `(cadddr (crsort-maker ,_s)))
285
286 ;;; Primitive Constructors -----------------------------------------------------
287
288 (defun create-cr-sort (p-type id module constructor inhabited slots hidden)
289 (declare (type symbol p-type id)
290 (type module module)
291 (type t constructor)
292 (type (or null t) inhabited hidden)
293 (type list slots)
294 (values crsort))
295 (let ((s (if (eq p-type 'class-sort)
296 (class-sort* id)
297 (record-sort* id))))
298 (setf (sort-module s) module
299 (sort-constructor s) constructor
300 (sort-inhabited s) inhabited
301 (crsort-slots s) slots
302 (crsort-hidden s) hidden)
303 (setf (crsort-maker s) (if (eq p-type 'class-sort)
304 (list nil nil nil nil)
305 (list nil nil)))
306 (set-object-context-module s module)
307 s))
308
309 (defun new-record-sort (id module &optional hidden)
310 (declare (type symbol id)
311 (type module module)
312 (type (or null t) hidden)
313 (values crsort))
314 (create-cr-sort 'record-sort ; type
315 id ; id
316 module ;
317 nil ; constructor
318 nil ; inhabited
319 nil ; slots
320 hidden))
321
322 (defun new-class-sort (id module &optional hidden)
323 (declare (type symbol id)
324 (type module module)
325 (type (or null t) hidden)
326 (values crsort))
327 (create-cr-sort 'class-sort
328 id
329 module
330 nil
331 nil
332 nil
333 hidden))
334
335 ;;; Type Predicates ------------------------------------------------------------
336
337 ;;; (defmacro crsort-p (_s)
338 ;;; `(and (chaos-object? ,_s) (memq (object-type ,_s) '(record-sort
339 ;;; class-sort))))
340 ;;; (defmacro record-sort-p (_s) `(is-record-sort ,_s))
341 ;;; (defmacro class-sort-p (_s) `(is-class-sort ,_s))
342
343 ;;; Accessors For Slot Informations --------------------------------------------
344
345 (defmacro find-slot-info (slot-name sort) ` (assoc ,slot-name (crsort-slots ,sort)
346 :test #'equal))
347 (defmacro cr-slot-name (_slot-info) `(car ,_slot-info))
348 (defmacro cr-slot-sort (_slot-info) `(cadr ,_slot-info))
349 (defmacro cr-slot-default (_slot-info) `(caddr ,_slot-info))
350 (defmacro cr-slot-attribute-id (_slot-info) `(cadddr ,_slot-info))
351 (defmacro cr-slot-attribute-id-method (_slot-info) `(car (cadddr ,_slot-info)))
352 (defmacro cr-slot-attribute-id-variable (_slot-info) `(cdr (cadddr ,_slot-info)))
353 (defmacro cr-slot-reader (_slot-info) `(nth 4 ,_slot-info))
354 (defmacro cr-slot-writer (_slot-info) `(nth 5 ,_slot-info))
355
356 ;;; getting infos via slot-name.
357
358 (defmacro get-slot-sort (_slot-name _s)
359 `(cr-slot-sort (find-slot-info ,_slot-name ,_s)))
360 (defmacro get-slot-default (_slot-name _s)
361 `(cr-slot-default (find-slot-info ,_slot-name ,_s)))
362 (defmacro get-attribute-id (_slot-name _s)
363 `(cr-slot-attribute-id (find-slot-info ,_slot-name ,_s)))
364 (defmacro get-attribute-id-method (_slot-name _s)
365 `(cr-slot-attribute-id-method (find-slot-info ,_slot-name ,_s)))
366 (defmacro get-attribute-id-variable (_slot-name _s)
367 `(cr-slot-attribute-id-variable (find-slot-info ,_slot-name ,_s)))
368 (defmacro get-slot-reader (_slot-name _s)
369 `(cr-slot-reader (find-slot-info ,_slot-name ,_s)))
370 (defmacro get-slot-writer (_slot-name _s)
371 `(cr-slot-writer (find-slot-info ,_slot-name ,_s)))
372185
373186 ;;; *****
374187 ;;; BSORT____________________
403216 (type module module)
404217 (type list info)
405218 (type (or null t) hidden)
406 (values bsort))
219 (optimize (speed 3) (safety 0)))
407220 (let ((bs (bsort* id hidden)))
408221 (setf (sort-module bs) module
409222 (bsort-info bs) info)
436249
437250 (defun get-builtin-sort-named (sort-name)
438251 (declare (type symbol sort-name)
439 (values (or null bsort)))
252 (optimize (speed 3) (safety 0)))
440253 (find-in-assoc-table *builtin-sort-table* sort-name #'eq))
441254
442255 (defun register-builtin-sort (sort)
443256 (declare (type bsort sort)
444 (values t))
257 (optimize (speed 3) (safety 0)))
445258 (add-to-assoc-table *builtin-sort-table* (sort-id sort) sort #'eq))
446259
447260 (defun clear-builtin-sorts ()
486299 (type (or null module) module)
487300 (type list and-components)
488301 (type (or null t) hidden)
489 (values and-sort))
302 (optimize (speed 3) (safety 0)))
490303 (let ((as (and-sort* id hidden)))
491304 (setf (sort-module as) module
492305 (and-sort-components as) and-components)
493306 (set-object-context-module as module)
494307 as))
495
496 ;;; Predicates -----------------------------------------------------------------
497
498 ;;; (defmacro and-sort-p (_object) `(is-and-sort ,_object))
499
500 #|| not used
501 (defmacro is-and-sort-term (term)
502 (once-only (term)
503 `(and (term? ,term) (and-sort-p (term-body ,term)))))
504 ||#
505308
506309 ;;; *******
507310 ;;; OR-SORT__________________
528331 (defun print-or-sort-object (obj stream &rest ignore)
529332 (print-sort-object obj stream ignore))
530333
531 ;;; Primitve accessors ---------------------------------------------------------
532
533 ;;; (defmacro or-sort-components (_or-sort)
534 ;;; `(%or-sort-components ,_or-sort))
535
536334 ;;; Primitve constructor -------------------------------------------------------
537335
538336 (defun new-or-sort (id &optional module or-components hidden)
540338 (type (or null module) module)
541339 (type list or-components)
542340 (type (or null t) hidden)
543 (values or-sort))
341 (optimize (speed 3) (safety 0)))
544342 (let ((os (or-sort* id hidden)))
545343 (setf (sort-module os) module
546344 (or-sort-components os) or-components)
547345 (set-object-context-module os module)
548346 os))
549
550 ;;; Predicate ------------------------------------------------------------------
551
552 ;;; (defmacro or-sort-p (_object) `(is-or-sort ,_object))
553347
554348 ;;; ********
555349 ;;; ERR-SORT_________________
575369 (defun print-err-sort-object (obj stream &rest ignore)
576370 (print-sort-object obj stream ignore))
577371
578 ;;; Primitve accessors ---------------------------------------------------------
579
580 ;;; (defmacro err-sort-components (_err-sort)
581 ;;; `(%err-sort-components ,_err-sort))
582
583 ;;; (defmacro err-sort-subsorts (_err-sort)
584 ;;; `(err-sort-lowers ,_err-sort))
585
586372 ;;; Primitive Constructor ------------------------------------------------------
587373
588374 (defun new-err-sort (id &optional module components lowers hidden)
590376 (type (or null module) module)
591377 (type list components lowers)
592378 (type (or null t) hidden)
593 (values err-sort))
379 (optimize (speed 3) (safety 0)))
594380 (let ((es (err-sort* id hidden)))
595381 (setf (sort-module es) module
596382 (err-sort-components es) components
597383 (err-sort-lowers es) lowers)
598384 (set-object-context-module es module)
599385 es))
600
601 ;;; Predicates ----------------------------------------------------------------
602
603 ;;; (defmacro err-sort-p (_object) `(is-err-sort ,_object))
604386
605387 ;;; ********************
606388 ;;; EQUALITY AMONG SORTS______________
670452
671453 (defun elim-sys-sorts-from-relation (sl)
672454 (declare (type list sl)
673 (values list))
455 (values list)
456 (optimize (speed 3) (safety 0)))
674457 (macrolet ((pure? (_sl)
675458 ` (dolist (_s ,_sl t)
676459 (when (sort-is-for-regularity? _s) (return nil))))
713496
714497 (defun copy-sort-order (sort-order)
715498 (declare (type sort-order sort-order)
499 (optimize (speed 3) (safety 0))
716500 (values sort-order))
717501 (let ((new-order (allocate-sort-order)))
718502 (maphash #'(lambda (s sl)
722506
723507 (defun get-all-sorts (sort-order)
724508 (declare (type sort-order sort-order)
725 (values list))
509 (optimize (speed 3) (safety 0)))
726510 (let ((res nil))
727511 (maphash #'(lambda (ss sl)
728512 (declare (ignore sl))
775559
776560 (defun the-err-sort (sort &optional (sort-order *current-sort-order*))
777561 (declare (type sort* sort)
778 (type sort-order sort-order))
562 (type sort-order sort-order)
563 (optimize (speed 3) (safety 0)))
779564 (cond ((sort= sort *universal-sort*) sort)
780565 ((sort= sort *huniversal-sort*) sort)
781566 ((sort= sort *cosmos*) sort)
799584 (defun sort< (s1 s2 &optional (sort-order *current-sort-order*))
800585 (declare (type sort* s1 s2)
801586 (type sort-order sort-order)
587 (optimize (speed 3) (safety 0))
802588 (values (or null t)))
803589 (and (not (sort= s1 s2))
804590 (or (sort= s2 *cosmos*)
840626 (memq ,s2 (supersorts ,s1 ,sort-order)))))))))))
841627
842628 ;;; function version
629 (declaim (inline sort<*))
843630 (defun sort<* (s1 s2 &optional (sort-order *current-sort-order*))
844631 (declare (type sort* s1 s2)
845632 (type sort-order sort-order)
846 (values (or null t)))
633 (optimize (speed 3) (safety 0)))
847634 (sort< s1 s2 sort-order))
848635
849636 ;;; SORT<= sort1 sort2 sort-order
855642 (sort< ,_s1 ,_s2 ,_sort-order))))
856643
857644 ;;; it's function version.
645 (declaim (inline sort<=*))
858646 (defun sort<=* (s1 s2 &optional (sort-order *current-sort-order*))
859647 (declare (type sort* s1 s2)
860648 (type sort-order sort-order)
649 (optimize (speed 3) (safety 0))
861650 (values (or null t)))
862651 (or (sort= s1 s2) (sort< s1 s2 sort-order)))
863652
879668 ;;; returns t iff each elements of sort-list1 is a subsort of
880669 ;;; corresponding sort of sort-list2.
881670 ;;;
671 (declaim (inline sort-list<=))
882672 (defun sort-list<= (lst1 lst2 &optional (so *current-sort-order*))
883673 (declare (type list lst1 lst2)
884674 (type sort-order so)
675 (optimize (speed 3) (safety 0))
885676 (values (or null t)))
886677 (loop (when (null lst1)(return (null lst2)))
887678 (when (null lst2)(return (null lst1)))
890681 (setq lst1 (cdr lst1))
891682 (setq lst2 (cdr lst2))))
892683
684 (declaim (inline sort-list<=-any))
893685 (defun sort-list<=-any (lst1 lst2 &optional (so *current-sort-order*))
894686 (declare (type list lst1 lst2)
895687 (type sort-order so)
688 (optimize (speed 3) (safety 0))
896689 (values (or null t)))
897690 (loop (when (null lst1)(return (null lst2)))
898691 (when (null lst2)(return (null lst1)))
907700 ;;; returns t iff each elements of sort-list1 is a proper subsort of
908701 ;;; corresponding sort of sort-list2.
909702 ;;;
703 (declaim (inline sort-list<))
910704 (defun sort-list< (lst1 lst2 &optional (so *current-sort-order*))
911705 (declare (type list lst1 lst2)
912706 (type sort-order so)
707 (optimize (speed 3) (safety 0))
913708 (values (or null t)))
914709 (loop (when (null lst1)(return (null lst2)))
915710 (when (null lst2)(return (null lst1)))
929724 (defun add-sort-to-order (sort &optional (sort-order *current-sort-order*))
930725 (declare (type sort* sort)
931726 (type sort-order sort-order)
932 (values t))
727 (optimize (speed 3) (safety 0)))
933728 (let ((ent (get-sort-relation sort sort-order)))
934729 (unless ent
935730 (add-relation-to-order (make-sort-relation sort nil nil) sort-order))))
942737 (sort-order *current-sort-order*))
943738 (declare (type list relation)
944739 (type sort-order sort-order)
945 (values list))
740 (optimize (speed 3) (safety 0)))
946741 (macrolet ((pushnew-relation (__?rel __?res)
947742 ` (pushnew ,__?rel ,__?res :test #'eq)))
948743 (let ((res nil)
960755 &optional (sort-order *current-sort-order*))
961756 (declare (type list sort-relation)
962757 (type sort-order sort-order)
758 (optimize (speed 3) (safety 0))
963759 (values sort-order))
964760 (let* ((sort (sort-relation-sort sort-relation))
965761 (subs (_subsorts sort-relation))
1012808 (defun max-minorants (sort-set order)
1013809 (declare (type sort-order order)
1014810 (type list sort-set)
811 (optimize (speed 3) (safety 0))
1015812 (values list))
1016813 (labels ((inter-lower (set)
1017814 (declare (type list set)
1039836 (defun maximal-sorts (sorts order)
1040837 (declare (type list sorts)
1041838 (type sort-order order)
839 (optimize (speed 3) (safety 0))
1042840 (values list))
1043841 (let ((maximal nil))
1044842 (dolist (s sorts maximal)
1048846 (defun maximal-sorts-no-error (sorts order) ; version avoiding error sorts.
1049847 (declare (type list sorts)
1050848 (type sort-order order)
849 (optimize (speed 3) (safety 0))
1051850 (values list))
1052851 (let ((maximal nil))
1053852 (dolist (s sorts maximal)
1061860 (defun minimal-sorts (sorts order)
1062861 (declare (type list sorts)
1063862 (type sort-order order)
863 (optimize (speed 3) (safety 0))
1064864 (values list))
1065865 (let ((minimal nil))
1066866 (declare (type list minimal))
1076876 ;;;
1077877 (defun meet-of-sorts (sort1 sort2 &optional (sort-order *current-sort-order*))
1078878 (declare (type sort* sort1 sort2)
1079 (type sort-order sort-order))
879 (type sort-order sort-order)
880 (optimize (speed 3) (safety 0)))
1080881 (cond ((sort<= sort1 sort2) (list sort1))
1081882 ((sort< sort2 sort1 sort-order) (list sort2))
1082883 (t (maximal-sorts (intersection (subsorts sort1) (subsorts sort2))
1087888 ;;;
1088889 (defun merge-sort-relations (sl1 sl2)
1089890 (declare (type list sl1 sl2)
891 (optimize (speed 3) (safety 0))
1090892 (values list))
1091893 (unless sl1 (return-from merge-sort-relations sl2))
1092894 (dolist (sort-relation sl1)
1109911 (defun merge-sort-order (order1 order2)
1110912 (declare (type (or null sort-order) order1)
1111913 (type sort-order order2)
914 (optimize (speed 3) (safety 0))
1112915 (values sort-order))
1113916 (unless order1 (return-from merge-sort-order order2))
1114917 (maphash #'(lambda (sort sort-relation)
1131934 (defun merge-sort-order-no-extra (order1 order2)
1132935 (declare (type (or null sort-order) order1)
1133936 (type sort-order order2)
937 (optimize (speed 3) (safety 0))
1134938 (values sort-order))
1135939 (unless order1 (return-from merge-sort-order-no-extra order2))
1136940 (macrolet ((filter-out-ordinal-sorts (___sort-list)
1160964 ;;; check if sort1 and sort2 is in same sort hierarchy
1161965 ;;; *NOTE* : assume error sorts are already genrated.
1162966 ;;;
967 (declaim (inline is-in-same-connected-component))
1163968 (defun is-in-same-connected-component (s1 s2 sort-order)
1164969 (declare (type sort* s1 s2)
1165970 (type sort-order sort-order)
971 (optimize (speed 3) (safety 0))
1166972 (values (or null t)))
1167973 (or (sort= s1 s2)
1168974 (if (or (sort= s1 *cosmos*) (sort= s2 *cosmos*))
1187993 ;;; COMPONENT-TOP : sort sort-order -> sort
1188994 ;;; returns the greatest sorts of given sort
1189995 ;;;
996 (declaim (inline component-top))
1190997 (defun component-top (sort sort-order)
1191998 (declare (type sort* sort)
1192999 (type sort-order sort-order)
1000 (optimize (speed 3) (safety 0))
11931001 (values list))
11941002 (maximal-sorts (supersorts-no-err sort sort-order) sort-order))
11951003
12011009 (defun is-in-same-connected-component* (s1 s2 so)
12021010 (declare (type sort* s1 s2)
12031011 (type sort-order so)
1012 (optimize (speed 3) (safety 0))
12041013 (values (or null t)))
12051014 (or (sort= s1 s2)
12061015 (sort= s1 *cosmos*)
12311040
12321041 ;;; HAVE-COMMON-SUBSORT : Sort Sort SortOrder -> Bool
12331042 ;;;
1043 (declaim (inline have-common-subsort))
12341044 (defun have-common-subsort (s1 s2 so)
12351045 (declare (type sort* s1 s2)
12361046 (type sort-order so)
1047 (optimize (speed 3) (safety 0))
12371048 (values (or null t)))
12381049 (let ((ss1 (subsorts s1 so))
12391050 (ss2 (subsorts s2 so)))
12431054
12441055 ;;; ALL-SORTS-IN-ORDER (&optional (sort-order *current-sort-order*))
12451056 ;;;
1057 (declaim (inline all-sorts-in-order))
12461058 (defun all-sorts-in-order (&optional (sort-order *current-sort-order*))
12471059 (declare (type sort-order sort-order)
1060 (optimize (speed 3) (safety 0))
12481061 (values list))
12491062 (let ((res nil))
12501063 (maphash #'(lambda (sort relation)
12551068
12561069 ;;; TOP-COMPONENTS sort-order
12571070 ;;;
1071 (declaim (inline top-components))
12581072 (defun top-components (&optional (sort-order *current-sort-order*))
12591073 (declare (type sort-order sort-order)
1074 (optimize (speed 3) (safety 0))
12601075 (values list))
12611076 (maximal-sorts (let ((res nil))
12621077 (maphash #'(lambda (sort relation)
12681083
12691084 ;;; BOTTOM-COMPONENTS sort-order
12701085 ;;;
1086 (declaim (inline bottom-components))
12711087 (defun bottom-components (&optional (sort-order *current-sort-order*))
12721088 (declare (type sort-order sort-order)
1089 (optimize (speed 3) (safety 0))
12731090 (values list))
12741091 (minimal-sorts (let ((res nil))
12751092 (maphash #'(lambda (sort relation)
12821099 ;;; DIRECT-SUBSORTS sort sort-order
12831100 ;;; returns the list of sorts which are direct subsorts
12841101 ;;;
1102 (declaim (inline direct-subsorts))
12851103 (defun direct-subsorts (sort &optional (sort-order *current-sort-order*))
12861104 (declare (type sort* sort)
12871105 (type sort-order sort-order)
1106 (optimize (speed 3) (safety 0))
12881107 (values list))
12891108 (maximal-sorts (subsorts sort sort-order) sort-order))
12901109
12911110 ;;; DIRECT-SUPERSORTS sort sort-order
12921111 ;;;
1112 (declaim (inline direct-supersorts))
12931113 (defun direct-supersorts (sort &optional (sort-order *current-sort-order*))
12941114 (declare (type sort*)
12951115 (type sort-order sort-order)
1116 (optimize (speed 3) (safety 0))
12961117 (values list))
12971118 (minimal-sorts (supersorts sort sort-order) sort-order))
12981119
12991120 ;;; DIRECT-SUPERSORTS-NO-ERR
13001121 ;;;
1122 (declaim (inline direct-supersorts-no-err))
13011123 (defun direct-supersorts-no-err (sort &optional (sort-order *current-sort-order*))
13021124 (declare (type sort* sort)
13031125 (type sort-order sort-order)
1126 (optimize (speed 3) (safety 0))
13041127 (values list))
13051128 (minimal-sorts (supersorts-no-err sort sort-order) sort-order))
1306
1307 #||
1308 ;;; DELETE-SORT-FROM-ORDER sort sort-order
1309 ;;; returns sort-order after eliminating sort.
1310 ;;;
1311 (defun delete-sort-from-order (sort sort-order)
1312 (remhash sort sort-order)
1313 (maphash #'(lambda (ss sort-rel)
1314 (declare (ignore ss))
1315 (setf (_subsorts sort-rel)
1316 (delete sort (_subsorts sort-rel) :test #'eq))
1317 (setf (_supersorts sort-rel)
1318 (delete sort (_supersorts sort-rel) :test #'eq)))
1319 sort-order)
1320 (update-sort-order sort-order)
1321 sort-order)
1322 ||#
13231129
13241130 ;;; SORT-RELATIONS-TRANSITIVE-CLOSURE sort-relations1 sort-relations2
13251131 ;;; sort-relations2 is destructively modified.
13261132 ;;;
1327 #||
1328 (defun sort-order-transitive-closure (previous-order new-order)
1329 (flet ((ls-union (order s ls)
1330 ;; make the union of the sorts lower than "s" with ls.
1331 (let ((sl (get-sort-relation s order)))
1332 (setf (_subsorts sl)
1333 (union (_subsorts sl) ls :test #'eq))))
1334 (gs-union (order s gs)
1335 ;; make the union of the sorts greater than "s" with gs.
1336 (let ((sl (get-sort-relation s order)))
1337 (setf (_supersorts sl)
1338 (union (_supersorts sl) gs :test #'eq)))))
1339 (let ((closure (merge-sort-order previous-order new-order)))
1340 (declare (type sort-order closure))
1341 (maphash #'(lambda (sort sort-rel)
1342 (declare (ignore sort))
1343 (let ((ls (_subsorts sort-rel))
1344 (gs (_supersorts sort-rel)))
1345 (dolist (s1 ls)
1346 (dolist (s2 gs)
1347 (declare (type sort* s2))
1348 (ls-union closure s2 (list s1))
1349 (gs-union closure s1 (list s2))))))
1350 closure)
1351 ;; generates erro sorts.
1352 (generate-err-sorts closure)
1353 closure)))
1354
1355 ||#
13561133
13571134 (defun sort-relations-transitive-closure (sl1 sl2)
13581135 (declare (type list sl1 sl2)
1136 (optimize (speed 3) (safety 0))
13591137 (values list))
13601138 (flet ((ls-union (relations s ls)
13611139 (declare (type list relations ls)
13931171
13941172 (defun sort-relations-transitive-closure1 (sl)
13951173 (declare (type list sl)
1174 (optimize (speed 3) (safety 0))
1175 (inline sort-relations-transitive-closure)
13961176 (values list))
13971177 (sort-relations-transitive-closure nil sl))
13981178
14001180 ;;;
14011181 (defun check-cyclic-sort-order (sort-order)
14021182 (declare (type sort-order sort-order)
1183 (optimize (speed 3) (safety 0))
14031184 (values t))
14041185 (maphash #'(lambda (ss sort-relation)
14051186 (when (member ss (_subsorts sort-relation) :test #'eq)
14151196 ;;;
14161197 (defun clear-err-sorts (sort-order)
14171198 (declare (type sort-order sort-order)
1199 (optimize (speed 3) (safety 0))
14181200 (values t))
14191201 (maphash #'(lambda (s sl)
14201202 (declare (ignore s))
14261208 ;;;
14271209 (defun get-kinds (sort-order)
14281210 (declare (type sort-order sort-order)
1211 (optimize (speed 3) (safety 0))
14291212 (values list))
14301213 (let ((res nil))
14311214 (maphash #'(lambda (s sl)
14501233 ;;;
14511234 (defun get-err-sorts (sort-order)
14521235 (declare (type sort-order sort-order)
1236 (optimize (speed 3) (safety 0))
14531237 (values list))
14541238 (let ((res nil))
14551239 (maphash #'(lambda (s sl)
14641248 (defun get-family (err-sort so)
14651249 (declare (type err-sort err-sort)
14661250 (type sort-order so)
1251 (optimize (speed 3) (safety 0))
14671252 (values list))
14681253 (let ((res nil))
14691254 (maphash #'(lambda (s sl)
+0
-52
chaos/term-parser/parse-engine.lisp less more
17171717 (set-if-then-else-sort result))
17181718 result))))
17191719
1720 (defun replace-class-id-with-var (cr-sort arg-list)
1721 (declare (type sort* cr-sort)
1722 (type list arg-list))
1723 (let ((class-id (second arg-list))
1724 (id-var nil))
1725 (unless (term-is-variable? class-id)
1726 (setf id-var (crsort-id-variable cr-sort))
1727 (unless id-var
1728 (with-output-panic-message ()
1729 (format t "could not find Class id variable for class ~s"
1730 (sort-id cr-sort))
1731 ;; (break)
1732 (chaos-error 'panic)))
1733 (if *parsing-axiom-lhs*
1734 (pushnew id-var *lhs-attrid-vars*)
1735 (unless (memq id-var *lhs-attrid-vars*)
1736 (return-from replace-class-id-with-var nil)))
1737 ;;
1738 (setf (second arg-list) id-var))
1739 arg-list))
1740
1741 (defun replace-attr-id-with-var (cr-sort sv-pair)
1742 (declare (type sort* cr-sort)
1743 (type term sv-pair))
1744 (let ((attr-id (term-arg-1 sv-pair))
1745 id-var)
1746 (unless (term-is-variable? attr-id)
1747 (setf id-var (get-attribute-id-variable
1748 (car (method-symbol (term-head attr-id)))
1749 cr-sort))
1750 (unless id-var
1751 (with-output-panic-message ()
1752 (format t "could not find id variable for slot ~a of sort ~a"
1753 (car (method-symbol (term-head attr-id)))
1754 (sort-id cr-sort))
1755 (print-next)
1756 (princ "id term = ")
1757 (term-print attr-id)
1758 (print-next)
1759 (princ " sv pair = ")
1760 (print-chaos-object sv-pair)
1761 ;; (break)
1762 (chaos-error 'panic)
1763 ))
1764 (if *parsing-axiom-lhs*
1765 (pushnew id-var *lhs-attrid-vars*)
1766 (unless (memq id-var *lhs-attrid-vars*)
1767 (return-from replace-attr-id-with-var nil)))
1768 ;;
1769 (setf (term-arg-1 sv-pair) id-var))
1770 sv-pair))
1771
17721720 ;;; op are-argumentsorts-correct :
17731721 ;;; Operator
17741722 ;;; LIST[ Sort ] -- possibly empty (cf. constants)