diff --git a/changelog b/changelog index f2ae7de..c797884 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +20091009 tpd src/axiom-website/patches.html 20091009.01.tpd.patch +20091009 tpd src/interp/database.lisp cleanup 20091008 tpd src/axiom-website/patches.html 20091008.01.tpd.patch 20091008 tpd src/interp/format.lisp cleanup 20091007 tpd src/axiom-website/patches.html 20091007.06.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 5a4e3bc..ad75b54 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -2135,5 +2135,7 @@ src/interp/g-cndata.lisp cleanup
src/interp/g-boot.lisp cleanup
20091008.01.tpd.patch src/interp/format.lisp cleanup
+20091009.01.tpd.patch +src/interp/database.lisp cleanup
diff --git a/src/interp/database.lisp.pamphlet b/src/interp/database.lisp.pamphlet index cc633ce..f9b9756 100644 --- a/src/interp/database.lisp.pamphlet +++ b/src/interp/database.lisp.pamphlet @@ -12,9 +12,7 @@ <<*>>= (IN-PACKAGE "BOOT" ) -;SETANDFILEQ($getUnexposedOperations,true) - -(SETANDFILEQ |$getUnexposedOperations| (QUOTE T)) +(SETANDFILEQ |$getUnexposedOperations| 'T) ;--% Functions for manipulating MODEMAP DATABASE ;augLisplibModemapsFromCategory(form is [op,:argl],body,signature) == @@ -38,92 +36,122 @@ ; [[op,:interactiveModemapForm modemap],:$lisplibModemapAlist] (DEFUN |augLisplibModemapsFromCategory| (|form| |body| |signature|) - (PROG (|argl| |sl| |opAlist| |nonCategorySigAlist| |domainList| - |catPredList| |op| |sig| |pred| |sel| |pred'| |modemap|) - (RETURN - (SEQ - (PROGN - (SPADLET |op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (SPADLET |sl| - (CONS - (CONS (QUOTE $) (QUOTE *1)) - (PROG (#0=#:G166082) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166088 |argl| (CDR #1#)) - (|a| NIL) - (#2=#:G166089 (CDR |$PatternVariableList|) (CDR #2#)) - (|p| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |a| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |p| (CAR #2#)) NIL)) - (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (CONS |a| |p|) #0#))))))))) - (SPADLET |form| (SUBLIS |sl| |form|)) - (SPADLET |body| (SUBLIS |sl| |body|)) - (SPADLET |signature| (SUBLIS |sl| |signature|)) - (SPADLET |opAlist| (OR (SUBLIS |sl| (ELT |$domainShell| 1)) (RETURN NIL))) - (SPADLET |nonCategorySigAlist| - (|mkAlistOfExplicitCategoryOps| (MSUBST (QUOTE *1) (QUOTE $) |body|))) - (SPADLET |domainList| - (PROG (#3=#:G166104) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G166111 (CDR |form|) (CDR #4#)) - (|a| NIL) - (#5=#:G166112 (CDR |signature|) (CDR #5#)) - (|m| NIL)) - ((OR (ATOM #4#) - (PROGN (SETQ |a| (CAR #4#)) NIL) - (ATOM #5#) - (PROGN (SETQ |m| (CAR #5#)) NIL)) - (NREVERSE0 #3#)) - (SEQ - (EXIT - (COND - ((|isCategoryForm| |m| |$EmptyEnvironment|) - (SETQ #3# (CONS (CONS |a| (CONS |m| NIL)) #3#)))))))))) - (SPADLET |catPredList| - (PROG (#6=#:G166125) - (SPADLET #6# NIL) - (RETURN - (DO ((#7=#:G166130 - (CONS - (CONS (QUOTE *1) (CONS |form| NIL)) - |domainList|) - (CDR #7#)) - (|u| NIL)) - ((OR (ATOM #7#) (PROGN (SETQ |u| (CAR #7#)) NIL)) - (NREVERSE0 #6#)) - (SEQ (EXIT (SETQ #6# (CONS (CONS (QUOTE |ofCategory|) |u|) #6#)))))))) - (DO ((#8=#:G166144 |opAlist| (CDR #8#)) (|entry| NIL)) - ((OR (ATOM #8#) - (PROGN (SETQ |entry| (CAR #8#)) NIL) - (PROGN - (PROGN - (SPADLET |op| (CAAR |entry|)) - (SPADLET |sig| (CADAR |entry|)) - (SPADLET |pred| (CADR |entry|)) - (SPADLET |sel| (CADDR |entry|)) - |entry|) - NIL)) - NIL) - (SEQ - (EXIT - (COND - ((|member| |sig| (LASSOC |op| |nonCategorySigAlist|)) - (PROGN - (SPADLET |pred'| (MKPF (CONS |pred| |catPredList|) (QUOTE AND))) - (SPADLET |modemap| - (CONS - (CONS (QUOTE *1) |sig|) - (CONS (CONS |pred'| (CONS |sel| NIL)) NIL))) - (SPADLET |$lisplibModemapAlist| - (CONS - (CONS |op| (|interactiveModemapForm| |modemap|)) - |$lisplibModemapAlist|))))))))))))) + (PROG (|argl| |sl| |opAlist| |nonCategorySigAlist| |domainList| + |catPredList| |op| |sig| |pred| |sel| |pred'| + |modemap|) + (DECLARE (SPECIAL |$lisplibModemapAlist| |$EmptyEnvironment| + |$domainShell| |$PatternVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |sl| + (CONS (CONS '$ '*1) + (PROG (G166082) + (SPADLET G166082 NIL) + (RETURN + (DO ((G166088 |argl| (CDR G166088)) + (|a| NIL) + (G166089 + (CDR |$PatternVariableList|) + (CDR G166089)) + (|p| NIL)) + ((OR (ATOM G166088) + (PROGN + (SETQ |a| (CAR G166088)) + NIL) + (ATOM G166089) + (PROGN + (SETQ |p| (CAR G166089)) + NIL)) + (NREVERSE0 G166082)) + (SEQ (EXIT + (SETQ G166082 + (CONS (CONS |a| |p|) + G166082))))))))) + (SPADLET |form| (SUBLIS |sl| |form|)) + (SPADLET |body| (SUBLIS |sl| |body|)) + (SPADLET |signature| (SUBLIS |sl| |signature|)) + (SPADLET |opAlist| + (OR (SUBLIS |sl| (ELT |$domainShell| 1)) + (RETURN NIL))) + (SPADLET |nonCategorySigAlist| + (|mkAlistOfExplicitCategoryOps| + (MSUBST '*1 '$ |body|))) + (SPADLET |domainList| + (PROG (G166104) + (SPADLET G166104 NIL) + (RETURN + (DO ((G166111 (CDR |form|) (CDR G166111)) + (|a| NIL) + (G166112 (CDR |signature|) + (CDR G166112)) + (|m| NIL)) + ((OR (ATOM G166111) + (PROGN + (SETQ |a| (CAR G166111)) + NIL) + (ATOM G166112) + (PROGN + (SETQ |m| (CAR G166112)) + NIL)) + (NREVERSE0 G166104)) + (SEQ (EXIT (COND + ((|isCategoryForm| |m| + |$EmptyEnvironment|) + (SETQ G166104 + (CONS + (CONS |a| (CONS |m| NIL)) + G166104)))))))))) + (SPADLET |catPredList| + (PROG (G166125) + (SPADLET G166125 NIL) + (RETURN + (DO ((G166130 + (CONS (CONS '*1 (CONS |form| NIL)) + |domainList|) + (CDR G166130)) + (|u| NIL)) + ((OR (ATOM G166130) + (PROGN + (SETQ |u| (CAR G166130)) + NIL)) + (NREVERSE0 G166125)) + (SEQ (EXIT (SETQ G166125 + (CONS (CONS '|ofCategory| |u|) + G166125)))))))) + (DO ((G166144 |opAlist| (CDR G166144)) (|entry| NIL)) + ((OR (ATOM G166144) + (PROGN (SETQ |entry| (CAR G166144)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAAR |entry|)) + (SPADLET |sig| (CADAR |entry|)) + (SPADLET |pred| (CADR |entry|)) + (SPADLET |sel| (CADDR |entry|)) + |entry|) + NIL)) + NIL) + (SEQ (EXIT (COND + ((|member| |sig| + (LASSOC |op| |nonCategorySigAlist|)) + (PROGN + (SPADLET |pred'| + (MKPF + (CONS |pred| |catPredList|) + 'AND)) + (SPADLET |modemap| + (CONS (CONS '*1 |sig|) + (CONS + (CONS |pred'| + (CONS |sel| NIL)) + NIL))) + (SPADLET |$lisplibModemapAlist| + (CONS + (CONS |op| + (|interactiveModemapForm| + |modemap|)) + |$lisplibModemapAlist|))))))))))))) ;augmentLisplibModemapsFromFunctor(form,opAlist,signature) == ; form:= [formOp,:argl]:= formal2Pattern form @@ -159,128 +187,178 @@ ; $lisplibModemapAlist:= [[op,:interactiveModemapForm modemap], ; :$lisplibModemapAlist] -(DEFUN |augmentLisplibModemapsFromFunctor| (|form| |opAlist| |signature|) - (PROG (|LETTMP#1| |formOp| |argl| |nonCategorySigAlist| |op| |pred| |sel| - |patternList| |predList| |sig| |pred'| |l| |skip| |modemap|) - (RETURN - (SEQ - (PROGN - (SPADLET |form| - (PROGN - (SPADLET |LETTMP#1| (|formal2Pattern| |form|)) - (SPADLET |formOp| (CAR |LETTMP#1|)) - (SPADLET |argl| (CDR |LETTMP#1|)) - |LETTMP#1|)) - (SPADLET |opAlist| (|formal2Pattern| |opAlist|)) - (SPADLET |signature| (|formal2Pattern| |signature|)) - (DO ((#0=#:G166194 |form| (CDR #0#)) - (|u| NIL) - (#1=#:G166195 |signature| (CDR #1#)) - (|v| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |u| (CAR #0#)) NIL) - (ATOM #1#) - (PROGN (SETQ |v| (CAR #1#)) NIL)) - NIL) - (SEQ - (EXIT - (COND - ((MEMQ |u| |$PatternVariableList|) - (SPADLET |$e| (|put| |u| (QUOTE |mode|) |v| |$e|))) - ((QUOTE T) NIL))))) - (SPADLET |nonCategorySigAlist| - (OR (|mkAlistOfExplicitCategoryOps| (CAR |signature|)) (RETURN NIL))) - (DO ((#2=#:G166219 |opAlist| (CDR #2#)) (|entry| NIL)) - ((OR (ATOM #2#) - (PROGN (SETQ |entry| (CAR #2#)) NIL) - (PROGN - (PROGN - (SPADLET |op| (CAAR |entry|)) - (SPADLET |sig| (CADAR |entry|)) - (SPADLET |pred| (CADR |entry|)) - (SPADLET |sel| (CADDR |entry|)) - |entry|) - NIL)) - NIL) - (SEQ - (EXIT - (COND - ((PROG (#3=#:G166226) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G166232 NIL #3#) - (#5=#:G166233 - (|allLASSOCs| |op| |nonCategorySigAlist|) (CDR #5#)) - (|catSig| NIL)) - ((OR #4# (ATOM #5#) (PROGN (SETQ |catSig| (CAR #5#)) NIL)) #3#) - (SEQ (EXIT (SETQ #3# (OR #3# (|member| |sig| |catSig|)))))))) - (PROGN - (SPADLET |skip| - (COND - ((AND |argl| (CONTAINED (QUOTE $) (CDR |sig|))) (QUOTE SKIP)) - ((QUOTE T) NIL))) - (SPADLET |sel| (MSUBST |form| (QUOTE $) |sel|)) - (SPADLET |patternList| (|listOfPatternIds| |sig|)) - (SPADLET |predList| - (PROG (#6=#:G166246) - (SPADLET #6# NIL) - (RETURN - (DO ((#7=#:G166253 |argl| (CDR #7#)) - (|a| NIL) - (#8=#:G166254 (CDR |signature|) (CDR #8#)) - (|m| NIL)) - ((OR (ATOM #7#) - (PROGN (SETQ |a| (CAR #7#)) NIL) - (ATOM #8#) - (PROGN (SETQ |m| (CAR #8#)) NIL)) - (NREVERSE0 #6#)) - (SEQ - (EXIT - (COND - ((MEMQ |a| |$PatternVariableList|) - (SETQ #6# (CONS (CONS |a| (CONS |m| NIL)) #6#)))))))))) - (SPADLET |sig| (MSUBST |form| (QUOTE $) |sig|)) - (SPADLET |pred'| - (MKPF - (CONS - |pred| - (PROG (#9=#:G166267) - (SPADLET #9# NIL) - (RETURN - (DO ((#10=#:G166272 |predList| (CDR #10#)) (|y| NIL)) - ((OR (ATOM #10#) - (PROGN (SETQ |y| (CAR #10#)) NIL)) - (NREVERSE0 #9#)) - (SEQ - (EXIT - (SETQ #9# (CONS (|mkDatabasePred| |y|) #9#)))))))) - (QUOTE AND))) - (SPADLET |l| (|listOfPatternIds| |predList|)) - (COND - ((PROG (#11=#:G166278) - (SPADLET #11# NIL) - (RETURN - (DO ((#12=#:G166284 NIL #11#) - (#13=#:G166285 |argl| (CDR #13#)) - (|u| NIL)) - ((OR #12# - (ATOM #13#) - (PROGN (SETQ |u| (CAR #13#)) NIL)) - #11#) - (SEQ (EXIT (SETQ #11# (OR #11# (NULL (MEMQ |u| |l|))))))))) - (|sayMSG| - (CONS - "cannot handle modemap for" - (APPEND (|bright| |op|) (CONS "by pattern match" NIL)))) - (SPADLET |skip| (QUOTE SKIP)))) - (SPADLET |modemap| - (CONS - (CONS |form| |sig|) - (CONS (CONS |pred'| (CONS |sel| |skip|)) NIL))) - (SPADLET |$lisplibModemapAlist| - (CONS - (CONS |op| (|interactiveModemapForm| |modemap|)) - |$lisplibModemapAlist|))))))))))))) +(DEFUN |augmentLisplibModemapsFromFunctor| + (|form| |opAlist| |signature|) + (PROG (|LETTMP#1| |formOp| |argl| |nonCategorySigAlist| |op| |pred| + |sel| |patternList| |predList| |sig| |pred'| |l| |skip| + |modemap|) + (DECLARE (SPECIAL |$lisplibModemapAlist| |$PatternVariableList| + |$e|)) + (RETURN + (SEQ (PROGN + (SPADLET |form| + (PROGN + (SPADLET |LETTMP#1| (|formal2Pattern| |form|)) + (SPADLET |formOp| (CAR |LETTMP#1|)) + (SPADLET |argl| (CDR |LETTMP#1|)) + |LETTMP#1|)) + (SPADLET |opAlist| (|formal2Pattern| |opAlist|)) + (SPADLET |signature| (|formal2Pattern| |signature|)) + (DO ((G166194 |form| (CDR G166194)) (|u| NIL) + (G166195 |signature| (CDR G166195)) (|v| NIL)) + ((OR (ATOM G166194) + (PROGN (SETQ |u| (CAR G166194)) NIL) + (ATOM G166195) + (PROGN (SETQ |v| (CAR G166195)) NIL)) + NIL) + (SEQ (EXIT (COND + ((MEMQ |u| |$PatternVariableList|) + (SPADLET |$e| + (|put| |u| '|mode| |v| |$e|))) + ('T NIL))))) + (SPADLET |nonCategorySigAlist| + (OR (|mkAlistOfExplicitCategoryOps| + (CAR |signature|)) + (RETURN NIL))) + (DO ((G166219 |opAlist| (CDR G166219)) (|entry| NIL)) + ((OR (ATOM G166219) + (PROGN (SETQ |entry| (CAR G166219)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAAR |entry|)) + (SPADLET |sig| (CADAR |entry|)) + (SPADLET |pred| (CADR |entry|)) + (SPADLET |sel| (CADDR |entry|)) + |entry|) + NIL)) + NIL) + (SEQ (EXIT (COND + ((PROG (G166226) + (SPADLET G166226 NIL) + (RETURN + (DO ((G166232 NIL G166226) + (G166233 + (|allLASSOCs| |op| + |nonCategorySigAlist|) + (CDR G166233)) + (|catSig| NIL)) + ((OR G166232 (ATOM G166233) + (PROGN + (SETQ |catSig| + (CAR G166233)) + NIL)) + G166226) + (SEQ + (EXIT + (SETQ G166226 + (OR G166226 + (|member| |sig| |catSig|)))))))) + (PROGN + (SPADLET |skip| + (COND + ((AND |argl| + (CONTAINED '$ (CDR |sig|))) + 'SKIP) + ('T NIL))) + (SPADLET |sel| (MSUBST |form| '$ |sel|)) + (SPADLET |patternList| + (|listOfPatternIds| |sig|)) + (SPADLET |predList| + (PROG (G166246) + (SPADLET G166246 NIL) + (RETURN + (DO + ((G166253 |argl| + (CDR G166253)) + (|a| NIL) + (G166254 + (CDR |signature|) + (CDR G166254)) + (|m| NIL)) + ((OR (ATOM G166253) + (PROGN + (SETQ |a| + (CAR G166253)) + NIL) + (ATOM G166254) + (PROGN + (SETQ |m| + (CAR G166254)) + NIL)) + (NREVERSE0 G166246)) + (SEQ + (EXIT + (COND + ((MEMQ |a| + |$PatternVariableList|) + (SETQ G166246 + (CONS + (CONS |a| + (CONS |m| NIL)) + G166246)))))))))) + (SPADLET |sig| (MSUBST |form| '$ |sig|)) + (SPADLET |pred'| + (MKPF + (CONS |pred| + (PROG (G166267) + (SPADLET G166267 NIL) + (RETURN + (DO + ((G166272 |predList| + (CDR G166272)) + (|y| NIL)) + ((OR (ATOM G166272) + (PROGN + (SETQ |y| + (CAR G166272)) + NIL)) + (NREVERSE0 G166267)) + (SEQ + (EXIT + (SETQ G166267 + (CONS + (|mkDatabasePred| + |y|) + G166267)))))))) + 'AND)) + (SPADLET |l| + (|listOfPatternIds| |predList|)) + (COND + ((PROG (G166278) + (SPADLET G166278 NIL) + (RETURN + (DO + ((G166284 NIL G166278) + (G166285 |argl| + (CDR G166285)) + (|u| NIL)) + ((OR G166284 (ATOM G166285) + (PROGN + (SETQ |u| (CAR G166285)) + NIL)) + G166278) + (SEQ + (EXIT + (SETQ G166278 + (OR G166278 + (NULL (MEMQ |u| |l|))))))))) + (|sayMSG| + (CONS "cannot handle modemap for" + (APPEND (|bright| |op|) + (CONS "by pattern match" NIL)))) + (SPADLET |skip| 'SKIP))) + (SPADLET |modemap| + (CONS (CONS |form| |sig|) + (CONS + (CONS |pred'| + (CONS |sel| |skip|)) + NIL))) + (SPADLET |$lisplibModemapAlist| + (CONS + (CONS |op| + (|interactiveModemapForm| + |modemap|)) + |$lisplibModemapAlist|))))))))))))) ;buildDatabase(filemode,expensive) == ; $InteractiveMode: local:= true @@ -310,35 +388,37 @@ ; buildGloss() (DEFUN |buildDatabase| (|filemode| |expensive|) - (PROG (|$InteractiveMode|) - (DECLARE (SPECIAL |$InteractiveMode|)) - (RETURN - (PROGN - (SPADLET |$InteractiveMode| (QUOTE T)) - (SPADLET |$constructorList| NIL) - (SPADLET |$ConstructorCache| (MAKE-HASHTABLE (QUOTE ID))) - (SAY (MAKESTRING "Making constructor autoload")) - (|makeConstructorsAutoLoad|) - (SAY (MAKESTRING "Building category table")) - (|genCategoryTable|) - (SAY (MAKESTRING "Building libdb.text")) - (|buildLibdb|) - (SAY (MAKESTRING "splitting libdb.text")) - (|dbSplitLibdb|) - (SAY (MAKESTRING "creating browse constructor index")) - (|dbAugmentConstructorDataTable|) - (SAY (MAKESTRING "Building browse.lisp")) - (|buildBrowsedb|) - (SAY (MAKESTRING "Building constructor users database")) - (|mkUsersHashTable|) - (SAY (MAKESTRING "Saving constructor users database")) - (|saveUsersHashTable|) - (SAY (MAKESTRING "Building constructor dependents database")) - (|mkDependentsHashTable|) - (SAY (MAKESTRING "Saving constructor dependents database")) - (|saveDependentsHashTable|) - (SAY (MAKESTRING "Building glossary files")) - (|buildGloss|))))) + (declare (ignore |filemode| |expensive|)) + (PROG (|$InteractiveMode|) + (DECLARE (SPECIAL |$InteractiveMode| |$ConstructorCache| + |$constructorList|)) + (RETURN + (PROGN + (SPADLET |$InteractiveMode| 'T) + (SPADLET |$constructorList| NIL) + (SPADLET |$ConstructorCache| (MAKE-HASHTABLE 'ID)) + (SAY (MAKESTRING "Making constructor autoload")) + (|makeConstructorsAutoLoad|) + (SAY (MAKESTRING "Building category table")) + (|genCategoryTable|) + (SAY (MAKESTRING "Building libdb.text")) + (|buildLibdb|) + (SAY (MAKESTRING "splitting libdb.text")) + (|dbSplitLibdb|) + (SAY (MAKESTRING "creating browse constructor index")) + (|dbAugmentConstructorDataTable|) + (SAY (MAKESTRING "Building browse.lisp")) + (|buildBrowsedb|) + (SAY (MAKESTRING "Building constructor users database")) + (|mkUsersHashTable|) + (SAY (MAKESTRING "Saving constructor users database")) + (|saveUsersHashTable|) + (SAY (MAKESTRING "Building constructor dependents database")) + (|mkDependentsHashTable|) + (SAY (MAKESTRING "Saving constructor dependents database")) + (|saveDependentsHashTable|) + (SAY (MAKESTRING "Building glossary files")) + (|buildGloss|))))) ;saveUsersHashTable() == ; _$ERASE('users,'DATABASE,'a) @@ -347,18 +427,21 @@ ; rwrite(k, HGET($usersTb, k), stream) ; RSHUT stream -(DEFUN |saveUsersHashTable| () - (PROG (|stream|) - (RETURN - (SEQ - (PROGN - ($ERASE (QUOTE |users|) (QUOTE DATABASE) (QUOTE |a|)) - (SPADLET |stream| - (|writeLib1| (QUOTE |users|) (QUOTE DATABASE) (QUOTE |a|))) - (DO ((#0=#:G166334 (MSORT (HKEYS |$usersTb|)) (CDR #0#)) (|k| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |k| (CAR #0#)) NIL)) NIL) - (SEQ (EXIT (|rwrite| |k| (HGET |$usersTb| |k|) |stream|)))) - (RSHUT |stream|)))))) +(DEFUN |saveUsersHashTable| () + (PROG (|stream|) + (DECLARE (SPECIAL |$usersTb| $ERASE)) + (RETURN + (SEQ (PROGN + ($ERASE '|users| 'DATABASE '|a|) + (SPADLET |stream| (|writeLib1| '|users| 'DATABASE '|a|)) + (DO ((G166334 (MSORT (HKEYS |$usersTb|)) + (CDR G166334)) + (|k| NIL)) + ((OR (ATOM G166334) + (PROGN (SETQ |k| (CAR G166334)) NIL)) + NIL) + (SEQ (EXIT (|rwrite| |k| (HGET |$usersTb| |k|) |stream|)))) + (RSHUT |stream|)))))) ;saveDependentsHashTable() == ; _$ERASE('dependents,'DATABASE,'a) @@ -368,17 +451,20 @@ ; RSHUT stream (DEFUN |saveDependentsHashTable| () - (PROG (|stream|) - (RETURN - (SEQ - (PROGN - ($ERASE (QUOTE |dependents|) (QUOTE DATABASE) (QUOTE |a|)) - (SPADLET |stream| - (|writeLib1| (QUOTE |dependents|) (QUOTE DATABASE) (QUOTE |a|))) - (DO ((#0=#:G166348 (MSORT (HKEYS |$depTb|)) (CDR #0#)) (|k| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |k| (CAR #0#)) NIL)) NIL) - (SEQ (EXIT (|rwrite| |k| (HGET |$depTb| |k|) |stream|)))) - (RSHUT |stream|)))))) + (PROG (|stream|) + (DECLARE (SPECIAL |$depTb| $ERASE)) + (RETURN + (SEQ (PROGN + ($ERASE '|dependents| 'DATABASE '|a|) + (SPADLET |stream| + (|writeLib1| '|dependents| 'DATABASE '|a|)) + (DO ((G166348 (MSORT (HKEYS |$depTb|)) (CDR G166348)) + (|k| NIL)) + ((OR (ATOM G166348) + (PROGN (SETQ |k| (CAR G166348)) NIL)) + NIL) + (SEQ (EXIT (|rwrite| |k| (HGET |$depTb| |k|) |stream|)))) + (RSHUT |stream|)))))) ;getUsersOfConstructor(con) == ; stream := readLib1('users, 'DATABASE, 'a) @@ -387,13 +473,14 @@ ; val (DEFUN |getUsersOfConstructor| (|con|) - (PROG (|stream| |val|) - (RETURN - (PROGN - (SPADLET |stream| - (|readLib1| (QUOTE |users|) (QUOTE DATABASE) (QUOTE |a|))) - (SPADLET |val| (|rread| |con| |stream| NIL)) - (RSHUT |stream|) |val|)))) + (PROG (|stream| |val|) + (RETURN + (PROGN + (SPADLET |stream| (|readLib1| '|users| 'DATABASE '|a|)) + (SPADLET |val| (|rread| |con| |stream| NIL)) + (RSHUT |stream|) + |val|)))) + ;getDependentsOfConstructor(con) == ; stream := readLib1('dependents, 'DATABASE, 'a) ; val := rread(con, stream, nil) @@ -401,14 +488,13 @@ ; val (DEFUN |getDependentsOfConstructor| (|con|) - (PROG (|stream| |val|) - (RETURN - (PROGN - (SPADLET |stream| - (|readLib1| (QUOTE |dependents|) (QUOTE DATABASE) (QUOTE |a|))) - (SPADLET |val| (|rread| |con| |stream| NIL)) - (RSHUT |stream|) - |val|)))) + (PROG (|stream| |val|) + (RETURN + (PROGN + (SPADLET |stream| (|readLib1| '|dependents| 'DATABASE '|a|)) + (SPADLET |val| (|rread| |con| |stream| NIL)) + (RSHUT |stream|) + |val|)))) ;orderPredicateItems(pred1,sig,skip) == ; pred:= signatureTran pred1 @@ -416,16 +502,15 @@ ; pred (DEFUN |orderPredicateItems| (|pred1| |sig| |skip|) - (PROG (|pred| |l|) - (RETURN - (PROGN - (SPADLET |pred| (|signatureTran| |pred1|)) - (COND - ((AND (PAIRP |pred|) - (EQ (QCAR |pred|) (QUOTE AND)) - (PROGN (SPADLET |l| (QCDR |pred|)) (QUOTE T))) - (|orderPredTran| |l| |sig| |skip|)) - ((QUOTE T) |pred|)))))) + (PROG (|pred| |l|) + (RETURN + (PROGN + (SPADLET |pred| (|signatureTran| |pred1|)) + (COND + ((AND (PAIRP |pred|) (EQ (QCAR |pred|) 'AND) + (PROGN (SPADLET |l| (QCDR |pred|)) 'T)) + (|orderPredTran| |l| |sig| |skip|)) + ('T |pred|)))))) ;orderPredTran(oldList,sig,skip) == ; lastPreds:=nil @@ -502,261 +587,342 @@ ; answer := [['AND,:newList],:INTERSECTIONQ(fullDependList,sig)] (DEFUN |orderPredTran| (|oldList| |sig| |skip|) - (PROG (|op| |pvar| |lastDependList| |somethingDone| |lastPreds| |v| |body| - |indepvl| |depvl| |dependList| |noldList| |ISTMP#1| |x| |ISTMP#2| - |y| |ids| |fullDependList| |newList| |answer|) - (RETURN - (SEQ - (PROGN - (SPADLET |lastPreds| NIL) - (SEQ - (DO ((#0=#:G166547 |oldList| (CDR #0#)) (|pred| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |pred| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((OR - (AND - (PAIRP |pred|) - (PROGN - (SPADLET |op| (QCAR |pred|)) - (SPADLET |ISTMP#1| (QCDR |pred|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |pvar| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL))))) - (MEMQ |op| (QUOTE (|isDomain| |ofCategory|))) - (BOOT-EQUAL |pvar| (CAR |sig|)) - (NULL (|member| |pvar| (CDR |sig|)))) - (AND - (NULL |skip|) - (PAIRP |pred|) - (EQ (QCAR |pred|) (QUOTE |isDomain|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |pred|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |pvar| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL))))) - (BOOT-EQUAL |pvar| (QUOTE *1)))) - (EXIT - (PROGN - (SPADLET |oldList| (|delete| |pred| |oldList|)) - (SPADLET |lastPreds| (CONS |pred| |lastPreds|))))))))) - (SPADLET |lastDependList| - (PROG (#1=#:G166553) - (SPADLET #1# NIL) - (RETURN - (DO ((#2=#:G166558 |lastPreds| (CDR #2#)) (|x| NIL)) - ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #1#) - (SEQ (EXIT (SETQ #1# (UNIONQ #1# (|listOfPatternIds| |x|))))))))) - (SPADLET |dependList| - (PROG (#3=#:G166564) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G166570 |oldList| (CDR #4#)) (|x| NIL)) - ((OR (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) #3#) - (SEQ - (EXIT - (COND - ((OR - (AND - (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |isDomain|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (AND - (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |ofCategory|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T)))))))) - (SETQ #3# (UNIONQ #3# (|listOfPatternIds| |y|))))))))))) - (DO ((#5=#:G166598 |oldList| (CDR #5#)) (|x| NIL)) - ((OR (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (COND - ((OR - (AND - (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |ofCategory|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |v| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |body| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (AND - (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |isDomain|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |v| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |body| (QCAR |ISTMP#2|)) (QUOTE T)))))))) - (SPADLET |indepvl| (|listOfPatternIds| |v|)) - (SPADLET |depvl| (|listOfPatternIds| |body|))) - ((QUOTE T) - (SPADLET |indepvl| (|listOfPatternIds| |x|)) - (SPADLET |depvl| NIL))) - (COND - ((AND - (NULL (INTERSECTIONQ |indepvl| |dependList|)) - (INTERSECTIONQ |indepvl| |lastDependList|)) - (PROGN - (SPADLET |somethingDone| (QUOTE T)) - (SPADLET |lastPreds| (APPEND |lastPreds| (CONS |x| NIL))) - (SPADLET |oldList| (|delete| |x| |oldList|))))))))) - (DO () - ((NULL |oldList|) NIL) - (SEQ - (EXIT - (PROGN - (DO - ((#6=#:G166651 |oldList| (CDR #6#)) (|x| NIL)) - ((OR (ATOM #6#) (PROGN (SETQ |x| (CAR #6#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (COND - ((OR - (AND - (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |ofCategory|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |v| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |body| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (AND - (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |isDomain|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |v| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |body| (QCAR |ISTMP#2|)) - (QUOTE T)))))))) - (SPADLET |indepvl| (|listOfPatternIds| |v|)) - (SPADLET |depvl| (|listOfPatternIds| |body|))) - ((QUOTE T) - (SPADLET |indepvl| (|listOfPatternIds| |x|)) - (SPADLET |depvl| NIL))) - (COND - ((NULL (INTERSECTIONQ |indepvl| |dependList|)) - (PROGN - (SPADLET |dependList| (SETDIFFERENCE |dependList| |depvl|)) - (SPADLET |newList| (APPEND |newList| (CONS |x| NIL)))))))))) - (COND - ((BOOT-EQUAL - (SPADLET |noldList| (SETDIFFERENCE |oldList| |newList|)) - |oldList|) - (SPADLET |newList| (APPEND |newList| |oldList|)) (RETURN NIL)) - ((QUOTE T) (SPADLET |oldList| |noldList|))))))) - (DO ((#7=#:G166674 |newList| (CDR #7#)) (|pred| NIL)) - ((OR (ATOM #7#) (PROGN (SETQ |pred| (CAR #7#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((OR - (AND - (PAIRP |pred|) - (EQ (QCAR |pred|) (QUOTE |isDomain|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |pred|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (AND - (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |ofCategory|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T)))))))) - (SPADLET |ids| (|listOfPatternIds| |y|)) - (COND - ((PROG (#8=#:G166680) - (SPADLET #8# (QUOTE T)) - (RETURN - (DO ((#9=#:G166686 NIL (NULL #8#)) - (#10=#:G166687 |ids| (CDR #10#)) - (|id| NIL)) - ((OR #9# - (ATOM #10#) - (PROGN (SETQ |id| (CAR #10#)) NIL)) - #8#) - (SEQ - (EXIT - (SETQ #8# (AND #8# (|member| |id| |fullDependList|)))))))) - (SPADLET |fullDependList| (|insertWOC| |x| |fullDependList|)))) - (SPADLET |fullDependList| (UNIONQ |fullDependList| |ids|))) - ((QUOTE T) NIL))))) - (SPADLET |newList| (APPEND |newList| |lastPreds|)) - (SPADLET |newList| (|isDomainSubst| |newList|)) - (SPADLET |answer| - (CONS - (CONS (QUOTE AND) |newList|) - (INTERSECTIONQ |fullDependList| |sig|))))))))) - + (PROG (|op| |pvar| |lastDependList| |somethingDone| |lastPreds| |v| + |body| |indepvl| |depvl| |dependList| |noldList| + |ISTMP#1| |x| |ISTMP#2| |y| |ids| |fullDependList| + |newList| |answer|) + (RETURN + (SEQ (PROGN + (SPADLET |lastPreds| NIL) + (SEQ (DO ((G166547 |oldList| (CDR G166547)) + (|pred| NIL)) + ((OR (ATOM G166547) + (PROGN (SETQ |pred| (CAR G166547)) NIL)) + NIL) + (SEQ (EXIT (COND + ((OR (AND (PAIRP |pred|) + (PROGN + (SPADLET |op| (QCAR |pred|)) + (SPADLET |ISTMP#1| + (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pvar| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL))))) + (MEMQ |op| + '(|isDomain| |ofCategory|)) + (BOOT-EQUAL |pvar| (CAR |sig|)) + (NULL + (|member| |pvar| (CDR |sig|)))) + (AND (NULL |skip|) (PAIRP |pred|) + (EQ (QCAR |pred|) '|isDomain|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pvar| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL))))) + (BOOT-EQUAL |pvar| '*1))) + (EXIT (PROGN + (SPADLET |oldList| + (|delete| |pred| |oldList|)) + (SPADLET |lastPreds| + (CONS |pred| |lastPreds|))))))))) + (SPADLET |lastDependList| + (PROG (G166553) + (SPADLET G166553 NIL) + (RETURN + (DO ((G166558 |lastPreds| + (CDR G166558)) + (|x| NIL)) + ((OR (ATOM G166558) + (PROGN + (SETQ |x| (CAR G166558)) + NIL)) + G166553) + (SEQ (EXIT + (SETQ G166553 + (UNIONQ G166553 + (|listOfPatternIds| |x|))))))))) + (SPADLET |dependList| + (PROG (G166564) + (SPADLET G166564 NIL) + (RETURN + (DO ((G166570 |oldList| + (CDR G166570)) + (|x| NIL)) + ((OR (ATOM G166570) + (PROGN + (SETQ |x| (CAR G166570)) + NIL)) + G166564) + (SEQ (EXIT + (COND + ((OR + (AND (PAIRP |x|) + (EQ (QCAR |x|) '|isDomain|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |y| + (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |x|) + (EQ (QCAR |x|) + '|ofCategory|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |y| + (QCAR |ISTMP#2|)) + 'T))))))) + (SETQ G166564 + (UNIONQ G166564 + (|listOfPatternIds| |y|))))))))))) + (DO ((G166598 |oldList| (CDR G166598)) (|x| NIL)) + ((OR (ATOM G166598) + (PROGN (SETQ |x| (CAR G166598)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((OR + (AND (PAIRP |x|) + (EQ (QCAR |x|) '|ofCategory|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |body| + (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |x|) + (EQ (QCAR |x|) '|isDomain|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |body| + (QCAR |ISTMP#2|)) + 'T))))))) + (SPADLET |indepvl| + (|listOfPatternIds| |v|)) + (SPADLET |depvl| + (|listOfPatternIds| |body|))) + ('T + (SPADLET |indepvl| + (|listOfPatternIds| |x|)) + (SPADLET |depvl| NIL))) + (COND + ((AND + (NULL + (INTERSECTIONQ |indepvl| + |dependList|)) + (INTERSECTIONQ |indepvl| + |lastDependList|)) + (PROGN + (SPADLET |somethingDone| 'T) + (SPADLET |lastPreds| + (APPEND |lastPreds| + (CONS |x| NIL))) + (SPADLET |oldList| + (|delete| |x| |oldList|))))))))) + (DO () ((NULL |oldList|) NIL) + (SEQ (EXIT (PROGN + (DO ((G166651 |oldList| + (CDR G166651)) + (|x| NIL)) + ((OR (ATOM G166651) + (PROGN + (SETQ |x| (CAR G166651)) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (COND + ((OR + (AND (PAIRP |x|) + (EQ (QCAR |x|) + '|ofCategory|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |body| + (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |x|) + (EQ (QCAR |x|) '|isDomain|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |body| + (QCAR |ISTMP#2|)) + 'T))))))) + (SPADLET |indepvl| + (|listOfPatternIds| |v|)) + (SPADLET |depvl| + (|listOfPatternIds| |body|))) + ('T + (SPADLET |indepvl| + (|listOfPatternIds| |x|)) + (SPADLET |depvl| NIL))) + (COND + ((NULL + (INTERSECTIONQ |indepvl| + |dependList|)) + (PROGN + (SPADLET |dependList| + (SETDIFFERENCE + |dependList| |depvl|)) + (SPADLET |newList| + (APPEND |newList| + (CONS |x| NIL)))))))))) + (COND + ((BOOT-EQUAL + (SPADLET |noldList| + (SETDIFFERENCE |oldList| + |newList|)) + |oldList|) + (SPADLET |newList| + (APPEND |newList| |oldList|)) + (RETURN NIL)) + ('T (SPADLET |oldList| |noldList|))))))) + (DO ((G166674 |newList| (CDR G166674)) + (|pred| NIL)) + ((OR (ATOM G166674) + (PROGN (SETQ |pred| (CAR G166674)) NIL)) + NIL) + (SEQ (EXIT (COND + ((OR (AND (PAIRP |pred|) + (EQ (QCAR |pred|) '|isDomain|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |y| + (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |x|) + (EQ (QCAR |x|) '|ofCategory|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |y| + (QCAR |ISTMP#2|)) + 'T))))))) + (SPADLET |ids| + (|listOfPatternIds| |y|)) + (COND + ((PROG (G166680) + (SPADLET G166680 'T) + (RETURN + (DO + ((G166686 NIL + (NULL G166680)) + (G166687 |ids| + (CDR G166687)) + (|id| NIL)) + ((OR G166686 + (ATOM G166687) + (PROGN + (SETQ |id| + (CAR G166687)) + NIL)) + G166680) + (SEQ + (EXIT + (SETQ G166680 + (AND G166680 + (|member| |id| + |fullDependList|)))))))) + (SPADLET |fullDependList| + (|insertWOC| |x| + |fullDependList|)))) + (SPADLET |fullDependList| + (UNIONQ |fullDependList| + |ids|))) + ('T NIL))))) + (SPADLET |newList| (APPEND |newList| |lastPreds|)) + (SPADLET |newList| (|isDomainSubst| |newList|)) + (SPADLET |answer| + (CONS (CONS 'AND |newList|) + (INTERSECTIONQ |fullDependList| |sig|))))))))) + ;--sayBrightlyNT '"answer=" ;--pp answer ;isDomainSubst u == main where @@ -778,90 +944,90 @@ ; findSub(x,rest alist) (DEFUN |isDomainSubst,findSub| (|x| |alist|) - (PROG (|ISTMP#1| |ISTMP#2| |y| |ISTMP#3| |z|) - (RETURN - (SEQ - (IF (NULL |alist|) (EXIT NIL)) - (IF - (AND - (AND - (PAIRP |alist|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |alist|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |isDomain|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |y| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN (SPADLET |z| (QCAR |ISTMP#3|)) (QUOTE T))))))))) - (BOOT-EQUAL |x| |y|)) - (EXIT |z|)) - (EXIT (|isDomainSubst,findSub| |x| (CDR |alist|))))))) + (PROG (|ISTMP#1| |ISTMP#2| |y| |ISTMP#3| |z|) + (RETURN + (SEQ (IF (NULL |alist|) (EXIT NIL)) + (IF (AND (AND (PAIRP |alist|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |alist|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|isDomain|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |z| + (QCAR |ISTMP#3|)) + 'T)))))))) + (BOOT-EQUAL |x| |y|)) + (EXIT |z|)) + (EXIT (|isDomainSubst,findSub| |x| (CDR |alist|))))))) (DEFUN |isDomainSubst,fn| (|x| |alist|) - (PROG (|s|) - (RETURN - (SEQ - (IF (ATOM |x|) - (EXIT - (SEQ - (IF - (AND - (AND (IDENTP |x|) (MEMQ |x| |$PatternVariableList|)) - (SPADLET |s| (|isDomainSubst,findSub| |x| |alist|))) - (EXIT |s|)) - (EXIT |x|)))) - (EXIT - (CONS - (CAR |x|) - (PROG (#0=#:G166826) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166831 (CDR |x|) (CDR #1#)) (|y| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# (CONS (|isDomainSubst,fn| |y| |alist|) #0#))))))))))))) + (PROG (|s|) + (DECLARE (SPECIAL |$PatternVariableList|)) + (RETURN + (SEQ (IF (ATOM |x|) + (EXIT (SEQ (IF (AND (AND (IDENTP |x|) + (MEMQ |x| |$PatternVariableList|)) + (SPADLET |s| + (|isDomainSubst,findSub| |x| + |alist|))) + (EXIT |s|)) + (EXIT |x|)))) + (EXIT (CONS (CAR |x|) + (PROG (G166826) + (SPADLET G166826 NIL) + (RETURN + (DO ((G166831 (CDR |x|) (CDR G166831)) + (|y| NIL)) + ((OR (ATOM G166831) + (PROGN + (SETQ |y| (CAR G166831)) + NIL)) + (NREVERSE0 G166826)) + (SEQ (EXIT (SETQ G166826 + (CONS + (|isDomainSubst,fn| |y| + |alist|) + G166826))))))))))))) (DEFUN |isDomainSubst| (|u|) - (PROG (|head| |tail| |ISTMP#1| |x| |ISTMP#2| |y| |nhead|) - (RETURN - (COND - ((AND (PAIRP |u|) - (PROGN - (SPADLET |head| (QCAR |u|)) - (SPADLET |tail| (QCDR |u|)) - (QUOTE T))) - (SPADLET |nhead| + (PROG (|head| |tail| |ISTMP#1| |x| |ISTMP#2| |y| |nhead|) + (RETURN (COND - ((AND - (PAIRP |head|) - (EQ (QCAR |head|) (QUOTE |isDomain|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |head|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (CONS - (QUOTE |isDomain|) - (CONS |x| (CONS (|isDomainSubst,fn| |y| |tail|) NIL)))) - ((QUOTE T) |head|))) - (CONS |nhead| (|isDomainSubst| (CDR |u|)))) - ((QUOTE T) |u|))))) + ((AND (PAIRP |u|) + (PROGN + (SPADLET |head| (QCAR |u|)) + (SPADLET |tail| (QCDR |u|)) + 'T)) + (SPADLET |nhead| + (COND + ((AND (PAIRP |head|) (EQ (QCAR |head|) '|isDomain|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |head|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |y| (QCAR |ISTMP#2|)) + 'T)))))) + (CONS '|isDomain| + (CONS |x| + (CONS (|isDomainSubst,fn| |y| |tail|) + NIL)))) + ('T |head|))) + (CONS |nhead| (|isDomainSubst| (CDR |u|)))) + ('T |u|))))) ;signatureTran pred == ; atom pred => pred @@ -870,33 +1036,36 @@ ; [signatureTran p for p in pred] (DEFUN |signatureTran| (|pred|) - (PROG (|ISTMP#1| D |ISTMP#2| |catForm|) - (RETURN - (SEQ - (COND - ((ATOM |pred|) |pred|) - ((AND - (PAIRP |pred|) - (EQ (QCAR |pred|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |pred|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET D (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |catForm| (QCAR |ISTMP#2|)) (QUOTE T)))))) - (|isCategoryForm| |catForm| |$e|)) - (CONS (QUOTE |ofCategory|) (CONS D (CONS |catForm| NIL)))) - ((QUOTE T) - (PROG (#0=#:G166884) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166889 |pred| (CDR #1#)) (|p| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |p| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (|signatureTran| |p|) #0#))))))))))))) + (PROG (|ISTMP#1| D |ISTMP#2| |catForm|) + (DECLARE (SPECIAL |$e|)) + (RETURN + (SEQ (COND + ((ATOM |pred|) |pred|) + ((AND (PAIRP |pred|) (EQ (QCAR |pred|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET D (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |catForm| (QCAR |ISTMP#2|)) + 'T))))) + (|isCategoryForm| |catForm| |$e|)) + (CONS '|ofCategory| (CONS D (CONS |catForm| NIL)))) + ('T + (PROG (G166884) + (SPADLET G166884 NIL) + (RETURN + (DO ((G166889 |pred| (CDR G166889)) (|p| NIL)) + ((OR (ATOM G166889) + (PROGN (SETQ |p| (CAR G166889)) NIL)) + (NREVERSE0 G166884)) + (SEQ (EXIT (SETQ G166884 + (CONS (|signatureTran| |p|) + G166884))))))))))))) ;interactiveModemapForm mm == ; -- create modemap form for use by the interpreter. This function @@ -921,68 +1090,74 @@ ; [mmpat, cond] (DEFUN |interactiveModemapForm,fn| (|x|) - (PROG (|a| |ISTMP#1| |b| |ISTMP#2| |c|) - (RETURN - (SEQ - (IF - (AND - (AND - (AND - (PAIRP |x|) - (PROGN - (SPADLET |a| (QCAR |x|)) - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |c| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (NEQUAL |a| (QUOTE |isFreeFunction|))) - (ATOM |c|)) - (EXIT (CONS |a| (CONS |b| (CONS (CONS |c| NIL) NIL))))) - (EXIT |x|))))) - -(DEFUN |interactiveModemapForm| (|mm|) - (PROG (|pattern| |dc| |sig| |mmpat| |patternAlist| |partial| |patvars| - |domainPredicateList| |LETTMP#1| |pred| |dependList| |cond|) - (RETURN - (SEQ - (PROGN - (SPADLET |mm| - (|replaceVars| - (COPY |mm|) - |$PatternVariableList| - |$FormalMapVariableList|)) - (SPADLET |pattern| (CAR |mm|)) - (SPADLET |dc| (CAAR |mm|)) - (SPADLET |sig| (CDAR |mm|)) - (SPADLET |pred| (CADR |mm|)) - (SPADLET |pred| - (PROG (#0=#:G166974) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166979 |pred| (CDR #1#)) (|x| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ - (EXIT (SETQ #0# (CONS (|interactiveModemapForm,fn| |x|) #0#)))))))) - (SPADLET |LETTMP#1| (|modemapPattern| |pattern| |sig|)) - (SPADLET |mmpat| (CAR |LETTMP#1|)) - (SPADLET |patternAlist| (CADR |LETTMP#1|)) - (SPADLET |partial| (CADDR |LETTMP#1|)) - (SPADLET |patvars| (CADDDR |LETTMP#1|)) - (SPADLET |LETTMP#1| (|substVars| |pred| |patternAlist| |patvars|)) - (SPADLET |pred| (CAR |LETTMP#1|)) - (SPADLET |domainPredicateList| (CADR |LETTMP#1|)) - (SPADLET |LETTMP#1| - (|fixUpPredicate| |pred| |domainPredicateList| |partial| (CDR |mmpat|))) - (SPADLET |pred| (CAR |LETTMP#1|)) - (SPADLET |dependList| (CDR |LETTMP#1|)) - (SPADLET |cond| (CAR |pred|)) - (CONS |mmpat| (CONS |cond| NIL))))))) + (PROG (|a| |ISTMP#1| |b| |ISTMP#2| |c|) + (RETURN + (SEQ (IF (AND (AND (AND (PAIRP |x|) + (PROGN + (SPADLET |a| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |c| + (QCAR |ISTMP#2|)) + 'T)))))) + (NEQUAL |a| '|isFreeFunction|)) + (ATOM |c|)) + (EXIT (CONS |a| (CONS |b| (CONS (CONS |c| NIL) NIL))))) + (EXIT |x|))))) + +(DEFUN |interactiveModemapForm| (|mm|) + (PROG (|pattern| |dc| |sig| |mmpat| |patternAlist| |partial| + |patvars| |domainPredicateList| |LETTMP#1| |pred| + |dependList| |cond|) + (DECLARE (SPECIAL |$PatternVariableList| |$FormalMapVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |mm| + (|replaceVars| (COPY |mm|) |$PatternVariableList| + |$FormalMapVariableList|)) + (SPADLET |pattern| (CAR |mm|)) + (SPADLET |dc| (CAAR |mm|)) + (SPADLET |sig| (CDAR |mm|)) + (SPADLET |pred| (CADR |mm|)) + (SPADLET |pred| + (PROG (G166974) + (SPADLET G166974 NIL) + (RETURN + (DO ((G166979 |pred| (CDR G166979)) + (|x| NIL)) + ((OR (ATOM G166979) + (PROGN + (SETQ |x| (CAR G166979)) + NIL)) + (NREVERSE0 G166974)) + (SEQ (EXIT (SETQ G166974 + (CONS + (|interactiveModemapForm,fn| + |x|) + G166974)))))))) + (SPADLET |LETTMP#1| (|modemapPattern| |pattern| |sig|)) + (SPADLET |mmpat| (CAR |LETTMP#1|)) + (SPADLET |patternAlist| (CADR |LETTMP#1|)) + (SPADLET |partial| (CADDR |LETTMP#1|)) + (SPADLET |patvars| (CADDDR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (|substVars| |pred| |patternAlist| |patvars|)) + (SPADLET |pred| (CAR |LETTMP#1|)) + (SPADLET |domainPredicateList| (CADR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (|fixUpPredicate| |pred| |domainPredicateList| + |partial| (CDR |mmpat|))) + (SPADLET |pred| (CAR |LETTMP#1|)) + (SPADLET |dependList| (CDR |LETTMP#1|)) + (SPADLET |cond| (CAR |pred|)) + (CONS |mmpat| (CONS |cond| NIL))))))) ;modemapPattern(mmPattern,sig) == ; -- Returns a list of the pattern of a modemap, an Alist of the @@ -1006,52 +1181,57 @@ ; [NREVERSE mmpat,patternAlist,partial,patvars] (DEFUN |modemapPattern| (|mmPattern| |sig|) - (PROG (|ISTMP#1| |dom| |ISTMP#2| |tag| |x| |partial| |patvar| - |patvars| |mmpat| |patternAlist|) - (RETURN - (SEQ - (PROGN - (SPADLET |patternAlist| NIL) - (SPADLET |mmpat| NIL) - (SPADLET |patvars| |$PatternVariableList|) - (SPADLET |partial| NIL) - (DO ((|xTails| |mmPattern| (CDR |xTails|))) - ((ATOM |xTails|) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |x| (CAR |xTails|)) - (COND - ((AND - (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |Union|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |dom| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |tag| (QCAR |ISTMP#2|)) (QUOTE T)))))) - (BOOT-EQUAL |tag| (MAKESTRING "failed")) - (BOOT-EQUAL |xTails| |sig|)) - (SPADLET |x| |dom|) (SPADLET |partial| (QUOTE T)))) - (SPADLET |patvar| (|rassoc| |x| |patternAlist|)) - (COND - ((NULL (NULL |patvar|)) - (SPADLET |mmpat| (CONS |patvar| |mmpat|))) - ((QUOTE T) - (SPADLET |patvar| (CAR |patvars|)) - (SPADLET |patvars| (CDR |patvars|)) - (SPADLET |mmpat| (CONS |patvar| |mmpat|)) - (SPADLET |patternAlist| - (CONS (CONS |patvar| |x|) |patternAlist|)))))))) - (CONS - (NREVERSE |mmpat|) - (CONS |patternAlist| (CONS |partial| (CONS |patvars| NIL))))))))) + (PROG (|ISTMP#1| |dom| |ISTMP#2| |tag| |x| |partial| |patvar| + |patvars| |mmpat| |patternAlist|) + (DECLARE (SPECIAL |$PatternVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |patternAlist| NIL) + (SPADLET |mmpat| NIL) + (SPADLET |patvars| |$PatternVariableList|) + (SPADLET |partial| NIL) + (DO ((|xTails| |mmPattern| (CDR |xTails|))) + ((ATOM |xTails|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| (CAR |xTails|)) + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) '|Union|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |dom| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |tag| + (QCAR |ISTMP#2|)) + 'T))))) + (BOOT-EQUAL |tag| + (MAKESTRING "failed")) + (BOOT-EQUAL |xTails| |sig|)) + (SPADLET |x| |dom|) + (SPADLET |partial| 'T))) + (SPADLET |patvar| + (|rassoc| |x| |patternAlist|)) + (COND + ((NULL (NULL |patvar|)) + (SPADLET |mmpat| + (CONS |patvar| |mmpat|))) + ('T (SPADLET |patvar| (CAR |patvars|)) + (SPADLET |patvars| (CDR |patvars|)) + (SPADLET |mmpat| + (CONS |patvar| |mmpat|)) + (SPADLET |patternAlist| + (CONS (CONS |patvar| |x|) + |patternAlist|)))))))) + (CONS (NREVERSE |mmpat|) + (CONS |patternAlist| + (CONS |partial| (CONS |patvars| NIL))))))))) ;substVars(pred,patternAlist,patternVarList) == ; --make pattern variable substitutions @@ -1072,44 +1252,64 @@ ; [pred, domainPredicates] (DEFUN |substVars| (|pred| |patternAlist| |patternVarList|) - (PROG (|patVar| |value| |everything| |replacementVar| |domainPredicates|) - (RETURN - (SEQ - (PROGN - (SPADLET |domainPredicates| NIL) - (DO ((#0=#:G167064 |patternAlist| (CDR #0#))) - ((OR (ATOM #0#) (PROGN (PROGN (SPADLET |patVar| (CAAR #0#)) (SPADLET |value| (CDAR #0#)) #0#) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |pred| (MSUBST |patVar| |value| |pred|)) - (SPADLET |patternAlist| (|nsubst| |patVar| |value| |patternAlist|)) - (SPADLET |domainPredicates| - (MSUBST |patVar| |value| |domainPredicates|)) - (COND - ((NULL (MEMQ |value| |$FormalMapVariableList|)) - (SPADLET |domainPredicates| - (CONS - (CONS (QUOTE |isDomain|) (CONS |patVar| (CONS |value| NIL))) - |domainPredicates|))) - ((QUOTE T) NIL)))))) - (SPADLET |everything| - (CONS |pred| (CONS |patternAlist| (CONS |domainPredicates| NIL)))) - (SEQ - (DO ((#1=#:G167089 |$FormalMapVariableList| (CDR #1#)) (|var| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |var| (CAR #1#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((CONTAINED |var| |everything|) - (EXIT - (PROGN - (SPADLET |replacementVar| (CAR |patternVarList|)) - (SPADLET |patternVarList| (CDR |patternVarList|)) - (SPADLET |pred| (MSUBST |replacementVar| |var| |pred|)) - (SPADLET |domainPredicates| - (MSUBST |replacementVar| |var| |domainPredicates|))))))))) - (CONS |pred| (CONS |domainPredicates| NIL)))))))) + (PROG (|patVar| |value| |everything| |replacementVar| + |domainPredicates|) + (DECLARE (SPECIAL |$FormalMapVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |domainPredicates| NIL) + (DO ((G167064 |patternAlist| (CDR G167064))) + ((OR (ATOM G167064) + (PROGN + (PROGN + (SPADLET |patVar| (CAAR G167064)) + (SPADLET |value| (CDAR G167064)) + G167064) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |pred| + (MSUBST |patVar| |value| |pred|)) + (SPADLET |patternAlist| + (|nsubst| |patVar| |value| + |patternAlist|)) + (SPADLET |domainPredicates| + (MSUBST |patVar| |value| + |domainPredicates|)) + (COND + ((NULL (MEMQ |value| + |$FormalMapVariableList|)) + (SPADLET |domainPredicates| + (CONS + (CONS '|isDomain| + (CONS |patVar| + (CONS |value| NIL))) + |domainPredicates|))) + ('T NIL)))))) + (SPADLET |everything| + (CONS |pred| + (CONS |patternAlist| + (CONS |domainPredicates| NIL)))) + (SEQ (DO ((G167089 |$FormalMapVariableList| + (CDR G167089)) + (|var| NIL)) + ((OR (ATOM G167089) + (PROGN (SETQ |var| (CAR G167089)) NIL)) + NIL) + (SEQ (EXIT (COND + ((CONTAINED |var| |everything|) + (EXIT (PROGN + (SPADLET |replacementVar| + (CAR |patternVarList|)) + (SPADLET |patternVarList| + (CDR |patternVarList|)) + (SPADLET |pred| + (MSUBST |replacementVar| + |var| |pred|)) + (SPADLET |domainPredicates| + (MSUBST |replacementVar| + |var| |domainPredicates|))))))))) + (CONS |pred| (CONS |domainPredicates| NIL)))))))) ;fixUpPredicate(predClause, domainPreds, partial, sig) == ; -- merge the predicates in predClause and domainPreds into a @@ -1132,51 +1332,56 @@ ; [[pred, fn, :skip],:dependList] (DEFUN |fixUpPredicate| (|predClause| |domainPreds| |partial| |sig|) - (PROG (|predicate| |fn| |skip| |predicates| |LETTMP#1| |ISTMP#1| |pvar| - |ISTMP#2| |ISTMP#3| |dependList| |pred|) - (RETURN - (PROGN - (SPADLET |predicate| (CAR |predClause|)) - (SPADLET |fn| (CADR |predClause|)) - (SPADLET |skip| (CDDR |predClause|)) - (COND - ((BOOT-EQUAL (CAR |predicate|) (QUOTE AND)) - (SPADLET |predicates| (APPEND |domainPreds| (CDR |predicate|)))) - ((NEQUAL |predicate| (MKQ (QUOTE T))) - (SPADLET |predicates| (CONS |predicate| |domainPreds|))) - ((QUOTE T) - (SPADLET |predicates| (OR |domainPreds| (CONS |predicate| NIL))))) - (COND - ((> (|#| |predicates|) 1) - (SPADLET |pred| (CONS (QUOTE AND) |predicates|)) - (SPADLET |LETTMP#1| (|orderPredicateItems| |pred| |sig| |skip|)) - (SPADLET |pred| (CAR |LETTMP#1|)) - (SPADLET |dependList| (CDR |LETTMP#1|)) |LETTMP#1|) - ((QUOTE T) - (SPADLET |pred| (|orderPredicateItems| (CAR |predicates|) |sig| |skip|)) - (SPADLET |dependList| - (COND - ((AND - (PAIRP |pred|) - (EQ (QCAR |pred|) (QUOTE |isDomain|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |pred|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |pvar| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) (EQ (QCDR |ISTMP#3|) NIL)))))))) - (CONS |pvar| NIL)) - ((QUOTE T) NIL))))) - (SPADLET |pred| (|moveORsOutside| |pred|)) - (COND (|partial| (SPADLET |pred| (CONS (QUOTE |partial|) |pred|)))) - (CONS (CONS |pred| (CONS |fn| |skip|)) |dependList|))))) + (PROG (|predicate| |fn| |skip| |predicates| |LETTMP#1| |ISTMP#1| + |pvar| |ISTMP#2| |ISTMP#3| |dependList| |pred|) + (RETURN + (PROGN + (SPADLET |predicate| (CAR |predClause|)) + (SPADLET |fn| (CADR |predClause|)) + (SPADLET |skip| (CDDR |predClause|)) + (COND + ((BOOT-EQUAL (CAR |predicate|) 'AND) + (SPADLET |predicates| + (APPEND |domainPreds| (CDR |predicate|)))) + ((NEQUAL |predicate| (MKQ 'T)) + (SPADLET |predicates| (CONS |predicate| |domainPreds|))) + ('T + (SPADLET |predicates| + (OR |domainPreds| (CONS |predicate| NIL))))) + (COND + ((> (|#| |predicates|) 1) + (SPADLET |pred| (CONS 'AND |predicates|)) + (SPADLET |LETTMP#1| + (|orderPredicateItems| |pred| |sig| |skip|)) + (SPADLET |pred| (CAR |LETTMP#1|)) + (SPADLET |dependList| (CDR |LETTMP#1|)) |LETTMP#1|) + ('T + (SPADLET |pred| + (|orderPredicateItems| (CAR |predicates|) |sig| + |skip|)) + (SPADLET |dependList| + (COND + ((AND (PAIRP |pred|) + (EQ (QCAR |pred|) '|isDomain|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pvar| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| + (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL)))))))) + (CONS |pvar| NIL)) + ('T NIL))))) + (SPADLET |pred| (|moveORsOutside| |pred|)) + (COND (|partial| (SPADLET |pred| (CONS '|partial| |pred|)))) + (CONS (CONS |pred| (CONS |fn| |skip|)) |dependList|))))) ;moveORsOutside p == ; p is ['AND,:q] => @@ -1187,50 +1392,68 @@ ; p (DEFUN |moveORsOutside| (|p|) - (PROG (|q| |s| |x|) - (RETURN - (SEQ - (COND - ((AND (PAIRP |p|) - (EQ (QCAR |p|) (QUOTE AND)) - (PROGN (SPADLET |q| (QCDR |p|)) (QUOTE T))) - (SPADLET |q| - (PROG (#0=#:G167169) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167174 |q| (CDR #1#)) (|r| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |r| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (|moveORsOutside| |r|) #0#)))))))) - (COND - ((SPADLET |x| - (PROG (#2=#:G167180) - (SPADLET #2# NIL) - (RETURN - (DO ((#3=#:G167187 NIL #2#) (#4=#:G167188 |q| (CDR #4#)) (|r| NIL)) - ((OR #3# (ATOM #4#) (PROGN (SETQ |r| (CAR #4#)) NIL)) #2#) - (SEQ - (EXIT + (PROG (|q| |s| |x|) + (RETURN + (SEQ (COND + ((AND (PAIRP |p|) (EQ (QCAR |p|) 'AND) + (PROGN (SPADLET |q| (QCDR |p|)) 'T)) + (SPADLET |q| + (PROG (G167169) + (SPADLET G167169 NIL) + (RETURN + (DO ((G167174 |q| (CDR G167174)) + (|r| NIL)) + ((OR (ATOM G167174) + (PROGN + (SETQ |r| (CAR G167174)) + NIL)) + (NREVERSE0 G167169)) + (SEQ (EXIT (SETQ G167169 + (CONS (|moveORsOutside| |r|) + G167169)))))))) (COND - ((AND - (PAIRP |r|) - (EQ (QCAR |r|) (QUOTE OR)) - (PROGN (SPADLET |s| (QCDR |r|)) (QUOTE T))) - (SETQ #2# (OR #2# |r|)))))))))) - (|moveORsOutside| - (CONS - (QUOTE OR) - (PROG (#5=#:G167199) - (SPADLET #5# NIL) - (RETURN - (DO ((#6=#:G167204 (CDR |x|) (CDR #6#)) (|t| NIL)) - ((OR (ATOM #6#) (PROGN (SETQ |t| (CAR #6#)) NIL)) - (NREVERSE0 #5#)) - (SEQ - (EXIT - (SETQ #5# - (CONS (CONS (QUOTE AND) (MSUBST |t| |x| |q|)) #5#)))))))))) - ((QUOTE T) (CONS (QUOTE AND) |q|)))) - ((QUOTE T) |p|)))))) + ((SPADLET |x| + (PROG (G167180) + (SPADLET G167180 NIL) + (RETURN + (DO ((G167187 NIL G167180) + (G167188 |q| (CDR G167188)) + (|r| NIL)) + ((OR G167187 (ATOM G167188) + (PROGN + (SETQ |r| (CAR G167188)) + NIL)) + G167180) + (SEQ (EXIT + (COND + ((AND (PAIRP |r|) + (EQ (QCAR |r|) 'OR) + (PROGN + (SPADLET |s| (QCDR |r|)) + 'T)) + (SETQ G167180 + (OR G167180 |r|)))))))))) + (|moveORsOutside| + (CONS 'OR + (PROG (G167199) + (SPADLET G167199 NIL) + (RETURN + (DO ((G167204 (CDR |x|) + (CDR G167204)) + (|t| NIL)) + ((OR (ATOM G167204) + (PROGN + (SETQ |t| (CAR G167204)) + NIL)) + (NREVERSE0 G167199)) + (SEQ (EXIT + (SETQ G167199 + (CONS + (CONS 'AND + (MSUBST |t| |x| |q|)) + G167199)))))))))) + ('T (CONS 'AND |q|)))) + ('T |p|)))))) ;replaceVars(x,oldvars,newvars) == ; -- replace every identifier in oldvars with the corresponding @@ -1240,18 +1463,16 @@ ; x (DEFUN |replaceVars| (|x| |oldvars| |newvars|) - (SEQ - (PROGN - (DO ((#0=#:G167225 |oldvars| (CDR #0#)) - (|old| NIL) - (#1=#:G167226 |newvars| (CDR #1#)) - (|new| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |old| (CAR #0#)) NIL) - (ATOM #1#) - (PROGN (SETQ |new| (CAR #1#)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |x| (MSUBST |new| |old| |x|))))) |x|))) + (SEQ (PROGN + (DO ((G167225 |oldvars| (CDR G167225)) (|old| NIL) + (G167226 |newvars| (CDR G167226)) (|new| NIL)) + ((OR (ATOM G167225) + (PROGN (SETQ |old| (CAR G167225)) NIL) + (ATOM G167226) + (PROGN (SETQ |new| (CAR G167226)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |x| (MSUBST |new| |old| |x|))))) + |x|))) ;getDomainFromMm mm == ; -- Returns the Domain (or package or category) of origin from a pattern @@ -1272,75 +1493,87 @@ ; val (DEFUN |getDomainFromMm| (|mm|) - (PROG (|c| |cond| |cl| |condList| |dom| |ISTMP#1| |ISTMP#2| |cat| |val|) - (RETURN - (SEQ - (PROGN - (SPADLET |cond| (CADR |mm|)) - (COND - ((AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |partial|)) - (PROGN (SPADLET |c| (QCDR |cond|)) (QUOTE T))) - (SPADLET |cond| |c|))) - (SPADLET |condList| - (COND - ((AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE AND)) - (PROGN (SPADLET |cl| (QCDR |cond|)) (QUOTE T))) - |cl|) - ((AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE OR)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cond|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) (QUOTE AND)) - (PROGN (SPADLET |cl| (QCDR |ISTMP#2|)) (QUOTE T))))))) - |cl|) - ((QUOTE T) - (CONS |cond| NIL)))) - (SPADLET |val| - (DO ((#0=#:G167289 |condList| (CDR #0#)) (|condition| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |condition| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((AND (PAIRP |condition|) - (EQ (QCAR |condition|) (QUOTE |isDomain|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |condition|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE *1)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |dom| (QCAR |ISTMP#2|)) - (QUOTE T))))))) - (RETURN (|opOf| |dom|))) - ((AND (PAIRP |condition|) - (EQ (QCAR |condition|) (QUOTE |ofCategory|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |condition|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE *1)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |cat| (QCAR |ISTMP#2|)) - (QUOTE T))))))) - (RETURN (|opOf| |cat|)))))))) - (COND - ((NULL |val|) - (|keyedSystemError| 'S2GE0016 - (CONS "getDomainFromMm" - (CONS "Can't find domain in modemap condition" NIL)))) - ((QUOTE T) |val|))))))) + (PROG (|c| |cond| |cl| |condList| |dom| |ISTMP#1| |ISTMP#2| |cat| + |val|) + (RETURN + (SEQ (PROGN + (SPADLET |cond| (CADR |mm|)) + (COND + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) '|partial|) + (PROGN (SPADLET |c| (QCDR |cond|)) 'T)) + (SPADLET |cond| |c|))) + (SPADLET |condList| + (COND + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'AND) + (PROGN (SPADLET |cl| (QCDR |cond|)) 'T)) + |cl|) + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'OR) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) 'AND) + (PROGN + (SPADLET |cl| + (QCDR |ISTMP#2|)) + 'T)))))) + |cl|) + ('T (CONS |cond| NIL)))) + (SPADLET |val| + (DO ((G167289 |condList| (CDR G167289)) + (|condition| NIL)) + ((OR (ATOM G167289) + (PROGN + (SETQ |condition| (CAR G167289)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |condition|) + (EQ (QCAR |condition|) + '|isDomain|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |condition|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '*1) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |dom| + (QCAR |ISTMP#2|)) + 'T)))))) + (RETURN (|opOf| |dom|))) + ((AND (PAIRP |condition|) + (EQ (QCAR |condition|) + '|ofCategory|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |condition|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '*1) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |cat| + (QCAR |ISTMP#2|)) + 'T)))))) + (RETURN (|opOf| |cat|)))))))) + (COND + ((NULL |val|) + (|keyedSystemError| 'S2GE0016 + (CONS "getDomainFromMm" + (CONS "Can't find domain in modemap condition" + NIL)))) + ('T |val|))))))) ;getFirstArgTypeFromMm mm == ; -- Returns the type of the first argument or nil @@ -1359,70 +1592,74 @@ ; type (DEFUN |getFirstArgTypeFromMm| (|mm|) - (PROG (|pats| |args| |arg1| |c| |cond| |cl| |condList| |ISTMP#1| |a1| - |ISTMP#2| |dom| |type|) - (RETURN - (SEQ - (PROGN - (SPADLET |pats| (CAR |mm|)) - (SPADLET |cond| (CADR |mm|)) - (SPADLET |args| (CDDR |pats|)) - (COND - ((NULL |args|) NIL) - ((QUOTE T) - (SPADLET |arg1| (CAR |args|)) - (COND - ((AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |partial|)) - (PROGN (SPADLET |c| (QCDR |cond|)) (QUOTE T))) - (SPADLET |cond| |c|))) - (SPADLET |condList| - (COND - ((AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE AND)) - (PROGN (SPADLET |cl| (QCDR |cond|)) (QUOTE T))) - |cl|) - ((AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE OR)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cond|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) (QUOTE AND)) - (PROGN - (SPADLET |cl| (QCDR |ISTMP#2|)) - (QUOTE T))))))) - |cl|) - ((QUOTE T) - (CONS |cond| NIL)))) - (SPADLET |type| NIL) - (DO ((#0=#:G167357 |condList| (CDR #0#)) (|condition| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |condition| (CAR #0#)) NIL) - (NULL (NULL |type|))) - NIL) - (SEQ - (EXIT - (COND - ((AND (PAIRP |condition|) - (EQ (QCAR |condition|) (QUOTE |isDomain|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |condition|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a1| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |dom| (QCAR |ISTMP#2|)) - (QUOTE T)))))) - (BOOT-EQUAL |a1| |arg1|)) - (SPADLET |type| |dom|)) - ((QUOTE T) NIL))))) - |type|))))))) + (PROG (|pats| |args| |arg1| |c| |cond| |cl| |condList| |ISTMP#1| |a1| + |ISTMP#2| |dom| |type|) + (RETURN + (SEQ (PROGN + (SPADLET |pats| (CAR |mm|)) + (SPADLET |cond| (CADR |mm|)) + (SPADLET |args| (CDDR |pats|)) + (COND + ((NULL |args|) NIL) + ('T (SPADLET |arg1| (CAR |args|)) + (COND + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) '|partial|) + (PROGN (SPADLET |c| (QCDR |cond|)) 'T)) + (SPADLET |cond| |c|))) + (SPADLET |condList| + (COND + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'AND) + (PROGN + (SPADLET |cl| (QCDR |cond|)) + 'T)) + |cl|) + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'OR) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) 'AND) + (PROGN + (SPADLET |cl| + (QCDR |ISTMP#2|)) + 'T)))))) + |cl|) + ('T (CONS |cond| NIL)))) + (SPADLET |type| NIL) + (DO ((G167357 |condList| (CDR G167357)) + (|condition| NIL)) + ((OR (ATOM G167357) + (PROGN + (SETQ |condition| (CAR G167357)) + NIL) + (NULL (NULL |type|))) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |condition|) + (EQ (QCAR |condition|) + '|isDomain|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |condition|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a1| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |dom| + (QCAR |ISTMP#2|)) + 'T))))) + (BOOT-EQUAL |a1| |arg1|)) + (SPADLET |type| |dom|)) + ('T NIL))))) + |type|))))))) ;isFreeFunctionFromMm mm == ; -- This returns true is the modemap represents a free function, ie, @@ -1431,11 +1668,11 @@ ; isFreeFunctionFromMmCond cond (DEFUN |isFreeFunctionFromMm| (|mm|) - (PROG (|cond|) - (RETURN - (PROGN - (SPADLET |cond| (CADR |mm|)) - (|isFreeFunctionFromMmCond| |cond|))))) + (PROG (|cond|) + (RETURN + (PROGN + (SPADLET |cond| (CADR |mm|)) + (|isFreeFunctionFromMmCond| |cond|))))) ;isFreeFunctionFromMmCond cond == ; -- This returns true is the modemap represents a free function, ie, @@ -1451,47 +1688,47 @@ ; iff (DEFUN |isFreeFunctionFromMmCond| (|cond|) - (PROG (|c| |ISTMP#1| |ISTMP#2| |cl| |condList| |iff|) - (RETURN - (SEQ - (PROGN - (COND - ((AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |partial|)) - (PROGN (SPADLET |c| (QCDR |cond|)) (QUOTE T))) - (SPADLET |cond| |c|))) - (SPADLET |condList| - (COND - ((AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE AND)) - (PROGN (SPADLET |cl| (QCDR |cond|)) (QUOTE T))) - |cl|) - ((AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE OR)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cond|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) (QUOTE AND)) - (PROGN (SPADLET |cl| (QCDR |ISTMP#2|)) (QUOTE T))))))) - |cl|) - ((QUOTE T) (CONS |cond| NIL)))) - (SPADLET |iff| NIL) - (DO ((#0=#:G167407 |condList| (CDR #0#)) (|condition| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |condition| (CAR #0#)) NIL) - (NULL (NULL |iff|))) - NIL) - (SEQ - (EXIT - (COND - ((AND (PAIRP |condition|) - (EQ (QCAR |condition|) (QUOTE |isFreeFunction|))) - (SPADLET |iff| (QUOTE T))) - ((QUOTE T) NIL))))) - |iff|))))) + (PROG (|c| |ISTMP#1| |ISTMP#2| |cl| |condList| |iff|) + (RETURN + (SEQ (PROGN + (COND + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) '|partial|) + (PROGN (SPADLET |c| (QCDR |cond|)) 'T)) + (SPADLET |cond| |c|))) + (SPADLET |condList| + (COND + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'AND) + (PROGN (SPADLET |cl| (QCDR |cond|)) 'T)) + |cl|) + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'OR) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) 'AND) + (PROGN + (SPADLET |cl| + (QCDR |ISTMP#2|)) + 'T)))))) + |cl|) + ('T (CONS |cond| NIL)))) + (SPADLET |iff| NIL) + (DO ((G167407 |condList| (CDR G167407)) + (|condition| NIL)) + ((OR (ATOM G167407) + (PROGN (SETQ |condition| (CAR G167407)) NIL) + (NULL (NULL |iff|))) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |condition|) + (EQ (QCAR |condition|) + '|isFreeFunction|)) + (SPADLET |iff| 'T)) + ('T NIL))))) + |iff|))))) ;getAllModemapsFromDatabase(op,nargs) == ; $getUnexposedOperations: local := true @@ -1501,15 +1738,15 @@ ; ans (DEFUN |getAllModemapsFromDatabase| (|op| |nargs|) - (PROG (|$getUnexposedOperations| |ans|) - (DECLARE (SPECIAL |$getUnexposedOperations|)) - (RETURN - (PROGN - (SPADLET |$getUnexposedOperations| (QUOTE T)) - (|startTimingProcess| (QUOTE |diskread|)) - (SPADLET |ans| (|getSystemModemaps| |op| |nargs|)) - (|stopTimingProcess| (QUOTE |diskread|)) - |ans|)))) + (PROG (|$getUnexposedOperations| |ans|) + (DECLARE (SPECIAL |$getUnexposedOperations|)) + (RETURN + (PROGN + (SPADLET |$getUnexposedOperations| 'T) + (|startTimingProcess| '|diskread|) + (SPADLET |ans| (|getSystemModemaps| |op| |nargs|)) + (|stopTimingProcess| '|diskread|) + |ans|)))) ;getModemapsFromDatabase(op,nargs) == ; $getUnexposedOperations: local := false @@ -1519,15 +1756,15 @@ ; ans (DEFUN |getModemapsFromDatabase| (|op| |nargs|) - (PROG (|$getUnexposedOperations| |ans|) - (DECLARE (SPECIAL |$getUnexposedOperations|)) - (RETURN - (PROGN - (SPADLET |$getUnexposedOperations| NIL) - (|startTimingProcess| (QUOTE |diskread|)) - (SPADLET |ans| (|getSystemModemaps| |op| |nargs|)) - (|stopTimingProcess| (QUOTE |diskread|)) - |ans|)))) + (PROG (|$getUnexposedOperations| |ans|) + (DECLARE (SPECIAL |$getUnexposedOperations|)) + (RETURN + (PROGN + (SPADLET |$getUnexposedOperations| NIL) + (|startTimingProcess| '|diskread|) + (SPADLET |ans| (|getSystemModemaps| |op| |nargs|)) + (|stopTimingProcess| '|diskread|) + |ans|)))) ;getSystemModemaps(op,nargs) == ; mml:= GETDATABASE(op,'OPERATION) => @@ -1541,28 +1778,31 @@ ; nil (DEFUN |getSystemModemaps| (|op| |nargs|) - (PROG (|mml| |sig| |mms|) - (RETURN - (SEQ - (COND - ((SPADLET |mml| (GETDATABASE |op| (QUOTE OPERATION))) - (SPADLET |mms| NIL) - (DO ((#0=#:G167451 |mml| (CDR #0#)) (|x| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |x| (CAR #0#)) NIL) - (PROGN (PROGN (SPADLET |sig| (CDAR |x|)) |x|) NIL)) NIL) - (SEQ - (EXIT - (COND - ((AND (NUMBERP |nargs|) (NEQUAL |nargs| (|#| (QCDR |sig|)))) - (QUOTE |iterate|)) - ((OR |$getUnexposedOperations| - (|isFreeFunctionFromMm| |x|) - (|isExposedConstructor| (|getDomainFromMm| |x|))) - (SPADLET |mms| (CONS |x| |mms|))) - ((QUOTE T) (QUOTE |iterate|)))))) - |mms|) - ((QUOTE T) NIL)))))) + (PROG (|mml| |sig| |mms|) + (DECLARE (SPECIAL |$getUnexposedOperations|)) + (RETURN + (SEQ (COND + ((SPADLET |mml| (GETDATABASE |op| 'OPERATION)) + (SPADLET |mms| NIL) + (DO ((G167451 |mml| (CDR G167451)) (|x| NIL)) + ((OR (ATOM G167451) + (PROGN (SETQ |x| (CAR G167451)) NIL) + (PROGN + (PROGN (SPADLET |sig| (CDAR |x|)) |x|) + NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (NUMBERP |nargs|) + (NEQUAL |nargs| (|#| (QCDR |sig|)))) + '|iterate|) + ((OR |$getUnexposedOperations| + (|isFreeFunctionFromMm| |x|) + (|isExposedConstructor| + (|getDomainFromMm| |x|))) + (SPADLET |mms| (CONS |x| |mms|))) + ('T '|iterate|))))) + |mms|) + ('T NIL)))))) ;getInCoreModemaps(modemapList,op,nargs) == ; mml:= LASSOC (op,modemapList) => @@ -1574,39 +1814,40 @@ ; nil (DEFUN |getInCoreModemaps| (|modemapList| |op| |nargs|) - (PROG (|mml| |dc| |sig| |domName| |cfn|) - (RETURN - (SEQ - (COND - ((SPADLET |mml| (LASSOC |op| |modemapList|)) - (SPADLET |mml| (CAR |mml|)) - (PROG (#0=#:G167477) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167484 |mml| (CDR #1#)) (|x| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |x| (CAR #1#)) NIL) - (PROGN - (PROGN - (SPADLET |dc| (CAAR |x|)) - (SPADLET |sig| (CDAR |x|)) - |x|) - NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (COND - ((AND - (COND - ((NUMBERP |nargs|) (BOOT-EQUAL |nargs| (|#| (CDR |sig|)))) - ((QUOTE T) (QUOTE T))) - (SPADLET |cfn| - (|abbreviate| (SPADLET |domName| (|getDomainFromMm| |x|)))) - (OR - |$getUnexposedOperations| - (|isExposedConstructor| |domName|))) - (SETQ #0# (CONS |x| #0#)))))))))) - ((QUOTE T) NIL)))))) + (PROG (|mml| |dc| |sig| |domName| |cfn|) + (DECLARE (SPECIAL |$getUnexposedOperations|)) + (RETURN + (SEQ (COND + ((SPADLET |mml| (LASSOC |op| |modemapList|)) + (SPADLET |mml| (CAR |mml|)) + (PROG (G167477) + (SPADLET G167477 NIL) + (RETURN + (DO ((G167484 |mml| (CDR G167484)) (|x| NIL)) + ((OR (ATOM G167484) + (PROGN (SETQ |x| (CAR G167484)) NIL) + (PROGN + (PROGN + (SPADLET |dc| (CAAR |x|)) + (SPADLET |sig| (CDAR |x|)) + |x|) + NIL)) + (NREVERSE0 G167477)) + (SEQ (EXIT (COND + ((AND (COND + ((NUMBERP |nargs|) + (BOOT-EQUAL |nargs| + (|#| (CDR |sig|)))) + ('T 'T)) + (SPADLET |cfn| + (|abbreviate| + (SPADLET |domName| + (|getDomainFromMm| |x|)))) + (OR |$getUnexposedOperations| + (|isExposedConstructor| + |domName|))) + (SETQ G167477 (CONS |x| G167477)))))))))) + ('T NIL)))))) ;mkAlistOfExplicitCategoryOps target == ; if target is ['add,a,:l] then @@ -1632,122 +1873,127 @@ ; ['"mkAlistOfExplicitCategoryOps",'"bad signature"]) (DEFUN |mkAlistOfExplicitCategoryOps,atomizeOp| (|op|) - (PROG (|a|) - (RETURN - (SEQ - (IF (ATOM |op|) (EXIT |op|)) - (IF - (AND (PAIRP |op|) - (EQ (QCDR |op|) NIL) - (PROGN (SPADLET |a| (QCAR |op|)) (QUOTE T))) - (EXIT |a|)) - (EXIT - (|keyedSystemError| 'S2GE0016 - (CONS "mkAlistOfExplicitCategoryOps" (CONS "bad signature" NIL)))))))) + (PROG (|a|) + (RETURN + (SEQ (IF (ATOM |op|) (EXIT |op|)) + (IF (AND (PAIRP |op|) (EQ (QCDR |op|) NIL) + (PROGN (SPADLET |a| (QCAR |op|)) 'T)) + (EXIT |a|)) + (EXIT (|keyedSystemError| 'S2GE0016 + (CONS "mkAlistOfExplicitCategoryOps" + (CONS "bad signature" NIL)))))))) (DEFUN |mkAlistOfExplicitCategoryOps,fn| (|op| |u|) - (PROG (|ISTMP#1| |a| |b| |c|) - (RETURN - (SEQ - (IF - (AND - (PAIRP |u|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |u|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |b| (QCDR |ISTMP#1|)) - (QUOTE T)))) - (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) - (EXIT - (SEQ - (IF (BOOT-EQUAL |a| |op|) - (EXIT (CONS |b| (|mkAlistOfExplicitCategoryOps,fn| |op| |c|)))) - (EXIT (|mkAlistOfExplicitCategoryOps,fn| |op| |c|))))))))) + (PROG (|ISTMP#1| |a| |b| |c|) + (RETURN + (SEQ (IF (AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |b| (QCDR |ISTMP#1|)) + 'T))) + (PROGN (SPADLET |c| (QCDR |u|)) 'T)) + (EXIT (SEQ (IF (BOOT-EQUAL |a| |op|) + (EXIT (CONS |b| + (|mkAlistOfExplicitCategoryOps,fn| + |op| |c|)))) + (EXIT (|mkAlistOfExplicitCategoryOps,fn| |op| + |c|))))))))) (DEFUN |mkAlistOfExplicitCategoryOps| (|target|) - (PROG (|a| |l| |ISTMP#1| |op| |ISTMP#2| |sig| |u| |opList|) - (RETURN - (SEQ - (PROGN - (COND - ((AND (PAIRP |target|) - (EQ (QCAR |target|) (QUOTE |add|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |l| (QCDR |ISTMP#1|)) - (QUOTE T))))) - (SPADLET |target| |a|))) - (COND - ((AND (PAIRP |target|) - (EQ (QCAR |target|) (QUOTE |Join|)) - (PROGN (SPADLET |l| (QCDR |target|)) (QUOTE T))) - (PROG (#0=#:G167561) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167566 |l| (CDR #1#)) (|cat| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |cat| (CAR #1#)) NIL)) #0#) - (SEQ - (EXIT - (SETQ #0# - (|union| #0# (|mkAlistOfExplicitCategoryOps| |cat|))))))))) - ((AND (PAIRP |target|) - (EQ (QCAR |target|) (QUOTE CATEGORY)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |l| (|flattenSignatureList| (CONS (QUOTE PROGN) |l|))) - (SPADLET |u| - (PROG (#2=#:G167577) - (SPADLET #2# NIL) - (RETURN - (DO ((#3=#:G167583 |l| (CDR #3#)) (|x| NIL)) - ((OR (ATOM #3#) - (PROGN (SETQ |x| (CAR #3#)) NIL)) - (NREVERSE0 #2#)) - (SEQ - (EXIT + (PROG (|a| |l| |ISTMP#1| |op| |ISTMP#2| |sig| |u| |opList|) + (DECLARE (SPECIAL |$e|)) + (RETURN + (SEQ (PROGN (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE SIGNATURE)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (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))))))) - (SETQ #2# - (CONS - (CONS (|mkAlistOfExplicitCategoryOps,atomizeOp| |op|) |sig|) - #2#)))))))))) - (SPADLET |opList| (REMDUP (ASSOCLEFT |u|))) - (PROG (#4=#:G167593) - (SPADLET #4# NIL) - (RETURN - (DO ((#5=#:G167598 |opList| (CDR #5#)) (|x| NIL)) - ((OR (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) (NREVERSE0 #4#)) - (SEQ - (EXIT - (SETQ #4# - (CONS - (CONS |x| (|mkAlistOfExplicitCategoryOps,fn| |x| |u|)) - #4#)))))))) - ((|isCategoryForm| |target| |$e|) NIL) - ((QUOTE T) - (|keyedSystemError| 'S2GE0016 - (CONS - "mkAlistOfExplicitCategoryOps" - (CONS "bad signature" NIL)))))))))) + ((AND (PAIRP |target|) (EQ (QCAR |target|) '|add|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |l| (QCDR |ISTMP#1|)) + 'T)))) + (SPADLET |target| |a|))) + (COND + ((AND (PAIRP |target|) (EQ (QCAR |target|) '|Join|) + (PROGN (SPADLET |l| (QCDR |target|)) 'T)) + (PROG (G167561) + (SPADLET G167561 NIL) + (RETURN + (DO ((G167566 |l| (CDR G167566)) (|cat| NIL)) + ((OR (ATOM G167566) + (PROGN (SETQ |cat| (CAR G167566)) NIL)) + G167561) + (SEQ (EXIT (SETQ G167561 + (|union| G167561 + (|mkAlistOfExplicitCategoryOps| + |cat|))))))))) + ((AND (PAIRP |target|) (EQ (QCAR |target|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T)))) + (SPADLET |l| + (|flattenSignatureList| (CONS 'PROGN |l|))) + (SPADLET |u| + (PROG (G167577) + (SPADLET G167577 NIL) + (RETURN + (DO ((G167583 |l| (CDR G167583)) + (|x| NIL)) + ((OR (ATOM G167583) + (PROGN + (SETQ |x| (CAR G167583)) + NIL)) + (NREVERSE0 G167577)) + (SEQ (EXIT + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) 'SIGNATURE) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (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)))))) + (SETQ G167577 + (CONS + (CONS + (|mkAlistOfExplicitCategoryOps,atomizeOp| + |op|) + |sig|) + G167577)))))))))) + (SPADLET |opList| (REMDUP (ASSOCLEFT |u|))) + (PROG (G167593) + (SPADLET G167593 NIL) + (RETURN + (DO ((G167598 |opList| (CDR G167598)) + (|x| NIL)) + ((OR (ATOM G167598) + (PROGN (SETQ |x| (CAR G167598)) NIL)) + (NREVERSE0 G167593)) + (SEQ (EXIT (SETQ G167593 + (CONS + (CONS |x| + (|mkAlistOfExplicitCategoryOps,fn| + |x| |u|)) + G167593)))))))) + ((|isCategoryForm| |target| |$e|) NIL) + ('T + (|keyedSystemError| 'S2GE0016 + (CONS "mkAlistOfExplicitCategoryOps" + (CONS "bad signature" NIL)))))))))) ;flattenSignatureList(x) == ; atom x => nil @@ -1763,69 +2009,73 @@ ; nil (DEFUN |flattenSignatureList| (|x|) - (PROG (|ISTMP#1| |cond| |ISTMP#2| |b1| |ISTMP#3| |b2| |l| |ll|) - (RETURN - (SEQ - (COND - ((ATOM |x|) NIL) - ((AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE SIGNATURE))) (CONS |x| NIL)) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE IF)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |cond| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b1| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |b2| (QCAR |ISTMP#3|)) - (QUOTE T))))))))) - (APPEND (|flattenSignatureList| |b1|) (|flattenSignatureList| |b2|))) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE PROGN)) - (PROGN (SPADLET |l| (QCDR |x|)) (QUOTE T))) - (SPADLET |ll| NIL) - (DO ((#0=#:G167664 |l| (CDR #0#)) (|x| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE SIGNATURE))) - (SPADLET |ll| (CONS |x| |ll|))) - ((QUOTE T) - (SPADLET |ll| (APPEND (|flattenSignatureList| |x|) |ll|))))))) - |ll|) - ((QUOTE T) NIL)))))) + (PROG (|ISTMP#1| |cond| |ISTMP#2| |b1| |ISTMP#3| |b2| |l| |ll|) + (RETURN + (SEQ (COND + ((ATOM |x|) NIL) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'SIGNATURE)) + (CONS |x| NIL)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |cond| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b1| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |b2| (QCAR |ISTMP#3|)) + 'T)))))))) + (APPEND (|flattenSignatureList| |b1|) + (|flattenSignatureList| |b2|))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PROGN) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (SPADLET |ll| NIL) + (DO ((G167664 |l| (CDR G167664)) (|x| NIL)) + ((OR (ATOM G167664) + (PROGN (SETQ |x| (CAR G167664)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) 'SIGNATURE)) + (SPADLET |ll| (CONS |x| |ll|))) + ('T + (SPADLET |ll| + (APPEND + (|flattenSignatureList| |x|) + |ll|))))))) + |ll|) + ('T NIL)))))) ;mkDatabasePred [a,t] == ; isCategoryForm(t,$e) => ['ofCategory,a,t] ; ['ofType,a,t] -(DEFUN |mkDatabasePred| (#0=#:G167684) - (PROG (|a| |t|) - (RETURN - (PROGN - (SPADLET |a| (CAR #0#)) - (SPADLET |t| (CADR #0#)) - (COND - ((|isCategoryForm| |t| |$e|) - (CONS (QUOTE |ofCategory|) (CONS |a| (CONS |t| NIL)))) - ((QUOTE T) - (CONS (QUOTE |ofType|) (CONS |a| (CONS |t| NIL))))))))) +(DEFUN |mkDatabasePred| (G167684) + (PROG (|a| |t|) + (DECLARE (SPECIAL |$e|)) + (RETURN + (PROGN + (SPADLET |a| (CAR G167684)) + (SPADLET |t| (CADR G167684)) + (COND + ((|isCategoryForm| |t| |$e|) + (CONS '|ofCategory| (CONS |a| (CONS |t| NIL)))) + ('T (CONS '|ofType| (CONS |a| (CONS |t| NIL))))))))) ;formal2Pattern x == ; SUBLIS(pairList($FormalMapVariableList,rest $PatternVariableList),x) (DEFUN |formal2Pattern| (|x|) - (SUBLIS - (|pairList| |$FormalMapVariableList| (CDR |$PatternVariableList|)) - |x|)) + (DECLARE (SPECIAL |$PatternVariableList|)) + (SUBLIS (|pairList| |$FormalMapVariableList| + (CDR |$PatternVariableList|)) + |x|)) ;updateDatabase(fname,cname,systemdir?) == ; -- for now in NRUNTIME do database update only if forced @@ -1842,24 +2092,24 @@ ; clearAllSlams [] (DEFUN |updateDatabase| (|fname| |cname| |systemdir?|) - (PROG (|oldFname|) - (RETURN - (COND - ((NULL |$forceDatabaseUpdate|) NIL) - ((BOOT-EQUAL |$newcompMode| (QUOTE |true|)) NIL) - ((QUOTE T) - (COND - ((SPADLET |oldFname| (|constructor?| |cname|)) - (|clearClams|) - (|clearAllSlams| NIL) - (COND - ((GETL |cname| (QUOTE LOADED)) (|clearConstructorCaches|)) - ((QUOTE T) NIL)))) - (COND - ((OR |$forceDatabaseUpdate| (NULL |systemdir?|)) - (|clearClams|) - (|clearAllSlams| NIL)) - ((QUOTE T) NIL))))))) + (declare (ignore |fname|)) + (PROG (|oldFname|) + (DECLARE (SPECIAL |$forceDatabaseUpdate| |$newcompMode|)) + (RETURN + (COND + ((NULL |$forceDatabaseUpdate|) NIL) + ((BOOT-EQUAL |$newcompMode| '|true|) NIL) + ('T + (COND + ((SPADLET |oldFname| (|constructor?| |cname|)) + (|clearClams|) (|clearAllSlams| NIL) + (COND + ((GETL |cname| 'LOADED) (|clearConstructorCaches|)) + ('T NIL)))) + (COND + ((OR |$forceDatabaseUpdate| (NULL |systemdir?|)) + (|clearClams|) (|clearAllSlams| NIL)) + ('T NIL))))))) ;removeCoreModemaps(modemapList,c) == ; newUserModemaps:= nil @@ -1873,43 +2123,49 @@ ; newUserModemaps (DEFUN |removeCoreModemaps| (|modemapList| |c|) - (PROG (|op| |mmList| |cname| |temp| |newUserModemaps|) - (RETURN - (SEQ - (PROGN - (SPADLET |newUserModemaps| NIL) - (SPADLET |c| (|opOf| (|unabbrev| |c|))) - (DO ((#0=#:G167724 |modemapList| (CDR #0#)) (#1=#:G167710 NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN - (SPADLET |op| (CAR #1#)) - (SPADLET |mmList| (CADR #1#)) - #1#) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |temp| NIL) - (DO ((#2=#:G167736 |mmList| (CDR #2#)) (|mm| NIL)) - ((OR (ATOM #2#) (PROGN (SETQ |mm| (CAR #2#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |cname| (|getDomainFromMm| |mm|)) - (COND - ((NEQUAL |cname| |c|) - (SPADLET |temp| (APPEND |temp| (CONS |mm| NIL)))) - ((QUOTE T) NIL)))))) - (COND - (|temp| - (SPADLET |newUserModemaps| - (APPEND |newUserModemaps| - (CONS (CONS |op| (CONS |temp| NIL)) NIL)))) - ((QUOTE T) NIL)))))) - |newUserModemaps|))))) + (PROG (|op| |mmList| |cname| |temp| |newUserModemaps|) + (RETURN + (SEQ (PROGN + (SPADLET |newUserModemaps| NIL) + (SPADLET |c| (|opOf| (|unabbrev| |c|))) + (DO ((G167724 |modemapList| (CDR G167724)) + (G167710 NIL)) + ((OR (ATOM G167724) + (PROGN (SETQ G167710 (CAR G167724)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G167710)) + (SPADLET |mmList| (CADR G167710)) + G167710) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |temp| NIL) + (DO ((G167736 |mmList| (CDR G167736)) + (|mm| NIL)) + ((OR (ATOM G167736) + (PROGN + (SETQ |mm| (CAR G167736)) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (SPADLET |cname| + (|getDomainFromMm| |mm|)) + (COND + ((NEQUAL |cname| |c|) + (SPADLET |temp| + (APPEND |temp| + (CONS |mm| NIL)))) + ('T NIL)))))) + (COND + (|temp| (SPADLET |newUserModemaps| + (APPEND |newUserModemaps| + (CONS + (CONS |op| (CONS |temp| NIL)) + NIL)))) + ('T NIL)))))) + |newUserModemaps|))))) ;addCoreModemap(modemapList,op,modemap,cname) == ; entry:= ASSQ(op,modemapList) => @@ -1918,15 +2174,19 @@ ; modeMapList:= [:modemapList,[op,[ modemap]]] (DEFUN |addCoreModemap| (|modemapList| |op| |modemap| |cname|) - (PROG (|entry| |modeMapList|) - (RETURN - (COND - ((SPADLET |entry| (ASSQ |op| |modemapList|)) - (RPLAC (CADR |entry|) (CONS |modemap| (CADR |entry|))) |modemapList|) - ((QUOTE T) - (SPADLET |modeMapList| - (APPEND |modemapList| - (CONS (CONS |op| (CONS (CONS |modemap| NIL) NIL)) NIL)))))))) + (declare (ignore |cname|)) + (PROG (|entry| |modeMapList|) + (RETURN + (COND + ((SPADLET |entry| (ASSQ |op| |modemapList|)) + (RPLAC (CADR |entry|) (CONS |modemap| (CADR |entry|))) + |modemapList|) + ('T + (SPADLET |modeMapList| + (APPEND |modemapList| + (CONS (CONS |op| + (CONS (CONS |modemap| NIL) NIL)) + NIL)))))))) ;REMOVER(lst,item) == ; --destructively removes item from lst @@ -1937,39 +2197,38 @@ ; RPLNODE(lst,REMOVER(first lst,item),REMOVER(rest lst,item)) (DEFUN REMOVER (|lst| |item|) - (COND - ((NULL (PAIRP |lst|)) - (COND ((BOOT-EQUAL |lst| |item|) NIL) ((QUOTE T) |lst|))) - ((BOOT-EQUAL (CAR |lst|) |item|) (CDR |lst|)) - ((QUOTE T) - (RPLNODE |lst| - (REMOVER (CAR |lst|) |item|) - (REMOVER (CDR |lst|) |item|))))) + (COND + ((NULL (PAIRP |lst|)) + (COND ((BOOT-EQUAL |lst| |item|) NIL) ('T |lst|))) + ((BOOT-EQUAL (CAR |lst|) |item|) (CDR |lst|)) + ('T + (RPLNODE |lst| (REMOVER (CAR |lst|) |item|) + (REMOVER (CDR |lst|) |item|))))) ;allLASSOCs(op,alist) == ; [value for [key,:value] in alist | key = op] (DEFUN |allLASSOCs| (|op| |alist|) - (PROG (|key| |value|) - (RETURN - (SEQ - (PROG (#0=#:G167775) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167782 |alist| (CDR #1#)) (#2=#:G167765 NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ #2# (CAR #1#)) NIL) - (PROGN - (PROGN - (SPADLET |key| (CAR #2#)) - (SPADLET |value| (CDR #2#)) - #2#) - NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |key| |op|) (SETQ #0# (CONS |value| #0#))))))))))))) + (PROG (|key| |value|) + (RETURN + (SEQ (PROG (G167775) + (SPADLET G167775 NIL) + (RETURN + (DO ((G167782 |alist| (CDR G167782)) + (G167765 NIL)) + ((OR (ATOM G167782) + (PROGN (SETQ G167765 (CAR G167782)) NIL) + (PROGN + (PROGN + (SPADLET |key| (CAR G167765)) + (SPADLET |value| (CDR G167765)) + G167765) + NIL)) + (NREVERSE0 G167775)) + (SEQ (EXIT (COND + ((BOOT-EQUAL |key| |op|) + (SETQ G167775 + (CONS |value| G167775))))))))))))) ;loadDependents fn == ; isExistingFile [fn,$spadLibFT,"*"] => @@ -1982,26 +2241,34 @@ ; loadIfNecessary x (DEFUN |loadDependents| (|fn|) - (PROG (|stream| |l|) - (RETURN - (SEQ - (COND - ((|isExistingFile| (CONS |fn| (CONS |$spadLibFT| (CONS (QUOTE *) NIL)))) - (EXIT - (COND - ((MEMQ (QUOTE |dependents|) (RKEYIDS |fn| |$spadLibFT|)) - (EXIT - (PROGN - (SPADLET |stream| (|readLib1| |fn| |$spadLibFT| (QUOTE *))) - (SPADLET |l| (|rread| (QUOTE |dependents|) |stream| NIL)) - (RSHUT |stream|) - (DO ((#0=#:G167800 |l| (CDR #0#)) (|x| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |x| (QUOTE |SubDomain|)) NIL) - ((QUOTE T) (|loadIfNecessary| |x|))))))))))))))))) + (PROG (|stream| |l|) + (DECLARE (SPECIAL |$spadLibFT|)) + (RETURN + (SEQ (COND + ((|isExistingFile| + (CONS |fn| (CONS |$spadLibFT| (CONS '* NIL)))) + (EXIT (COND + ((MEMQ '|dependents| (RKEYIDS |fn| |$spadLibFT|)) + (EXIT (PROGN + (SPADLET |stream| + (|readLib1| |fn| |$spadLibFT| + '*)) + (SPADLET |l| + (|rread| '|dependents| |stream| + NIL)) + (RSHUT |stream|) + (DO ((G167800 |l| (CDR G167800)) + (|x| NIL)) + ((OR (ATOM G167800) + (PROGN + (SETQ |x| (CAR G167800)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((BOOT-EQUAL |x| '|SubDomain|) + NIL) + ('T (|loadIfNecessary| |x|))))))))))))))))) ;--% Miscellaneous Stuff ;getOplistForConstructorForm (form := [op,:argl]) == @@ -2015,48 +2282,53 @@ ; for [op,:signatureAlist] in opAlist] (DEFUN |getOplistForConstructorForm| (|form|) - (PROG (|argl| |pairlis| |opAlist| |op| |signatureAlist|) - (RETURN - (SEQ - (PROGN - (SPADLET |op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (SPADLET |pairlis| - (PROG (#0=#:G167832) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167838 |$FormalMapVariableList| (CDR #1#)) - (|fv| NIL) - (#2=#:G167839 |argl| (CDR #2#)) - (|arg| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |fv| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |arg| (CAR #2#)) NIL)) - (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (CONS |fv| |arg|) #0#)))))))) - (SPADLET |opAlist| (|getOperationAlistFromLisplib| |op|)) - (PROG (#3=#:G167848) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G167854 |opAlist| (CDR #4#)) (#5=#:G167811 NIL)) - ((OR (ATOM #4#) - (PROGN (SETQ #5# (CAR #4#)) NIL) - (PROGN - (PROGN - (SPADLET |op| (CAR #5#)) - (SPADLET |signatureAlist| (CDR #5#)) - #5#) - NIL)) - #3#) - (SEQ - (EXIT - (SETQ #3# - (APPEND #3# - (|getOplistWithUniqueSignatures| - |op| - |pairlis| - |signatureAlist|))))))))))))) + (PROG (|argl| |pairlis| |opAlist| |op| |signatureAlist|) + (DECLARE (SPECIAL |$FormalMapVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |pairlis| + (PROG (G167832) + (SPADLET G167832 NIL) + (RETURN + (DO ((G167838 |$FormalMapVariableList| + (CDR G167838)) + (|fv| NIL) + (G167839 |argl| (CDR G167839)) + (|arg| NIL)) + ((OR (ATOM G167838) + (PROGN + (SETQ |fv| (CAR G167838)) + NIL) + (ATOM G167839) + (PROGN + (SETQ |arg| (CAR G167839)) + NIL)) + (NREVERSE0 G167832)) + (SEQ (EXIT (SETQ G167832 + (CONS (CONS |fv| |arg|) + G167832)))))))) + (SPADLET |opAlist| (|getOperationAlistFromLisplib| |op|)) + (PROG (G167848) + (SPADLET G167848 NIL) + (RETURN + (DO ((G167854 |opAlist| (CDR G167854)) + (G167811 NIL)) + ((OR (ATOM G167854) + (PROGN (SETQ G167811 (CAR G167854)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G167811)) + (SPADLET |signatureAlist| + (CDR G167811)) + G167811) + NIL)) + G167848) + (SEQ (EXIT (SETQ G167848 + (APPEND G167848 + (|getOplistWithUniqueSignatures| + |op| |pairlis| |signatureAlist|))))))))))))) ;getOplistWithUniqueSignatures(op,pairlis,signatureAlist) == ; alist:= nil @@ -2066,37 +2338,40 @@ ; alist) ; alist -(DEFUN |getOplistWithUniqueSignatures| (|op| |pairlis| |signatureAlist|) - (PROG (|sig| |slotNumber| |pred| |kind| |alist|) - (RETURN - (SEQ - (PROGN - (SPADLET |alist| NIL) - (DO ((#0=#:G167884 |signatureAlist| (CDR #0#)) (#1=#:G167872 NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN - (SPADLET |sig| (CAR #1#)) - (SPADLET |slotNumber| (CADR #1#)) - (SPADLET |pred| (CADDR #1#)) - (SPADLET |kind| (CADDDR #1#)) - #1#) - NIL)) - NIL) - (SEQ - (EXIT - (COND - ((NEQUAL |kind| (QUOTE |Subsumed|)) - (SPADLET |alist| - (|insertAlist| - (SUBLIS |pairlis| (CONS |op| (CONS |sig| NIL))) - (SUBLIS |pairlis| - (CONS - |pred| - (CONS (CONS |kind| (CONS NIL (CONS |slotNumber| NIL))) NIL))) - |alist|))))))) - |alist|))))) +(DEFUN |getOplistWithUniqueSignatures| + (|op| |pairlis| |signatureAlist|) + (PROG (|sig| |slotNumber| |pred| |kind| |alist|) + (RETURN + (SEQ (PROGN + (SPADLET |alist| NIL) + (DO ((G167884 |signatureAlist| (CDR G167884)) + (G167872 NIL)) + ((OR (ATOM G167884) + (PROGN (SETQ G167872 (CAR G167884)) NIL) + (PROGN + (PROGN + (SPADLET |sig| (CAR G167872)) + (SPADLET |slotNumber| (CADR G167872)) + (SPADLET |pred| (CADDR G167872)) + (SPADLET |kind| (CADDDR G167872)) + G167872) + NIL)) + NIL) + (SEQ (EXIT (COND + ((NEQUAL |kind| '|Subsumed|) + (SPADLET |alist| + (|insertAlist| + (SUBLIS |pairlis| + (CONS |op| (CONS |sig| NIL))) + (SUBLIS |pairlis| + (CONS |pred| + (CONS + (CONS |kind| + (CONS NIL + (CONS |slotNumber| NIL))) + NIL))) + |alist|))))))) + |alist|))))) ;--% Code For Modemap Insertion ;insertModemap(new,mmList) == @@ -2106,9 +2381,7 @@ ; [new,:mmList] (DEFUN |insertModemap| (|new| |mmList|) - (COND - ((NULL |mmList|) (CONS |new| NIL)) - ((QUOTE T) (CONS |new| |mmList|)))) + (COND ((NULL |mmList|) (CONS |new| NIL)) ('T (CONS |new| |mmList|)))) ;--% Exposure Group Code ;dropPrefix(fn) == @@ -2116,18 +2389,12 @@ ; fn (DEFUN |dropPrefix| (|fn|) - (COND - ((|member| - (ELT |fn| 0) - (CONS - (|char| (QUOTE ?)) - (CONS - (|char| (QUOTE -)) - (CONS - (|char| (QUOTE +)) - NIL)))) - (SUBSTRING |fn| 1 NIL)) - ((QUOTE T) |fn|))) + (COND + ((|member| (ELT |fn| 0) + (CONS (|char| '?) + (CONS (|char| '-) (CONS (|char| '+) NIL)))) + (SUBSTRING |fn| 1 NIL)) + ('T |fn|))) ;isExposedConstructor name == ; -- this function checks the local exposure data in the frame to @@ -2149,28 +2416,31 @@ ; found (DEFUN |isExposedConstructor| (|name|) - (PROG (|x| |found|) - (RETURN - (SEQ - (COND - ((MEMQ |name| (QUOTE (|Union| |Record| |Mapping|))) (QUOTE T)) - ((MEMQ |name| (ELT |$localExposureData| 2)) NIL) - ((MEMQ |name| (ELT |$localExposureData| 1)) (QUOTE T)) - ((QUOTE T) - (SPADLET |found| NIL) - (DO ((#0=#:G167914 (ELT |$localExposureData| 0) (CDR #0#)) (|g| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |g| (CAR #0#)) NIL) - (NULL (NULL |found|))) - NIL) - (SEQ - (EXIT - (COND - ((NULL (SPADLET |x| (GETALIST |$globalExposureGroupAlist| |g|))) - (QUOTE |iterate|)) - ((GETALIST |x| |name|) - (SPADLET |found| (QUOTE T))) ((QUOTE T) NIL))))) - |found|)))))) + (PROG (|x| |found|) + (DECLARE (SPECIAL |$globalExposureGroupAlist| |$localExposureData|)) + (RETURN + (SEQ (COND + ((MEMQ |name| '(|Union| |Record| |Mapping|)) 'T) + ((MEMQ |name| (ELT |$localExposureData| 2)) NIL) + ((MEMQ |name| (ELT |$localExposureData| 1)) 'T) + ('T (SPADLET |found| NIL) + (DO ((G167914 (ELT |$localExposureData| 0) + (CDR G167914)) + (|g| NIL)) + ((OR (ATOM G167914) + (PROGN (SETQ |g| (CAR G167914)) NIL) + (NULL (NULL |found|))) + NIL) + (SEQ (EXIT (COND + ((NULL (SPADLET |x| + (GETALIST + |$globalExposureGroupAlist| |g|))) + '|iterate|) + ((GETALIST |x| |name|) + (SPADLET |found| 'T)) + ('T NIL))))) + |found|)))))) + @ \eject