diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet
index bf39800..f02a36f 100644
--- a/books/bookvol9.pamphlet
+++ b/books/bookvol9.pamphlet
@@ -4266,231 +4266,6 @@ leave it alone."
\end{chunk}
-\defvar{current-fragment}
-A string containing remaining chars from readline; needed because
-Symbolics read-line returns embedded newlines in a c-m-Y.
-\begin{chunk}{initvars}
-(defvar current-fragment nil)
-
-\end{chunk}
-
-\defun{read-a-line}{read-a-line}
-\calls{read-a-line}{subseq}
-\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* File-Closed))
- (if (and Current-Fragment (> (length Current-Fragment) 0))
- (let ((line (with-input-from-string
- (s Current-Fragment :index cp :start 0)
- (read-line s nil nil))))
- (setq Current-Fragment (subseq Current-Fragment cp))
- line)
- (prog nil
- (when (stream-eof in-stream)
- (setq File-Closed t)
- (setq *eof* t)
- (Line-New-Line (make-string 0) Current-Line)
- (return nil))
- (when (setq Current-Fragment (read-line stream))
- (return (read-a-line stream)))))))
-
-\end{chunk}
-
-\section{Line Handling}
-
-\subsection{Line Buffer}
-The philosophy of lines is that
-\begin{itemize}
-\item NEXT LINE will always return a non-blank line or fail.
-\item Every line is terminated by a blank character.
-\end{itemize}
-Hence there is always a current character, because there is never a
-non-blank line, and there is always a separator character between tokens
-on separate lines. Also, when a line is read, the character pointer is
-always positioned ON the first character.
-\defstruct{line}
-\begin{chunk}{initvars}
-(defstruct line "Line of input file to parse."
- (buffer (make-string 0) :type string)
- (current-char #\Return :type character)
- (current-index 1 :type fixnum)
- (last-index 0 :type fixnum)
- (number 0 :type fixnum))
-
-\end{chunk}
-
-\defvar{current-line}
-The current input line.
-\begin{chunk}{initvars}
-(defvar current-line (make-line))
-
-\end{chunk}
-
-
-\defmacro{line-clear}
-\usesstruct{line-clear}{line}
-\begin{chunk}{defmacro line-clear}
-(defmacro line-clear (line)
- `(let ((l ,line))
- (setf (line-buffer l) (make-string 0))
- (setf (line-current-char l) #\return)
- (setf (line-current-index l) 1)
- (setf (line-last-index l) 0)
- (setf (line-number l) 0)))
-
-\end{chunk}
-
-\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))))
-
-\end{chunk}
-
-\defun{line-at-end-p}{line-at-end-p}
-\usesstruct{line-at-end-p}{line}
-\begin{chunk}{defun line-at-end-p}
-(defun line-at-end-p (line)
- "Tests if line is empty or positioned past the last character."
- (>= (line-current-index line) (line-last-index line)))
-
-\end{chunk}
-
-\defun{line-past-end-p}{line-past-end-p}
-\usesstruct{line-past-end-p}{line}
-\begin{chunk}{defun line-past-end-p}
-(defun line-past-end-p (line)
- "Tests if line is empty or positioned past the last character."
- (> (line-current-index line) (line-last-index line)))
-
-\end{chunk}
-
-\defun{line-next-char}{line-next-char}
-\usesstruct{line-next-char}{line}
-\begin{chunk}{defun line-next-char}
-(defun line-next-char (line)
- (elt (line-buffer line) (1+ (line-current-index line))))
-
-\end{chunk}
-
-\defun{line-advance-char}{line-advance-char}
-\usesstruct{line-advance-char}{line}
-\begin{chunk}{defun line-advance-char}
-(defun line-advance-char (line)
- (setf (line-current-char line)
- (elt (line-buffer line) (incf (line-current-index line)))))
-
-\end{chunk}
-
-\defun{line-current-segment}{line-current-segment}
-\usesstruct{line-print}{line}
-\begin{chunk}{defun line-current-segment}
-(defun line-current-segment (line)
- "Buffer from current index to last index."
- (if (line-at-end-p line)
- (make-string 0)
- (subseq (line-buffer line)
- (line-current-index line)
- (line-last-index line))))
-
-\end{chunk}
-
-\defun{line-new-line}{line-new-line}
-\usesstruct{line-new-line}{line}
-\begin{chunk}{defun line-new-line}
-(defun line-new-line (string line &optional (linenum nil))
- "Sets string to be the next line stored in line."
- (setf (line-last-index line) (1- (length string)))
- (setf (line-current-index line) 0)
- (setf (line-current-char line)
- (or (and (> (length string) 0) (elt string 0)) #\Return))
- (setf (line-buffer line) string)
- (setf (line-number line) (or linenum (1+ (line-number 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}
-
-\defun{Advance-Char}{Advance-Char}
-\calls{Advance-Char}{Line-At-End-P}
-\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))
- (return (Line-Advance-Char Current-Line)))
- ((next-line in-stream)
- (return (current-char)))
- ((return nil)))))
-
-\end{chunk}
-
-\defun{storeblanks}{storeblanks}
-\begin{chunk}{defun storeblanks}
-(defun storeblanks (line n)
- (do ((i 0 (1+ i)))
- ((= i n) line)
- (setf (char line i) #\ )))
-
-\end{chunk}
-
-\defun{initial-substring}{initial-substring}
-\calls{initial-substring}{mismatch}
-\begin{chunk}{defun initial-substring}
-(defun initial-substring (pattern line)
- (let ((ind (mismatch pattern line)))
- (or (null ind) (eql ind (size pattern)))))
-
-\end{chunk}
-
-\defun{get-a-line}{get-a-line}
-\calls{get-a-line}{is-console}
-\seebook{get-a-line}{mkprompt}{5}
-\calls{get-a-line}{read-a-line}
-\calls{get-a-line}{make-string-adjustable}
-\begin{chunk}{defun get-a-line}
-(defun get-a-line (stream)
- (when (is-console stream) (princ (mkprompt)))
- (let ((ll (read-a-line stream)))
- (if (stringp ll)
- (make-string-adjustable ll)
- ll)))
-
-\end{chunk}
-
-\defun{make-string-adjustable}{make-string-adjustable}
-\begin{chunk}{defun make-string-adjustable}
-(defun make-string-adjustable (s)
- (if (adjustable-array-p s)
- s
- (make-array (array-dimensions s) :element-type 'string-char
- :adjustable t :initial-contents s)))
-
-\end{chunk}
-
\subsection{Parsing stack}
\defstruct{stack}
\begin{chunk}{initvars}
@@ -6417,7 +6192,7 @@ $\rightarrow$
(|get| op '|isCategory| |$CategoryFrame|))
(cons op
(loop for x in argl
- collect (|quotifyCategoryArgument| x))))
+ collect (mkq x))))
(t
(setq tmp1 (|compOrCroak| c |$EmptyMode| |$e|))
(setq x (car tmp1))
@@ -6596,6 +6371,317 @@ $\rightarrow$
\end{chunk}
+\defun{compile}{compile}
+\calls{compile}{member}
+\calls{compile}{getmode}
+\calls{compile}{pairp}
+\calls{compile}{qcar}
+\calls{compile}{qcdr}
+\calls{compile}{get}
+\calls{compile}{modeEqual}
+\calls{compile}{userError}
+\calls{compile}{encodeItem}
+\calls{compile}{strconc}
+\calls{compile}{encodeItem}
+\calls{compile}{isPackageFunction}
+\calls{compile}{nequal}
+\calls{compile}{kar}
+\calls{compile}{encodeFunctionName}
+\calls{compile}{splitEncodedFunctionName}
+\calls{compile}{sayBrightly}
+\calls{compile}{optimizeFunctionDef}
+\calls{compile}{putInLocalDomainReferences}
+\calls{compile}{constructMacro}
+\calls{compile}{spadCompileOrSetq}
+\calls{compile}{elapsedTime}
+\calls{compile}{addStats}
+\calls{compile}{printStats}
+\refsdollar{compile}{functionStats}
+\refsdollar{compile}{macroIfTrue}
+\refsdollar{compile}{doNotCompileJustPrint}
+\refsdollar{compile}{insideCapsuleFunctionIfTrue}
+\refsdollar{compile}{saveableItems}
+\refsdollar{compile}{lisplibItemsAlreadyThere}
+\refsdollar{compile}{splitUpItemsAlreadyThere}
+\refsdollar{compile}{lisplib}
+\refsdollar{compile}{compileOnlyCertainItems}
+\refsdollar{compile}{functorForm}
+\refsdollar{compile}{signatureOfForm}
+\refsdollar{compile}{suffix}
+\refsdollar{compile}{prefix}
+\refsdollar{compile}{signatureOfForm}
+\refsdollar{compile}{e}
+\defsdollar{compile}{functionStats}
+\defsdollar{compile}{savableItems}
+\defsdollar{compile}{suffix}
+\begin{chunk}{defun compile}
+(defun |compile| (u)
+ (labels (
+ (isLocalFunction (op)
+ (let (tmp1)
+ (declare (special |$e| |$formalArgList|))
+ (and (null (|member| op |$formalArgList|))
+ (progn
+ (setq tmp1 (|getmode| op |$e|))
+ (and (pairp tmp1) (eq (qcar tmp1) '|Mapping|)))))))
+ (let (op lamExpr DC sig sel opexport opmodes opp parts s tt unew
+ optimizedBody stuffToCompile result functionStats)
+ (declare (special |$functionStats| |$macroIfTrue| |$doNotCompileJustPrint|
+ |$insideCapsuleFunctionIfTrue| |$saveableItems| |$e|
+ |$lisplibItemsAlreadyThere| |$splitUpItemsAlreadyThere|
+ |$compileOnlyCertainItems| $LISPLIB |$suffix|
+ |$signatureOfForm| |$functorForm| |$prefix|
+ |$savableItems|))
+ (setq op (first u))
+ (setq lamExpr (second u))
+ (when |$suffix|
+ (setq |$suffix| (1+ |$suffix|))
+ (setq opp
+ (progn
+ (setq opexport nil)
+ (setq opmodes
+ (loop for item in (|get| op '|modemap| |$e|)
+ do
+ (setq dc (caar item))
+ (setq sig (cdar item))
+ (setq sel (cadadr item))
+ when (and (eq dc '$)
+ (setq opexport t)
+ (let ((result t))
+ (loop for x in sig for y in |$signatureOfForm|
+ do (setq result (|modeEqual| x y)))
+ result))
+ collect sel))
+ (cond
+ ((isLocalFunction op)
+ (when opexport
+ (|userError| (list '|%b| op '|%d| " is local and exported")))
+ (intern (strconc (|encodeItem| |$prefix|) ";" (|encodeItem| op))))
+ ((and (|isPackageFunction|)
+ (nequal (kar |$functorForm|) '|CategoryDefaults|))
+ (when (null opmodes) (|userError| (list "no modemap for " op)))
+ (cond
+ ((and (pairp opmodes) (eq (qcdr opmodes) nil) (pairp (qcar opmodes))
+ (eq (qcar (qcar opmodes)) 'pac) (pairp (qcdr (qcar opmodes)))
+ (pairp (qcdr (qcdr (qcar opmodes))))
+ (eq (qcdr (qcdr (qcdr (qcar opmodes)))) nil))
+ (qcar (qcdr (qcdr (qcar opmodes)))))
+ (t
+ (|encodeFunctionName| op |$functorForm| |$signatureOfForm|
+ '|;| |$suffix|))))
+ (t
+ (|encodeFunctionName| op |$functorForm| |$signatureOfForm|
+ '|;| |$suffix|)))))
+ (setq u (list opp lamExpr)))
+ (when (and $lisplib |$compileOnlyCertainItems|)
+ (setq parts (|splitEncodedFunctionName| (elt u 0) '|;|))
+ (cond
+ ((eq parts '|inner|)
+ (setq |$savableItems| (cons (elt u 0) |$savableItems|)))
+ (t
+ (setq unew nil)
+ (loop for item in |$splitUpItemsAlreadyThere|
+ do
+ (setq s (first item))
+ (setq tt (second item))
+ (when
+ (and (equal (elt parts 0) (elt s 0))
+ (equal (elt parts 1) (elt s 1))
+ (equal (elt parts 2) (elt s 2)))
+ (setq unew tt)))
+ (cond
+ ((null unew)
+ (|sayBrightly| (list " Error: Item did not previously exist"))
+ (|sayBrightly| (cons " Item not saved: " (|bright| (elt u 0))))
+ (|sayBrightly|
+ (list " What's there is: " |$lisplibItemsAlreadyThere|))
+ nil)
+ (t
+ (|sayBrightly| (list " Renaming " (elt u 0) " as " unew))
+ (setq u (cons unew (cdr u)))
+ (setq |$savableItems| (cons unew |$saveableItems|)))))))
+ (setq optimizedBody (|optimizeFunctionDef| u))
+ (setq stuffToCompile
+ (if |$insideCapsuleFunctionIfTrue|
+ (|putInLocalDomainReferences| optimizedBody)
+ optimizedBody))
+ (cond
+ ((eq |$doNotCompileJustPrint| t)
+ (prettyprint stuffToCompile)
+ opp)
+ (|$macroIfTrue| (|constructMacro| stuffToCompile))
+ (t
+ (setq result (|spadCompileOrSetq| stuffToCompile))
+ (setq functionStats (list 0 (|elapsedTime|)))
+ (setq |$functionStats| (|addStats| |$functionStats| functionStats))
+ (|printStats| functionStats)
+ result)))))
+
+\end{chunk}
+
+\defun{constructMacro}{constructMacro}
+constructMacro (form is [nam,[lam,vl,body]])
+\calls{constructMacro}{stackSemanticError}
+\calls{constructMacro}{identp}
+\begin{chunk}{defun constructMacro}
+(defun |constructMacro| (form)
+ (let (vl body)
+ (setq vl (cadadr form))
+ (setq body (car (cddadr form)))
+ (cond
+ ((null (let ((result t))
+ (loop for x in vl
+ do (setq result (and result (atom x))))
+ result))
+ (|stackSemanticError| (list '|illegal parameters for macro: | vl) nil))
+ (t
+ (list 'xlam (loop for x in vl when (identp x) collect x) body)))))
+
+\end{chunk}
+
+\defun{spadCompileOrSetq}{spadCompileOrSetq}
+\calls{spadCompileOrSetq}{pairp}
+\calls{spadCompileOrSetq}{qcar}
+\calls{spadCompileOrSetq}{qcdr}
+\calls{spadCompileOrSetq}{contained}
+\calls{spadCompileOrSetq}{sayBrightly}
+\calls{spadCompileOrSetq}{bright}
+\calls{spadCompileOrSetq}{LAM,EVALANDFILEACTQ}
+\calls{spadCompileOrSetq}{mkq}
+\calls{spadCompileOrSetq}{comp}
+\calls{spadCompileOrSetq}{compileConstructor}
+\refsdollar{spadCompileOrSetq}{insideCapsuleFunctionIfTrue}
+\begin{chunk}{defun spadCompileOrSetq}
+(defun |spadCompileOrSetq| (form)
+ (let (nam lam vl body namp tmp1 e vlp macform)
+ (declare (special |$insideCapsuleFunctionIfTrue|))
+ (setq nam (car form))
+ (setq lam (caadr form))
+ (setq vl (cadadr form))
+ (setq body (car (cddadr form)))
+ (cond
+ ((contained (intern " " "BOOT") body)
+ (|sayBrightly| (cons " " (append (|bright| nam) (list " not compiled")))))
+ (t
+ (cond
+ ((and (pairp vl) (progn (setq tmp1 (reverse vl)) t)
+ (pairp tmp1)
+ (progn
+ (setq e (qcar tmp1))
+ (setq vlp (qcdr tmp1))
+ t)
+ (progn (setq vlp (nreverse vlp)) t)
+ (pairp body)
+ (progn (setq namp (qcar body)) t)
+ (equal (qcdr body) vlp))
+ (|LAM,EVALANDFILEACTQ|
+ (list 'put (mkq nam) (mkq '|SPADreplace|) (mkq namp)))
+ (|sayBrightly|
+ (cons " " (append (|bright| nam)
+ (cons "is replaced by" (|bright| namp))))))
+ ((and (or (atom body)
+ (let ((result t))
+ (loop for x in body
+ do (setq result (and result (atom x))))
+ result))
+ (pairp vl)
+ (progn (setq tmp1 (reverse vl)) t)
+ (pairp tmp1)
+ (progn
+ (setq e (qcar tmp1))
+ (setq vlp (qcdr tmp1))
+ t)
+ (progn (setq vlp (nreverse vlp)) t)
+ (null (contained e body)))
+ (setq macform (list 'xlam vlp body))
+ (|LAM,EVALANDFILEACTQ|
+ (list 'put (mkq nam) (mkq '|SPADreplace|) (mkq macform)))
+ (|sayBrightly| (cons " " (append (|bright| nam)
+ (cons "is replaced by" (|bright| body))))))
+ (t nil))
+ (if |$insideCapsuleFunctionIfTrue|
+ (car (comp (list form)))
+ (|compileConstructor| form))))))
+
+\end{chunk}
+
+\defun{compileConstructor}{compileConstructor}
+\calls{compileConstructor}{compileConstructor1}
+\calls{compileConstructor}{clearClams}
+\begin{chunk}{defun compileConstructor}
+(defun |compileConstructor| (form)
+ (let (u)
+ (setq u (|compileConstructor1| form))
+ (|clearClams|)
+ u))
+
+\end{chunk}
+
+\defun{compileConstructor1}{compileConstructor1}
+\calls{compileConstructor1}{getdatabase}
+\calls{compileConstructor1}{compAndDefine}
+\calls{compileConstructor1}{comp}
+\calls{compileConstructor1}{clearConstructorCache}
+\refsdollar{compileConstructor1}{mutableDomain}
+\refsdollar{compileConstructor1}{ConstructorCache}
+\refsdollar{compileConstructor1}{clamList}
+\defsdollar{compileConstructor1}{clamList}
+\begin{chunk}{defun compileConstructor1}
+(defun |compileConstructor1| (form)
+ (let (|$clamList| fn key vl bodyl lambdaOrSlam compForm u)
+ (declare (special |$clamList| |$ConstructorCache| |$mutableDomain|))
+ (setq fn (car form))
+ (setq key (caadr form))
+ (setq vl (cadadr form))
+ (setq bodyl (cddadr form))
+ (setq |$clamList| nil)
+ (setq lambdaOrSlam
+ (cond
+ ((eq (getdatabase fn 'constructorkind) '|category|) 'spadslam)
+ (|$mutableDomain| 'lambda)
+ (t
+ (setq |$clamList|
+ (cons (list fn '|$ConstructorCache| '|domainEqualList| '|count|)
+ |$clamList|))
+ 'lambda)))
+ (setq compForm (list (list fn (cons lambdaorslam (cons vl bodyl)))))
+ (if (eq (getdatabase fn 'constructorkind) '|category|)
+ (setq u (|compAndDefine| compForm))
+ (setq u (comp compForm)))
+ (|clearConstructorCache| fn)
+ (car u)))
+
+\end{chunk}
+
+\defun{putInLocalDomainReferences}{putInLocalDomainReferences}
+\calls{putInLocalDomainReferences}{NRTputInTail}
+\refsdollar{putInLocalDomainReferences}{QuickCode}
+\defsdollar{putInLocalDomainReferences}{elt}
+\begin{chunk}{defun putInLocalDomainReferences}
+(defun |putInLocalDomainReferences| (def)
+ (let (|$elt| opName lam varl body)
+ (declare (special |$elt| |$QuickCode|))
+ (setq opName (car def))
+ (setq lam (caadr def))
+ (setq varl (cadadr def))
+ (setq body (car (cddadr def)))
+ (setq |$elt| (if |$QuickCode| 'qrefelt 'elt))
+ (|NRTputInTail| (cddadr def))
+ def))
+
+\end{chunk}
+
+\defun{getArgumentModeOrMoan}{getArgumentModeOrMoan}
+\calls{getArgumentModeOrMoan}{getArgumentMode}
+\calls{getArgumentModeOrMoan}{stackSemanticError}
+\begin{chunk}{defun getArgumentModeOrMoan}
+(defun |getArgumentModeOrMoan| (x form env)
+ (or (|getArgumentMode| x env)
+ (|stackSemanticError|
+ (list '|argument | x '| of | form '| is not declared|) nil)))
+
+\end{chunk}
+
\defun{augLisplibModemapsFromCategory}{augLisplibModemapsFromCategory}
\calls{augLisplibModemapsFromCategory}{sublis}
\calls{augLisplibModemapsFromCategory}{mkAlistOfExplicitCategoryOps}
@@ -7676,6 +7762,23 @@ where item has form
\end{chunk}
+\defun{compMakeCategoryObject}{compMakeCategoryObject}
+\calls{compMakeCategoryObject}{isCategoryForm}
+\calls{compMakeCategoryObject}{mkEvalableCategoryForm}
+\refsdollar{compMakeCategoryObject}{e}
+\refsdollar{compMakeCategoryObject}{Category}
+\begin{chunk}{defun compMakeCategoryObject}
+(defun |compMakeCategoryObject| (c |$e|)
+ (declare (special |$e|))
+ (let (u)
+ (declare (special |$Category|))
+ (cond
+ ((null (|isCategoryForm| c |$e|)) nil)
+ ((setq u (|mkEvalableCategoryForm| c)) (list (|eval| u) |$Category| |$e|))
+ (t nil))))
+
+\end{chunk}
+
\defun{mergeSignatureAndLocalVarAlists}{mergeSignatureAndLocalVarAlists}
\calls{mergeSignatureAndLocalVarAlists}{lassoc}
\begin{chunk}{defun mergeSignatureAndLocalVarAlists}
@@ -7721,7 +7824,6 @@ where item has form
\defun{compDefineFunctor1}{compDefineFunctor1}
\calls{compDefineFunctor1}{isCategoryPackageName}
\calls{compDefineFunctor1}{getArgumentModeOrMoan}
-\calls{compDefineFunctor1}{modemap2Signature}
\calls{compDefineFunctor1}{getModemap}
\calls{compDefineFunctor1}{giveFormalParametersValues}
\calls{compDefineFunctor1}{compMakeCategoryObject}
@@ -7923,7 +8025,7 @@ where item has form
(setq |$form| (cons |$op| argl))
(setq |$functorForm| |$form|)
(unless (car signaturep)
- (setq signaturep (|modemap2Signature| (|getModemap| |$form| |$e|))))
+ (setq signaturep (cdar (|getModemap| |$form| |$e|))))
(setq target (first signaturep))
(setq |$functorTarget| target)
(setq |$e| (|giveFormalParametersValues| argl |$e|))
@@ -8218,6 +8320,22 @@ where item has form
\end{chunk}
+\defun{bootStrapError}{bootStrapError}
+\calls{bootStrapError}{mkq}
+\calls{bootStrapError}{namestring}
+\calls{bootStrapError}{mkDomainConstructor}
+\begin{chunk}{defun bootStrapError}
+(defun |bootStrapError| (functorForm sourceFile)
+ (list 'cond
+ (list '|$bootStrapMode|
+ (list 'vector (|mkDomainConstructor| functorForm) nil nil nil nil nil))
+ (list ''t
+ (list '|systemError|
+ (list 'list ''|%b| (MKQ (CAR functorForm)) ''|%d| "from" ''|%b|
+ (mkq (|namestring| sourceFile)) ''|%d| "needs to be compiled")))))
+
+\end{chunk}
+
\defun{reportOnFunctorCompilation}{reportOnFunctorCompilation}
\calls{reportOnFunctorCompilation}{displayMissingFunctions}
\calls{reportOnFunctorCompilation}{sayBrightly}
@@ -8653,6 +8771,46 @@ where item has form
\end{chunk}
+\defun{orderByDependency}{orderByDependency}
+\calls{orderByDependency}{say}
+\calls{orderByDependency}{userError}
+\calls{orderByDependency}{intersection}
+\calls{orderByDependency}{member}
+\calls{orderByDependency}{remdup}
+\begin{chunk}{defun orderByDependency}
+(defun |orderByDependency| (vl dl)
+ (let (selfDependents fatalError newl orderedVarList vlp dlp)
+ (setq selfDependents
+ (loop for v in vl for d in dl
+ when (member v d)
+ collect v))
+ (loop for v in vl for d in dl
+ when (member v d)
+ do (say v "depends on itself")
+ (setq fatalError t))
+ (cond
+ (fatalError (|userError| "Parameter specification error"))
+ (t
+ (loop until (null vl) do
+ (setq newl
+ (loop for v in vl for d in dl
+ when (null (|intersection| d vl))
+ collect v))
+ (if (null newl)
+ (setq vl nil) ; force loop exit
+ (progn
+ (setq orderedVarList (append newl orderedVarList))
+ (setq vlp (setdifference vl newl))
+ (setq dlp
+ (loop for x in vl for d in dl
+ when (|member| x vlp)
+ collect (setdifference d newl)))
+ (setq vl vlp)
+ (setq dl dlp))))
+ (when (and newl orderedVarList) (remdup (nreverse orderedVarList)))))))
+
+\end{chunk}
+
\section{Functions to manipulate modemaps}
\defun{addDomain}{addDomain}
@@ -9037,43 +9195,6 @@ The way XLAMs work:
\end{chunk}
-\defun{addModemapKnown}{addModemapKnown}
-\calls{addModemapKnown}{addModemap0}
-\refsdollar{addModemapKnown}{e}
-\refsdollar{CapsuleModemapFrame}{insideCapsuleFunctionIfTrue}
-\defsdollar{addModemapKnown}{CapsuleModemapFrame}
-\begin{chunk}{defun addModemapKnown}
-(defun |addModemapKnown| (op mc sig pred fn |$e|)
- (declare (special |$e| |$CapsuleModemapFrame| |$insideCapsuleFunctionIfTrue|))
- (if (eq |$insideCapsuleFunctionIfTrue| t)
- (progn
- (setq |$CapsuleModemapFrame|
- (|addModemap0| op mc sig pred fn |$CapsuleModemapFrame|))
- |$e|)
- (|addModemap0| op mc sig pred fn |$e|)))
-
-\end{chunk}
-
-\defun{addModemap0}{addModemap0}
-\calls{addModemap0}{pairp}
-\calls{addModemap0}{qcar}
-\calls{addModemap0}{addEltModemap}
-\calls{addModemap0}{addModemap1}
-\refsdollar{addModemap0}{functorForm}
-\begin{chunk}{defun addModemap0}
-(defun |addModemap0| (op mc sig pred fn env)
- (declare (special |$functorForm|))
- (cond
- ((and (pairp |$functorForm|)
- (eq (qcar |$functorForm|) '|CategoryDefaults|)
- (eq mc '$))
- env)
- ((or (eq op '|elt|) (eq op '|setelt|))
- (|addEltModemap| op mc sig pred fn env))
- (t (|addModemap1| op mc sig pred fn env))))
-
-\end{chunk}
-
\defun{addEltModemap}{addEltModemap}
This is a hack to change selectors from strings to identifiers; and to
add flag identifiers as literals in the environment
@@ -9118,29 +9239,6 @@ add flag identifiers as literals in the environment
\end{chunk}
-\defun{addModemap1}{addModemap1}
-\calls{addModemap1}{msubst}
-\calls{addModemap1}{getProplist}
-\calls{addModemap1}{mkNewModemapList}
-\calls{addModemap1}{lassoc}
-\calls{addModemap1}{augProplist}
-\calls{addModemap1}{unErrorRef}
-\calls{addModemap1}{addBinding}
-\begin{chunk}{defun addModemap1}
-(defun |addModemap1| (op mc sig pred fn env)
- (let (currentProplist newModemapList newProplist newProplistp)
- (when (eq mc '|Rep|) (setq sig (msubst '$ '|Rep| sig)))
- (setq currentProplist (or (|getProplist| op env) nil))
- (setq newModemapList
- (|mkNewModemapList| mc sig pred fn
- (lassoc '|modemap| currentProplist) env nil))
- (setq newProplist (|augProplist| currentProplist '|modemap| newModemapList))
- (setq newProplistp (|augProplist| newProplist 'fluid t))
- (|unErrorRef| op)
- (|addBinding| op newProplistp env)))
-
-\end{chunk}
-
\defun{mkNewModemapList}{mkNewModemapList}
\calls{mkNewModemapList}{member}
\calls{mkNewModemapList}{assoc}
@@ -9245,6 +9343,19 @@ add flag identifiers as literals in the environment
\end{chunk}
+\defun{TruthP}{TruthP}
+\calls{TruthP}{qcar}
+\calls{TruthP}{pairp}
+\begin{chunk}{defun TruthP}
+(defun |TruthP| (x)
+ (cond
+ ((null x) nil)
+ ((eq x t) t)
+ ((and (pairp x) (eq (qcar x) 'quote)) t)
+ (t nil)))
+
+\end{chunk}
+
\defun{evalAndSub}{evalAndSub}
\calls{evalAndSub}{isCategory}
\calls{evalAndSub}{substNames}
@@ -9399,6 +9510,103 @@ add flag identifiers as literals in the environment
\end{chunk}
+\section{Maintaining Modemaps}
+\defun{addModemapKnown}{addModemapKnown}
+\calls{addModemapKnown}{addModemap0}
+\refsdollar{addModemapKnown}{e}
+\refsdollar{CapsuleModemapFrame}{insideCapsuleFunctionIfTrue}
+\defsdollar{addModemapKnown}{CapsuleModemapFrame}
+\begin{chunk}{defun addModemapKnown}
+(defun |addModemapKnown| (op mc sig pred fn |$e|)
+ (declare (special |$e| |$CapsuleModemapFrame| |$insideCapsuleFunctionIfTrue|))
+ (if (eq |$insideCapsuleFunctionIfTrue| t)
+ (progn
+ (setq |$CapsuleModemapFrame|
+ (|addModemap0| op mc sig pred fn |$CapsuleModemapFrame|))
+ |$e|)
+ (|addModemap0| op mc sig pred fn |$e|)))
+
+\end{chunk}
+
+\defun{addModemap}{addModemap}
+\calls{addModemap}{addModemap0}
+\calls{addModemap}{knownInfo}
+\refsdollar{addModemap}{e}
+\refsdollar{addModemap}{InteractiveMode}
+\refsdollar{addModemap}{insideCapsuleFunctionIfTrue}
+\refsdollar{addModemap}{CapsuleModemapFrame}
+\defsdollar{addModemap}{CapsuleModemapFrame}
+\begin{chunk}{defun addModemap}
+;addModemap(op,mc,sig,pred,fn,$e) ==
+; $InteractiveMode => $e
+; if knownInfo pred then pred:=true
+; $insideCapsuleFunctionIfTrue=true =>
+; $CapsuleModemapFrame :=
+; addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame)
+; $e
+; addModemap0(op,mc,sig,pred,fn,$e)
+
+(defun |addModemap| (op mc sig pred fn |$e|)
+ (declare (special |$e| |$CapsuleModemapFrame| |$InteractiveMode|
+ |$insideCapsuleFunctionIfTrue|))
+ (cond
+ (|$InteractiveMode| |$e|)
+ (t
+ (when (|knownInfo| pred) (setq pred t))
+ (cond
+ ((eq |$insideCapsuleFunctionIfTrue| t)
+ (setq |$CapsuleModemapFrame|
+ (|addModemap0| op mc sig pred fn |$CapsuleModemapFrame|))
+ |$e|)
+ (t
+ (|addModemap0| op mc sig pred fn |$e|))))))
+
+\end{chunk}
+
+\defun{addModemap0}{addModemap0}
+\calls{addModemap0}{pairp}
+\calls{addModemap0}{qcar}
+\calls{addModemap0}{addEltModemap}
+\calls{addModemap0}{addModemap1}
+\refsdollar{addModemap0}{functorForm}
+\begin{chunk}{defun addModemap0}
+(defun |addModemap0| (op mc sig pred fn env)
+ (declare (special |$functorForm|))
+ (cond
+ ((and (pairp |$functorForm|)
+ (eq (qcar |$functorForm|) '|CategoryDefaults|)
+ (eq mc '$))
+ env)
+ ((or (eq op '|elt|) (eq op '|setelt|))
+ (|addEltModemap| op mc sig pred fn env))
+ (t (|addModemap1| op mc sig pred fn env))))
+
+\end{chunk}
+
+\defun{addModemap1}{addModemap1}
+\calls{addModemap1}{msubst}
+\calls{addModemap1}{getProplist}
+\calls{addModemap1}{mkNewModemapList}
+\calls{addModemap1}{lassoc}
+\calls{addModemap1}{augProplist}
+\calls{addModemap1}{unErrorRef}
+\calls{addModemap1}{addBinding}
+\begin{chunk}{defun addModemap1}
+(defun |addModemap1| (op mc sig pred fn env)
+ (let (currentProplist newModemapList newProplist newProplistp)
+ (when (eq mc '|Rep|) (setq sig (msubst '$ '|Rep| sig)))
+ (setq currentProplist (or (|getProplist| op env) nil))
+ (setq newModemapList
+ (|mkNewModemapList| mc sig pred fn
+ (lassoc '|modemap| currentProplist) env nil))
+ (setq newProplist (|augProplist| currentProplist '|modemap| newModemapList))
+ (setq newProplistp (|augProplist| newProplist 'fluid t))
+ (|unErrorRef| op)
+ (|addBinding| op newProplistp env)))
+
+\end{chunk}
+
+
\section{Indirect called comp routines}
In the {\bf compExpression} function there is the code:
\begin{verbatim}
@@ -9517,6 +9725,16 @@ in the body of the add.
\end{chunk}
+\defun{compTuple2Record}{compTuple2Record}
+\begin{chunk}{defun compTuple2Record}
+(defun |compTuple2Record| (u)
+ (let ((i 0))
+ (cons '|Record|
+ (loop for x in (rest u)
+ collect (list '|:| (incf i) x)))))
+
+\end{chunk}
+
\defplist{capsule}{compCapsule plist}
\begin{chunk}{postvars}
(eval-when (eval load)
@@ -9579,6 +9797,258 @@ in the body of the add.
\end{chunk}
+\defun{compCapsuleItems}{compCapsuleItems}
+The variable data appears to be unbound at runtime. Optimized
+code won't check for this but interpreted code fails. We should
+PROVE that data is unbound at runtime but have not done so yet.
+Rather than remove the code entirely (since there MIGHT be a
+path where it is used) we check for the runtime bound case and
+assign \verb|$myFunctorBody| if data has a value.
+
+The compCapsuleInner function in this file LOOKS like it sets
+data and expects code to manipulate the assigned data structure.
+Since we can't be sure we take the least disruptive course of action.
+
+\calls{compCapsuleItems}{compSingleCapsuleItem}
+\defsdollar{compCapsuleItems}{top-level}
+\defsdollar{compCapsuleItems}{myFunctorBody}
+\defsdollar{compCapsuleItems}{signatureOfForm}
+\defsdollar{compCapsuleItems}{suffix}
+\defsdollar{compCapsuleItems}{e}
+\refsdollar{compCapsuleItems}{pred}
+\refsdollar{compCapsuleItems}{e}
+\begin{chunk}{defun compCapsuleItems}
+(defun |compCapsuleItems| (itemlist |$predl| |$e|)
+ (declare (special |$predl| |$e|))
+ (let ($top_level |$myFunctorBody| |$signatureOfForm| |$suffix|)
+ (declare (special $top_level |$myFunctorBody| |$signatureOfForm| |$suffix|))
+ (setq $top_level nil)
+ (setq |$myFunctorBody| nil)
+ (when (boundp '|data|) (setq |$myFunctorBody| |data|))
+ (setq |$signatureOfForm| nil)
+ (setq |$suffix| 0)
+ (loop for item in itemlist do
+ (setq |$e| (|compSingleCapsuleItem| item |$predl| |$e|)))
+ |$e|))
+
+\end{chunk}
+
+;compSingleCapsuleItem(item,$predl,$e) ==
+; doIt(macroExpandInPlace(item,$e),$predl)
+; $e
+
+\defun{compSingleCapsuleItem}{compSingleCapsuleItem}
+\calls{compSingleCapsuleItem}{doit}
+\refsdollar{compSingleCapsuleItem}{pred}
+\refsdollar{compSingleCapsuleItem}{e}
+\calls{compSingleCapsuleItem}{macroExpandInPlace}
+\begin{chunk}{defun compSingleCapsuleItem}
+(defun |compSingleCapsuleItem| (item |$predl| |$e|)
+ (declare (special |$predl| |$e|))
+ (|doIt| (|macroExpandInPlace| item |$e|) |$predl|)
+ |$e|)
+
+\end{chunk}
+
+\defun{doIt}{doIt}
+\calls{doIt}{pairp}
+\calls{doIt}{qcar}
+\calls{doIt}{qcdr}
+\calls{doIt}{lastnode}
+\calls{doIt}{compSingleCapsuleItem}
+\calls{doIt}{isDomainForm}
+\calls{doIt}{stackWarning}
+\calls{doIt}{doIt}
+\calls{doIt}{compOrCroak}
+\calls{doIt}{stackSemanticError}
+\calls{doIt}{bright}
+\calls{doIt}{member}
+\calls{doIt}{kar}
+\calls{doIt}{|isFunctor}
+\calls{doIt}{insert}
+\calls{doIt}{opOf}
+\calls{doIt}{get}
+\calls{doIt}{NRTgetLocalIndex}
+\calls{doIt}{sublis}
+\calls{doIt}{NRTgetLocalIndexClear}
+\calls{doIt}{compOrCroak}
+\calls{doIt}{sayBrightly}
+\calls{doIt}{formatUnabbreviated}
+\calls{doIt}{doItIf}
+\calls{doIt}{isMacro}
+\calls{doIt}{put}
+\calls{doIt}{cannotDo}
+\refsdollar{doIt}{predl}
+\refsdollar{doIt}{e}
+\refsdollar{doIt}{EmptyMode}
+\refsdollar{doIt}{NonMentionableDomainNames}
+\refsdollar{doIt}{functorLocalParameters}
+\refsdollar{doIt}{functorsUsed}
+\refsdollar{doIt}{packagesUsed}
+\refsdollar{doIt}{NRTopt}
+\refsdollar{doIt}{Representation}
+\refsdollar{doIt}{LocalDomainAlist}
+\refsdollar{doIt}{QuickCode}
+\refsdollar{doIt}{signatureOfForm}
+\defsdollar{doIt}{genno}
+\defsdollar{doIt}{e}
+\defsdollar{doIt}{functorLocalParameters}
+\defsdollar{doIt}{functorsUsed}
+\defsdollar{doIt}{packagesUsed}
+\defsdollar{doIt}{Representation}
+\defsdollar{doIt}{LocalDomainAlist}
+\begin{chunk}{defun doIt}
+(defun |doIt| (item |$predl|)
+ (declare (special |$predl|))
+ (prog ($genno x rhs tmp3 lhsp lhs rhsp rhsCode a doms b z tmp1
+ tmp2 tmp6 op body tt functionPart u code)
+ (declare (special $genno |$e| |$EmptyMode| |$signatureOfForm|
+ |$QuickCode| |$LocalDomainAlist| |$Representation|
+ |$NRTopt| |$packagesUsed| |$functorsUsed|
+ |$functorLocalParameters| |$NonMentionableDomainNames|))
+ (setq $genno 0)
+ (cond
+ ((and (pairp item) (eq (qcar item) 'seq) (pairp (qcdr item))
+ (progn (setq tmp6 (reverse (qcdr item))) t)
+ (pairp tmp6) (pairp (qcar tmp6))
+ (eq (qcar (qcar tmp6)) '|exit|)
+ (pairp (qcdr (qcar tmp6)))
+ (equal (qcar (qcdr (qcar tmp6))) 1)
+ (pairp (qcdr (qcdr (qcar tmp6))))
+ (eq (qcdr (qcdr (qcdr (qcar tmp6)))) nil))
+ (setq x (qcar (qcdr (qcdr (qcar tmp6)))))
+ (setq z (qcdr tmp6))
+ (setq z (nreverse z))
+ (rplaca item 'progn)
+ (rplaca (lastnode item) x)
+ (loop for it1 in (rest item)
+ do (setq |$e| (|compSingleCapsuleItem| it1 |$predl| |$e|))))
+ ((|isDomainForm| item |$e|)
+ (setq u (list '|import| (cons (car item) (cdr item))))
+ (|stackWarning| (list '|Use: import | (cons (car item) (cdr item))))
+ (rplaca item (car u))
+ (rplacd item (cdr u))
+ (|doIt| item |$predl|))
+ ((and (pairp item) (eq (qcar item) 'let) (pairp (qcdr item))
+ (pairp (qcdr (qcdr item))))
+ (setq lhs (qcar (qcdr item)))
+ (setq rhs (qcar (qcdr (qcdr item))))
+ (cond
+ ((null (progn
+ (setq tmp2 (|compOrCroak| item |$EmptyMode| |$e|))
+ (and (pairp tmp2)
+ (progn
+ (setq code (qcar tmp2))
+ (and (pairp (qcdr tmp2))
+ (progn
+ (and (pairp (qcdr (qcdr tmp2)))
+ (eq (qcdr (qcdr (qcdr tmp2))) nil)
+ (PROGN
+ (setq |$e| (qcar (qcdr (qcdr tmp2))))
+ t))))))))
+ (|stackSemanticError|
+ (cons '|cannot compile assigned value to| (|bright| lhs))
+ nil))
+ ((null (and (pairp code) (eq (qcar code) 'let)
+ (progn
+ (and (pairp (qcdr code))
+ (progn
+ (setq lhsp (qcar (qcdr code)))
+ (and (pairp (qcdr (qcdr code)))))))
+ (atom (qcar (qcdr code)))))
+ (cond
+ ((and (pairp code) (eq (qcar code) 'progn))
+ (|stackSemanticError|
+ (list '|multiple assignment | item '| not allowed|)
+ nil))
+ (t
+ (rplaca item (car code))
+ (rplacd item (cdr code)))))
+ (t
+ (setq lhs lhsp)
+ (cond
+ ((and (null (|member| (kar rhs) |$NonMentionableDomainNames|))
+ (null (member lhs |$functorLocalParameters|)))
+ (setq |$functorLocalParameters|
+ (append |$functorLocalParameters| (list lhs)))))
+ (cond
+ ((and (pairp code) (eq (qcar code) 'let)
+ (progn
+ (setq tmp2 (qcdr code))
+ (and (pairp tmp2)
+ (progn
+ (setq tmp6 (qcdr tmp2))
+ (and (pairp tmp6)
+ (progn
+ (setq rhsp (qcar tmp6))
+ t)))))
+ (|isDomainForm| rhsp |$e|))
+ (cond
+ ((|isFunctor| rhsp)
+ (setq |$functorsUsed| (|insert| (|opOf| rhsp) |$functorsUsed|))
+ (setq |$packagesUsed| (|insert| (list (|opOf| rhsp))
+ |$packagesUsed|))))
+ (cond
+ ((eq lhs '|Rep|)
+ (setq |$Representation| (elt (|get| '|Rep| '|value| |$e|) 0))
+ (cond
+ ((eq |$NRTopt| t)
+ (|NRTgetLocalIndex| |$Representation|))
+ (t nil))))
+ (setq |$LocalDomainAlist|
+ (cons (cons lhs
+ (sublis |$LocalDomainAlist| (elt (|get| lhs '|value| |$e|) 0)))
+ |$LocalDomainAlist|))))
+ (cond
+ ((and (pairp code) (eq (qcar code) 'let))
+ (rplaca item (if |$QuickCode| 'qsetrefv 'setelt))
+ (setq rhsCode rhsp)
+ (rplacd item (list '$ (|NRTgetLocalIndexClear| lhs) rhsCode)))
+ (t
+ (rplaca item (car code))
+ (rplacd item (cdr code)))))))
+ ((and (pairp item) (eq (qcar item) '|:|) (pairp (qcdr item))
+ (pairp (qcdr (qcdr item))) (eq (qcdr (qcdr (qcdr item))) nil))
+ (setq tmp1 (|compOrCroak| item |$EmptyMode| |$e|))
+ (setq |$e| (caddr tmp1))
+ tmp1)
+ ((and (pairp item) (eq (qcar item) '|import|))
+ (loop for dom in (qcdr item)
+ do (|sayBrightly| (cons " importing " (|formatUnabbreviated| dom))))
+ (setq tmp1 (|compOrCroak| item |$EmptyMode| |$e|))
+ (setq |$e| (caddr tmp1))
+ (rplaca item 'progn)
+ (rplacd item nil))
+ ((and (pairp item) (eq (qcar item) 'if))
+ (|doItIf| item |$predl| |$e|))
+ ((and (pairp item) (eq (qcar item) '|where|) (pairp (qcdr item)))
+ (|compOrCroak| item |$EmptyMode| |$e|))
+ ((and (pairp item) (eq (qcar item) 'mdef))
+ (setq tmp1 (|compOrCroak| item |$EmptyMode| |$e|))
+ (setq |$e| (caddr tmp1)) tmp1)
+ ((and (pairp item) (eq (qcar item) 'def) (pairp (qcdr item))
+ (pairp (qcar (qcdr item))))
+ (setq op (qcar (qcar (qcdr item))))
+ (cond
+ ((setq body (|isMacro| item |$e|))
+ (setq |$e| (|put| op '|macro| body |$e|)))
+ (t
+ (setq tt (|compOrCroak| item |$EmptyMode| |$e|))
+ (setq |$e| (caddr tt))
+ (rplaca item '|CodeDefine|)
+ (rplacd (cadr item) (list |$signatureOfForm|))
+ (setq functionPart (list '|dispatchFunction| (car tt)))
+ (rplaca (cddr item) functionPart)
+ (rplacd (cddr item) nil))))
+ ((setq u (|compOrCroak| item |$EmptyMode| |$e|))
+ (setq code (car u))
+ (setq |$e| (caddr u))
+ (rplaca item (car code))
+ (rplacd item (cdr code)))
+ (t (|cannotDo|)))))
+
+\end{chunk}
+
\defplist{case}{compCase plist}
\begin{chunk}{postvars}
(eval-when (eval load)
@@ -10167,6 +10637,593 @@ An angry JHD - August 15th., 1984
\end{chunk}
+\defun{getSignatureFromMode}{getSignatureFromMode}
+\calls{getSignatureFromMode}{getmode}
+\calls{getSignatureFromMode}{opOf}
+\calls{getSignatureFromMode}{pairp}
+\calls{getSignatureFromMode}{qcar}
+\calls{getSignatureFromMode}{qcdr}
+\calls{getSignatureFromMode}{nequal}
+\calls{getSignatureFromMode}{length}
+\calls{getSignatureFromMode}{stackAndThrow}
+\calls{getSignatureFromMode}{eqsubstlist}
+\calls{getSignatureFromMode}{take}
+\refsdollar{getSignatureFromMode}{FormalMapVariableList}
+\begin{chunk}{defun getSignatureFromMode}
+(defun |getSignatureFromMode| (form env)
+ (let (tmp1 signature)
+ (declare (special |$FormalMapVariableList|))
+ (setq tmp1 (|getmode| (|opOf| form) env))
+ (when (and (pairp tmp1) (eq (qcar tmp1) '|Mapping|))
+ (setq signature (qcdr tmp1))
+ (if (nequal (|#| form) (|#| signature))
+ (|stackAndThrow| (list '|Wrong number of arguments: | form))
+ (eqsubstlist (cdr form)
+ (take (|#| (cdr form)) |$FormalMapVariableList|)
+ signature)))))
+
+\end{chunk}
+
+\defun{compInternalFunction}{compInternalFunction}
+\calls{compInternalFunction}{identp}
+\calls{compInternalFunction}{stackAndThrow}
+\begin{chunk}{defun compInternalFunction}
+(defun |compInternalFunction| (df m env)
+ (let (form signature specialCases body op argl nbody nf ress)
+ (setq form (second df))
+ (setq signature (third df))
+ (setq specialCases (fourth df))
+ (setq body (fifth df))
+ (setq op (first form))
+ (setq argl (rest form))
+ (cond
+ ((null (identp op))
+ (|stackAndThrow| (list '|Bad name for internal function:| op)))
+ ((eql (|#| argl) 0)
+ (|stackAndThrow|
+ (list '|Argumentless internal functions unsupported:| op )))
+ (t
+ (setq nbody (list '+-> argl body))
+ (setq nf (list 'let (list '|:| op (cons '|Mapping| signature)) nbody))
+ (setq ress (|comp| nf m env)) ress))))
+
+\end{chunk}
+
+\defun{compDefineCapsuleFunction}{compDefineCapsuleFunction}
+\calls{compDefineCapsuleFunction}{length}
+\calls{compDefineCapsuleFunction}{get}
+\calls{compDefineCapsuleFunction}{profileRecord}
+\calls{compDefineCapsuleFunction}{compArgumentConditions}
+\calls{compDefineCapsuleFunction}{addDomain}
+\calls{compDefineCapsuleFunction}{giveFormalParametersValues}
+\calls{compDefineCapsuleFunction}{getSignature}
+\calls{compDefineCapsuleFunction}{put}
+\calls{compDefineCapsuleFunction}{stripOffSubdomainConditions}
+\calls{compDefineCapsuleFunction}{getArgumentModeOrMoan}
+\calls{compDefineCapsuleFunction}{checkAndDeclare}
+\calls{compDefineCapsuleFunction}{hasSigInTargetCategory}
+\calls{compDefineCapsuleFunction}{stripOffArgumentConditions}
+\calls{compDefineCapsuleFunction}{resolve}
+\calls{compDefineCapsuleFunction}{member}
+\calls{compDefineCapsuleFunction}{getmode}
+\calls{compDefineCapsuleFunction}{formatUnabbreviated}
+\calls{compDefineCapsuleFunction}{sayBrightly}
+\calls{compDefineCapsuleFunction}{compOrCroak}
+\calls{compDefineCapsuleFunction}{NRTassignCapsuleFunctionSlot}
+\calls{compDefineCapsuleFunction}{mkq}
+\calls{compDefineCapsuleFunction}{replaceExitEtc}
+\calls{compDefineCapsuleFunction}{addArgumentConditions}
+\calls{compDefineCapsuleFunction}{compileCases}
+\calls{compDefineCapsuleFunction}{addStats}
+\refsdollar{compDefineCapsuleFunction}{semanticErrorStack}
+\refsdollar{compDefineCapsuleFunction}{DomainsInScope}
+\refsdollar{compDefineCapsuleFunction}{op}
+\refsdollar{compDefineCapsuleFunction}{formalArgList}
+\refsdollar{compDefineCapsuleFunction}{signatureOfForm}
+\refsdollar{compDefineCapsuleFunction}{functionLocations}
+\refsdollar{compDefineCapsuleFunction}{profileCompiler}
+\refsdollar{compDefineCapsuleFunction}{compileOnlyCertainItems}
+\refsdollar{compDefineCapsuleFunction}{returnMode}
+\refsdollar{compDefineCapsuleFunction}{functorStats}
+\refsdollar{compDefineCapsuleFunction}{functionStats}
+\defsdollar{compDefineCapsuleFunction}{form}
+\defsdollar{compDefineCapsuleFunction}{functionStats}
+\defsdollar{compDefineCapsuleFunction}{argumentConditionList}
+\defsdollar{compDefineCapsuleFunction}{finalEnv}
+\defsdollar{compDefineCapsuleFunction}{initCapsuleErrorCount}
+\defsdollar{compDefineCapsuleFunction}{insideCapsuleFunctionIfTrue}
+\defsdollar{compDefineCapsuleFunction}{CapsuleModemapFrame}
+\defsdollar{compDefineCapsuleFunction}{CapsuleDomainsInScope}
+\defsdollar{compDefineCapsuleFunction}{insideExpressionIfTrue}
+\defsdollar{compDefineCapsuleFunction}{returnMode}
+\defsdollar{compDefineCapsuleFunction}{op}
+\defsdollar{compDefineCapsuleFunction}{formalArgList}
+\defsdollar{compDefineCapsuleFunction}{signatureOfForm}
+\defsdollar{compDefineCapsuleFunction}{functionLocations}
+\begin{chunk}{defun compDefineCapsuleFunction}
+(defun |compDefineCapsuleFunction| (df m oldE |$prefix| |$formalArgList|)
+ (declare (special |$prefix| |$formalArgList|))
+ (let (|$form| |$op| |$functionStats| |$argumentConditionList| |$finalEnv|
+ |$initCapsuleErrorCount| |$insideCapsuleFunctionIfTrue|
+ |$CapsuleModemapFrame| |$CapsuleDomainsInScope|
+ |$insideExpressionIfTrue| form signature body tmp1 lineNumber
+ specialCases argl identSig argModeList signaturep e rettype tmp2
+ localOrExported formattedSig tt catchTag bodyp finalBody fun val)
+ (declare (special |$form| |$op| |$functionStats| |$functorStats|
+ |$argumentConditionList| |$finalEnv| |$returnMode|
+ |$initCapsuleErrorCount| |$newCompCompare| |$NoValueMode|
+ |$insideCapsuleFunctionIfTrue|
+ |$CapsuleModemapFrame| |$CapsuleDomainsInScope|
+ |$insideExpressionIfTrue| |$compileOnlyCertainItems|
+ |$profileCompiler| |$functionLocations| |$finalEnv|
+ |$signatureOfForm| |$semanticErrorStack|))
+ (setq form (second df))
+ (setq signature (third df))
+ (setq specialCases (fourth df))
+ (setq body (fifth df))
+ (setq tmp1 specialCases)
+ (setq lineNumber (first tmp1))
+ (setq specialCases (rest tmp1))
+ (setq e oldE)
+;-1. bind global variables
+ (setq |$form| nil)
+ (setq |$op| nil)
+ (setq |$functionStats| (list 0 0))
+ (setq |$argumentConditionList| nil)
+ (setq |$finalEnv| nil)
+; used by ReplaceExitEtc to get a common environment
+ (setq |$initCapsuleErrorCount| (|#| |$semanticErrorStack|))
+ (setq |$insideCapsuleFunctionIfTrue| t)
+ (setq |$CapsuleModemapFrame| e)
+ (setq |$CapsuleDomainsInScope| (|get| '|$DomainsInScope| 'special e))
+ (setq |$insideExpressionIfTrue| t)
+ (setq |$returnMode| m)
+ (setq |$op| (first form))
+ (setq argl (rest form))
+ (setq |$form| (cons |$op| argl))
+ (setq argl (|stripOffArgumentConditions| argl))
+ (setq |$formalArgList| (append argl |$formalArgList|))
+; let target and local signatures help determine modes of arguments
+ (setq argModeList
+ (cond
+ ((setq identSig (|hasSigInTargetCategory| argl form (car signature) e))
+ (setq e (|checkAndDeclare| argl form identSig e))
+ (cdr identSig))
+ (t
+ (loop for a in argl
+ collect (|getArgumentModeOrMoan| a form e)))))
+ (setq argModeList (|stripOffSubdomainConditions| argModeList argl))
+ (setq signaturep (cons (car signature) argModeList))
+ (unless identSig
+ (setq oldE (|put| |$op| '|mode| (cons '|Mapping| signaturep) oldE)))
+; obtain target type if not given
+ (cond
+ ((null (car signaturep))
+ (setq signaturep
+ (cond
+ (identSig identSig)
+ (t (|getSignature| |$op| (cdr signaturep) e))))))
+ (when signaturep
+ (setq e (|giveFormalParametersValues| argl e))
+ (setq |$signatureOfForm| signaturep)
+ (setq |$functionLocations|
+ (cons (cons (list |$op| |$signatureOfForm|) lineNumber)
+ |$functionLocations|))
+ (setq e (|addDomain| (car signaturep) e))
+ (setq e (|compArgumentConditions| e))
+ (when |$profileCompiler|
+ (loop for x in argl for y in signaturep
+ do (|profileRecord| '|arguments| x y)))
+; 4. introduce needed domains into extendedEnv
+ (loop for domain in signaturep
+ do (setq e (|addDomain| domain e)))
+; 6. compile body in environment with extended environment
+ (setq rettype (|resolve| (car signaturep) |$returnMode|))
+ (setq localOrExported
+ (cond
+ ((and (null (|member| |$op| |$formalArgList|))
+ (progn
+ (setq tmp2 (|getmode| |$op| e))
+ (and (pairp tmp2) (eq (qcar tmp2) '|Mapping|))))
+ '|local|)
+ (t '|exported|)))
+; 6a skip if compiling only certain items but not this one
+; could be moved closer to the top
+ (setq formattedSig (|formatUnabbreviated| (cons '|Mapping| signaturep)))
+ (cond
+ ((and |$compileOnlyCertainItems|
+ (null (|member| |$op| |$compileOnlyCertainItems|)))
+ (|sayBrightly|
+ (cons " skipping " (cons localOrExported (|bright| |$op|))))
+ (list nil (cons '|Mapping| signaturep) oldE))
+ (t
+ (|sayBrightly|
+ (cons " compiling " (cons localOrExported (append (|bright| |$op|)
+ (cons ": " formattedSig)))))
+ (setq tt
+ (or (catch '|compCapsuleBody| (|compOrCroak| body rettype e))
+ (list (intern " " "BOOT") rettype e)))
+ (|NRTassignCapsuleFunctionSlot| |$op| signaturep)
+; A THROW to the above CATCH occurs if too many semantic errors occur
+; see stackSemanticError
+ (setq catchTag (mkq (gensym)))
+ (setq fun
+ (progn
+ (setq bodyp
+ (|replaceExitEtc| (car tt) catchTag '|TAGGEDreturn| |$returnMode|))
+ (setq bodyp (|addArgumentConditions| bodyp |$op|))
+ (setq finalBody (list 'catch catchTag bodyp))
+ (|compileCases|
+ (list |$op| (list 'lam (append argl (list '$)) finalBody))
+ oldE)))
+ (setq |$functorStats| (|addStats| |$functorStats| |$functionStats|))
+; 7. give operator a 'value property
+ (setq val (list fun signaturep e))
+ (list fun (list '|Mapping| signaturep) oldE))))))
+
+\end{chunk}
+
+\defun{compileCases}{compileCases}
+\calls{compileCases}{eval}
+\calls{compileCases}{pairp}
+\calls{compileCases}{qcar}
+\calls{compileCases}{qcdr}
+\calls{compileCases}{msubst}
+\calls{compileCases}{compile}
+\calls{compileCases}{getSpecialCaseAssoc}
+\calls{compileCases}{get}
+\calls{compileCases}{assocleft}
+\calls{compileCases}{outerProduct}
+\calls{compileCases}{assocright}
+\calls{compileCases}{mkpf}
+\refsdollar{compileCases}{getDomainCode}
+\refsdollar{compileCases}{insideFunctorIfTrue}
+\defsdollar{compileCases}{specialCaseKeyList}
+\begin{chunk}{defun compileCases}
+(defun |compileCases| (x |$e|)
+ (declare (special |$e|))
+ (labels (
+ (isEltArgumentIn (Rlist x)
+ (cond
+ ((atom x) nil)
+ ((and (pairp x) (eq (qcar x) 'elt) (pairp (qcdr x))
+ (pairp (qcdr (qcdr x))) (eq (qcdr (qcdr (qcdr x))) nil))
+ (or (member (second x) Rlist)
+ (isEltArgumentIn Rlist (cdr x))))
+ ((and (pairp x) (eq (qcar x) 'qrefelt) (pairp (qcdr x))
+ (pairp (qcdr (qcdr x))) (eq (qcdr (qcdr (qcdr x))) nil))
+ (or (member (second x) Rlist)
+ (isEltArgumentIn Rlist (cdr x))))
+ (t
+ (or (isEltArgumentIn Rlist (car x))
+ (isEltArgumentIn Rlist (CDR x))))))
+ (FindNamesFor (r rp)
+ (let (v u)
+ (declare (special |$getDomainCode|))
+ (cons r
+ (loop for item in |$getDomainCode|
+ do
+ (setq v (second item))
+ (setq u (third item))
+ when (and (equal (second u) r) (|eval| (msubst rp r u)))
+ collect v)))))
+ (let (|$specialCaseKeyList| specialCaseAssoc listOfDomains listOfAllCases cl)
+ (declare (special |$specialCaseKeyList| |$true| |$insideFunctorIfTrue|))
+ (setq |$specialCaseKeyList| nil)
+ (cond
+ ((null (eq |$insideFunctorIfTrue| t)) (|compile| x))
+ (t
+ (setq specialCaseAssoc
+ (loop for y in (|getSpecialCaseAssoc|)
+ when (and (null (|get| (first y) '|specialCase| |$e|))
+ (isEltArgumentIn (FindNamesFor (first y) (second y)) x))
+ collect y))
+ (cond
+ ((null specialCaseAssoc) (|compile| x))
+ (t
+ (setq listOfDomains (assocleft specialCaseAssoc))
+ (setq listOfAllCases (|outerProduct| (assocright specialCaseAssoc)))
+ (setq cl
+ (loop for z in listOfAllCases
+ collect
+ (progn
+ (setq |$specialCaseKeyList|
+ (loop for d in listOfDomains for c in z
+ collect (cons d c)))
+ (cons
+ (mkpf
+ (loop for d in listOfDomains for c in z
+ collect (list 'equal d c))
+ 'and)
+ (list (|compile| (copy x)))))))
+ (setq |$specialCaseKeyList| nil)
+ (cons 'cond (append cl (list (list |$true| (|compile| x))))))))))))
+
+\end{chunk}
+
+\defun{getSpecialCaseAssoc}{getSpecialCaseAssoc}
+\refsdollar{getSpecialCaseAssoc}{functorForm}
+\refsdollar{getSpecialCaseAssoc}{functorSpecialCases}
+\begin{chunk}{defun getSpecialCaseAssoc}
+(defun |getSpecialCaseAssoc| ()
+ (declare (special |$functorSpecialCases| |$functorForm|))
+ (loop for r in (rest |$functorForm|)
+ for z in (rest |$functorSpecialCases|)
+ when z
+ collect (cons r z)))
+
+\end{chunk}
+
+\defun{addArgumentConditions}{addArgumentConditions}
+\calls{addArgumentConditions}{pairp}
+\calls{addArgumentConditions}{qcar}
+\calls{addArgumentConditions}{qcdr}
+\calls{addArgumentConditions}{mkq}
+\calls{addArgumentConditions}{systemErrorHere}
+\refsdollar{addArgumentConditions}{true}
+\refsdollar{addArgumentConditions}{functionName}
+\refsdollar{addArgumentConditions}{body}
+\refsdollar{addArgumentConditions}{argumentConditionList}
+\defsdollar{addArgumentConditions}{argumentConditionList}
+\begin{chunk}{defun addArgumentConditions}
+(defun |addArgumentConditions| (|$body| |$functionName|)
+ (declare (special |$body| |$functionName| |$argumentConditionList| |$true|))
+ (labels (
+ (fn (clist)
+ (let (n untypedCondition typedCondition)
+ (cond
+ ((and (pairp clist) (pairp (qcar clist)) (pairp (qcdr (qcar clist)))
+ (pairp (qcdr (qcdr (qcar clist))))
+ (eq (qcdr (qcdr (qcdr (qcar clist)))) nil))
+ (setq n (qcar (qcar clist)))
+ (setq untypedCondition (qcar (qcdr (qcar clist))))
+ (setq typedCondition (qcar (qcdr (qcdr (qcar clist)))))
+ (list 'cond
+ (list typedCondition (fn (cdr clist)))
+ (list |$true|
+ (list '|argumentDataError| n
+ (mkq untypedCondition) (mkq |$functionName|)))))
+ ((null clist) |$body|)
+ (t (|systemErrorHere| "addArgumentConditions"))))))
+ (if |$argumentConditionList|
+ (fn |$argumentConditionList|)
+ |$body|)))
+
+
+\end{chunk}
+
+\defun{compArgumentConditions}{compArgumentConditions}
+\calls{compArgumentConditions}{msubst}
+\calls{compArgumentConditions}{compOrCroak}
+\refsdollar{compArgumentConditions}{Boolean}
+\refsdollar{compArgumentConditions}{argumentConditionList}
+\defsdollar{compArgumentConditions}{argumentConditionList}
+\begin{chunk}{defun compArgumentConditions}
+(defun |compArgumentConditions| (env)
+ (let (n a x y tmp1)
+ (declare (special |$Boolean| |$argumentConditionList|))
+ (setq |$argumentConditionList|
+ (loop for item in |$argumentConditionList|
+ do
+ (setq n (first item))
+ (setq a (second item))
+ (setq x (third item))
+ (setq y (msubst a '|#1| x))
+ (setq tmp1 (|compOrCroak| y |$Boolean| env))
+ (setq env (third tmp1))
+ collect
+ (list n x (first tmp1))))
+ env))
+
+\end{chunk}
+
+\defun{stripOffSubdomainConditions}{stripOffSubdomainConditions}
+\calls{stripOffSubdomainConditions}{pairp}
+\calls{stripOffSubdomainConditions}{qcar}
+\calls{stripOffSubdomainConditions}{qcdr}
+\calls{stripOffSubdomainConditions}{assoc}
+\calls{stripOffSubdomainConditions}{mkpf}
+\refsdollar{stripOffSubdomainConditions}{argumentConditionList}
+\defsdollar{stripOffSubdomainConditions}{argumentConditionList}
+\begin{chunk}{defun stripOffSubdomainConditions}
+(defun |stripOffSubdomainConditions| (margl argl)
+ (let (pair (i 0))
+ (declare (special |$argumentConditionList|))
+ (loop for x in margl for arg in argl
+ do (incf i)
+ collect
+ (cond
+ ((and (pairp x) (eq (qcar x) '|SubDomain|) (pairp (qcdr x))
+ (pairp (qcdr (qcdr x))) (eq (qcdr (qcdr (qcdr x))) nil))
+ (cond
+ ((setq pair (|assoc| i |$argumentConditionList|))
+ (rplac (cadr pair) (mkpf (list (third x) (cadr pair)) 'and))
+ (second x))
+ (t
+ (setq |$argumentConditionList|
+ (cons (list i arg (third x)) |$argumentConditionList|))
+ (second x))))
+ (t x)))))
+
+\end{chunk}
+
+\defun{stripOffArgumentConditions}{stripOffArgumentConditions}
+\calls{stripOffArgumentConditions}{pairp}
+\calls{stripOffArgumentConditions}{qcar}
+\calls{stripOffArgumentConditions}{qcdr}
+\calls{stripOffArgumentConditions}{msubst}
+\refsdollar{stripOffArgumentConditions}{argumentConditionList}
+\defsdollar{stripOffArgumentConditions}{argumentConditionList}
+\begin{chunk}{defun stripOffArgumentConditions}
+(defun |stripOffArgumentConditions| (argl)
+ (let (condition (i 0))
+ (declare (special |$argumentConditionList|))
+ (loop for x in argl
+ do (incf i)
+ collect
+ (cond
+ ((and (pairp x) (eq (qcar x) '|\||) (pairp (qcdr x))
+ (pairp (qcdr (qcdr x))) (eq (qcdr (qcdr (qcdr x))) nil))
+ (setq condition (msubst '|#1| (second x) (third x)))
+ (setq |$argumentConditionList|
+ (cons (list i (second x) condition) |$argumentConditionList|))
+ (second x))
+ (t x)))))
+
+\end{chunk}
+
+\defun{getSignature}{getSignature}
+Try to return a signature. If there isn't one, complain and return nil.
+If there are more than one then remove any that are subsumed. If there
+is still more than one complain else return the only signature.
+\calls{getSignature}{get}
+\calls{getSignature}{length}
+\calls{getSignature}{remdup}
+\calls{getSignature}{knownInfo}
+\calls{getSignature}{getmode}
+\calls{getSignature}{pairp}
+\calls{getSignature}{qcar}
+\calls{getSignature}{qcdr}
+\calls{getSignature}{say}
+\calls{getSignature}{printSignature}
+\calls{getSignature}{SourceLevelSubsume}
+\calls{getSignature}{stackSemanticError}
+\refsdollar{getSignature{e}
+\begin{chunk}{defun getSignature}
+(defun |getSignature| (op argModeList |$e|)
+ (declare (special |$e|))
+ (let (mmList pred u tmp1 dc sig sigl)
+ (setq mmList (|get| op '|modemap| |$e|))
+ (cond
+ ((eql 1
+ (|#| (setq sigl (remdup
+ (loop for item in mmList
+ do
+ (setq dc (caar item))
+ (setq sig (cdar item))
+ (setq pred (caadr item))
+ when (and (eq dc '$) (equal (cdr sig) argModeList) (|knownInfo| pred))
+ collect sig)))))
+ (car sigl))
+ ((null sigl)
+ (cond
+ ((progn
+ (setq tmp1 (setq u (|getmode| op |$e|)))
+ (and (pairp tmp1) (eq (qcar tmp1) '|Mapping|)))
+ (qcdr tmp1))
+ (t
+ (say "************* USER ERROR **********")
+ (say "available signatures for " op ": ")
+ (cond
+ ((null mmList) (say " NONE"))
+ (t
+ (loop for item in mmList
+ do (|printSignature| '| | op (cdar item)))
+ (|printSignature| '|NEED | op (cons '? argModeList))))
+ nil)))
+ (t
+ ; Before we complain about duplicate signatures, we should
+ ; check that we do not have for example, a partial - as
+ ; well as a total one. SourceLevelSubsume should do this
+ (loop for u in sigl do
+ (loop for v in sigl
+ when (null (equal u v))
+ do (when (|SourceLevelSubsume| u v) (setq sigl (|delete| v sigl)))))
+ (cond
+ ((eql 1 (|#| sigl)) (car sigl))
+ (t
+ (|stackSemanticError|
+ (list '|duplicate signatures for | op '|: | argModeList) nil)))))))))
+
+\end{chunk}
+
+\defun{checkAndDeclare}{checkAndDeclare}
+\calls{checkAndDeclare}{getArgumentMode}
+\calls{checkAndDeclare}{modeEqual}
+\calls{checkAndDeclare}{put}
+\calls{checkAndDeclare}{sayBrightly}
+\calls{checkAndDeclare}{bright}
+\begin{chunk}{defun checkAndDeclare}
+(defun |checkAndDeclare| (argl form sig env)
+ (let (m1 stack)
+ (loop for a in argl for m in (rest sig)
+ do
+ (if (setq m1 (|getArgumentMode| a env))
+ (if (null (|modeEqual| m1 m))
+ (setq stack
+ (cons '| | (append (|bright| a)
+ (cons "must have type "
+ (cons m
+ (cons " not "
+ (cons m1
+ (cons '|%l| stack)))))))))
+ (setq env (|put| a '|mode| m env))))
+ (when stack
+ (|sayBrightly|
+ (cons " Parameters of "
+ (append (|bright| (car form))
+ (cons " are of wrong type:"
+ (cons '|%l| stack))))))
+ env))
+
+\end{chunk}
+
+\defun{hasSigInTargetCategory}{hasSigInTargetCategory}
+\calls{hasSigInTargetCategory}{getArgumentMode}
+\calls{hasSigInTargetCategory}{remdup}
+\calls{hasSigInTargetCategory}{length}
+\calls{hasSigInTargetCategory}{getSignatureFromMode}
+\calls{hasSigInTargetCategory}{stackWarning}
+\calls{hasSigInTargetCategory}{compareMode2Arg}
+\calls{hasSigInTargetCategory}{bright}
+\refsdollar{hasSigInTargetCategory}{domainShell}
+\begin{chunk}{defun hasSigInTargetCategory}
+(defun |hasSigInTargetCategory| (argl form opsig env)
+ (labels (
+ (fn (opName sig opsig mList form)
+ (declare (special |$op|))
+ (and
+ (and
+ (and (equal opName |$op|) (equal (|#| sig) (|#| form)))
+ (or (null opsig) (equal opsig (car sig))))
+ (let ((result t))
+ (loop for x in mList for y in (rest sig)
+ do (setq result (and result (or (null x) (|modeEqual| x y)))))
+ result))))
+ (let (mList potentialSigList c sig)
+ (declare (special |$domainShell|))
+ (setq mList
+ (loop for x in argl
+ collect (|getArgumentMode| x env)))
+ (setq potentialSigList
+ (remdup
+ (loop for item in (elt |$domainShell| 1)
+ when (fn (caar item) (cadar item) opsig mList form)
+ collect (cadar item))))
+ (setq c (|#| potentialSigList))
+ (cond
+ ((eql 1 c) (car potentialSigList))
+ ((eql 0 c)
+ (when (equal (|#| (setq sig (|getSignatureFromMode| form env))) (|#| form))
+ sig))
+ ((> c 1)
+ (setq sig (car potentialSigList))
+ (|stackWarning|
+ (cons '|signature of lhs not unique:|
+ (append (|bright| sig) (list '|chosen|))))
+ sig)
+ (t nil)))))
+
+\end{chunk}
+
+\defun{getArgumentMode}{getArgumentMode}
+\calls{getArgumentMode}{get}
+\begin{chunk}{defun getArgumentMode}
+(defun |getArgumentMode| (x e)
+ (if (stringp x) x (|get| x '|mode| e)))
+
+\end{chunk}
+
\defplist{elt}{compElt plist}
\begin{chunk}{postvars}
(eval-when (eval load)
@@ -10789,6 +11846,18 @@ An angry JHD - August 15th., 1984
\end{chunk}
+\defun{compForMode}{compForMode}
+\calls{compForMode}{comp}
+\defsdollar{compForMode}{compForModeIfTrue}
+\begin{chunk}{defun compForMode}
+(defun |compForMode| (x m e)
+ (let (|$compForModeIfTrue|)
+ (declare (special |$compForModeIfTrue|))
+ (setq |$compForModeIfTrue| t)
+ (|comp| x m e)))
+
+\end{chunk}
+
\defplist{$+->$}{compLambda plist}
\begin{chunk}{postvars}
(eval-when (eval load)
@@ -11390,6 +12459,18 @@ An angry JHD - August 15th., 1984
\end{chunk}
+\defun{uncons}{uncons}
+\calls{uncons}{uncons}
+\begin{chunk}{defun uncons}
+(defun |uncons| (x)
+ (cond
+ ((atom x) x)
+ ((and (pairp x) (eq (qcar x) 'cons) (pairp (qcdr x))
+ (pairp (qcdr (qcdr x))) (eq (qcdr (qcdr (qcdr x))) nil))
+ (cons (second x) (|uncons| (third x))))))
+
+\end{chunk}
+
\defun{setqMultiple}{setqMultiple}
\calls{setqMultiple}{nreverse0}
\calls{setqMultiple}{pairp}
@@ -11836,6 +12917,14 @@ An angry JHD - August 15th., 1984
\end{chunk}
+\defun{lispize}{lispize}
+\calls{lispize}{optimize}
+\begin{chunk}{defun lispize}
+(defun |lispize| (x)
+ (car (|optimize| (list x))))
+
+\end{chunk}
+
\defplist{SubsetCategory}{compSubsetCategory plist}
\begin{chunk}{postvars}
(eval-when (eval load)
@@ -19803,6 +20892,226 @@ if \verb|$InteractiveMode| then use a null outputstream
\end{chunk}
+\chapter{Level 1}
+
+\defvar{current-fragment}
+A string containing remaining chars from readline; needed because
+Symbolics read-line returns embedded newlines in a c-m-Y.
+\begin{chunk}{initvars}
+(defvar current-fragment nil)
+
+\end{chunk}
+
+\defun{read-a-line}{read-a-line}
+\calls{read-a-line}{subseq}
+\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* File-Closed))
+ (if (and Current-Fragment (> (length Current-Fragment) 0))
+ (let ((line (with-input-from-string
+ (s Current-Fragment :index cp :start 0)
+ (read-line s nil nil))))
+ (setq Current-Fragment (subseq Current-Fragment cp))
+ line)
+ (prog nil
+ (when (stream-eof in-stream)
+ (setq File-Closed t)
+ (setq *eof* t)
+ (Line-New-Line (make-string 0) Current-Line)
+ (return nil))
+ (when (setq Current-Fragment (read-line stream))
+ (return (read-a-line stream)))))))
+
+\end{chunk}
+
+
+\chapter{Level 0}
+\section{Line Handling}
+
+\subsection{Line Buffer}
+The philosophy of lines is that
+\begin{itemize}
+\item NEXT LINE will always return a non-blank line or fail.
+\item Every line is terminated by a blank character.
+\end{itemize}
+Hence there is always a current character, because there is never a
+non-blank line, and there is always a separator character between tokens
+on separate lines. Also, when a line is read, the character pointer is
+always positioned ON the first character.
+\defstruct{line}
+\begin{chunk}{initvars}
+(defstruct line "Line of input file to parse."
+ (buffer (make-string 0) :type string)
+ (current-char #\Return :type character)
+ (current-index 1 :type fixnum)
+ (last-index 0 :type fixnum)
+ (number 0 :type fixnum))
+
+\end{chunk}
+
+\defvar{current-line}
+The current input line.
+\begin{chunk}{initvars}
+(defvar current-line (make-line))
+
+\end{chunk}
+
+
+\defmacro{line-clear}
+\usesstruct{line-clear}{line}
+\begin{chunk}{defmacro line-clear}
+(defmacro line-clear (line)
+ `(let ((l ,line))
+ (setf (line-buffer l) (make-string 0))
+ (setf (line-current-char l) #\return)
+ (setf (line-current-index l) 1)
+ (setf (line-last-index l) 0)
+ (setf (line-number l) 0)))
+
+\end{chunk}
+
+\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))))
+
+\end{chunk}
+
+\defun{line-at-end-p}{line-at-end-p}
+\usesstruct{line-at-end-p}{line}
+\begin{chunk}{defun line-at-end-p}
+(defun line-at-end-p (line)
+ "Tests if line is empty or positioned past the last character."
+ (>= (line-current-index line) (line-last-index line)))
+
+\end{chunk}
+
+\defun{line-past-end-p}{line-past-end-p}
+\usesstruct{line-past-end-p}{line}
+\begin{chunk}{defun line-past-end-p}
+(defun line-past-end-p (line)
+ "Tests if line is empty or positioned past the last character."
+ (> (line-current-index line) (line-last-index line)))
+
+\end{chunk}
+
+\defun{line-next-char}{line-next-char}
+\usesstruct{line-next-char}{line}
+\begin{chunk}{defun line-next-char}
+(defun line-next-char (line)
+ (elt (line-buffer line) (1+ (line-current-index line))))
+
+\end{chunk}
+
+\defun{line-advance-char}{line-advance-char}
+\usesstruct{line-advance-char}{line}
+\begin{chunk}{defun line-advance-char}
+(defun line-advance-char (line)
+ (setf (line-current-char line)
+ (elt (line-buffer line) (incf (line-current-index line)))))
+
+\end{chunk}
+
+\defun{line-current-segment}{line-current-segment}
+\usesstruct{line-print}{line}
+\begin{chunk}{defun line-current-segment}
+(defun line-current-segment (line)
+ "Buffer from current index to last index."
+ (if (line-at-end-p line)
+ (make-string 0)
+ (subseq (line-buffer line)
+ (line-current-index line)
+ (line-last-index line))))
+
+\end{chunk}
+
+\defun{line-new-line}{line-new-line}
+\usesstruct{line-new-line}{line}
+\begin{chunk}{defun line-new-line}
+(defun line-new-line (string line &optional (linenum nil))
+ "Sets string to be the next line stored in line."
+ (setf (line-last-index line) (1- (length string)))
+ (setf (line-current-index line) 0)
+ (setf (line-current-char line)
+ (or (and (> (length string) 0) (elt string 0)) #\Return))
+ (setf (line-buffer line) string)
+ (setf (line-number line) (or linenum (1+ (line-number 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}
+
+\defun{Advance-Char}{Advance-Char}
+\calls{Advance-Char}{Line-At-End-P}
+\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))
+ (return (Line-Advance-Char Current-Line)))
+ ((next-line in-stream)
+ (return (current-char)))
+ ((return nil)))))
+
+\end{chunk}
+
+\defun{storeblanks}{storeblanks}
+\begin{chunk}{defun storeblanks}
+(defun storeblanks (line n)
+ (do ((i 0 (1+ i)))
+ ((= i n) line)
+ (setf (char line i) #\ )))
+
+\end{chunk}
+
+\defun{initial-substring}{initial-substring}
+\calls{initial-substring}{mismatch}
+\begin{chunk}{defun initial-substring}
+(defun initial-substring (pattern line)
+ (let ((ind (mismatch pattern line)))
+ (or (null ind) (eql ind (size pattern)))))
+
+\end{chunk}
+
+\defun{get-a-line}{get-a-line}
+\calls{get-a-line}{is-console}
+\seebook{get-a-line}{mkprompt}{5}
+\calls{get-a-line}{read-a-line}
+\begin{chunk}{defun get-a-line}
+(defun get-a-line (stream)
+ (when (is-console stream) (princ (mkprompt)))
+ (let ((ll (read-a-line stream)))
+ (if (and (stringp ll) (adjustable-array-p ll))
+ (make-array (array-dimensions ll) :element-type 'string-char
+ :adjustable t :initial-contents ll)
+ ll)))
+
+\end{chunk}
+
+\chapter{The Chunks}
\begin{chunk}{Compiler}
(in-package "BOOT")
@@ -19826,12 +21135,14 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defmacro star}
\getchunk{defun action}
+\getchunk{defun addArgumentConditions}
\getchunk{defun addclose}
\getchunk{defun addConstructorModemaps}
\getchunk{defun addDomain}
\getchunk{defun addEltModemap}
\getchunk{defun addEmptyCapsuleIfNecessary}
\getchunk{defun addModemapKnown}
+\getchunk{defun addModemap}
\getchunk{defun addModemap0}
\getchunk{defun addModemap1}
\getchunk{defun addNewDomain}
@@ -19853,11 +21164,13 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun autoCoerceByModemap}
\getchunk{defun blankp}
+\getchunk{defun bootStrapError}
\getchunk{defun bumperrorcount}
\getchunk{defun canReturn}
\getchunk{defun char-eq}
\getchunk{defun char-ne}
+\getchunk{defun checkAndDeclare}
\getchunk{defun checkWarning}
\getchunk{defun coerce}
\getchunk{defun coerceable}
@@ -19872,12 +21185,14 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun comp2}
\getchunk{defun comp3}
\getchunk{defun compAdd}
+\getchunk{defun compArgumentConditions}
\getchunk{defun compArgumentsAndTryAgain}
\getchunk{defun compAtom}
\getchunk{defun compAtSign}
\getchunk{defun compBoolean}
\getchunk{defun compCapsule}
\getchunk{defun compCapsuleInner}
+\getchunk{defun compCapsuleItems}
\getchunk{defun compCase}
\getchunk{defun compCase1}
\getchunk{defun compCat}
@@ -19893,6 +21208,7 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun compDefine}
\getchunk{defun compDefine1}
\getchunk{defun compDefineAddSignature}
+\getchunk{defun compDefineCapsuleFunction}
\getchunk{defun compDefineCategory}
\getchunk{defun compDefineCategory1}
\getchunk{defun compDefineCategory2}
@@ -19909,27 +21225,34 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun compForm2}
\getchunk{defun compForm3}
\getchunk{defun compFormMatch}
+\getchunk{defun compForMode}
\getchunk{defun compFormPartiallyBottomUp}
\getchunk{defun compFromIf}
\getchunk{defun compFunctorBody}
\getchunk{defun compHas}
\getchunk{defun compHasFormat}
\getchunk{defun compIf}
+\getchunk{defun compile}
+\getchunk{defun compileCases}
+\getchunk{defun compileConstructor}
+\getchunk{defun compileConstructor1}
+\getchunk{defun compileDocumentation}
\getchunk{defun compileFileQuietly}
\getchunk{defun compile-lib-file}
\getchunk{defun compiler}
-\getchunk{defun compileDocumentation}
\getchunk{defun compilerDoit}
\getchunk{defun compilerDoitWithScreenedLisplib}
\getchunk{defun compileSpad2Cmd}
\getchunk{defun compileSpadLispCmd}
\getchunk{defun compImport}
+\getchunk{defun compInternalFunction}
\getchunk{defun compIs}
\getchunk{defun compJoin}
\getchunk{defun compLambda}
\getchunk{defun compLeave}
\getchunk{defun compList}
\getchunk{defun compMacro}
+\getchunk{defun compMakeCategoryObject}
\getchunk{defun compMakeDeclaration}
\getchunk{defun compNoStacking}
\getchunk{defun compNoStacking1}
@@ -19945,10 +21268,9 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun compSeq}
\getchunk{defun compSeqItem}
\getchunk{defun compSeq1}
-\getchunk{defun setqSetelt}
-\getchunk{defun setqSingle}
\getchunk{defun compSetq}
\getchunk{defun compSetq1}
+\getchunk{defun compSingleCapsuleItem}
\getchunk{defun compString}
\getchunk{defun compSubDomain}
\getchunk{defun compSubDomain1}
@@ -19956,12 +21278,14 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun compSubsetCategory}
\getchunk{defun compSuchthat}
\getchunk{defun compTopLevel}
+\getchunk{defun compTuple2Record}
\getchunk{defun compTypeOf}
\getchunk{defun compUniquely}
\getchunk{defun compVector}
\getchunk{defun compWhere}
\getchunk{defun compWithMappingMode}
\getchunk{defun compWithMappingMode1}
+\getchunk{defun constructMacro}
\getchunk{defun containsBang}
\getchunk{defun convert}
\getchunk{defun convertOpAlist2compilerInfo}
@@ -19977,6 +21301,7 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun disallowNilAttribute}
\getchunk{defun displayMissingFunctions}
\getchunk{defun displayPreCompilationErrors}
+\getchunk{defun doIt}
\getchunk{defun dollarTran}
\getchunk{defun domainMember}
\getchunk{defun drop}
@@ -19998,6 +21323,8 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun freelist}
\getchunk{defun get-a-line}
+\getchunk{defun getArgumentMode}
+\getchunk{defun getArgumentModeOrMoan}
\getchunk{defun getCategoryOpsAndAtts}
\getchunk{defun getConstructorOpsAndAtts}
\getchunk{defun getDomainsInScope}
@@ -20009,8 +21336,11 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun getModemapListFromDomain}
\getchunk{defun getOperationAlist}
\getchunk{defun getScriptName}
+\getchunk{defun getSignature}
+\getchunk{defun getSignatureFromMode}
\getchunk{defun getSlotFromCategoryForm}
\getchunk{defun getSlotFromFunctor}
+\getchunk{defun getSpecialCaseAssoc}
\getchunk{defun getSuccessEnvironment}
\getchunk{defun getTargetFromRhs}
\getchunk{defun get-token}
@@ -20029,6 +21359,7 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun hasAplExtension}
\getchunk{defun hasFormalMapVariable}
\getchunk{defun hasFullSignature}
+\getchunk{defun hasSigInTargetCategory}
\getchunk{defun hasType}
\getchunk{defun indent-pos}
@@ -20058,6 +21389,7 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun line-past-end-p}
\getchunk{defun line-print}
\getchunk{defun line-new-line}
+\getchunk{defun lispize}
\getchunk{defun lisplibDoRename}
\getchunk{defun lisplibWrite}
\getchunk{defun loadIfNecessary}
@@ -20069,7 +21401,6 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun makeCategoryPredicates}
\getchunk{defun makeFunctorArgumentParameters}
\getchunk{defun makeSimplePredicateOrNil}
-\getchunk{defun make-string-adjustable}
\getchunk{defun make-symbol-of}
\getchunk{defun match-advance-string}
\getchunk{defun match-current-token}
@@ -20103,6 +21434,7 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun nonblankloc}
\getchunk{defun optional}
+\getchunk{defun orderByDependency}
\getchunk{defun orderPredicateItems}
\getchunk{defun orderPredTran}
\getchunk{defun outputComp}
@@ -20299,6 +21631,7 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun print-defun}
\getchunk{defun push-reduction}
\getchunk{defun putDomainsInScope}
+\getchunk{defun putInLocalDomainReferences}
\getchunk{defun quote-if-string}
@@ -20317,17 +21650,22 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun seteltModemapFilter}
\getchunk{defun setqMultiple}
\getchunk{defun setqMultipleExplicit}
+\getchunk{defun setqSetelt}
+\getchunk{defun setqSingle}
\getchunk{defun signatureTran}
\getchunk{defun skip-blanks}
\getchunk{defun skip-ifblock}
\getchunk{defun skip-to-endif}
\getchunk{defun spad}
+\getchunk{defun spadCompileOrSetq}
\getchunk{defun spad-fixed-arg}
\getchunk{defun stack-clear}
\getchunk{defun stack-load}
\getchunk{defun stack-pop}
\getchunk{defun stack-push}
\getchunk{defun storeblanks}
+\getchunk{defun stripOffArgumentConditions}
+\getchunk{defun stripOffSubdomainConditions}
\getchunk{defun substituteCategoryArguments}
\getchunk{defun substNames}
\getchunk{defun substVars}
@@ -20341,12 +21679,14 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun transIs1}
\getchunk{defun translabel}
\getchunk{defun translabel1}
+\getchunk{defun TruthP}
\getchunk{defun try-get-token}
\getchunk{defun tuple2List}
\getchunk{defun underscore}
\getchunk{defun unget-tokens}
\getchunk{defun unknownTypeError}
+\getchunk{defun uncons}
\getchunk{defun unTuple}
\getchunk{defun updateCategoryFrameForCategory}
\getchunk{defun updateCategoryFrameForConstructor}
diff --git a/changelog b/changelog
index 5baaa13..3305292 100644
--- a/changelog
+++ b/changelog
@@ -1,3 +1,7 @@
+20110824 tpd src/axiom-website/patches.html 20110824.01.tpd.patch
+20110824 tpd src/interp/i-util.lisp treeshake compiler
+20110824 tpd src/interp/define.lisp treeshake compiler
+20110824 tpd books/bookvol9 treeshake compiler
20110818 tpd src/axiom-website/patches.html 20110818.02.tpd.patch
20110818 tpd src/interp/Makefile remove foam_l
20110818 tpd src/interp/foam_l.lisp removed
diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html
index 9db656e..414c4ff 100644
--- a/src/axiom-website/patches.html
+++ b/src/axiom-website/patches.html
@@ -3592,5 +3592,7 @@ books/bookvol9 treeshake compiler
books/bookvol9 treeshake compiler, remove compiler.lisp
20110818.02.tpd.patch
src/interp/Makefile remove foam_l
+20110824.01.tpd.patch
+books/bookvol9 treeshake compiler