diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index f468135..90c8339 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -2088,14 +2088,13 @@ of the symbol being parsed. The original list read: \calls{parseIf}{parseTran} <>= (defun |parseIf| (arg) - (let (p a b) (if (null (and (pairp arg) (pairp (qcdr arg)) (pairp (qcdr (qcdr arg))) (eq (qcdr (qcdr (qcdr arg))) nil))) arg (|parseIf,ifTran| (|parseTran| (first arg)) (|parseTran| (second arg)) - (|parseTran| (third arg)))))) + (|parseTran| (third arg))))) @ @@ -2407,7 +2406,8 @@ of the symbol being parsed. The original list read: \usesdollar{parseNotEqual}{op} <>= (defun |parseNotEqual| (arg) - (|parseTran| (list '|not| (cons (msubst '= '^= |$op|) arg)))) + (declare (special |$op|)) + (|parseTran| (list '|not| (cons (msubst '= '^= |$op|) arg)))) @ @@ -2724,6 +2724,277 @@ of the symbol being parsed. The original list read: @ +\defplist{capsule}{compCapsule} +<>= +(eval-when (eval load) + (setf (get 'capsule 'special) '|compCapsule|)) + +@ + +\defun{compCapsule}{compCapsule} +\calls{compCapsule}{bootStrapError} +\calls{compCapsule}{compCapsuleInner} +\calls{compCapsule}{addDomain} +\uses{compCapsule}{editfile} +\usesdollar{compCapsule}{insideExpressionIfTrue} +\usesdollar{compCapsule}{functorForm} +\usesdollar{compCapsule}{bootStrapMode} +<>= +(defun |compCapsule| (arg m e) + (let (|$insideExpressionIfTrue| itemList) + (declare (special |$insideExpressionIfTrue| |$functorForm| /editfile + |$bootStrapMode|)) + (setq itemList (cdr arg)) + (cond + ((eq |$bootStrapMode| t) + (list (|bootStrapError| |$functorForm| /editfile) m e)) + (t + (setq |$insideExpressionIfTrue| nil) + (|compCapsuleInner| itemList m (|addDomain| '$ e)))))) + +@ + +\defun{compCapsuleInner}{compCapsuleInner} +\calls{compCapsuleInner}{addInformation} +\calls{compCapsuleInner}{compCapsuleItems} +\calls{compCapsuleInner}{processFunctorOrPackage} +\calls{compCapsuleInner}{mkpf} +\usesdollar{compCapsuleInner}{getDomainCode} +\usesdollar{compCapsuleInner}{signature} +\usesdollar{compCapsuleInner}{form} +\usesdollar{compCapsuleInner}{addForm} +\usesdollar{compCapsuleInner}{insideCategoryPackageIfTrue} +\usesdollar{compCapsuleInner}{insideCategoryIfTrue} +\usesdollar{compCapsuleInner}{functorLocalParameters} +<>= +(defun |compCapsuleInner| (itemList m e) + (let (localParList data code) + (declare (special |$getDomainCode| |$signature| |$form| |$addForm| + |$insideCategoryPackageIfTrue| |$insideCategoryIfTrue| + |$functorLocalParameters|)) + (setq e (|addInformation| m e)) + (setq data (cons 'progn itemList)) + (setq e (|compCapsuleItems| itemList nil e)) + (setq localParList |$functorLocalParameters|) + (when |$addForm| (setq data (list '|add| |$addForm| data))) + (setq code + (if (and |$insideCategoryIfTrue| (null |$insideCategoryPackageIfTrue|)) + data + (|processFunctorOrPackage| |$form| |$signature| data localParList m e))) + (cons (mkpf (append |$getDomainCode| (list code)) 'progn) (list m e)))) + +@ + +\defplist{case}{compCase} +<>= +(eval-when (eval load) + (setf (get '|case| 'special) '|compCase|)) + +@ + +\defun{compCase}{compCase} +Will the jerk who commented out these two functions please NOT do so +again. These functions ARE needed, and case can NOT be done by +modemap alone. The reason is that A case B requires to take A +evaluated, but B unevaluated. Therefore a special function is +required. You may have thought that you had tested this on ``failed'' +etc., but ``failed'' evaluates to it's own mode. Try it on x case \$ +next time. + +An angry JHD - August 15th., 1984 +\calls{compCase}{addDomain} +\calls{compCase}{compCase1} +\calls{compCase}{coerce} +<>= +(defun |compCase| (arg m e) + (let (mp td) + (setq mp (third arg)) + (setq e (|addDomain| mp e)) + (when (setq td (|compCase1| (second arg) mp e)) (|coerce| td m)))) + +@ + +\defun{compCase1}{compCase1} +\calls{compCase1}{comp} +\calls{compCase1}{getModemapList} +\calls{compCase1}{nreverse0} +\calls{compCase1}{modeEqual} +\usesdollar{compCase1}{Boolean} +\usesdollar{compCase1}{EmptyMode} +<>= +(defun |compCase1| (x m e) + (let (xp mp ep map tmp3 tmp5 tmp6 u fn onepair) + (declare (special |$Boolean| |$EmptyMode|)) + (when (setq tmp3 (|comp| x |$EmptyMode| e)) + (setq xp (first tmp3)) + (setq mp (second tmp3)) + (setq ep (third tmp3)) + (when + (setq u + (dolist (modemap (|getModemapList| '|case| 2 ep) (nreverse0 tmp5)) + (setq map (first modemap)) + (when + (and (pairp map) (pairp (qcdr map)) (pairp (qcdr (qcdr map))) + (pairp (qcdr (qcdr (qcdr map)))) + (eq (qcdr (qcdr (qcdr (qcdr map)))) nil) + (|modeEqual| (fourth map) m) + (|modeEqual| (third map) mp)) + (push (second modemap) tmp5)))) + (when + (setq fn + (dolist (onepair u tmp6) + (when (first onepair) (setq tmp6 (or tmp6 (second onepair)))))) + (list (list '|call| fn xp) |$Boolean| ep)))))) + +@ + +\defplist{Record}{compCat} +<>= +(eval-when (eval load) + (setf (get '|Record| 'special) '|compCat|)) + +@ + +\defplist{Mapping}{compCat} +<>= +(eval-when (eval load) + (setf (get '|Mapping| 'special) '|compCat|)) + +@ + +\defplist{Union}{compCat} +<>= +(eval-when (eval load) + (setf (get '|Union| 'special) '|compCat|)) + +@ + +\defun{compCat}{compCat} +\calls{compCat}{getl} +<>= +(defun |compCat| (form m e) + (declare (ignore m)) + (let (functorName fn tmp1 tmp2 funList op sig catForm) + (setq functorName (first form)) + (when (setq fn (getl functorName '|makeFunctionList|)) + (setq tmp1 (funcall fn form form e)) + (setq funList (first tmp1)) + (setq e (second tmp1)) + (setq catForm + (list '|Join| '(|SetCategory|) + (cons 'category + (cons '|domain| + (dolist (item funList (nreverse0 tmp2)) + (setq op (first item)) + (setq sig (second item)) + (unless (eq op '=) (push (list 'signature op sig) tmp2))))))) + (list form catForm e)))) + +@ + +\defplist{category}{compCategory} +<>= +(eval-when (eval load) + (setf (get 'category 'special) '|compCategory|)) + +@ + +\defun{compCategory}{compCategory} +\calls{compCategory}{resolve} +\calls{compCategory}{qcar} +\calls{compCategory}{qcdr} +\calls{compCategory}{compCategoryItem} +\calls{compCategory}{mkExplicitCategoryFunction} +\calls{compCategory}{systemErrorHere} +<>= +(defun |compCategory| (x m e) + (let ($top_level |$sigList| |$atList| tmp1 domainOrPackage z rep) + (declare (special $top_level |$sigList| |$atList|)) + (setq $top_level t) + (cond + ((and + (equal (setq m (|resolve| m (list '|Category|))) (list '|Category|)) + (pairp x) + (eq (qcar x) 'category) + (pairp (qcdr x))) + (setq domainOrPackage (second x)) + (setq z (qcdr (qcdr x))) + (setq |$sigList| nil) + (setq |$atList| nil) + (setq |$sigList| nil) + (setq |$atList| nil) + (dolist (x z) (|compCategoryItem| x nil)) + (setq rep + (|mkExplicitCategoryFunction| domainOrPackage |$sigList| |$atList|)) + (list rep m e)) + (t + (|systemErrorHere| "compCategory"))))) + +@ + +\defplist{::}{compCoerce} +<>= +(eval-when (eval load) + (setf (get '|::| 'special) '|compCoerce|)) + +@ + +\defun{compCoerce}{compCoerce} +\calls{compCoerce}{addDomain} +\calls{compCoerce}{getmode} +\calls{compCoerce}{compCoerce1} +\calls{compCoerce}{coerce} +<>= +(defun |compCoerce| (arg m e) + (let (x mp tmp1 tmp4 z td) + (setq x (second arg)) + (setq mp (third arg)) + (setq e (|addDomain| mp e)) + (setq tmp1 (|getmode| mp e)) + (cond + ((setq td (|compCoerce1| x mp e)) + (|coerce| td m)) + ((and (pairp tmp1) (eq (qcar tmp1) '|Mapping|) + (pairp (qcdr tmp1)) (eq (qcdr (qcdr tmp1)) nil) + (pairp (qcar (qcdr tmp1))) + (eq (qcar (qcar (qcdr tmp1))) '|UnionCategory|)) + (setq z (qcdr (qcar (qcdr tmp1)))) + (when + (setq td + (dolist (z m1 tmp4) (setq tmp4 (or tmp4 (|compCoerce1| x m1 e))))) + (|coerce| (list (car td) mp (third td)) m)))))) + +@ + +\defun{compCoerce1}{compCoerce1} +\calls{compCoerce1}{comp} +\calls{compCoerce1}{resolve} +\calls{compCoerce1}{coerce} +\calls{compCoerce1}{coerceByModemap} +\calls{compCoerce1}{msubst} +\calls{compCoerce1}{mkq} +<>= +(defun |compCoerce1| (x mp e) + (let (m1 td tp gg pred code) + (declare (special |$String| |$EmptyMode|)) + (when (setq td (or (|comp| x mp e) (|comp| x |$EmptyMode| e))) + (setq m1 (if (stringp (second td)) |$String| (second td))) + (setq mp (|resolve| m1 mp)) + (setq td (list (car td) m1 (third td))) + (cond + ((setq tp (|coerce| td mp)) tp) + ((setq tp (|coerceByModemap| td mp)) tp) + ((setq pred (|isSubset| mp (second td) e)) + (setq gg (gensym)) + (setq pred (msubst gg '* pred)) + (setq code + (list 'prog1 + (list 'let gg (first td)) + (cons '|check-subtype| (cons pred (list (mkq mp) gg))))) + (list code mp (third td))))))) + +@ + \defplist{:}{compColon} <>= (eval-when (eval load) @@ -2907,6 +3178,329 @@ of the symbol being parsed. The original list read: @ +\defplist{cons}{compCons} +<>= +(eval-when (eval load) + (setf (get 'cons 'special) '|compCons|)) + +@ + +\defun{compCons}{compCons} +\calls{compCons}{compCons1} +\calls{compCons}{compForm} +<>= +(defun |compCons| (form m e) + (or (|compCons1| form m e) (|compForm| form m e))) + +@ + +\defun{compCons1}{compCons1} +\calls{compCons1}{comp} +\calls{compCons1}{convert} +\calls{compCons1}{pairp} +\calls{compCons1}{qcar} +\calls{compCons1}{qcdr} +\usesdollar{compCons1}{EmptyMode} +<>= +(defun |compCons1| (arg m e) + (let (mx y my yt mp mr ytp tmp1 x tmp2 td) + (declare (special |$EmptyMode|)) + (setq x (second arg)) + (setq y (third arg)) + (when (setq tmp1 (|comp| x |$EmptyMode| e)) + (setq x (first tmp1)) + (setq mx (second tmp1)) + (setq e (third tmp1)) + (cond + ((null y) + (|convert| (list (list 'list x) (list '|List| mx) e ) m)) + (t + (when (setq yt (|comp| y |$EmptyMode| e)) + (setq y (first yt)) + (setq my (second yt)) + (setq e (third yt)) + (setq td + (cond + ((and (pairp my) (eq (qcar my) '|List|) (pairp (qcdr my))) + (setq mp (second my)) + (when (setq mr (list '|List| (|resolve| mp mx))) + (when (setq ytp (|convert| yt mr)) + (when (setq tmp1 (|convert| (list x mx (third ytp)) (second mr))) + (setq x (first tmp1)) + (setq e (third tmp1)) + (cond + ((and (pairp (car ytp)) (eq (qcar (car ytp)) 'list)) + (list (cons 'list (cons x (cdr (car ytp)))) mr e)) + (t + (list (list 'cons x (car ytp)) mr e))))))) + (t + (list (list 'cons x y) (list '|Pair| mx my) e )))) + (|convert| td m))))))) + +@ + +\defplist{ListCategory}{compConstructorCategory} +<>= +(eval-when (eval load) + (setf (get '|ListCategory| 'special) '|compConstructorCategory|)) + +@ + +\defplist{RecordCategory}{compConstructorCategory} +<>= +(eval-when (eval load) + (setf (get '|RecordCategory| 'special) '|compConstructorCategory|)) + +@ + +\defplist{UnionCategory}{compConstructorCategory} +<>= +(eval-when (eval load) + (setf (get '|UnionCategory| 'special) '|compConstructorCategory|)) + +@ + +\defplist{VectorCategory}{compConstructorCategory} +<>= +(eval-when (eval load) + (setf (get '|VectorCategory| 'special) '|compConstructorCategory|)) + +@ + +\defun{compConstructorCategory}{compConstructorCategory} +\calls{compConstructorCategory}{resolve} +\usesdollar{compConstructorCategory}{Category} +<>= +(defun |compConstructorCategory| (x m e) + (declare (special |$Category|)) + (list x (|resolve| |$Category| m) e)) + +@ + +\defplist{construct}{compConstruct} +<>= +(eval-when (eval load) + (setf (get '|construct| 'special) '|compConstruct|)) + +@ + +\defun{compConstruct}{compConstruct} +\calls{compConstruct}{modeIsAggregateOf} +\calls{compConstruct}{compList} +\calls{compConstruct}{convert} +\calls{compConstruct}{compForm} +\calls{compConstruct}{compVector} +\calls{compConstruct}{getDomainsInScope} +<>= +(defun |compConstruct| (form m e) + (let (z y td tp) + (setq z (cdr form)) + (cond + ((setq y (|modeIsAggregateOf| '|List| m e)) + (if (setq td (|compList| z (list '|List| (cadr y)) e)) + (|convert| td m) + (|compForm| form m e))) + ((setq y (|modeIsAggregateOf| '|Vector| m e)) + (if (setq td (|compVector| z (list '|Vector| (cadr y)) e)) + (|convert| td m) + (|compForm| form m e))) + ((setq td (|compForm| form m e)) td) + (t + (dolist (d (|getDomainsInScope| e)) + (cond + ((and (setq y (|modeIsAggregateOf| '|List| D e)) + (setq td (|compList| z (list '|List| (cadr y)) e)) + (setq tp (|convert| td m))) + (return tp)) + ((and (setq y (|modeIsAggregateOf| '|Vector| D e)) + (setq td (|compVector| z (list '|Vector| (cadr y)) e)) + (setq tp (|convert| td m))) + (return tp)))))))) + +@ + +\defplist{def}{compDefine} +<>= +(eval-when (eval load) + (setf (get 'def 'special) '|compDefine|)) + +@ + +\defun{compDefine}{compDefine} +\calls{compDefine}{compDefine1} +\usesdollar{compDefine}{tripleCache} +\usesdollar{compDefine}{tripleHits} +\usesdollar{compDefine}{macroIfTrue} +\usesdollar{compDefine}{packagesUsed} +<>= +(defun |compDefine| (form m e) + (let (|$tripleCache| |$tripleHits| |$macroIfTrue| |$packagesUsed|) + (declare (special |$tripleCache| |$tripleHits| |$macroIfTrue| + |$packagesUsed|)) + (setq |$tripleCache| nil) + (setq |$tripleHits| 0) + (setq |$macroIfTrue| nil) + (setq |$packagesUsed| nil) + (|compDefine1| form m e))) + +@ + +\defun{compDefine1}{compDefine1} +\calls{compDefine1}{macroExpand} +\calls{compDefine1}{isMacro} +\calls{compDefine1}{getSignatureFromMode} +\calls{compDefine1}{compDefine1} +\calls{compDefine1}{compInternalFunction} +\calls{compDefine1}{compDefineAddSignature} +\calls{compDefine1}{compDefWhereClause} +\calls{compDefine1}{compDefineCategory} +\calls{compDefine1}{isDomainForm} +\calls{compDefine1}{getTargetFromRhs} +\calls{compDefine1}{giveFormalParametersValues} +\calls{compDefine1}{addEmptyCapsuleIfNecessary} +\calls{compDefine1}{compDefineFunctor} +\calls{compDefine1}{stackAndThrow} +\calls{compDefine1}{strconc} +\calls{compDefine1}{getAbbreviation} +\calls{compDefine1}{length} +\calls{compDefine1}{compDefineCapsuleFunction} +\usesdollar{compDefine1}{insideExpressionIfTrue} +\usesdollar{compDefine1}{formalArgList} +\usesdollar{compDefine1}{form} +\usesdollar{compDefine1}{op} +\usesdollar{compDefine1}{prefix} +\usesdollar{compDefine1}{insideFunctorIfTrue} +\usesdollar{compDefine1}{Category} +\usesdollar{compDefine1}{insideCategoryIfTrue} +\usesdollar{compDefine1}{insideCapsuleFunctionIfTrue} +\usesdollar{compDefine1}{ConstructorNames} +\usesdollar{compDefine1}{NoValueMode} +\usesdollar{compDefine1}{EmptyMode} +\usesdollar{compDefine1}{insideWhereIfTrue} +\usesdollar{compDefine1}{insideExpressionIfTrue} +<>= +(defun |compDefine1| (form m e) + (let (|$insideExpressionIfTrue| lhs specialCases sig signature rhs newPrefix + (tmp1 t)) + (declare (special |$insideExpressionIfTrue| |$formalArgList| |$form| + |$op| |$prefix| |$insideFunctorIfTrue| |$Category| + |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| + |$ConstructorNames| |$NoValueMode| |$EmptyMode| + |$insideWhereIfTrue| |$insideExpressionIfTrue|)) + (setq |$insideExpressionIfTrue| nil) + (setq form (|macroExpand| form e)) + (setq lhs (second form)) + (setq signature (third form)) + (setq specialCases (fourth form)) + (setq rhs (fifth form)) + (cond + ((and |$insideWhereIfTrue| + (|isMacro| form e) + (or (equal m |$EmptyMode|) (equal m |$NoValueMode|))) + (list lhs m (|put| (car lhs) '|macro| rhs e))) + ((and (null (car signature)) (consp rhs) + (null (member (qcar rhs) |$ConstructorNames|)) + (setq sig (|getSignatureFromMode| lhs e))) + (|compDefine1| + (list 'def lhs (cons (car sig) (cdr signature)) specialCases rhs) m e)) + (|$insideCapsuleFunctionIfTrue| (|compInternalFunction| form m e)) + (t + (when (equal (car signature) |$Category|) (setq |$insideCategoryIfTrue| t)) + (setq e (|compDefineAddSignature| lhs signature e)) + (cond + ((null (dolist (x (rest signature) tmp1) (setq tmp1 (and tmp1 (null x))))) + (|compDefWhereClause| form m e)) + ((equal (car signature) |$Category|) + (|compDefineCategory| form m e nil |$formalArgList|)) + ((and (|isDomainForm| rhs e) (null |$insideFunctorIfTrue|)) + (when (null (car signature)) + (setq signature + (cons (|getTargetFromRhs| lhs rhs + (|giveFormalParametersValues| (cdr lhs) e)) + (cdr signature)))) + (setq rhs (|addEmptyCapsuleIfNecessary| (car signature) rhs)) + (|compDefineFunctor| + (list 'def lhs signature specialCases rhs) m e NIL |$formalArgList|)) + ((null |$form|) + (|stackAndThrow| (list "bad == form " form))) + (t + (setq newPrefix + (if |$prefix| + (intern (strconc (|encodeItem| |$prefix|) "," (|encodeItem| |$op|))) + (|getAbbreviation| |$op| (|#| (cdr |$form|))))) + (|compDefineCapsuleFunction| form m e newPrefix |$formalArgList|))))))) + +@ + +\defplist{elt}{compElt} +<>= +(eval-when (eval load) + (setf (get '|elt| 'special) '|compElt|)) + +@ + +\defun{compElt}{compElt} +\calls{compElt}{compForm} +\calls{compElt}{isDomainForm} +\calls{compElt}{addDomain} +\calls{compElt}{getModemapListFromDomain} +\calls{compElt}{length} +\calls{compElt}{stackMessage} +\calls{compElt}{stackWarning} +\calls{compElt}{convert} +\calls{compElt}{opOf} +\calls{compElt}{getDeltaEntry} +\calls{compElt}{nequal} +\usesdollar{compElt}{One} +\usesdollar{compElt}{Zero} +<>= +(defun |compElt| (form m e) + (let (tmp1 aDomain tmp2 anOp mmList n modemap sig pred val) + (declare (special |$One| |$Zero|)) + (setq anOp (third form)) + (setq aDomain (second form)) + (cond + ((null (and (pairp form) (eq (qcar form) '|elt|) + (pairp (qcdr form)) (pairp (qcdr (qcdr form))) + (eq (qcdr (qcdr (qcdr form))) nil))) + (|compForm| form m e)) + ((eq aDomain '|Lisp|) + (list (cond + ((equal anOp |$Zero|) 0) + ((equal anOp |$One|) 1) + (t anOp)) + m e)) + ((|isDomainForm| aDomain e) + (setq e (|addDomain| aDomain e)) + (setq mmList (|getModemapListFromDomain| anOp 0 aDomain e)) + (setq modemap + (progn + (setq n (|#| mmList)) + (cond + ((eql 1 n) (elt mmList 0)) + ((eql 0 n) + (|stackMessage| + (list "Operation " '|%b| anOp '|%d| "missing from domain: " + aDomain nil)) + nil) + (t + (|stackWarning| + (list "more than 1 modemap for: " anOp " with dc=" + aDomain " ===>" mmList )) + (elt mmList 0))))) + (when modemap + (setq sig (first modemap)) + (setq pred (caadr modemap)) + (setq val (cadadr modemap)) + (unless (and (nequal (|#| sig) 2) + (null (and (pairp val) (eq (qcar val) '|elt|)))) + (setq val (|genDeltaEntry| (cons (|opOf| anOp) modemap))) + (|convert| (list (list '|call| val) (second sig) e) m)))) + (t + (|compForm| form m e))))) + +@ + \defplist{exit}{compExit} <>= (eval-when (eval load) @@ -2941,6 +3535,100 @@ of the symbol being parsed. The original list read: @ +\defplist{has}{compHas} +<>= +(eval-when (eval load) + (setf (get '|has| 'special) '|compHas|)) + +@ + +\defun{compHas}{compHas} +\calls{compHas}{chaseInferences} +\calls{compHas}{compHasFormat} +\calls{compHas}{coerce} +\usesdollar{compHas}{e} +<>= +(defun |compHas| (pred m |$e|) + (declare (special |$e|)) + (let (a b predCode) + (setq a (second pred)) + (setq b (third pred)) + (setq |$e| (|chaseInferences| pred |$e|)) + (setq predCode (|compHasFormat| pred)) + (|coerce| (list predCode |$Boolean| |$e|) m))) + +@ + +\defplist{if}{compIf} +<>= +(eval-when (eval load) + (setf (get 'if 'special) '|compIf|)) + +@ + +\defun{compIf}{compIf} +\calls{compIf}{canReturn} +\calls{compIf}{intersectionEnvironment} +\calls{compIf}{compBoolean} +\calls{compIf}{compFromIf} +\calls{compIf}{resolve} +\calls{compIf}{coerce} +\calls{compIf}{quotify} +\usesdollar{compIf}{Boolean} +<>= +(defun |compIf| (arg m e) + (labels ( + (env (bEnv cEnv b c e) + (cond + ((|canReturn| b 0 0 t) + (if (|canReturn| c 0 0 t) (|intersectionEnvironment| bEnv cEnv) bEnv)) + ((|canReturn| c 0 0 t) cEnv) + (t e)))) + (let (a b c tmp1 xa ma Ea Einv Tb xb mb Eb Tc xc mc Ec xbp x returnEnv) + (declare (special |$Boolean|)) + (setq a (second arg)) + (setq b (third arg)) + (setq c (fourth arg)) + (when (setq tmp1 (|compBoolean| a |$Boolean| e)) + (setq xa (first tmp1)) + (setq ma (second tmp1)) + (setq Ea (third tmp1)) + (setq Einv (fourth tmp1)) + (when (setq Tb (|compFromIf| b m Ea)) + (setq xb (first Tb)) + (setq mb (second Tb)) + (setq Eb (third Tb)) + (when (setq Tc (|compFromIf| c (|resolve| mb m) Einv)) + (setq xc (first Tc)) + (setq mc (second Tc)) + (setq Ec (third Tc)) + (when (setq xbp (|coerce| Tb mc)) + (setq x (list 'if xa (|quotify| (first xbp)) (|quotify| xc))) + (setq returnEnv (env (third xbp) Ec (first xbp) xc e)) + (list x mc returnEnv)))))))) + +@ + +\defplist{import}{compImport} +<>= +(eval-when (eval load) + (setf (get '|import| 'special) '|compImport|)) + +@ + +\defun{compImport}{compImport} +\calls{compImport}{addDomain} +<>= +(defun |compImport| (arg m e) + (declare (ignore m)) + (let (doms) + (declare (special |$NoValueMode|)) + (setq doms (first arg)) + (dolist (dom doms) (setq e (|addDomain| |dom| e))) + (list '|/throwAway| |$NoValueMode| e))) + +@ + \defplist{+->}{compLambda} <>= (eval-when (eval load) @@ -10249,13 +10937,31 @@ if \verb|$InteractiveMode| then use a null outputstream <> <> <> +<> +<> +<> +<> +<> +<> +<> +<> <> <> +<> +<> +<> +<> +<> +<> +<> <> <> <> <> <> +<> +<> +<> <> <> <> diff --git a/changelog b/changelog index ee4c1b1..3f6669f 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,9 @@ +20101125 tpd src/axiom-website/patches.html 20101125.01.tpd.patch +20101125 tpd src/interp/postprop.lisp treeshake compiler +20101125 tpd src/interp/modemap.lisp treeshake compiler +20101125 tpd src/interp/define.lisp treeshake compiler +20101125 tpd src/interp/compiler.lisp treeshake compiler +20101125 tpd books/bookvol9 treeshake compiler 20101121 tpd src/axiom-website/patches.html 20101121.02.tpd.patch 20101121 tpd src/interp/postprop.lisp treeshake compiler 20101121 tpd src/interp/define.lisp treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 4eed4b4..22efccc 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3268,7 +3268,9 @@ books/bookvol9 treeshake compiler
books/bookvolbib Chee Keng Yap [Yap00]
20101121.01.tpd.patch books/bookvol9 fix |special| bug
-20101121.02.tpd.patch +20101121.02.tpd.patch +books/bookvol9 treeshake compiler
+20101125.01.tpd.patch books/bookvol9 treeshake compiler
diff --git a/src/interp/compiler.lisp.pamphlet b/src/interp/compiler.lisp.pamphlet index 506a3eb..cc69775 100644 --- a/src/interp/compiler.lisp.pamphlet +++ b/src/interp/compiler.lisp.pamphlet @@ -855,15 +855,6 @@ @ \section{Special evaluation functions} -\subsection{compConstructorCategory} -<<*>>= -;compConstructorCategory(x,m,e) == [x,resolve($Category,m),e] - -(DEFUN |compConstructorCategory| (|x| |m| |e|) - (declare (special |$Category|)) - (CONS |x| (CONS (|resolve| |$Category| |m|) (CONS |e| NIL)))) - -@ \subsection{compString} <<*>>= ;compString(x,m,e) == [x,resolve($StringCategory,m),e] @@ -932,107 +923,7 @@ Compile SubsetCategory |m| |e|))))) @ -\subsection{compCons} -Compile cons -<<*>>= -;compCons(form,m,e) == compCons1(form,m,e) or compForm(form,m,e) - -(DEFUN |compCons| (|form| |m| |e|) - (OR (|compCons1| |form| |m| |e|) (|compForm| |form| |m| |e|))) - -@ -\subsection{compCons1} -<<*>>= -;compCons1(["CONS",x,y],m,e) == -; [x,mx,e]:= comp(x,$EmptyMode,e) or return nil -; null y => convert([["LIST",x],["List",mx],e],m) -; yt:= [y,my,e]:= comp(y,$EmptyMode,e) or return nil -; T:= -; my is ["List",m',:.] => -; mr:= ["List",resolve(m',mx) or return nil] -; yt':= convert(yt,mr) or return nil -; [x,.,e]:= convert([x,mx,yt'.env],CADR mr) or return nil -; yt'.expr is ["LIST",:.] => [["LIST",x,:rest yt'.expr],mr,e] -; [["CONS",x,yt'.expr],mr,e] -; [["CONS",x,y],["Pair",mx,my],e] -; convert(T,m) - -(DEFUN |compCons1| (G168075 |m| |e|) - (PROG (|mx| |y| |my| |yt| |m'| |mr| |yt'| |LETTMP#1| |x| |ISTMP#1| T$) - (declare (special |$EmptyMode|)) - (RETURN - (PROGN - (COND ((EQ (CAR G168075) 'CONS) (CAR G168075))) - (SPADLET |x| (CADR G168075)) - (SPADLET |y| (CADDR G168075)) - (SPADLET |LETTMP#1| - (OR (|comp| |x| |$EmptyMode| |e|) (RETURN NIL))) - (SPADLET |x| (CAR |LETTMP#1|)) - (SPADLET |mx| (CADR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (COND - ((NULL |y|) - (|convert| - (CONS (CONS 'LIST (CONS |x| NIL)) - (CONS (CONS '|List| (CONS |mx| NIL)) - (CONS |e| NIL))) - |m|)) - ('T - (SPADLET |yt| - (PROGN - (SPADLET |LETTMP#1| - (OR (|comp| |y| |$EmptyMode| |e|) - (RETURN NIL))) - (SPADLET |y| (CAR |LETTMP#1|)) - (SPADLET |my| (CADR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - |LETTMP#1|)) - (SPADLET T$ - (COND - ((AND (PAIRP |my|) (EQ (QCAR |my|) '|List|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |my|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |m'| (QCAR |ISTMP#1|)) - 'T)))) - (SPADLET |mr| - (CONS '|List| - (CONS - (OR (|resolve| |m'| |mx|) - (RETURN NIL)) - NIL))) - (SPADLET |yt'| - (OR (|convert| |yt| |mr|) (RETURN NIL))) - (SPADLET |LETTMP#1| - (OR (|convert| - (CONS |x| - (CONS |mx| - (CONS (CADDR |yt'|) NIL))) - (CADR |mr|)) - (RETURN NIL))) - (SPADLET |x| (CAR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (COND - ((PROGN - (SPADLET |ISTMP#1| (CAR |yt'|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) 'LIST))) - (CONS (CONS 'LIST - (CONS |x| (CDR (CAR |yt'|)))) - (CONS |mr| (CONS |e| NIL)))) - ('T - (CONS (CONS 'CONS - (CONS |x| (CONS (CAR |yt'|) NIL))) - (CONS |mr| (CONS |e| NIL)))))) - ('T - (CONS (CONS 'CONS (CONS |x| (CONS |y| NIL))) - (CONS (CONS '|Pair| - (CONS |mx| (CONS |my| NIL))) - (CONS |e| NIL)))))) - (|convert| T$ |m|))))))) -@ \subsection{compSetq} Compile setq <<*>>= @@ -1663,79 +1554,6 @@ Compile setelt NIL))))))))))))) @ -\subsection{compConstruct} -Compile construct -<<*>>= -;compConstruct(form is ["construct",:l],m,e) == -; y:= modeIsAggregateOf("List",m,e) => -; T:= compList(l,["List",CADR y],e) => convert(T,m) -; compForm(form,m,e) -; y:= modeIsAggregateOf("Vector",m,e) => -; T:= compVector(l,["Vector",CADR y],e) => convert(T,m) -; compForm(form,m,e) -; T:= compForm(form,m,e) => T -; for D in getDomainsInScope e repeat -; (y:=modeIsAggregateOf("List",D,e)) and -; (T:= compList(l,["List",CADR y],e)) and (T':= convert(T,m)) => -; return T' -; (y:=modeIsAggregateOf("Vector",D,e)) and -; (T:= compVector(l,["Vector",CADR y],e)) and (T':= convert(T,m)) => -; return T' - -(DEFUN |compConstruct| (|form| |m| |e|) - (PROG (|l| |y| T$ |T'|) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR |form|) '|construct|) (CAR |form|))) - (SPADLET |l| (CDR |form|)) - (COND - ((SPADLET |y| (|modeIsAggregateOf| '|List| |m| |e|)) - (COND - ((SPADLET T$ - (|compList| |l| - (CONS '|List| (CONS (CADR |y|) NIL)) - |e|)) - (|convert| T$ |m|)) - ('T (|compForm| |form| |m| |e|)))) - ((SPADLET |y| (|modeIsAggregateOf| '|Vector| |m| |e|)) - (COND - ((SPADLET T$ - (|compVector| |l| - (CONS '|Vector| (CONS (CADR |y|) NIL)) - |e|)) - (|convert| T$ |m|)) - ('T (|compForm| |form| |m| |e|)))) - ((SPADLET T$ (|compForm| |form| |m| |e|)) T$) - ('T - (DO ((G168638 (|getDomainsInScope| |e|) - (CDR G168638)) - (D NIL)) - ((OR (ATOM G168638) - (PROGN (SETQ D (CAR G168638)) NIL)) - NIL) - (SEQ (EXIT (COND - ((AND (SPADLET |y| - (|modeIsAggregateOf| '|List| D - |e|)) - (SPADLET T$ - (|compList| |l| - (CONS '|List| - (CONS (CADR |y|) NIL)) - |e|)) - (SPADLET |T'| (|convert| T$ |m|))) - (RETURN |T'|)) - ((AND (SPADLET |y| - (|modeIsAggregateOf| '|Vector| D - |e|)) - (SPADLET T$ - (|compVector| |l| - (CONS '|Vector| - (CONS (CADR |y|) NIL)) - |e|)) - (SPADLET |T'| (|convert| T$ |m|))) - (RETURN |T'|))))))))))))) - -@ \subsection{compQuote} Compile quote <<*>>= @@ -2042,129 +1860,6 @@ Compile return (CONS |m| (CONS |e'| NIL))))))))) @ -\subsection{compElt} -Compile Elt -<<*>>= -;compElt(form,m,E) == -; form isnt ["elt",aDomain,anOp] => compForm(form,m,E) -; aDomain="Lisp" => -; [anOp',m,E] where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp) -; isDomainForm(aDomain,E) => -; E:= addDomain(aDomain,E) -; mmList:= getModemapListFromDomain(anOp,0,aDomain,E) -; modemap:= -; n:=#mmList -; 1=n => mmList.(0) -; 0=n => -; return -; stackMessage ['"Operation ","%b",anOp,"%d", -; '"missing from domain: ", aDomain] -; stackWarning ['"more than 1 modemap for: ",anOp, -; '" with dc=",aDomain,'" ===>" -; ,mmList] -; mmList.(0) -; [sig,[pred,val]]:= modemap -; #sig^=2 and ^val is ["elt",:.] => nil --what does the second clause do ???? -;--+ -; val := genDeltaEntry [opOf anOp,:modemap] -; convert([["call",val],first rest sig,E], m) --implies fn calls used to access constants -; compForm(form,m,E) - -(DEFUN |compElt| (|form| |m| E) - (PROG (|ISTMP#1| |aDomain| |ISTMP#2| |anOp| |mmList| |n| |modemap| - |sig| |pred| |val|) - (declare (special |$One| |$Zero|)) - (RETURN - (COND - ((NULL (AND (PAIRP |form|) (EQ (QCAR |form|) '|elt|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |aDomain| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |anOp| (QCAR |ISTMP#2|)) - 'T))))))) - (|compForm| |form| |m| E)) - ((BOOT-EQUAL |aDomain| '|Lisp|) - (CONS (COND - ((BOOT-EQUAL |anOp| |$Zero|) 0) - ((BOOT-EQUAL |anOp| |$One|) 1) - ('T |anOp|)) - (CONS |m| (CONS E NIL)))) - ((|isDomainForm| |aDomain| E) - (SPADLET E (|addDomain| |aDomain| E)) - (SPADLET |mmList| - (|getModemapListFromDomain| |anOp| 0 |aDomain| E)) - (SPADLET |modemap| - (PROGN - (SPADLET |n| (|#| |mmList|)) - (COND - ((EQL 1 |n|) (ELT |mmList| 0)) - ((EQL 0 |n|) - (RETURN - (|stackMessage| - (CONS "Operation " - (CONS '|%b| - (CONS |anOp| - (CONS '|%d| - (CONS - "missing from domain: " - (CONS |aDomain| NIL))))))))) - ('T - (|stackWarning| - (CONS "more than 1 modemap for: " - (CONS |anOp| - (CONS " with dc=" - (CONS |aDomain| - (CONS " ===>" - (CONS |mmList| NIL))))))) - (ELT |mmList| 0))))) - (SPADLET |sig| (CAR |modemap|)) - (SPADLET |pred| (CAADR |modemap|)) - (SPADLET |val| (CADADR |modemap|)) - (COND - ((AND (NEQUAL (|#| |sig|) 2) - (NULL (AND (PAIRP |val|) (EQ (QCAR |val|) '|elt|)))) - NIL) - ('T - (SPADLET |val| - (|genDeltaEntry| (CONS (|opOf| |anOp|) |modemap|))) - (|convert| - (CONS (CONS '|call| (CONS |val| NIL)) - (CONS (CAR (CDR |sig|)) (CONS E NIL))) - |m|)))) - ('T (|compForm| |form| |m| E)))))) - -@ -\subsection{compHas} -Compile has -<<*>>= -;compHas(pred is ["has",a,b],m,$e) == -; --b is (":",:.) => (.,.,E):= comp(b,$EmptyMode,E) -; $e:= chaseInferences(pred,$e) -; --pred':= ("has",a',b') := formatHas(pred) -; predCode:= compHasFormat pred -; coerce([predCode,$Boolean,$e],m) - -(DEFUN |compHas| (|pred| |m| |$e|) - (DECLARE (SPECIAL |$e|)) - (PROG (|a| |b| |predCode|) - (RETURN - (PROGN - (COND ((EQ (CAR |pred|) '|has|) (CAR |pred|))) - (SPADLET |a| (CADR |pred|)) - (SPADLET |b| (CADDR |pred|)) - (SPADLET |$e| (|chaseInferences| |pred| |$e|)) - (SPADLET |predCode| (|compHasFormat| |pred|)) - (|coerce| (CONS |predCode| (CONS |$Boolean| (CONS |$e| NIL))) - |m|))))) - -; --used in various other places to make the discrimination -@ \subsection{compHasFormat} <<*>>= ;compHasFormat (pred is ["has",olda,b]) == @@ -2254,68 +1949,6 @@ Compile has (CONS |a| (CONS (|mkDomainConstructor| |b|) NIL)))))))))) @ -\subsection{compIf} -Compile if -<<*>>= -;compIf(["IF",a,b,c],m,E) == -; [xa,ma,Ea,Einv]:= compBoolean(a,$Boolean,E) or return nil -; [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil -; [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil -; xb':= coerce(Tb,mc) or return nil -; x:= ["IF",xa,quotify xb'.expr,quotify xc] -; (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where -; Env(bEnv,cEnv,b,c,E) == -; canReturn(b,0,0,true) => -; (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv) -; canReturn(c,0,0,true) => cEnv -; E -; [x,mc,returnEnv] - -(DEFUN |compIf,Env| (|bEnv| |cEnv| |b| |c| E) - (SEQ (IF (|canReturn| |b| 0 0 'T) - (EXIT (SEQ (IF (|canReturn| |c| 0 0 'T) - (EXIT (|intersectionEnvironment| |bEnv| - |cEnv|))) - (EXIT |bEnv|)))) - (IF (|canReturn| |c| 0 0 'T) (EXIT |cEnv|)) (EXIT E))) - -(DEFUN |compIf| (G169289 |m| E) - (PROG (|a| |b| |c| |LETTMP#1| |xa| |ma| |Ea| |Einv| |Tb| |xb| |mb| - |Eb| |Tc| |xc| |mc| |Ec| |xb'| |x| |returnEnv|) - (declare (special |$Boolean|)) - (RETURN - (PROGN - (COND ((EQ (CAR G169289) 'IF) (CAR G169289))) - (SPADLET |a| (CADR G169289)) - (SPADLET |b| (CADDR G169289)) - (SPADLET |c| (CADDDR G169289)) - (SPADLET |LETTMP#1| - (OR (|compBoolean| |a| |$Boolean| E) (RETURN NIL))) - (SPADLET |xa| (CAR |LETTMP#1|)) - (SPADLET |ma| (CADR |LETTMP#1|)) - (SPADLET |Ea| (CADDR |LETTMP#1|)) - (SPADLET |Einv| (CADDDR |LETTMP#1|)) - (SPADLET |Tb| (OR (|compFromIf| |b| |m| |Ea|) (RETURN NIL))) - (SPADLET |xb| (CAR |Tb|)) - (SPADLET |mb| (CADR |Tb|)) - (SPADLET |Eb| (CADDR |Tb|)) - (SPADLET |Tc| - (OR (|compFromIf| |c| (|resolve| |mb| |m|) |Einv|) - (RETURN NIL))) - (SPADLET |xc| (CAR |Tc|)) - (SPADLET |mc| (CADR |Tc|)) - (SPADLET |Ec| (CADDR |Tc|)) - (SPADLET |xb'| (OR (|coerce| |Tb| |mc|) (RETURN NIL))) - (SPADLET |x| - (CONS 'IF - (CONS |xa| - (CONS (|quotify| (CAR |xb'|)) - (CONS (|quotify| |xc|) NIL))))) - (SPADLET |returnEnv| - (|compIf,Env| (CADDR |xb'|) |Ec| (CAR |xb'|) |xc| E)) - (CONS |x| (CONS |mc| (CONS |returnEnv| NIL))))))) - -@ \subsection{canReturn} <<*>>= ;canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends @@ -2863,158 +2496,6 @@ Compile if (DEFUN |quotify| (|x|) |x|) @ -\subsection{compImport} -<<*>>= -;compImport(["import",:doms],m,e) == -; for dom in doms repeat e:=addDomain(dom,e) -; ["/throwAway",$NoValueMode,e] - -(DEFUN |compImport| (G169794 |m| |e|) - (declare (ignore |m|)) - (PROG (|doms|) - (declare (special |$NoValueMode|)) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR G169794) '|import|) (CAR G169794))) - (SPADLET |doms| (CDR G169794)) - (DO ((G169806 |doms| (CDR G169806)) (|dom| NIL)) - ((OR (ATOM G169806) - (PROGN (SETQ |dom| (CAR G169806)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |e| (|addDomain| |dom| |e|))))) - (CONS '|/throwAway| (CONS |$NoValueMode| (CONS |e| NIL)))))))) - -@ -\subsection{compCase} -Will the jerk who commented out these two functions please NOT do so -again. These functions ARE needed, and case can NOT be done by -modemap alone. The reason is that A case B requires to take A -evaluated, but B unevaluated. Therefore a special function is -required. You may have thought that you had tested this on ``failed'' -etc., but ``failed'' evaluates to it's own mode. Try it on x case \$ -next time. - -An angry JHD - August 15th., 1984 -<<*>>= -;compCase(["case",x,m'],m,e) == -; e:= addDomain(m',e) -; T:= compCase1(x,m',e) => coerce(T,m) -; nil - -(DEFUN |compCase| (G169818 |m| |e|) - (PROG (|x| |m'| T$) - (RETURN - (PROGN - (COND ((EQ (CAR G169818) '|case|) (CAR G169818))) - (SPADLET |x| (CADR G169818)) - (SPADLET |m'| (CADDR G169818)) - (SPADLET |e| (|addDomain| |m'| |e|)) - (COND - ((SPADLET T$ (|compCase1| |x| |m'| |e|)) (|coerce| T$ |m|)) - ('T NIL)))))) - -@ -\subsection{compCase1} -<<*>>= -;compCase1(x,m,e) == -; [x',m',e']:= comp(x,$EmptyMode,e) or return nil -; u:= -; [cexpr -; for (modemap:= [map,cexpr]) in getModemapList("case",2,e') | map is [.,.,s, -; t] and modeEqual(t,m) and modeEqual(s,m')] or return nil -; fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil -; [["call",fn,x'],$Boolean,e'] - -(DEFUN |compCase1| (|x| |m| |e|) - (PROG (|LETTMP#1| |x'| |m'| |e'| |map| |cexpr| |ISTMP#1| |ISTMP#2| - |s| |ISTMP#3| |t| |u| |cond| |selfn| |fn|) - (declare (special |$Boolean| |$EmptyMode|)) - (RETURN - (SEQ (PROGN - (SPADLET |LETTMP#1| - (OR (|comp| |x| |$EmptyMode| |e|) (RETURN NIL))) - (SPADLET |x'| (CAR |LETTMP#1|)) - (SPADLET |m'| (CADR |LETTMP#1|)) - (SPADLET |e'| (CADDR |LETTMP#1|)) - (SPADLET |u| - (OR (PROG (G169884) - (SPADLET G169884 NIL) - (RETURN - (DO ((G169891 - (|getModemapList| '|case| 2 |e'|) - (CDR G169891)) - (|modemap| NIL)) - ((OR (ATOM G169891) - (PROGN - (SETQ |modemap| (CAR G169891)) - NIL) - (PROGN - (PROGN - (SPADLET |map| (CAR |modemap|)) - (SPADLET |cexpr| - (CADR |modemap|)) - |modemap|) - NIL)) - (NREVERSE0 G169884)) - (SEQ (EXIT - (COND - ((AND (PAIRP |map|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |map|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |s| - (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) - NIL) - (PROGN - (SPADLET |t| - (QCAR |ISTMP#3|)) - 'T))))))) - (|modeEqual| |t| |m|) - (|modeEqual| |s| |m'|)) - (SETQ G169884 - (CONS |cexpr| G169884))))))))) - (RETURN NIL))) - (SPADLET |fn| - (OR (PROG (G169898) - (SPADLET G169898 NIL) - (RETURN - (DO ((G169906 NIL G169898) - (G169907 |u| (CDR G169907)) - (G169873 NIL)) - ((OR G169906 (ATOM G169907) - (PROGN - (SETQ G169873 (CAR G169907)) - NIL) - (PROGN - (PROGN - (SPADLET |cond| - (CAR G169873)) - (SPADLET |selfn| - (CADR G169873)) - G169873) - NIL)) - G169898) - (SEQ (EXIT - (COND - ((BOOT-EQUAL |cond| 'T) - (SETQ G169898 - (OR G169898 |selfn|))))))))) - (RETURN NIL))) - (CONS (CONS '|call| (CONS |fn| (CONS |x'| NIL))) - (CONS |$Boolean| (CONS |e'| NIL)))))))) - -@ \subsection{unknownTypeError} <<*>>= ;unknownTypeError name == @@ -3431,113 +2912,6 @@ of basic objects may not be the same. |m'|))))) @ -\subsection{compCoerce} -<<*>>= -;compCoerce(["::",x,m'],m,e) == -; e:= addDomain(m',e) -; T:= compCoerce1(x,m',e) => coerce(T,m) -; getmode(m',e) is ["Mapping",["UnionCategory",:l]] => -; T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil -; coerce([T.expr,m',T.env],m) - -(DEFUN |compCoerce| (G170439 |m| |e|) - (PROG (|x| |m'| |ISTMP#1| |ISTMP#2| |ISTMP#3| |l| T$) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR G170439) '|::|) (CAR G170439))) - (SPADLET |x| (CADR G170439)) - (SPADLET |m'| (CADDR G170439)) - (SPADLET |e| (|addDomain| |m'| |e|)) - (COND - ((SPADLET T$ (|compCoerce1| |x| |m'| |e|)) - (|coerce| T$ |m|)) - ((PROGN - (SPADLET |ISTMP#1| (|getmode| |m'| |e|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|Mapping|) - (PROGN - (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 (QCAR |ISTMP#3|) - '|UnionCategory|) - (PROGN - (SPADLET |l| (QCDR |ISTMP#3|)) - 'T))))))) - (SPADLET T$ - (OR (PROG (G170458) - (SPADLET G170458 NIL) - (RETURN - (DO ((G170464 NIL G170458) - (G170465 |l| (CDR G170465)) - (|m1| NIL)) - ((OR G170464 (ATOM G170465) - (PROGN - (SETQ |m1| (CAR G170465)) - NIL)) - G170458) - (SEQ - (EXIT - (SETQ G170458 - (OR G170458 - (|compCoerce1| |x| |m1| |e|)))))))) - (RETURN NIL))) - (|coerce| - (CONS (CAR T$) (CONS |m'| (CONS (CADDR T$) NIL))) - |m|)))))))) - -@ -\subsection{compCoerce1} -<<*>>= -;compCoerce1(x,m',e) == -; T:= comp(x,m',e) or comp(x,$EmptyMode,e) or return nil -; m1:= -; STRINGP T.mode => $String -; T.mode -; m':=resolve(m1,m') -; T:=[T.expr,m1,T.env] -; T':= coerce(T,m') => T' -; T':= coerceByModemap(T,m') => T' -; pred:=isSubset(m',T.mode,e) => -; gg:=GENSYM() -; pred:= substitute(gg,"*",pred) -; code:= ['PROG1,['LET,gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] -; [code,m',T.env] - -(DEFUN |compCoerce1| (|x| |m'| |e|) - (PROG (|m1| T$ |T'| |gg| |pred| |code|) - (declare (special |$String| |$EmptyMode|)) - (RETURN - (PROGN - (SPADLET T$ - (OR (|comp| |x| |m'| |e|) - (|comp| |x| |$EmptyMode| |e|) (RETURN NIL))) - (SPADLET |m1| - (COND ((STRINGP (CADR T$)) |$String|) ('T (CADR T$)))) - (SPADLET |m'| (|resolve| |m1| |m'|)) - (SPADLET T$ (CONS (CAR T$) (CONS |m1| (CONS (CADDR T$) NIL)))) - (COND - ((SPADLET |T'| (|coerce| T$ |m'|)) |T'|) - ((SPADLET |T'| (|coerceByModemap| T$ |m'|)) |T'|) - ((SPADLET |pred| (|isSubset| |m'| (CADR T$) |e|)) - (PROGN - (SPADLET |gg| (GENSYM)) - (SPADLET |pred| (MSUBST |gg| '* |pred|)) - (SPADLET |code| - (CONS 'PROG1 - (CONS (CONS 'LET - (CONS |gg| (CONS (CAR T$) NIL))) - (CONS (CONS '|check-subtype| - (CONS |pred| - (CONS (MKQ |m'|) - (CONS |gg| NIL)))) - NIL)))) - (CONS |code| (CONS |m'| (CONS (CADDR T$) NIL)))))))))) - -@ \subsection{coerceByModemap} <<*>>= ;coerceByModemap([x,m,e],m') == diff --git a/src/interp/define.lisp.pamphlet b/src/interp/define.lisp.pamphlet index f10229d..d8f72a0 100644 --- a/src/interp/define.lisp.pamphlet +++ b/src/interp/define.lisp.pamphlet @@ -14,173 +14,6 @@ ;--% FUNCTIONS WHICH MUNCH ON == STATEMENTS ; -;compDefine(form,m,e) == -; $tripleCache: local:= nil -; $tripleHits: local:= 0 -; $macroIfTrue: local := nil -; $packagesUsed: local := nil -; result:= compDefine1(form,m,e) -; result - -(DEFUN |compDefine| (|form| |m| |e|) - (PROG (|$tripleCache| |$tripleHits| |$macroIfTrue| |$packagesUsed| - |result|) - (DECLARE (SPECIAL |$tripleCache| |$tripleHits| |$macroIfTrue| - |$packagesUsed|)) - (RETURN - (PROGN - (SPADLET |$tripleCache| NIL) - (SPADLET |$tripleHits| 0) - (SPADLET |$macroIfTrue| NIL) - (SPADLET |$packagesUsed| NIL) - (SPADLET |result| (|compDefine1| |form| |m| |e|)) - |result|)))) - -;compDefine1(form,m,e) == -; $insideExpressionIfTrue: local:= false -; --1. decompose after macro-expanding form -; ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) -; $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) -; => [lhs,m,put(first lhs,'macro,rhs,e)] -; null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and -; (sig:= getSignatureFromMode(lhs,e)) => -; -- here signature of lhs is determined by a previous declaration -; compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) -; $insideCapsuleFunctionIfTrue => -; --stackAndThrow ["Internal functions unsupported:",form] -; compInternalFunction(form,m,e) -; if signature.target=$Category then $insideCategoryIfTrue:= true -;--?? following 3 lines seem bogus, BMT 6/23/93 -;--? if signature.target is ['Mapping,:map] then -;--? signature:= map -;--? form:= ['DEF,lhs,signature,specialCases,rhs] -; -;-- RDJ (11/83): when argument and return types are all declared, -;-- or arguments have types declared in the environment, -;-- and there is no existing modemap for this signature, add -;-- the modemap by a declaration, then strip off declarations and recurse -; e := compDefineAddSignature(lhs,signature,e) -;-- 2. if signature list for arguments is not empty, replace ('DEF,..) by -;-- ('where,('DEF,..),..) with an empty signature list; -;-- otherwise, fill in all NILs in the signature -; not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) -; signature.target=$Category => -; compDefineCategory(form,m,e,nil,$formalArgList) -; isDomainForm(rhs,e) and not $insideFunctorIfTrue => -; if null signature.target then signature:= -; [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: -; rest signature] -; rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) -; compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, -; $formalArgList) -; null $form => stackAndThrow ['"bad == form ",form] -; newPrefix:= -; $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) -; getAbbreviation($op,#rest $form) -; compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) - -(DEFUN |compDefine1| (|form| |m| |e|) - (PROG (|$insideExpressionIfTrue| |lhs| |specialCases| |sig| - |signature| |rhs| |newPrefix|) - (DECLARE (SPECIAL |$insideExpressionIfTrue| |$formalArgList| |$form| - |$op| |$prefix| |$insideFunctorIfTrue| |$Category| - |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| - |$ConstructorNames| |$NoValueMode| |$EmptyMode| - |$insideWhereIfTrue| |$insideExpressionIfTrue|)) - (RETURN - (SEQ (PROGN - (SPADLET |$insideExpressionIfTrue| NIL) - (SPADLET |form| (|macroExpand| |form| |e|)) - (SPADLET |lhs| (CADR |form|)) - (SPADLET |signature| (CADDR |form|)) - (SPADLET |specialCases| (CADDDR |form|)) - (SPADLET |rhs| (CAR (CDDDDR |form|))) - (COND - ((AND |$insideWhereIfTrue| (|isMacro| |form| |e|) - (OR (BOOT-EQUAL |m| |$EmptyMode|) - (BOOT-EQUAL |m| |$NoValueMode|))) - (CONS |lhs| - (CONS |m| - (CONS (|put| (CAR |lhs|) '|macro| |rhs| - |e|) - NIL)))) - ((AND (NULL (CAR |signature|)) - (NULL (member (KAR |rhs|) |$ConstructorNames|)) - (SPADLET |sig| (|getSignatureFromMode| |lhs| |e|))) - (|compDefine1| - (CONS 'DEF - (CONS |lhs| - (CONS (CONS (CAR |sig|) - (CDR |signature|)) - (CONS |specialCases| - (CONS |rhs| NIL))))) - |m| |e|)) - (|$insideCapsuleFunctionIfTrue| - (|compInternalFunction| |form| |m| |e|)) - ('T - (COND - ((BOOT-EQUAL (CAR |signature|) |$Category|) - (SPADLET |$insideCategoryIfTrue| 'T))) - (SPADLET |e| - (|compDefineAddSignature| |lhs| |signature| - |e|)) - (COND - ((NULL (PROG (G166088) - (SPADLET G166088 'T) - (RETURN - (DO ((G166094 NIL (NULL G166088)) - (G166095 (CDR |signature|) - (CDR G166095)) - (|x| NIL)) - ((OR G166094 (ATOM G166095) - (PROGN - (SETQ |x| (CAR G166095)) - NIL)) - G166088) - (SEQ (EXIT - (SETQ G166088 - (AND G166088 (NULL |x|))))))))) - (|compDefWhereClause| |form| |m| |e|)) - ((BOOT-EQUAL (CAR |signature|) |$Category|) - (|compDefineCategory| |form| |m| |e| NIL - |$formalArgList|)) - ((AND (|isDomainForm| |rhs| |e|) - (NULL |$insideFunctorIfTrue|)) - (COND - ((NULL (CAR |signature|)) - (SPADLET |signature| - (CONS (|getTargetFromRhs| |lhs| |rhs| - (|giveFormalParametersValues| - (CDR |lhs|) |e|)) - (CDR |signature|))))) - (SPADLET |rhs| - (|addEmptyCapsuleIfNecessary| - (CAR |signature|) |rhs|)) - (|compDefineFunctor| - (CONS 'DEF - (CONS |lhs| - (CONS |signature| - (CONS |specialCases| - (CONS |rhs| NIL))))) - |m| |e| NIL |$formalArgList|)) - ((NULL |$form|) - (|stackAndThrow| - (CONS "bad == form " - (CONS |form| NIL)))) - ('T - (SPADLET |newPrefix| - (COND - (|$prefix| - (INTERN (STRCONC - (|encodeItem| |$prefix|) - "," - (|encodeItem| |$op|)))) - ('T - (|getAbbreviation| |$op| - (|#| (CDR |$form|)))))) - (|compDefineCapsuleFunction| |form| |m| |e| - |newPrefix| |$formalArgList|)))))))))) - ;compDefineAddSignature([op,:argl],signature,e) == ; (sig:= hasFullSignature(argl,signature,e)) and ; not ASSOC(['$,:sig],LASSOC('modemap,getProplist(op,e))) => @@ -5035,26 +4868,6 @@ (CONS |i| (CONS |x| NIL))) G169701)))))))))))) -;compCapsule(['CAPSULE,:itemList],m,e) == -; $bootStrapMode = true => -; [bootStrapError($functorForm, _/EDITFILE),m,e] -; $insideExpressionIfTrue: local:= false -; compCapsuleInner(itemList,m,addDomain('_$,e)) - -(DEFUN |compCapsule| (G169718 |m| |e|) - (PROG (|$insideExpressionIfTrue| |itemList|) - (DECLARE (SPECIAL |$insideExpressionIfTrue| |$functorForm| /EDITFILE - |$bootStrapMode|)) - (RETURN - (PROGN - (SPADLET |itemList| (CDR G169718)) - (COND - ((BOOT-EQUAL |$bootStrapMode| 'T) - (CONS (|bootStrapError| |$functorForm| /EDITFILE) - (CONS |m| (CONS |e| NIL)))) - ('T (SPADLET |$insideExpressionIfTrue| NIL) - (|compCapsuleInner| |itemList| |m| (|addDomain| '$ |e|)))))))) - ;compSubDomain(["SubDomain",domainForm,predicate],m,e) == ; $addFormLhs: local:= domainForm ; $addForm: local := nil @@ -5162,46 +4975,6 @@ NIL)))) (CONS |domainForm| (CONS |m| (CONS |e| NIL))))))) -;compCapsuleInner(itemList,m,e) == -; e:= addInformation(m,e) -; --puts a new 'special' property of $Information -; data:= ["PROGN",:itemList] -; --RPLACd by compCapsuleItems and Friends -; e:= compCapsuleItems(itemList,nil,e) -; localParList:= $functorLocalParameters -; if $addForm then data:= ['add,$addForm,data] -; code:= -; $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data -; processFunctorOrPackage($form,$signature,data,localParList,m,e) -; [MKPF([:$getDomainCode,code],"PROGN"),m,e] - -(DEFUN |compCapsuleInner| (|itemList| |m| |e|) - (PROG (|localParList| |data| |code|) - (declare (special |$getDomainCode| |$signature| |$form| |$addForm| - |$insideCategoryPackageIfTrue| |$insideCategoryIfTrue| - |$functorLocalParameters|)) - (RETURN - (PROGN - (SPADLET |e| (|addInformation| |m| |e|)) - (SPADLET |data| (CONS 'PROGN |itemList|)) - (SPADLET |e| (|compCapsuleItems| |itemList| NIL |e|)) - (SPADLET |localParList| |$functorLocalParameters|) - (COND - (|$addForm| - (SPADLET |data| - (CONS '|add| - (CONS |$addForm| (CONS |data| NIL)))))) - (SPADLET |code| - (COND - ((AND |$insideCategoryIfTrue| - (NULL |$insideCategoryPackageIfTrue|)) - |data|) - ('T - (|processFunctorOrPackage| |$form| |$signature| - |data| |localParList| |m| |e|)))) - (CONS (MKPF (APPEND |$getDomainCode| (CONS |code| NIL)) 'PROGN) - (CONS |m| (CONS |e| NIL))))))) - ;--% PROCESS FUNCTOR CODE ; ;processFunctor(form,signature,data,localParList,e) == diff --git a/src/interp/modemap.lisp.pamphlet b/src/interp/modemap.lisp.pamphlet index a58ef71..3319575 100644 --- a/src/interp/modemap.lisp.pamphlet +++ b/src/interp/modemap.lisp.pamphlet @@ -987,70 +987,6 @@ NIL)) G166616)))))))))))) -;compCat(form is [functorName,:argl],m,e) == -; fn:= GET(functorName,"makeFunctionList") or return nil -; [funList,e]:= FUNCALL(fn,form,form,e) -; catForm:= -; ["Join",'(SetCategory),["CATEGORY","domain",: -; [["SIGNATURE",op,sig] for [op,sig,.] in funList | op^="="]]] -; --RDJ: for coercion purposes, it necessary to know it's a Set; I'm not -; --sure if it uses any of the other signatures(see extendsCategoryForm) -; [form,catForm,e] - -(DEFUN |compCat| (|form| |m| |e|) - (declare (ignore |m|)) - (PROG (|functorName| |argl| |fn| |LETTMP#1| |funList| |op| |sig| - |catForm|) - (RETURN - (SEQ (PROGN - (SPADLET |functorName| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (SPADLET |fn| - (OR (GETL |functorName| '|makeFunctionList|) - (RETURN NIL))) - (SPADLET |LETTMP#1| (FUNCALL |fn| |form| |form| |e|)) - (SPADLET |funList| (CAR |LETTMP#1|)) - (SPADLET |e| (CADR |LETTMP#1|)) - (SPADLET |catForm| - (CONS '|Join| - (CONS '(|SetCategory|) - (CONS (CONS 'CATEGORY - (CONS '|domain| - (PROG (G166672) - (SPADLET G166672 NIL) - (RETURN - (DO - ((G166679 |funList| - (CDR G166679)) - (G166646 NIL)) - ((OR (ATOM G166679) - (PROGN - (SETQ G166646 - (CAR G166679)) - NIL) - (PROGN - (PROGN - (SPADLET |op| - (CAR G166646)) - (SPADLET |sig| - (CADR G166646)) - G166646) - NIL)) - (NREVERSE0 G166672)) - (SEQ - (EXIT - (COND - ((NEQUAL |op| '=) - (SETQ G166672 - (CONS - (CONS 'SIGNATURE - (CONS |op| - (CONS |sig| - NIL))) - G166672))))))))))) - NIL)))) - (CONS |form| (CONS |catForm| (CONS |e| NIL)))))))) - ;addConstructorModemaps(name,form is [functorName,:.],e) == ; $InteractiveMode: local:= nil ; e:= putDomainsInScope(name,e) --frame diff --git a/src/interp/postprop.lisp.pamphlet b/src/interp/postprop.lisp.pamphlet index 73f4e26..64b8c8d 100644 --- a/src/interp/postprop.lisp.pamphlet +++ b/src/interp/postprop.lisp.pamphlet @@ -52,27 +52,27 @@ '( ; (|add| |compAdd|) ; (\@ |compAtSign|) - (CAPSULE |compCapsule|) - (|case| |compCase|) - (|Record| |compCat|) - (|Mapping| |compCat|) - (|Union| |compCat|) - (CATEGORY |compCategory|) - (\:\: |compCoerce|) +; (CAPSULE |compCapsule|) +; (|case| |compCase|) +; (|Record| |compCat|) +; (|Mapping| |compCat|) +; (|Union| |compCat|) +; (CATEGORY |compCategory|) +; (\:\: |compCoerce|) (COLLECTV |compCollectV|) ; (\: |compColon|) - (CONS |compCons|) - (|ListCategory| |compConstructorCategory|) - (|RecordCategory| |compConstructorCategory|) - (|UnionCategory| |compConstructorCategory|) - (|VectorCategory| |compConstructorCategory|) - (|construct| |compConstruct|) - (DEF |compDefine|) - (|elt| |compElt|) +; (CONS |compCons|) +; (|ListCategory| |compConstructorCategory|) +; (|RecordCategory| |compConstructorCategory|) +; (|UnionCategory| |compConstructorCategory|) +; (|VectorCategory| |compConstructorCategory|) +; (|construct| |compConstruct|) +; (DEF |compDefine|) +; (|elt| |compElt|) ; (|exit| |compExit|) - (|has| |compHas|) - (IF |compIf|) - (|import| |compImport|) +; (|has| |compHas|) +; (IF |compIf|) +; (|import| |compImport|) (|is| |compIs|) (|Join| |compJoin|) ; (|+->| |compLambda|)