diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 7eef84a..7cb8614 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -4149,9 +4149,11 @@ leave it alone." \calls{preparseReadLine}{storeblanks} \calls{preparseReadLine}{skip-to-endif} \calls{preparseReadLine}{preparseReadLine} +\refsdollar{preparseReadLine}{*eof*} \begin{chunk}{defun preparseReadLine} (defun preparseReadLine (x) (let (line ind tmp1) + (declare (special *eof*)) (setq tmp1 (preparseReadLine1)) (setq ind (car tmp1)) (setq line (cdr tmp1)) @@ -4277,10 +4279,11 @@ Symbolics read-line returns embedded newlines in a c-m-Y. \calls{read-a-line}{Line-New-Line} \calls{read-a-line}{read-a-line} \uses{read-a-line}{*eof*} +\uses{read-a-line}{File-Closed} \begin{chunk}{defun read-a-line} (defun read-a-line (&optional (stream t)) (let (cp) - (declare (special *eof*)) + (declare (special *eof* File-Closed)) (if (and Current-Fragment (> (length Current-Fragment) 0)) (let ((line (with-input-from-string (s Current-Fragment :index cp :start 0) @@ -4344,8 +4347,10 @@ The current input line. \defun{line-print}{line-print} \usesstruct{line-print}{line} +\refsdollar{line-print}{out-stream} \begin{chunk}{defun line-print} (defun line-print (line) + (declare (special out-stream)) (format out-stream "~&~5D> ~A~%" (Line-Number line) (Line-Buffer Line)) (format out-stream "~v@T^~%" (+ 7 (Line-Current-Index line)))) @@ -4414,8 +4419,10 @@ The current input line. \end{chunk} \defun{next-line}{next-line} +\refsdollar{next-line}{in-stream} \begin{chunk}{defun next-line} (defun next-line (&optional (in-stream t)) + (declare (special in-stream)) (funcall Line-Handler in-stream)) \end{chunk} @@ -4425,10 +4432,12 @@ The current input line. \calls{Advance-Char}{Line-Advance-Char} \calls{Advance-Char}{next-line} \calls{Advance-Char}{current-char} +\refsdollar{Advance-Char}{in-stream} \usesstruct{Advance-Char}{line} \begin{chunk}{defun Advance-Char} (defun Advance-Char () "Advances IN-STREAM, invoking Next Line if necessary." + (declare (special in-stream)) (loop (cond ((not (Line-At-End-P Current-Line)) @@ -4909,9 +4918,10 @@ of the symbol being parsed. The original list read: \calls{parseColon}{parseTran} \calls{parseColon}{parseType} \usesdollar{parseColon}{InteractiveMode} -\usesdollar{parseColon}{insideConstructIfTrue} +\refsdollar{parseColon}{insideConstructIfTrue} \begin{chunk}{defun parseColon} (defun |parseColon| (arg) + (declare (special |$insideConstructIfTrue|)) (cond ((and (pairp arg) (eq (qcdr arg) nil)) (list '|:| (|parseTran| (first arg)))) @@ -6421,30 +6431,37 @@ $\rightarrow$ \calls{compDefineCategory2}{constructor?} \calls{compDefineCategory2}{augLisplibModemapsFromCategory} \usesdollar{compDefineCategory2}{prefix} -\usesdollar{compDefineCategory2}{formalArgList} -\usesdollar{compDefineCategory2}{insideCategoryIfTrue} -\usesdollar{compDefineCategory2}{top-level} -\usesdollar{compDefineCategory2}{definition} -\usesdollar{compDefineCategory2}{form} -\usesdollar{compDefineCategory2}{op} -\usesdollar{compDefineCategory2}{extraParms} -\usesdollar{compDefineCategory2}{functionStats} -\usesdollar{compDefineCategory2}{functorStats} -\usesdollar{compDefineCategory2}{frontier} -\usesdollar{compDefineCategory2}{getDomainCode} -\usesdollar{compDefineCategory2}{addForm} -\usesdollar{compDefineCategory2}{lisplibAbbreviation} -\usesdollar{compDefineCategory2}{lisplibAncestors} -\usesdollar{compDefineCategory2}{lisplibCategory} -\usesdollar{compDefineCategory2}{FormalMapVariableList} -\usesdollar{compDefineCategory2}{lisplibParents} -\usesdollar{compDefineCategory2}{lisplibModemap} -\usesdollar{compDefineCategory2}{lisplibKind} -\usesdollar{compDefineCategory2}{lisplibForm} -\usesdollar{compDefineCategory2}{lisplib} -\usesdollar{compDefineCategory2}{domainShell} -\usesdollar{compDefineCategory2}{libFile} -\usesdollar{compDefineCategory2}{TriangleVariableList} +\refsdollar{compDefineCategory2}{formalArgList} +\refsdollar{compDefineCategory2}{definition} +\refsdollar{compDefineCategory2}{form} +\refsdollar{compDefineCategory2}{op} +\refsdollar{compDefineCategory2}{extraParms} +\refsdollar{compDefineCategory2}{lisplibCategory} +\refsdollar{compDefineCategory2}{FormalMapVariableList} +\refsdollar{compDefineCategory2}{libFile} +\refsdollar{compDefineCategory2}{TriangleVariableList} +\refsdollar{compDefineCategory2}{lisplib} +\defsdollar{compDefineCategory2}{formalArgList} +\defsdollar{compDefineCategory2}{insideCategoryIfTrue} +\defsdollar{compDefineCategory2}{top-level} +\defsdollar{compDefineCategory2}{definition} +\defsdollar{compDefineCategory2}{form} +\defsdollar{compDefineCategory2}{op} +\defsdollar{compDefineCategory2}{extraParms} +\defsdollar{compDefineCategory2}{functionStats} +\defsdollar{compDefineCategory2}{functorStats} +\defsdollar{compDefineCategory2}{frontier} +\defsdollar{compDefineCategory2}{getDomainCode} +\defsdollar{compDefineCategory2}{addForm} +\defsdollar{compDefineCategory2}{lisplibAbbreviation} +\defsdollar{compDefineCategory2}{functorForm} +\defsdollar{compDefineCategory2}{lisplibAncestors} +\defsdollar{compDefineCategory2}{lisplibCategory} +\defsdollar{compDefineCategory2}{lisplibParents} +\defsdollar{compDefineCategory2}{lisplibModemap} +\defsdollar{compDefineCategory2}{lisplibKind} +\defsdollar{compDefineCategory2}{lisplibForm} +\defsdollar{compDefineCategory2}{domainShell} \begin{chunk}{defun compDefineCategory2} (defun |compDefineCategory2| (form signature specialCases body mode env |$prefix| |$formalArgList|) @@ -6456,7 +6473,7 @@ $\rightarrow$ (declare (special |$insideCategoryIfTrue| $top_level |$definition| |$form| |$op| |$extraParms| |$functionStats| |$functorStats| |$frontier| |$getDomainCode| - |$addForm| |$lisplibAbbreviation| + |$addForm| |$lisplibAbbreviation| |$functorForm| |$lisplibAncestors| |$lisplibCategory| |$FormalMapVariableList| |$lisplibParents| |$lisplibModemap| |$lisplibKind| |$lisplibForm| @@ -8666,6 +8683,21 @@ where item has form \end{chunk} +\defun{unknownTypeError}{unknownTypeError} +\calls{unknownTypeError}{pairp} +\calls{unknownTypeError}{qcar} +\calls{unknownTypeError}{stackSemanticError} +\begin{chunk}{defun unknownTypeError} +(defun |unknownTypeError| (name) + (let (op) + (setq name + (if (and (pairp name) (setq op (qcar name))) + op + name)) + (|stackSemanticError| (list '|%b| name '|%d| '|is not a known type|) nil))) + +\end{chunk} + \defun{isFunctor}{isFunctor} \calls{isFunctor}{opOf} \calls{isFunctor}{identp} @@ -10312,10 +10344,12 @@ An angry JHD - August 15th., 1984 \calls{compHas}{chaseInferences} \calls{compHas}{compHasFormat} \calls{compHas}{coerce} -\usesdollar{compHas}{e} +\refsdollar{compHas}{e} +\defsdollar{compHas}{e} +\refsdollar{compHas}{Boolean} \begin{chunk}{defun compHas} (defun |compHas| (pred mode |$e|) - (declare (special |$e|)) + (declare (special |$e| |$Boolean|)) (let (a b predCode) (setq a (second pred)) (setq b (third pred)) @@ -10419,12 +10453,211 @@ An angry JHD - August 15th., 1984 (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 x (list 'if xa (first xbp) xc)) (setq returnEnv (environ (third xbp) Ec (first xbp) xc env)) (list x mc returnEnv)))))))) \end{chunk} +\defun{coerce}{coerce} +The function coerce is used by the old compiler for coercions. +The function coerceInteractive is used by the interpreter. +One should always call the correct function, since the representation +of basic objects may not be the same. +\calls{coerce}{keyedSystemError} +\calls{coerce}{rplac} +\calls{coerce}{msubst} +\calls{coerce}{coerceEasy} +\calls{coerce}{coerceSubset} +\calls{coerce}{coerceHard} +\calls{coerce}{isSomeDomainVariable} +\calls{coerce}{stackMessage} +\refsdollar{coerce}{InteractiveMode} +\refsdollar{coerce}{Rep} +\refsdollar{coerce}{fromCoerceable} +\begin{chunk}{defun coerce} +(defun |coerce| (tt mode) + (labels ( + (fn (x m1 m2) + (list '|Cannot coerce| '|%b| x '|%d| '|%l| '| of mode| '|%b| m1 + '|%d| '|%l| '| to mode| '|%b| m2 '|%d|))) + (let (tp) + (declare (special |$fromCoerceable$| |$Rep| |$InteractiveMode|)) + (if |$InteractiveMode| + (|keyedSystemError| 'S2GE0016 + (list "coerce" "function coerce called from the interpreter.")) + (progn + (|rplac| (cadr tt) (msubst '$ |$Rep| (cadr tt))) + (cond + ((setq tp (|coerceEasy| tt mode)) tp) + ((setq tp (|coerceSubset| tt mode)) tp) + ((setq tp (|coerceHard| tt mode)) tp) + ((or (eq (car tt) '|$fromCoerceable$|) (|isSomeDomainVariable| mode)) nil) + (t (|stackMessage| (fn (first tt) (second tt) mode))))))))) + +\end{chunk} + +\defun{coerceEasy}{coerceEasy} +\calls{coerceEasy}{modeEqualSubst} +\refsdollar{coerceEasy}{EmptyMode} +\refsdollar{coerceEasy}{Exit} +\refsdollar{coerceEasy}{NoValueMode} +\refsdollar{coerceEasy}{Void} +\begin{chunk}{defun coerceEasy} +(defun |coerceEasy| (tt m) + (declare (special |$EmptyMode| |$Exit| |$NoValueMode| |$Void|)) + (cond + ((equal m |$EmptyMode|) tt) + ((or (equal m |$NoValueMode|) (equal m |$Void|)) + (list (car tt) m (third tt))) + ((equal (second tt) m) tt) + ((equal (second tt) |$NoValueMode|) tt) + ((equal (second tt) |$Exit|) + (list + (list 'progn (car tt) (list '|userError| "Did not really exit.")) + m (third tt))) + ((or (equal (second tt) |$EmptyMode|) + (|modeEqualSubst| (second tt) m (third tt))) + (list (car tt) m (third tt))))) + +\end{chunk} + +\defun{coerceSubset}{coerceSubset} +\calls{coerceSubset}{isSubset} +\calls{coerceSubset}{lassoc} +\calls{coerceSubset}{get} +\calls{coerceSubset}{opOf} +\calls{coerceSubset}{eval} +\calls{coerceSubset}{msubst} +\calls{coerceSubset}{isSubset} +\calls{coerceSubset}{maxSuperType} +\begin{chunk}{defun coerceSubset} +(defun |coerceSubset| (arg1 mp) + (let (x m env tmp1 pred) + (setq x (first arg1)) + (setq m (second arg1)) + (setq env (third arg1)) + (cond + ((or (|isSubset| m mp env) (and (eq m '|Rep|) (eq mp '$))) + (list x mp env)) + ((and (pairp m) (eq (qcar m) '|SubDomain|) + (pairp (qcdr m)) (equal (qcar (qcdr m)) mp)) + (list x mp env)) + ((and (setq pred (lassoc (|opOf| mp) (|get| (|opOf| m) '|SubDomain| env))) + (integerp x) (|eval| (msubst x '|#1| pred))) + (list x mp env)) + ((and (setq pred (|isSubset| mp (|maxSuperType| m env) env)) + (integerp x) (|eval| (msubst x '* pred))) + (list x mp env)) + (t nil)))) + +\end{chunk} + +\defun{coerceHard}{coerceHard} +\calls{coerceHard}{modeEqual} +\calls{coerceHard}{get} +\calls{coerceHard}{getmode} +\calls{coerceHard}{isCategoryForm} +\calls{coerceHard}{extendsCategoryForm} +\calls{coerceHard}{coerceExtraHard} +\defsdollar{coerceHard}{e} +\refsdollar{coerceHard}{e} +\refsdollar{coerceHard}{String} +\refsdollar{coerceHard}{bootStrapMode} +\begin{chunk}{defun coerceHard} +(defun |coerceHard| (tt m) + (let (|$e| mp tmp1 mpp) + (declare (special |$e| |$String| |$bootStrapMode|)) + (setq |$e| (third tt)) + (setq mp (second tt)) + (cond + ((and (stringp mp) (|modeEqual| m |$String|)) + (list (car tt) m |$e|)) + ((or (|modeEqual| mp m) + (and (or (progn + (setq tmp1 (|get| mp '|value| |$e|)) + (and (pairp tmp1) + (progn (setq mpp (qcar tmp1)) t))) + (progn + (setq tmp1 (|getmode| mp |$e|)) + (and (pairp tmp1) + (eq (qcar tmp1) '|Mapping|) + (and (pairp (qcdr tmp1)) + (eq (qcdr (qcdr tmp1)) nil) + (progn (setq mpp (qcar (qcdr tmp1))) t))))) + (|modeEqual| mpp m)) + (and (or (progn + (setq tmp1 (|get| m '|value| |$e|)) + (and (pairp tmp1) + (progn (setq mpp (qcar tmp1)) t))) + (progn + (setq tmp1 (|getmode| m |$e|)) + (and (pairp tmp1) + (eq (qcar tmp1) '|Mapping|) + (and (pairp (qcdr tmp1)) + (eq (qcdr (qcdr tmp1)) nil) + (progn (setq mpp (qcar (qcdr tmp1))) t))))) + (|modeEqual| mpp mp))) + (list (car tt) m (third tt))) + ((and (stringp (car tt)) (equal (car tt) m)) + (list (car tt) m |$e|)) + ((|isCategoryForm| m |$e|) + (cond + ((eq |$bootStrapMode| t) + (list (car tt) m |$e|)) + ((|extendsCategoryForm| (car tt) (cadr tt) m) + (list (car tt) m |$e|)) + (t (|coerceExtraHard| tt m)))) + (t (|coerceExtraHard| tt m))))) + +\end{chunk} + +\defun{coerceExtraHard}{coerceExtraHard} +\calls{coerceExtraHard}{autoCoerceByModemap} +\calls{coerceExtraHard}{isUnionMode} +\calls{coerceExtraHard}{pairp} +\calls{coerceExtraHard}{qcar} +\calls{coerceExtraHard}{qcdr} +\calls{coerceExtraHard}{hasType} +\calls{coerceExtraHard}{member} +\calls{coerceExtraHard}{autoCoerceByModemap} +\calls{coerceExtraHard}{coerce} +\refsdollar{coerceExtraHard}{Expression} +\begin{chunk}{defun coerceExtraHard} +(defun |coerceExtraHard| (tt m) + (let (x mp e tmp1 z ta tp tpp) + (declare (special |$Expression|)) + (setq x (first tt)) + (setq mp (second tt)) + (setq e (third tt)) + (cond + ((setq tp (|autoCoerceByModemap| tt m)) tp) + ((and (progn + (setq tmp1 (|isUnionMode| mp e)) + (and (pairp tmp1) (eq (qcar tmp1) '|Union|) + (progn + (setq z (qcdr tmp1)) t))) + (setq ta (|hasType| x e)) + (|member| ta z) + (setq tp (|autoCoerceByModemap| tt ta)) + (setq tpp (|coerce| tp m))) + tpp) + ((and (pairp mp) (eq (qcar mp) '|Record|) (equal m |$Expression|)) + (list (list '|coerceRe2E| x (list 'elt (copy mp) 0)) m e)) + (t nil)))) + +\end{chunk} + +\defun{compFromIf}{compFromIf} +\calls{compFromIf}{comp} +\begin{chunk}{defun compFromIf} +(defun |compFromIf| (a m env) + (if (eq a '|noBranch|) + (list '|noBranch| m env) + (|comp| a m env))) + +\end{chunk} + \defun{canReturn}{canReturn} \calls{canReturn}{say} \calls{canReturn}{pairp} @@ -10456,7 +10689,7 @@ An angry JHD - August 15th., 1984 (or result (findThrow gs u level exitCount ValueFlag)))) result))))) - (let (op count gs) + (let (op gs) (cond ((atom expr) (and ValueFlag (equal level exitCount))) ((eq (setq op (car expr)) 'quote) (and ValueFlag (equal level exitCount))) @@ -10611,7 +10844,7 @@ An angry JHD - August 15th., 1984 \refsdollar{getInverseEnvironment}{EmptyEnvironment} \begin{chunk}{defun getInverseEnvironment} (defun |getInverseEnvironment| (a env) - (let (op argl x m tmp2 oldpred z tmp1 zz newpred) + (let (op argl x m oldpred tmp1 zz newpred) (declare (special |$EmptyEnvironment|)) (cond ((atom a) env) @@ -10626,76 +10859,63 @@ An angry JHD - August 15th., 1984 ((and (identp x) (|isDomainForm| m |$EmptyEnvironment|)) (|put| x '|specialCase| m env)) (t env))) - ((and (pairp a) (eq (qcar a) '|case|) - (PROGN - (setq tmp1 (QCDR a)) - (and (pairp tmp1) - (PROGN - (setq x (QCAR tmp1)) - (setq tmp2 (QCDR tmp1)) - (AND (PAIRP tmp2) - (EQ (QCDR tmp2) nil) - (PROGN (setq m (QCAR tmp2)) t))))) - (IDENTP x)) - (COND - ((AND (PROGN - (setq tmp1 (|get| x '|condition| env)) - (AND (PAIRP tmp1) (EQ (QCDR tmp1) nil) - (PROGN - (setq tmp2 (QCAR tmp1)) - (AND (PAIRP tmp2) - (EQ (QCAR tmp2) 'OR) - (PROGN (setq oldpred (QCDR tmp2)) t))))) - (|member| a oldpred)) - (|put| x '|condition| - (LIST (MKPF (|delete| a oldpred) 'OR)) - env)) + ((and (pairp a) (eq (qcar a) '|case|) (pairp (qcdr a)) + (pairp (qcdr (qcdr a))) (eq (qcdr (qcdr (qcdr a))) nil) + (identp (qcar (qcdr a)))) + (setq x (qcar (qcdr a))) + (setq m (qcar (qcdr (qcdr a)))) + (setq tmp1 (|get| x '|condition| env)) + (cond + ((and tmp1 (pairp tmp1) (eq (qcdr tmp1) nil) (pairp (qcar tmp1)) + (eq (qcar (qcar tmp1)) 'or) (|member| a (qcdr (qcar tmp1)))) + (setq oldpred (qcdr (qcar tmp1))) + (|put| x '|condition| (list (mkpf (|delete| a oldpred) 'or)) env)) (t (setq tmp1 (|getUnionMode| x env)) - (AND (PAIRP tmp1) - (EQ (QCAR tmp1) '|Union|) - (PROGN - (setq z (QCDR tmp1)) t)) - (setq zz (|delete| m z)) - (DO ((G169713 zz (CDR G169713)) (u nil)) - ((OR (ATOM G169713) - (PROGN (SETQ u (CAR G169713)) nil)) - nil) - (COND - ((AND (PAIRP u) - (EQ (QCAR u) '|:|) - (PROGN - (setq tmp1 (QCDR u)) - (AND (PAIRP tmp1) - (EQUAL (QCAR tmp1) m)))) - (setq zz (|delete| u zz))) - (t nil))) - (setq newpred - (MKPF (PROG (G169723) - (RETURN - (DO - ((G169728 zz - (CDR G169728)) - (mp nil)) - ((OR (ATOM G169728) - (PROGN - (SETQ mp (CAR G169728)) - nil)) - (NREVERSE0 G169723)) - (SETQ G169723 - (CONS - (CONS '|case| - (CONS x - (CONS mp nil))) - G169723))))) - 'OR)) - (|put| x '|condition| - (CONS newpred (|get| x '|condition| env)) - env)))) + (setq zz (|delete| m (qcdr tmp1))) + (loop for u in zz + when (and (pairp u) (eq (qcar u) '|:|) + (pairp (qcdr u)) (equal (qcar (qcdr u)) m)) + do (setq zz (|delete| u zz))) + (setq newpred + (mkpf (loop for mp in zz collect (list '|case| x mp)) 'or)) + (|put| x '|condition| + (cons newpred (|get| x '|condition| env)) env)))) (t env)))))) \end{chunk} +\defun{getUnionMode}{getUnionMode} +\calls{getUnionMode}{isUnionMode} +\calls{getUnionMode}{getmode} +\begin{chunk}{defun getUnionMode} +(defun |getUnionMode| (x env) + (let (m) + (setq m (when (atom x) (|getmode| x env))) + (when m (|isUnionMode| m env)))) + +\end{chunk} + +\defun{isUnionMode}{isUnionMode} +\calls{isUnionMode}{getmode} +\calls{isUnionMode}{get} +\begin{chunk}{defun isUnionMode} +(defun |isUnionMode| (m env) + (let (mp v tmp1) + (cond + ((and (pairp m) (eq (qcar m) '|Union|)) m) + ((progn + (setq tmp1 (setq mp (|getmode| m env))) + (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|))) + (second mp)) + ((setq v (|get| (if (eq m '$) '|Rep| m) '|value| env)) + (when (and (pairp (car v)) (eq (qcar (car v)) '|Union|)) (car v)))))) + +\end{chunk} + \defplist{import}{compImport plist} \begin{chunk}{postvars} (eval-when (eval load) @@ -11345,6 +11565,20 @@ An angry JHD - August 15th., 1984 \end{chunk} +\defun{convertOrCroak}{convertOrCroak} +\calls{convertOrCroak}{convert} +\calls{convertOrCroak}{userError} +\begin{chunk}{defun convertOrCroak} +(defun |convertOrCroak| (tt m) + (let (u) + (if (setq u (|convert| tt m)) + u + (|userError| + (list '|CANNOT CONVERT: | (first tt) '|%l| '| OF MODE: | (second tt) + '|%l| '| TO MODE: | m '|%l|))))) + +\end{chunk} + \defun{compSeqItem}{compSeqItem} \calls{compSeqItem}{comp} \calls{compSeqItem}{macroExpand} @@ -14014,11 +14248,11 @@ IteratorTail: ('repeat' ! / Iterator*) ; \calls{PARSE-SpecialCommand}{star} \calls{PARSE-SpecialCommand}{PARSE-PrimaryOrQM} \calls{PARSE-SpecialCommand}{PARSE-CommandTail} -\usesdollar{PARSE-SpecialCommand}{noParseCommands} -\usesdollar{PARSE-SpecialCommand}{tokenCommands} +\refsdollar{PARSE-SpecialCommand}{noParseCommands} +\refsdollar{PARSE-SpecialCommand}{tokenCommands} \begin{chunk}{defun PARSE-SpecialCommand} (defun |PARSE-SpecialCommand| () - (declare (special $noParseCommands $tokenCommands)) + (declare (special |$noParseCommands| |$tokenCommands|)) (or (and (match-advance-string "show") (bang fil_test (optional @@ -15310,9 +15544,10 @@ so there is a bit of indirection involved in the call. \calls{PARSE-FloatTok}{push-reduction} \calls{PARSE-FloatTok}{pop-stack-1} \calls{PARSE-FloatTok}{bfp-} -\usesdollar{PARSE-FloatTok}{boot} +\refsdollar{PARSE-FloatTok}{boot} \begin{chunk}{defun PARSE-FloatTok} (defun |PARSE-FloatTok| () + (declare (special $boot)) (and (parse-number) (push-reduction '|PARSE-FloatTok| (if $boot (pop-stack-1) (bfp- (pop-stack-1)))))) @@ -15471,8 +15706,10 @@ If it is successful, advance inputstream past X. \end{chunk} \defun{escape-keywords}{escape-keywords} +\refsdollar{escape-keywords}{keywords} \begin{chunk}{defun escape-keywords} (defun escape-keywords (pname id) + (declare (special keywords)) (if (member id keywords) (concatenate 'string "_" pname) pname)) @@ -15948,12 +16185,13 @@ Stack of results of reduced productions. \usesdollar{bumperrorcount}{spad-errors} \begin{chunk}{defun bumperrorcount} (defun bumperrorcount (kind) + (declare (special |$InteractiveMode| $spad_errors)) (unless |$InteractiveMode| (let ((index (case kind (|syntax| 0) (|precompilation| 1) (|semantic| 2) - (t (error "BUMPERRORCOUNT"))))) + (t (error (break "BUMPERRORCOUNT: kind=~s~%" kind)))))) (setelt $spad_errors index (1+ (elt $spad_errors index)))))) \end{chunk} @@ -17367,12 +17605,18 @@ And the {\bf s-process} function which returns a parsed version of the input. \usesdollar{spad}{InteractiveFrame} \usesdollar{spad}{InitialDomainsInScope} \usesdollar{spad}{InteractiveMode} +\usesdollar{spad}{spad} +\usesdollar{spad}{boot} +\uses{spad}{curoutstream} +\uses{spad}{*fileactq-apply*} \uses{spad}{line} +\uses{spad}{optionlist} \uses{spad}{echo-meta} \uses{spad}{/editfile} \uses{spad}{*comp370-apply*} \uses{spad}{*eof*} \uses{spad}{file-closed} +\uses{spad}{boot-line-stack} \catches{spad}{spad-reader} \begin{chunk}{defun spad} (defun spad (&optional (*spad-input-file* nil) (*spad-output-file* nil) @@ -17381,9 +17625,10 @@ And the {\bf s-process} function which returns a parsed version of the input. ($spad t) ($boot nil) (optionlist nil) (*eof* nil) (file-closed nil) (/editfile *spad-input-file*) (|$noSubsumption| |$noSubsumption|) in-stream out-stream) - (declare (special echo-meta /editfile *comp370-apply* *eof* + (declare (special echo-meta /editfile *comp370-apply* *eof* curoutstream file-closed |$noSubsumption| |$InteractiveFrame| - |$InteractiveMode| |$InitialDomainsInScope|)) + |$InteractiveMode| |$InitialDomainsInScope| optionlist + boot-line-stack *fileactq-apply* $spad $boot)) ;; only rebind |$InteractiveFrame| if compiling (progv (if (not |$InteractiveMode|) '(|$InteractiveFrame|)) (if (not |$InteractiveMode|) @@ -17473,6 +17718,10 @@ And the {\bf s-process} function which returns a parsed version of the input. \usesdollar{s-process}{previousTime} \usesdollar{s-process}{LocalFrame} \usesdollar{s-process}{Translation} +\usesdollar{s-process}{TranslateOnly} +\usesdollar{s-process}{PrintOnly} +\usesdollar{s-process}{currentLine} +\usesdollar{s-process}{InteractiveFrame} \uses{s-process}{curoutstream} \begin{chunk}{defun s-process} (defun s-process (x) @@ -17511,7 +17760,8 @@ And the {\bf s-process} function which returns a parsed version of the input. |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| |$DomainFrame| |$e| |$EmptyEnvironment| |$genFVar| |$genSDVar| |$VariableCount| |$previousTime| |$LocalFrame| - curstrm |$s| |$x| |$m| curoutstream $traceflag |$Translation|)) + curstrm |$s| |$x| |$m| curoutstream $traceflag |$Translation| + |$TranslateOnly| |$PrintOnly| |$currentLine| |$InteractiveFrame|)) (setq $traceflag t) (if (not x) (return nil)) (if $boot @@ -19259,6 +19509,7 @@ symbol in the free list are represented by the alist (symbol . count) (let* ((bfile (make-pathname :type *lisp-bin-filetype* :defaults lfile)) (bdate (and (probe-file bfile) (file-write-date bfile))) (ldate (and (probe-file lfile) (file-write-date lfile)))) + (declare (special *lisp-bin-filetype*)) (unless (and ldate bdate (> bdate ldate)) (compile-lib-file lfile) (list bfile)))) @@ -19373,6 +19624,11 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun char-eq} \getchunk{defun char-ne} \getchunk{defun checkWarning} +\getchunk{defun coerce} +\getchunk{defun coerceEasy} +\getchunk{defun coerceExtraHard} +\getchunk{defun coerceHard} +\getchunk{defun coerceSubset} \getchunk{defun comma2Tuple} \getchunk{defun comp} \getchunk{defun comp2} @@ -19416,6 +19672,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun compForm3} \getchunk{defun compFormMatch} \getchunk{defun compFormPartiallyBottomUp} +\getchunk{defun compFromIf} \getchunk{defun compFunctorBody} \getchunk{defun compHas} \getchunk{defun compHasFormat} @@ -19469,6 +19726,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun containsBang} \getchunk{defun convert} \getchunk{defun convertOpAlist2compilerInfo} +\getchunk{defun convertOrCroak} \getchunk{defun current-char} \getchunk{defun current-symbol} \getchunk{defun current-token} @@ -19518,6 +19776,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun getTargetFromRhs} \getchunk{defun get-token} \getchunk{defun getToken} +\getchunk{defun getUnionMode} \getchunk{defun getUniqueModemap} \getchunk{defun getUniqueSignature} \getchunk{defun genDomainOps} @@ -19548,6 +19807,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun isListConstructor} \getchunk{defun isSuperDomain} \getchunk{defun isTokenDelimiter} +\getchunk{defun isUnionMode} \getchunk{defun killColons} @@ -19842,6 +20102,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun underscore} \getchunk{defun unget-tokens} +\getchunk{defun unknownTypeError} \getchunk{defun unTuple} \getchunk{defun updateCategoryFrameForCategory} \getchunk{defun updateCategoryFrameForConstructor} diff --git a/changelog b/changelog index b7c733e..a67189b 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20110814 tpd src/axiom-website/patches.html 20110814.01.tpd.patch +20110814 tpd src/interp/compiler.lisp treeshake compiler +20110814 tpd books/bookvol9 treeshake compiler 20110813 tpd src/axiom-website/patches.html 20110813.01.tpd.patch 20110813 tpd src/input/Makefile respect the BUILD=fast variable value 20110812 tpd src/axiom-website/patches.html 20110812.02.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 356f027..33401e5 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3586,5 +3586,7 @@ src/input/ffieldbug.input added
books/bookvol9 treeshake compiler
20110813.01.tpd.patch src/input/Makefile respect the BUILD=fast variable value
+20110814.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/compiler.lisp.pamphlet b/src/interp/compiler.lisp.pamphlet index 4c54370..4aa5794 100644 --- a/src/interp/compiler.lisp.pamphlet +++ b/src/interp/compiler.lisp.pamphlet @@ -31,30 +31,6 @@ \end{chunk} -\subsection{convertOrCroak} -\begin{chunk}{*} -;convertOrCroak(T,m) == -; u:= convert(T,m) => u -; userError ["CANNOT CONVERT: ",T.expr,"%l"," OF MODE: ",T.mode,"%l", -; " TO MODE: ",m,"%l"] - -(DEFUN |convertOrCroak| (T$ |m|) - (PROG (|u|) - (RETURN - (COND - ((SPADLET |u| (|convert| T$ |m|)) |u|) - ('T - (|userError| - (CONS '|CANNOT CONVERT: | - (CONS (CAR T$) - (CONS '|%l| - (CONS '| OF MODE: | - (CONS (CADR T$) - (CONS '|%l| - (CONS '| TO MODE: | - (CONS |m| (CONS '|%l| NIL))))))))))))))) - -\end{chunk} \subsection{mkUnion} \begin{chunk}{*} ;mkUnion(a,b) == @@ -332,365 +308,7 @@ \end{chunk} -\subsection{getUnionMode} -\begin{chunk}{*} -;getUnionMode(x,e) == -; m:= -; atom x => getmode(x,e) -; return nil -; isUnionMode(m,e) - -(DEFUN |getUnionMode| (|x| |e|) - (PROG (|m|) - (RETURN - (PROGN - (SPADLET |m| - (COND - ((ATOM |x|) (|getmode| |x| |e|)) - ('T (RETURN NIL)))) - (|isUnionMode| |m| |e|))))) - -\end{chunk} -\subsection{isUnionMode} -\begin{chunk}{*} -;isUnionMode(m,e) == -; m is ["Union",:.] => m -; (m':= getmode(m,e)) is ["Mapping",["UnionCategory",:.]] => CADR m' -; v:= get(if m="$" then "Rep" else m,"value",e) => -; (v.expr is ["Union",:.] => v.expr; nil) -; nil - -(DEFUN |isUnionMode| (|m| |e|) - (PROG (|m'| |ISTMP#2| |ISTMP#3| |v| |ISTMP#1|) - (RETURN - (COND - ((AND (PAIRP |m|) (EQ (QCAR |m|) '|Union|)) |m|) - ((PROGN - (SPADLET |ISTMP#1| (SPADLET |m'| (|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|))))))) - (CADR |m'|)) - ((SPADLET |v| - (|get| (COND ((BOOT-EQUAL |m| '$) '|Rep|) ('T |m|)) - '|value| |e|)) - (COND - ((PROGN - (SPADLET |ISTMP#1| (CAR |v|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|Union|))) - (CAR |v|)) - ('T NIL))) - ('T NIL))))) - -\end{chunk} -\subsection{compFromIf} -\begin{chunk}{*} -;compFromIf(a,m,E) == -; a="noBranch" => ["noBranch",m,E] -; true => comp(a,m,E) - -(DEFUN |compFromIf| (|a| |m| E) - (COND - ((BOOT-EQUAL |a| '|noBranch|) - (CONS '|noBranch| (CONS |m| (CONS E NIL)))) - ('T (|comp| |a| |m| E)))) - -\end{chunk} -\subsection{quotify} -\begin{chunk}{*} -;quotify x == x - -(DEFUN |quotify| (|x|) |x|) - -\end{chunk} -\subsection{unknownTypeError} -\begin{chunk}{*} -;unknownTypeError name == -; name:= -; name is [op,:.] => op -; name -; stackSemanticError(["%b",name,"%d","is not a known type"],nil) - -(DEFUN |unknownTypeError| (|name|) - (PROG (|op|) - (RETURN - (PROGN - (SPADLET |name| - (COND - ((AND (PAIRP |name|) - (PROGN (SPADLET |op| (QCAR |name|)) 'T)) - |op|) - ('T |name|))) - (|stackSemanticError| - (CONS '|%b| - (CONS |name| - (CONS '|%d| (CONS '|is not a known type| NIL)))) - NIL))))) - -\end{chunk} \section{Functions for coercion by the compiler} -\subsection{coerce} -The function coerce is used by the old compiler for coercions. -The function coerceInteractive is used by the interpreter. -One should always call the correct function, since the representation -of basic objects may not be the same. -\begin{chunk}{*} -;coerce(T,m) == -; $InteractiveMode => -; keyedSystemError("S2GE0016",['"coerce", -; '"function coerce called from the interpreter."]) -; rplac(CADR T,substitute("$",$Rep,CADR T)) -; T':= coerceEasy(T,m) => T' -; T':= coerceSubset(T,m) => T' -; T':= coerceHard(T,m) => T' -; T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil -; stackMessage fn(T.expr,T.mode,m) where -; -- if from from coerceable, this coerce was just a trial coercion -; -- from compFormWithModemap to filter through the modemaps -; fn(x,m1,m2) == -; ["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l", -; " to mode","%b",m2,"%d"] - -(DEFUN |coerce,fn| (|x| |m1| |m2|) - (CONS '|Cannot coerce| - (CONS '|%b| - (CONS |x| - (CONS '|%d| - (CONS '|%l| - (CONS '| of mode| - (CONS '|%b| - (CONS |m1| - (CONS '|%d| - (CONS '|%l| - (CONS '| to mode| - (CONS '|%b| - (CONS |m2| - (CONS '|%d| NIL))))))))))))))) - - -(DEFUN |coerce| (T$ |m|) - (PROG (|T'|) - (declare (special |$fromCoerceable$| |$Rep| |$InteractiveMode|)) - (RETURN - (COND - (|$InteractiveMode| - (|keyedSystemError| 'S2GE0016 - (CONS "coerce" - (CONS "function coerce called from the interpreter." - NIL)))) - ('T (|rplac| (CADR T$) (MSUBST '$ |$Rep| (CADR T$))) - (COND - ((SPADLET |T'| (|coerceEasy| T$ |m|)) |T'|) - ((SPADLET |T'| (|coerceSubset| T$ |m|)) |T'|) - ((SPADLET |T'| (|coerceHard| T$ |m|)) |T'|) - ((OR (BOOT-EQUAL (CAR T$) '|$fromCoerceable$|) - (|isSomeDomainVariable| |m|)) - NIL) - ('T (|stackMessage| (|coerce,fn| (CAR T$) (CADR T$) |m|))))))))) - -\end{chunk} -\subsection{coerceEasy} -\begin{chunk}{*} -;coerceEasy(T,m) == -; m=$EmptyMode => T -; m=$NoValueMode or m=$Void => [T.expr,m,T.env] -; T.mode =m => T -; T.mode =$NoValueMode => T -; T.mode =$Exit => -; [["PROGN", T.expr, ["userError", '"Did not really exit."]], -; m,T.env] -; T.mode=$EmptyMode or modeEqualSubst(T.mode,m,T.env) => -; [T.expr,m,T.env] - -(DEFUN |coerceEasy| (T$ |m|) - (declare (special |$EmptyMode| |$Exit| |$NoValueMode| |$Void|)) - (COND - ((BOOT-EQUAL |m| |$EmptyMode|) T$) - ((OR (BOOT-EQUAL |m| |$NoValueMode|) (BOOT-EQUAL |m| |$Void|)) - (CONS (CAR T$) (CONS |m| (CONS (CADDR T$) NIL)))) - ((BOOT-EQUAL (CADR T$) |m|) T$) - ((BOOT-EQUAL (CADR T$) |$NoValueMode|) T$) - ((BOOT-EQUAL (CADR T$) |$Exit|) - (CONS (CONS 'PROGN - (CONS (CAR T$) - (CONS (CONS '|userError| - (CONS - "Did not really exit." - NIL)) - NIL))) - (CONS |m| (CONS (CADDR T$) NIL)))) - ((OR (BOOT-EQUAL (CADR T$) |$EmptyMode|) - (|modeEqualSubst| (CADR T$) |m| (CADDR T$))) - (CONS (CAR T$) (CONS |m| (CONS (CADDR T$) NIL)))))) - -\end{chunk} -\subsection{coerceSubset} -\begin{chunk}{*} -;coerceSubset([x,m,e],m') == -; isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e] -; m is ['SubDomain,=m',:.] => [x,m',e] -; (pred:= LASSOC(opOf m',get(opOf m,'SubDomain,e))) and INTEGERP x and -; -- obviously this is temporary -; eval substitute(x,"#1",pred) => [x,m',e] -; (pred:= isSubset(m',maxSuperType(m,e),e)) and INTEGERP x -- again temporary -; and eval substitute(x,"*",pred) => -; [x,m',e] -; nil - -(DEFUN |coerceSubset| (G170274 |m'|) - (PROG (|x| |m| |e| |ISTMP#1| |pred|) - (RETURN - (PROGN - (SPADLET |x| (CAR G170274)) - (SPADLET |m| (CADR G170274)) - (SPADLET |e| (CADDR G170274)) - (COND - ((OR (|isSubset| |m| |m'| |e|) - (AND (BOOT-EQUAL |m| '|Rep|) (BOOT-EQUAL |m'| '$))) - (CONS |x| (CONS |m'| (CONS |e| NIL)))) - ((AND (PAIRP |m|) (EQ (QCAR |m|) '|SubDomain|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |m|)) - (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |m'|)))) - (CONS |x| (CONS |m'| (CONS |e| NIL)))) - ((AND (SPADLET |pred| - (LASSOC (|opOf| |m'|) - (|get| (|opOf| |m|) '|SubDomain| |e|))) - (INTEGERP |x|) (|eval| (MSUBST |x| '|#1| |pred|))) - (CONS |x| (CONS |m'| (CONS |e| NIL)))) - ((AND (SPADLET |pred| - (|isSubset| |m'| (|maxSuperType| |m| |e|) |e|)) - (INTEGERP |x|) (|eval| (MSUBST |x| '* |pred|))) - (CONS |x| (CONS |m'| (CONS |e| NIL)))) - ('T NIL)))))) - -\end{chunk} -\subsection{coerceHard} -\begin{chunk}{*} -;coerceHard(T,m) == -; $e: local:= T.env -; m':= T.mode -; STRINGP m' and modeEqual(m,$String) => [T.expr,m,$e] -; modeEqual(m',m) or -; (get(m',"value",$e) is [m'',:.] or getmode(m',$e) is ["Mapping",m'']) and -; modeEqual(m'',m) or -; (get(m,"value",$e) is [m'',:.] or getmode(m,$e) is ["Mapping",m'']) and -; modeEqual(m'',m') => [T.expr,m,T.env] -; STRINGP T.expr and T.expr=m => [T.expr,m,$e] -; isCategoryForm(m,$e) => -; $bootStrapMode = true => [T.expr,m,$e] -; extendsCategoryForm(T.expr,T.mode,m) => [T.expr,m,$e] -; coerceExtraHard(T,m) -; coerceExtraHard(T,m) - -(DEFUN |coerceHard| (T$ |m|) - (PROG (|$e| |m'| |ISTMP#1| |ISTMP#2| |m''|) - (DECLARE (SPECIAL |$e| |$String| |$bootStrapMode|)) - (RETURN - (PROGN - (SPADLET |$e| (CADDR T$)) - (SPADLET |m'| (CADR T$)) - (COND - ((AND (STRINGP |m'|) (|modeEqual| |m| |$String|)) - (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) - ((OR (|modeEqual| |m'| |m|) - (AND (OR (PROGN - (SPADLET |ISTMP#1| - (|get| |m'| '|value| |$e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |m''| (QCAR |ISTMP#1|)) - 'T))) - (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 |m''| - (QCAR |ISTMP#2|)) - 'T)))))) - (|modeEqual| |m''| |m|)) - (AND (OR (PROGN - (SPADLET |ISTMP#1| (|get| |m| '|value| |$e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |m''| (QCAR |ISTMP#1|)) - 'T))) - (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 |m''| - (QCAR |ISTMP#2|)) - 'T)))))) - (|modeEqual| |m''| |m'|))) - (CONS (CAR T$) (CONS |m| (CONS (CADDR T$) NIL)))) - ((AND (STRINGP (CAR T$)) (BOOT-EQUAL (CAR T$) |m|)) - (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) - ((|isCategoryForm| |m| |$e|) - (COND - ((BOOT-EQUAL |$bootStrapMode| 'T) - (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) - ((|extendsCategoryForm| (CAR T$) (CADR T$) |m|) - (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) - ('T (|coerceExtraHard| T$ |m|)))) - ('T (|coerceExtraHard| T$ |m|))))))) - -\end{chunk} -\subsection{coerceExtraHard} -\begin{chunk}{*} -;coerceExtraHard(T is [x,m',e],m) == -; T':= autoCoerceByModemap(T,m) => T' -; isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and -; MEMBER(t,l) and (T':= autoCoerceByModemap(T,t)) and -; (T'':= coerce(T',m)) => T'' -; m' is ['Record,:.] and m = $Expression => -; [['coerceRe2E,x,['ELT,COPY m',0]],m,e] -; nil - -(DEFUN |coerceExtraHard| (T$ |m|) - (PROG (|x| |m'| |e| |ISTMP#1| |l| |t| |T'| |T''|) - (declare (special |$Expression|)) - (RETURN - (PROGN - (SPADLET |x| (CAR T$)) - (SPADLET |m'| (CADR T$)) - (SPADLET |e| (CADDR T$)) - (COND - ((SPADLET |T'| (|autoCoerceByModemap| T$ |m|)) |T'|) - ((AND (PROGN - (SPADLET |ISTMP#1| (|isUnionMode| |m'| |e|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|Union|) - (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T))) - (SPADLET |t| (|hasType| |x| |e|)) (|member| |t| |l|) - (SPADLET |T'| (|autoCoerceByModemap| T$ |t|)) - (SPADLET |T''| (|coerce| |T'| |m|))) - |T''|) - ((AND (PAIRP |m'|) (EQ (QCAR |m'|) '|Record|) - (BOOT-EQUAL |m| |$Expression|)) - (CONS (CONS '|coerceRe2E| - (CONS |x| - (CONS (CONS 'ELT - (CONS (COPY |m'|) (CONS 0 NIL))) - NIL))) - (CONS |m| (CONS |e| NIL)))) - ('T NIL)))))) - -\end{chunk} \subsection{coerceable} \begin{chunk}{*} ;coerceable(m,m',e) ==