diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index 6c47b62..1b42dec 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -1686,57 +1686,50 @@ system function and constructor caches. \end{verbatim} <>= -(defun |clearSpad2Cmd| (|l|) - (prog (|$clearExcept| |opt| |optList| |arg|) - (declare (special |$clearExcept|)) - (return - (seq - (progn - (setq |$clearExcept| nil) - (cond - (|$options| - (setq |$clearExcept| - (prog (t0) - (setq t0 t) - (return - (do ((t1 nil (null t0)) - (t2 |$options| (cdr t2)) - (t3 nil)) - ((or t1 - (atom t2) - (progn (setq t3 (car t2)) nil) - (progn (progn (setq |opt| (car t3)) t3) nil)) - t0) - (seq - (exit - (setq t0 - (and t0 - (eq - (|selectOptionLC| |opt| '(|except|) '|optionError|) - '|except|))))))))))) +(defun |clearSpad2Cmd| (l) + (let (|$clearExcept| |opt| |optList| |arg|) + (declare (special |$clearExcept| |$options| |$clearOptions|)) + (setq |$clearExcept| nil) + (cond + (|$options| + (setq |$clearExcept| + (prog (t0) + (setq t0 t) + (return + (do ((t1 nil (null t0)) + (t2 |$options| (cdr t2)) + (t3 nil)) + ((or t1 + (atom t2) + (progn (setq t3 (car t2)) nil) + (progn (progn (setq |opt| (car t3)) t3) nil)) + t0) + (setq t0 + (and t0 + (eq + (|selectOptionLC| |opt| '(|except|) '|optionError|) + '|except|))))))))) + (cond + ((null l) + (setq |optList| + (prog (t4) + (setq t4 nil) + (return + (do ((t5 |$clearOptions| (cdr t5)) (x nil)) + ((or (atom t5) (progn (setq x (car t5)) nil)) t4) + (setq t4 (append t4 `(|%l| " " ,x))))))) + (|sayKeyedMsg| 's2iz0010 (cons |optList| nil))) + (t + (setq |arg| + (|selectOptionLC| (car l) '(|all| |completely| |scaches|) nil)) (cond - ((null |l|) - (setq |optList| - (prog (t4) - (setq t4 nil) - (return - (do ((t5 |$clearOptions| (cdr t5)) (|x| nil)) - ((or (atom t5) (progn (setq |x| (car t5)) nil)) t4) - (seq - (exit - (setq t4 - (append t4 (cons '|%l| (cons " " (cons |x| nil))))))))))) - (|sayKeyedMsg| 's2iz0010 (cons |optList| nil))) - (t - (setq |arg| - (|selectOptionLC| (car |l|) '(|all| |completely| |scaches|) nil)) - (cond - ((eq |arg| '|all|) (|clearCmdAll|)) - ((eq |arg| '|completely|) (|clearCmdCompletely|)) - ((eq |arg| '|scaches|) (|clearCmdSortedCaches|)) - (|$clearExcept| (|clearCmdExcept| |l|)) - (t - (|clearCmdParts| |l|) (|updateCurrentInterpreterFrame|)))))))))) + ((eq |arg| '|all|) (|clearCmdAll|)) + ((eq |arg| '|completely|) (|clearCmdCompletely|)) + ((eq |arg| '|scaches|) (|clearCmdSortedCaches|)) + (|$clearExcept| (|clearCmdExcept| l)) + (t + (|clearCmdParts| l) + (|updateCurrentInterpreterFrame|))))))) @ @@ -1751,24 +1744,18 @@ system function and constructor caches. <>= (defun |clearCmdSortedCaches| () - (prog (|$lookupDefaults| |domain| |pair|) - (declare (special |$lookupDefaults|)) - (return - (seq - (progn - (setq |$lookupDefaults| nil) - (do ((t0 (hget |$ConstructorCache| '|SortedCache|) (cdr t0)) - (t1 nil)) - ((or (atom t0) - (progn (setq t1 (car t0)) nil) - (progn (progn (setq |domain| (cddr t1)) t1) nil)) - nil) - (seq - (exit - (progn - (setq |pair| - (|compiledLookupCheck| '|clearCache| (cons |$Void| nil) |domain|)) - (spadcall |pair|)))))))))) + (let (|$lookupDefaults| domain pair) + (declare (special |$lookupDefaults| |$Void| |$ConstructorCache|)) + (do ((t0 (hget |$ConstructorCache| '|SortedCache|) (cdr t0)) + (t1 nil)) + ((or (atom t0) + (progn + (setq t1 (car t0)) + (setq domain (cddr t1)) + nil)) + nil) + (setq pair (|compiledLookupCheck| '|clearCache| (list |$Void|) domain)) + (spadcall pair)))) @ @@ -1796,7 +1783,10 @@ system function and constructor caches. <>= (defun |clearCmdCompletely| () - (progn (|clearCmdAll|) + (declare (special |$localExposureData| |$xdatabase| |$CatOfCatDatabase| + |$DomOfCatDatabase| |$JoinOfCatDatabase| |$JoinOfDomDatabase| + |$attributeDb| |$functionTable| |$existingFiles|)) + (|clearCmdAll|) (setq |$localExposureData| (copy-seq |$localExposureDataDefault|)) (setq |$xdatabase| nil) (setq |$CatOfCatDatabase| nil) @@ -1811,8 +1801,7 @@ system function and constructor caches. (setq |$existingFiles| (make-hashtable 'UEQUAL)) (|sayKeyedMsg| 's2iz0014 nil) (reclaim) - (|sayKeyedMsg| 's2iz0015 nil) - nil)) + (|sayKeyedMsg| 's2iz0015 nil)) @ @@ -1840,7 +1829,9 @@ system function and constructor caches. <>= (defun |clearCmdAll| () - (progn + (declare (special |$frameRecord| |$previousBindings| |$variableNumberAlist| + |$InteractiveFrame| |$useInternalHistoryTable| |$internalHistoryTable| + |$frameMessages| |$interpreterFrameName| |$currentLine|)) (|clearCmdSortedCaches|) (setq |$frameRecord| nil) (setq |$previousBindings| nil) @@ -1848,47 +1839,28 @@ system function and constructor caches. (|untraceMapSubNames| /tracenames) (setq |$InteractiveFrame| (list (list nil))) (|resetInCoreHist|) - (cond - (|$useInternalHistoryTable| (setq |$internalHistoryTable| nil)) - (t (|deleteFile| (|histFileName|)))) + (when |$useInternalHistoryTable| + (setq |$internalHistoryTable| nil) + (|deleteFile| (|histFileName|))) (setq |$IOindex| 1) (|updateCurrentInterpreterFrame|) (setq |$currentLine| ")clear all") (|clearMacroTable|) - (cond - (|$frameMessages| - (|sayKeyedMsg| 's2iz0011 (cons |$interpreterFrameName| nil))) - (t (|sayKeyedMsg| 's2iz0012 nil))))) + (when |$frameMessages| + (|sayKeyedMsg| 's2iz0011 (list |$interpreterFrameName|)) + (|sayKeyedMsg| 's2iz0012 nil))) @ \defun{clearCmdExcept} -\begin{verbatim} -;clearCmdExcept(l is [opt,:vl]) == -; --clears elements of vl of all options EXCEPT opt -; for option in $clearOptions | -; ^stringPrefix?(object2String opt,object2String option) -; repeat clearCmdParts [option,:vl] -\end{verbatim} - +Clear all the options except the argument. <>= (defun |clearCmdExcept| (arg) - (prog (opt vl) - (return - (seq - (progn - (setq opt (car arg)) - (setq vl (cdr arg)) - (do ((t0 |$clearOptions| (cdr t0)) (option nil)) - ((or (atom t0) (progn (setq option (car t0)) nil)) nil) - (seq - (exit - (cond - ((null - (|stringPrefix?| - (|object2String| opt) - (|object2String| option))) - (|clearCmdParts| (cons option vl)))))))))))) + (let ((opt (car arg)) (vl (cdr arg))) + (declare (special |$clearOptions|)) + (dolist (option |$clearOptions|) + (unless (|stringPrefix?| (|object2String| opt) (|object2String| option)) + (|clearCmdParts| (cons option vl)))))) @ @@ -1938,77 +1910,63 @@ system function and constructor caches. <>= (defun |clearCmdParts| (arg) - (prog (|$e| |opt| |option| |pmacs| |imacs| |vl| |p1| |lm| |prop| |p2|) - (declare (special |$e|)) - (return - (seq - (progn - (setq |opt| (car arg)) - (setq |vl| (cdr arg)) - (setq |option| (|selectOptionLC| |opt| |$clearOptions| '|optionError|)) - (setq |option| (intern (pname |option|))) - (setq |option| - (cond - ((eq |option| '|types|) '|mode|) - ((eq |option| '|modes|) '|mode|) - ((eq |option| '|values|) '|value|) - (t |option|))) - (cond - ((null |vl|) (|sayKeyedMsg| 's2iz0055 nil)) - (t - (setq |pmacs| (|getParserMacroNames|)) - (setq |imacs| (|getInterpMacroNames|)) - (cond - ((boot-equal |vl| '(|all|)) - (setq |vl| (assocleft (caar |$InteractiveFrame|))) - (setq |vl| (remdup (append |vl| |pmacs|))))) - (setq |$e| |$InteractiveFrame|) - (do ((t0 |vl| (cdr t0)) (|x| nil)) - ((or (atom t0) (progn (setq |x| (car t0)) nil)) nil) - (seq - (exit - (progn - (|clearDependencies| |x| t) - (cond - ((and (eq |option| '|properties|) (|member| |x| |pmacs|)) - (|clearParserMacro| |x|))) - (cond - ((and (eq |option| '|properties|) - (|member| |x| |imacs|) - (null (|member| |x| |pmacs|))) - (|sayMessage| (cons - " You cannot clear the definition of the system-defined macro " - (cons (|fixObjectForPrinting| |x|) - (cons (intern "." "BOOT") nil)))))) - (cond - ((setq |p1| (|assoc| |x| (caar |$InteractiveFrame|))) + (let (|$e| (opt (car arg)) option pmacs imacs (vl (cdr arg)) p1 lm prop p2) + (declare (special |$e| |$InteractiveFrame| |$clearOptions|)) + (setq option (|selectOptionLC| opt |$clearOptions| '|optionError|)) + (setq option (intern (pname option))) + (setq option + (case option + (|types| '|mode|) + (|modes| '|mode|) + (|values| '|value|) + (t option))) + (if (null vl) + (|sayKeyedMsg| 's2iz0055 nil) + (progn + (setq pmacs (|getParserMacroNames|)) + (setq imacs (|getInterpMacroNames|)) + (cond + ((boot-equal vl '(|all|)) + (setq vl (assocleft (caar |$InteractiveFrame|))) + (setq vl (remdup (append vl pmacs))))) + (setq |$e| |$InteractiveFrame|) + (do ((t0 vl (cdr t0)) (x nil)) + ((or (atom t0) (progn (setq x (car t0)) nil)) nil) + (|clearDependencies| x t) + (when (and (eq option '|properties|) (|member| x pmacs)) + (|clearParserMacro| x)) + (when (and (eq option '|properties|) + (|member| x imacs) + (null (|member| x pmacs))) + (|sayMessage| (cons + " You cannot clear the definition of the system-defined macro " + (cons (|fixObjectForPrinting| x) + (cons (intern "." "BOOT") nil))))) + (cond + ((setq p1 (|assoc| x (caar |$InteractiveFrame|))) + (cond + ((eq option '|properties|) + (cond + ((|isMap| x) + (seq (cond - ((eq |option| '|properties|) + ((setq lm + (|get| x '|localModemap| |$InteractiveFrame|)) (cond - ((|isMap| |x|) - (seq - (cond - ((setq |lm| - (|get| |x| '|localModemap| |$InteractiveFrame|)) - (cond - ((pairp |lm|) - (exit (|untraceMapSubNames| (cons (cadar |lm|) nil)))))) - (t nil))))) - (do ((t1 (cdr |p1|) (cdr t1)) (|p2| nil)) - ((or (atom t1) (progn (setq |p2| (car t1)) nil)) nil) - (seq - (exit - (progn - (setq |prop| (car |p2|)) - (|recordOldValue| |x| |prop| (cdr |p2|)) - (|recordNewValue| |x| |prop| nil))))) - (setf (caar |$InteractiveFrame|) - (|deleteAssoc| |x| (caar |$InteractiveFrame|)))) - ((setq |p2| (|assoc| |option| (cdr |p1|))) - (|recordOldValue| |x| |option| (cdr |p2|)) - (|recordNewValue| |x| |option| nil) - (rplacd |p2| nil))))))))) - nil))))))) + ((pairp lm) + (exit (|untraceMapSubNames| (cons (cadar lm) nil)))))) + (t nil))))) + (dolist (p2 (cdr p1)) + (setq prop (car p2)) + (|recordOldValue| x prop (cdr p2)) + (|recordNewValue| x prop nil)) + (setf (caar |$InteractiveFrame|) + (|deleteAssoc| x (caar |$InteractiveFrame|)))) + ((setq p2 (|assoc| option (cdr p1))) + (|recordOldValue| x option (cdr p2)) + (|recordNewValue| x option nil) + (rplacd p2 nil)))))) + nil)))) @ @@ -2055,9 +2013,9 @@ the entire Axiom session. Returns the number of active scratchpad clients <>= (defun |queryClients| () - (progn + (declare (special |$SessionManager| |$QueryClients|)) (|sockSendInt| |$SessionManager| |$QueryClients|) - (|sockGetInt| |$SessionManager|))) + (|sockGetInt| |$SessionManager|)) @ @@ -2092,48 +2050,34 @@ Returns the number of active scratchpad clients <>= (defun |close| (args) - (prog (numClients opt fullopt quiet x) - (return - (seq + (let (numClients opt fullopt quiet x) + (declare (special |$SpadServer| |$SessionManager| |$CloseClient| + |$currentFrameNum| |$options|)) + (if (null |$SpadServer|) + (|throwKeyedMsg| 's2iz0071 nil)) + (progn + (setq numClients (|queryClients|)) (cond - (|$saturn| - (|sayErrorly| "Obsolete system command" (cons - " The )close system command is obsolete in this version of AXIOM." - (cons " Please use Close from the File menu instead." nil)))) + ((> numClients 1) + (|sockSendInt| |$SessionManager| |$CloseClient|) + (|sockSendInt| |$SessionManager| |$currentFrameNum|) + (|closeInterpreterFrame| nil)) (t - (setq quiet nil) + (do ((t0 |$options| (cdr t0)) (t1 nil)) + ((or (atom t0) + (progn (setq t1 (car t0)) nil) + (progn (progn (setq opt (car t1)) t1) nil)) + nil) + (setq fullopt (|selectOptionLC| opt '(|quiet|) '|optionError|)) + (unless quiet (setq quiet (eq fullopt '|quiet|)))) (cond - ((null |$SpadServer|) (|throwKeyedMsg| 's2iz0071 nil)) + (quiet + (|sockSendInt| |$SessionManager| |$CloseClient|) + (|sockSendInt| |$SessionManager| |$currentFrameNum|) + (|closeInterpreterFrame| nil)) (t - (setq numClients (|queryClients|)) - (cond - ((> numClients 1) - (|sockSendInt| |$SessionManager| |$CloseClient|) - (|sockSendInt| |$SessionManager| |$currentFrameNum|) - (|closeInterpreterFrame| NIL)) - (t - (do ((t0 |$options| (cdr t0)) (t1 nil)) - ((or (atom t0) - (progn (setq t1 (car t0)) nil) - (progn (progn (setq opt (car t1)) t1) nil)) - nil) - (seq - (exit - (progn - (setq fullopt - (|selectOptionLC| opt '(|quiet|) '|optionError|)) - (cond ((eq fullopt '|quiet|) - (setq quiet t))))))) - (cond - (quiet - (|sockSendInt| |$SessionManager| |$CloseClient|) - (|sockSendInt| |$SessionManager| |$currentFrameNum|) - (|closeInterpreterFrame| NIL)) - (t - (setq x (upcase (|queryUserKeyedMsg| 's2iz0072 nil))) - (cond - ((memq (string2id-n x 1) '(yes y)) (bye)) - (t nil)))))))))))))) + (setq x (upcase (|queryUserKeyedMsg| 's2iz0072 nil))) + (when (memq (string2id-n x 1) '(yes y)) (bye))))))))) @ @@ -2530,114 +2474,97 @@ The value of the {\tt )set break} variable then controls what happens. <>= (defun |compiler| (args) - (prog (|$newConlist| optlist optname optargs fullopt havenew haveold - aft ef af af1) - (declare (special |$newConlist|)) - (return - (seq - (progn - (setq |$newConlist| nil) - (cond - ((and (null args) (null |$options|) (null /editfile)) - (|helpSpad2Cmd| '(|compiler|))) - (t - (cond ((null args) (setq args (cons /editfile nil)))) - (setq optlist '(|new| |old| |translate| |constructor|)) - (setq havenew nil) - (setq haveold nil) - (do ((t0 |$options| (CDR t0)) (|opt| NIL)) - ((or (atom t0) - (progn (setq |opt| (car t0)) nil) - (null (null (and havenew haveold)))) - nil) - (seq - (exit - (progn - (setq optname (car |opt|)) - (setq optargs (cdr |opt|)) - (setq fullopt (|selectOptionLC| optname optlist nil)) - (cond - ((eq fullopt '|new|) (setq havenew t)) - ((eq fullopt '|translate|) (setq haveold t)) - ((eq fullopt '|constructor|) (setq haveold t)) - ((eq fullopt '|old|) (setq haveold t))))))) - (cond - ((and havenew haveold) (|throwKeyedMsg| 's2iz0081 nil)) - (t - (setq af (|pathname| args)) - (setq aft (|pathnameType| af)) - (cond - ((or havenew (string= aft "as")) - (cond - ((null (setq af1 ($findfile af '(|as|)))) - (|throwKeyedMsg| 's2il0003 (cons (namestring af) nil))) - (t - (|compileAsharpCmd| (cons af1 nil))))) - ((or haveold (string= aft "spad")) - (cond - ((null (setq af1 ($findfile af '(|spad|)))) - (|throwKeyedMsg| 's2il0003 (cons (namestring af) nil))) - (t - (|compileSpad2Cmd| (cons af1 nil))))) - ((string= aft "lsp") - (cond - ((null (setq af1 ($findfile af '(|lsp|)))) - (|throwKeyedMsg| 's2il0003 (cons (namestring af) nil))) - (t - (|compileAsharpLispCmd| (CONS af1 NIL))))) - ((string= aft "nrlib") - (cond - ((null (setq af1 ($findfile af '(|nrlib|)))) - (|throwKeyedMsg| 'S2IL0003 (cons (namestring af) nil))) - (t - (|compileSpadLispCmd| (cons af1 nil))))) - ((string= aft "ao") - (cond - ((null (setq af1 ($findfile af '(|ao|)))) - (|throwKeyedMsg| 's2il0003 (cons (namestring af) nil))) - (t (|compileAsharpCmd| (cons af1 nil))))) - ((string= aft "al") - (cond - ((null (setq af1 ($findfile af '(|al|)))) - (|throwKeyedMsg| 's2il0003 (cons (namestring af) nil))) - (t (|compileAsharpArchiveCmd| (cons af1 nil))))) - (t - (setq af1 ($findfile af '(|as| |spad| |ao| |asy|))) - (cond - ((and af1 (string= (|pathnameType| af1) "as")) - (|compileAsharpCmd| (CONS af1 NIL))) - ((and af1 (string= (|pathnameType| af1) "ao")) - (|compileAsharpCmd| (CONS af1 NIL))) - ((and af1 (string= (|pathnameType| af1) "spad")) - (|compileSpad2Cmd| (CONS af1 NIL))) - ((and af1 (string= (|pathnameType| af1) "asy")) - (|compileAsharpArchiveCmd| (CONS af1 NIL))) - (t - (setq ef (|pathname| /editfile)) - (setq ef (|mergePathnames| af ef)) - (cond - ((boot-equal ef af) (|throwKeyedMsg| 's2iz0039 nil)) - (t - (setq af ef) - (cond - ((string= (|pathnameType| af) "as") - (|compileAsharpCmd| args)) - ((string= (|pathnameType| af) "ao") - (|compileAsharpCmd| args)) - ((string= (|pathnameType| af) "spad") - (|compileSpad2Cmd| args)) - (t - (setq af1 ($findfile af '(|as| |spad| |ao| |asy|))) - (cond - ((and af1 (string= (|pathnameType| af1) "as")) - (|compileAsharpCmd| (CONS af1 NIL))) - ((and af1 (string= (|pathnameType| af1) "ao")) - (|compileAsharpCmd| (CONS af1 NIL))) - ((and af1 (string= (|pathnameType| af1) "spad")) - (|compileSpad2Cmd| (CONS af1 NIL))) - ((and af1 (string= (|pathnameType| af1) "asy")) - (|compileAsharpArchiveCmd| (CONS af1 NIL))) - (t (|throwKeyedMsg| 's2iz0039 nil)))))))))))))))))))) + (let (|$newConlist| optlist optname optargs havenew haveold aft ef af af1) + (declare (special |$newConlist| |$options|)) + (setq |$newConlist| nil) + (cond + ((and (null args) (null |$options|) (null /editfile)) + (|helpSpad2Cmd| '(|compiler|))) + (t + (cond ((null args) (setq args (cons /editfile nil)))) + (setq optlist '(|new| |old| |translate| |constructor|)) + (setq havenew nil) + (setq haveold nil) + (do ((t0 |$options| (cdr t0)) (opt nil)) + ((or (atom t0) + (progn (setq opt (car t0)) nil) + (null (null (and havenew haveold)))) + nil) + (setq optname (car opt)) + (setq optargs (cdr opt)) + (case (|selectOptionLC| optname optlist nil) + (|new| (setq havenew t)) + (|translate| (setq haveold t)) + (|constructor| (setq haveold t)) + (|old| (setq haveold t)))) + (cond + ((and havenew haveold) + (|throwKeyedMsg| 's2iz0081 nil)) + (t + (setq af (|pathname| args)) + (setq aft (|pathnameType| af)) + (cond + ((or havenew (string= aft "as")) + (if (null (setq af1 ($findfile af '(|as|)))) + (|throwKeyedMsg| 's2il0003 (cons (namestring af) nil)) + (|compileAsharpCmd| (cons af1 nil)))) + ((or haveold (string= aft "spad")) + (if (null (setq af1 ($findfile af '(|spad|)))) + (|throwKeyedMsg| 's2il0003 (cons (namestring af) nil)) + (|compileSpad2Cmd| (cons af1 nil)))) + ((string= aft "lsp") + (if (null (setq af1 ($findfile af '(|lsp|)))) + (|throwKeyedMsg| 's2il0003 (cons (namestring af) nil)) + (|compileAsharpLispCmd| (cons af1 nil)))) + ((string= aft "nrlib") + (if (null (setq af1 ($findfile af '(|nrlib|)))) + (|throwKeyedMsg| 'S2IL0003 (cons (namestring af) nil)) + (|compileSpadLispCmd| (cons af1 nil)))) + ((string= aft "ao") + (if (null (setq af1 ($findfile af '(|ao|)))) + (|throwKeyedMsg| 's2il0003 (cons (namestring af) nil)) + (|compileAsharpCmd| (cons af1 nil)))) + ((string= aft "al") + (if (null (setq af1 ($findfile af '(|al|)))) + (|throwKeyedMsg| 's2il0003 (cons (namestring af) nil)) + (|compileAsharpArchiveCmd| (cons af1 nil)))) + (t + (setq af1 ($findfile af '(|as| |spad| |ao| |asy|))) + (cond + ((and af1 (string= (|pathnameType| af1) "as")) + (|compileAsharpCmd| (cons af1 nil))) + ((and af1 (string= (|pathnameType| af1) "ao")) + (|compileAsharpCmd| (cons af1 nil))) + ((and af1 (string= (|pathnameType| af1) "spad")) + (|compileSpad2Cmd| (cons af1 nil))) + ((and af1 (string= (|pathnameType| af1) "asy")) + (|compileAsharpArchiveCmd| (cons af1 nil))) + (t + (setq ef (|pathname| /editfile)) + (setq ef (|mergePathnames| af ef)) + (cond + ((boot-equal ef af) (|throwKeyedMsg| 's2iz0039 nil)) + (t + (setq af ef) + (cond + ((string= (|pathnameType| af) "as") + (|compileAsharpCmd| args)) + ((string= (|pathnameType| af) "ao") + (|compileAsharpCmd| args)) + ((string= (|pathnameType| af) "spad") + (|compileSpad2Cmd| args)) + (t + (setq af1 ($findfile af '(|as| |spad| |ao| |asy|))) + (cond + ((and af1 (string= (|pathnameType| af1) "as")) + (|compileAsharpCmd| (CONS af1 NIL))) + ((and af1 (string= (|pathnameType| af1) "ao")) + (|compileAsharpCmd| (CONS af1 NIL))) + ((and af1 (string= (|pathnameType| af1) "spad")) + (|compileSpad2Cmd| (CONS af1 NIL))) + ((and af1 (string= (|pathnameType| af1) "asy")) + (|compileAsharpArchiveCmd| (cons af1 nil))) + (t (|throwKeyedMsg| 's2iz0039 nil))))))))))))))))) @ @@ -2736,112 +2663,97 @@ The value of the {\tt )set break} variable then controls what happens. <>= (defun |compileAsharpCmd1| (args) - (prog (path pathtype optlist optname optargs fullopt bequiet docompilelisp + (let (path pathtype optlist optname optargs bequiet docompilelisp moreargs onlyargs dolibrary p tempargs s asharpargs command rc lsp) - (return - (seq - (progn - (setq path (|pathname| args)) - (setq pathtype (|pathnameType| path)) - (cond - ((and (nequal pathtype "as") (nequal pathtype "ao")) - (|throwKeyedMsg| 's2iz0083 nil)) - ((null (probe-file path)) - (|throwKeyedMsg| 's2il0003 (cons (|namestring| args) nil))) - (t - (setq /editfile path) - (|updateSourceFiles| path) - (setq optlist - '(|new| |old| |translate| |onlyargs| |moreargs| |quiet| - |nolispcompile| |noquiet| |library| |nolibrary|)) - (setq bequiet nil) - (setq dolibrary t) - (setq docompilelisp t) - (setq moreargs nil) - (setq onlyargs nil) - (do ((t0 |$options| (cdr t0)) (|opt| nil)) - ((or (atom t0) (progn (setq |opt| (car t0)) nil)) nil) + (declare (special |$options| |$asharpCmdlineFlags||$newConlist|)) + (setq path (|pathname| args)) + (setq pathtype (|pathnameType| path)) + (cond + ((and (nequal pathtype "as") (nequal pathtype "ao")) + (|throwKeyedMsg| 's2iz0083 nil)) + ((null (probe-file path)) + (|throwKeyedMsg| 's2il0003 (cons (|namestring| args) nil))) + (t + (setq /editfile path) + (|updateSourceFiles| path) + (setq optlist + '(|new| |old| |translate| |onlyargs| |moreargs| |quiet| + |nolispcompile| |noquiet| |library| |nolibrary|)) + (setq bequiet nil) + (setq dolibrary t) + (setq docompilelisp t) + (setq moreargs nil) + (setq onlyargs nil) + (dolist (opt |$options|) + (setq optname (car opt)) + (setq optargs (cdr opt)) + (case (|selectOptionLC| optname optlist nil) + (|new| nil) + (|old| (|error| '|Internal error: compileAsharpCmd got )old|)) + (|translate| + (|error| '|Internal error: compileAsharpCmd got )translate|)) + (|quiet| (setq bequiet t)) + (|noquiet| (setq bequiet nil)) + (|nolispcompile| (setq docompilelisp nil)) + (|moreargs| (setq moreargs optargs)) + (|onlyargs| (setq onlyargs optargs)) + (|library| (setq dolibrary t)) + (|nolibrary| (setq dolibrary nil)) + (t + (|throwKeyedMsg| 's2iz0036 + (cons (strconc ")" (|object2String| optname)) nil))))) + (setq tempargs + (if (string= pathtype "ao") + (if (setq p (strpos "-Fao" |$asharpCmdlineFlags| 0 nil)) + (if (eql p 0) + (substring |$asharpCmdlineFlags| 5 nil) + (strconc (substring |$asharpCmdlineFlags| 0 p) + " " (substring |$asharpCmdlineFlags| (plus p 5) nil))) + |$asharpCmdlineFlags|) + |$asharpCmdlineFlags|)) + (setq asharpargs + (cond + (onlyargs + (setq s '||) + (do ((t1 onlyargs (cdr t1)) (|a| nil)) + ((or (atom t1) (progn (setq |a| (car t1)) nil)) nil) (seq (exit - (progn - (setq optname (car |opt|)) - (setq optargs (cdr |opt|)) - (setq fullopt (|selectOptionLC| optname optlist nil)) - (cond - ((eq fullopt '|new|) nil) - ((eq fullopt '|old|) - (|error| '|Internal error: compileAsharpCmd got )old|)) - ((eq fullopt '|translate|) - (|error| '|Internal error: compileAsharpCmd got )translate|)) - ((eq fullopt '|quiet|) (setq bequiet t)) - ((eq fullopt '|noquiet|) (setq bequiet nil)) - ((eq fullopt '|nolispcompile|) - (setq docompilelisp nil)) - ((eq fullopt '|moreargs|) (setq moreargs optargs)) - ((eq fullopt '|onlyargs|) (setq onlyargs optargs)) - ((eq fullopt '|library|) (setq dolibrary t)) - ((eq fullopt '|nolibrary|) (setq dolibrary nil)) - (t - (|throwKeyedMsg| 's2iz0036 - (cons (strconc ")" (|object2String| optname)) nil)))))))) - (setq tempargs - (cond - ((string= pathtype "ao") - (cond - ((setq p (strpos "-Fao" |$asharpCmdlineFlags| 0 nil)) - (cond - ((eql p 0) (substring |$asharpCmdlineFlags| 5 nil)) - (t - (strconc (substring |$asharpCmdlineFlags| 0 p) - " " (substring |$asharpCmdlineFlags| (plus p 5) nil))))) - (t |$asharpCmdlineFlags|))) - (t |$asharpCmdlineFlags|))) - (setq asharpargs - (cond - (onlyargs - (setq s '||) - (do ((t1 onlyargs (cdr t1)) (|a| nil)) - ((or (atom t1) (progn (setq |a| (car t1)) nil)) nil) - (seq - (exit - (setq s (strconc s " " (|object2String| |a|)))))) - s) - (moreargs - (setq s tempargs) - (do ((t2 moreargs (cdr t2)) (|a| nil)) - ((or (atom t2) (progn (setq |a| (car t2)) nil)) nil) - (seq - (exit - (setq s (strconc s " " (|object2String| |a|)))))) - s) - (t tempargs))) - (cond ((null bequiet) - (|sayKeyedMsg| 's2iz0038a - (cons (|namestring| args) (cons asharpargs nil))))) - (setq command - (strconc - (strconc (getenv "ALDORROOT") "/bin/") - '|aldor | asharpargs " " (|namestring| args))) - (setq rc (obey command)) - (cond - ((and (eql rc 0) docompilelisp) - (setq lsp (|fnameMake| "." (|pathnameName| args) "lsp")) - (cond - ((|fnameReadable?| lsp) - (cond - ((null bequiet) - (|sayKeyedMsg| 's2iz0089 (cons (|namestring| lsp) nil)))) - (|compileFileQuietly| lsp)) - (t (|sayKeyedMsg| 's2il0003 (cons (|namestring| lsp) nil)))))) + (setq s (strconc s " " (|object2String| |a|)))))) + s) + (moreargs + (setq s tempargs) + (do ((t2 moreargs (cdr t2)) (|a| nil)) + ((or (atom t2) (progn (setq |a| (car t2)) nil)) nil) + (seq + (exit + (setq s (strconc s " " (|object2String| |a|)))))) + s) + (t tempargs))) + (unless bequiet + (|sayKeyedMsg| 's2iz0038a (list (|namestring| args) asharpargs ))) + (setq command + (strconc + (strconc (getenv "ALDORROOT") "/bin/") + '|aldor | asharpargs " " (|namestring| args))) + (setq rc (obey command)) + (cond + ((and (eql rc 0) docompilelisp) + (setq lsp (|fnameMake| "." (|pathnameName| args) "lsp")) (cond - ((and (eql rc 0) dolibrary) - (cond - ((null bequiet) - (|sayKeyedMsg| 's2iz0090 (cons (|pathnameName| path) nil)))) - (|withAsharpCmd| (cons (|pathnameName| path) nil))) - ((null bequiet) (|sayKeyedMsg| 's2iz0084 nil)) - (t nil)) - (|extendLocalLibdb| |$newConlist|)))))))) + ((|fnameReadable?| lsp) + (unless bequiet + (|sayKeyedMsg| 's2iz0089 (cons (|namestring| lsp) nil))) + (|compileFileQuietly| lsp)) + (t (|sayKeyedMsg| 's2il0003 (cons (|namestring| lsp) nil)))))) + (cond + ((and (eql rc 0) dolibrary) + (unless bequiet + (|sayKeyedMsg| 's2iz0090 (cons (|pathnameName| path) nil))) + (|withAsharpCmd| (cons (|pathnameName| path) nil))) + ((null bequiet) (|sayKeyedMsg| 's2iz0084 nil)) + (t nil)) + (|extendLocalLibdb| |$newConlist|))))) @ @@ -2893,56 +2805,46 @@ The value of the {\tt )set break} variable then controls what happens. <>= (defun |compileAsharpArchiveCmd| (args) - (prog (path dir exists isdir curdir cmd rc asos) - (return - (seq - (progn - (setq path (|pathname| args)) - (cond - ((null (probe-file path)) - (|throwKeyedMsg| 's2il0003 (cons (|namestring| args) nil))) - (t - (setq dir (|fnameMake| "." (|pathnameName| path) "axldir")) - (setq exists (probe-file dir)) - (setq isdir (|directoryp| (|namestring| dir))) - (cond - ((and exists (nequal isdir 1)) - (|throwKeyedMsg| 's2il0027 + (let (path dir exists isdir curdir cmd rc asos) + (declare (special $current-directory)) + (setq path (|pathname| args)) + (if (null (probe-file path)) + (|throwKeyedMsg| 's2il0003 (cons (|namestring| args) nil)) + (progn + (setq dir (|fnameMake| "." (|pathnameName| path) "axldir")) + (setq exists (probe-file dir)) + (setq isdir (|directoryp| (|namestring| dir))) + (if (and exists (nequal isdir 1)) + (|throwKeyedMsg| 's2il0027 (list (|namestring| dir) (|namestring| args))) + (progn + (when (nequal isdir 1) + (setq cmd (strconc "mkdir " (|namestring| dir))) + (setq rc (obey cmd)) + (when (nequal rc 0) + (|throwKeyedMsg| 's2il0027 + (list (|namestring| dir) (|namestring| args))))) + (setq curdir $current-directory) + (|cd| (cons (|object2Identifier| (|namestring| dir)) nil)) + (setq cmd (strconc "ar x " (|namestring| path))) + (setq rc (obey cmd)) + (cond + ((nequal rc 0) + (|cd| (cons (|object2Identifier| (|namestring| curdir)) nil)) + (|throwKeyedMsg| 's2il0028 + (cons (|namestring| dir) (cons (|namestring| args) nil)))) + (t + (setq asos (directory (makestring "*.ao"))) + (cond + ((null asos) + (|cd| (cons (|object2Identifier| (|namestring| curdir)) nil)) + (|throwKeyedMsg| 's2il0029 (cons (|namestring| dir) (cons (|namestring| args) nil)))) - (t - (cond - ((nequal isdir 1) - (setq cmd (strconc "mkdir " (|namestring| dir))) - (setq rc (obey cmd)) - (cond - ((nequal rc 0) - (|throwKeyedMsg| 's2il0027 - (cons (|namestring| dir) (cons (|namestring| args) nil))))))) - (setq curdir $current-directory) - (|cd| (cons (|object2Identifier| (|namestring| dir)) nil)) - (setq cmd (strconc "ar x " (|namestring| path))) - (setq rc (obey cmd)) - (cond - ((nequal rc 0) - (|cd| (cons (|object2Identifier| (|namestring| curdir)) nil)) - (|throwKeyedMsg| 's2il0028 - (cons (|namestring| dir) (cons (|namestring| args) nil)))) - (t - (setq asos (directory (makestring "*.ao"))) - (cond - ((null asos) - (|cd| (cons (|object2Identifier| (|namestring| curdir)) nil)) - (|throwKeyedMsg| 's2il0029 - (cons (|namestring| dir) (cons (|namestring| args) nil)))) - (t - (do ((t0 asos (cdr t0)) (|aso| nil)) - ((or (atom t0) (progn (setq |aso| (car t0)) nil)) nil) - (seq - (exit - (|compileAsharpCmd1| (cons (|namestring| |aso|) nil))))) - (|cd| (CONS (|object2Identifier| (|namestring| curdir)) NIL)) - (|terminateSystemCommand|) - (|spadPrompt|)))))))))))))) + (t + (dolist (aso asos) + (|compileAsharpCmd1| (list (|namestring| |aso|)))) + (|cd| (list (|object2Identifier| (|namestring| curdir)))) + (|terminateSystemCommand|) + (|spadPrompt|))))))))))) @ @@ -2987,57 +2889,46 @@ The value of the {\tt )set break} variable then controls what happens. <>= (defun |compileAsharpLispCmd| (args) - (prog (path optlist optname optargs fullopt bequiet - dolibrary lsp) - (return - (seq - (progn - (setq path (|pathname| args)) - (cond - ((null (probe-file path)) - (|throwKeyedMsg| 's2il0003 (CONS (|namestring| args) NIL))) - (t - (setq optlist '(|quiet| |noquiet| |library| |nolibrary|)) - (setq bequiet nil) - (setq dolibrary t) - (do ((t0 |$options| (cdr t0)) (|opt| nil)) - ((or (atom t0) (progn (setq |opt| (car t0)) nil)) nil) - (seq - (exit - (progn - (setq optname (car |opt|)) - (setq optargs (cdr |opt|)) - (setq fullopt (|selectOptionLC| optname optlist nil)) - (cond - ((eq fullopt '|quiet|) (setq bequiet t)) - ((eq fullopt '|noquiet|) (setq bequiet nil)) - ((eq fullopt '|library|) (setq dolibrary t)) - ((eq fullopt '|nolibrary|) (setq dolibrary nil)) - (t - (|throwKeyedMsg| 's2iz0036 - (cons (strconc ")" (|object2String| optname)) nil)))))))) - (setq lsp - (|fnameMake| - (|pathnameDirectory| path) - (|pathnameName| path) - (|pathnameType| path))) - (cond - ((|fnameReadable?| lsp) - (cond - ((null bequiet) - (|sayKeyedMsg| 's2iz0089 (cons (|namestring| lsp) NIL)))) - (|compileFileQuietly| lsp)) - (t (|sayKeyedMsg| 's2il0003 (cons (|namestring| lsp) nil)))) - (cond - (dolibrary - (cond - ((null bequiet) - (|sayKeyedMsg| 's2iz0090 (cons (|pathnameName| path) nil)))) - (|withAsharpCmd| (CONS (|pathnameName| path) NIL))) - ((null bequiet) (|sayKeyedMsg| 's2iz0084 nil)) - (t nil)) - (|terminateSystemCommand|) - (|spadPrompt|)))))))) + (let (path optlist optname optargs bequiet dolibrary lsp) + (setq path (|pathname| args)) + (cond + ((null (probe-file path)) + (|throwKeyedMsg| 's2il0003 (cons (|namestring| args) nil))) + (t + (setq optlist '(|quiet| |noquiet| |library| |nolibrary|)) + (setq bequiet nil) + (setq dolibrary t) + (dolist (opt |$options|) + (setq optname (car opt)) + (setq optargs (cdr opt)) + (case (|selectOptionLC| optname optlist nil) + (|quiet| (setq bequiet t)) + (|noquiet| (setq bequiet nil)) + (|library| (setq dolibrary t)) + (|nolibrary| (setq dolibrary nil)) + (t + (|throwKeyedMsg| 's2iz0036 + (list (strconc ")" (|object2String| optname))))))) + (setq lsp + (|fnameMake| + (|pathnameDirectory| path) + (|pathnameName| path) + (|pathnameType| path))) + (cond + ((|fnameReadable?| lsp) + (unless bequiet + (|sayKeyedMsg| 's2iz0089 (cons (|namestring| lsp) NIL))) + (|compileFileQuietly| lsp)) + (t (|sayKeyedMsg| 's2il0003 (cons (|namestring| lsp) nil)))) + (cond + (dolibrary + (unless bequiet + (|sayKeyedMsg| 's2iz0090 (cons (|pathnameName| path) nil))) + (|withAsharpCmd| (cons (|pathnameName| path) nil))) + ((null bequiet) (|sayKeyedMsg| 's2iz0084 nil)) + (t nil)) + (|terminateSystemCommand|) + (|spadPrompt|))))) @ @@ -3083,57 +2974,46 @@ The value of the {\tt )set break} variable then controls what happens. <>= (defun |compileSpadLispCmd| (args) - (prog (path optlist optname optargs fullopt beQuiet dolibrary lsp) - (return - (seq - (progn - (setq path (|pathname| (|fnameMake| (car args) "code" "lsp"))) - (cond - ((null (probe-file path)) - (|throwKeyedMsg| 's2il0003 (cons (|namestring| args) nil))) - (t - (setq optlist '(|quiet| |noquiet| |library| |nolibrary|)) - (setq beQuiet nil) - (setq dolibrary t) - (do ((t0 |$options| (cdr t0)) (|opt| nil)) - ((or (atom t0) (progn (setq |opt| (car t0)) nil)) nil) - (seq - (exit - (progn - (setq optname (car |opt|)) - (setq optargs (cdr |opt|)) - (setq fullopt (|selectOptionLC| optname optlist nil)) - (cond - ((eq fullopt '|quiet|) (setq beQuiet t)) - ((eq fullopt '|noquiet|) (setq beQuiet nil)) - ((eq fullopt '|library|) (setq dolibrary t)) - ((eq fullopt '|nolibrary|) (setq dolibrary nil)) - (t - (|throwKeyedMsg| 's2iz0036 - (cons (strconc ")" (|object2String| optname)) nil)))))))) - (setq lsp - (|fnameMake| - (|pathnameDirectory| path) - (|pathnameName| path) - (|pathnameType| path))) - (cond - ((|fnameReadable?| lsp) - (cond - ((null beQuiet) - (|sayKeyedMsg| 's2iz0089 (cons (|namestring| lsp) nil)))) - (recompile-lib-file-if-necessary lsp)) - (t - (|sayKeyedMsg| 's2il0003 (cons (|namestring| lsp) nil)))) - (cond - (dolibrary - (cond - ((null beQuiet) - (|sayKeyedMsg| 's2iz0090 (cons (|pathnameName| path) nil)))) - (localdatabase (cons (|pathnameName| (car args)) nil) nil)) - ((null beQuiet) (|sayKeyedMsg| 's2iz0084 nil)) - (t nil)) - (|terminateSystemCommand|) - (|spadPrompt|)))))))) + (let (path optlist optname optargs beQuiet dolibrary lsp) + (declare (special |$options|)) + (setq path (|pathname| (|fnameMake| (car args) "code" "lsp"))) + (cond + ((null (probe-file path)) + (|throwKeyedMsg| 's2il0003 (cons (|namestring| args) nil))) + (t + (setq optlist '(|quiet| |noquiet| |library| |nolibrary|)) + (setq beQuiet nil) + (setq dolibrary t) + (dolist (opt |$options|) + (setq optname (car opt)) + (setq optargs (cdr opt)) + (case (|selectOptionLC| optname optlist nil) + (|quiet| (setq beQuiet t)) + (|noquiet| (setq beQuiet nil)) + (|library| (setq dolibrary t)) + (|nolibrary| (setq dolibrary nil)) + (t + (|throwKeyedMsg| 's2iz0036 + (list (strconc ")" (|object2String| optname))))))) + (setq lsp + (|fnameMake| + (|pathnameDirectory| path) + (|pathnameName| path) + (|pathnameType| path))) + (cond + ((|fnameReadable?| lsp) + (unless beQuiet (|sayKeyedMsg| 's2iz0089 (list (|namestring| lsp)))) + (recompile-lib-file-if-necessary lsp)) + (t + (|sayKeyedMsg| 's2il0003 (list (|namestring| lsp))))) + (cond + (dolibrary + (unless beQuiet (|sayKeyedMsg| 's2iz0090 (list (|pathnameName| path)))) + (localdatabase (list (|pathnameName| (car args))) nil)) + ((null beQuiet) (|sayKeyedMsg| 's2iz0084 nil)) + (t nil)) + (|terminateSystemCommand|) + (|spadPrompt|))))) @ @@ -3301,9 +3181,9 @@ to construct a list of strings for the sayMessage function and tell the user what options are available. <>= (defun displaySpad2Cmd (l) - (declare (special |$e|)) (let ((|$e| |$EmptyEnvironment|) (opt (car l)) (vl (cdr l)) option optList msg) + (declare (special |$e| |$EmptyEnvironment| |$displayOptions|)) (if (and (pairp l) (not (eq opt '?))) (progn (setq option (|selectOptionLC| opt |$displayOptions| '|optionError|)) diff --git a/changelog b/changelog index bb5312c..5c3e7c9 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +20090317 tpd src/axiom-website/patches.html 20090317.01.tpd.patch +20090317 tpd books/bookvol5 rewrite generated lisp into readable form 20090316 tpd src/axiom-website/patches.html 20090316.02.tpd.patch 20090316 tpd src/interp/sockio.lisp restore sock-send-int 20090316 tpd src/input/setcmd.input fix minor breakage diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 372d908..74c25dd 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1009,5 +1009,7 @@ bookvol5 document collect set support functions
bookvol5 add )expose, add )set break resume
20090316.02.tpd.patch sockio.lisp restore sock-send-int
+20090317.01.tpd.patch +bookvol5 rewrite generated lisp into readable form