diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 7cb8614..bf39800 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -5997,6 +5997,26 @@ of the symbol being parsed. The original list read: \end{chunk} \chapter{Compile Transformers} + +\defdollar{NoValueMode} +\begin{chunk}{initvars} +(defvar |$NoValueMode| '|NoValueMode|) + +\end{chunk} + +\defdollar{EmptyMode} +\verb|$EmptyMode| is a contant whose value is \verb|$EmptyMode|. +It is used by isPartialMode to +decide if a modemap is partially constructed. If the \verb|$EmptyMode| +constant occurs anywhere in the modemap structure at any depth +then the modemap is still incomplete. To find this constant the +isPartialMode function calls CONTAINED \verb|$EmptyMode| $Y$ +which will walk the structure $Y$ looking for this constant. +\begin{chunk}{initvars} +(defvar |$EmptyMode| '|EmptyMode|) + +\end{chunk} + \section{Routines for handling forms} The functions in this section are called through the symbol-plist of the symbol being parsed. @@ -9497,25 +9517,6 @@ in the body of the add. \end{chunk} -\defplist{@}{compAtSign plist} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get '|@| 'special) 'compAtSign)) - -\end{chunk} - -\defun{compAtSign}{compAtSign} -\calls{compAtSign}{addDomain} -\calls{compAtSign}{comp} -\calls{compAtSign}{coerce} -\begin{chunk}{defun compAtSign} -(defun compAtSign (form mode env) - (let ((newform (second form)) (mprime (third form)) tmp) - (setq env (|addDomain| mprime env)) - (when (setq tmp (|comp| newform mprime env)) (|coerce| tmp mode)))) - -\end{chunk} - \defplist{capsule}{compCapsule plist} \begin{chunk}{postvars} (eval-when (eval load) @@ -9726,70 +9727,6 @@ An angry JHD - August 15th., 1984 \end{chunk} -\defplist{::}{compCoerce plist} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get '|::| 'special) '|compCoerce|)) - -\end{chunk} - -\defun{compCoerce}{compCoerce} -\calls{compCoerce}{addDomain} -\calls{compCoerce}{getmode} -\calls{compCoerce}{compCoerce1} -\calls{compCoerce}{coerce} -\begin{chunk}{defun compCoerce} -(defun |compCoerce| (form mode env) - (let (newform newmode tmp1 tmp4 z td) - (setq newform (second form)) - (setq newmode (third form)) - (setq env (|addDomain| newmode env)) - (setq tmp1 (|getmode| newmode env)) - (cond - ((setq td (|compCoerce1| newform newmode env)) - (|coerce| td mode)) - ((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 (mode1 z tmp4) - (setq tmp4 (or tmp4 (|compCoerce1| newform mode1 env))))) - (|coerce| (list (car td) newmode (third td)) mode)))))) - -\end{chunk} - -\defun{compCoerce1}{compCoerce1} -\calls{compCoerce1}{comp} -\calls{compCoerce1}{resolve} -\calls{compCoerce1}{coerce} -\calls{compCoerce1}{coerceByModemap} -\calls{compCoerce1}{msubst} -\calls{compCoerce1}{mkq} -\begin{chunk}{defun compCoerce1} -(defun |compCoerce1| (form mode env) - (let (m1 td tp gg pred code) - (declare (special |$String| |$EmptyMode|)) - (when (setq td (or (|comp| form mode env) (|comp| form |$EmptyMode| env))) - (setq m1 (if (stringp (second td)) |$String| (second td))) - (setq mode (|resolve| m1 mode)) - (setq td (list (car td) m1 (third td))) - (cond - ((setq tp (|coerce| td mode)) tp) - ((setq tp (|coerceByModemap| td mode)) tp) - ((setq pred (|isSubset| mode (second td) env)) - (setq gg (gensym)) - (setq pred (msubst gg '* pred)) - (setq code - (list 'prog1 - (list 'let gg (first td)) - (cons '|check-subtype| (cons pred (list (mkq mode) gg))))) - (list code mode (third td))))))) - -\end{chunk} - \defplist{:}{compColon plist} \begin{chunk}{postvars} (eval-when (eval load) @@ -10459,195 +10396,6 @@ An angry JHD - August 15th., 1984 \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} @@ -11941,57 +11689,6 @@ of basic objects may not be the same. \end{chunk} -;(defun |outputComp| (x env) -; (let (u tmp1 v argl tmp2) -; (declare (special |$Expression|)) -; (cond -; ((setq u (|comp| (list '|::| x |$Expression|) |$Expression| env)) -; u) -; ((and (pairp x) (eq (qcar x) '|construct|)) -; (setq argl (qcdr x)) -; (list (cons 'list -; (prog (result) -; (return -; (do ((tmp1 argl (cdr tmp1)) (x nil)) -; ((or (atom tmp1)) (nreverse0 result)) -; (setq x (car tmp1)) -; (setq result -; (cons -; (car -; (progn -; (setq tmp2 (|outputComp| x env)) -; (setq env (third tmp2)) -; tmp2)) -; result)))))) -; |$Expression| env)) -; ((and (setq v (|get| x '|value| env)) -; (pairp (cadr v)) (eq (qcar (cadr v)) '|Union|)) -; (list (list '|coerceUn2E| x (cadr v)) |$Expression| env)) -; (t (list x |$Expression| env))))) - -;(defun |outputComp| (x env) -; (let (tmp1 v result) -; (declare (special |$Expression|)) -; (cond -; ((|comp| (list '|::| x |$Expression|) |$Expression| env)) -; ((and (pairp x) (eq (qcar x) '|construct|)) -; (list -; (cons 'list -; (dolist (y (rest x) (nreverse0 result)) -; (push (car (progn -; (setq tmp1 (|outputComp| y env)) -; (setq env (third tmp1)) -; tmp1)) -; result)) -; |$Expression| env))) -; ((and (setq v (|get| x '|value| env)) -; (pairp (second v)) (eq (qcar (second v)) '|Union|)) -; (list (list '|coerceUn2E| x (second v)) |$Expression| env)) -; (t -; (list x |$Expression| env))))) - -\end{chunk} - \defun{maxSuperType}{maxSuperType} \calls{maxSuperType}{get} \calls{maxSuperType}{maxSuperType} @@ -12285,6 +11982,545 @@ of basic objects may not be the same. \end{chunk} +\section{Functions for coercion} +\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 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{hasType}{hasType} +\calls{hasType}{get} +\begin{chunk}{defun hasType} +(defun |hasType| (x e) + (labels ( + (fn (x) + (cond + ((null x) nil) + ((and (pairp x) (pairp (qcar x)) (eq (qcar (qcar x)) '|case|) + (pairp (qcdr (qcar x))) (pairp (qcdr (qcdr (qcar x)))) + (eq (qcdr (qcdr (qcdr (qcar x)))) nil)) + (qcar (qcdr (qcdr (qcar x))))) + (t (fn (cdr x)))))) + (fn (|get| x '|condition| e)))) + +\end{chunk} + +\defun{coerceable}{coerceable} +\calls{coerceable}{pmatch} +\calls{coerceable}{sublis} +\calls{coerceable}{coerce} +\refsdollar{coerceable}{fromCoerceable} +\begin{chunk}{defun coerceable} +(defun |coerceable| (m mp env) + (let (sl) + (declare (special |$fromCoerceable$|)) + (cond + ((equal m mp) m) + ((setq sl (|pmatch| mp m)) (sublis sl mp)) + ((|coerce| (list '|$fromCoerceable$| m env) mp) mp) + (t nil)))) + +\end{chunk} + +\defun{coerceExit}{coerceExit} +\calls{coerceExit}{resolve} +\calls{coerceExit}{replaceExitEsc} +\calls{coerceExit}{coerce} +\refsdollar{coerceExit}{exitMode} +\begin{chunk}{defun coerceExit} +(defun |coerceExit| (arg1 mp) + (let (x m e catchTag xp) + (declare (special |$exitMode|)) + (setq x (first arg1)) + (setq m (second arg1)) + (setq e (third arg1)) + (setq mp (|resolve| m mp)) + (setq xp + (|replaceExitEtc| x + (setq catchTag (mkq (gensym))) '|TAGGEDexit| |$exitMode|)) + (|coerce| (list (list 'catch catchTag xp) m e) mp))) + +\end{chunk} + +\defplist{@}{compAtSign plist} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '|@| 'special) 'compAtSign)) + +\end{chunk} + +\defun{compAtSign}{compAtSign} +\calls{compAtSign}{addDomain} +\calls{compAtSign}{comp} +\calls{compAtSign}{coerce} +\begin{chunk}{defun compAtSign} +(defun compAtSign (form mode env) + (let ((newform (second form)) (mprime (third form)) tmp) + (setq env (|addDomain| mprime env)) + (when (setq tmp (|comp| newform mprime env)) (|coerce| tmp mode)))) + +\end{chunk} + +\defplist{::}{compCoerce plist} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '|::| 'special) '|compCoerce|)) + +\end{chunk} + +\defun{compCoerce}{compCoerce} +\calls{compCoerce}{addDomain} +\calls{compCoerce}{getmode} +\calls{compCoerce}{compCoerce1} +\calls{compCoerce}{coerce} +\begin{chunk}{defun compCoerce} +(defun |compCoerce| (form mode env) + (let (newform newmode tmp1 tmp4 z td) + (setq newform (second form)) + (setq newmode (third form)) + (setq env (|addDomain| newmode env)) + (setq tmp1 (|getmode| newmode env)) + (cond + ((setq td (|compCoerce1| newform newmode env)) + (|coerce| td mode)) + ((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 (mode1 z tmp4) + (setq tmp4 (or tmp4 (|compCoerce1| newform mode1 env))))) + (|coerce| (list (car td) newmode (third td)) mode)))))) + +\end{chunk} + +\defun{compCoerce1}{compCoerce1} +\calls{compCoerce1}{comp} +\calls{compCoerce1}{resolve} +\calls{compCoerce1}{coerce} +\calls{compCoerce1}{coerceByModemap} +\calls{compCoerce1}{msubst} +\calls{compCoerce1}{mkq} +\begin{chunk}{defun compCoerce1} +(defun |compCoerce1| (form mode env) + (let (m1 td tp gg pred code) + (declare (special |$String| |$EmptyMode|)) + (when (setq td (or (|comp| form mode env) (|comp| form |$EmptyMode| env))) + (setq m1 (if (stringp (second td)) |$String| (second td))) + (setq mode (|resolve| m1 mode)) + (setq td (list (car td) m1 (third td))) + (cond + ((setq tp (|coerce| td mode)) tp) + ((setq tp (|coerceByModemap| td mode)) tp) + ((setq pred (|isSubset| mode (second td) env)) + (setq gg (gensym)) + (setq pred (msubst gg '* pred)) + (setq code + (list 'prog1 + (list 'let gg (first td)) + (cons '|check-subtype| (cons pred (list (mkq mode) gg))))) + (list code mode (third td))))))) + +\end{chunk} + +\defun{coerceByModemap}{coerceByModemap} +\calls{coerceByModemap}{pairp} +\calls{coerceByModemap}{qcar} +\calls{coerceByModemap}{qcdr} +\calls{coerceByModemap}{modeEqual} +\calls{coerceByModemap}{isSubset} +\calls{coerceByModemap}{genDeltaEntry} +\begin{chunk}{defun coerceByModemap} +(defun |coerceByModemap| (arg1 mp) + (let (x m env map cexpr u mm fn) + (setq x (first arg1)) + (setq m (second arg1)) + (setq env (third arg1)) + (setq u + (loop for modemap in (|getModemapList| '|coerce| 1 env) + do + (setq map (first modemap)) + (setq cexpr (second modemap)) + when + (and (pairp map) (pairp (qcdr map)) + (pairp (qcdr (qcdr map))) + (eq (qcdr (qcdr (qcdr map))) nil) + (or (|modeEqual| (second map) mp) (|isSubset| (second map) mp env)) + (or (|modeEqual| (third map) m) (|isSubset| m (third map) env))) + collect modemap)) + (when u + (setq mm (first u)) + (setq fn (|genDeltaEntry| (cons '|coerce| mm))) + (list (list '|call| fn x) mp env)))) + +\end{chunk} + +\defun{autoCoerceByModemap}{autoCoerceByModemap} +\calls{autoCoerceByModemap}{pairp} +\calls{autoCoerceByModemap}{qcar} +\calls{autoCoerceByModemap}{qcdr} +\calls{autoCoerceByModemap}{getModemapList} +\calls{autoCoerceByModemap}{modeEqual} +\calls{autoCoerceByModemap}{member} +\calls{autoCoerceByModemap}{get} +\calls{autoCoerceByModemap}{stackMessage} +\refsdollar{autoCoerceByModemap}{fromCoerceable} +\begin{chunk}{defun autoCoerceByModemap} +(defun |autoCoerceByModemap| (arg1 target) + (let (x source e map cexpr u fn y) + (declare (special |$fromCoerceable$|)) + (setq x (first arg1)) + (setq source (second arg1)) + (setq e (third arg1)) + (setq u + (loop for modemap in (|getModemapList| '|autoCoerce| 1 e) + do + (setq map (first modemap)) + (setq cexpr (second modemap)) + when + (and (pairp map) (pairp (qcdr map)) (pairp (qcdr (qcdr map))) + (eq (qcdr (qcdr (qcdr map))) nil) + (|modeEqual| (second map) target) + (|modeEqual| (third map) source)) + collect cexpr)) + (when u + (setq fn + (let (result) + (loop for item in u + do + (when (first item) (setq result (or result (second item))))) + result)) + (when fn + (cond + ((and (pairp source) (eq (qcar source) '|Union|) + (|member| target (qcdr source))) + (cond + ((and (setq y (|get| x '|condition| e)) + (let (result) + (loop for u in y do + (setq result + (or result + (and (pairp u) (eq (qcar u) '|case|) (pairp (qcdr u)) + (pairp (qcdr (qcdr u))) + (eq (qcdr (qcdr (qcdr u))) nil) + (equal (qcar (qcdr (qcdr u))) target))))) + result)) + (list (list '|call| fn x) target e)) + ((eq x '|$fromCoerceable$|) nil) + (t + (|stackMessage| + (list '|cannot coerce: | x '|%l| '| of mode: | source + '|%l| '| to: | target '| without a case statement|))))) + (t + (list (list '|call| fn x) target e))))))) + +\end{chunk} + +\defun{resolve}{resolve} +\calls{resolve}{nequal} +\calls{resolve}{modeEqual} +\calls{resolve}{mkUnion} +\refsdollar{resolve}{String} +\refsdollar{resolve}{EmptyMode} +\refsdollar{resolve}{NoValueMode} +\begin{chunk}{defun resolve} +(defun |resolve| (din dout) + (declare (special |$String| |$EmptyMode| |$NoValueMode|)) + (cond + ((or (equal din |$NoValueMode|) (equal dout |$NoValueMode|)) |$NoValueMode|) + ((equal dout |$EmptyMode|) din) + ((and (nequal din dout) (or (stringp din) (stringp dout))) + (cond + ((|modeEqual| dout |$String|) dout) + ((|modeEqual| din |$String|) nil) + (t (|mkUnion| din dout)))) + (t dout))) + +\end{chunk} + +\defun{mkUnion}{mkUnion} +\calls{mkUnion}{pairp} +\calls{mkUnion}{qcar} +\calls{mkUnion}{qcdr} +\calls{mkUnion}{union} +\refsdollar{mkUnion}{Rep} +\begin{chunk}{defun mkUnion} +(defun |mkUnion| (a b) + (declare (special |$Rep|)) + (cond + ((and (eq b '$) (pairp |$Rep|) (eq (qcar |$Rep|) '|Union|)) + (qcdr |$Rep|)) + ((and (pairp a) (eq (qcar a) '|Union|)) + (cond + ((and (pairp b) (eq (qcar b) '|Union|)) + (cons '|Union| (|union| (qcdr a) (qcdr b)))) + (t (cons '|Union| (|union| (list b) (qcdr a)))))) + ((and (pairp b) (eq (qcar b) '|Union|)) + (cons '|Union| (|union| (list a) (qcdr b)))) + (t (list '|Union| a b)))) + +\end{chunk} + +\defun{modeEqual}{This orders Unions} +This orders Unions +\begin{chunk}{defun modeEqual} +(defun |modeEqual| (x y) + (let (xl yl) + (cond + ((or (atom x) (atom y)) (equal x y)) + ((nequal (|#| x) (|#| y)) nil) + ((and (pairp x) (eq (qcar x) '|Union|) (pairp y) (eq (qcar y) '|Union|)) + (setq xl (qcdr x)) + (setq yl (qcdr y)) + (loop for a in xl do + (loop for b in yl do + (when (|modeEqual| a b) + (setq xl (|delete| a xl)) + (setq yl (|delete| b yl)) + (return nil)))) + (unless (or xl yl) t)) + (t + (let ((result t)) + (loop for u in x for v in y + do (setq result (and result (|modeEqual| u v)))) + result))))) + +\end{chunk} + +\defun{modeEqualSubst}{modeEqualSubst} +\calls{modeEqualSubst}{modeEqual} +\calls{modeEqualSubst}{modeEqualSubst} +\calls{modeEqualSubst}{length} +\begin{chunk}{defun modeEqualSubst} +(defun |modeEqualSubst| (m1 m env) + (let (mp op z1 z2) + (cond + ((|modeEqual| m1 m) t) + ((atom m1) + (when (setq mp (car (|get| m1 '|value| env))) + (|modeEqual| mp m))) + ((and (pairp m1) (pairp m) (equal (qcar m) (qcar m1)) + (equal (|#| (qcdr m1)) (|#| (qcdr m)))) + (setq op (qcar m1)) + (setq z1 (qcdr m1)) + (setq z2 (qcdr m)) + (let ((result t)) + (loop for xm1 in z1 for xm2 in z2 + do (setq result (and result (|modeEqualSubst| xm1 xm2 env)))) + result)) + (t nil)))) + +\end{chunk} + +\subsection{compilerDoitWithScreenedLisplib}{compilerDoitWithScreenedLisplib} +\calls{compilerDoitWithScreenedLisplib}{embed} +\calls{compilerDoitWithScreenedLisplib}{rwrite} +\calls{compilerDoitWithScreenedLisplib}{compilerDoit} +\calls{compilerDoitWithScreenedLisplib}{unembed} +\refsdollar{compilerDoitWithScreenedLisplib}{saveableItems} +\refsdollar{compilerDoitWithScreenedLisplib}{libFile} +\begin{chunk}{defun compilerDoitWithScreenedLisplib} +(defun |compilerDoitWithScreenedLisplib| (constructor fun) + (declare (special |$saveableItems| |$libFile|)) + (embed 'rwrite + '(lambda (key value stream) + (cond + ((and (eq stream |$libFile|) + (not (member key |$saveableItems|))) + value) + ((not nil) (rwrite key value stream))))) + (unwind-protect + (|compilerDoit| constructor fun) + (unembed 'rwrite))) + +\end{chunk} + \chapter{Post Transformers} \section{Direct called postparse routines} \defun{postTransform}{postTransform} @@ -13678,7 +13914,7 @@ of the symbol being parsed. The original list read: (list 'in (setq g (genvar)) (|aplTran1| y)) (list (list f g ) )))) (t - (list '|map| f (|aplTran1| y) )))) + (list 'map f (|aplTran1| y) )))) (t x))) ((progn (setq tmp1 (|hasAplExtension| argl)) @@ -16981,7 +17217,6 @@ Again we find a lot of redundant work. We finally end up calling \calls{compileSpad2Cmd}{object2String} \calls{compileSpad2Cmd}{browserAutoloadOnceTrigger} \calls{compileSpad2Cmd}{spad2AsTranslatorAutoloadOnceTrigger} -\calls{compileSpad2Cmd}{convertSpadToAsFile} \calls{compileSpad2Cmd}{compilerDoitWithScreenedLisplib} \calls{compileSpad2Cmd}{compilerDoit} \calls{compileSpad2Cmd}{extendLocalLibdb} @@ -17627,14 +17862,13 @@ And the {\bf s-process} function which returns a parsed version of the input. (|$noSubsumption| |$noSubsumption|) in-stream out-stream) (declare (special echo-meta /editfile *comp370-apply* *eof* curoutstream file-closed |$noSubsumption| |$InteractiveFrame| - |$InteractiveMode| |$InitialDomainsInScope| optionlist + |$InteractiveMode| optionlist boot-line-stack *fileactq-apply* $spad $boot)) ;; only rebind |$InteractiveFrame| if compiling (progv (if (not |$InteractiveMode|) '(|$InteractiveFrame|)) (if (not |$InteractiveMode|) (list (|addBinding| '|$DomainsInScope| - `((fluid . |true|) - (special . ,(copy-tree |$InitialDomainsInScope|))) + `((fluid . |true|)) (|addBinding| '|$Information| nil (|makeInitialModemapFrame|))))) (init-boot/spad-reader) @@ -19616,6 +19850,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun augModemapsFromCategoryRep} \getchunk{defun augModemapsFromDomain} \getchunk{defun augModemapsFromDomain1} +\getchunk{defun autoCoerceByModemap} \getchunk{defun blankp} \getchunk{defun bumperrorcount} @@ -19625,7 +19860,10 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun char-ne} \getchunk{defun checkWarning} \getchunk{defun coerce} +\getchunk{defun coerceable} +\getchunk{defun coerceByModemap} \getchunk{defun coerceEasy} +\getchunk{defun coerceExit} \getchunk{defun coerceExtraHard} \getchunk{defun coerceHard} \getchunk{defun coerceSubset} @@ -19682,6 +19920,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun compiler} \getchunk{defun compileDocumentation} \getchunk{defun compilerDoit} +\getchunk{defun compilerDoitWithScreenedLisplib} \getchunk{defun compileSpad2Cmd} \getchunk{defun compileSpadLispCmd} \getchunk{defun compImport} @@ -19790,6 +20029,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun hasAplExtension} \getchunk{defun hasFormalMapVariable} \getchunk{defun hasFullSignature} +\getchunk{defun hasType} \getchunk{defun indent-pos} \getchunk{defun infixtok} @@ -19847,7 +20087,10 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun mkEvalableCategoryForm} \getchunk{defun mkNewModemapList} \getchunk{defun mkOpVec} +\getchunk{defun mkUnion} \getchunk{defun modifyModeStack} +\getchunk{defun modeEqual} +\getchunk{defun modeEqualSubst} \getchunk{defun modemapPattern} \getchunk{defun moveORsOutside} @@ -20062,10 +20305,11 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun read-a-line} \getchunk{defun recompile-lib-file-if-necessary} \getchunk{defun replaceExitEtc} -\getchunk{defun /rf-1} \getchunk{defun removeSuperfluousMapping} \getchunk{defun replaceVars} +\getchunk{defun resolve} \getchunk{defun reportOnFunctorCompilation} +\getchunk{defun /rf-1} \getchunk{defun /RQ,LIB} \getchunk{defun rwriteLispForm} diff --git a/changelog b/changelog index a67189b..47ec494 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,10 @@ +20110818 tpd src/axiom-website/patches.html 20110818.01.tpd.patch +20110818 tpd src/lib/cfuns-c.c treeshake compiler +20110818 tpd src/interp/vmlisp.lisp treeshake compiler +20110818 tpd src/interp/apply.lisp pick up function from compiler.lisp +20110818 tpd src/interp/Makefile remove compiler.lisp +20110818 tpd src/interp/compiler.lisp removed +20110818 tpd books/bookvol9 treeshake compiler 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 diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 33401e5..9d74ca0 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3588,5 +3588,7 @@ books/bookvol9 treeshake compiler
src/input/Makefile respect the BUILD=fast variable value
20110814.01.tpd.patch books/bookvol9 treeshake compiler
+20110818.01.tpd.patch +books/bookvol9 treeshake compiler, remove compiler.lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 4155aa3..a3a534e 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -178,7 +178,7 @@ OBJS= ${OUT}/vmlisp.${O} \ ${OUT}/parsing.${O} \ ${OUT}/apply.${O} ${OUT}/c-doc.${O} \ ${OUT}/c-util.${O} ${OUT}/profile.${O} \ - ${OUT}/category.${O} ${OUT}/compiler.${O} \ + ${OUT}/category.${O} \ ${OUT}/define.${O} ${OUT}/functor.${O} \ ${OUT}/info.${O} ${OUT}/iterator.${O} \ ${OUT}/nruncomp.${O} \ @@ -1614,31 +1614,6 @@ ${MID}/clammed.lisp: ${IN}/clammed.lisp.pamphlet @ -\subsection{compiler.lisp} -<>= -${OUT}/compiler.${O}: ${MID}/compiler.lisp - @ echo 136 making ${OUT}/compiler.${O} from ${MID}/compiler.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/compiler.lisp"' \ - ':output-file "${OUT}/compiler.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/compiler.lisp"' \ - ':output-file "${OUT}/compiler.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/compiler.lisp: ${IN}/compiler.lisp.pamphlet - @ echo 137 making ${MID}/compiler.lisp from \ - ${IN}/compiler.lisp.pamphlet - @ (cd ${MID} ; \ - echo '(tangle "${IN}/compiler.lisp.pamphlet" "*" "compiler.lisp")' \ - | ${OBJ}/${SYS}/bin/lisp ) - -@ - \subsection{profile.lisp} <>= ${OUT}/profile.${O}: ${MID}/profile.lisp @@ -3244,9 +3219,6 @@ clean: <> <> -<> -<> - <> <> diff --git a/src/interp/apply.lisp.pamphlet b/src/interp/apply.lisp.pamphlet index 1200b92..bf39f1d 100644 --- a/src/interp/apply.lisp.pamphlet +++ b/src/interp/apply.lisp.pamphlet @@ -517,6 +517,86 @@ (SETQ T$ (CONS |x'| (CONS |m'| (CONS |e'| NIL)))) (|convert| T$ |m|)))))))) +;substituteIntoFunctorModemap(argl,modemap is [[dc,:sig],:.],e) == +; #dc^=#sig => +; keyedSystemError("S2GE0016",['"substituteIntoFunctorModemap", +; '"Incompatible maps"]) +; #argl=#rest sig => +; --here, we actually have a functor form +; sig:= EQSUBSTLIST(argl,rest dc,sig) +; --make new modemap, subst. actual for formal parametersinto modemap +; Tl:= [[.,.,e]:= compOrCroak(a,m,e) for a in argl for m in rest sig] +; substitutionList:= [[x,:T.expr] for x in rest dc for T in Tl] +; [SUBLIS(substitutionList,modemap),e] +; nil + +(DEFUN |substituteIntoFunctorModemap| (|argl| |modemap| |e|) + (PROG (|dc| |sig| |LETTMP#1| |Tl| |substitutionList|) + (RETURN + (SEQ (PROGN + (SPADLET |dc| (CAAR |modemap|)) + (SPADLET |sig| (CDAR |modemap|)) + (COND + ((NEQUAL (|#| |dc|) (|#| |sig|)) + (|keyedSystemError| 'S2GE0016 + (CONS "substituteIntoFunctorModemap" + (CONS "Incompatible maps" NIL)))) + ((BOOT-EQUAL (|#| |argl|) (|#| (CDR |sig|))) + (SPADLET |sig| (EQSUBSTLIST |argl| (CDR |dc|) |sig|)) + (SPADLET |Tl| + (PROG (G167960) + (SPADLET G167960 NIL) + (RETURN + (DO ((G167969 |argl| (CDR G167969)) + (|a| NIL) + (G167970 (CDR |sig|) + (CDR G167970)) + (|m| NIL)) + ((OR (ATOM G167969) + (PROGN + (SETQ |a| (CAR G167969)) + NIL) + (ATOM G167970) + (PROGN + (SETQ |m| (CAR G167970)) + NIL)) + (NREVERSE0 G167960)) + (SEQ (EXIT + (SETQ G167960 + (CONS + (PROGN + (SPADLET |LETTMP#1| + (|compOrCroak| |a| |m| |e|)) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|) + G167960)))))))) + (SPADLET |substitutionList| + (PROG (G167984) + (SPADLET G167984 NIL) + (RETURN + (DO ((G167990 (CDR |dc|) + (CDR G167990)) + (|x| NIL) + (G167991 |Tl| (CDR G167991)) + (T$ NIL)) + ((OR (ATOM G167990) + (PROGN + (SETQ |x| (CAR G167990)) + NIL) + (ATOM G167991) + (PROGN + (SETQ T$ (CAR G167991)) + NIL)) + (NREVERSE0 G167984)) + (SEQ (EXIT + (SETQ G167984 + (CONS (CONS |x| (CAR T$)) + G167984)))))))) + (CONS (SUBLIS |substitutionList| |modemap|) + (CONS |e| NIL))) + ('T NIL))))))) + ;applyMapping([op,:argl],m,e,ml) == ; #argl^=#ml-1 => nil ; isCategoryForm(first ml,e) => diff --git a/src/interp/compiler.lisp.pamphlet b/src/interp/compiler.lisp.pamphlet deleted file mode 100644 index 4aa5794..0000000 --- a/src/interp/compiler.lisp.pamphlet +++ /dev/null @@ -1,838 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp compiler.lisp} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{chunk}{*} - -(IN-PACKAGE "BOOT" ) - -(defvar |$NoValueMode| '|NoValueMode|) -(defvar |$ValueMode| '|ValueMode|) -(defvar |$globalMacroStack| nil) -(defvar |$abbreviationStack| nil) - -\end{chunk} -\subsection{tc} -\begin{chunk}{*} -;tc() == -; $tripleCache:= nil -; comp($x,$m,$f) - -;(DEFUN |tc| () -; (declare (special |$tripleCache| |$x| |$m| |$f|)) -; (PROGN (SPADLET |$tripleCache| NIL) (|comp| |$x| |$m| |$f|))) - -\end{chunk} - -\subsection{mkUnion} -\begin{chunk}{*} -;mkUnion(a,b) == -; b="$" and $Rep is ["Union",:l] => b -; a is ["Union",:l] => -; b is ["Union",:l'] => ["Union",:setUnion(l,l')] -; ["Union",:setUnion([b],l)] -; b is ["Union",:l] => ["Union",:setUnion([a],l)] -; ["Union",a,b] - -(DEFUN |mkUnion| (|a| |b|) - (PROG (|l'| |l|) - (declare (special |$Rep|)) - (RETURN - (COND - ((AND (BOOT-EQUAL |b| '$) (PAIRP |$Rep|) - (EQ (QCAR |$Rep|) '|Union|) - (PROGN (SPADLET |l| (QCDR |$Rep|)) 'T)) - |b|) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|Union|) - (PROGN (SPADLET |l| (QCDR |a|)) 'T)) - (COND - ((AND (PAIRP |b|) (EQ (QCAR |b|) '|Union|) - (PROGN (SPADLET |l'| (QCDR |b|)) 'T)) - (CONS '|Union| (|union| |l| |l'|))) - ('T (CONS '|Union| (|union| (CONS |b| NIL) |l|))))) - ((AND (PAIRP |b|) (EQ (QCAR |b|) '|Union|) - (PROGN (SPADLET |l| (QCDR |b|)) 'T)) - (CONS '|Union| (|union| (CONS |a| NIL) |l|))) - ('T (CONS '|Union| (CONS |a| (CONS |b| NIL)))))))) - -\end{chunk} -\subsection{hasType} -\begin{chunk}{*} -;hasType(x,e) == -; fn get(x,"condition",e) where -; fn x == -; null x => nil -; x is [["case",.,y],:.] => y -; fn rest x - -(DEFUN |hasType,fn| (|x|) - (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |y|) - (RETURN - (SEQ (IF (NULL |x|) (EXIT NIL)) - (IF (AND (PAIRP |x|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |x|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|case|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |y| (QCAR |ISTMP#3|)) - 'T)))))))) - (EXIT |y|)) - (EXIT (|hasType,fn| (CDR |x|))))))) - -(DEFUN |hasType| (|x| |e|) - (|hasType,fn| (|get| |x| '|condition| |e|))) - -\end{chunk} -\subsection{getConstructorFormOfMode} -\begin{chunk}{*} -;getConstructorFormOfMode(m,e) == -; isConstructorForm m => m -; if m="$" then m:= "Rep" -; atom m and get(m,"value",e) is [v,:.] => -; isConstructorForm v => v - -(DEFUN |getConstructorFormOfMode| (|m| |e|) - (PROG (|ISTMP#1| |v|) - (RETURN - (SEQ (COND - ((|isConstructorForm| |m|) |m|) - ('T (COND ((BOOT-EQUAL |m| '$) (SPADLET |m| '|Rep|))) - (SEQ (COND - ((AND (ATOM |m|) - (PROGN - (SPADLET |ISTMP#1| - (|get| |m| '|value| |e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |v| (QCAR |ISTMP#1|)) - 'T)))) - (COND ((|isConstructorForm| |v|) (EXIT |v|)))))))))))) - -\end{chunk} -\subsection{getConstructorMode} -\begin{chunk}{*} -;getConstructorMode(x,e) == -; atom x => (u:= getmode(x,e) or return nil; getConstructorFormOfMode(u,e)) -; x is ["elt",y,a] => -; u:= getConstructorMode(y,e) -; u is ["Vector",R] or u is ["List",R] => -; isConstructorForm R => R -; u is ["Record",:l] => -; (or/[p is [., =a,R] for p in l]) and isConstructorForm R => R - -(DEFUN |getConstructorMode| (|x| |e|) - (PROG (|y| |a| |u| |l| |ISTMP#1| |ISTMP#2| R) - (RETURN - (SEQ (COND - ((ATOM |x|) - (SPADLET |u| (OR (|getmode| |x| |e|) (RETURN NIL))) - (|getConstructorFormOfMode| |u| |e|)) - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|elt|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |y| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |a| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |u| (|getConstructorMode| |y| |e|)) - (SEQ (COND - ((OR (AND (PAIRP |u|) (EQ (QCAR |u|) '|Vector|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET R (QCAR |ISTMP#1|)) - 'T)))) - (AND (PAIRP |u|) (EQ (QCAR |u|) '|List|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET R (QCAR |ISTMP#1|)) - 'T))))) - (COND ((|isConstructorForm| R) (EXIT R)))) - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|Record|) - (PROGN (SPADLET |l| (QCDR |u|)) 'T)) - (COND - ((AND (PROG (G167805) - (SPADLET G167805 NIL) - (RETURN - (DO ((G167817 NIL G167805) - (G167818 |l| (CDR G167818)) - (|p| NIL)) - ((OR G167817 (ATOM G167818) - (PROGN - (SETQ |p| (CAR G167818)) - NIL)) - G167805) - (SEQ - (EXIT - (SETQ G167805 - (OR G167805 - (AND (PAIRP |p|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |p|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) - |a|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (SPADLET R - (QCAR |ISTMP#2|)) - 'T))))))))))))) - (|isConstructorForm| R)) - (EXIT R)))))))))))) - -\end{chunk} -\subsection{isConstructorForm} -\begin{chunk}{*} -;isConstructorForm u == u is [name,:.] and MEMBER(name,'(Record Vector List)) - -(DEFUN |isConstructorForm| (|u|) - (PROG (|name|) - (RETURN - (AND (PAIRP |u|) (PROGN (SPADLET |name| (QCAR |u|)) 'T) - (|member| |name| '(|Record| |Vector| |List|)))))) - -\end{chunk} -\subsection{substituteIntoFunctorModemap} -\begin{chunk}{*} -;substituteIntoFunctorModemap(argl,modemap is [[dc,:sig],:.],e) == -; #dc^=#sig => -; keyedSystemError("S2GE0016",['"substituteIntoFunctorModemap", -; '"Incompatible maps"]) -; #argl=#rest sig => -; --here, we actually have a functor form -; sig:= EQSUBSTLIST(argl,rest dc,sig) -; --make new modemap, subst. actual for formal parametersinto modemap -; Tl:= [[.,.,e]:= compOrCroak(a,m,e) for a in argl for m in rest sig] -; substitutionList:= [[x,:T.expr] for x in rest dc for T in Tl] -; [SUBLIS(substitutionList,modemap),e] -; nil - -(DEFUN |substituteIntoFunctorModemap| (|argl| |modemap| |e|) - (PROG (|dc| |sig| |LETTMP#1| |Tl| |substitutionList|) - (RETURN - (SEQ (PROGN - (SPADLET |dc| (CAAR |modemap|)) - (SPADLET |sig| (CDAR |modemap|)) - (COND - ((NEQUAL (|#| |dc|) (|#| |sig|)) - (|keyedSystemError| 'S2GE0016 - (CONS "substituteIntoFunctorModemap" - (CONS "Incompatible maps" NIL)))) - ((BOOT-EQUAL (|#| |argl|) (|#| (CDR |sig|))) - (SPADLET |sig| (EQSUBSTLIST |argl| (CDR |dc|) |sig|)) - (SPADLET |Tl| - (PROG (G167960) - (SPADLET G167960 NIL) - (RETURN - (DO ((G167969 |argl| (CDR G167969)) - (|a| NIL) - (G167970 (CDR |sig|) - (CDR G167970)) - (|m| NIL)) - ((OR (ATOM G167969) - (PROGN - (SETQ |a| (CAR G167969)) - NIL) - (ATOM G167970) - (PROGN - (SETQ |m| (CAR G167970)) - NIL)) - (NREVERSE0 G167960)) - (SEQ (EXIT - (SETQ G167960 - (CONS - (PROGN - (SPADLET |LETTMP#1| - (|compOrCroak| |a| |m| |e|)) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|) - G167960)))))))) - (SPADLET |substitutionList| - (PROG (G167984) - (SPADLET G167984 NIL) - (RETURN - (DO ((G167990 (CDR |dc|) - (CDR G167990)) - (|x| NIL) - (G167991 |Tl| (CDR G167991)) - (T$ NIL)) - ((OR (ATOM G167990) - (PROGN - (SETQ |x| (CAR G167990)) - NIL) - (ATOM G167991) - (PROGN - (SETQ T$ (CAR G167991)) - NIL)) - (NREVERSE0 G167984)) - (SEQ (EXIT - (SETQ G167984 - (CONS (CONS |x| (CAR T$)) - G167984)))))))) - (CONS (SUBLIS |substitutionList| |modemap|) - (CONS |e| NIL))) - ('T NIL))))))) - -\end{chunk} - -\section{Functions for coercion by the compiler} -\subsection{coerceable} -\begin{chunk}{*} -;coerceable(m,m',e) == -; m=m' => m -; -- must find any free parameters in m -; sl:= pmatch(m',m) => SUBLIS(sl,m') -; coerce(["$fromCoerceable$",m,e],m') => m' -; nil - -(DEFUN |coerceable| (|m| |m'| |e|) - (PROG (|sl|) - (declare (special |$fromCoerceable$|)) - (RETURN - (COND - ((BOOT-EQUAL |m| |m'|) |m|) - ((SPADLET |sl| (|pmatch| |m'| |m|)) (SUBLIS |sl| |m'|)) - ((|coerce| (CONS '|$fromCoerceable$| (CONS |m| (CONS |e| NIL))) - |m'|) - |m'|) - ('T NIL))))) - -\end{chunk} -\subsection{coerceExit} -\begin{chunk}{*} -;coerceExit([x,m,e],m') == -; m':= resolve(m,m') -; x':= replaceExitEtc(x,catchTag:= MKQ GENSYM(),"TAGGEDexit",$exitMode) -; coerce([["CATCH",catchTag,x'],m,e],m') - -(DEFUN |coerceExit| (G170380 |m'|) - (PROG (|x| |m| |e| |catchTag| |x'|) - (declare (special |$exitMode|)) - (RETURN - (PROGN - (SPADLET |x| (CAR G170380)) - (SPADLET |m| (CADR G170380)) - (SPADLET |e| (CADDR G170380)) - (SPADLET |m'| (|resolve| |m| |m'|)) - (SPADLET |x'| - (|replaceExitEtc| |x| - (SPADLET |catchTag| (MKQ (GENSYM))) '|TAGGEDexit| - |$exitMode|)) - (|coerce| - (CONS (CONS 'CATCH (CONS |catchTag| (CONS |x'| NIL))) - (CONS |m| (CONS |e| NIL))) - |m'|))))) - -\end{chunk} -\subsection{coerceByModemap} -\begin{chunk}{*} -;coerceByModemap([x,m,e],m') == -;--+ modified 6/27 for new runtime system -; u:= -; [modemap -; for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t, -; s] and (modeEqual(t,m') or isSubset(t,m',e)) -; and (modeEqual(s,m) or isSubset(m,s,e))] or return nil -; --mm:= (or/[mm for (mm:=[.,[cond,.]]) in u | cond=true]) or return nil -; mm:=first u -- patch for non-trival conditons -; fn := -; genDeltaEntry ['coerce,:mm] -; [["call",fn,x],m',e] - -(DEFUN |coerceByModemap| (G170521 |m'|) - (PROG (|x| |m| |e| |map| |cexpr| |ISTMP#1| |t| |ISTMP#2| |s| |u| |mm| - |fn|) - (RETURN - (SEQ (PROGN - (SPADLET |x| (CAR G170521)) - (SPADLET |m| (CADR G170521)) - (SPADLET |e| (CADDR G170521)) - (SPADLET |u| - (OR (PROG (G170548) - (SPADLET G170548 NIL) - (RETURN - (DO ((G170555 - (|getModemapList| '|coerce| 1 |e|) - (CDR G170555)) - (|modemap| NIL)) - ((OR (ATOM G170555) - (PROGN - (SETQ |modemap| (CAR G170555)) - NIL) - (PROGN - (PROGN - (SPADLET |map| (CAR |modemap|)) - (SPADLET |cexpr| - (CADR |modemap|)) - |modemap|) - NIL)) - (NREVERSE0 G170548)) - (SEQ (EXIT - (COND - ((AND (PAIRP |map|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |map|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |t| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (SPADLET |s| - (QCAR |ISTMP#2|)) - 'T))))) - (OR (|modeEqual| |t| |m'|) - (|isSubset| |t| |m'| |e|)) - (OR (|modeEqual| |s| |m|) - (|isSubset| |m| |s| |e|))) - (SETQ G170548 - (CONS |modemap| G170548))))))))) - (RETURN NIL))) - (SPADLET |mm| (CAR |u|)) - (SPADLET |fn| (|genDeltaEntry| (CONS '|coerce| |mm|))) - (CONS (CONS '|call| (CONS |fn| (CONS |x| NIL))) - (CONS |m'| (CONS |e| NIL)))))))) - -\end{chunk} -\subsection{autoCoerceByModemap} -\begin{chunk}{*} -;autoCoerceByModemap([x,source,e],target) == -; u:= -; [cexpr -; for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [ -; .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil -; fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil -; source is ["Union",:l] and MEMBER(target,l) => -; (y:= get(x,"condition",e)) and (or/[u is ["case",., =target] for u in y]) -; => [["call",fn,x],target,e] -; x="$fromCoerceable$" => nil -; stackMessage ["cannot coerce: ",x,"%l"," of mode: ",source,"%l", -; " to: ",target," without a case statement"] -; [["call",fn,x],target,e] - -(DEFUN |autoCoerceByModemap| (G170609 |target|) - (PROG (|x| |source| |e| |map| |cexpr| |t| |s| |u| |cond| |selfn| |fn| - |l| |y| |ISTMP#1| |ISTMP#2|) - (declare (special |$fromCoerceable$|)) - (RETURN - (SEQ (PROGN - (SPADLET |x| (CAR G170609)) - (SPADLET |source| (CADR G170609)) - (SPADLET |e| (CADDR G170609)) - (SPADLET |u| - (OR (PROG (G170645) - (SPADLET G170645 NIL) - (RETURN - (DO ((G170652 - (|getModemapList| '|autoCoerce| 1 - |e|) - (CDR G170652)) - (|modemap| NIL)) - ((OR (ATOM G170652) - (PROGN - (SETQ |modemap| (CAR G170652)) - NIL) - (PROGN - (PROGN - (SPADLET |map| (CAR |modemap|)) - (SPADLET |cexpr| - (CADR |modemap|)) - |modemap|) - NIL)) - (NREVERSE0 G170645)) - (SEQ (EXIT - (COND - ((AND (PAIRP |map|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |map|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |t| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (SPADLET |s| - (QCAR |ISTMP#2|)) - 'T))))) - (|modeEqual| |t| |target|) - (|modeEqual| |s| |source|)) - (SETQ G170645 - (CONS |cexpr| G170645))))))))) - (RETURN NIL))) - (SPADLET |fn| - (OR (PROG (G170659) - (SPADLET G170659 NIL) - (RETURN - (DO ((G170667 NIL G170659) - (G170668 |u| (CDR G170668)) - (G170597 NIL)) - ((OR G170667 (ATOM G170668) - (PROGN - (SETQ G170597 (CAR G170668)) - NIL) - (PROGN - (PROGN - (SPADLET |cond| - (CAR G170597)) - (SPADLET |selfn| - (CADR G170597)) - G170597) - NIL)) - G170659) - (SEQ (EXIT - (COND - ((BOOT-EQUAL |cond| 'T) - (SETQ G170659 - (OR G170659 |selfn|))))))))) - (RETURN NIL))) - (COND - ((AND (PAIRP |source|) (EQ (QCAR |source|) '|Union|) - (PROGN (SPADLET |l| (QCDR |source|)) 'T) - (|member| |target| |l|)) - (COND - ((AND (SPADLET |y| (|get| |x| '|condition| |e|)) - (PROG (G170676) - (SPADLET G170676 NIL) - (RETURN - (DO ((G170686 NIL G170676) - (G170687 |y| (CDR G170687)) - (|u| NIL)) - ((OR G170686 (ATOM G170687) - (PROGN - (SETQ |u| (CAR G170687)) - NIL)) - G170676) - (SEQ (EXIT - (SETQ G170676 - (OR G170676 - (AND (PAIRP |u|) - (EQ (QCAR |u|) '|case|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (EQUAL (QCAR |ISTMP#2|) - |target|)))))))))))))) - (CONS (CONS '|call| (CONS |fn| (CONS |x| NIL))) - (CONS |target| (CONS |e| NIL)))) - ((BOOT-EQUAL |x| '|$fromCoerceable$|) NIL) - ('T - (|stackMessage| - (CONS '|cannot coerce: | - (CONS |x| - (CONS '|%l| - (CONS '| of mode: | - (CONS |source| - (CONS '|%l| - (CONS '| to: | - (CONS |target| - (CONS - '| without a case statement| - NIL))))))))))))) - ('T - (CONS (CONS '|call| (CONS |fn| (CONS |x| NIL))) - (CONS |target| (CONS |e| NIL)))))))))) - -\end{chunk} -\subsection{resolve} -Very old resolve -should only be used in the old (preWATT) compiler -\begin{chunk}{*} -;resolve(din,dout) == -; din=$NoValueMode or dout=$NoValueMode => $NoValueMode -; dout=$EmptyMode => din -; din^=dout and (STRINGP din or STRINGP dout) => -; modeEqual(dout,$String) => dout -; modeEqual(din,$String) => nil -; mkUnion(din,dout) -; dout - -(DEFUN |resolve| (|din| |dout|) - (declare (special |$String| |$EmptyMode| |$NoValueMode|)) - (COND - ((OR (BOOT-EQUAL |din| |$NoValueMode|) - (BOOT-EQUAL |dout| |$NoValueMode|)) - |$NoValueMode|) - ((BOOT-EQUAL |dout| |$EmptyMode|) |din|) - ((AND (NEQUAL |din| |dout|) (OR (STRINGP |din|) (STRINGP |dout|))) - (COND - ((|modeEqual| |dout| |$String|) |dout|) - ((|modeEqual| |din| |$String|) NIL) - ('T (|mkUnion| |din| |dout|)))) - ('T |dout|))) - -\end{chunk} -\subsection{modeEqual} -\begin{chunk}{*} -;modeEqual(x,y) == -; -- this is the late modeEqual -; -- orders Unions -; atom x or atom y => x=y -; #x ^=#y => nil -; x is ['Union,:xl] and y is ['Union,:yl] => -; for x1 in xl repeat -; for y1 in yl repeat -; modeEqual(x1,y1) => -; xl := DELETE(x1,xl) -; yl := DELETE(y1,yl) -; return nil -; xl or yl => nil -; true -; (and/[modeEqual(u,v) for u in x for v in y]) - -(DEFUN |modeEqual| (|x| |y|) - (PROG (|xl| |yl|) - (RETURN - (SEQ (COND - ((OR (ATOM |x|) (ATOM |y|)) (BOOT-EQUAL |x| |y|)) - ((NEQUAL (|#| |x|) (|#| |y|)) NIL) - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Union|) - (PROGN (SPADLET |xl| (QCDR |x|)) 'T) (PAIRP |y|) - (EQ (QCAR |y|) '|Union|) - (PROGN (SPADLET |yl| (QCDR |y|)) 'T)) - (SEQ (DO ((G170731 |xl| (CDR G170731)) (|x1| NIL)) - ((OR (ATOM G170731) - (PROGN (SETQ |x1| (CAR G170731)) NIL)) - NIL) - (SEQ (EXIT (DO ((G170743 |yl| (CDR G170743)) - (|y1| NIL)) - ((OR (ATOM G170743) - (PROGN - (SETQ |y1| (CAR G170743)) - NIL)) - NIL) - (SEQ (EXIT - (COND - ((|modeEqual| |x1| |y1|) - (EXIT - (PROGN - (SPADLET |xl| - (|delete| |x1| |xl|)) - (SPADLET |yl| - (|delete| |y1| |yl|)) - (RETURN NIL))))))))))) - (COND ((OR |xl| |yl|) NIL) ('T 'T)))) - ('T - (PROG (G170749) - (SPADLET G170749 'T) - (RETURN - (DO ((G170756 NIL (NULL G170749)) - (G170757 |x| (CDR G170757)) (|u| NIL) - (G170758 |y| (CDR G170758)) (|v| NIL)) - ((OR G170756 (ATOM G170757) - (PROGN (SETQ |u| (CAR G170757)) NIL) - (ATOM G170758) - (PROGN (SETQ |v| (CAR G170758)) NIL)) - G170749) - (SEQ (EXIT (SETQ G170749 - (AND G170749 - (|modeEqual| |u| |v|)))))))))))))) - -\end{chunk} -\subsection{modeEqualSubst} -\begin{chunk}{*} -;modeEqualSubst(m1,m,e) == -; modeEqual(m1, m) => true -; atom m1 => get(m1,"value",e) is [m',:.] and modeEqual(m',m) -; m1 is [op,:l1] and m is [=op,:l2] and # l1 = # l2 => -;-- Above length test inserted JHD 4:47 on 15/8/86 -;-- Otherwise Records can get fouled up - consider expressIdealElt -;-- in the DEFAULTS package -; and/[modeEqualSubst(xm1,xm2,e) for xm1 in l1 for xm2 in l2] -; nil - -(DEFUN |modeEqualSubst| (|m1| |m| |e|) - (PROG (|ISTMP#1| |m'| |op| |l1| |l2|) - (RETURN - (SEQ (COND - ((|modeEqual| |m1| |m|) 'T) - ((ATOM |m1|) - (AND (PROGN - (SPADLET |ISTMP#1| (|get| |m1| '|value| |e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET |m'| (QCAR |ISTMP#1|)) 'T))) - (|modeEqual| |m'| |m|))) - ((AND (PAIRP |m1|) - (PROGN - (SPADLET |op| (QCAR |m1|)) - (SPADLET |l1| (QCDR |m1|)) - 'T) - (PAIRP |m|) (EQUAL (QCAR |m|) |op|) - (PROGN (SPADLET |l2| (QCDR |m|)) 'T) - (BOOT-EQUAL (|#| |l1|) (|#| |l2|))) - (PROG (G170784) - (SPADLET G170784 'T) - (RETURN - (DO ((G170791 NIL (NULL G170784)) - (G170792 |l1| (CDR G170792)) (|xm1| NIL) - (G170793 |l2| (CDR G170793)) (|xm2| NIL)) - ((OR G170791 (ATOM G170792) - (PROGN (SETQ |xm1| (CAR G170792)) NIL) - (ATOM G170793) - (PROGN (SETQ |xm2| (CAR G170793)) NIL)) - G170784) - (SEQ (EXIT (SETQ G170784 - (AND G170784 - (|modeEqualSubst| |xm1| |xm2| - |e|))))))))) - ('T NIL)))))) - -\end{chunk} -\subsection{convertSpadToAsFile} -\begin{chunk}{*} -;convertSpadToAsFile path == -; -- can assume path has type = .spad -; $globalMacroStack : local := nil -- for spad -> as translator -; $abbreviationStack: local := nil -- for spad -> as translator -; $macrosAlreadyPrinted: local := nil -- for spad -> as translator -; SETQ($badStack, nil) --ditto TEMP to check for bad code -; $newPaths: local := true --ditto TEMP -; $abbreviationsAlreadyPrinted: local := nil -- for spad -> as translator -; $convertingSpadFile : local := true -; $options: local := '((nolib)) -- translator shouldn't create nrlibs -; SETQ(HT,MAKE_-HASHTABLE 'UEQUAL) -; newName := fnameMake(pathnameDirectory path, pathnameName path, '"as") -; canDoIt := true -; if not fnameWritable? newName then -; sayKeyedMsg("S2IZ0086", [NAMESTRING newName]) -; newName := fnameMake('".", pathnameName path, '"as") -; if not fnameWritable? newName then -; sayKeyedMsg("S2IZ0087", [NAMESTRING newName]) -; canDoIt := false -; not canDoIt => 'failure -; sayKeyedMsg("S2IZ0088", [NAMESTRING newName]) -; $outStream :local := MAKE_-OUTSTREAM newName -; markSay('"#include _"axiom.as_"") -; markTerpri() -; CATCH("SPAD__READER",compiler [path]) -; SHUT $outStream -; mkCheck() -; 'done - -(DEFUN |convertSpadToAsFile| (|path|) - (PROG (|$globalMacroStack| |$abbreviationStack| - |$macrosAlreadyPrinted| |$newPaths| - |$abbreviationsAlreadyPrinted| |$convertingSpadFile| - |$options| |$outStream| |newName| |canDoIt|) - (DECLARE (SPECIAL |$globalMacroStack| |$abbreviationStack| - |$macrosAlreadyPrinted| |$newPaths| - |$abbreviationsAlreadyPrinted| |$badStack| - |$convertingSpadFile| |$options| |$outStream|)) - (RETURN - (PROGN - (SPADLET |$globalMacroStack| NIL) - (SPADLET |$abbreviationStack| NIL) - (SPADLET |$macrosAlreadyPrinted| NIL) - (SETQ |$badStack| NIL) - (SPADLET |$newPaths| 'T) - (SPADLET |$abbreviationsAlreadyPrinted| NIL) - (SPADLET |$convertingSpadFile| 'T) - (SPADLET |$options| '((|nolib|))) - (SETQ HT (MAKE-HASHTABLE 'UEQUAL)) - (SPADLET |newName| - (|fnameMake| (|pathnameDirectory| |path|) - (|pathnameName| |path|) "as")) - (SPADLET |canDoIt| 'T) - (COND - ((NULL (|fnameWritable?| |newName|)) - (|sayKeyedMsg| 'S2IZ0086 (CONS (NAMESTRING |newName|) NIL)) - (SPADLET |newName| - (|fnameMake| "." - (|pathnameName| |path|) "as")) - (COND - ((NULL (|fnameWritable?| |newName|)) - (|sayKeyedMsg| 'S2IZ0087 - (CONS (NAMESTRING |newName|) NIL)) - (SPADLET |canDoIt| NIL)) - ('T NIL)))) - (COND - ((NULL |canDoIt|) '|failure|) - ('T - (|sayKeyedMsg| 'S2IZ0088 (CONS (NAMESTRING |newName|) NIL)) - (SPADLET |$outStream| (MAKE-OUTSTREAM |newName|)) - (|markSay| "#include \"axiom.as\"") - (|markTerpri|) - (CATCH 'SPAD_READER (|compiler| (CONS |path| NIL))) - (SHUT |$outStream|) (|mkCheck|) '|done|)))))) - -\end{chunk} -\subsection{compilerDoitWithScreenedLisplib} -\begin{chunk}{*} -;compilerDoitWithScreenedLisplib(constructor, fun) == -; EMBED('RWRITE, -; '(LAMBDA (KEY VALUE STREAM) -; (COND ((AND (EQ STREAM $libFile) -; (NOT (MEMBER KEY $saveableItems))) -; VALUE) -; ((NOT NIL) -; (RWRITE KEY VALUE STREAM)))) ) -; UNWIND_-PROTECT(compilerDoit(constructor,fun), -; SEQ(UNEMBED 'RWRITE)) - -(DEFUN |compilerDoitWithScreenedLisplib| (|constructor| |fun|) - (declare (special |$saveableItems| |$libFile|)) - (PROGN - (EMBED 'RWRITE - '(LAMBDA (KEY VALUE STREAM) - (COND - ((AND (EQ STREAM |$libFile|) - (NOT (MEMBER KEY |$saveableItems|))) - VALUE) - ((NOT NIL) (RWRITE KEY VALUE STREAM))))) - (UNWIND-PROTECT - (|compilerDoit| |constructor| |fun|) - (UNEMBED 'RWRITE)))) - -\end{chunk} -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index 7f7118a..9e85239 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -2206,16 +2206,9 @@ do the compile, and then rename the result back to code.o. (def-boot-val |$EmptyEnvironment| '((NIL)) "???") (def-boot-val |$EmptyList| () "???") \end{chunk} -\verb|$EmptyMode| is a contant whose value is \verb|$EmptyMode|. -It is used by isPartialMode (in i-funsel.boot) to -decide if a modemap is partially constructed. If the \verb|$EmptyMode| -constant occurs anywhere in the modemap structure at any depth -then the modemap is still incomplete. To find this constant the -isPartialMode function calls CONTAINED \verb|$EmptyMode| Y -which will walk the structure $Y$ looking for this constant. \begin{chunk}{*} -(def-boot-val |$EmptyMode| '|$EmptyMode| "compiler constant") -(def-boot-val |$EM| |$EmptyMode| "???") +;(def-boot-val |$EmptyMode| '|$EmptyMode| "compiler constant") +;(def-boot-val |$EM| |$EmptyMode| "???") (def-boot-val |$EmptyString| "" "???") (def-boot-val |$EmptyVector| '#() "???") (def-boot-val |$Expression| '(|Expression|) "???") @@ -2249,9 +2242,9 @@ which will walk the structure $Y$ looking for this constant. (def-boot-var |$hasYield| "???") (def-boot-var |$ignoreCommentsIfTrue| "???") (def-boot-var |$Index| "???") -(def-boot-val |$InitialDomainsInScope| - '((|Boolean|) |$EmptyMode| |$NoValueMode|) - "???") +;(def-boot-val |$InitialDomainsInScope| +; '((|Boolean|) |$EmptyMode| |$NoValueMode|) +; "???") (def-boot-var |$insideCapsuleFunctionIfTrue| "???") (def-boot-var |$insideCategoryIfTrue| "???") (def-boot-var |$insideCoerceInteractiveHardIfTrue| "???") @@ -2306,7 +2299,7 @@ which will walk the structure $Y$ looking for this constant. (def-boot-val |$NonPositiveIntegerOpt| '(|NonPositiveInteger| . OPT) "???") (def-boot-val |$NonPositiveInteger| '(|NonPositiveInteger|) "???") (def-boot-var |$noParseCommands| "???") -(def-boot-val |$NoValueMode| '|$NoValueMode| "compiler literal") +;(def-boot-val |$NoValueMode| '|$NoValueMode| "compiler literal") (def-boot-val |$NoValue| '|$NoValue| "compiler literal") (def-boot-val $num_of_meta_errors 0 "Number of errors seen so far") (def-boot-var $OLDLINE "Used to output command lines.") @@ -5886,8 +5879,8 @@ now the function is defined but does nothing. ))) )))) -(SETQ |$InitialDomainsInScope| - '(|$EmptyMode| |$NoValueMode|)) +;(SETQ |$InitialDomainsInScope| +; '(|$EmptyMode| |$NoValueMode|)) (SETQ |$NRTflag| T) (SETQ |$NRTaddForm| NIL) diff --git a/src/lib/cfuns-c.c.pamphlet b/src/lib/cfuns-c.c.pamphlet index 846a74c..92a4d77 100644 --- a/src/lib/cfuns-c.c.pamphlet +++ b/src/lib/cfuns-c.c.pamphlet @@ -123,10 +123,7 @@ int make_path_from_file(char *s, char *t) { @ This function is used in {\tt interp/fname.lisp} to support the {\tt myWriteable?} function, which is called by {\tt fnameWriteable?}. -Ultimately it is used in two places. First it supports a test called -{\tt writeable?} in {\tt algebra/fname.spad}. Second, it supports a -check in {\tt interp/compiler.boot} during the {\tt convertSpadToAsFile} -function. +It supports a test called {\tt writeable?} in {\tt algebra/fname.spad}. <<*>>= int writeablep(char *path) { struct stat buf;