diff --git a/changelog b/changelog index dbc5bb3..8aeb692 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +20091009 tpd src/axiom-website/patches.html 20091009.04.tpd.patch +20091009 tpd src/interp/clam.lisp cleanup 20091009 tpd src/axiom-website/patches.html 20091009.03.tpd.patch 20091009 tpd src/interp/clammed.lisp cleanup 20091009 tpd src/axiom-website/patches.html 20091009.02.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 7ce879b..6ae99d3 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -2141,5 +2141,7 @@ src/interp/database.lisp cleanup
src/interp/compress.lisp cleanup
20091009.03.tpd.patch src/interp/clammed.lisp cleanup
+20091009.04.tpd.patch +src/interp/clam.lisp cleanup
diff --git a/src/interp/clam.lisp.pamphlet b/src/interp/clam.lisp.pamphlet index 0a538e5..60593b8 100644 --- a/src/interp/clam.lisp.pamphlet +++ b/src/interp/clam.lisp.pamphlet @@ -142,207 +142,212 @@ ;;; *** |compClam| REDEFINED (DEFUN |compClam| (|op| |argl| |body| |$clamList|) - (DECLARE (SPECIAL |$clamList|)) - (PROG (|ISTMP#1| |kind| |ISTMP#2| |eqEtc| |options| |u| |shiftFl| |countFl| - |cacheCount| |phrase| |auxfn| |g1| |LETTMP#1| |arg| |computeValue| - |cacheName| |hitCounter| |callCounter| |callCountCode| |hitCountCode| - |g2| |g3| |lookUpFunction| |returnFoundValue| |namePart| - |secondPredPair| |resetCacheEntry| |thirdPredPair| |codeBody| |lamex| - |mainFunction| |computeFunction| |cacheType| |cacheResetCode| - |cacheCountCode| |cacheVector|) - (RETURN - (PROGN - (COND - (|$InteractiveMode| (|startTimingProcess| (QUOTE |compilation|)))) - (COND - ((NULL - (PROGN - (SPADLET |ISTMP#1| (SPADLET |u| (LASSQ |op| |$clamList|))) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |kind| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |eqEtc| (QCAR |ISTMP#2|)) - (SPADLET |options| (QCDR |ISTMP#2|)) (QUOTE T))))))) - (|keyedSystemError| (QUOTE S2GE0004) (CONS |op| NIL)))) - (SPADLET |$clamList| NIL) - (COND - ((SPADLET |u| (S- |options| (QUOTE (|shift| |count|)))) - (|keyedSystemError| (QUOTE S2GE0006) (CONS |op| |u|)))) - (SPADLET |shiftFl| (MEMQ (QUOTE |shift|) |options|)) - (SPADLET |countFl| (MEMQ (QUOTE |count|) |options|)) - (COND - ((AND (> (|#| |argl|) 1) (BOOT-EQUAL |eqEtc| (QUOTE EQ))) - (|keyedSystemError| (QUOTE S2GE0007) (CONS |op| NIL)))) - (COND - ((AND (NULL (IDENTP |kind|)) (OR (NULL (INTEGERP |kind|)) (> 1 |kind|))) - (|keyedSystemError| (QUOTE S2GE0005) (CONS |op| NIL))) - ((IDENTP |kind|) - (COND - (|shiftFl| - (|keyedSystemError| (QUOTE S2GE0008) (CONS |op| NIL))) - ((QUOTE T) - (|compHash| |op| |argl| |body| - (COND - ((BOOT-EQUAL |kind| (QUOTE |hash|)) NIL) - ((QUOTE T) |kind|)) - |eqEtc| |countFl|)))) - ((QUOTE T) - (SPADLET |cacheCount| |kind|) - (COND - ((NULL |argl|) (|keyedSystemError| (QUOTE S2GE0009) (CONS |op| NIL)))) - (SPADLET |phrase| - (COND - ((EQL |cacheCount| 1) (CONS (MAKESTRING "computed value only") NIL)) - ((QUOTE T) - (APPEND - (|bright| |cacheCount|) - (CONS (MAKESTRING "computed values") NIL))))) - (|sayBrightly| - (APPEND (|bright| |op|) (CONS (MAKESTRING "will save last") |phrase|))) - (SPADLET |auxfn| (INTERNL |op| (MAKESTRING ";"))) - (SPADLET |g1| (GENSYM)) - (SPADLET |LETTMP#1| - (COND - ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) - (CONS (CONS |g1| NIL) (CONS (CONS |auxfn| (CONS |g1| NIL)) NIL))) - ((QUOTE T) - (CONS - |g1| - (CONS - (CONS - (QUOTE APPLX) - (CONS - (CONS (QUOTE |function|) (CONS |auxfn| NIL)) - (CONS |g1| NIL))) - NIL))))) - (SPADLET |arg| (CAR |LETTMP#1|)) - (SPADLET |computeValue| (CADR |LETTMP#1|)) - (SPADLET |cacheName| (INTERNL |op| (MAKESTRING ";AL"))) - (COND - ((BOOT-EQUAL |$reportCounts| (QUOTE T)) - (SPADLET |hitCounter| (INTERNL |op| (MAKESTRING ";hit"))) - (SPADLET |callCounter| (INTERNL |op| (MAKESTRING ";calls"))) - (SET |hitCounter| 0) - (SET |callCounter| 0) - (SPADLET |callCountCode| - (CONS - (CONS - (QUOTE SETQ) - (CONS - |callCounter| - (CONS (CONS (QUOTE QSADD1) (CONS |callCounter| NIL)) NIL))) - NIL)) - (SPADLET |hitCountCode| - (CONS - (CONS - (QUOTE SETQ) - (CONS - |hitCounter| - (CONS (CONS (QUOTE QSADD1) (CONS |hitCounter| NIL)) NIL))) - NIL)))) - (SPADLET |g2| (GENSYM)) - (SPADLET |g3| (GENSYM)) - (SPADLET |lookUpFunction| - (COND - (|shiftFl| - (COND - (|countFl| (QUOTE |assocCacheShiftCount|)) - ((QUOTE T) (QUOTE |assocCacheShift|)))) - (|countFl| (QUOTE |assocCacheCount|)) - ((QUOTE T) (QUOTE |assocCache|)))) - (SPADLET |returnFoundValue| - (COND - (|countFl| (CONS (QUOTE CDDR) (CONS |g3| NIL))) - ((QUOTE T) (CONS (QUOTE CDR) (CONS |g3| NIL))))) - (SPADLET |namePart| - (COND (|countFl| |cacheName|) ((QUOTE T) (MKQ |cacheName|)))) - (SPADLET |secondPredPair| - (CONS - (CONS - (QUOTE SETQ) - (CONS - |g3| - (CONS - (CONS - |lookUpFunction| - (CONS |g1| (CONS |namePart| (CONS |eqEtc| NIL)))) - NIL))) - (APPEND |hitCountCode| (CONS |returnFoundValue| NIL)))) - (SPADLET |resetCacheEntry| - (COND - (|countFl| - (CONS (QUOTE CONS) (CONS 1 (CONS |g2| NIL)))) ((QUOTE T) |g2|))) - (SPADLET |thirdPredPair| - (CONS - (QUOTE (QUOTE T)) - (CONS - (CONS (QUOTE SETQ) (CONS |g2| (CONS |computeValue| NIL))) - (CONS - (CONS - (QUOTE SETQ) - (CONS |g3| (CONS (CONS (QUOTE CAR) (CONS |cacheName| NIL)) NIL))) - (CONS - (CONS (QUOTE RPLACA) (CONS |g3| (CONS |g1| NIL))) - (CONS - (CONS (QUOTE RPLACD) (CONS |g3| (CONS |resetCacheEntry| NIL))) - (CONS |g2| NIL))))))) - (SPADLET |codeBody| - (CONS - (QUOTE PROG) - (CONS - (CONS |g2| (CONS |g3| NIL)) - (APPEND |callCountCode| - (CONS - (CONS - (QUOTE RETURN) - (CONS - (CONS - (QUOTE COND) - (CONS |secondPredPair| (CONS |thirdPredPair| NIL))) - NIL)) - NIL))))) - (SPADLET |lamex| (CONS (QUOTE LAM) (CONS |arg| (CONS |codeBody| NIL)))) - (SPADLET |mainFunction| (CONS |op| (CONS |lamex| NIL))) - (SPADLET |computeFunction| - (CONS |auxfn| (CONS (CONS (QUOTE LAMBDA) (CONS |argl| |body|)) NIL))) - (|compileInteractive| |mainFunction|) - (COND - (|$reportCompilation| - (|sayBrightlyI| - (|bright| (MAKESTRING "Generated LISP code for function:"))) - (|pp| |computeFunction|))) - (|compileQuietly| (CONS |computeFunction| NIL)) - (SPADLET |cacheType| (QUOTE |function|)) - (SPADLET |cacheResetCode| - (CONS - (QUOTE SETQ) - (CONS - |cacheName| - (CONS (CONS (QUOTE |initCache|) (CONS |cacheCount| NIL)) NIL)))) - (SPADLET |cacheCountCode| - (CONS - (QUOTE |countCircularAlist|) - (CONS |cacheName| (CONS |cacheCount| NIL)))) - (SPADLET |cacheVector| - (|mkCacheVec| |op| |cacheName| |cacheType| |cacheResetCode| - |cacheCountCode|)) - (|LAM,EVALANDFILEACTQ| - (CONS - (QUOTE PUT) - (CONS - (MKQ |op|) - (CONS - (MKQ (QUOTE |cacheInfo|)) - (CONS (MKQ |cacheVector|) NIL))))) - (|LAM,EVALANDFILEACTQ| |cacheResetCode|) - (COND (|$InteractiveMode| (|stopTimingProcess| (QUOTE |compilation|)))) - |op|)))))) -; + (DECLARE (SPECIAL |$clamList|)) + (PROG (|ISTMP#1| |kind| |ISTMP#2| |eqEtc| |options| |u| |shiftFl| + |countFl| |cacheCount| |phrase| |auxfn| |g1| |LETTMP#1| + |arg| |computeValue| |cacheName| |hitCounter| |callCounter| + |callCountCode| |hitCountCode| |g2| |g3| |lookUpFunction| + |returnFoundValue| |namePart| |secondPredPair| + |resetCacheEntry| |thirdPredPair| |codeBody| |lamex| + |mainFunction| |computeFunction| |cacheType| + |cacheResetCode| |cacheCountCode| |cacheVector|) + (DECLARE (SPECIAL |$InteractiveMode| |$reportCompilation| + |$reportCounts| |$clamList|)) + (RETURN + (PROGN + (COND + (|$InteractiveMode| (|startTimingProcess| '|compilation|))) + (COND + ((NULL (PROGN + (SPADLET |ISTMP#1| + (SPADLET |u| (LASSQ |op| |$clamList|))) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |kind| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |eqEtc| (QCAR |ISTMP#2|)) + (SPADLET |options| (QCDR |ISTMP#2|)) + 'T)))))) + (|keyedSystemError| 'S2GE0004 (CONS |op| NIL)))) + (SPADLET |$clamList| NIL) + (COND + ((SPADLET |u| (S- |options| '(|shift| |count|))) + (|keyedSystemError| 'S2GE0006 (CONS |op| |u|)))) + (SPADLET |shiftFl| (MEMQ '|shift| |options|)) + (SPADLET |countFl| (MEMQ '|count| |options|)) + (COND + ((AND (> (|#| |argl|) 1) (BOOT-EQUAL |eqEtc| 'EQ)) + (|keyedSystemError| 'S2GE0007 (CONS |op| NIL)))) + (COND + ((AND (NULL (IDENTP |kind|)) + (OR (NULL (INTEGERP |kind|)) (> 1 |kind|))) + (|keyedSystemError| 'S2GE0005 (CONS |op| NIL))) + ((IDENTP |kind|) + (COND + (|shiftFl| (|keyedSystemError| 'S2GE0008 (CONS |op| NIL))) + ('T + (|compHash| |op| |argl| |body| + (COND ((BOOT-EQUAL |kind| '|hash|) NIL) ('T |kind|)) + |eqEtc| |countFl|)))) + ('T (SPADLET |cacheCount| |kind|) + (COND + ((NULL |argl|) + (|keyedSystemError| 'S2GE0009 (CONS |op| NIL)))) + (SPADLET |phrase| + (COND + ((EQL |cacheCount| 1) + (CONS (MAKESTRING "computed value only") NIL)) + ('T + (APPEND (|bright| |cacheCount|) + (CONS (MAKESTRING "computed values") + NIL))))) + (|sayBrightly| + (APPEND (|bright| |op|) + (CONS (MAKESTRING "will save last") |phrase|))) + (SPADLET |auxfn| (INTERNL |op| (MAKESTRING ";"))) + (SPADLET |g1| (GENSYM)) + (SPADLET |LETTMP#1| + (COND + ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) + (CONS (CONS |g1| NIL) + (CONS (CONS |auxfn| (CONS |g1| NIL)) NIL))) + ('T + (CONS |g1| + (CONS (CONS 'APPLX + (CONS + (CONS '|function| + (CONS |auxfn| NIL)) + (CONS |g1| NIL))) + NIL))))) + (SPADLET |arg| (CAR |LETTMP#1|)) + (SPADLET |computeValue| (CADR |LETTMP#1|)) + (SPADLET |cacheName| (INTERNL |op| (MAKESTRING ";AL"))) + (COND + ((BOOT-EQUAL |$reportCounts| 'T) + (SPADLET |hitCounter| (INTERNL |op| (MAKESTRING ";hit"))) + (SPADLET |callCounter| + (INTERNL |op| (MAKESTRING ";calls"))) + (SET |hitCounter| 0) (SET |callCounter| 0) + (SPADLET |callCountCode| + (CONS (CONS 'SETQ + (CONS |callCounter| + (CONS + (CONS 'QSADD1 + (CONS |callCounter| NIL)) + NIL))) + NIL)) + (SPADLET |hitCountCode| + (CONS (CONS 'SETQ + (CONS |hitCounter| + (CONS + (CONS 'QSADD1 + (CONS |hitCounter| NIL)) + NIL))) + NIL)))) + (SPADLET |g2| (GENSYM)) (SPADLET |g3| (GENSYM)) + (SPADLET |lookUpFunction| + (COND + (|shiftFl| + (COND + (|countFl| '|assocCacheShiftCount|) + ('T '|assocCacheShift|))) + (|countFl| '|assocCacheCount|) + ('T '|assocCache|))) + (SPADLET |returnFoundValue| + (COND + (|countFl| (CONS 'CDDR (CONS |g3| NIL))) + ('T (CONS 'CDR (CONS |g3| NIL))))) + (SPADLET |namePart| + (COND + (|countFl| |cacheName|) + ('T (MKQ |cacheName|)))) + (SPADLET |secondPredPair| + (CONS (CONS 'SETQ + (CONS |g3| + (CONS + (CONS |lookUpFunction| + (CONS |g1| + (CONS |namePart| + (CONS |eqEtc| NIL)))) + NIL))) + (APPEND |hitCountCode| + (CONS |returnFoundValue| NIL)))) + (SPADLET |resetCacheEntry| + (COND + (|countFl| (CONS 'CONS (CONS 1 (CONS |g2| NIL)))) + ('T |g2|))) + (SPADLET |thirdPredPair| + (CONS ''T + (CONS (CONS 'SETQ + (CONS |g2| + (CONS |computeValue| NIL))) + (CONS (CONS 'SETQ + (CONS |g3| + (CONS + (CONS 'CAR + (CONS |cacheName| NIL)) + NIL))) + (CONS + (CONS 'RPLACA + (CONS |g3| (CONS |g1| NIL))) + (CONS + (CONS 'RPLACD + (CONS |g3| + (CONS |resetCacheEntry| NIL))) + (CONS |g2| NIL))))))) + (SPADLET |codeBody| + (CONS 'PROG + (CONS (CONS |g2| (CONS |g3| NIL)) + (APPEND |callCountCode| + (CONS + (CONS 'RETURN + (CONS + (CONS 'COND + (CONS |secondPredPair| + (CONS |thirdPredPair| NIL))) + NIL)) + NIL))))) + (SPADLET |lamex| + (CONS 'LAM (CONS |arg| (CONS |codeBody| NIL)))) + (SPADLET |mainFunction| (CONS |op| (CONS |lamex| NIL))) + (SPADLET |computeFunction| + (CONS |auxfn| + (CONS (CONS 'LAMBDA (CONS |argl| |body|)) + NIL))) + (|compileInteractive| |mainFunction|) + (COND + (|$reportCompilation| + (|sayBrightlyI| + (|bright| + (MAKESTRING + "Generated LISP code for function:"))) + (|pp| |computeFunction|))) + (|compileQuietly| (CONS |computeFunction| NIL)) + (SPADLET |cacheType| '|function|) + (SPADLET |cacheResetCode| + (CONS 'SETQ + (CONS |cacheName| + (CONS (CONS '|initCache| + (CONS |cacheCount| NIL)) + NIL)))) + (SPADLET |cacheCountCode| + (CONS '|countCircularAlist| + (CONS |cacheName| (CONS |cacheCount| NIL)))) + (SPADLET |cacheVector| + (|mkCacheVec| |op| |cacheName| |cacheType| + |cacheResetCode| |cacheCountCode|)) + (|LAM,EVALANDFILEACTQ| + (CONS 'PUT + (CONS (MKQ |op|) + (CONS (MKQ '|cacheInfo|) + (CONS (MKQ |cacheVector|) NIL))))) + (|LAM,EVALANDFILEACTQ| |cacheResetCode|) + (COND + (|$InteractiveMode| (|stopTimingProcess| '|compilation|))) + |op|)))))) + ;compHash(op,argl,body,cacheNameOrNil,eqEtc,countFl) == ; --Note: when cacheNameOrNil^=nil, it names a global hashtable ; @@ -456,278 +461,272 @@ ;;; *** |compHash| REDEFINED -(DEFUN |compHash| (|op| |argl| |body| |cacheNameOrNil| |eqEtc| |countFl|) - (PROG (|auxfn| |g1| |key| |LETTMP#1| |arg| |cacheArgKey| |computeValue| - |cacheName| |hitCounter| |callCounter| |callCountCode| |hitCountCode| - |g2| |returnFoundValue| |getCode| |secondPredPair| |putCode| - |thirdPredPair| |codeBody| |lamex| |mainFunction| |computeFunction| - |cacheType| |weakStrong| |cacheResetCode| |cacheCountCode| - |cacheVector|) - (RETURN - (PROGN - (COND - ((AND - |cacheNameOrNil| - (NEQUAL |cacheNameOrNil| (QUOTE |$ConstructorCache|))) - (|keyedSystemError| (QUOTE S2GE0010) (CONS |op| NIL)))) - (COND - ((NULL |argl|) - (COND - ((NULL |cacheNameOrNil|) - (|keyedSystemError| (QUOTE S2GE0011) (CONS |op| NIL))) - ((QUOTE T) NIL)))) - (COND - ((AND - (NULL |cacheNameOrNil|) - (NULL (MEMQ |eqEtc| (QUOTE (EQ CVEC UEQUAL))))) - (|keyedSystemError| (QUOTE S2GE0012) (CONS |op| NIL))) - ((QUOTE T) - (SPADLET |auxfn| (INTERNL |op| (MAKESTRING ";"))) - (SPADLET |g1| (GENSYM)) - (SPADLET |LETTMP#1| - (COND - ((NULL |argl|) (CONS NIL (CONS NIL (CONS (CONS |auxfn| NIL) NIL)))) - ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) - (SPADLET |key| +(DEFUN |compHash| + (|op| |argl| |body| |cacheNameOrNil| |eqEtc| |countFl|) + (PROG (|auxfn| |g1| |key| |LETTMP#1| |arg| |cacheArgKey| + |computeValue| |cacheName| |hitCounter| |callCounter| + |callCountCode| |hitCountCode| |g2| |returnFoundValue| + |getCode| |secondPredPair| |putCode| |thirdPredPair| + |codeBody| |lamex| |mainFunction| |computeFunction| + |cacheType| |weakStrong| |cacheResetCode| + |cacheCountCode| |cacheVector|) + (DECLARE (SPECIAL |$reportCompilation| |$reportCounts| + |$ConstructorCache|)) + (RETURN + (PROGN + (COND + ((AND |cacheNameOrNil| + (NEQUAL |cacheNameOrNil| '|$ConstructorCache|)) + (|keyedSystemError| 'S2GE0010 (CONS |op| NIL)))) + (COND + ((NULL |argl|) (COND - (|cacheNameOrNil| (CONS (QUOTE |devaluate|) (CONS |g1| NIL))) - ((QUOTE T) |g1|))) - (CONS - (CONS |g1| NIL) - (CONS - (CONS (QUOTE LIST) (CONS |key| NIL)) - (CONS (CONS |auxfn| (CONS |g1| NIL)) NIL)))) - ((QUOTE T) - (SPADLET |key| - (COND - (|cacheNameOrNil| (CONS (QUOTE |devaluateList|) (CONS |g1| NIL))) - ((QUOTE T) |g1|))) - (CONS - |g1| - (CONS - |key| - (CONS - (CONS - (QUOTE APPLY) - (CONS - (CONS (QUOTE |function|) (CONS |auxfn| NIL)) - (CONS |g1| NIL))) - NIL)))))) - (SPADLET |arg| (CAR |LETTMP#1|)) - (SPADLET |cacheArgKey| (CADR |LETTMP#1|)) - (SPADLET |computeValue| (CADDR |LETTMP#1|)) - (SPADLET |cacheName| - (OR |cacheNameOrNil| (INTERNL |op| (MAKESTRING ";AL")))) - (COND - ((BOOT-EQUAL |$reportCounts| (QUOTE T)) - (SPADLET |hitCounter| (INTERNL |op| (MAKESTRING ";hit"))) - (SPADLET |callCounter| (INTERNL |op| (MAKESTRING ";calls"))) - (SET |hitCounter| 0) - (SET |callCounter| 0) - (SPADLET |callCountCode| - (CONS - (CONS - (QUOTE SETQ) - (CONS - |callCounter| - (CONS (CONS (QUOTE QSADD1) (CONS |callCounter| NIL)) NIL))) - NIL)) - (SPADLET |hitCountCode| - (CONS - (CONS - (QUOTE SETQ) - (CONS - |hitCounter| - (CONS (CONS (QUOTE QSADD1) (CONS |hitCounter| NIL)) NIL))) - NIL)))) - (SPADLET |g2| (GENSYM)) - (SPADLET |returnFoundValue| - (COND - ((NULL |argl|) - (COND - (|countFl| - (CONS - (QUOTE |CDRwithIncrement|) - (CONS (CONS (QUOTE CDAR) (CONS |g2| NIL)) NIL))) - ((QUOTE T) (CONS (QUOTE CDAR) (CONS |g2| NIL))))) - (|countFl| (CONS (QUOTE |CDRwithIncrement|) (CONS |g2| NIL))) - ((QUOTE T) |g2|))) - (SPADLET |getCode| - (COND - ((NULL |argl|) - (CONS (QUOTE HGET) (CONS |cacheName| (CONS (MKQ |op|) NIL)))) - (|cacheNameOrNil| - (COND - ((NEQUAL |eqEtc| (QUOTE EQUAL)) - (CONS - (QUOTE |lassocShiftWithFunction|) - (CONS - |cacheArgKey| - (CONS - (CONS - (QUOTE HGET) - (CONS |cacheNameOrNil| (CONS (MKQ |op|) NIL))) - (CONS (MKQ |eqEtc|) NIL))))) - ((QUOTE T) - (CONS - (QUOTE |lassocShift|) - (CONS - |cacheArgKey| - (CONS - (CONS - (QUOTE HGET) - (CONS |cacheNameOrNil| (CONS (MKQ |op|) NIL))) - NIL)))))) - ((QUOTE T) (CONS (QUOTE HGET) (CONS |cacheName| (CONS |g1| NIL)))))) - (SPADLET |secondPredPair| - (CONS - (CONS (QUOTE SETQ) (CONS |g2| (CONS |getCode| NIL))) - (APPEND |hitCountCode| (CONS |returnFoundValue| NIL)))) - (SPADLET |putCode| - (COND - ((NULL |argl|) - (COND - (|cacheNameOrNil| + ((NULL |cacheNameOrNil|) + (|keyedSystemError| 'S2GE0011 (CONS |op| NIL))) + ('T NIL)))) + (COND + ((AND (NULL |cacheNameOrNil|) + (NULL (MEMQ |eqEtc| '(EQ CVEC UEQUAL)))) + (|keyedSystemError| 'S2GE0012 (CONS |op| NIL))) + ('T (SPADLET |auxfn| (INTERNL |op| (MAKESTRING ";"))) + (SPADLET |g1| (GENSYM)) + (SPADLET |LETTMP#1| + (COND + ((NULL |argl|) + (CONS NIL + (CONS NIL (CONS (CONS |auxfn| NIL) NIL)))) + ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) + (SPADLET |key| + (COND + (|cacheNameOrNil| + (CONS '|devaluate| + (CONS |g1| NIL))) + ('T |g1|))) + (CONS (CONS |g1| NIL) + (CONS (CONS 'LIST (CONS |key| NIL)) + (CONS (CONS |auxfn| (CONS |g1| NIL)) + NIL)))) + ('T + (SPADLET |key| + (COND + (|cacheNameOrNil| + (CONS '|devaluateList| + (CONS |g1| NIL))) + ('T |g1|))) + (CONS |g1| + (CONS |key| + (CONS + (CONS 'APPLY + (CONS + (CONS '|function| + (CONS |auxfn| NIL)) + (CONS |g1| NIL))) + NIL)))))) + (SPADLET |arg| (CAR |LETTMP#1|)) + (SPADLET |cacheArgKey| (CADR |LETTMP#1|)) + (SPADLET |computeValue| (CADDR |LETTMP#1|)) + (SPADLET |cacheName| + (OR |cacheNameOrNil| + (INTERNL |op| (MAKESTRING ";AL")))) (COND - (|countFl| - (CONS - (QUOTE CDDAR) - (CONS - (CONS - (QUOTE HPUT) - (CONS - |cacheNameOrNil| - (CONS - (MKQ |op|) - (CONS - (CONS - (QUOTE LIST) - (CONS - (CONS - (QUOTE CONS) - (CONS - NIL - (CONS - (CONS - (QUOTE CONS) - (CONS 1 (CONS |computeValue| NIL))) NIL))) - NIL)) - NIL)))) - NIL))) - ((QUOTE T) - (CONS - (QUOTE HPUT) - (CONS - |cacheNameOrNil| - (CONS - (MKQ |op|) - (CONS - (CONS - (QUOTE LIST) - (CONS - (CONS (QUOTE CONS) (CONS NIL (CONS |computeValue| NIL))) - NIL)) - NIL))))))) - ((QUOTE T) (|systemError| (MAKESTRING "unexpected"))))) - (|cacheNameOrNil| |computeValue|) - (|countFl| - (CONS - (QUOTE CDR) - (CONS - (CONS - (QUOTE HPUT) - (CONS - |cacheName| - (CONS - |g1| - (CONS - (CONS (QUOTE CONS) (CONS 1 (CONS |computeValue| NIL))) - NIL)))) - NIL))) - ((QUOTE T) - (CONS - (QUOTE HPUT) - (CONS |cacheName| (CONS |g1| (CONS |computeValue| NIL))))))) - (COND - (|cacheNameOrNil| - (SPADLET |putCode| - (CONS - (QUOTE UNWIND-PROTECT) - (CONS - (CONS - (QUOTE PROG1) - (CONS - |putCode| - (CONS (CONS (QUOTE SETQ) (CONS |g2| (CONS (QUOTE T) NIL))) NIL))) - (CONS - (CONS - (QUOTE COND) - (CONS - (CONS - (CONS (QUOTE NOT) (CONS |g2| NIL)) - (CONS - (CONS (QUOTE HREM) (CONS |cacheName| (CONS (MKQ |op|) NIL))) - NIL)) - NIL)) - NIL)))))) - (SPADLET |thirdPredPair| (CONS (QUOTE (QUOTE T)) (CONS |putCode| NIL))) - (SPADLET |codeBody| - (CONS - (QUOTE PROG) - (CONS - (CONS |g2| NIL) - (APPEND - |callCountCode| - (CONS - (CONS - (QUOTE RETURN) - (CONS - (CONS - (QUOTE COND) (CONS |secondPredPair| (CONS |thirdPredPair| NIL))) - NIL)) - NIL))))) - (SPADLET |lamex| (CONS (QUOTE LAM) (CONS |arg| (CONS |codeBody| NIL)))) - (SPADLET |mainFunction| (CONS |op| (CONS |lamex| NIL))) - (SPADLET |computeFunction| - (CONS |auxfn| (CONS (CONS (QUOTE LAMBDA) (CONS |argl| |body|)) NIL))) - (|compileInteractive| |mainFunction|) - (COND - (|$reportCompilation| - (|sayBrightlyI| - (|bright| - (MAKESTRING "Generated LISP code for function:"))) - (|pp| |computeFunction|))) - (|compileQuietly| (CONS |computeFunction| NIL)) - (COND - ((NULL |cacheNameOrNil|) - (SPADLET |cacheType| - (COND - (|countFl| (QUOTE |hash-tableWithCounts|)) - ((QUOTE T) (QUOTE |hash-table|)))) - (SPADLET |weakStrong| - (COND (|countFl| (QUOTE STRONG)) ((QUOTE T) (QUOTE WEAK)))) - (SPADLET |cacheResetCode| - (CONS - (QUOTE SETQ) - (CONS - |cacheName| - (CONS - (CONS (QUOTE MAKE-HASHTABLE) (CONS (MKQ |eqEtc|) NIL)) - NIL)))) - (SPADLET |cacheCountCode| - (CONS (QUOTE |hashCount|) (CONS |cacheName| NIL))) - (SPADLET |cacheVector| - (|mkCacheVec| |op| |cacheName| |cacheType| |cacheResetCode| - |cacheCountCode|)) - (|LAM,EVALANDFILEACTQ| - (CONS - (QUOTE PUT) - (CONS - (MKQ |op|) - (CONS (MKQ (QUOTE |cacheInfo|)) (CONS (MKQ |cacheVector|) NIL))))) - (|LAM,EVALANDFILEACTQ| |cacheResetCode|))) - |op|)))))) -; + ((BOOT-EQUAL |$reportCounts| 'T) + (SPADLET |hitCounter| (INTERNL |op| (MAKESTRING ";hit"))) + (SPADLET |callCounter| + (INTERNL |op| (MAKESTRING ";calls"))) + (SET |hitCounter| 0) (SET |callCounter| 0) + (SPADLET |callCountCode| + (CONS (CONS 'SETQ + (CONS |callCounter| + (CONS + (CONS 'QSADD1 + (CONS |callCounter| NIL)) + NIL))) + NIL)) + (SPADLET |hitCountCode| + (CONS (CONS 'SETQ + (CONS |hitCounter| + (CONS + (CONS 'QSADD1 + (CONS |hitCounter| NIL)) + NIL))) + NIL)))) + (SPADLET |g2| (GENSYM)) + (SPADLET |returnFoundValue| + (COND + ((NULL |argl|) + (COND + (|countFl| + (CONS '|CDRwithIncrement| + (CONS (CONS 'CDAR (CONS |g2| NIL)) + NIL))) + ('T (CONS 'CDAR (CONS |g2| NIL))))) + (|countFl| + (CONS '|CDRwithIncrement| (CONS |g2| NIL))) + ('T |g2|))) + (SPADLET |getCode| + (COND + ((NULL |argl|) + (CONS 'HGET + (CONS |cacheName| (CONS (MKQ |op|) NIL)))) + (|cacheNameOrNil| + (COND + ((NEQUAL |eqEtc| 'EQUAL) + (CONS '|lassocShiftWithFunction| + (CONS |cacheArgKey| + (CONS + (CONS 'HGET + (CONS |cacheNameOrNil| + (CONS (MKQ |op|) NIL))) + (CONS (MKQ |eqEtc|) NIL))))) + ('T + (CONS '|lassocShift| + (CONS |cacheArgKey| + (CONS + (CONS 'HGET + (CONS |cacheNameOrNil| + (CONS (MKQ |op|) NIL))) + NIL)))))) + ('T + (CONS 'HGET (CONS |cacheName| (CONS |g1| NIL)))))) + (SPADLET |secondPredPair| + (CONS (CONS 'SETQ (CONS |g2| (CONS |getCode| NIL))) + (APPEND |hitCountCode| + (CONS |returnFoundValue| NIL)))) + (SPADLET |putCode| + (COND + ((NULL |argl|) + (COND + (|cacheNameOrNil| + (COND + (|countFl| + (CONS 'CDDAR + (CONS + (CONS 'HPUT + (CONS |cacheNameOrNil| + (CONS (MKQ |op|) + (CONS + (CONS 'LIST + (CONS + (CONS 'CONS + (CONS NIL + (CONS + (CONS 'CONS + (CONS 1 + (CONS |computeValue| + NIL))) + NIL))) + NIL)) + NIL)))) + NIL))) + ('T + (CONS 'HPUT + (CONS |cacheNameOrNil| + (CONS (MKQ |op|) + (CONS + (CONS 'LIST + (CONS + (CONS 'CONS + (CONS NIL + (CONS |computeValue| NIL))) + NIL)) + NIL))))))) + ('T (|systemError| (MAKESTRING "unexpected"))))) + (|cacheNameOrNil| |computeValue|) + (|countFl| + (CONS 'CDR + (CONS (CONS 'HPUT + (CONS |cacheName| + (CONS |g1| + (CONS + (CONS 'CONS + (CONS 1 + (CONS |computeValue| NIL))) + NIL)))) + NIL))) + ('T + (CONS 'HPUT + (CONS |cacheName| + (CONS |g1| + (CONS |computeValue| NIL))))))) + (COND + (|cacheNameOrNil| + (SPADLET |putCode| + (CONS 'UNWIND-PROTECT + (CONS (CONS 'PROG1 + (CONS |putCode| + (CONS + (CONS 'SETQ + (CONS |g2| (CONS 'T NIL))) + NIL))) + (CONS + (CONS 'COND + (CONS + (CONS + (CONS 'NOT (CONS |g2| NIL)) + (CONS + (CONS 'HREM + (CONS |cacheName| + (CONS (MKQ |op|) NIL))) + NIL)) + NIL)) + NIL)))))) + (SPADLET |thirdPredPair| (CONS ''T (CONS |putCode| NIL))) + (SPADLET |codeBody| + (CONS 'PROG + (CONS (CONS |g2| NIL) + (APPEND |callCountCode| + (CONS + (CONS 'RETURN + (CONS + (CONS 'COND + (CONS |secondPredPair| + (CONS |thirdPredPair| NIL))) + NIL)) + NIL))))) + (SPADLET |lamex| + (CONS 'LAM (CONS |arg| (CONS |codeBody| NIL)))) + (SPADLET |mainFunction| (CONS |op| (CONS |lamex| NIL))) + (SPADLET |computeFunction| + (CONS |auxfn| + (CONS (CONS 'LAMBDA (CONS |argl| |body|)) + NIL))) + (|compileInteractive| |mainFunction|) + (COND + (|$reportCompilation| + (|sayBrightlyI| + (|bright| + (MAKESTRING + "Generated LISP code for function:"))) + (|pp| |computeFunction|))) + (|compileQuietly| (CONS |computeFunction| NIL)) + (COND + ((NULL |cacheNameOrNil|) + (SPADLET |cacheType| + (COND + (|countFl| '|hash-tableWithCounts|) + ('T '|hash-table|))) + (SPADLET |weakStrong| + (COND (|countFl| 'STRONG) ('T 'WEAK))) + (SPADLET |cacheResetCode| + (CONS 'SETQ + (CONS |cacheName| + (CONS + (CONS 'MAKE-HASHTABLE + (CONS (MKQ |eqEtc|) NIL)) + NIL)))) + (SPADLET |cacheCountCode| + (CONS '|hashCount| (CONS |cacheName| NIL))) + (SPADLET |cacheVector| + (|mkCacheVec| |op| |cacheName| |cacheType| + |cacheResetCode| |cacheCountCode|)) + (|LAM,EVALANDFILEACTQ| + (CONS 'PUT + (CONS (MKQ |op|) + (CONS (MKQ '|cacheInfo|) + (CONS (MKQ |cacheVector|) NIL))))) + (|LAM,EVALANDFILEACTQ| |cacheResetCode|))) + |op|)))))) + ;compHashGlobal(op,argl,body,cacheName,eqEtc,countFl) == ; --Note: when cacheNameOrNil^=nil, it names a global hashtable ; @@ -765,90 +764,93 @@ ;;; *** |compHashGlobal| REDEFINED -(DEFUN |compHashGlobal| (|op| |argl| |body| |cacheName| |eqEtc| |countFl|) - (PROG (|auxfn| |g1| |application| |LETTMP#1| |arg| |cacheArgKey| - |computeValue| |g2| |returnFoundValue| |getCode| |secondPredPair| - |putForm| |putCode| |thirdPredPair| |codeBody| |lamex| |mainFunction| - |computeFunction|) - (RETURN - (PROGN - (COND - ((NULL (MEMQ |eqEtc| (QUOTE (UEQUAL)))) - (|sayBrightly| - (MAKESTRING - "for hash option, only EQ, CVEC, and UEQUAL are allowed")))) - (SPADLET |auxfn| (INTERNL |op| (MAKESTRING ";"))) - (SPADLET |g1| (GENSYM)) - (SPADLET |LETTMP#1| - (PROGN - (SPADLET |application| - (COND - ((NULL |argl|) (CONS |auxfn| NIL)) - ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) - (CONS |auxfn| (CONS |g1| NIL))) - ((QUOTE T) - (CONS - (QUOTE APPLX) - (CONS - (CONS (QUOTE |function|) (CONS |auxfn| NIL)) - (CONS |g1| NIL)))))) - (CONS - |g1| - (CONS - (CONS (QUOTE |consForHashLookup|) (CONS (MKQ |op|) (CONS |g1| NIL))) - (CONS |application| NIL))))) - (SPADLET |arg| (CAR |LETTMP#1|)) - (SPADLET |cacheArgKey| (CADR |LETTMP#1|)) - (SPADLET |computeValue| (CADDR |LETTMP#1|)) - (SPADLET |g2| (GENSYM)) - (SPADLET |returnFoundValue| - (COND - (|countFl| (CONS (QUOTE |CDRwithIncrement|) (CONS |g2| NIL))) - ((QUOTE T) |g2|))) - (SPADLET |getCode| - (CONS (QUOTE HGET) (CONS |cacheName| (CONS |cacheArgKey| NIL)))) - (SPADLET |secondPredPair| - (CONS - (CONS (QUOTE SETQ) (CONS |g2| (CONS |getCode| NIL))) - (CONS |returnFoundValue| NIL))) - (SPADLET |putForm| (CONS (QUOTE CONS) (CONS (MKQ |op|) (CONS |g1| NIL)))) - (SPADLET |putCode| - (COND - (|countFl| - (CONS - (QUOTE HPUT) - (CONS - |cacheName| - (CONS - |putForm| - (CONS (CONS (QUOTE CONS) (CONS 1 (CONS |computeValue| NIL))) NIL))))) - ((QUOTE T) - (CONS - (QUOTE HPUT) - (CONS |cacheName| (CONS |putForm| (CONS |computeValue| NIL))))))) - (SPADLET |thirdPredPair| (CONS (QUOTE (QUOTE T)) (CONS |putCode| NIL))) - (SPADLET |codeBody| - (CONS - (QUOTE PROG) - (CONS - (CONS |g2| NIL) - (CONS - (CONS - (QUOTE RETURN) - (CONS - (CONS - (QUOTE COND) - (CONS |secondPredPair| (CONS |thirdPredPair| NIL))) - NIL)) - NIL)))) - (SPADLET |lamex| (CONS (QUOTE LAM) (CONS |arg| (CONS |codeBody| NIL)))) - (SPADLET |mainFunction| (CONS |op| (CONS |lamex| NIL))) - (SPADLET |computeFunction| - (CONS |auxfn| (CONS (CONS (QUOTE LAMBDA) (CONS |argl| |body|)) NIL))) - (|compileInteractive| |mainFunction|) - (|compileInteractive| |computeFunction|) - |op|)))) -; +(DEFUN |compHashGlobal| + (|op| |argl| |body| |cacheName| |eqEtc| |countFl|) + (PROG (|auxfn| |g1| |application| |LETTMP#1| |arg| |cacheArgKey| + |computeValue| |g2| |returnFoundValue| |getCode| + |secondPredPair| |putForm| |putCode| |thirdPredPair| + |codeBody| |lamex| |mainFunction| |computeFunction|) + (RETURN + (PROGN + (COND + ((NULL (MEMQ |eqEtc| '(UEQUAL))) + (|sayBrightly| + (MAKESTRING + "for hash option, only EQ, CVEC, and UEQUAL are allowed")))) + (SPADLET |auxfn| (INTERNL |op| (MAKESTRING ";"))) + (SPADLET |g1| (GENSYM)) + (SPADLET |LETTMP#1| + (PROGN + (SPADLET |application| + (COND + ((NULL |argl|) (CONS |auxfn| NIL)) + ((AND (PAIRP |argl|) + (EQ (QCDR |argl|) NIL)) + (CONS |auxfn| (CONS |g1| NIL))) + ('T + (CONS 'APPLX + (CONS + (CONS '|function| + (CONS |auxfn| NIL)) + (CONS |g1| NIL)))))) + (CONS |g1| + (CONS (CONS '|consForHashLookup| + (CONS (MKQ |op|) (CONS |g1| NIL))) + (CONS |application| NIL))))) + (SPADLET |arg| (CAR |LETTMP#1|)) + (SPADLET |cacheArgKey| (CADR |LETTMP#1|)) + (SPADLET |computeValue| (CADDR |LETTMP#1|)) + (SPADLET |g2| (GENSYM)) + (SPADLET |returnFoundValue| + (COND + (|countFl| + (CONS '|CDRwithIncrement| (CONS |g2| NIL))) + ('T |g2|))) + (SPADLET |getCode| + (CONS 'HGET + (CONS |cacheName| (CONS |cacheArgKey| NIL)))) + (SPADLET |secondPredPair| + (CONS (CONS 'SETQ (CONS |g2| (CONS |getCode| NIL))) + (CONS |returnFoundValue| NIL))) + (SPADLET |putForm| + (CONS 'CONS (CONS (MKQ |op|) (CONS |g1| NIL)))) + (SPADLET |putCode| + (COND + (|countFl| + (CONS 'HPUT + (CONS |cacheName| + (CONS |putForm| + (CONS + (CONS 'CONS + (CONS 1 + (CONS |computeValue| NIL))) + NIL))))) + ('T + (CONS 'HPUT + (CONS |cacheName| + (CONS |putForm| + (CONS |computeValue| NIL))))))) + (SPADLET |thirdPredPair| (CONS ''T (CONS |putCode| NIL))) + (SPADLET |codeBody| + (CONS 'PROG + (CONS (CONS |g2| NIL) + (CONS (CONS 'RETURN + (CONS + (CONS 'COND + (CONS |secondPredPair| + (CONS |thirdPredPair| NIL))) + NIL)) + NIL)))) + (SPADLET |lamex| + (CONS 'LAM (CONS |arg| (CONS |codeBody| NIL)))) + (SPADLET |mainFunction| (CONS |op| (CONS |lamex| NIL))) + (SPADLET |computeFunction| + (CONS |auxfn| + (CONS (CONS 'LAMBDA (CONS |argl| |body|)) NIL))) + (|compileInteractive| |mainFunction|) + (|compileInteractive| |computeFunction|) + |op|)))) + ;consForHashLookup(a,b) == ; RPLACA($hashNode,a) ; RPLACD($hashNode,b) @@ -857,8 +859,12 @@ ;;; *** |consForHashLookup| REDEFINED (DEFUN |consForHashLookup| (|a| |b|) - (PROGN (RPLACA |$hashNode| |a|) (RPLACD |$hashNode| |b|) |$hashNode|)) -; + (DECLARE (SPECIAL |$hashNode|)) + (PROGN + (RPLACA |$hashNode| |a|) + (RPLACD |$hashNode| |b|) + |$hashNode|)) + ;CDRwithIncrement x == ; RPLACA(x,QSADD1 CAR x) ; CDR x @@ -866,8 +872,8 @@ ;;; *** |CDRwithIncrement| REDEFINED (DEFUN |CDRwithIncrement| (|x|) - (PROGN (RPLACA |x| (QSADD1 (CAR |x|))) (CDR |x|))) -; + (PROGN (RPLACA |x| (QSADD1 (CAR |x|))) (CDR |x|))) + ;HGETandCount(hashTable,prop) == ; u:= HGET(hashTable,prop) or return nil ; RPLACA(u,QSADD1 CAR u) @@ -876,36 +882,38 @@ ;;; *** |HGETandCount| REDEFINED (DEFUN |HGETandCount| (|hashTable| |prop|) - (PROG (|u|) - (RETURN - (PROGN - (SPADLET |u| (OR (HGET |hashTable| |prop|) (RETURN NIL))) - (RPLACA |u| (QSADD1 (CAR |u|))) |u|)))) -; + (PROG (|u|) + (RETURN + (PROGN + (SPADLET |u| (OR (HGET |hashTable| |prop|) (RETURN NIL))) + (RPLACA |u| (QSADD1 (CAR |u|))) + |u|)))) + ;clearClams() == ; for [fn,kind,:.] in $clamList | kind = 'hash or INTEGERP kind repeat ; clearClam fn ;;; *** |clearClams| REDEFINED -(DEFUN |clearClams| NIL - (PROG (|fn| |kind|) - (RETURN - (SEQ - (DO ((#0=#:G2474 |$clamList| (CDR #0#)) (#1=#:G2465 NIL)) - ((OR - (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN (SPADLET |fn| (CAR #1#)) (SPADLET |kind| (CADR #1#)) #1#) - NIL)) - NIL) - (SEQ - (EXIT - (COND - ((OR (BOOT-EQUAL |kind| (QUOTE |hash|)) (INTEGERP |kind|)) - (|clearClam| |fn|)))))))))) -; +(DEFUN |clearClams| () + (PROG (|fn| |kind|) + (DECLARE (SPECIAL |$clamList|)) + (RETURN + (SEQ (DO ((G2474 |$clamList| (CDR G2474)) (G2465 NIL)) + ((OR (ATOM G2474) + (PROGN (SETQ G2465 (CAR G2474)) NIL) + (PROGN + (PROGN + (SPADLET |fn| (CAR G2465)) + (SPADLET |kind| (CADR G2465)) + G2465) + NIL)) + NIL) + (SEQ (EXIT (COND + ((OR (BOOT-EQUAL |kind| '|hash|) + (INTEGERP |kind|)) + (|clearClam| |fn|)))))))))) + ;clearClam fn == ; infovec:= GET(fn,'cacheInfo) or keyedSystemError("S2GE0003",[fn]) ; eval infovec.cacheReset @@ -913,32 +921,32 @@ ;;; *** |clearClam| REDEFINED (DEFUN |clearClam| (|fn|) - (PROG (|infovec|) - (RETURN - (PROGN - (SPADLET |infovec| - (OR - (GETL |fn| (QUOTE |cacheInfo|)) - (|keyedSystemError| (QUOTE S2GE0003) (CONS |fn| NIL)))) - (|eval| (CADDDR |infovec|)))))) -; + (PROG (|infovec|) + (RETURN + (PROGN + (SPADLET |infovec| + (OR (GETL |fn| '|cacheInfo|) + (|keyedSystemError| 'S2GE0003 (CONS |fn| NIL)))) + (|eval| (CADDDR |infovec|)))))) + ;reportAndClearClams() == ; cacheStats() ; clearClams() ;;; *** |reportAndClearClams| REDEFINED -(DEFUN |reportAndClearClams| NIL (PROGN (|cacheStats|) (|clearClams|))) -; +(DEFUN |reportAndClearClams| () (PROGN (|cacheStats|) (|clearClams|))) + ;clearConstructorCaches() == ; clearCategoryCaches() ; CLRHASH $ConstructorCache ;;; *** |clearConstructorCaches| REDEFINED -(DEFUN |clearConstructorCaches| NIL - (PROGN (|clearCategoryCaches|) (CLRHASH |$ConstructorCache|))) -; +(DEFUN |clearConstructorCaches| () + (DECLARE (SPECIAL |$ConstructorCache|)) + (PROGN (|clearCategoryCaches|) (CLRHASH |$ConstructorCache|))) + ;clearConstructorCache(cname) == ; (kind := GETDATABASE(cname,'CONSTRUCTORKIND)) => ; kind = 'category => clearCategoryCache cname @@ -946,27 +954,30 @@ ;;; *** |clearConstructorCache| REDEFINED -(DEFUN |clearConstructorCache| (|cname|) - (PROG (|kind|) - (RETURN - (SEQ - (COND - ((SPADLET |kind| (GETDATABASE |cname| (QUOTE CONSTRUCTORKIND))) - (EXIT - (COND - ((BOOT-EQUAL |kind| (QUOTE |category|)) - (|clearCategoryCache| |cname|)) - ((QUOTE T) (HREM |$ConstructorCache| |cname|)))))))))) -; +(DEFUN |clearConstructorCache| (|cname|) + (PROG (|kind|) + (DECLARE (SPECIAL |$ConstructorCache|)) + (RETURN + (SEQ (COND + ((SPADLET |kind| (GETDATABASE |cname| 'CONSTRUCTORKIND)) + (EXIT (COND + ((BOOT-EQUAL |kind| '|category|) + (|clearCategoryCache| |cname|)) + ('T (HREM |$ConstructorCache| |cname|)))))))))) + ;clearConstructorAndLisplibCaches() == ; clearClams() ; clearConstructorCaches() ;;; *** |clearConstructorAndLisplibCaches| REDEFINED -(DEFUN |clearConstructorAndLisplibCaches| NIL +(pprint '(DEFUN |clearConstructorAndLisplibCaches| NIL (PROGN (|clearClams|) (|clearConstructorCaches|))) -; +) + + (DEFUN |clearConstructorAndLisplibCaches| () + (PROGN (|clearClams|) (|clearConstructorCaches|))) + ;clearCategoryCaches() == ; for name in allConstructors() repeat ; if GETDATABASE(name,'CONSTRUCTORKIND) = 'category then @@ -977,32 +988,34 @@ ;;; *** |clearCategoryCaches| REDEFINED -(DEFUN |clearCategoryCaches| NIL - (PROG (|cacheName|) - (RETURN - (SEQ - (DO ((#0=#:G2514 (|allConstructors|) (CDR #0#)) (|name| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |name| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (COND - ((BOOT-EQUAL - (GETDATABASE |name| (QUOTE CONSTRUCTORKIND)) - (QUOTE |category|)) - (COND - ((BOUNDP - (SPADLET |cacheName| - (INTERNL (STRCONC (PNAME |name|) (MAKESTRING ";AL"))))) - (SET |cacheName| NIL)) - ((QUOTE T) NIL)))) - (COND - ((BOUNDP - (SPADLET |cacheName| - (INTERNL (STRCONC (PNAME |name|) (MAKESTRING ";CAT"))))) - (SET |cacheName| NIL)) - ((QUOTE T) NIL)))))))))) -; +(DEFUN |clearCategoryCaches| () + (PROG (|cacheName|) + (RETURN + (SEQ (DO ((G2514 (|allConstructors|) (CDR G2514)) + (|name| NIL)) + ((OR (ATOM G2514) + (PROGN (SETQ |name| (CAR G2514)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((BOOT-EQUAL + (GETDATABASE |name| 'CONSTRUCTORKIND) + '|category|) + (COND + ((BOUNDP (SPADLET |cacheName| + (INTERNL + (STRCONC (PNAME |name|) + (MAKESTRING ";AL"))))) + (SET |cacheName| NIL)) + ('T NIL)))) + (COND + ((BOUNDP (SPADLET |cacheName| + (INTERNL + (STRCONC (PNAME |name|) + (MAKESTRING ";CAT"))))) + (SET |cacheName| NIL)) + ('T NIL)))))))))) + ;clearCategoryCache catName == ; cacheName:= INTERNL STRCONC(PNAME catName,'";AL") ; SET(cacheName,nil) @@ -1010,13 +1023,14 @@ ;;; *** |clearCategoryCache| REDEFINED (DEFUN |clearCategoryCache| (|catName|) - (PROG (|cacheName|) - (RETURN - (PROGN - (SPADLET |cacheName| - (INTERNL (STRCONC (PNAME |catName|) (MAKESTRING ";AL")))) - (SET |cacheName| NIL))))) -; + (PROG (|cacheName|) + (RETURN + (PROGN + (SPADLET |cacheName| + (INTERNL (STRCONC (PNAME |catName|) + (MAKESTRING ";AL")))) + (SET |cacheName| NIL))))) + ;displayHashtable x == ; l:= NREVERSE SORTBY('CAR,[[opOf HGET(x,key),key] for key in HKEYS x]) ; for [a,b] in l repeat @@ -1026,41 +1040,48 @@ ;;; *** |displayHashtable| REDEFINED (DEFUN |displayHashtable| (|x|) - (PROG (|l| |a| |b|) - (RETURN - (SEQ - (PROGN - (SPADLET |l| - (NREVERSE - (SORTBY - (QUOTE CAR) - (PROG (#0=#:G2540) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G2545 (HKEYS |x|) (CDR #1#)) (|key| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |key| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# - (CONS - (CONS (|opOf| (HGET |x| |key|)) (CONS |key| NIL)) - #0#)))))))))) - (DO ((#2=#:G2557 |l| (CDR #2#)) (#3=#:G2531 NIL)) - ((OR - (ATOM #2#) - (PROGN (SETQ #3# (CAR #2#)) NIL) - (PROGN - (PROGN (SPADLET |a| (CAR #3#)) (SPADLET |b| (CADR #3#)) #3#) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (|sayBrightlyNT| - (CONS (QUOTE |%b|) (CONS |a| (CONS (QUOTE |%d|) NIL)))) - (|pp| |b|)))))))))) -; + (PROG (|l| |a| |b|) + (RETURN + (SEQ (PROGN + (SPADLET |l| + (NREVERSE + (SORTBY 'CAR + (PROG (G2540) + (SPADLET G2540 NIL) + (RETURN + (DO + ((G2545 (HKEYS |x|) + (CDR G2545)) + (|key| NIL)) + ((OR (ATOM G2545) + (PROGN + (SETQ |key| (CAR G2545)) + NIL)) + (NREVERSE0 G2540)) + (SEQ + (EXIT + (SETQ G2540 + (CONS + (CONS + (|opOf| (HGET |x| |key|)) + (CONS |key| NIL)) + G2540)))))))))) + (DO ((G2557 |l| (CDR G2557)) (G2531 NIL)) + ((OR (ATOM G2557) + (PROGN (SETQ G2531 (CAR G2557)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G2531)) + (SPADLET |b| (CADR G2531)) + G2531) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|sayBrightlyNT| + (CONS '|%b| + (CONS |a| (CONS '|%d| NIL)))) + (|pp| |b|)))))))))) + ;cacheStats() == ; for [fn,kind,:u] in $clamList repeat ; not MEMQ('count,u) => @@ -1071,44 +1092,43 @@ ;;; *** |cacheStats| REDEFINED -(DEFUN |cacheStats| NIL - (PROG (|fn| |kind| |u|) - (RETURN - (SEQ - (DO ((#0=#:G2581 |$clamList| (CDR #0#)) (#1=#:G2572 NIL)) - ((OR - (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN - (SPADLET |fn| (CAR #1#)) - (SPADLET |kind| (CADR #1#)) - (SPADLET |u| (CDDR #1#)) - #1#) - NIL)) - NIL) - (SEQ - (EXIT - (COND - ((NULL (MEMQ (QUOTE |count|) |u|)) - (|sayBrightly| - (CONS - (MAKESTRING "%b") - (CONS - |fn| - (CONS - (MAKESTRING "%d") - (CONS (MAKESTRING "does not keep reference counts") NIL)))))) - ((INTEGERP |kind|) (|reportCircularCacheStats| |fn| |kind|)) - ((BOOT-EQUAL |kind| (QUOTE |hash|)) (|reportHashCacheStats| |fn|)) - ((QUOTE T) - (|sayBrightly| - (CONS - (MAKESTRING "Unknown cache type for") - (CONS - (MAKESTRING "%b") - (CONS |fn| (CONS (MAKESTRING "%d") NIL)))))))))))))) -; +(DEFUN |cacheStats| () + (PROG (|fn| |kind| |u|) + (DECLARE (SPECIAL |$clamList|)) + (RETURN + (SEQ (DO ((G2581 |$clamList| (CDR G2581)) (G2572 NIL)) + ((OR (ATOM G2581) + (PROGN (SETQ G2572 (CAR G2581)) NIL) + (PROGN + (PROGN + (SPADLET |fn| (CAR G2572)) + (SPADLET |kind| (CADR G2572)) + (SPADLET |u| (CDDR G2572)) + G2572) + NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (MEMQ '|count| |u|)) + (|sayBrightly| + (CONS (MAKESTRING "%b") + (CONS |fn| + (CONS (MAKESTRING "%d") + (CONS + (MAKESTRING + "does not keep reference counts") + NIL)))))) + ((INTEGERP |kind|) + (|reportCircularCacheStats| |fn| |kind|)) + ((BOOT-EQUAL |kind| '|hash|) + (|reportHashCacheStats| |fn|)) + ('T + (|sayBrightly| + (CONS (MAKESTRING + "Unknown cache type for") + (CONS (MAKESTRING "%b") + (CONS |fn| + (CONS (MAKESTRING "%d") NIL)))))))))))))) + ;reportCircularCacheStats(fn,n) == ; infovec:= GET(fn,'cacheInfo) ; circList:= eval infovec.cacheName @@ -1121,46 +1141,46 @@ ;;; *** |reportCircularCacheStats| REDEFINED (DEFUN |reportCircularCacheStats| (|fn| |n|) - (PROG (|infovec| |circList| |numberUsed|) - (RETURN - (SEQ - (PROGN - (SPADLET |infovec| (GETL |fn| (QUOTE |cacheInfo|))) - (SPADLET |circList| (|eval| (CADR |infovec|))) - (SPADLET |numberUsed| - (PROG (#0=#:G2595) - (SPADLET #0# 0) - (RETURN - (DO ((|i| 1 (QSADD1 |i|)) (#1=#:G2602 |circList| (CDR #1#)) (|x| NIL)) - ((OR - (QSGREATERP |i| |n|) - (ATOM #1#) - (PROGN (SETQ |x| (CAR #1#)) NIL) - (NULL - (NULL (AND (PAIRP |x|) (EQUAL (QCAR |x|) (QUOTE |$failed|)))))) - #0#) - (SEQ (EXIT (SETQ #0# (PLUS #0# 1)))))))) - (|sayBrightly| - (CONS - (MAKESTRING "%b") - (CONS - |fn| - (CONS - (MAKESTRING "%d") - (CONS - (MAKESTRING "has") - (CONS - (MAKESTRING "%b") - (CONS - |numberUsed| - (CONS - (MAKESTRING "%d") - (CONS - (MAKESTRING "/ ") - (CONS |n| (CONS (MAKESTRING " values cached") NIL))))))))))) - (|displayCacheFrequency| (|mkCircularCountAlist| |circList| |n|)) - (TERPRI)))))) -; + (PROG (|infovec| |circList| |numberUsed|) + (DECLARE (SPECIAL |$failed|)) + (RETURN + (SEQ (PROGN + (SPADLET |infovec| (GETL |fn| '|cacheInfo|)) + (SPADLET |circList| (|eval| (CADR |infovec|))) + (SPADLET |numberUsed| + (PROG (G2595) + (SPADLET G2595 0) + (RETURN + (DO ((|i| 1 (QSADD1 |i|)) + (G2602 |circList| (CDR G2602)) + (|x| NIL)) + ((OR (QSGREATERP |i| |n|) (ATOM G2602) + (PROGN + (SETQ |x| (CAR G2602)) + NIL) + (NULL + (NULL + (AND (PAIRP |x|) + (EQUAL (QCAR |x|) '|$failed|))))) + G2595) + (SEQ (EXIT (SETQ G2595 (PLUS G2595 1)))))))) + (|sayBrightly| + (CONS (MAKESTRING "%b") + (CONS |fn| + (CONS (MAKESTRING "%d") + (CONS (MAKESTRING "has") + (CONS (MAKESTRING "%b") + (CONS |numberUsed| + (CONS (MAKESTRING "%d") + (CONS (MAKESTRING "/ ") + (CONS |n| + (CONS + (MAKESTRING " values cached") + NIL))))))))))) + (|displayCacheFrequency| + (|mkCircularCountAlist| |circList| |n|)) + (TERPRI)))))) + ;displayCacheFrequency al == ; al := NREVERSE SORTBY('CAR,al) ; sayBrightlyNT " #hits/#occurrences: " @@ -1170,25 +1190,27 @@ ;;; *** |displayCacheFrequency| REDEFINED (DEFUN |displayCacheFrequency| (|al|) - (PROG (|a| |b|) - (RETURN - (SEQ - (PROGN - (SPADLET |al| (NREVERSE (SORTBY (QUOTE CAR) |al|))) - (|sayBrightlyNT| (QUOTE | #hits/#occurrences: |)) - (DO ((#0=#:G2626 |al| (CDR #0#)) (#1=#:G2617 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 - (|sayBrightlyNT| - (CONS |a| (CONS (QUOTE /) (CONS |b| (CONS (QUOTE | |) NIL)))))))) - (TERPRI)))))) -; + (PROG (|a| |b|) + (RETURN + (SEQ (PROGN + (SPADLET |al| (NREVERSE (SORTBY 'CAR |al|))) + (|sayBrightlyNT| '| #hits/#occurrences: |) + (DO ((G2626 |al| (CDR G2626)) (G2617 NIL)) + ((OR (ATOM G2626) + (PROGN (SETQ G2617 (CAR G2626)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G2617)) + (SPADLET |b| (CDR G2617)) + G2617) + NIL)) + NIL) + (SEQ (EXIT (|sayBrightlyNT| + (CONS |a| + (CONS '/ + (CONS |b| (CONS '| | NIL)))))))) + (TERPRI)))))) + ;mkCircularCountAlist(cl,len) == ; for [x,count,:.] in cl for i in 1..len while x ^= '_$failed repeat ; u:= ASSOC(count,al) => RPLACD(u,1 + CDR u) @@ -1201,35 +1223,40 @@ ;;; *** |mkCircularCountAlist| REDEFINED (DEFUN |mkCircularCountAlist| (|cl| |len|) - (PROG (|x| |count| |u| |al|) - (RETURN - (SEQ - (PROGN - (DO - ((#0=#:G2652 |cl| (CDR #0#)) (#1=#:G2641 NIL) (|i| 1 (QSADD1 |i|))) - ((OR - (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN (SPADLET |x| (CAR #1#)) (SPADLET |count| (CADR #1#)) #1#) NIL) - (QSGREATERP |i| |len|) - (NULL (NEQUAL |x| (QUOTE |$failed|)))) - NIL) - (SEQ - (EXIT - (COND - ((SPADLET |u| (|assoc| |count| |al|)) (RPLACD |u| (PLUS 1 (CDR |u|)))) - ((QUOTE T) - (COND - ((AND - (INTEGERP |$reportFavoritesIfNumber|) - (>= |count| |$reportFavoritesIfNumber|)) - (|sayBrightlyNT| - (CONS (QUOTE | |) (CONS |count| (CONS (QUOTE | |) NIL)))) - (|pp| |x|))) - (SPADLET |al| (CONS (CONS |count| 1) |al|))))))) - |al|))))) -; + (PROG (|x| |count| |u| |al|) + (DECLARE (SPECIAL |$reportFavoritesIfNumber| |$failed|)) + (RETURN + (SEQ (PROGN + (DO ((G2652 |cl| (CDR G2652)) (G2641 NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G2652) + (PROGN (SETQ G2641 (CAR G2652)) NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G2641)) + (SPADLET |count| (CADR G2641)) + G2641) + NIL) + (QSGREATERP |i| |len|) + (NULL (NEQUAL |x| '|$failed|))) + NIL) + (SEQ (EXIT (COND + ((SPADLET |u| (|assoc| |count| |al|)) + (RPLACD |u| (PLUS 1 (CDR |u|)))) + ('T + (COND + ((AND (INTEGERP + |$reportFavoritesIfNumber|) + (>= |count| + |$reportFavoritesIfNumber|)) + (|sayBrightlyNT| + (CONS '| | + (CONS |count| (CONS '| | NIL)))) + (|pp| |x|))) + (SPADLET |al| + (CONS (CONS |count| 1) |al|))))))) + |al|))))) + ;reportHashCacheStats fn == ; infovec:= GET(fn,'cacheInfo) ; hashTable:= eval infovec.cacheName @@ -1241,30 +1268,37 @@ ;;; *** |reportHashCacheStats| REDEFINED (DEFUN |reportHashCacheStats| (|fn|) - (PROG (|infovec| |hashTable| |hashValues|) - (RETURN - (SEQ - (PROGN - (SPADLET |infovec| (GETL |fn| (QUOTE |cacheInfo|))) - (SPADLET |hashTable| (|eval| (CADR |infovec|))) - (SPADLET |hashValues| - (PROG (#0=#:G2673) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G2678 (HKEYS |hashTable|) (CDR #1#)) (|key| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |key| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (HGET |hashTable| |key|) #0#)))))))) - (|sayBrightly| - (APPEND - (|bright| |fn|) - (CONS - (MAKESTRING "has") - (APPEND - (|bright| (|#| |hashValues|)) - (CONS (MAKESTRING "values cached.") NIL))))) - (|displayCacheFrequency| (|mkHashCountAlist| |hashValues|)) - (TERPRI)))))) -; + (PROG (|infovec| |hashTable| |hashValues|) + (RETURN + (SEQ (PROGN + (SPADLET |infovec| (GETL |fn| '|cacheInfo|)) + (SPADLET |hashTable| (|eval| (CADR |infovec|))) + (SPADLET |hashValues| + (PROG (G2673) + (SPADLET G2673 NIL) + (RETURN + (DO ((G2678 (HKEYS |hashTable|) + (CDR G2678)) + (|key| NIL)) + ((OR (ATOM G2678) + (PROGN + (SETQ |key| (CAR G2678)) + NIL)) + (NREVERSE0 G2673)) + (SEQ (EXIT (SETQ G2673 + (CONS (HGET |hashTable| |key|) + G2673)))))))) + (|sayBrightly| + (APPEND (|bright| |fn|) + (CONS (MAKESTRING "has") + (APPEND (|bright| (|#| |hashValues|)) + (CONS + (MAKESTRING "values cached.") + NIL))))) + (|displayCacheFrequency| + (|mkHashCountAlist| |hashValues|)) + (TERPRI)))))) + ;mkHashCountAlist vl == ; for [count,:.] in vl repeat ; u:= ASSOC(count,al) => RPLACD(u,1 + CDR u) @@ -1274,25 +1308,26 @@ ;;; *** |mkHashCountAlist| REDEFINED (DEFUN |mkHashCountAlist| (|vl|) - (PROG (|count| |u| |al|) - (RETURN - (SEQ - (PROGN - (DO ((#0=#:G2700 |vl| (CDR #0#)) (#1=#:G2692 NIL)) - ((OR - (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN (PROGN (SPADLET |count| (CAR #1#)) #1#) NIL)) - NIL) - (SEQ - (EXIT - (COND - ((SPADLET |u| (|assoc| |count| |al|)) - (RPLACD |u| (PLUS 1 (CDR |u|)))) - ((QUOTE T) - (SPADLET |al| (CONS (CONS |count| 1) |al|))))))) - |al|))))) -; + (PROG (|count| |u| |al|) + (RETURN + (SEQ (PROGN + (DO ((G2700 |vl| (CDR G2700)) (G2692 NIL)) + ((OR (ATOM G2700) + (PROGN (SETQ G2692 (CAR G2700)) NIL) + (PROGN + (PROGN + (SPADLET |count| (CAR G2692)) + G2692) + NIL)) + NIL) + (SEQ (EXIT (COND + ((SPADLET |u| (|assoc| |count| |al|)) + (RPLACD |u| (PLUS 1 (CDR |u|)))) + ('T + (SPADLET |al| + (CONS (CONS |count| 1) |al|))))))) + |al|))))) + ;clearHashReferenceCounts() == ; --free all cells with 0 reference counts; clear other counts to 0 ; for x in $clamList repeat @@ -1302,18 +1337,17 @@ ;;; *** |clearHashReferenceCounts| REDEFINED -(DEFUN |clearHashReferenceCounts| NIL - (SEQ - (DO ((#0=#:G2717 |$clamList| (CDR #0#)) (|x| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL (CADDR |x|) (QUOTE |hash-tableWithCounts|)) - (|remHashEntriesWith0Count| (|eval| (CADR |x|)))) - ((BOOT-EQUAL (CADDR |x|) (QUOTE |hash-table|)) - (CLRHASH (|eval| (CADR |x|)))))))))) -; +(DEFUN |clearHashReferenceCounts| () + (DECLARE (SPECIAL |$clamList|)) + (SEQ (DO ((G2717 |$clamList| (CDR G2717)) (|x| NIL)) + ((OR (ATOM G2717) (PROGN (SETQ |x| (CAR G2717)) NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL (CADDR |x|) '|hash-tableWithCounts|) + (|remHashEntriesWith0Count| (|eval| (CADR |x|)))) + ((BOOT-EQUAL (CADDR |x|) '|hash-table|) + (CLRHASH (|eval| (CADR |x|)))))))))) + ;remHashEntriesWith0Count $hashTable == ; MAPHASH(fn,$hashTable) where fn(key,obj) == ; CAR obj = 0 => HREM($hashTable,key) --free store @@ -1322,16 +1356,16 @@ ;;; *** |remHashEntriesWith0Count,fn| REDEFINED (DEFUN |remHashEntriesWith0Count,fn| (|key| |obj|) - (SEQ - (IF (EQL (CAR |obj|) 0) (EXIT (HREM |$hashTable| |key|))) - (EXIT NIL))) + (DECLARE (SPECIAL |$hashTable|)) + (SEQ (IF (EQL (CAR |obj|) 0) (EXIT (HREM |$hashTable| |key|))) + (EXIT NIL))) ;;; *** |remHashEntriesWith0Count| REDEFINED (DEFUN |remHashEntriesWith0Count| (|$hashTable|) - (DECLARE (SPECIAL |$hashTable|)) - (MAPHASH |remHashEntriesWith0Count,fn| |$hashTable|)) -; + (DECLARE (SPECIAL |$hashTable|)) + (MAPHASH |remHashEntriesWith0Count,fn| |$hashTable|)) + ;initCache n == ; tail:= '(0 . $failed) ; l:= [[$failed,:tail] for i in 1..n] @@ -1340,20 +1374,23 @@ ;;; *** |initCache| REDEFINED (DEFUN |initCache| (|n|) - (PROG (|tail| |l|) - (RETURN - (SEQ - (PROGN - (SPADLET |tail| (QUOTE (0 . |$failed|))) - (SPADLET |l| - (PROG (#0=#:G2740) - (SPADLET #0# NIL) - (RETURN - (DO ((|i| 1 (QSADD1 |i|))) - ((QSGREATERP |i| |n|) (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (CONS |$failed| |tail|) #0#)))))))) - (RPLACD (LASTNODE |l|) |l|)))))) -; + (PROG (|tail| |l|) + (DECLARE (SPECIAL |$failed|)) + (RETURN + (SEQ (PROGN + (SPADLET |tail| '(0 . |$failed|)) + (SPADLET |l| + (PROG (G2740) + (SPADLET G2740 NIL) + (RETURN + (DO ((|i| 1 (QSADD1 |i|))) + ((QSGREATERP |i| |n|) + (NREVERSE0 G2740)) + (SEQ (EXIT (SETQ G2740 + (CONS (CONS |$failed| |tail|) + G2740)))))))) + (RPLACD (LASTNODE |l|) |l|)))))) + ;assocCache(x,cacheName,fn) == ; --fn=equality function; do not SHIFT or COUNT ; al:= eval cacheName @@ -1370,25 +1407,26 @@ ;;; *** |assocCache| REDEFINED (DEFUN |assocCache| (|x| |cacheName| |fn|) - (PROG (|al| |val| |backPointer| |forwardPointer|) - (RETURN - (SEQ - (PROGN - (SPADLET |al| (|eval| |cacheName|)) - (SPADLET |forwardPointer| |al|) - (SPADLET |val| NIL) - (DO ((#0=#:G2759 NIL (EQ |forwardPointer| |al|))) - (#0# NIL) - (SEQ - (EXIT - (COND - ((FUNCALL |fn| (CAAR |forwardPointer|) |x|) - (RETURN (SPADLET |val| (CAR |forwardPointer|)))) - ((QUOTE T) - (SPADLET |backPointer| |forwardPointer|) - (SPADLET |forwardPointer| (CDR |forwardPointer|))))))) - (COND (|val| |val|) ((QUOTE T) (SET |cacheName| |backPointer|) NIL))))))) -; + (PROG (|al| |val| |backPointer| |forwardPointer|) + (RETURN + (SEQ (PROGN + (SPADLET |al| (|eval| |cacheName|)) + (SPADLET |forwardPointer| |al|) + (SPADLET |val| NIL) + (DO ((G2759 NIL (EQ |forwardPointer| |al|))) + (G2759 NIL) + (SEQ (EXIT (COND + ((FUNCALL |fn| (CAAR |forwardPointer|) |x|) + (RETURN + (SPADLET |val| (CAR |forwardPointer|)))) + ('T + (SPADLET |backPointer| |forwardPointer|) + (SPADLET |forwardPointer| + (CDR |forwardPointer|))))))) + (COND + (|val| |val|) + ('T (SET |cacheName| |backPointer|) NIL))))))) + ;assocCacheShift(x,cacheName,fn) == --like ASSOC except that al is circular ; --fn=equality function; SHIFT but do not COUNT ; al:= eval cacheName @@ -1409,29 +1447,33 @@ ;;; *** |assocCacheShift| REDEFINED (DEFUN |assocCacheShift| (|x| |cacheName| |fn|) - (PROG (|al| |y| |val| |backPointer| |forwardPointer|) - (RETURN - (SEQ - (PROGN - (SPADLET |al| (|eval| |cacheName|)) - (SPADLET |forwardPointer| |al|) - (SPADLET |val| NIL) - (DO ((#0=#:G2779 NIL (EQ |forwardPointer| |al|))) - (#0# NIL) - (SEQ - (EXIT - (COND - ((FUNCALL |fn| (CAR (SPADLET |y| (CAR |forwardPointer|))) |x|) - (COND - ((NULL (EQ |forwardPointer| |al|)) - (RPLACA |forwardPointer| (CAR |al|)) - (RPLACA |al| |y|))) - (RETURN (SPADLET |val| |y|))) - ((QUOTE T) - (SPADLET |backPointer| |forwardPointer|) - (SPADLET |forwardPointer| (CDR |forwardPointer|))))))) - (COND (|val| |val|) ((QUOTE T) (SET |cacheName| |backPointer|) NIL))))))) -; + (PROG (|al| |y| |val| |backPointer| |forwardPointer|) + (RETURN + (SEQ (PROGN + (SPADLET |al| (|eval| |cacheName|)) + (SPADLET |forwardPointer| |al|) + (SPADLET |val| NIL) + (DO ((G2779 NIL (EQ |forwardPointer| |al|))) + (G2779 NIL) + (SEQ (EXIT (COND + ((FUNCALL |fn| + (CAR + (SPADLET |y| + (CAR |forwardPointer|))) + |x|) + (COND + ((NULL (EQ |forwardPointer| |al|)) + (RPLACA |forwardPointer| (CAR |al|)) + (RPLACA |al| |y|))) + (RETURN (SPADLET |val| |y|))) + ('T + (SPADLET |backPointer| |forwardPointer|) + (SPADLET |forwardPointer| + (CDR |forwardPointer|))))))) + (COND + (|val| |val|) + ('T (SET |cacheName| |backPointer|) NIL))))))) + ;assocCacheShiftCount(x,al,fn) == ; -- if x is found, entry containing x becomes first element of list; if ; -- x is not found, entry with smallest use count is shifted to front so @@ -1458,35 +1500,41 @@ ;;; *** |assocCacheShiftCount| REDEFINED (DEFUN |assocCacheShiftCount| (|x| |al| |fn|) - (PROG (|y| |val| |c| |minCount| |newFrontPointer| |forwardPointer| |temp|) - (RETURN - (SEQ - (PROGN - (SPADLET |forwardPointer| |al|) - (SPADLET |val| NIL) - (SPADLET |minCount| 10000) - (DO ((#0=#:G2801 NIL (EQ |forwardPointer| |al|))) - (#0# NIL) - (SEQ - (EXIT - (COND - ((FUNCALL |fn| (CAR (SPADLET |y| (CAR |forwardPointer|))) |x|) - (SPADLET |newFrontPointer| |forwardPointer|) - (RPLAC (CADR |y|) (QSADD1 (CADR |y|))) - (RETURN (SPADLET |val| |y|))) - ((QUOTE T) - (COND - ((QSLESSP (SPADLET |c| (CADR |y|)) |minCount|) - (SPADLET |minCount| |c|) - (SPADLET |newFrontPointer| |forwardPointer|))) - (SPADLET |forwardPointer| (CDR |forwardPointer|))))))) - (COND - ((NULL (EQ |newFrontPointer| |al|)) - (SPADLET |temp| (CAR |newFrontPointer|)) - (RPLACA |newFrontPointer| (CAR |al|)) - (RPLACA |al| |temp|))) - |val|))))) -; + (PROG (|y| |val| |c| |minCount| |newFrontPointer| |forwardPointer| + |temp|) + (RETURN + (SEQ (PROGN + (SPADLET |forwardPointer| |al|) + (SPADLET |val| NIL) + (SPADLET |minCount| 10000) + (DO ((G2801 NIL (EQ |forwardPointer| |al|))) + (G2801 NIL) + (SEQ (EXIT (COND + ((FUNCALL |fn| + (CAR + (SPADLET |y| + (CAR |forwardPointer|))) + |x|) + (SPADLET |newFrontPointer| + |forwardPointer|) + (RPLAC (CADR |y|) (QSADD1 (CADR |y|))) + (RETURN (SPADLET |val| |y|))) + ('T + (COND + ((QSLESSP (SPADLET |c| (CADR |y|)) + |minCount|) + (SPADLET |minCount| |c|) + (SPADLET |newFrontPointer| + |forwardPointer|))) + (SPADLET |forwardPointer| + (CDR |forwardPointer|))))))) + (COND + ((NULL (EQ |newFrontPointer| |al|)) + (SPADLET |temp| (CAR |newFrontPointer|)) + (RPLACA |newFrontPointer| (CAR |al|)) + (RPLACA |al| |temp|))) + |val|))))) + ;clamStats() == ; for [op,kind,:.] in $clamList repeat ; cacheVec:= GET(op,'cacheInfo) or systemErrorHere "clamStats" @@ -1509,76 +1557,78 @@ ;;; *** |clamStats| REDEFINED -(DEFUN |clamStats| NIL - (PROG (|op| |kind| |cacheVec| |hitCounter| |callCounter| |res| |prefix| - |cacheValue| |empties| |postString|) - (RETURN - (SEQ - (DO ((#0=#:G2836 |$clamList| (CDR #0#)) (#1=#:G2822 NIL)) - ((OR - (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN (SPADLET |op| (CAR #1#)) (SPADLET |kind| (CADR #1#)) #1#) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |cacheVec| - (OR - (GETL |op| (QUOTE |cacheInfo|)) - (|systemErrorHere| (QUOTE |clamStats|)))) - (SPADLET |prefix| - (COND - ((NEQUAL |$reportCounts| (QUOTE T)) NIL) - ((QUOTE T) - (SPADLET |hitCounter| (INTERNL |op| (MAKESTRING ";hit"))) - (SPADLET |callCounter| (INTERNL |op| (MAKESTRING ";calls"))) - (SPADLET |res| - (CONS - (QUOTE |%b|) - (CONS - (|eval| |hitCounter|) - (CONS - (QUOTE /) - (CONS - (|eval| |callCounter|) - (CONS (QUOTE |%d|) (CONS (QUOTE |calls to |) NIL))))))) - (SET |hitCounter| 0) (SET |callCounter| 0) |res|))) - (SPADLET |postString| - (PROGN - (SPADLET |cacheValue| (|eval| (CADR |cacheVec|))) - (COND - ((BOOT-EQUAL |kind| (QUOTE |hash|)) - (CONS - (QUOTE | (|) - (CONS - (QUOTE |%b|) - (CONS - (HASH-TABLE-COUNT |cacheValue|) - (CONS (QUOTE |%d|) (CONS (QUOTE |entries)|) NIL)))))) - ((QUOTE T) - (SPADLET |empties| - (|numberOfEmptySlots| (|eval| (CADR |cacheVec|)))) - (COND - ((EQL |empties| 0) NIL) - ((QUOTE T) - (CONS - (QUOTE | (|) - (CONS - (QUOTE |%b|) - (CONS - (SPADDIFFERENCE |kind| |empties|) - (CONS - (QUOTE /) - (CONS - |kind| - (CONS - (QUOTE |%d|) - (CONS (QUOTE |slots used)|) NIL))))))))))))) - (|sayBrightly| (APPEND |prefix| (CONS |op| |postString|))))))))))) -; +(DEFUN |clamStats| () + (PROG (|op| |kind| |cacheVec| |hitCounter| |callCounter| |res| + |prefix| |cacheValue| |empties| |postString|) + (DECLARE (SPECIAL |$reportCounts| |$clamList|)) + (RETURN + (SEQ (DO ((G2836 |$clamList| (CDR G2836)) (G2822 NIL)) + ((OR (ATOM G2836) + (PROGN (SETQ G2822 (CAR G2836)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G2822)) + (SPADLET |kind| (CADR G2822)) + G2822) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |cacheVec| + (OR (GETL |op| '|cacheInfo|) + (|systemErrorHere| '|clamStats|))) + (SPADLET |prefix| + (COND + ((NEQUAL |$reportCounts| 'T) NIL) + ('T + (SPADLET |hitCounter| + (INTERNL |op| + (MAKESTRING ";hit"))) + (SPADLET |callCounter| + (INTERNL |op| + (MAKESTRING ";calls"))) + (SPADLET |res| + (CONS '|%b| + (CONS (|eval| |hitCounter|) + (CONS '/ + (CONS (|eval| |callCounter|) + (CONS '|%d| + (CONS '|calls to | NIL))))))) + (SET |hitCounter| 0) + (SET |callCounter| 0) |res|))) + (SPADLET |postString| + (PROGN + (SPADLET |cacheValue| + (|eval| (CADR |cacheVec|))) + (COND + ((BOOT-EQUAL |kind| '|hash|) + (CONS '| (| + (CONS '|%b| + (CONS + (HASH-TABLE-COUNT + |cacheValue|) + (CONS '|%d| + (CONS '|entries)| NIL)))))) + ('T + (SPADLET |empties| + (|numberOfEmptySlots| + (|eval| (CADR |cacheVec|)))) + (COND + ((EQL |empties| 0) NIL) + ('T + (CONS '| (| + (CONS '|%b| + (CONS + (SPADDIFFERENCE |kind| + |empties|) + (CONS '/ + (CONS |kind| + (CONS '|%d| + (CONS '|slots used)| + NIL))))))))))))) + (|sayBrightly| + (APPEND |prefix| + (CONS |op| |postString|))))))))))) + ;numberOfEmptySlots cache== ; count:= (CAAR cache ='$failed => 1; 0) ; for x in tails rest cache while NE(x,cache) repeat @@ -1588,22 +1638,22 @@ ;;; *** |numberOfEmptySlots| REDEFINED (DEFUN |numberOfEmptySlots| (|cache|) - (PROG (|count|) - (RETURN - (SEQ - (PROGN - (SPADLET |count| - (COND ((BOOT-EQUAL (CAAR |cache|) (QUOTE |$failed|)) 1) ((QUOTE T) 0))) - (DO ((|x| (CDR |cache|) (CDR |x|))) - ((OR (ATOM |x|) (NULL (NE |x| |cache|))) NIL) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL (CAAR |x|) (QUOTE |$failed|)) - (SPADLET |count| (PLUS |count| 1))) - ((QUOTE T) NIL))))) - |count|))))) -; + (PROG (|count|) + (DECLARE (SPECIAL |$failed|)) + (RETURN + (SEQ (PROGN + (SPADLET |count| + (COND + ((BOOT-EQUAL (CAAR |cache|) '|$failed|) 1) + ('T 0))) + (DO ((|x| (CDR |cache|) (CDR |x|))) + ((OR (ATOM |x|) (NULL (NE |x| |cache|))) NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL (CAAR |x|) '|$failed|) + (SPADLET |count| (PLUS |count| 1))) + ('T NIL))))) + |count|))))) + ;addToSlam([name,:argnames],shell) == ; $mutableDomain => return nil ; null argnames => addToConstructorCache(name,nil,shell) @@ -1612,45 +1662,53 @@ ;;; *** |addToSlam| REDEFINED -(DEFUN |addToSlam| (#0=#:G2872 |shell|) - (PROG (|name| |argnames| |args|) - (RETURN - (SEQ - (PROGN - (SPADLET |name| (CAR #0#)) - (SPADLET |argnames| (CDR #0#)) - (COND - (|$mutableDomain| (RETURN NIL)) - ((NULL |argnames|) (|addToConstructorCache| |name| NIL |shell|)) - ((QUOTE T) - (SPADLET |args| - (CONS - (QUOTE LIST) - (PROG (#1=#:G2885) - (SPADLET #1# NIL) - (RETURN - (DO ((#2=#:G2890 |argnames| (CDR #2#)) (|a| NIL)) - ((OR (ATOM #2#) (PROGN (SETQ |a| (CAR #2#)) NIL)) - (NREVERSE0 #1#)) - (SEQ (EXIT (SETQ #1# (CONS (|mkDevaluate| |a|) #1#))))))))) - (|addToConstructorCache| |name| |args| |shell|)))))))) -; +(DEFUN |addToSlam| (G2872 |shell|) + (PROG (|name| |argnames| |args|) + (DECLARE (SPECIAL |$mutableDomain|)) + (RETURN + (SEQ (PROGN + (SPADLET |name| (CAR G2872)) + (SPADLET |argnames| (CDR G2872)) + (COND + (|$mutableDomain| (RETURN NIL)) + ((NULL |argnames|) + (|addToConstructorCache| |name| NIL |shell|)) + ('T + (SPADLET |args| + (CONS 'LIST + (PROG (G2885) + (SPADLET G2885 NIL) + (RETURN + (DO + ((G2890 |argnames| (CDR G2890)) + (|a| NIL)) + ((OR (ATOM G2890) + (PROGN + (SETQ |a| (CAR G2890)) + NIL)) + (NREVERSE0 G2885)) + (SEQ + (EXIT + (SETQ G2885 + (CONS (|mkDevaluate| |a|) + G2885))))))))) + (|addToConstructorCache| |name| |args| |shell|)))))))) + ;addToConstructorCache(op,args,value) == ; ['haddProp,'$ConstructorCache,MKQ op,args,['CONS,1,value]] ;;; *** |addToConstructorCache| REDEFINED (DEFUN |addToConstructorCache| (|op| |args| |value|) - (CONS - (QUOTE |haddProp|) - (CONS - (QUOTE |$ConstructorCache|) - (CONS - (MKQ |op|) - (CONS - |args| - (CONS (CONS (QUOTE CONS) (CONS 1 (CONS |value| NIL))) NIL)))))) -; + (DECLARE (SPECIAL |$ConstructorCache|)) + (CONS '|haddProp| + (CONS '|$ConstructorCache| + (CONS (MKQ |op|) + (CONS |args| + (CONS (CONS 'CONS + (CONS 1 (CONS |value| NIL))) + NIL)))))) + ;haddProp(ht,op,prop,val) == ; --called inside functors (except for union and record types ??) ; --presently, ht always = $ConstructorCache @@ -1672,28 +1730,27 @@ ;;; *** |haddProp| REDEFINED (DEFUN |haddProp| (|ht| |op| |prop| |val|) - (PROG (|$op| |u|) - (DECLARE (SPECIAL |$op|)) - (RETURN - (PROGN - (|statRecordInstantiationEvent|) - (COND - ((OR - (BOOT-EQUAL |$reportInstantiations| (QUOTE T)) - (BOOT-EQUAL |$reportEachInstantiation| (QUOTE T))) - (|startTimingProcess| (QUOTE |debug|)) - (|recordInstantiation| |op| |prop| NIL) - (|stopTimingProcess| (QUOTE |debug|)))) - (COND - ((SPADLET |u| (HGET |ht| |op|)) - (COND - ((|assoc| |prop| |u|) |val|) - ((QUOTE T) - (RPLACD |u| (CONS (CAR |u|) (CDR |u|))) - (RPLACA |u| (CONS |prop| |val|)) - (SPADLET |$op| |op|) (|listTruncate| |u| 20) |val|))) - ((QUOTE T) (HPUT |ht| |op| (CONS (CONS |prop| |val|) NIL)) |val|)))))) -; + (PROG (|$op| |u|) + (DECLARE (SPECIAL |$op| |$reportEachInstantiation| + |$reportInstantiations|)) + (RETURN + (PROGN + (|statRecordInstantiationEvent|) + (COND + ((OR (BOOT-EQUAL |$reportInstantiations| 'T) + (BOOT-EQUAL |$reportEachInstantiation| 'T)) + (|startTimingProcess| '|debug|) + (|recordInstantiation| |op| |prop| NIL) + (|stopTimingProcess| '|debug|))) + (COND + ((SPADLET |u| (HGET |ht| |op|)) + (COND + ((|assoc| |prop| |u|) |val|) + ('T (RPLACD |u| (CONS (CAR |u|) (CDR |u|))) + (RPLACA |u| (CONS |prop| |val|)) (SPADLET |$op| |op|) + (|listTruncate| |u| 20) |val|))) + ('T (HPUT |ht| |op| (CONS (CONS |prop| |val|) NIL)) |val|)))))) + ;recordInstantiation(op,prop,dropIfTrue) == ; startTimingProcess 'debug ; recordInstantiation1(op,prop,dropIfTrue) @@ -1702,11 +1759,11 @@ ;;; *** |recordInstantiation| REDEFINED (DEFUN |recordInstantiation| (|op| |prop| |dropIfTrue|) - (PROGN - (|startTimingProcess| (QUOTE |debug|)) - (|recordInstantiation1| |op| |prop| |dropIfTrue|) - (|stopTimingProcess| (QUOTE |debug|)))) -; + (PROGN + (|startTimingProcess| '|debug|) + (|recordInstantiation1| |op| |prop| |dropIfTrue|) + (|stopTimingProcess| '|debug|))) + ;recordInstantiation1(op,prop,dropIfTrue) == ; op in '(CategoryDefaults RepeatedSquaring) => nil--ignore defaults for now ; if $reportEachInstantiation = true then @@ -1738,69 +1795,72 @@ ;;; *** |recordInstantiation1| REDEFINED (DEFUN |recordInstantiation1| (|op| |prop| |dropIfTrue|) - (PROG (|trailer| |m1| |ISTMP#1| |m2| |xtra| |u| |v| |val|) - (RETURN - (COND - ((|member| |op| (QUOTE (|CategoryDefaults| |RepeatedSquaring|))) NIL) - ((QUOTE T) - (COND - ((BOOT-EQUAL |$reportEachInstantiation| (QUOTE T)) - (SPADLET |trailer| - (COND - (|dropIfTrue| (MAKESTRING " dropped")) - ((QUOTE T) (MAKESTRING " instantiated")))) - (COND - ((BOOT-EQUAL |$insideCoerceInteractive| (QUOTE T)) - (SPADLET |$instantCoerceCount| (PLUS 1 |$instantCoerceCount|)))) - (COND - ((AND - (PAIRP |$insideCanCoerceFrom|) - (PROGN - (SPADLET |m1| (QCAR |$insideCanCoerceFrom|)) - (SPADLET |ISTMP#1| (QCDR |$insideCanCoerceFrom|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |m2| (QCAR |ISTMP#1|)) (QUOTE T)))) - (NULL |dropIfTrue|)) - (SPADLET |$instantCanCoerceCount| (PLUS 1 |$instantCanCoerceCount|)) - (SPADLET |xtra| - (CONS - (MAKESTRING " for ") - (CONS - (|outputDomainConstructor| |m1|) - (CONS - (MAKESTRING "-->") - (CONS (|outputDomainConstructor| |m2|) NIL))))))) - (COND - ((AND - (BOOT-EQUAL |$insideEvalMmCondIfTrue| (QUOTE T)) - (NULL |dropIfTrue|)) - (SPADLET |$instantMmCondCount| (PLUS |$instantMmCondCount| 1)))) - (|typeTimePrin| - (CONS - (QUOTE CONCAT) - (CONS - (|outputDomainConstructor| (CONS |op| |prop|)) - (CONS |trailer| |xtra|)))))) - (COND - ((NULL |$reportInstantiations|) NIL) - ((SPADLET |u| (HGET |$instantRecord| |op|)) - (COND - ((SPADLET |v| (LASSOC |prop| |u|)) - (COND - (|dropIfTrue| (RPLAC (CDR |v|) (PLUS 1 (CDR |v|)))) - ((QUOTE T) (RPLAC (CAR |v|) (PLUS 1 (CAR |v|)))))) - ((QUOTE T) - (RPLACD |u| (CONS (CAR |u|) (CDR |u|))) - (SPADLET |val| - (COND (|dropIfTrue| (CONS 0 1)) ((QUOTE T) (CONS 1 0)))) - (RPLACA |u| (CONS |prop| |val|))))) - ((QUOTE T) - (SPADLET |val| - (COND (|dropIfTrue| (CONS 0 1)) ((QUOTE T) (CONS 1 0)))) - (HPUT |$instantRecord| |op| (CONS (CONS |prop| |val|) NIL))))))))) -; + (PROG (|trailer| |m1| |ISTMP#1| |m2| |xtra| |u| |v| |val|) + (DECLARE (SPECIAL |$instantRecord| |$reportInstantiations| + |$instantMmCondCount| |$insideEvalMmCondIfTrue| + |$instantCanCoerceCount| |$insideCanCoerceFrom| + |$instantCoerceCount| |$insideCoerceInteractive| + |$reportEachInstantiation|)) + (RETURN + (COND + ((|member| |op| '(|CategoryDefaults| |RepeatedSquaring|)) NIL) + ('T + (COND + ((BOOT-EQUAL |$reportEachInstantiation| 'T) + (SPADLET |trailer| + (COND + (|dropIfTrue| (MAKESTRING " dropped")) + ('T (MAKESTRING " instantiated")))) + (COND + ((BOOT-EQUAL |$insideCoerceInteractive| 'T) + (SPADLET |$instantCoerceCount| + (PLUS 1 |$instantCoerceCount|)))) + (COND + ((AND (PAIRP |$insideCanCoerceFrom|) + (PROGN + (SPADLET |m1| (QCAR |$insideCanCoerceFrom|)) + (SPADLET |ISTMP#1| (QCDR |$insideCanCoerceFrom|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |m2| (QCAR |ISTMP#1|)) 'T))) + (NULL |dropIfTrue|)) + (SPADLET |$instantCanCoerceCount| + (PLUS 1 |$instantCanCoerceCount|)) + (SPADLET |xtra| + (CONS (MAKESTRING " for ") + (CONS (|outputDomainConstructor| |m1|) + (CONS (MAKESTRING "-->") + (CONS + (|outputDomainConstructor| |m2|) + NIL))))))) + (COND + ((AND (BOOT-EQUAL |$insideEvalMmCondIfTrue| 'T) + (NULL |dropIfTrue|)) + (SPADLET |$instantMmCondCount| + (PLUS |$instantMmCondCount| 1)))) + (|typeTimePrin| + (CONS 'CONCAT + (CONS (|outputDomainConstructor| + (CONS |op| |prop|)) + (CONS |trailer| |xtra|)))))) + (COND + ((NULL |$reportInstantiations|) NIL) + ((SPADLET |u| (HGET |$instantRecord| |op|)) + (COND + ((SPADLET |v| (LASSOC |prop| |u|)) + (COND + (|dropIfTrue| (RPLAC (CDR |v|) (PLUS 1 (CDR |v|)))) + ('T (RPLAC (CAR |v|) (PLUS 1 (CAR |v|)))))) + ('T (RPLACD |u| (CONS (CAR |u|) (CDR |u|))) + (SPADLET |val| + (COND + (|dropIfTrue| (CONS 0 1)) + ('T (CONS 1 0)))) + (RPLACA |u| (CONS |prop| |val|))))) + ('T + (SPADLET |val| + (COND (|dropIfTrue| (CONS 0 1)) ('T (CONS 1 0)))) + (HPUT |$instantRecord| |op| (CONS (CONS |prop| |val|) NIL))))))))) + ;reportInstantiations() == ; --assumed to be a hashtable with reference counts ; conList:= @@ -1824,142 +1884,162 @@ ;;; *** |reportInstantiations| REDEFINED -(DEFUN |reportInstantiations| NIL - (PROG (|argList| |conList| |n| |m| |form| |nTotal| |mTotal| |rTotal| - |nForms|) - (RETURN - (SEQ - (PROGN - (SPADLET |conList| - (PROG (#0=#:G2964) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G2973 (HKEYS |$instantRecord|) (CDR #1#)) (|key| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |key| (CAR #1#)) NIL)) #0#) - (SEQ - (EXIT - (SETQ #0# - (APPEND - #0# - (PROG (#2=#:G2984) - (SPADLET #2# NIL) - (RETURN - (DO ((#3=#:G2990 (HGET |$instantRecord| |key|) (CDR #3#)) - (#4=#:G2952 NIL)) - ((OR - (ATOM #3#) - (PROGN (SETQ #4# (CAR #3#)) NIL) - (PROGN +(DEFUN |reportInstantiations| () + (PROG (|argList| |conList| |n| |m| |form| |nTotal| |mTotal| |rTotal| + |nForms|) + (DECLARE (SPECIAL |$instantMmCondCount| |$instantCanCoerceCount| + |$instantCoerceCount| |$instantRecord|)) + (RETURN + (SEQ (PROGN + (SPADLET |conList| + (PROG (G2964) + (SPADLET G2964 NIL) + (RETURN + (DO ((G2973 (HKEYS |$instantRecord|) + (CDR G2973)) + (|key| NIL)) + ((OR (ATOM G2973) + (PROGN + (SETQ |key| (CAR G2973)) + NIL)) + G2964) + (SEQ (EXIT (SETQ G2964 + (APPEND G2964 + (PROG (G2984) + (SPADLET G2984 NIL) + (RETURN + (DO + ((G2990 + (HGET |$instantRecord| + |key|) + (CDR G2990)) + (G2952 NIL)) + ((OR (ATOM G2990) + (PROGN + (SETQ G2952 + (CAR G2990)) + NIL) + (PROGN + (PROGN + (SPADLET |argList| + (CAR G2952)) + (SPADLET |n| + (CADR G2952)) + (SPADLET |m| + (CDDR G2952)) + G2952) + NIL)) + (NREVERSE0 G2984)) + (SEQ + (EXIT + (SETQ G2984 + (CONS + (CONS |n| + (CONS |m| + (CONS + (CONS |key| + |argList|) + NIL))) + G2984))))))))))))))) + (|sayBrightly| + (CONS (MAKESTRING + "# instantiated/# dropped/domain name") + (CONS (MAKESTRING "%l") + (CONS (MAKESTRING + "------------------------------------") + NIL)))) + (SPADLET |nTotal| + (SPADLET |mTotal| + (SPADLET |rTotal| (SPADLET |nForms| 0)))) + (DO ((G3006 (NREVERSE (SORTBY 'CADDR |conList|)) + (CDR G3006)) + (G2958 NIL)) + ((OR (ATOM G3006) + (PROGN (SETQ G2958 (CAR G3006)) NIL) (PROGN - (SPADLET |argList| (CAR #4#)) - (SPADLET |n| (CADR #4#)) - (SPADLET |m| (CDDR #4#)) #4#) - NIL)) - (NREVERSE0 #2#)) - (SEQ - (EXIT - (SETQ #2# - (CONS - (CONS |n| (CONS |m| (CONS (CONS |key| |argList|) NIL))) - #2#))))))))))))))) - (|sayBrightly| - (CONS - (MAKESTRING "# instantiated/# dropped/domain name") - (CONS - (MAKESTRING "%l") - (CONS (MAKESTRING "------------------------------------") NIL)))) - (SPADLET |nTotal| - (SPADLET |mTotal| (SPADLET |rTotal| (SPADLET |nForms| 0)))) - (DO ((#5=#:G3006 (NREVERSE (SORTBY (QUOTE CADDR) |conList|)) (CDR #5#)) - (#6=#:G2958 NIL)) - ((OR - (ATOM #5#) - (PROGN (SETQ #6# (CAR #5#)) NIL) - (PROGN - (PROGN - (SPADLET |n| (CAR #6#)) - (SPADLET |m| (CADR #6#)) - (SPADLET |form| (CADDR #6#)) - #6#) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |nTotal| (PLUS |nTotal| |n|)) - (SPADLET |mTotal| (PLUS |mTotal| |m|)) - (COND - ((> |n| 1) - (SPADLET |rTotal| (SPADDIFFERENCE (PLUS |rTotal| |n|) 1)))) - (SPADLET |nForms| (PLUS |nForms| 1)) - (|typeTimePrin| - (CONS - (QUOTE CONCATB) - (CONS - |n| - (CONS |m| (CONS (|outputDomainConstructor| |form|) NIL))))))))) - (|sayBrightly| - (CONS - (MAKESTRING "%b") - (CONS - (MAKESTRING "Totals:") - (CONS - (MAKESTRING "%d") - (CONS - |nTotal| - (CONS - (MAKESTRING " instantiated") - (CONS - (MAKESTRING "%l") - (CONS - (MAKESTRING " ") - (CONS - |$instantCoerceCount| - (CONS - (MAKESTRING " inside coerceInteractive") - (CONS - (MAKESTRING "%l") - (CONS - (MAKESTRING " ") - (CONS - |$instantCanCoerceCount| - (CONS - (MAKESTRING " inside canCoerceFrom") - (CONS - (MAKESTRING "%l") - (CONS - (MAKESTRING " ") - (CONS - |$instantMmCondCount| - (CONS - (MAKESTRING " inside evalMmCond") - (CONS - (MAKESTRING "%l") - (CONS - (MAKESTRING " ") - (CONS - |rTotal| - (CONS - (MAKESTRING " reinstantiated") - (CONS - (MAKESTRING "%l") - (CONS - (MAKESTRING " ") - (CONS - |mTotal| - (CONS - (MAKESTRING " dropped") - (CONS - (MAKESTRING "%l") - (CONS - (MAKESTRING " ") - (CONS - |nForms| - (CONS - (MAKESTRING - " distinct domains instantiated/dropped") - NIL))))))))))))))))))))))))))))))))))) -; + (PROGN + (SPADLET |n| (CAR G2958)) + (SPADLET |m| (CADR G2958)) + (SPADLET |form| (CADDR G2958)) + G2958) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |nTotal| (PLUS |nTotal| |n|)) + (SPADLET |mTotal| (PLUS |mTotal| |m|)) + (COND + ((> |n| 1) + (SPADLET |rTotal| + (SPADDIFFERENCE + (PLUS |rTotal| |n|) 1)))) + (SPADLET |nForms| (PLUS |nForms| 1)) + (|typeTimePrin| + (CONS 'CONCATB + (CONS |n| + (CONS |m| + (CONS + (|outputDomainConstructor| + |form|) + NIL))))))))) + (|sayBrightly| + (CONS (MAKESTRING "%b") + (CONS (MAKESTRING "Totals:") + (CONS (MAKESTRING "%d") + (CONS |nTotal| + (CONS (MAKESTRING " instantiated") + (CONS (MAKESTRING "%l") + (CONS (MAKESTRING " ") + (CONS |$instantCoerceCount| + (CONS + (MAKESTRING + " inside coerceInteractive") + (CONS (MAKESTRING "%l") + (CONS + (MAKESTRING " ") + (CONS + |$instantCanCoerceCount| + (CONS + (MAKESTRING + " inside canCoerceFrom") + (CONS (MAKESTRING "%l") + (CONS + (MAKESTRING " ") + (CONS + |$instantMmCondCount| + (CONS + (MAKESTRING + " inside evalMmCond") + (CONS + (MAKESTRING "%l") + (CONS + (MAKESTRING + " ") + (CONS |rTotal| + (CONS + (MAKESTRING + " reinstantiated") + (CONS + (MAKESTRING "%l") + (CONS + (MAKESTRING + " ") + (CONS |mTotal| + (CONS + (MAKESTRING + " dropped") + (CONS + (MAKESTRING + "%l") + (CONS + (MAKESTRING + " ") + (CONS + |nForms| + (CONS + (MAKESTRING + " distinct domains instantiated/dropped") + NIL))))))))))))))))))))))))))))))))))) + ;hputNewProp(ht,op,argList,val) == ; --NOTE: obselete if lines *** are commented out ; -- Warning!!! This function should only be called for @@ -1979,19 +2059,25 @@ ;;; *** |hputNewProp| REDEFINED (DEFUN |hputNewProp| (|ht| |op| |argList| |val|) - (PROG (|prop|) - (RETURN - (SEQ - (PROGN - (SPADLET |prop| - (PROG (#0=#:G3038) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G3043 |argList| (CDR #1#)) (|x| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (|devaluate| |x|) #0#)))))))) - (|haddProp| |ht| |op| |prop| |val|)))))) -; + (PROG (|prop|) + (RETURN + (SEQ (PROGN + (SPADLET |prop| + (PROG (G3038) + (SPADLET G3038 NIL) + (RETURN + (DO ((G3043 |argList| (CDR G3043)) + (|x| NIL)) + ((OR (ATOM G3043) + (PROGN + (SETQ |x| (CAR G3043)) + NIL)) + (NREVERSE0 G3038)) + (SEQ (EXIT (SETQ G3038 + (CONS (|devaluate| |x|) + G3038)))))))) + (|haddProp| |ht| |op| |prop| |val|)))))) + ;listTruncate(l,n) == ; u:= l ; n:= QSSUB1 n @@ -2007,25 +2093,25 @@ ;;; *** |listTruncate| REDEFINED (DEFUN |listTruncate| (|l| |n|) - (PROG (|u|) - (RETURN - (SEQ - (PROGN - (SPADLET |u| |l|) - (SPADLET |n| (QSSUB1 |n|)) - (DO NIL - ((NULL (AND (NEQ |n| 0) (NULL (ATOM |u|)))) NIL) - (SEQ (EXIT (PROGN (SPADLET |n| (QSSUB1 |n|)) (SPADLET |u| (QCDR |u|)))))) - (COND - ((NULL (ATOM |u|)) - (COND - ((AND - (NULL (ATOM (CDR |u|))) - (BOOT-EQUAL |$reportInstantiations| (QUOTE T))) - (|recordInstantiation| |$op| (CAADR |u|) (QUOTE T)))) - (RPLACD |u| NIL))) - |l|))))) -; + (PROG (|u|) + (DECLARE (SPECIAL |$op| |$reportInstantiations|)) + (RETURN + (SEQ (PROGN + (SPADLET |u| |l|) + (SPADLET |n| (QSSUB1 |n|)) + (DO () ((NULL (AND (NEQ |n| 0) (NULL (ATOM |u|)))) NIL) + (SEQ (EXIT (PROGN + (SPADLET |n| (QSSUB1 |n|)) + (SPADLET |u| (QCDR |u|)))))) + (COND + ((NULL (ATOM |u|)) + (COND + ((AND (NULL (ATOM (CDR |u|))) + (BOOT-EQUAL |$reportInstantiations| 'T)) + (|recordInstantiation| |$op| (CAADR |u|) 'T))) + (RPLACD |u| NIL))) + |l|))))) + ;lassocShift(x,l) == ; y:= l ; while not atom y repeat @@ -2041,26 +2127,22 @@ ;;; *** |lassocShift| REDEFINED (DEFUN |lassocShift| (|x| |l|) - (PROG (|result| |y|) - (RETURN - (SEQ - (PROGN - (SPADLET |y| |l|) - (DO NIL - ((NULL (NULL (ATOM |y|))) NIL) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |x| (CAR (QCAR |y|))) - (RETURN (SPADLET |result| (QCAR |y|)))) - ((QUOTE T) (SPADLET |y| (QCDR |y|))))))) - (COND - (|result| - (COND - ((NEQ |y| |l|) (QRPLACA |y| (CAR |l|)) (QRPLACA |l| |result|))) - (QCDR |result|)) - ((QUOTE T) NIL))))))) -; + (PROG (|result| |y|) + (RETURN + (SEQ (PROGN + (SPADLET |y| |l|) + (DO () ((NULL (NULL (ATOM |y|))) NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |x| (CAR (QCAR |y|))) + (RETURN (SPADLET |result| (QCAR |y|)))) + ('T (SPADLET |y| (QCDR |y|))))))) + (COND + (|result| (COND + ((NEQ |y| |l|) (QRPLACA |y| (CAR |l|)) + (QRPLACA |l| |result|))) + (QCDR |result|)) + ('T NIL))))))) + ;lassocShiftWithFunction(x,l,fn) == ; y:= l ; while not atom y repeat @@ -2076,25 +2158,22 @@ ;;; *** |lassocShiftWithFunction| REDEFINED (DEFUN |lassocShiftWithFunction| (|x| |l| |fn|) - (PROG (|result| |y|) - (RETURN - (SEQ - (PROGN - (SPADLET |y| |l|) - (DO NIL - ((NULL (NULL (ATOM |y|))) NIL) - (SEQ - (EXIT - (COND - ((FUNCALL |fn| |x| (CAR (QCAR |y|))) - (RETURN (SPADLET |result| (QCAR |y|)))) - ((QUOTE T) (SPADLET |y| (QCDR |y|))))))) - (COND - (|result| - (COND ((NEQ |y| |l|) (QRPLACA |y| (CAR |l|)) (QRPLACA |l| |result|))) - (QCDR |result|)) - ((QUOTE T) NIL))))))) -; + (PROG (|result| |y|) + (RETURN + (SEQ (PROGN + (SPADLET |y| |l|) + (DO () ((NULL (NULL (ATOM |y|))) NIL) + (SEQ (EXIT (COND + ((FUNCALL |fn| |x| (CAR (QCAR |y|))) + (RETURN (SPADLET |result| (QCAR |y|)))) + ('T (SPADLET |y| (QCDR |y|))))))) + (COND + (|result| (COND + ((NEQ |y| |l|) (QRPLACA |y| (CAR |l|)) + (QRPLACA |l| |result|))) + (QCDR |result|)) + ('T NIL))))))) + ;lassocShiftQ(x,l) == ; y:= l ; while not atom y repeat @@ -2110,24 +2189,22 @@ ;;; *** |lassocShiftQ| REDEFINED (DEFUN |lassocShiftQ| (|x| |l|) - (PROG (|result| |y|) - (RETURN - (SEQ - (PROGN - (SPADLET |y| |l|) - (DO NIL - ((NULL (NULL (ATOM |y|))) NIL) - (SEQ - (EXIT - (COND - ((EQ |x| (CAR (CAR |y|))) (RETURN (SPADLET |result| (CAR |y|)))) - ((QUOTE T) (SPADLET |y| (CDR |y|))))))) - (COND - (|result| - (COND ((NEQ |y| |l|) (RPLACA |y| (CAR |l|)) (RPLACA |l| |result|))) - (CDR |result|)) - ((QUOTE T) NIL))))))) -; + (PROG (|result| |y|) + (RETURN + (SEQ (PROGN + (SPADLET |y| |l|) + (DO () ((NULL (NULL (ATOM |y|))) NIL) + (SEQ (EXIT (COND + ((EQ |x| (CAR (CAR |y|))) + (RETURN (SPADLET |result| (CAR |y|)))) + ('T (SPADLET |y| (CDR |y|))))))) + (COND + (|result| (COND + ((NEQ |y| |l|) (RPLACA |y| (CAR |l|)) + (RPLACA |l| |result|))) + (CDR |result|)) + ('T NIL))))))) + ;-- rassocShiftQ(x,l) == ;-- y:= l ;-- while not atom y repeat @@ -2157,76 +2234,87 @@ ;;; *** |globalHashtableStats| REDEFINED (DEFUN |globalHashtableStats| (|x| |sortFn|) - (PROG (|keys| |u| |argList| |argList1| |reportList| |n| |fn| |args|) - (RETURN - (SEQ - (PROGN - (SPADLET |keys| (HKEYS |x|)) - (DO ((#0=#:G3141 |keys| (CDR #0#)) (|key| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |key| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |u| (HGET |x| |key|)) - (DO ((#1=#:G3151 |u| (CDR #1#)) (#2=#:G3121 NIL)) - ((OR - (ATOM #1#) - (PROGN (SETQ #2# (CAR #1#)) NIL) - (PROGN - (PROGN - (SPADLET |argList| (CAR #2#)) - (SPADLET |n| (CADR #2#)) #2#) - NIL)) - NIL) - (SEQ - (EXIT - (COND - ((NULL (INTEGERP |n|)) - (|keyedSystemError| (QUOTE S2GE0013) (CONS |x| NIL))) - ((QUOTE T) - (SPADLET |argList1| - (PROG (#3=#:G3162) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G3167 |argList| (CDR #4#)) (|x| NIL)) - ((OR - (ATOM #4#) - (PROGN (SETQ |x| (CAR #4#)) NIL)) - (NREVERSE0 #3#)) - (SEQ - (EXIT - (SETQ #3# - (CONS (|constructor2ConstructorForm| |x|) #3#)))))))) - (SPADLET |reportList| - (CONS - (CONS |n| (CONS |key| (CONS |argList1| NIL))) - |reportList|))))))))))) - (|sayBrightly| - (CONS - (MAKESTRING "%b") - (CONS (MAKESTRING " USE NAME ARGS") (CONS (MAKESTRING "%d") NIL)))) - (DO ((#5=#:G3179 (NREVERSE (SORTBY |sortFn| |reportList|)) (CDR #5#)) - (#6=#:G3127 NIL)) - ((OR - (ATOM #5#) - (PROGN (SETQ #6# (CAR #5#)) NIL) - (PROGN - (PROGN - (SPADLET |n| (CAR #6#)) - (SPADLET |fn| (CADR #6#)) - (SPADLET |args| (CADDR #6#)) - #6#) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (|sayBrightlyNT| - (APPEND - (|rightJustifyString| |n| 6) - (CONS (QUOTE | |) (CONS |fn| (CONS (QUOTE |: |) NIL))))) - (|pp| |args|)))))))))) -; + (PROG (|keys| |u| |argList| |argList1| |reportList| |n| |fn| |args|) + (RETURN + (SEQ (PROGN + (SPADLET |keys| (HKEYS |x|)) + (DO ((G3141 |keys| (CDR G3141)) (|key| NIL)) + ((OR (ATOM G3141) + (PROGN (SETQ |key| (CAR G3141)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |u| (HGET |x| |key|)) + (DO ((G3151 |u| (CDR G3151)) + (G3121 NIL)) + ((OR (ATOM G3151) + (PROGN + (SETQ G3121 (CAR G3151)) + NIL) + (PROGN + (PROGN + (SPADLET |argList| + (CAR G3121)) + (SPADLET |n| (CADR G3121)) + G3121) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((NULL (INTEGERP |n|)) + (|keyedSystemError| 'S2GE0013 + (CONS |x| NIL))) + ('T + (SPADLET |argList1| + (PROG (G3162) + (SPADLET G3162 NIL) + (RETURN + (DO + ((G3167 |argList| + (CDR G3167)) + (|x| NIL)) + ((OR (ATOM G3167) + (PROGN + (SETQ |x| + (CAR G3167)) + NIL)) + (NREVERSE0 G3162)) + (SEQ + (EXIT + (SETQ G3162 + (CONS + (|constructor2ConstructorForm| + |x|) + G3162)))))))) + (SPADLET |reportList| + (CONS + (CONS |n| + (CONS |key| + (CONS |argList1| NIL))) + |reportList|))))))))))) + (|sayBrightly| + (CONS (MAKESTRING "%b") + (CONS (MAKESTRING " USE NAME ARGS") + (CONS (MAKESTRING "%d") NIL)))) + (DO ((G3179 (NREVERSE (SORTBY |sortFn| |reportList|)) + (CDR G3179)) + (G3127 NIL)) + ((OR (ATOM G3179) + (PROGN (SETQ G3127 (CAR G3179)) NIL) + (PROGN + (PROGN + (SPADLET |n| (CAR G3127)) + (SPADLET |fn| (CADR G3127)) + (SPADLET |args| (CADDR G3127)) + G3127) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|sayBrightlyNT| + (APPEND (|rightJustifyString| |n| 6) + (CONS '| | + (CONS |fn| (CONS '|: | NIL))))) + (|pp| |args|)))))))))) + ;constructor2ConstructorForm x == ; VECP x => x.0 ; x @@ -2234,8 +2322,8 @@ ;;; *** |constructor2ConstructorForm| REDEFINED (DEFUN |constructor2ConstructorForm| (|x|) - (COND ((VECP |x|) (ELT |x| 0)) ((QUOTE T) |x|))) -; + (COND ((VECP |x|) (ELT |x| 0)) ('T |x|))) + ;rightJustifyString(x,maxWidth) == ; size:= entryWidth x ; size > maxWidth => keyedSystemError("S2GE0014",[x]) @@ -2244,17 +2332,17 @@ ;;; *** |rightJustifyString| REDEFINED (DEFUN |rightJustifyString| (|x| |maxWidth|) - (PROG (SIZE) - (RETURN - (PROGN - (SPADLET SIZE (|entryWidth| |x|)) - (COND - ((> SIZE |maxWidth|) (|keyedSystemError| (QUOTE S2GE0014) (CONS |x| NIL))) - ((QUOTE T) - (CONS - (|fillerSpaces| (SPADDIFFERENCE |maxWidth| SIZE) (QUOTE | |)) - (CONS |x| NIL)))))))) -; + (PROG (SIZE) + (RETURN + (PROGN + (SPADLET SIZE (|entryWidth| |x|)) + (COND + ((> SIZE |maxWidth|) + (|keyedSystemError| 'S2GE0014 (CONS |x| NIL))) + ('T + (CONS (|fillerSpaces| (SPADDIFFERENCE |maxWidth| SIZE) '| |) + (CONS |x| NIL)))))))) + ;domainEqualList(argl1,argl2) == ; --function used to match argument lists of constructors ; while argl1 and argl2 repeat @@ -2271,26 +2359,25 @@ ;;; *** |domainEqualList| REDEFINED (DEFUN |domainEqualList| (|argl1| |argl2|) - (PROG (|item1| |item2| |partsMatch|) - (RETURN - (SEQ - (PROGN - (DO NIL - ((NULL (AND |argl1| |argl2|)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |item1| (|devaluate| (CAR |argl1|))) - (SPADLET |item2| (CAR |argl2|)) - (SPADLET |partsMatch| - (COND ((BOOT-EQUAL |item1| |item2|) (QUOTE T)) ((QUOTE T) NIL))) - (COND - ((NULL |partsMatch|) (RETURN NIL)) - ((QUOTE T) - (SPADLET |argl1| (CDR |argl1|)) - (SPADLET |argl2| (CDR |argl2|)))))))) - (COND ((OR |argl1| |argl2|) NIL) ((QUOTE T) (QUOTE T)))))))) -; + (PROG (|item1| |item2| |partsMatch|) + (RETURN + (SEQ (PROGN + (DO () ((NULL (AND |argl1| |argl2|)) NIL) + (SEQ (EXIT (PROGN + (SPADLET |item1| + (|devaluate| (CAR |argl1|))) + (SPADLET |item2| (CAR |argl2|)) + (SPADLET |partsMatch| + (COND + ((BOOT-EQUAL |item1| |item2|) + 'T) + ('T NIL))) + (COND + ((NULL |partsMatch|) (RETURN NIL)) + ('T (SPADLET |argl1| (CDR |argl1|)) + (SPADLET |argl2| (CDR |argl2|)))))))) + (COND ((OR |argl1| |argl2|) NIL) ('T 'T))))))) + ;removeAllClams() == ; for [fun,:.] in $clamList repeat ; sayBrightly ['"Un-clamming function",'%b,fun,'%d] @@ -2298,26 +2385,27 @@ ;;; *** |removeAllClams| REDEFINED -(DEFUN |removeAllClams| NIL - (PROG (|fun|) - (RETURN - (SEQ - (DO ((#0=#:G3239 |$clamList| (CDR #0#)) (#1=#:G3230 NIL)) - ((OR - (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN (PROGN (SPADLET |fun| (CAR #1#)) #1#) NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (|sayBrightly| - (CONS - (MAKESTRING "Un-clamming function") - (CONS (QUOTE |%b|) (CONS |fun| (CONS (QUOTE |%d|) NIL))))) - (SET |fun| - (|eval| - (INTERN (STRCONC (STRINGIMAGE |fun|) (MAKESTRING ";"))))))))))))) +(DEFUN |removeAllClams| () + (PROG (|fun|) + (DECLARE (SPECIAL |$clamList|)) + (RETURN + (SEQ (DO ((G3239 |$clamList| (CDR G3239)) (G3230 NIL)) + ((OR (ATOM G3239) + (PROGN (SETQ G3230 (CAR G3239)) NIL) + (PROGN + (PROGN (SPADLET |fun| (CAR G3230)) G3230) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|sayBrightly| + (CONS (MAKESTRING "Un-clamming function") + (CONS '|%b| + (CONS |fun| (CONS '|%d| NIL))))) + (SET |fun| + (|eval| (INTERN + (STRCONC (STRINGIMAGE |fun|) + (MAKESTRING ";"))))))))))))) + @ \eject