diff --git a/changelog b/changelog index cab2e96..0685902 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +20090922 tpd src/axiom-website/patches.html 20090922.01.tpd.patch +20090922 tpd src/interp/cattable.lisp cleanup 20090915 tpd src/axiom-website/patches.html 20090915.03.tpd.patch 20090915 tpd Makefile stop making bootdir 20090915 tpd src/axiom-website/patches.html 20090915.02.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 4431c9b..64dea2d 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -2010,5 +2010,7 @@ src/interp/i-funsel.lisp refactored
src/interp/buildom.lisp cleanup
20090915.03.tpd.patch Makefile stop making bootdir
+20090922.01.tpd.patch +src/interp/cattable.lisp cleanup
diff --git a/src/interp/cattable.lisp.pamphlet b/src/interp/cattable.lisp.pamphlet index a57001e..b42bdec 100644 --- a/src/interp/cattable.lisp.pamphlet +++ b/src/interp/cattable.lisp.pamphlet @@ -13,42 +13,39 @@ (IN-PACKAGE "BOOT" ) -;hasCat(domainOrCatName,catName) == - -; catName='Object or catName='Type -- every domain is a Type (Object) -; or GETDATABASE([domainOrCatName,:catName],'HASCATEGORY) - (DEFUN |hasCat| (|domainOrCatName| |catName|) - (OR (BOOT-EQUAL |catName| (QUOTE |Object|)) - (BOOT-EQUAL |catName| (QUOTE |Type|)) - (GETDATABASE (CONS |domainOrCatName| |catName|) (QUOTE HASCATEGORY)))) + (OR (BOOT-EQUAL |catName| '|Object|) (BOOT-EQUAL |catName| '|Type|) + (GETDATABASE (CONS |domainOrCatName| |catName|) 'HASCATEGORY))) ;showCategoryTable con == ; [[b,:val] for (key :=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_* ; | a = con and (val := HGET(_*HASCATEGORY_-HASH_*,key))] (DEFUN |showCategoryTable| (|con|) - (PROG (|a| |b| |val|) - (RETURN - (SEQ - (PROG (#0=#:G166069) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166076 (HKEYS *HASCATEGORY-HASH*) (CDR #1#)) (|key| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |key| (CAR #1#)) NIL) - (PROGN - (PROGN - (SPADLET |a| (CAR |key|)) - (SPADLET |b| (CDR |key|)) |key|) - NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (COND - ((AND (BOOT-EQUAL |a| |con|) - (SPADLET |val| (HGET *HASCATEGORY-HASH* |key|))) - (SETQ #0# (CONS (CONS |b| |val|) #0#))))))))))))) + (PROG (|a| |b| |val|) + (declare (special *HASCATEGORY-HASH*)) + (RETURN + (SEQ (PROG (G166069) + (SPADLET G166069 NIL) + (RETURN + (DO ((G166076 (HKEYS *HASCATEGORY-HASH*) + (CDR G166076)) + (|key| NIL)) + ((OR (ATOM G166076) + (PROGN (SETQ |key| (CAR G166076)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR |key|)) + (SPADLET |b| (CDR |key|)) + |key|) + NIL)) + (NREVERSE0 G166069)) + (SEQ (EXIT (COND + ((AND (BOOT-EQUAL |a| |con|) + (SPADLET |val| + (HGET *HASCATEGORY-HASH* |key|))) + (SETQ G166069 + (CONS (CONS |b| |val|) G166069))))))))))))) ;displayCategoryTable(:options) == ; conList := IFCAR options @@ -59,39 +56,42 @@ ; sayMSG [:bright id,'"extends:"] ; PRINT HGET($ct,id) -(DEFUN |displayCategoryTable| (&REST #0=#:G166124 &AUX |options|) - (DSETQ |options| #0#) - (PROG (|conList| |a| |b|) - (RETURN - (SEQ - (PROGN - (SPADLET |conList| (IFCAR |options|)) - (SETQ |$ct| (MAKE-HASHTABLE (QUOTE ID))) - (DO ((#1=#:G166099 (HKEYS *HASCATEGORY-HASH*) (CDR #1#)) (|key| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |key| (CAR #1#)) NIL) - (PROGN - (PROGN - (SPADLET |a| (CAR |key|)) - (SPADLET |b| (CDR |key|)) - |key|) - NIL)) - NIL) - (SEQ - (EXIT - (HPUT |$ct| |a| - (CONS - (CONS |b| (HGET *HASCATEGORY-HASH* |key|)) - (HGET |$ct| |a|)))))) - (DO ((#2=#:G166112 (HKEYS |$ct|) (CDR #2#)) (|id| NIL)) - ((OR (ATOM #2#) (PROGN (SETQ |id| (CAR #2#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((OR (NULL |conList|) (MEMQ |id| |conList|)) - (PROGN - (|sayMSG| (APPEND (|bright| |id|) (CONS "extends:" NIL))) - (PRINT (HGET |$ct| |id|))))))))))))) +(DEFUN |displayCategoryTable| (&REST G166124 &AUX |options|) + (DSETQ |options| G166124) + (PROG (|conList| |a| |b|) + (declare (special |$ct| *HASCATEGORY-HASH*)) + (RETURN + (SEQ (PROGN + (SPADLET |conList| (IFCAR |options|)) + (SETQ |$ct| (MAKE-HASHTABLE 'ID)) + (DO ((G166099 (HKEYS *HASCATEGORY-HASH*) + (CDR G166099)) + (|key| NIL)) + ((OR (ATOM G166099) + (PROGN (SETQ |key| (CAR G166099)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR |key|)) + (SPADLET |b| (CDR |key|)) + |key|) + NIL)) + NIL) + (SEQ (EXIT (HPUT |$ct| |a| + (CONS (CONS |b| + (HGET *HASCATEGORY-HASH* |key|)) + (HGET |$ct| |a|)))))) + (DO ((G166112 (HKEYS |$ct|) (CDR G166112)) (|id| NIL)) + ((OR (ATOM G166112) + (PROGN (SETQ |id| (CAR G166112)) NIL)) + NIL) + (SEQ (EXIT (COND + ((OR (NULL |conList|) + (MEMQ |id| |conList|)) + (PROGN + (|sayMSG| + (APPEND (|bright| |id|) + (CONS (MAKESTRING "extends:") NIL))) + (PRINT (HGET |$ct| |id|))))))))))))) ;genCategoryTable() == ; SETQ(_*ANCESTORS_-HASH_*, MAKE_-HASHTABLE 'ID) @@ -115,79 +115,110 @@ ; compressHashTable _*HASCATEGORY_-HASH_* (DEFUN |genCategoryTable| () - (PROG (|domainList| |catl| |specialDs| |domainTable| |id| |entry| |a| |b|) - (RETURN - (SEQ - (PROGN - (SETQ *ANCESTORS-HASH* (MAKE-HASHTABLE (QUOTE ID))) - (SETQ *HASCATEGORY-HASH* (MAKE-HASHTABLE (QUOTE UEQUAL))) - (|genTempCategoryTable|) - (SPADLET |domainList| - (PROG (#0=#:G166139) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166145 (|allConstructors|) (CDR #1#)) (|con| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |con| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL (GETDATABASE |con| (QUOTE CONSTRUCTORKIND)) - (QUOTE |domain|)) - (SETQ #0# (CONS |con| #0#)))))))))) - (SPADLET |domainTable| - (PROG (#2=#:G166156) - (SPADLET #2# NIL) - (RETURN - (DO ((#3=#:G166162 |domainList| (CDR #3#)) (|con| NIL)) - ((OR (ATOM #3#) - (PROGN (SETQ |con| (CAR #3#)) NIL)) - (NREVERSE0 #2#)) - (SEQ - (EXIT - (COND - ((SPADLET |catl| (GETDATABASE |con| (QUOTE CONSTRUCTORCATEGORY))) - (SETQ #2# - (CONS - (|addDomainToTable| |con| (|getConstrCat| |catl|)) - #2#)))))))))) - (SPADLET |specialDs| - (SETDIFFERENCE |$nonLisplibDomains| |$noCategoryDomains|)) - (SPADLET |domainTable| - (APPEND - (PROG (#4=#:G166172) - (SPADLET #4# NIL) - (RETURN - (DO ((#5=#:G166177 |specialDs| (CDR #5#)) (|id| NIL)) - ((OR (ATOM #5#) - (PROGN (SETQ |id| (CAR #5#)) NIL)) - (NREVERSE0 #4#)) - (SEQ - (EXIT - (SETQ #4# - (CONS - (|addDomainToTable| |id| - (|getConstrCat| (ELT (|eval| (CONS |id| NIL)) 3))) - #4#))))))) - |domainTable|)) - (DO ((#6=#:G166190 |domainTable| (CDR #6#)) (#7=#:G166129 NIL)) - ((OR (ATOM #6#) (PROGN (SETQ #7# (CAR #6#)) NIL) (PROGN (PROGN (SPADLET |id| (CAR #7#)) (SPADLET |entry| (CDR #7#)) #7#) NIL)) NIL) - (SEQ - (EXIT - (DO ((#8=#:G166201 (|encodeCategoryAlist| |id| |entry|) (CDR #8#)) - (#9=#:G166125 NIL)) - ((OR (ATOM #8#) - (PROGN (SETQ #9# (CAR #8#)) NIL) - (PROGN - (PROGN (SPADLET |a| (CAR #9#)) (SPADLET |b| (CDR #9#)) #9#) - NIL)) - NIL) - (SEQ (EXIT (HPUT *HASCATEGORY-HASH* (CONS |id| |a|) |b|))))))) - (|simpTempCategoryTable|) - (|compressHashTable| *ANCESTORS-HASH*) - (|simpCategoryTable|) - (|compressHashTable| *HASCATEGORY-HASH*)))))) + (PROG (|domainList| |catl| |specialDs| |domainTable| |id| |entry| |a| |b|) + (declare (special |$noCategoryDomains| |$nonLisplibDomains| + *ANCESTORS-HASH* *HASCATEGORY-HASH*)) + (RETURN + (SEQ (PROGN + (SETQ *ANCESTORS-HASH* (MAKE-HASHTABLE 'ID)) + (SETQ *HASCATEGORY-HASH* (MAKE-HASHTABLE 'UEQUAL)) + (|genTempCategoryTable|) + (SPADLET |domainList| + (PROG (G166139) + (SPADLET G166139 NIL) + (RETURN + (DO ((G166145 (|allConstructors|) + (CDR G166145)) + (|con| NIL)) + ((OR (ATOM G166145) + (PROGN + (SETQ |con| (CAR G166145)) + NIL)) + (NREVERSE0 G166139)) + (SEQ (EXIT (COND + ((BOOT-EQUAL + (GETDATABASE |con| + 'CONSTRUCTORKIND) + '|domain|) + (SETQ G166139 + (CONS |con| G166139)))))))))) + (SPADLET |domainTable| + (PROG (G166156) + (SPADLET G166156 NIL) + (RETURN + (DO ((G166162 |domainList| (CDR G166162)) + (|con| NIL)) + ((OR (ATOM G166162) + (PROGN + (SETQ |con| (CAR G166162)) + NIL)) + (NREVERSE0 G166156)) + (SEQ (EXIT (COND + ((SPADLET |catl| + (GETDATABASE |con| + 'CONSTRUCTORCATEGORY)) + (SETQ G166156 + (CONS + (|addDomainToTable| |con| + (|getConstrCat| |catl|)) + G166156)))))))))) + (SPADLET |specialDs| + (SETDIFFERENCE |$nonLisplibDomains| + |$noCategoryDomains|)) + (SPADLET |domainTable| + (APPEND (PROG (G166172) + (SPADLET G166172 NIL) + (RETURN + (DO ((G166177 |specialDs| + (CDR G166177)) + (|id| NIL)) + ((OR (ATOM G166177) + (PROGN + (SETQ |id| (CAR G166177)) + NIL)) + (NREVERSE0 G166172)) + (SEQ + (EXIT + (SETQ G166172 + (CONS + (|addDomainToTable| |id| + (|getConstrCat| + (ELT (|eval| (CONS |id| NIL)) + 3))) + G166172))))))) + |domainTable|)) + (DO ((G166190 |domainTable| (CDR G166190)) + (G166129 NIL)) + ((OR (ATOM G166190) + (PROGN (SETQ G166129 (CAR G166190)) NIL) + (PROGN + (PROGN + (SPADLET |id| (CAR G166129)) + (SPADLET |entry| (CDR G166129)) + G166129) + NIL)) + NIL) + (SEQ (EXIT (DO ((G166201 + (|encodeCategoryAlist| |id| |entry|) + (CDR G166201)) + (G166125 NIL)) + ((OR (ATOM G166201) + (PROGN + (SETQ G166125 (CAR G166201)) + NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G166125)) + (SPADLET |b| (CDR G166125)) + G166125) + NIL)) + NIL) + (SEQ (EXIT (HPUT *HASCATEGORY-HASH* + (CONS |id| |a|) |b|))))))) + (|simpTempCategoryTable|) + (|compressHashTable| *ANCESTORS-HASH*) + (|simpCategoryTable|) + (|compressHashTable| *HASCATEGORY-HASH*)))))) ;simpTempCategoryTable() == ; for id in HKEYS _*ANCESTORS_-HASH_* repeat @@ -196,26 +227,32 @@ ; RPLACD(u,simpHasPred b) (DEFUN |simpTempCategoryTable| () - (PROG (|a| |b|) - (RETURN - (SEQ - (DO ((#0=#:G166235 (HKEYS *ANCESTORS-HASH*) (CDR #0#)) (|id| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |id| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (DO ((#1=#:G166247 (GETDATABASE |id| (QUOTE ANCESTORS)) (CDR #1#)) - (|u| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |u| (CAR #1#)) NIL) - (PROGN - (PROGN (SPADLET |a| (CAR |u|)) (SPADLET |b| (CDR |u|)) |u|) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (RPLACA |u| (MSUBST (QUOTE |Type|) (QUOTE |Object|) |a|)) - (RPLACD |u| (|simpHasPred| |b|))))))))))))) + (PROG (|a| |b|) + (declare (special *ANCESTORS-HASH*)) + (RETURN + (SEQ (DO ((G166235 (HKEYS *ANCESTORS-HASH*) (CDR G166235)) + (|id| NIL)) + ((OR (ATOM G166235) + (PROGN (SETQ |id| (CAR G166235)) NIL)) + NIL) + (SEQ (EXIT (DO ((G166247 (GETDATABASE |id| 'ANCESTORS) + (CDR G166247)) + (|u| NIL)) + ((OR (ATOM G166247) + (PROGN + (SETQ |u| (CAR G166247)) + NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR |u|)) + (SPADLET |b| (CDR |u|)) + |u|) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (RPLACA |u| + (MSUBST '|Type| '|Object| |a|)) + (RPLACD |u| (|simpHasPred| |b|))))))))))))) ;simpCategoryTable() == main where ; main == @@ -228,41 +265,59 @@ ; HPUT(_*HASCATEGORY_-HASH_*,key,change) (DEFUN |simpCategoryTable| () - (PROG (|entry| |x| |pred| |npred| |change|) - (RETURN - (SEQ - (DO ((#0=#:G166277 (HKEYS *HASCATEGORY-HASH*) (CDR #0#)) (|key| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |key| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |entry| (HGET *HASCATEGORY-HASH* |key|)) - (COND - ((NULL |entry|) (HREM *HASCATEGORY-HASH* |key|)) - ((QUOTE T) - (SPADLET |change| - (COND - ((ATOM (|opOf| |entry|)) (|simpHasPred| |entry|)) - ((QUOTE T) - (PROG (#1=#:G166289) - (SPADLET #1# NIL) - (RETURN - (DO ((#2=#:G166296 |entry| (CDR #2#)) (#3=#:G166259 NIL)) - ((OR (ATOM #2#) - (PROGN (SETQ #3# (CAR #2#)) NIL) - (PROGN - (PROGN - (SPADLET |x| (CAR #3#)) - (SPADLET |pred| (CDR #3#)) - #3#) - NIL)) - (NREVERSE0 #1#)) - (SEQ - (EXIT - (COND - ((SPADLET |npred| (|simpHasPred| |pred|)) - (SETQ #1# (CONS (CONS |x| |npred|) #1#)))))))))))) - (HPUT *HASCATEGORY-HASH* |key| |change|))))))))))) + (PROG (|entry| |x| |pred| |npred| |change|) + (declare (special *HASCATEGORY-HASH*)) + (RETURN + (SEQ (DO ((G166277 (HKEYS *HASCATEGORY-HASH*) (CDR G166277)) + (|key| NIL)) + ((OR (ATOM G166277) + (PROGN (SETQ |key| (CAR G166277)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |entry| + (HGET *HASCATEGORY-HASH* |key|)) + (COND + ((NULL |entry|) + (HREM *HASCATEGORY-HASH* |key|)) + ('T + (SPADLET |change| + (COND + ((ATOM (|opOf| |entry|)) + (|simpHasPred| |entry|)) + ('T + (PROG (G166289) + (SPADLET G166289 NIL) + (RETURN + (DO + ((G166296 |entry| + (CDR G166296)) + (G166259 NIL)) + ((OR (ATOM G166296) + (PROGN + (SETQ G166259 + (CAR G166296)) + NIL) + (PROGN + (PROGN + (SPADLET |x| + (CAR G166259)) + (SPADLET |pred| + (CDR G166259)) + G166259) + NIL)) + (NREVERSE0 G166289)) + (SEQ + (EXIT + (COND + ((SPADLET |npred| + (|simpHasPred| + |pred|)) + (SETQ G166289 + (CONS + (CONS |x| + |npred|) + G166289)))))))))))) + (HPUT *HASCATEGORY-HASH* |key| |change|))))))))))) ;simpHasPred(pred,:options) == main where ; main == @@ -306,181 +361,194 @@ ; x (DEFUN |simpHasPred,eval| (|pred|) - (PROG (|d| |cat| |x| |y| |args| |p| |npred|) - (RETURN - (SEQ - (PROGN - (SPADLET |d| (CADR |pred|)) - (SPADLET |cat| (CADDR |pred|)) - |pred| - (SEQ - (SPADLET |x| (|hasCat| (CAR |d|) (CAR |cat|))) - (IF (SPADLET |y| (CDR |cat|)) - (EXIT - (SEQ - (IF (SPADLET |npred| - (PROG (#0=#:G166367) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166375 NIL #0#) - (#2=#:G166376 |x| (CDR #2#)) - (#3=#:G166350 NIL)) - ((OR #1# - (ATOM #2#) - (PROGN (SETQ #3# (CAR #2#)) NIL) - (PROGN - (PROGN - (SPADLET |args| (CAR #3#)) - (SPADLET |p| (CDR #3#)) - #3#) - NIL)) - #0#) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |y| |args|) (SETQ #0# (OR #0# |p|)))))))))) - (EXIT (|simpHasPred,simp| |npred|))) - (EXIT NIL)))) - (EXIT |x|))))))) + (PROG (|d| |cat| |x| |y| |args| |p| |npred|) + (RETURN + (SEQ (PROGN + (SPADLET |d| (CADR |pred|)) + (SPADLET |cat| (CADDR |pred|)) + |pred| + (SEQ (SPADLET |x| (|hasCat| (CAR |d|) (CAR |cat|))) + (IF (SPADLET |y| (CDR |cat|)) + (EXIT (SEQ (IF (SPADLET |npred| + (PROG (G166367) + (SPADLET G166367 NIL) + (RETURN + (DO + ((G166375 NIL G166367) + (G166376 |x| + (CDR G166376)) + (G166350 NIL)) + ((OR G166375 + (ATOM G166376) + (PROGN + (SETQ G166350 + (CAR G166376)) + NIL) + (PROGN + (PROGN + (SPADLET |args| + (CAR G166350)) + (SPADLET |p| + (CDR G166350)) + G166350) + NIL)) + G166367) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |y| + |args|) + (SETQ G166367 + (OR G166367 |p|)))))))))) + (EXIT + (|simpHasPred,simp| |npred|))) + (EXIT NIL)))) + (EXIT |x|))))))) (DEFUN |simpHasPred,simpHas| (|pred| |a| |b|) - (PROG (|attr| |ISTMP#1| |op| |ISTMP#2| |sig| |npred|) - (RETURN - (SEQ - (IF (AND (PAIRP |b|) - (EQ (QCAR |b|) (QUOTE ATTRIBUTE)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |b|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |attr| (QCAR |ISTMP#1|)) (QUOTE T))))) - (EXIT (|simpHasAttribute| |pred| |a| |attr|))) - (IF (AND (PAIRP |b|) - (EQ (QCAR |b|) (QUOTE SIGNATURE)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |b|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |op| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |sig| (QCAR |ISTMP#2|)) - (QUOTE T))))))) - (EXIT (|simpHasSignature| |pred| |a| |op| |sig|))) - (IF (OR (IDENTP |a|) (|hasIdent| |b|)) - (EXIT |pred|)) - (SPADLET |npred| (|simpHasPred,eval| |pred|)) - (IF (OR (IDENTP |npred|) (NULL (|hasIdent| |npred|))) - (EXIT |npred|)) - (EXIT |pred|))))) + (PROG (|attr| |ISTMP#1| |op| |ISTMP#2| |sig| |npred|) + (RETURN + (SEQ (IF (AND (PAIRP |b|) (EQ (QCAR |b|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |attr| (QCAR |ISTMP#1|)) + 'T)))) + (EXIT (|simpHasAttribute| |pred| |a| |attr|))) + (IF (AND (PAIRP |b|) (EQ (QCAR |b|) 'SIGNATURE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |sig| (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT (|simpHasSignature| |pred| |a| |op| |sig|))) + (IF (OR (IDENTP |a|) (|hasIdent| |b|)) (EXIT |pred|)) + (SPADLET |npred| (|simpHasPred,eval| |pred|)) + (IF (OR (IDENTP |npred|) (NULL (|hasIdent| |npred|))) + (EXIT |npred|)) + (EXIT |pred|))))) (DEFUN |simpHasPred,simpDevaluate| (|a|) - (EVAL (MSUBST (QUOTE QUOTE) (QUOTE |devaluate|) |a|))) + (EVAL (MSUBST 'QUOTE '|devaluate| |a|))) (DEFUN |simpHasPred,simp| (|pred|) - (PROG (|r| |LETTMP#1| |op| |sig| |a| |b| |form| |u| |op1|) - (RETURN - (SEQ - (IF (AND (PAIRP |pred|) - (PROGN - (SPADLET |op| (QCAR |pred|)) - (SPADLET |r| (QCDR |pred|)) - (QUOTE T))) - (EXIT - (SEQ - (IF (BOOT-EQUAL |op| (QUOTE |has|)) - (EXIT (|simpHasPred,simpHas| |pred| (CAR |r|) (CAR (CDR |r|))))) - (IF (BOOT-EQUAL |op| (QUOTE |HasCategory|)) - (EXIT - (|simpHasPred,simp| - (CONS - (QUOTE |has|) - (CONS - (CAR |r|) - (CONS (|simpHasPred,simpDevaluate| (CADR |r|)) NIL)))))) - (IF (BOOT-EQUAL |op| (QUOTE |HasSignature|)) - (EXIT - (SEQ - (PROGN - (SPADLET |LETTMP#1| (|simpHasPred,simpDevaluate| (CADR |r|))) - (SPADLET |op| (CAR |LETTMP#1|)) - (SPADLET |sig| (CADR |LETTMP#1|)) - |LETTMP#1|) - (EXIT - (CONS - (QUOTE |has|) - (CONS - (CAR |r|) - (CONS - (CONS (QUOTE SIGNATURE) (CONS |op| (CONS |sig| NIL))) - NIL))))))) - (IF (BOOT-EQUAL |op| (QUOTE |HasAttribute|)) - (EXIT - (SEQ - (SPADLET |form| - (CONS - (QUOTE |has|) - (CONS - (SPADLET |a| (CAR |r|)) - (CONS - (CONS - (QUOTE ATTRIBUTE) - (CONS - (SPADLET |b| (|simpHasPred,simpDevaluate| (CADR |r|))) - NIL)) - NIL)))) - (EXIT (|simpHasAttribute| |form| |a| |b|))))) - (IF (MEMQ |op| (QUOTE (AND OR NOT))) - (EXIT - (SEQ - (IF - (NULL - (SPADLET |u| - (MKPF - (PROG (#0=#:G166412) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166417 |r| (CDR #1#)) (|p| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |p| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# (CONS (|simpHasPred,simp| |p|) #0#))))))) - |op|))) - (EXIT NIL)) - (IF (EQUAL |u| (QUOTE (QUOTE T))) - (EXIT (QUOTE T))) - (EXIT (|simpBool| |u|))))) - (IF (BOOT-EQUAL |op| (QUOTE |hasArgs|)) - (EXIT - (SEQ - (IF |$hasArgs| - (EXIT (BOOT-EQUAL |$hasArgs| |r|))) - (EXIT |pred|)))) - (IF (AND (NULL |r|) (BOOT-EQUAL (|opOf| |op|) (QUOTE |has|))) - (EXIT (|simpHasPred,simp| (CAR |pred|)))) - (IF (EQUAL |pred| (QUOTE (QUOTE T))) (EXIT (QUOTE T))) - (IF (SPADLET |op1| - (LASSOC |op| (QUOTE ((|and| . AND) (|or| . OR) (|not| . NOT))))) - (EXIT (|simpHasPred,simp| (CONS |op1| |r|)))) - (EXIT (|simpHasPred,simp| (CAR |pred|)))))) - (IF (|member| |pred| (QUOTE (T |etc|))) - (EXIT |pred|)) - (IF (NULL |pred|) - (EXIT NIL)) - (EXIT |pred|))))) - -(DEFUN |simpHasPred| (&REST #0=#:G166444 &AUX |options| |pred|) - (DSETQ (|pred| . |options|) #0#) - (PROG (|$hasArgs|) - (DECLARE (SPECIAL |$hasArgs|)) - (RETURN - (PROGN - (SPADLET |$hasArgs| (IFCDR (IFCAR |options|))) - (|simpHasPred,simp| |pred|))))) + (PROG (|r| |LETTMP#1| |op| |sig| |a| |b| |form| |u| |op1|) + (declare (special |$hasArgs|)) + (RETURN + (SEQ (IF (AND (PAIRP |pred|) + (PROGN + (SPADLET |op| (QCAR |pred|)) + (SPADLET |r| (QCDR |pred|)) + 'T)) + (EXIT (SEQ (IF (BOOT-EQUAL |op| '|has|) + (EXIT (|simpHasPred,simpHas| |pred| + (CAR |r|) (CAR (CDR |r|))))) + (IF (BOOT-EQUAL |op| '|HasCategory|) + (EXIT (|simpHasPred,simp| + (CONS '|has| + (CONS (CAR |r|) + (CONS + (|simpHasPred,simpDevaluate| + (CADR |r|)) + NIL)))))) + (IF (BOOT-EQUAL |op| '|HasSignature|) + (EXIT (SEQ + (PROGN + (SPADLET |LETTMP#1| + (|simpHasPred,simpDevaluate| + (CADR |r|))) + (SPADLET |op| (CAR |LETTMP#1|)) + (SPADLET |sig| + (CADR |LETTMP#1|)) + |LETTMP#1|) + (EXIT + (CONS '|has| + (CONS (CAR |r|) + (CONS + (CONS 'SIGNATURE + (CONS |op| (CONS |sig| NIL))) + NIL))))))) + (IF (BOOT-EQUAL |op| '|HasAttribute|) + (EXIT (SEQ + (SPADLET |form| + (CONS '|has| + (CONS (SPADLET |a| (CAR |r|)) + (CONS + (CONS 'ATTRIBUTE + (CONS + (SPADLET |b| + (|simpHasPred,simpDevaluate| + (CADR |r|))) + NIL)) + NIL)))) + (EXIT + (|simpHasAttribute| |form| |a| + |b|))))) + (IF (MEMQ |op| '(AND OR NOT)) + (EXIT (SEQ + (IF + (NULL + (SPADLET |u| + (MKPF + (PROG (G166412) + (SPADLET G166412 NIL) + (RETURN + (DO + ((G166417 |r| + (CDR G166417)) + (|p| NIL)) + ((OR (ATOM G166417) + (PROGN + (SETQ |p| + (CAR G166417)) + NIL)) + (NREVERSE0 G166412)) + (SEQ + (EXIT + (SETQ G166412 + (CONS + (|simpHasPred,simp| + |p|) + G166412))))))) + |op|))) + (EXIT NIL)) + (IF (EQUAL |u| ''T) (EXIT 'T)) + (EXIT (|simpBool| |u|))))) + (IF (BOOT-EQUAL |op| '|hasArgs|) + (EXIT (SEQ + (IF |$hasArgs| + (EXIT + (BOOT-EQUAL |$hasArgs| |r|))) + (EXIT |pred|)))) + (IF (AND (NULL |r|) + (BOOT-EQUAL (|opOf| |op|) '|has|)) + (EXIT (|simpHasPred,simp| (CAR |pred|)))) + (IF (EQUAL |pred| ''T) (EXIT 'T)) + (IF (SPADLET |op1| + (LASSOC |op| + '((|and| . AND) (|or| . OR) + (|not| . NOT)))) + (EXIT (|simpHasPred,simp| + (CONS |op1| |r|)))) + (EXIT (|simpHasPred,simp| (CAR |pred|)))))) + (IF (|member| |pred| '(T |etc|)) (EXIT |pred|)) + (IF (NULL |pred|) (EXIT NIL)) (EXIT |pred|))))) + +(DEFUN |simpHasPred| (&REST G166444 &AUX |options| |pred|) + (DSETQ (|pred| . |options|) G166444) + (PROG (|$hasArgs|) + (DECLARE (SPECIAL |$hasArgs|)) + (RETURN + (PROGN + (SPADLET |$hasArgs| (IFCDR (IFCAR |options|))) + (|simpHasPred,simp| |pred|))))) ;simpHasSignature(pred,conform,op,sig) == --eval w/o loading ; IDENTP conform => pred @@ -493,64 +561,77 @@ ; simpHasPred(match is [sig,.,:p] and sublisFormal(args,p) or true) (DEFUN |simpHasSignature| (|pred| |conform| |op| |sig|) - (PROG (|conname| |args| |n| |u| |candidates| |sig1| |match| |ISTMP#1| |p|) - (RETURN - (SEQ - (COND - ((IDENTP |conform|) |pred|) - ((QUOTE T) - (SPADLET |conname| (CAR |conform|)) - (SPADLET |args| (CDR |conform|)) - (SPADLET |n| (|#| |sig|)) - (SPADLET |u| - (LASSOC |op| (GETDATABASE |conname| (QUOTE OPERATIONALIST)))) - (SPADLET |candidates| - (OR - (PROG (#0=#:G166468) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166475 |u| (CDR #1#)) (|x| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |x| (CAR #1#)) NIL) - (PROGN - (PROGN (SPADLET |sig1| (CAR |x|)) |x|) - NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL (|#| |sig1|) (|#| |sig|)) - (SETQ #0# (CONS |x| #0#))))))))) - (RETURN NIL))) - (SPADLET |match| - (OR - (PROG (#2=#:G166482) - (SPADLET #2# NIL) - (RETURN - (DO ((#3=#:G166490 NIL #2#) - (#4=#:G166491 |candidates| (CDR #4#)) - (|x| NIL)) - ((OR #3# - (ATOM #4#) - (PROGN (SETQ |x| (CAR #4#)) NIL) - (PROGN (PROGN (SPADLET |sig1| (CAR |x|)) |x|) NIL)) - #2#) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |sig| (|sublisFormal| |args| |sig1|)) - (SETQ #2# (OR #2# |x|))))))))) - (RETURN NIL))) - (|simpHasPred| - (OR (AND - (PAIRP |match|) - (PROGN - (SPADLET |sig| (QCAR |match|)) - (SPADLET |ISTMP#1| (QCDR |match|)) - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET |p| (QCDR |ISTMP#1|)) (QUOTE T)))) - (|sublisFormal| |args| |p|)) - (QUOTE T))))))))) + (PROG (|conname| |args| |n| |u| |candidates| |sig1| |match| |ISTMP#1| + |p|) + (RETURN + (SEQ (COND + ((IDENTP |conform|) |pred|) + ('T (SPADLET |conname| (CAR |conform|)) + (SPADLET |args| (CDR |conform|)) + (SPADLET |n| (|#| |sig|)) + (SPADLET |u| + (LASSOC |op| + (GETDATABASE |conname| 'OPERATIONALIST))) + (SPADLET |candidates| + (OR (PROG (G166468) + (SPADLET G166468 NIL) + (RETURN + (DO ((G166475 |u| (CDR G166475)) + (|x| NIL)) + ((OR (ATOM G166475) + (PROGN + (SETQ |x| (CAR G166475)) + NIL) + (PROGN + (PROGN + (SPADLET |sig1| (CAR |x|)) + |x|) + NIL)) + (NREVERSE0 G166468)) + (SEQ (EXIT + (COND + ((BOOT-EQUAL (|#| |sig1|) + (|#| |sig|)) + (SETQ G166468 + (CONS |x| G166468))))))))) + (RETURN NIL))) + (SPADLET |match| + (OR (PROG (G166482) + (SPADLET G166482 NIL) + (RETURN + (DO ((G166490 NIL G166482) + (G166491 |candidates| + (CDR G166491)) + (|x| NIL)) + ((OR G166490 (ATOM G166491) + (PROGN + (SETQ |x| (CAR G166491)) + NIL) + (PROGN + (PROGN + (SPADLET |sig1| (CAR |x|)) + |x|) + NIL)) + G166482) + (SEQ (EXIT + (COND + ((BOOT-EQUAL |sig| + (|sublisFormal| |args| + |sig1|)) + (SETQ G166482 + (OR G166482 |x|))))))))) + (RETURN NIL))) + (|simpHasPred| + (OR (AND (PAIRP |match|) + (PROGN + (SPADLET |sig| (QCAR |match|)) + (SPADLET |ISTMP#1| (QCDR |match|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |p| (QCDR |ISTMP#1|)) + 'T))) + (|sublisFormal| |args| |p|)) + 'T)))))))) ;simpHasAttribute(pred,conform,attr) == --eval w/o loading ; IDENTP conform => pred @@ -569,36 +650,39 @@ ; simpHasPred predvec.(k - 1) (DEFUN |simpHasAttribute| (|pred| |conform| |attr|) - (PROG (|conname| |p| |infovec| |k| |predvec|) - (RETURN - (SEQ - (COND - ((IDENTP |conform|) |pred|) - ((QUOTE T) - (SPADLET |conname| (|opOf| |conform|)) - (COND - ((BOOT-EQUAL (GETDATABASE |conname| (QUOTE CONSTRUCTORKIND)) - (QUOTE |category|)) - (|simpCatHasAttribute| |conform| |attr|)) - ((QUOTE T) - (SEQ - (COND - ((|asharpConstructorName?| |conname|) - (EXIT - (COND - ((SPADLET |p| - (LASSOC |attr| (GETDATABASE |conname| (QUOTE |attributes|)))) - (EXIT (|simpHasPred| (|sublisFormal| (CDR |conform|) |p|)))))))) - (SPADLET |infovec| (|dbInfovec| |conname|)) - (SPADLET |k| (OR (LASSOC |attr| (ELT |infovec| 2)) (RETURN NIL))) - (COND ((EQL |k| 0) (EXIT (QUOTE T)))) - (COND (|$domain| (EXIT (|kTestPred| |k|)))) - (SPADLET |predvec| - (OR |$predvec| - (|sublisFormal| - (CDR |conform|) - (GETDATABASE |conname| (QUOTE PREDICATES))))) - (|simpHasPred| (ELT |predvec| (SPADDIFFERENCE |k| 1)))))))))))) + (PROG (|conname| |p| |infovec| |k| |predvec|) + (declare (special |$predvec| |$domain|)) + (RETURN + (SEQ (COND + ((IDENTP |conform|) |pred|) + ('T (SPADLET |conname| (|opOf| |conform|)) + (COND + ((BOOT-EQUAL (GETDATABASE |conname| 'CONSTRUCTORKIND) + '|category|) + (|simpCatHasAttribute| |conform| |attr|)) + ('T + (SEQ (COND + ((|asharpConstructorName?| |conname|) + (EXIT (COND + ((SPADLET |p| + (LASSOC |attr| + (GETDATABASE |conname| + '|attributes|))) + (EXIT (|simpHasPred| + (|sublisFormal| + (CDR |conform|) |p|)))))))) + (SPADLET |infovec| (|dbInfovec| |conname|)) + (SPADLET |k| + (OR (LASSOC |attr| (ELT |infovec| 2)) + (RETURN NIL))) + (COND ((EQL |k| 0) (EXIT 'T))) + (COND (|$domain| (EXIT (|kTestPred| |k|)))) + (SPADLET |predvec| + (OR |$predvec| + (|sublisFormal| (CDR |conform|) + (GETDATABASE |conname| 'PREDICATES)))) + (|simpHasPred| + (ELT |predvec| (SPADDIFFERENCE |k| 1)))))))))))) ;simpCatHasAttribute(domform,attr) == ; conform := getConstructorForm opOf domform @@ -611,21 +695,22 @@ ; EVAL SUBLISLIS(rest domform,rest conform,pred) (DEFUN |simpCatHasAttribute| (|domform| |attr|) - (PROG (|conform| |catval| |u| |pred|) - (RETURN - (PROGN - (SPADLET |conform| (|getConstructorForm| (|opOf| |domform|))) - (SPADLET |catval| (EVAL (|mkEvalable| |conform|))) - (COND ((ATOM (KDR |attr|)) (SPADLET |attr| (IFCAR |attr|)))) - (SPADLET |pred| - (COND - ((SPADLET |u| (LASSOC |attr| (ELT |catval| 2))) (CAR |u|)) - ((QUOTE T) (RETURN NIL)))) - (COND - ((BOOT-EQUAL |pred| (QUOTE T)) - (QUOTE T)) - ((QUOTE T) - (EVAL (SUBLISLIS (CDR |domform|) (CDR |conform|) |pred|)))))))) + (PROG (|conform| |catval| |u| |pred|) + (RETURN + (PROGN + (SPADLET |conform| (|getConstructorForm| (|opOf| |domform|))) + (SPADLET |catval| (EVAL (|mkEvalable| |conform|))) + (COND ((ATOM (KDR |attr|)) (SPADLET |attr| (IFCAR |attr|)))) + (SPADLET |pred| + (COND + ((SPADLET |u| (LASSOC |attr| (ELT |catval| 2))) + (CAR |u|)) + ('T (RETURN NIL)))) + (COND + ((BOOT-EQUAL |pred| 'T) 'T) + ('T + (EVAL (SUBLISLIS (CDR |domform|) (CDR |conform|) |pred|)))))))) + ;hasIdent pred == ; pred is [op,:r] => ; op = 'QUOTE => false @@ -635,26 +720,30 @@ ; false (DEFUN |hasIdent| (|pred|) - (PROG (|op| |r|) - (RETURN - (SEQ - (COND - ((AND (PAIRP |pred|) - (PROGN (SPADLET |op| (QCAR |pred|)) - (SPADLET |r| (QCDR |pred|)) - (QUOTE T))) - (COND - ((BOOT-EQUAL |op| (QUOTE QUOTE)) NIL) - ((QUOTE T) - (PROG (#0=#:G166539) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166545 NIL #0#) (#2=#:G166546 |r| (CDR #2#)) (|x| NIL)) - ((OR #1# (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #0#) - (SEQ (EXIT (SETQ #0# (OR #0# (|hasIdent| |x|))))))))))) - ((BOOT-EQUAL |pred| (QUOTE $)) NIL) - ((IDENTP |pred|) (QUOTE T)) - ((QUOTE T) NIL)))))) + (PROG (|op| |r|) + (RETURN + (SEQ (COND + ((AND (PAIRP |pred|) + (PROGN + (SPADLET |op| (QCAR |pred|)) + (SPADLET |r| (QCDR |pred|)) + 'T)) + (COND + ((BOOT-EQUAL |op| 'QUOTE) NIL) + ('T + (PROG (G166539) + (SPADLET G166539 NIL) + (RETURN + (DO ((G166545 NIL G166539) + (G166546 |r| (CDR G166546)) (|x| NIL)) + ((OR G166545 (ATOM G166546) + (PROGN (SETQ |x| (CAR G166546)) NIL)) + G166539) + (SEQ (EXIT (SETQ G166539 + (OR G166539 (|hasIdent| |x|))))))))))) + ((BOOT-EQUAL |pred| '$) NIL) + ((IDENTP |pred|) 'T) + ('T NIL)))))) ;addDomainToTable(id,catl) == ; alist:= nil @@ -668,65 +757,83 @@ ; [id,:alist] (DEFUN |addDomainToTable| (|id| |catl|) - (PROG (|ISTMP#1| |pred| |ISTMP#2| |cat1| |a| |b| |newAlist| |alist|) - (RETURN - (SEQ - (PROGN - (SPADLET |alist| NIL) - (DO ((#0=#:G166595 |catl| (CDR #0#)) (|cat| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |cat| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((AND (PAIRP |cat|) (EQ (QCAR |cat|) (QUOTE CATEGORY))) NIL) - ((AND (PAIRP |cat|) - (EQ (QCAR |cat|) (QUOTE IF)) - (PROGN (SPADLET |ISTMP#1| (QCDR |cat|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |pred| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |cat1| (QCAR |ISTMP#2|)) - (QUOTE T))))))) - (SPADLET |newAlist| - (PROG (#1=#:G166606) - (SPADLET #1# NIL) - (RETURN - (DO ((#2=#:G166612 - (|getCategoryExtensionAlist0| |cat1|) (CDR #2#)) - (#3=#:G166575 NIL)) - ((OR (ATOM #2#) - (PROGN (SETQ #3# (CAR #2#)) NIL) - (PROGN - (PROGN - (SPADLET |a| (CAR #3#)) - (SPADLET |b| (CDR #3#)) - #3#) - NIL)) - (NREVERSE0 #1#)) - (SEQ - (EXIT - (SETQ #1# (CONS (CONS |a| (|quickAnd| |pred| |b|)) #1#)))))))) - (SPADLET |alist| (APPEND |alist| |newAlist|))) - ((QUOTE T) - (SPADLET |alist| - (APPEND |alist| (|getCategoryExtensionAlist0| |cat|)))))))) - (CONS |id| |alist|)))))) + (PROG (|ISTMP#1| |pred| |ISTMP#2| |cat1| |a| |b| |newAlist| |alist|) + (RETURN + (SEQ (PROGN + (SPADLET |alist| NIL) + (DO ((G166595 |catl| (CDR G166595)) (|cat| NIL)) + ((OR (ATOM G166595) + (PROGN (SETQ |cat| (CAR G166595)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |cat|) + (EQ (QCAR |cat|) 'CATEGORY)) + NIL) + ((AND (PAIRP |cat|) (EQ (QCAR |cat|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cat|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |cat1| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |newAlist| + (PROG (G166606) + (SPADLET G166606 NIL) + (RETURN + (DO + ((G166612 + (|getCategoryExtensionAlist0| + |cat1|) + (CDR G166612)) + (G166575 NIL)) + ((OR (ATOM G166612) + (PROGN + (SETQ G166575 + (CAR G166612)) + NIL) + (PROGN + (PROGN + (SPADLET |a| + (CAR G166575)) + (SPADLET |b| + (CDR G166575)) + G166575) + NIL)) + (NREVERSE0 G166606)) + (SEQ + (EXIT + (SETQ G166606 + (CONS + (CONS |a| + (|quickAnd| |pred| + |b|)) + G166606)))))))) + (SPADLET |alist| + (APPEND |alist| |newAlist|))) + ('T + (SPADLET |alist| + (APPEND |alist| + (|getCategoryExtensionAlist0| + |cat|)))))))) + (CONS |id| |alist|)))))) ;domainHput(table,key:=[id,:a],b) == ; HPUT(table,key,b) (DEFUN |domainHput| (|table| |key| |b|) - (PROG (|id| |a|) - (RETURN - (PROGN - (SPADLET |id| (CAR |key|)) - (SPADLET |a| (CDR |key|)) - (HPUT |table| |key| |b|))))) + (PROG (|id| |a|) + (RETURN + (PROGN + (SPADLET |id| (CAR |key|)) + (SPADLET |a| (CDR |key|)) + (HPUT |table| |key| |b|))))) ;genTempCategoryTable() == ; --generates hashtable with key=categoryName and value of the form @@ -743,31 +850,44 @@ ; HPUT(_*ANCESTORS_-HASH_*,id,listSort(function GLESSEQP,item)) (DEFUN |genTempCategoryTable| () - (PROG (|item| |b|) - (RETURN - (SEQ - (DO ((#0=#:G166653 (|allConstructors|) (CDR #0#)) (|con| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |con| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL (GETDATABASE |con| (QUOTE CONSTRUCTORKIND)) - (QUOTE |category|)) - (EXIT (|addToCategoryTable| |con|))))))) - (DO ((#1=#:G166667 (HKEYS *ANCESTORS-HASH*) (CDR #1#)) (|id| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |id| (CAR #1#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |item| (HGET *ANCESTORS-HASH* |id|)) - (DO ((#2=#:G166677 |item| (CDR #2#)) (|u| NIL)) - ((OR (ATOM #2#) - (PROGN (SETQ |u| (CAR #2#)) NIL) - (PROGN (PROGN (SPADLET |b| (CDR |u|)) |u|) NIL)) NIL) - (SEQ - (EXIT (RPLACD |u| (|simpCatPredicate| (|simpBool| |b|)))))) - (HPUT *ANCESTORS-HASH* |id| - (|listSort| (|function| GLESSEQP) |item|)))))))))) + (PROG (|item| |b|) + (declare (special *ANCESTORS-HASH*)) + (RETURN + (SEQ (DO ((G166653 (|allConstructors|) (CDR G166653)) + (|con| NIL)) + ((OR (ATOM G166653) + (PROGN (SETQ |con| (CAR G166653)) NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL + (GETDATABASE |con| 'CONSTRUCTORKIND) + '|category|) + (EXIT (|addToCategoryTable| |con|))))))) + (DO ((G166667 (HKEYS *ANCESTORS-HASH*) (CDR G166667)) + (|id| NIL)) + ((OR (ATOM G166667) + (PROGN (SETQ |id| (CAR G166667)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |item| (HGET *ANCESTORS-HASH* |id|)) + (DO ((G166677 |item| (CDR G166677)) + (|u| NIL)) + ((OR (ATOM G166677) + (PROGN + (SETQ |u| (CAR G166677)) + NIL) + (PROGN + (PROGN + (SPADLET |b| (CDR |u|)) + |u|) + NIL)) + NIL) + (SEQ (EXIT (RPLACD |u| + (|simpCatPredicate| + (|simpBool| |b|)))))) + (HPUT *ANCESTORS-HASH* |id| + (|listSort| (|function| GLESSEQP) + |item|)))))))))) ;addToCategoryTable con == ; -- adds an entry to $tempCategoryTable with key=con and alist entries @@ -777,12 +897,14 @@ ; alist (DEFUN |addToCategoryTable| (|con|) - (PROG (|u| |alist|) - (RETURN - (PROGN - (SPADLET |u| (CAAR (GETDATABASE |con| (QUOTE CONSTRUCTORMODEMAP)))) - (SPADLET |alist| (|getCategoryExtensionAlist| |u|)) - (HPUT *ANCESTORS-HASH* (CAR |u|) |alist|) |alist|)))) + (PROG (|u| |alist|) + (declare (special *ANCESTORS-HASH*)) + (RETURN + (PROGN + (SPADLET |u| (CAAR (GETDATABASE |con| 'CONSTRUCTORMODEMAP))) + (SPADLET |alist| (|getCategoryExtensionAlist| |u|)) + (HPUT *ANCESTORS-HASH* (CAR |u|) |alist|) + |alist|)))) ;encodeCategoryAlist(id,alist) == ; newAl:= nil @@ -801,36 +923,52 @@ ; newAl (DEFUN |encodeCategoryAlist| (|id| |alist|) - (PROG (|a| |b| |key| |argl| |newEntry| |u| |p| |newAl|) - (RETURN - (SEQ - (PROGN - (SPADLET |newAl| NIL) - (DO ((#0=#:G166715 |alist| (CDR #0#)) (#1=#:G166702 NIL)) - ((OR (ATOM #0#) (PROGN (SETQ #1# (CAR #0#)) NIL) (PROGN (PROGN (SPADLET |a| (CAR #1#)) (SPADLET |b| (CDR #1#)) #1#) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |key| (CAR |a|)) - (SPADLET |argl| (CDR |a|)) - (SPADLET |newEntry| (COND (|argl| (CONS (CONS |argl| |b|) NIL)) ((QUOTE T) |b|))) - (COND - ((SPADLET |u| (|assoc| |key| |newAl|)) - (COND - (|argl| - (RPLACD |u| (|encodeUnion| |id| (CAR |newEntry|) (CDR |u|)))) - ((NEQUAL |newEntry| (CDR |u|)) - (COND - ((SPADLET |p| - (|moreGeneralCategoryPredicate| |id| |newEntry| (CDR |u|))) - (RPLACD |u| |p|)) - ((QUOTE T) - (|sayMSG| "Duplicate entries:") - (PRINT (CONS |newEntry| (CONS (CDR |u|) NIL)))))) - ((QUOTE T) NIL))) - ((QUOTE T) - (SPADLET |newAl| (CONS (CONS |key| |newEntry|) |newAl|)))))))) - |newAl|))))) + (PROG (|a| |b| |key| |argl| |newEntry| |u| |p| |newAl|) + (RETURN + (SEQ (PROGN + (SPADLET |newAl| NIL) + (DO ((G166715 |alist| (CDR G166715)) (G166702 NIL)) + ((OR (ATOM G166715) + (PROGN (SETQ G166702 (CAR G166715)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G166702)) + (SPADLET |b| (CDR G166702)) + G166702) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |key| (CAR |a|)) + (SPADLET |argl| (CDR |a|)) + (SPADLET |newEntry| + (COND + (|argl| + (CONS (CONS |argl| |b|) NIL)) + ('T |b|))) + (COND + ((SPADLET |u| (|assoc| |key| |newAl|)) + (COND + (|argl| (RPLACD |u| + (|encodeUnion| |id| + (CAR |newEntry|) (CDR |u|)))) + ((NEQUAL |newEntry| (CDR |u|)) + (COND + ((SPADLET |p| + (|moreGeneralCategoryPredicate| + |id| |newEntry| (CDR |u|))) + (RPLACD |u| |p|)) + ('T + (|sayMSG| + (MAKESTRING "Duplicate entries:")) + (PRINT + (CONS |newEntry| + (CONS (CDR |u|) NIL)))))) + ('T NIL))) + ('T + (SPADLET |newAl| + (CONS (CONS |key| |newEntry|) + |newAl|)))))))) + |newAl|))))) ;encodeUnion(id,new:=[a,:b],alist) == ; u := ASSOC(a,alist) => @@ -839,16 +977,17 @@ ; [new,:alist] (DEFUN |encodeUnion| (|id| |new| |alist|) - (PROG (|a| |b| |u|) - (RETURN - (PROGN - (SPADLET |a| (CAR |new|)) - (SPADLET |b| (CDR |new|)) - (COND - ((SPADLET |u| (|assoc| |a| |alist|)) - (RPLACD |u| (|moreGeneralCategoryPredicate| |id| |b| (CDR |u|))) |alist|) - ((QUOTE T) - (CONS |new| |alist|))))))) + (PROG (|a| |b| |u|) + (RETURN + (PROGN + (SPADLET |a| (CAR |new|)) + (SPADLET |b| (CDR |new|)) + (COND + ((SPADLET |u| (|assoc| |a| |alist|)) + (RPLACD |u| + (|moreGeneralCategoryPredicate| |id| |b| (CDR |u|))) + |alist|) + ('T (CONS |new| |alist|))))))) ;moreGeneralCategoryPredicate(id,new,old) == ; old = 'T or new = 'T => 'T @@ -859,53 +998,46 @@ ; mkCategoryOr(new,old) (DEFUN |moreGeneralCategoryPredicate| (|id| |new| |old|) - (PROG (|a| |b| |ISTMP#1| |ISTMP#2| |c|) - (RETURN - (COND - ((OR (BOOT-EQUAL |old| (QUOTE T)) (BOOT-EQUAL |new| (QUOTE T))) (QUOTE T)) - ((AND - (PAIRP |old|) - (EQ (QCAR |old|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |old|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T)))))) - (PAIRP |new|) - (EQ (QCAR |new|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |new|)) - (AND - (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |a|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |c| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (COND - ((|tempExtendsCat| |b| |c|) |new|) - ((|tempExtendsCat| |c| |b|) |old|) - ((QUOTE T) (CONS (QUOTE OR) (CONS |old| (CONS |new| NIL)))))) - ((QUOTE T) (|mkCategoryOr| |new| |old|)))))) + (declare (ignore |id|)) + (PROG (|a| |b| |ISTMP#1| |ISTMP#2| |c|) + (RETURN + (COND + ((OR (BOOT-EQUAL |old| 'T) (BOOT-EQUAL |new| 'T)) 'T) + ((AND (PAIRP |old|) (EQ (QCAR |old|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |old|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) 'T))))) + (PAIRP |new|) (EQ (QCAR |new|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |new|)) + (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |a|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |c| (QCAR |ISTMP#2|)) 'T)))))) + (COND + ((|tempExtendsCat| |b| |c|) |new|) + ((|tempExtendsCat| |c| |b|) |old|) + ('T (CONS 'OR (CONS |old| (CONS |new| NIL)))))) + ('T (|mkCategoryOr| |new| |old|)))))) ;mkCategoryOr(new,old) == ; old is ['OR,:l] => simpCategoryOr(new,l) ; ['OR,old,new] (DEFUN |mkCategoryOr| (|new| |old|) - (PROG (|l|) - (RETURN - (COND - ((AND (PAIRP |old|) - (EQ (QCAR |old|) (QUOTE OR)) - (PROGN (SPADLET |l| (QCDR |old|)) (QUOTE T))) - (|simpCategoryOr| |new| |l|)) - ((QUOTE T) (CONS (QUOTE OR) (CONS |old| (CONS |new| NIL)))))))) + (PROG (|l|) + (RETURN + (COND + ((AND (PAIRP |old|) (EQ (QCAR |old|) 'OR) + (PROGN (SPADLET |l| (QCDR |old|)) 'T)) + (|simpCategoryOr| |new| |l|)) + ('T (CONS 'OR (CONS |old| (CONS |new| NIL)))))))) ;simpCategoryOr(new,l) == ; newExtendsAnOld:= false @@ -923,73 +1055,85 @@ ; ['OR,:newList] (DEFUN |simpCategoryOr| (|new| |l|) - (PROG (|a| |b| |ISTMP#1| |ISTMP#2| |c| |anOldExtendsNew| - |newExtendsAnOld| |newList|) - (RETURN - (SEQ - (PROGN - (SPADLET |newExtendsAnOld| NIL) - (SPADLET |anOldExtendsNew| NIL) - (SPADLET |a| (CADR |new|)) - (SPADLET |b| (CADDR |new|)) - (SPADLET |newList| NIL) - (DO ((#0=#:G166818 |l| (CDR #0#)) (|pred| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |pred| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((AND (PAIRP |pred|) - (EQ (QCAR |pred|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |pred|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |a|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |c| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (COND - ((|tempExtendsCat| |c| |b|) - (SPADLET |anOldExtendsNew| (QUOTE T))) - ((QUOTE T) + (PROG (|a| |b| |ISTMP#1| |ISTMP#2| |c| |anOldExtendsNew| + |newExtendsAnOld| |newList|) + (RETURN + (SEQ (PROGN + (SPADLET |newExtendsAnOld| NIL) + (SPADLET |anOldExtendsNew| NIL) + (SPADLET |a| (CADR |new|)) + (SPADLET |b| (CADDR |new|)) + (SPADLET |newList| NIL) + (DO ((G166818 |l| (CDR G166818)) (|pred| NIL)) + ((OR (ATOM G166818) + (PROGN (SETQ |pred| (CAR G166818)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |pred|) + (EQ (QCAR |pred|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |a|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |c| + (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((|tempExtendsCat| |c| |b|) + (SPADLET |anOldExtendsNew| 'T)) + ('T + (COND + ((|tempExtendsCat| |b| |c|) + (SPADLET |newExtendsAnOld| 'T))) + (SPADLET |newList| + (CONS |pred| |newList|))))) + ('T + (SPADLET |newList| + (CONS |pred| |newList|))))))) (COND - ((|tempExtendsCat| |b| |c|) - (SPADLET |newExtendsAnOld| (QUOTE T)))) - (SPADLET |newList| (CONS |pred| |newList|))))) - ((QUOTE T) (SPADLET |newList| (CONS |pred| |newList|))))))) - (COND - ((NULL |newExtendsAnOld|) (SPADLET |newList| (CONS |new| |newList|)))) - (COND - ((AND (PAIRP |newList|) (EQ (QCDR |newList|) NIL)) (CAR |newList|)) - ((QUOTE T) (CONS (QUOTE OR) |newList|)))))))) + ((NULL |newExtendsAnOld|) + (SPADLET |newList| (CONS |new| |newList|)))) + (COND + ((AND (PAIRP |newList|) (EQ (QCDR |newList|) NIL)) + (CAR |newList|)) + ('T (CONS 'OR |newList|)))))))) ;tempExtendsCat(b,c) == ; or/[first c = a for [[a,:.],:.] in GETDATABASE(first b,'ANCESTORS)] (DEFUN |tempExtendsCat| (|b| |c|) - (PROG (|a|) - (RETURN - (SEQ - (PROG (#0=#:G166843) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166850 NIL #0#) - (#2=#:G166851 (GETDATABASE (CAR |b|) (QUOTE ANCESTORS)) (CDR #2#)) - (#3=#:G166840 NIL)) - ((OR #1# - (ATOM #2#) - (PROGN (SETQ #3# (CAR #2#)) NIL) - (PROGN (PROGN (SPADLET |a| (CAAR #3#)) #3#) NIL)) - #0#) - (SEQ (EXIT (SETQ #0# (OR #0# (BOOT-EQUAL (CAR |c|) |a|)))))))))))) + (PROG (|a|) + (RETURN + (SEQ (PROG (G166843) + (SPADLET G166843 NIL) + (RETURN + (DO ((G166850 NIL G166843) + (G166851 (GETDATABASE (CAR |b|) 'ANCESTORS) + (CDR G166851)) + (G166840 NIL)) + ((OR G166850 (ATOM G166851) + (PROGN (SETQ G166840 (CAR G166851)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAAR G166840)) + G166840) + NIL)) + G166843) + (SEQ (EXIT (SETQ G166843 + (OR G166843 + (BOOT-EQUAL (CAR |c|) |a|)))))))))))) ;getCategoryExtensionAlist0 cform == ; [[cform,:'T],:getCategoryExtensionAlist cform] (DEFUN |getCategoryExtensionAlist0| (|cform|) - (CONS (CONS |cform| (QUOTE T)) (|getCategoryExtensionAlist| |cform|))) + (CONS (CONS |cform| 'T) (|getCategoryExtensionAlist| |cform|))) ;getCategoryExtensionAlist cform == ; --avoids substitution as much as possible @@ -997,49 +1141,49 @@ ; mkCategoryExtensionAlist cform (DEFUN |getCategoryExtensionAlist| (|cform|) - (PROG (|u|) - (RETURN - (COND - ((SPADLET |u| (GETDATABASE (CAR |cform|) (QUOTE ANCESTORS))) - (|formalSubstitute| |cform| |u|)) - ((QUOTE T) - (|mkCategoryExtensionAlist| |cform|)))))) + (PROG (|u|) + (RETURN + (COND + ((SPADLET |u| (GETDATABASE (CAR |cform|) 'ANCESTORS)) + (|formalSubstitute| |cform| |u|)) + ('T (|mkCategoryExtensionAlist| |cform|)))))) ;formalSubstitute(form:=[.,:argl],u) == ; isFormalArgumentList argl => u ; EQSUBSTLIST(argl,$FormalMapVariableList,u) (DEFUN |formalSubstitute| (|form| |u|) - (PROG (|argl|) - (RETURN - (PROGN - (SPADLET |argl| (CDR |form|)) - (COND - ((|isFormalArgumentList| |argl|) |u|) - ((QUOTE T) (EQSUBSTLIST |argl| |$FormalMapVariableList| |u|))))))) + (PROG (|argl|) + (declare (special |$FormalMapVariableList|)) + (RETURN + (PROGN + (SPADLET |argl| (CDR |form|)) + (COND + ((|isFormalArgumentList| |argl|) |u|) + ('T (EQSUBSTLIST |argl| |$FormalMapVariableList| |u|))))))) ;isFormalArgumentList argl == ; and/[x=fa for x in argl for fa in $FormalMapVariableList] (DEFUN |isFormalArgumentList| (|argl|) - (PROG () - (RETURN - (SEQ - (PROG (#0=#:G166883) - (SPADLET #0# (QUOTE T)) - (RETURN - (DO ((#1=#:G166890 NIL (NULL #0#)) - (#2=#:G166891 |argl| (CDR #2#)) - (|x| NIL) - (#3=#:G166892 |$FormalMapVariableList| (CDR #3#)) - (|fa| NIL)) - ((OR #1# - (ATOM #2#) - (PROGN (SETQ |x| (CAR #2#)) NIL) - (ATOM #3#) - (PROGN (SETQ |fa| (CAR #3#)) NIL)) - #0#) - (SEQ (EXIT (SETQ #0# (AND #0# (BOOT-EQUAL |x| |fa|)))))))))))) + (PROG () + (declare (special |$FormalMapVariableList|)) + (RETURN + (SEQ (PROG (G166883) + (SPADLET G166883 'T) + (RETURN + (DO ((G166890 NIL (NULL G166883)) + (G166891 |argl| (CDR G166891)) (|x| NIL) + (G166892 |$FormalMapVariableList| + (CDR G166892)) + (|fa| NIL)) + ((OR G166890 (ATOM G166891) + (PROGN (SETQ |x| (CAR G166891)) NIL) + (ATOM G166892) + (PROGN (SETQ |fa| (CAR G166892)) NIL)) + G166883) + (SEQ (EXIT (SETQ G166883 + (AND G166883 (BOOT-EQUAL |x| |fa|)))))))))))) ;mkCategoryExtensionAlist cform == ; not CONSP cform => nil @@ -1056,60 +1200,74 @@ ; extendsList (DEFUN |mkCategoryExtensionAlist| (|cform|) - (PROG (|cop| |catlist| |cat| |pred| |newList| |a| |b| - |finalList| |extendsList|) - (RETURN - (SEQ - (COND - ((NULL (CONSP |cform|)) NIL) - ((QUOTE T) - (SPADLET |cop| (CAR |cform|)) - (COND - ((MEMQ |cop| |$CategoryNames|) - (|mkCategoryExtensionAlistBasic| |cform|)) - ((QUOTE T) - (SPADLET |catlist| - (|formalSubstitute| |cform| - (CAR (|getConstructorExports| |cform| (QUOTE T))))) - (SPADLET |extendsList| NIL) - (DO ((#0=#:G166927 |catlist| (CDR #0#)) (#1=#:G166912 NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN - (SPADLET |cat| (CAR #1#)) - (SPADLET |pred| (CDR #1#)) - #1#) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |newList| (|getCategoryExtensionAlist0| |cat|)) - (SPADLET |finalList| - (COND - ((BOOT-EQUAL |pred| (QUOTE T)) |newList|) - ((QUOTE T) - (PROG (#2=#:G166939) - (SPADLET #2# NIL) - (RETURN - (DO ((#3=#:G166945 |newList| (CDR #3#)) (#4=#:G166906 NIL)) - ((OR (ATOM #3#) - (PROGN (SETQ #4# (CAR #3#)) NIL) + (PROG (|cop| |catlist| |cat| |pred| |newList| |a| |b| |finalList| + |extendsList|) + (declare (special |$CategoryNames|)) + (RETURN + (SEQ (COND + ((NULL (CONSP |cform|)) NIL) + ('T (SPADLET |cop| (CAR |cform|)) + (COND + ((MEMQ |cop| |$CategoryNames|) + (|mkCategoryExtensionAlistBasic| |cform|)) + ('T + (SPADLET |catlist| + (|formalSubstitute| |cform| + (CAR (|getConstructorExports| |cform| 'T)))) + (SPADLET |extendsList| NIL) + (DO ((G166927 |catlist| (CDR G166927)) + (G166912 NIL)) + ((OR (ATOM G166927) + (PROGN (SETQ G166912 (CAR G166927)) NIL) (PROGN - (PROGN - (SPADLET |a| (CAR #4#)) - (SPADLET |b| (CDR #4#)) - #4#) - NIL)) - (NREVERSE0 #2#)) - (SEQ - (EXIT - (SETQ #2# - (CONS (CONS |a| (|quickAnd| |b| |pred|)) #2#)))))))))) - (SPADLET |extendsList| - (|catPairUnion| |extendsList| |finalList| |cop| |cat|)))))) - |extendsList|)))))))) + (PROGN + (SPADLET |cat| (CAR G166912)) + (SPADLET |pred| (CDR G166912)) + G166912) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |newList| + (|getCategoryExtensionAlist0| + |cat|)) + (SPADLET |finalList| + (COND + ((BOOT-EQUAL |pred| 'T) + |newList|) + ('T + (PROG (G166939) + (SPADLET G166939 NIL) + (RETURN + (DO + ((G166945 |newList| + (CDR G166945)) + (G166906 NIL)) + ((OR (ATOM G166945) + (PROGN + (SETQ G166906 + (CAR G166945)) + NIL) + (PROGN + (PROGN + (SPADLET |a| + (CAR G166906)) + (SPADLET |b| + (CDR G166906)) + G166906) + NIL)) + (NREVERSE0 G166939)) + (SEQ + (EXIT + (SETQ G166939 + (CONS + (CONS |a| + (|quickAnd| |b| + |pred|)) + G166939)))))))))) + (SPADLET |extendsList| + (|catPairUnion| |extendsList| + |finalList| |cop| |cat|)))))) + |extendsList|)))))))) ;-- following code to handle Unions Records Mapping etc. ;mkCategoryExtensionAlistBasic cform == @@ -1128,62 +1286,83 @@ ; extendsList (DEFUN |mkCategoryExtensionAlistBasic| (|cform|) - (PROG (|cop| |category| |cat| |pred| |newList| |a| |b| - |finalList| |extendsList|) - (RETURN - (SEQ - (PROGN - (SPADLET |cop| (CAR |cform|)) - (SPADLET |category| - (COND - ((|macrop| |cop|) (|eval| |cform|)) - ((QUOTE T) (APPLY |cop| (CDR |cform|))))) - (SPADLET |extendsList| - (PROG (#0=#:G166982) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166987 (ELT (ELT |category| 4) 0) (CDR #1#)) (|x| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (CONS |x| (QUOTE T)) #0#)))))))) - (DO ((#2=#:G167003 (ELT (ELT |category| 4) 1) (CDR #2#)) - (#3=#:G166973 NIL)) - ((OR (ATOM #2#) - (PROGN (SETQ #3# (CAR #2#)) NIL) - (PROGN - (PROGN - (SPADLET |cat| (CAR #3#)) - (SPADLET |pred| (CADR #3#)) - #3#) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |newList| (|getCategoryExtensionAlist0| |cat|)) - (SPADLET |finalList| - (COND - ((BOOT-EQUAL |pred| (QUOTE T)) |newList|) - ((QUOTE T) - (PROG (#4=#:G167015) - (SPADLET #4# NIL) - (RETURN - (DO ((#5=#:G167021 |newList| (CDR #5#)) (#6=#:G166967 NIL)) - ((OR (ATOM #5#) - (PROGN (SETQ #6# (CAR #5#)) NIL) - (PROGN + (PROG (|cop| |category| |cat| |pred| |newList| |a| |b| |finalList| + |extendsList|) + (RETURN + (SEQ (PROGN + (SPADLET |cop| (CAR |cform|)) + (SPADLET |category| + (COND + ((|macrop| |cop|) (|eval| |cform|)) + ('T (APPLY |cop| (CDR |cform|))))) + (SPADLET |extendsList| + (PROG (G166982) + (SPADLET G166982 NIL) + (RETURN + (DO ((G166987 (ELT (ELT |category| 4) 0) + (CDR G166987)) + (|x| NIL)) + ((OR (ATOM G166987) + (PROGN + (SETQ |x| (CAR G166987)) + NIL)) + (NREVERSE0 G166982)) + (SEQ (EXIT (SETQ G166982 + (CONS (CONS |x| 'T) G166982)))))))) + (DO ((G167003 (ELT (ELT |category| 4) 1) + (CDR G167003)) + (G166973 NIL)) + ((OR (ATOM G167003) + (PROGN (SETQ G166973 (CAR G167003)) NIL) + (PROGN (PROGN - (SPADLET |a| (CAR #6#)) - (SPADLET |b| (CDR #6#)) - #6#) + (SPADLET |cat| (CAR G166973)) + (SPADLET |pred| (CADR G166973)) + G166973) NIL)) - (NREVERSE0 #4#)) - (SEQ - (EXIT - (SETQ #4# - (CONS (CONS |a| (|quickAnd| |b| |pred|)) #4#)))))))))) - (SPADLET |extendsList| - (|catPairUnion| |extendsList| |finalList| |cop| |cat|)))))) - |extendsList|))))) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |newList| + (|getCategoryExtensionAlist0| + |cat|)) + (SPADLET |finalList| + (COND + ((BOOT-EQUAL |pred| 'T) + |newList|) + ('T + (PROG (G167015) + (SPADLET G167015 NIL) + (RETURN + (DO + ((G167021 |newList| + (CDR G167021)) + (G166967 NIL)) + ((OR (ATOM G167021) + (PROGN + (SETQ G166967 + (CAR G167021)) + NIL) + (PROGN + (PROGN + (SPADLET |a| + (CAR G166967)) + (SPADLET |b| + (CDR G166967)) + G166967) + NIL)) + (NREVERSE0 G167015)) + (SEQ + (EXIT + (SETQ G167015 + (CONS + (CONS |a| + (|quickAnd| |b| + |pred|)) + G167015)))))))))) + (SPADLET |extendsList| + (|catPairUnion| |extendsList| + |finalList| |cop| |cat|)))))) + |extendsList|))))) ;catPairUnion(oldList,newList,op,cat) == ; for pair in newList repeat @@ -1194,26 +1373,32 @@ ; oldList:= [pair,:oldList] ; oldList -(DEFUN |catPairUnion,addConflict| (|new| |old|) (|quickOr| |new| |old|)) +(DEFUN |catPairUnion,addConflict| (|new| |old|) + (|quickOr| |new| |old|)) (DEFUN |catPairUnion| (|oldList| |newList| |op| |cat|) - (PROG (|u|) - (RETURN - (SEQ - (PROGN - (DO ((#0=#:G167053 |newList| (CDR #0#)) (|pair| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |pair| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((SPADLET |u| (|assoc| (CAR |pair|) |oldList|)) - (COND - ((BOOT-EQUAL (CDR |u|) (CDR |pair|)) NIL) - ((QUOTE T) - (RPLACD |u| - (|catPairUnion,addConflict| (CDR |pair|) (CDR |u|)))))) - ((QUOTE T) (SPADLET |oldList| (CONS |pair| |oldList|))))))) - |oldList|))))) + (declare (ignore |op| |cat|)) + (PROG (|u|) + (RETURN + (SEQ (PROGN + (DO ((G167053 |newList| (CDR G167053)) (|pair| NIL)) + ((OR (ATOM G167053) + (PROGN (SETQ |pair| (CAR G167053)) NIL)) + NIL) + (SEQ (EXIT (COND + ((SPADLET |u| + (|assoc| (CAR |pair|) |oldList|)) + (COND + ((BOOT-EQUAL (CDR |u|) (CDR |pair|)) + NIL) + ('T + (RPLACD |u| + (|catPairUnion,addConflict| + (CDR |pair|) (CDR |u|)))))) + ('T + (SPADLET |oldList| + (CONS |pair| |oldList|))))))) + |oldList|))))) ;simpCatPredicate p == ; p is ['OR,:l] => @@ -1222,30 +1407,28 @@ ; p (DEFUN |simpCatPredicate| (|p|) - (PROG (|l| |u| |ISTMP#1|) - (RETURN - (COND - ((AND (PAIRP |p|) - (EQ (QCAR |p|) (QUOTE OR)) - (PROGN (SPADLET |l| (QCDR |p|)) (QUOTE T))) - (COND - ((PROGN - (SPADLET |ISTMP#1| (SPADLET |u| (|simpOrUnion| |l|))) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) (QUOTE T)))) - |p|) - ((QUOTE T) (CONS (QUOTE OR) |u|)))) - ((QUOTE T) |p|))))) + (PROG (|l| |u| |ISTMP#1|) + (RETURN + (COND + ((AND (PAIRP |p|) (EQ (QCAR |p|) 'OR) + (PROGN (SPADLET |l| (QCDR |p|)) 'T)) + (COND + ((PROGN + (SPADLET |ISTMP#1| (SPADLET |u| (|simpOrUnion| |l|))) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) 'T))) + |p|) + ('T (CONS 'OR |u|)))) + ('T |p|))))) ;simpOrUnion l == ; if l then simpOrUnion1(first l,simpOrUnion rest l) ; else l (DEFUN |simpOrUnion| (|l|) - (COND - (|l| (|simpOrUnion1| (CAR |l|) (|simpOrUnion| (CDR |l|)))) - ((QUOTE T) |l|))) + (COND + (|l| (|simpOrUnion1| (CAR |l|) (|simpOrUnion| (CDR |l|)))) + ('T |l|))) ;simpOrUnion1(x,l) == ; null l => [x] @@ -1253,12 +1436,12 @@ ; [first l,:simpOrUnion1(x,rest l)] (DEFUN |simpOrUnion1| (|x| |l|) - (PROG (|p|) - (RETURN - (COND - ((NULL |l|) (CONS |x| NIL)) - ((SPADLET |p| (|mergeOr| |x| (CAR |l|))) (CONS |p| (CDR |l|))) - ((QUOTE T) (CONS (CAR |l|) (|simpOrUnion1| |x| (CDR |l|)))))))) + (PROG (|p|) + (RETURN + (COND + ((NULL |l|) (CONS |x| NIL)) + ((SPADLET |p| (|mergeOr| |x| (CAR |l|))) (CONS |p| (CDR |l|))) + ('T (CONS (CAR |l|) (|simpOrUnion1| |x| (CDR |l|)))))))) ;mergeOr(x,y) == ; x is ['has,a,b] and y is ['has,=a,c] => @@ -1268,38 +1451,31 @@ ; nil (DEFUN |mergeOr| (|x| |y|) - (PROG (|a| |b| |ISTMP#1| |ISTMP#2| |c|) - (RETURN - (COND - ((AND - (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T)))))) - (PAIRP |y|) - (EQ (QCAR |y|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |a|) - (PROGN (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |c| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (PROG (|a| |b| |ISTMP#1| |ISTMP#2| |c|) + (RETURN (COND - ((|testExtend| |b| |c|) |y|) - ((|testExtend| |c| |b|) |x|) - ((QUOTE T) NIL))) - ((QUOTE T) NIL))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) 'T))))) + (PAIRP |y|) (EQ (QCAR |y|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |a|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |c| (QCAR |ISTMP#2|)) 'T)))))) + (COND + ((|testExtend| |b| |c|) |y|) + ((|testExtend| |c| |b|) |x|) + ('T NIL))) + ('T NIL))))) ;testExtend(a:=[op,:argl],b) == ; (u:= GETDATABASE(op,'ANCESTORS)) and (val:= LASSOC(b,u)) => @@ -1307,16 +1483,16 @@ ; nil (DEFUN |testExtend| (|a| |b|) - (PROG (|op| |argl| |u| |val|) - (RETURN - (PROGN - (SPADLET |op| (CAR |a|)) - (SPADLET |argl| (CDR |a|)) - (COND - ((AND (SPADLET |u| (GETDATABASE |op| (QUOTE ANCESTORS))) - (SPADLET |val| (LASSOC |b| |u|))) - (|formalSubstitute| |a| |val|)) - ((QUOTE T) NIL)))))) + (PROG (|op| |argl| |u| |val|) + (RETURN + (PROGN + (SPADLET |op| (CAR |a|)) + (SPADLET |argl| (CDR |a|)) + (COND + ((AND (SPADLET |u| (GETDATABASE |op| 'ANCESTORS)) + (SPADLET |val| (LASSOC |b| |u|))) + (|formalSubstitute| |a| |val|)) + ('T NIL)))))) ;getConstrCat(x) == ;-- gets a different representation of the constructorCategory from the @@ -1331,37 +1507,41 @@ ; cats (DEFUN |getConstrCat| (|x|) - (PROG (|y| |ISTMP#1| |z| |cats|) - (RETURN - (SEQ - (PROGN - (SPADLET |x| - (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |Join|)) - (PROGN (SPADLET |y| (QCDR |x|)) (QUOTE T))) - |y|) - ((QUOTE T) (CONS |x| NIL)))) - (SPADLET |cats| NIL) - (DO ((#0=#:G167152 |x| (CDR #0#)) (|y| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |y| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((AND (PAIRP |y|) - (EQ (QCAR |y|) (QUOTE CATEGORY)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |z| (QCDR |ISTMP#1|)) (QUOTE T))))) - (DO ((#1=#:G167161 |z| (CDR #1#)) (|zz| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |zz| (CAR #1#)) NIL)) NIL) - (SEQ - (EXIT (SPADLET |cats| (|makeCatPred| |zz| |cats| (QUOTE T))))))) - ((QUOTE T) (SPADLET |cats| (CONS |y| |cats|))))))) - (SPADLET |cats| (NREVERSE |cats|)) - |cats|))))) + (PROG (|y| |ISTMP#1| |z| |cats|) + (RETURN + (SEQ (PROGN + (SPADLET |x| + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Join|) + (PROGN (SPADLET |y| (QCDR |x|)) 'T)) + |y|) + ('T (CONS |x| NIL)))) + (SPADLET |cats| NIL) + (DO ((G167152 |x| (CDR G167152)) (|y| NIL)) + ((OR (ATOM G167152) + (PROGN (SETQ |y| (CAR G167152)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |y|) (EQ (QCAR |y|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |z| (QCDR |ISTMP#1|)) + 'T)))) + (DO ((G167161 |z| (CDR G167161)) + (|zz| NIL)) + ((OR (ATOM G167161) + (PROGN + (SETQ |zz| (CAR G167161)) + NIL)) + NIL) + (SEQ (EXIT + (SPADLET |cats| + (|makeCatPred| |zz| |cats| 'T)))))) + ('T (SPADLET |cats| (CONS |y| |cats|))))))) + (SPADLET |cats| (NREVERSE |cats|)) + |cats|))))) ;makeCatPred(zz, cats, thePred) == ; if zz is ['IF,curPred := ['has,z1,z2],ats,.] then @@ -1375,94 +1555,109 @@ ; cats (DEFUN |makeCatPred| (|zz| |cats| |thePred|) - (PROG (|ISTMP#2| |ISTMP#3| |z1| |ISTMP#4| |z2| |curPred| |ISTMP#5| - |ISTMP#6| |atl| |ats| |z3| |ISTMP#1| |pred|) - (RETURN - (SEQ - (PROGN - (COND - ((AND - (PAIRP |zz|) - (EQ (QCAR |zz|) (QUOTE IF)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |zz|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |z1| (QCAR |ISTMP#3|)) - (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) + (PROG (|ISTMP#2| |ISTMP#3| |z1| |ISTMP#4| |z2| |curPred| |ISTMP#5| + |ISTMP#6| |atl| |ats| |z3| |ISTMP#1| |pred|) + (RETURN + (SEQ (PROGN + (COND + ((AND (PAIRP |zz|) (EQ (QCAR |zz|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |zz|)) + (AND (PAIRP |ISTMP#1|) (PROGN - (SPADLET |z2| (QCAR |ISTMP#4|)) - (QUOTE T)))))))) - (PROGN (SPADLET |curPred| (QCAR |ISTMP#1|)) (QUOTE T)) - (PROGN - (SPADLET |ISTMP#5| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#5|) - (PROGN - (SPADLET |ats| (QCAR |ISTMP#5|)) - (SPADLET |ISTMP#6| (QCDR |ISTMP#5|)) - (AND (PAIRP |ISTMP#6|) (EQ (QCDR |ISTMP#6|) NIL)))))))) - (SPADLET |ats| - (COND - ((AND (PAIRP |ats|) - (EQ (QCAR |ats|) (QUOTE PROGN)) - (PROGN (SPADLET |atl| (QCDR |ats|)) (QUOTE T))) - |atl|) - ((QUOTE T) (CONS |ats| NIL)))) - (DO ((#0=#:G167257 |ats| (CDR #0#)) (|at| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |at| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (COND - ((AND - (PAIRP |at|) - (EQ (QCAR |at|) (QUOTE ATTRIBUTE)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |at|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |z3| (QCAR |ISTMP#1|)) (QUOTE T)))) - (NULL (ATOM |z3|)) (|constructor?| (CAR |z3|))) - (SPADLET |cats| - (CONS - (CONS - (QUOTE IF) - (CONS - (|quickAnd| - (CONS (QUOTE |has|) (CONS |z1| (CONS |z2| NIL))) |thePred|) - (CONS |z3| (CONS (QUOTE |noBranch|) NIL)))) - |cats|)))) - (COND - ((AND - (PAIRP |at|) - (EQ (QCAR |at|) (QUOTE IF)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |at|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |pred| (QCAR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |cats| (|makeCatPred| |at| |cats| |curPred|)))))))))) - |cats|))))) + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) '|has|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |z1| (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |z2| + (QCAR |ISTMP#4|)) + 'T))))))) + (PROGN + (SPADLET |curPred| (QCAR |ISTMP#1|)) + 'T) + (PROGN + (SPADLET |ISTMP#5| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#5|) + (PROGN + (SPADLET |ats| (QCAR |ISTMP#5|)) + (SPADLET |ISTMP#6| + (QCDR |ISTMP#5|)) + (AND (PAIRP |ISTMP#6|) + (EQ (QCDR |ISTMP#6|) NIL)))))))) + (SPADLET |ats| + (COND + ((AND (PAIRP |ats|) (EQ (QCAR |ats|) 'PROGN) + (PROGN + (SPADLET |atl| (QCDR |ats|)) + 'T)) + |atl|) + ('T (CONS |ats| NIL)))) + (DO ((G167257 |ats| (CDR G167257)) (|at| NIL)) + ((OR (ATOM G167257) + (PROGN (SETQ |at| (CAR G167257)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((AND (PAIRP |at|) + (EQ (QCAR |at|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |at|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |z3| + (QCAR |ISTMP#1|)) + 'T))) + (NULL (ATOM |z3|)) + (|constructor?| (CAR |z3|))) + (SPADLET |cats| + (CONS + (CONS 'IF + (CONS + (|quickAnd| + (CONS '|has| + (CONS |z1| + (CONS |z2| NIL))) + |thePred|) + (CONS |z3| + (CONS '|noBranch| NIL)))) + |cats|)))) + (COND + ((AND (PAIRP |at|) + (EQ (QCAR |at|) 'IF) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |at|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |cats| + (|makeCatPred| |at| |cats| + |curPred|)))))))))) + |cats|))))) ;getConstructorExports(conform,:options) == categoryParts(conform, ; GETDATABASE(opOf conform,'CONSTRUCTORCATEGORY),IFCAR options) -(DEFUN |getConstructorExports| (&REST #0=#:G167287 &AUX |options| |conform|) - (DSETQ (|conform| . |options|) #0#) - (|categoryParts| |conform| - (GETDATABASE (|opOf| |conform|) (QUOTE CONSTRUCTORCATEGORY)) - (IFCAR |options|))) +(DEFUN |getConstructorExports| + (&REST G167287 &AUX |options| |conform|) + (DSETQ (|conform| . |options|) G167287) + (|categoryParts| |conform| + (GETDATABASE (|opOf| |conform|) 'CONSTRUCTORCATEGORY) + (IFCAR |options|))) ;categoryParts(conform,category,:options) == main where ; main == @@ -1481,7 +1676,7 @@ ; res := SUBLISLIS($FormalMapVariableList,tvl,res) ; res ; build(item,pred) == -; item is ['SIGNATURE,op,sig,:.] => $oplist:= [[opOf op,sig,:pred],:$oplist] +; item is ['SIGNATURE,op,sig,:.] => $oplist := [[opOf op,sig,:pred],:$oplist] ; --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero) ; item is ['ATTRIBUTE,attr] => ; constructor? opOf attr => @@ -1507,179 +1702,175 @@ ; nil (DEFUN |categoryParts,exportsOf| (|target|) - (PROG (|ISTMP#1| |ISTMP#2| |f| |r|) - (RETURN - (SEQ - (IF - (AND - (PAIRP |target|) - (EQ (QCAR |target|) (QUOTE CATEGORY)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET |r| (QCDR |ISTMP#1|)) (QUOTE T))))) - (EXIT |r|)) - (IF - (AND - (PAIRP |target|) - (EQ (QCAR |target|) (QUOTE |Join|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) (QUOTE T))) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |f| (QCAR |ISTMP#2|)) - (SPADLET |r| (QCDR |ISTMP#2|)) - (QUOTE T))) - (PROGN (SPADLET |r| (NREVERSE |r|)) (QUOTE T))))) - (EXIT - (SEQ - (DO ((#0=#:G167385 |r| (CDR #0#)) (|x| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (SPADLET |$conslist| (CONS (CONS |x| (QUOTE T)) |$conslist|))))) - (EXIT (|categoryParts,exportsOf| |f|))))) - (SPADLET |$conslist| (CONS (CONS |target| (QUOTE T)) |$conslist|)) - (EXIT NIL))))) + (PROG (|ISTMP#1| |ISTMP#2| |f| |r|) + (declare (special |$conslist|)) + (RETURN + (SEQ (IF (AND (PAIRP |target|) (EQ (QCAR |target|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |r| (QCDR |ISTMP#1|)) 'T)))) + (EXIT |r|)) + (IF (AND (PAIRP |target|) (EQ (QCAR |target|) '|Join|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (REVERSE |ISTMP#1|)) + 'T)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |f| (QCAR |ISTMP#2|)) + (SPADLET |r| (QCDR |ISTMP#2|)) + 'T)) + (PROGN (SPADLET |r| (NREVERSE |r|)) 'T)))) + (EXIT (SEQ (DO ((G167385 |r| (CDR G167385)) + (|x| NIL)) + ((OR (ATOM G167385) + (PROGN + (SETQ |x| (CAR G167385)) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |$conslist| + (CONS (CONS |x| 'T) + |$conslist|))))) + (EXIT (|categoryParts,exportsOf| |f|))))) + (SPADLET |$conslist| (CONS (CONS |target| 'T) |$conslist|)) + (EXIT NIL))))) (DEFUN |categoryParts,build| (|item| |pred|) - (PROG (|sig| |attr| |op| |type| |ISTMP#1| |pred1| |ISTMP#2| - |s1| |ISTMP#3| |s2| |r|) - (RETURN - (SEQ - (IF - (AND - (PAIRP |item|) - (EQ (QCAR |item|) (QUOTE SIGNATURE)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |item|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |op| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN (SPADLET |sig| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (EXIT - (SPADLET |$oplist| - (CONS (CONS (|opOf| |op|) (CONS |sig| |pred|)) |$oplist|)))) - (IF - (AND - (PAIRP |item|) - (EQ (QCAR |item|) (QUOTE ATTRIBUTE)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |item|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |attr| (QCAR |ISTMP#1|)) (QUOTE T))))) - (EXIT - (SEQ - (IF - (|constructor?| (|opOf| |attr|)) - (EXIT - (SEQ - (SPADLET |$conslist| (CONS (CONS |attr| |pred|) |$conslist|)) - (EXIT NIL)))) - (IF (BOOT-EQUAL (|opOf| |attr|) (QUOTE |nothing|)) - (EXIT (QUOTE |skip|))) - (EXIT - (SPADLET |$attrlist| - (CONS - (CONS (|opOf| |attr|) (CONS (IFCDR |attr|) |pred|)) - |$attrlist|)))))) - (IF - (AND - (PAIRP |item|) - (EQ (QCAR |item|) (QUOTE TYPE)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |item|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |op| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |type| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (EXIT - (SPADLET |$oplist| - (CONS (CONS |op| (CONS (CONS |type| NIL) |pred|)) |$oplist|)))) - (IF - (AND - (PAIRP |item|) - (EQ (QCAR |item|) (QUOTE IF)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |item|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |pred1| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |s1| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN (SPADLET |s2| (QCAR |ISTMP#3|)) (QUOTE T))))))))) - (EXIT - (SEQ - (|categoryParts,build| |s1| (|quickAnd| |pred| |pred1|)) - (EXIT - (IF |s2| - (EXIT - (|categoryParts,build| |s2| - (|quickAnd| |pred| (CONS (QUOTE NOT) (CONS |pred1| NIL)))))))))) - (IF - (AND - (PAIRP |item|) - (EQ (QCAR |item|) (QUOTE PROGN)) - (PROGN (SPADLET |r| (QCDR |item|)) (QUOTE T))) - (EXIT - (DO ((#0=#:G167406 |r| (CDR #0#)) (|x| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) - (SEQ (EXIT (|categoryParts,build| |x| |pred|)))))) - (IF (|member| |item| (QUOTE (|noBranch|))) (EXIT (QUOTE |ok|))) - (IF (NULL |item|) (EXIT (QUOTE |ok|))) - (EXIT (|systemError| (MAKESTRING "build error"))))))) - -(DEFUN |categoryParts| (&REST #0=#:G167466 &AUX |options| |category| |conform|) - (DSETQ (|conform| |category| . |options|) #0#) - (PROG (|$attrlist| |$oplist| |$conslist| |cons?| |conname| |tvl| |res|) - (DECLARE (SPECIAL |$attrlist| |$oplist| |$conslist|)) - (RETURN - (SEQ - (PROGN - (SPADLET |cons?| (IFCAR |options|)) - (SPADLET |$attrlist| NIL) - (SPADLET |$oplist| NIL) - (SPADLET |$conslist| NIL) - (SPADLET |conname| (|opOf| |conform|)) - (DO ((#1=#:G167440 (|categoryParts,exportsOf| |category|) (CDR #1#)) - (|x| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) NIL) - (SEQ (EXIT (|categoryParts,build| |x| (QUOTE T))))) - (SPADLET |$attrlist| (|listSort| (|function| GLESSEQP) |$attrlist|)) - (SPADLET |$oplist| (|listSort| (|function| GLESSEQP) |$oplist|)) - (SPADLET |res| (CONS |$attrlist| |$oplist|)) - (COND - (|cons?| - (SPADLET |res| - (CONS (|listSort| (|function| GLESSEQP) |$conslist|) |res|)))) - (COND - ((BOOT-EQUAL (GETDATABASE |conname| (QUOTE CONSTRUCTORKIND)) - (QUOTE |category|)) - (SPADLET |tvl| (TAKE (|#| (CDR |conform|)) |$TriangleVariableList|)) - (SPADLET |res| (SUBLISLIS |$FormalMapVariableList| |tvl| |res|)))) - |res|))))) + (PROG (|sig| |attr| |op| |type| |ISTMP#1| |pred1| |ISTMP#2| |s1| + |ISTMP#3| |s2| |r|) + (declare (special |$oplist| |$attrlist| |$conslist|)) + (RETURN + (SEQ (IF (AND (PAIRP |item|) (EQ (QCAR |item|) 'SIGNATURE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |sig| (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT (SPADLET |$oplist| + (CONS (CONS (|opOf| |op|) + (CONS |sig| |pred|)) + |$oplist|)))) + (IF (AND (PAIRP |item|) (EQ (QCAR |item|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |attr| (QCAR |ISTMP#1|)) + 'T)))) + (EXIT (SEQ (IF (|constructor?| (|opOf| |attr|)) + (EXIT (SEQ + (SPADLET |$conslist| + (CONS (CONS |attr| |pred|) + |$conslist|)) + (EXIT NIL)))) + (IF (BOOT-EQUAL (|opOf| |attr|) '|nothing|) + (EXIT '|skip|)) + (EXIT (SPADLET |$attrlist| + (CONS + (CONS (|opOf| |attr|) + (CONS (IFCDR |attr|) |pred|)) + |$attrlist|)))))) + (IF (AND (PAIRP |item|) (EQ (QCAR |item|) 'TYPE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |type| (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT (SPADLET |$oplist| + (CONS (CONS |op| + (CONS (CONS |type| NIL) |pred|)) + |$oplist|)))) + (IF (AND (PAIRP |item|) (EQ (QCAR |item|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pred1| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |s1| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |s2| (QCAR |ISTMP#3|)) + 'T)))))))) + (EXIT (SEQ (|categoryParts,build| |s1| + (|quickAnd| |pred| |pred1|)) + (EXIT (IF |s2| + (EXIT + (|categoryParts,build| |s2| + (|quickAnd| |pred| + (CONS 'NOT (CONS |pred1| NIL)))))))))) + (IF (AND (PAIRP |item|) (EQ (QCAR |item|) 'PROGN) + (PROGN (SPADLET |r| (QCDR |item|)) 'T)) + (EXIT (DO ((G167406 |r| (CDR G167406)) (|x| NIL)) + ((OR (ATOM G167406) + (PROGN (SETQ |x| (CAR G167406)) NIL)) + NIL) + (SEQ (EXIT (|categoryParts,build| |x| |pred|)))))) + (IF (|member| |item| '(|noBranch|)) (EXIT '|ok|)) + (IF (NULL |item|) (EXIT '|ok|)) + (EXIT (|systemError| (MAKESTRING "build error"))))))) + +(DEFUN |categoryParts| + (&REST G167466 &AUX |options| |category| |conform|) + (DSETQ (|conform| |category| . |options|) G167466) + (PROG (|$attrlist| |$oplist| |$conslist| |cons?| |conname| |tvl| |res|) + (DECLARE (SPECIAL |$attrlist| |$oplist| |$conslist| + |$FormalMapVariableList| |$TriangleVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |cons?| (IFCAR |options|)) + (SPADLET |$attrlist| NIL) + (SPADLET |$oplist| NIL) + (SPADLET |$conslist| NIL) + (SPADLET |conname| (|opOf| |conform|)) + (DO ((G167440 (|categoryParts,exportsOf| |category|) + (CDR G167440)) + (|x| NIL)) + ((OR (ATOM G167440) + (PROGN (SETQ |x| (CAR G167440)) NIL)) + NIL) + (SEQ (EXIT (|categoryParts,build| |x| 'T)))) + (SPADLET |$attrlist| + (|listSort| (|function| GLESSEQP) |$attrlist|)) + (SPADLET |$oplist| + (|listSort| (|function| GLESSEQP) |$oplist|)) + (SPADLET |res| (CONS |$attrlist| |$oplist|)) + (COND + (|cons?| (SPADLET |res| + (CONS (|listSort| + (|function| GLESSEQP) + |$conslist|) + |res|)))) + (COND + ((BOOT-EQUAL (GETDATABASE |conname| 'CONSTRUCTORKIND) + '|category|) + (SPADLET |tvl| + (TAKE (|#| (CDR |conform|)) + |$TriangleVariableList|)) + (SPADLET |res| + (SUBLISLIS |$FormalMapVariableList| |tvl| + |res|)))) + |res|))))) ;--------------------> NEW DEFINITION (override in patches.lisp.pamphlet) ;compressHashTable ht == @@ -1691,17 +1882,19 @@ ; ht (DEFUN |compressHashTable| (|ht|) - (PROG (|$found|) - (DECLARE (SPECIAL |$found|)) - (RETURN - (SEQ - (PROGN - (|sayBrightlyNT| (MAKESTRING "compressing hash table...")) - (SPADLET |$found| (MAKE-HASHTABLE (QUOTE UEQUAL))) - (DO ((#0=#:G167471 (HKEYS |ht|) (CDR #0#)) (|x| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) - (SEQ (EXIT (|compressSexpr| (HGET |ht| |x|) NIL NIL)))) - (|sayBrightly| (MAKESTRING "done")) |ht|))))) + (PROG (|$found|) + (DECLARE (SPECIAL |$found|)) + (RETURN + (SEQ (PROGN + (|sayBrightlyNT| (MAKESTRING "compressing hash table...")) + (SPADLET |$found| (MAKE-HASHTABLE 'UEQUAL)) + (DO ((G167471 (HKEYS |ht|) (CDR G167471)) (|x| NIL)) + ((OR (ATOM G167471) + (PROGN (SETQ |x| (CAR G167471)) NIL)) + NIL) + (SEQ (EXIT (|compressSexpr| (HGET |ht| |x|) NIL NIL)))) + (|sayBrightly| (MAKESTRING "done")) + |ht|))))) ;compressSexpr(x,left,right) == ;-- recursive version of compressHashTable @@ -1715,19 +1908,18 @@ ; HPUT($found,x,x) (DEFUN |compressSexpr| (|x| |left| |right|) - (PROG (|u|) - (RETURN - (COND - ((ATOM |x|) NIL) - ((SPADLET |u| (HGET |$found| |x|)) - (COND - (|left| (RPLACA |left| |u|)) - (|right| (RPLACD |right| |u|)) - ((QUOTE T) NIL))) - ((QUOTE T) - (|compressSexpr| (CAR |x|) |x| NIL) - (|compressSexpr| (CDR |x|) NIL |x|) - (HPUT |$found| |x| |x|)))))) + (PROG (|u|) + (declare (special |$found|)) + (RETURN + (COND + ((ATOM |x|) NIL) + ((SPADLET |u| (HGET |$found| |x|)) + (COND + (|left| (RPLACA |left| |u|)) + (|right| (RPLACD |right| |u|)) + ('T NIL))) + ('T (|compressSexpr| (CAR |x|) |x| NIL) + (|compressSexpr| (CDR |x|) NIL |x|) (HPUT |$found| |x| |x|)))))) ;squeezeList(l) == ;-- changes the list l, so that is has maximal sharing of cells @@ -1735,9 +1927,9 @@ ; squeeze1 l (DEFUN |squeezeList| (|l|) - (PROG (|$found|) - (DECLARE (SPECIAL |$found|)) - (RETURN (PROGN (SPADLET |$found| NIL) (|squeeze1| |l|))))) + (PROG (|$found|) + (DECLARE (SPECIAL |$found|)) + (RETURN (PROGN (SPADLET |$found| NIL) (|squeeze1| |l|))))) ;squeeze1(l) == ;-- recursive version of squeezeList @@ -1757,23 +1949,26 @@ ; RPLACD(l,y) (DEFUN |squeeze1| (|l|) - (PROG (|x| |z| |y|) - (RETURN - (PROGN - (SPADLET |x| (CAR |l|)) - (SPADLET |y| - (COND - ((ATOM |x|) |x|) - ((SPADLET |z| (|member| |x| |$found|)) (CAR |z|)) - ((QUOTE T) (SPADLET |$found| (CONS |x| |$found|)) (|squeeze1| |x|)))) - (RPLACA |l| |y|) - (SPADLET |x| (CDR |l|)) - (SPADLET |y| - (COND - ((ATOM |x|) |x|) - ((SPADLET |z| (|member| |x| |$found|)) (CAR |z|)) - ((QUOTE T) (SPADLET |$found| (CONS |x| |$found|)) (|squeeze1| |x|)))) - (RPLACD |l| |y|))))) + (PROG (|x| |z| |y|) + (declare (special |$found|)) + (RETURN + (PROGN + (SPADLET |x| (CAR |l|)) + (SPADLET |y| + (COND + ((ATOM |x|) |x|) + ((SPADLET |z| (|member| |x| |$found|)) (CAR |z|)) + ('T (SPADLET |$found| (CONS |x| |$found|)) + (|squeeze1| |x|)))) + (RPLACA |l| |y|) + (SPADLET |x| (CDR |l|)) + (SPADLET |y| + (COND + ((ATOM |x|) |x|) + ((SPADLET |z| (|member| |x| |$found|)) (CAR |z|)) + ('T (SPADLET |$found| (CONS |x| |$found|)) + (|squeeze1| |x|)))) + (RPLACD |l| |y|))))) ;updateCategoryTable(cname,kind) == ; $newcompMode = true => nil @@ -1788,20 +1983,21 @@ ; GETDATABASE(cname,'CONSTRUCTORCATEGORY))) (DEFUN |updateCategoryTable| (|cname| |kind|) - (COND - ((BOOT-EQUAL |$newcompMode| (QUOTE T)) NIL) - (|$updateCatTableIfTrue| - (COND - ((BOOT-EQUAL |kind| (QUOTE |package|)) NIL) - ((BOOT-EQUAL |kind| (QUOTE |category|)) - (|updateCategoryTableForCategory| |cname|)) - ((QUOTE T) - (|updateCategoryTableForDomain| |cname| - (|getConstrCat| (GETDATABASE |cname| (QUOTE CONSTRUCTORCATEGORY))))))) - ((AND (BOOT-EQUAL |kind| (QUOTE |domain|)) - (BOOT-EQUAL |$NRTflag| (QUOTE T))) - (|updateCategoryTableForDomain| |cname| - (|getConstrCat| (GETDATABASE |cname| (QUOTE CONSTRUCTORCATEGORY))))))) + (declare (special |$NRTflag| |$updateCatTableIfTrue| |$newcompMode|)) + (COND + ((BOOT-EQUAL |$newcompMode| 'T) NIL) + (|$updateCatTableIfTrue| + (COND + ((BOOT-EQUAL |kind| '|package|) NIL) + ((BOOT-EQUAL |kind| '|category|) + (|updateCategoryTableForCategory| |cname|)) + ('T + (|updateCategoryTableForDomain| |cname| + (|getConstrCat| + (GETDATABASE |cname| 'CONSTRUCTORCATEGORY)))))) + ((AND (BOOT-EQUAL |kind| '|domain|) (BOOT-EQUAL |$NRTflag| 'T)) + (|updateCategoryTableForDomain| |cname| + (|getConstrCat| (GETDATABASE |cname| 'CONSTRUCTORCATEGORY)))))) ;updateCategoryTableForCategory(cname) == ; clearTempCategoryTable([[cname,'category]]) @@ -1811,24 +2007,34 @@ ; RPLACD(u,simpCatPredicate simpBool b) (DEFUN |updateCategoryTableForCategory| (|cname|) - (PROG (|b|) - (RETURN - (SEQ - (PROGN - (|clearTempCategoryTable| - (CONS (CONS |cname| (CONS (QUOTE |category|) NIL)) NIL)) - (|addToCategoryTable| |cname|) - (DO ((#0=#:G167523 (HKEYS *ANCESTORS-HASH*) (CDR #0#)) (|id| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |id| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (DO ((#1=#:G167533 (GETDATABASE |id| (QUOTE ANCESTORS)) (CDR #1#)) - (|u| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |u| (CAR #1#)) NIL) - (PROGN (PROGN (SPADLET |b| (CDR |u|)) |u|) NIL)) NIL) - (SEQ - (EXIT (RPLACD |u| (|simpCatPredicate| (|simpBool| |b|)))))))))))))) + (PROG (|b|) + (declare (special *ANCESTORS-HASH*)) + (RETURN + (SEQ (PROGN + (|clearTempCategoryTable| + (CONS (CONS |cname| (CONS '|category| NIL)) NIL)) + (|addToCategoryTable| |cname|) + (DO ((G167523 (HKEYS *ANCESTORS-HASH*) (CDR G167523)) + (|id| NIL)) + ((OR (ATOM G167523) + (PROGN (SETQ |id| (CAR G167523)) NIL)) + NIL) + (SEQ (EXIT (DO ((G167533 (GETDATABASE |id| 'ANCESTORS) + (CDR G167533)) + (|u| NIL)) + ((OR (ATOM G167533) + (PROGN + (SETQ |u| (CAR G167533)) + NIL) + (PROGN + (PROGN + (SPADLET |b| (CDR |u|)) + |u|) + NIL)) + NIL) + (SEQ (EXIT (RPLACD |u| + (|simpCatPredicate| + (|simpBool| |b|)))))))))))))) ;updateCategoryTableForDomain(cname,category) == ; clearCategoryTable(cname) @@ -1839,44 +2045,52 @@ ; compressHashTable _*HASCATEGORY_-HASH_* (DEFUN |updateCategoryTableForDomain| (|cname| |category|) - (PROG (|LETTMP#1| |domainEntry| |a| |b|) - (RETURN - (SEQ - (PROGN - (|clearCategoryTable| |cname|) - (SPADLET |LETTMP#1| (|addDomainToTable| |cname| |category|)) - (SPADLET |cname| (CAR |LETTMP#1|)) - (SPADLET |domainEntry| (CDR |LETTMP#1|)) - (DO ((#0=#:G167560 - (|encodeCategoryAlist| |cname| |domainEntry|) (CDR #0#)) - (#1=#:G167551 NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN (SPADLET |a| (CAR #1#)) (SPADLET |b| (CDR #1#)) #1#) - NIL)) - NIL) - (SEQ (EXIT (HPUT *HASCATEGORY-HASH* (CONS |cname| |a|) |b|)))) - (COND - ((BOOT-EQUAL |$doNotCompressHashTableIfTrue| (QUOTE T)) - *HASCATEGORY-HASH*) - ((QUOTE T) (|compressHashTable| *HASCATEGORY-HASH*)))))))) + (PROG (|LETTMP#1| |domainEntry| |a| |b|) + (declare (special |$doNotCompressHashTableIfTrue| *ANCESTORS-HASH* + *HASCATEGORY-HASH*)) + (RETURN + (SEQ (PROGN + (|clearCategoryTable| |cname|) + (SPADLET |LETTMP#1| + (|addDomainToTable| |cname| |category|)) + (SPADLET |cname| (CAR |LETTMP#1|)) + (SPADLET |domainEntry| (CDR |LETTMP#1|)) + (DO ((G167560 + (|encodeCategoryAlist| |cname| |domainEntry|) + (CDR G167560)) + (G167551 NIL)) + ((OR (ATOM G167560) + (PROGN (SETQ G167551 (CAR G167560)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G167551)) + (SPADLET |b| (CDR G167551)) + G167551) + NIL)) + NIL) + (SEQ (EXIT (HPUT *HASCATEGORY-HASH* (CONS |cname| |a|) + |b|)))) + (COND + ((BOOT-EQUAL |$doNotCompressHashTableIfTrue| 'T) + *HASCATEGORY-HASH*) + ('T (|compressHashTable| *HASCATEGORY-HASH*)))))))) ;clearCategoryTable($cname) == ; MAPHASH('clearCategoryTable1,_*HASCATEGORY_-HASH_*) (DEFUN |clearCategoryTable| (|$cname|) - (DECLARE (SPECIAL |$cname|)) - (MAPHASH (QUOTE |clearCategoryTable1|) *HASCATEGORY-HASH*)) + (DECLARE (SPECIAL |$cname| *HASCATEGORY-HASH*)) + (MAPHASH '|clearCategoryTable1| *HASCATEGORY-HASH*)) ;clearCategoryTable1(key,val) == ; (CAR key=$cname)=> HREM(_*HASCATEGORY_-HASH_*,key) ; nil (DEFUN |clearCategoryTable1| (|key| |val|) - (COND - ((BOOT-EQUAL (CAR |key|) |$cname|) (HREM *HASCATEGORY-HASH* |key|)) - ((QUOTE T) NIL))) + (declare (special |$cname| *HASCATEGORY-HASH*) (ignore |val|)) + (COND + ((BOOT-EQUAL (CAR |key|) |$cname|) (HREM *HASCATEGORY-HASH* |key|)) + ('T NIL))) ;clearTempCategoryTable(catNames) == ; for key in HKEYS(_*ANCESTORS_-HASH_*) repeat @@ -1889,33 +2103,42 @@ ; HPUT(_*ANCESTORS_-HASH_*,key,extensions) (DEFUN |clearTempCategoryTable| (|catNames|) - (PROG (|catForm| |extensions|) - (RETURN - (SEQ - (DO ((#0=#:G167592 (HKEYS *ANCESTORS-HASH*) (CDR #0#)) (|key| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |key| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((MEMQ |key| |catNames|) NIL) - ((QUOTE T) - (SPADLET |extensions| NIL) - (DO ((#1=#:G167602 (GETDATABASE |key| (QUOTE ANCESTORS)) (CDR #1#)) - (|extension| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |extension| (CAR #1#)) NIL) - (PROGN - (PROGN (SPADLET |catForm| (CAR |extension|)) |extension|) - NIL)) - NIL) - (SEQ - (EXIT - (COND - ((MEMQ (CAR |catForm|) |catNames|) NIL) - ((QUOTE T) - (SPADLET |extensions| (CONS |extension| |extensions|))))))) - (HPUT *ANCESTORS-HASH* |key| |extensions|)))))))))) - + (PROG (|catForm| |extensions|) + (declare (special *ANCESTORS-HASH*)) + (RETURN + (SEQ (DO ((G167592 (HKEYS *ANCESTORS-HASH*) (CDR G167592)) + (|key| NIL)) + ((OR (ATOM G167592) + (PROGN (SETQ |key| (CAR G167592)) NIL)) + NIL) + (SEQ (EXIT (COND + ((MEMQ |key| |catNames|) NIL) + ('T (SPADLET |extensions| NIL) + (DO ((G167602 + (GETDATABASE |key| 'ANCESTORS) + (CDR G167602)) + (|extension| NIL)) + ((OR (ATOM G167602) + (PROGN + (SETQ |extension| + (CAR G167602)) + NIL) + (PROGN + (PROGN + (SPADLET |catForm| + (CAR |extension|)) + |extension|) + NIL)) + NIL) + (SEQ (EXIT (COND + ((MEMQ (CAR |catForm|) + |catNames|) + NIL) + ('T + (SPADLET |extensions| + (CONS |extension| + |extensions|))))))) + (HPUT *ANCESTORS-HASH* |key| |extensions|)))))))))) @ \eject