diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index 1b42dec..2875b50 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -511,38 +511,31 @@ has the default function \verb|InterpExecuteSpadSystemCommand|. Thus, when a system command is entered this function is called. <>= (defun |SpadInterpretStream| (str source interactive?) - (prog (|$promptMsg| |$shoeReadLineFunction| |$systemCommandFunction| - |$ncMsgList| |$erMsgToss| |$lastPos| |$inclAssertions| - |$okToExecuteMachineCode| |$newcompErrorCount| |$newcompMode| - |$libQuiet| |$fn|) + (let (|$promptMsg| |$shoeReadLineFunction| |$systemCommandFunction| + |$ncMsgList| |$erMsgToss| |$lastPos| |$inclAssertions| + |$okToExecuteMachineCode| |$newcompErrorCount| |$newcompMode| + |$libQuiet| |$fn|) (declare (special |$promptMsg| |$shoeReadLineFunction| |$systemCommandFunction| |$ncMsgList| |$erMsgToss| |$lastPos| |$inclAssertions| |$okToExecuteMachineCode| |$newcompErrorCount| |$newcompMode| |$libQuiet| |$fn| |$nopos|)) - (return - (progn - (setq |$fn| source) - (setq |$libQuiet| (null interactive?)) - (setq |$newcompMode| nil) - (setq |$newcompErrorCount| 0) - (setq |$okToExecuteMachineCode| t) - (setq |$inclAssertions| (list 'aix '|CommonLisp|)) - (setq |$lastPos| |$nopos|) - (setq |$erMsgToss| nil) - (setq |$ncMsgList| nil) - (setq |$systemCommandFunction| #'|InterpExecuteSpadSystemCommand|) - (setq |$shoeReadLineFunction| #'|serverReadLine|) - (setq |$promptMsg| 'S2CTP023) - (cond - (interactive? - (progn - (princ (mkprompt)) - (|intloopReadConsole| "" str) - nil)) - (t - (progn - (|intloopInclude| source 0) - nil))))))) + (setq |$fn| source) + (setq |$libQuiet| (null interactive?)) + (setq |$newcompMode| nil) + (setq |$newcompErrorCount| 0) + (setq |$okToExecuteMachineCode| t) + (setq |$inclAssertions| (list 'aix '|CommonLisp|)) + (setq |$lastPos| |$nopos|) + (setq |$erMsgToss| nil) + (setq |$ncMsgList| nil) + (setq |$systemCommandFunction| #'|InterpExecuteSpadSystemCommand|) + (setq |$shoeReadLineFunction| #'|serverReadLine|) + (setq |$promptMsg| 'S2CTP023) + (if interactive? + (progn + (princ (mkprompt)) + (|intloopReadConsole| "" str)) + (|intloopInclude| source 0)))) @ \section{The Read-Eval-Print Loop} @@ -855,9 +848,12 @@ See:\\ \item The \fnref{zsystemdevelopment} command \end{itemize} +\defdollar{systemCommands} <>= (defvar |$systemCommands| nil) +@ +<>= (eval-when (eval load) (setq |$systemCommands| '( @@ -901,12 +897,16 @@ See:\\ @ -\defdollar{SYSCOMMANDS} +\defdollar{syscommands} This table is used to look up a symbol to see if it might be a command. <>= -(defvar $SYSCOMMANDS nil) +(defvar $syscommands nil) + +@ + +<>= (eval-when (eval load) - (setq $SYSCOMMANDS (mapcar #'car |$systemCommands|))) + (setq $syscommands (mapcar #'car |$systemCommands|))) @ \defdollar{noParseCommands} @@ -930,6 +930,68 @@ all kinds of input that will not be acceptable to the interpreter. ))) @ +\defun{handleNoParseCommands} +The system commands given by the global variable +\verb|$noParseCommands| require essentially no preprocessing/parsing +of their arguments. Here we dispatch the functions which implement +these commands. + +There are four standard commands which receive arguments +\begin{itemize} +\item boot +\item lisp +\item synonym +\item system +\end{itemize} + +There are five standard commands +which do not receive arguments -- +\begin{itemize} +\item quit +\item fin +\item pquit +\item credits +\item copyright +\end{itemize} + +As these commands do not necessarily +exhaust those mentioned in \verb|$noParseCommands|, we provide a +generic dispatch based on two conventions: commands which do not +require an argument name themselves, those which do have their names +prefixed by ``np''. This makes it possible to dynamically define +new system commands provided you handle the argument parsing. + +<>= +(defun |handleNoParseCommands| (unab string) + (let (spaceindex funname) + (setq string (|stripSpaces| string)) + (setq spaceindex (search " " string)) + (cond + ((eq unab '|lisp|) + (if spaceindex + (|nplisp| (|stripLisp| string)) + (|sayKeyedMsg| 's2iv0005 nil))) + ((eq unab '|boot|) + (if spaceindex + (|npboot| (subseq string (1+ spaceindex))) + (|sayKeyedMsg| 's2iv0005 nil))) + ((eq unab '|system|) + (if spaceindex + (|npsystem| unab string) + (|sayKeyedMsg| 's2iv0005 nil))) + ((eq unab '|synonym|) + (if spaceindex + (|npsynonym| unab (subseq string (1+ spaceindex))) + (|npsynonym| unab ""))) + ((null spaceindex) + (funcall unab)) + ((|member| unab '(|quit| |fin| |pquit| |credits| |copyright|)) + (|sayKeyedMsg| 's2iv0005 nil)) + (t + (setq funname (intern (concat "np" (string unab)))) + (funcall funname (subseq string (1+ spaceindex))))))) + +@ \defdollar{tokenCommands} This is a list of the commands that expect the interpreter to parse their arguments. Thus the history command expects that Axiom will have @@ -1033,6 +1095,10 @@ above initial list of synonyms. The user synonyms that are added during a session are pushed onto this list for later lookup. <>= (defvar |$CommandSynonymAlist| nil) + +@ + +<>= (eval-when (eval load) (setq |$CommandSynonymAlist| (copy-alist |$InitialCommandSynonymAlist|))) @@ -1061,6 +1127,7 @@ for processing \verb|)read| of input files. n)))) @ + \defun{ncloopPrefix?} If we find the prefix string in the whole string starting at position zero we return the remainder of the string without the leading prefix. @@ -1070,6 +1137,37 @@ we return the remainder of the string without the leading prefix. (subseq whole (length prefix)))) @ + +\defun{selectOptionLC} +<>= +(defun |selectOptionLC| (x l errorFunction) + (|selectOption| (downcase (|object2Identifier| x)) l errorFunction)) + +@ + +\defun{selectOption} +<>= +(defun |selectOption| (x l errorfunction) + (let (u y) + (cond + ((|member| x l) x) + ((null (identp x)) + (cond + (errorfunction (funcall errorfunction x u)) + (t nil))) + (t + (setq u + (let (t0) + (do ((t1 l (CDR t1)) (y NIL)) + ((or (atom t1) (progn (setq y (car t1)) nil)) (nreverse0 t0)) + (if (|stringPrefix?| (pname x) (pname y)) + (setq t0 (cons y t0)))))) + (cond + ((and (pairp u) (eq (qcdr u) nil) (progn (setq y (qcar u)) t)) y) + (errorfunction (funcall errorfunction x u)) + (t nil)))))) + +@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \cmdhead{abbreviations} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -1167,36 +1265,6 @@ constructor name {\tt VectorFunctions2} from the system: @ \defun{abbreviationsSpad2Cmd} -\begin{verbatim} -;abbreviationsSpad2Cmd l == -; null l => helpSpad2Cmd '(abbreviations) -; abopts := '(query domain category package remove) -; quiet := nil -; for [opt] in $options repeat -; opt := selectOptionLC(opt,'(quiet),'optionError) -; opt = 'quiet => quiet := true -; l is [opt,:al] => -; key := opOf CAR al -; type := selectOptionLC(opt,abopts,'optionError) -; type is 'query => -; null al => listConstructorAbbreviations() -; constructor := abbreviation?(key) => abbQuery(constructor) -; abbQuery(key) -; type is 'remove => -; DELDATABASE(key,'ABBREVIATION) -; ODDP SIZE al => sayKeyedMsg("S2IZ0002",[type]) -; repeat -; null al => return 'fromLoop -; [a,b,:al] := al -; mkUserConstructorAbbreviation(b,a,type) -; SETDATABASE(b,'ABBREVIATION,a) -; SETDATABASE(b,'CONSTRUCTORKIND,type) -; null quiet => -; sayKeyedMsg("S2IZ0001",[a,type,opOf b]) -; nil -; nil -\end{verbatim} - <>= (defun |abbreviationsSpad2Cmd| (arg) (let (abopts quiet opt key type constructor t2 a b al) @@ -1211,22 +1279,16 @@ constructor name {\tt VectorFunctions2} from the system: (progn (setq t1 (car t0)) nil) (progn (progn (setq opt (car t1)) t1) nil)) nil) - (seq - (exit - (progn - (setq opt - (|selectOptionLC| opt '(|quiet|) '|optionError|)) - (cond ((eq opt '|quiet|) - (setq quiet t))))))) - (cond - ((and (pairp arg) + (setq opt (|selectOptionLC| opt '(|quiet|) '|optionError|)) + (when (eq opt '|quiet|) (setq quiet t))) + (when + (and (pairp arg) (progn (setq opt (qcar arg)) (setq al (qcdr arg)) t)) (setq key (|opOf| (car al))) - (setq type - (|selectOptionLC| opt abopts '|optionError|)) + (setq type (|selectOptionLC| opt abopts '|optionError|)) (cond ((eq type '|query|) (cond @@ -1237,7 +1299,7 @@ constructor name {\tt VectorFunctions2} from the system: ((eq type '|remove|) (deldatabase key 'abbreviation)) ((oddp (size al)) - (|sayKeyedMsg| 's2iz0002 (cons type nil))) + (|sayKeyedMsg| 's2iz0002 (list type))) (t (do () (nil nil) (seq @@ -1252,11 +1314,8 @@ constructor name {\tt VectorFunctions2} from the system: (|mkUserConstructorAbbreviation| b a type) (setdatabase b 'abbreviation a) (setdatabase b 'constructorkind type)))))) - (cond ((null quiet) - (progn - (|sayKeyedMsg| 's2iz0001 - (cons a (cons type (cons (|opOf| b) nil)))) nil)))))) - (t nil)))))) + (unless quiet + (|sayKeyedMsg| 's2iz0001 (list a type (|opOf| b))))))))))) @ @@ -1658,6 +1717,12 @@ system function and constructor caches. \fnref{frame}, and \fnref{undo} +\defdollar{clearOptions} +<>= +(defvar |$clearOptions| '(|modes| |operations| |properties| |types| |values|)) + +@ + \defun{clear} <>= (defun |clear| (l) @@ -1687,9 +1752,8 @@ system function and constructor caches. <>= (defun |clearSpad2Cmd| (l) - (let (|$clearExcept| |opt| |optList| |arg|) + (let (|$clearExcept| opt optlist arg) (declare (special |$clearExcept| |$options| |$clearOptions|)) - (setq |$clearExcept| nil) (cond (|$options| (setq |$clearExcept| @@ -1702,31 +1766,31 @@ system function and constructor caches. ((or t1 (atom t2) (progn (setq t3 (car t2)) nil) - (progn (progn (setq |opt| (car t3)) t3) nil)) + (progn (progn (setq opt (car t3)) t3) nil)) t0) (setq t0 (and t0 (eq - (|selectOptionLC| |opt| '(|except|) '|optionError|) + (|selectOptionLC| opt '(|except|) '|optionError|) '|except|))))))))) (cond ((null l) - (setq |optList| + (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))) + (|sayKeyedMsg| 's2iz0010 (list optlist))) (t - (setq |arg| + (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)) + ((eq arg '|all|) (|clearCmdAll|)) + ((eq arg '|completely|) (|clearCmdCompletely|)) + ((eq arg '|scaches|) (|clearCmdSortedCaches|)) + (|$clearExcept| (|clearCmdExcept| l)) (t (|clearCmdParts| l) (|updateCurrentInterpreterFrame|))))))) @@ -3174,7 +3238,8 @@ All of the other options are just subcases. There is a slight mismatch between the \$displayOptions list of symbols and the options this command accepts so we have a cond -branch to clean up the option variable. +branch to clean up the option variable. This allows for the options +to be plural. If we fall all the way thru we use the \$displayOptions list to construct a list of strings for the sayMessage function @@ -3213,6 +3278,20 @@ and tell the user what options are available. (format nil "~% or abbreviations thereof")))))) @ + +\defun{abbQuery} +<>= +(defun |abbQuery| (x) + (let (abb) + (cond + ((setq abb (getdatabase x 'abbreviation)) + (|sayKeyedMsg| 's2iz0001 (list abb (getdatabase x 'constructorkind) x))) + ((setq abb (getdatabase x 'constructor)) + (|sayKeyedMsg| 's2iz0001 (list x (getdatabase abb 'constructorkind) abb))) + (t + (|sayKeyedMsg| 's2iz0003 (list x)))))) + +@ \defun{displayOperations} This function takes a list of operation names. If the list is null we query the user to see if they want all operations printed. Otherwise @@ -3479,6 +3558,38 @@ calls {\tt emacs} to edit the file. \fnref{compiler}, and \fnref{read} +\defun{edit} +<>= +(defun |edit| (l) (|editSpad2Cmd| l)) + +@ + +\defun{editSpad2Cmd} +<>= +(defun |editSpad2Cmd| (l) + (let (olddir filetypes ll rc) + (setq l (cond ((null l) /editfile) (t (car l)))) + (setq l (|pathname| l)) + (setq olddir (|pathnameDirectory| l)) + (setq filetypes + (cond + ((|pathnameType| l) (list (|pathnameType| l))) + ((eq |$UserLevel| '|interpreter|) '("input" "INPUT" "spad" "SPAD")) + ((eq |$UserLevel| '|compiler|) '("input" "INPUT" "spad" "SPAD")) + (t '("input" "INPUT" "spad" "SPAD" "boot" "BOOT" + "lisp" "LISP" "meta" "META")))) + (setq ll + (cond + ((string= olddir "") + (|pathname| ($findfile (|pathnameName| l) filetypes))) + (t l))) + (setq l (|pathname| ll)) + (setq /editfile l) + (setq rc (|editFile| l)) + (|updateSourceFiles| l) + rc)) + +@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \cmdhead{fin} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -7496,7 +7607,7 @@ explanations see the list structure section \ref{Theliststructure}. (dolist (setdata settree) (case (fourth setdata) (FUNCTION - (if (|functionp| (fifth setdata)) + (if (functionp (fifth setdata)) (funcall (fifth setdata) '|%initialize%|)) (|sayMSG| " Function not implemented.")) (INTEGER (set (fifth setdata) (seventh setdata))) @@ -7554,7 +7665,7 @@ explanations see the list structure section \ref{Theliststructure}. (case (fourth setdata) (FUNCTION (terpri) - (if (|functionp| (fifth setdata)) + (if (functionp (fifth setdata)) (funcall (fifth setdata) '|%describe%|) (|sayMSG| " Function not implemented."))) (INTEGER @@ -7612,7 +7723,7 @@ explanations see the list structure section \ref{Theliststructure}. (case (fourth setdata) (FUNCTION (setq opt - (if (|functionp| (fifth setdata)) + (if (functionp (fifth setdata)) (funcall (fifth setdata) '|%display%|) "unimplemented")) (cond @@ -8706,6 +8817,57 @@ linker linker arguments (e.g. libraries to search) -lxlf "/tmp/")) NIL) @ + +\defun{setFortTmpDir} +<>= +(defun |setFortTmpDir| (arg) + (let (mode) + (cond + ((eq arg '|%initialize%|) (setq |$fortranTmpDir| "/tmp/")) + ((eq arg '|%display%|) + (if (stringp |$fortranTmpDir|) + |$fortranTmpDir| + (pname |$fortranTmpDir|))) + ((or (null arg) (eq arg '|%describe%|) (eq (car arg) '?)) + (|describeSetFortTmpDir|)) + ((null (setq mode (|validateOutputDirectory| arg))) + (|sayBrightly| + `(" Sorry, but your argument(s)" ,@(|bright| arg) + "is(are) not valid." |%l|)) + (|describeSetFortTmpDir|)) + (t (setq |$fortranTmpDir| mode))))) + +@ + +\defun{validateOutputDirectory} +<>= +(defun |validateOutputDirectory| (x) + (let ((dirname (car x))) + (when (and (pathname-directory dirname) (null (probe-file dirname))) + dirname))) + +@ + +\defun{describeSetFortTmpDir} +<>= +(defun |describeSetFortTmpDir| () + (|sayBrightly| (list + '|%b| ")set fortran calling tempfile" + '|%d| " is used to tell AXIOM where" + '|%l| " to place intermediate FORTRAN data files . This must be the " + '|%l| " name of a valid existing directory to which you have permission " + '|%l| " to write (including the final slash)." + '|%l| + '|%l| " Syntax:" + '|%l| " )set fortran calling tempfile DIRECTORYNAME" + '|%l| + '|%l| " The current setting is" + '|%b| |$fortranTmpDir| + '|%d|))) + +@ + + \subsubsection{directory} \begin{verbatim} -------------------- The directory Option --------------------- @@ -8735,6 +8897,47 @@ linker linker arguments (e.g. libraries to search) -lxlf "./")) NIL) @ + +\defun{setFortDir} +<>= +(defun |setFortDir| (arg) + (declare (special |$fortranDirectory|)) + (let (mode) + (COND + ((eq arg '|%initialize%|) (setq |$fortranDirectory| "./")) + ((eq arg '|%display%|) + (if (stringp |$fortranDirectory|) + |$fortranDirectory| + (pname |$fortranDirectory|))) + ((or (null arg) (eq arg '|%describe%|) (eq (car arg) '?)) + (|describeSetFortDir|)) + ((null (setq mode (|validateOutputDirectory| arg))) + (|sayBrightly| + `(" Sorry, but your argument(s)" ,@(|bright| arg) + "is(are) not valid." |%l|)) + (|describeSetFortDir|)) + (t (setq |$fortranDirectory| mode))))) + +@ +\defun{describeSetFortDir} +<>= +(defun |describeSetFortDir| () + (declare (special |$fortranDirectory|)) + (|sayBrightly| (list + '|%b| ")set fortran calling directory" + '|%d| " is used to tell AXIOM where" + '|%l| " to place generated FORTRAN files. This must be the name " + '|%l| " of a valid existing directory to which you have permission " + '|%l| " to write (including the final slash)." + '|%l| + '|%l| " Syntax:" + '|%l| " )set fortran calling directory DIRECTORYNAME" + '|%l| + '|%l| " The current setting is" + '|%b| |$fortranDirectory| + '|%d|))) + +@ \subsubsection{linker} \begin{verbatim} ---------------------- The linker Option ---------------------- @@ -8766,6 +8969,45 @@ linker linker arguments (e.g. libraries to search) -lxlf NIL ) @ + +\defun{setLinkerArgs} +<>= +(defun |setLinkerArgs| (arg) + (declare (special |$fortranLibraries|)) + (cond + ((eq arg '|%initialize%|) (setq |$fortranLibraries| "-lxlf")) + ((eq arg '|%display%|) (|object2String| |$fortranLibraries|)) + ((or (null arg) (eq arg '|%describe%|) (eq (car arg) '?)) + (|describeSetLinkerArgs|)) + ((and (listp arg) (stringp (car arg))) + (setq |$fortranLibraries| (car arg))) + (t (|describeSetLinkerArgs|)))) + +@ + +\defun{describeSetLinkerArgs} +<>= +(defun |describeSetLinkerArgs| () + (declare (special |$fortranLibraries|)) + (|sayBrightly| (list + '|%b| ")set fortran calling linkerargs" + '|%d| " is used to pass arguments to the linker" + '|%l| " when using " + '|%b| "mkFort" + '|%d| " to create functions which call Fortran code." + '|%l| " For example, it might give a list of libraries to be searched," + '|%l| " and their locations." + '|%l| " The string is passed verbatim, so must be the correct syntax for" + '|%l| " the particular linker being used." + '|%l| + '|%l| " Example: )set fortran calling linker \"-lxlf\"" + '|%l| + '|%l| " The current setting is" + '|%b| |$fortranLibraries| + '|%d|))) + +@ + \section{kernel} \begin{verbatim} Current Values of kernel Variables @@ -10436,7 +10678,7 @@ prettyprint prettyprint BOOT func's as they compile off <>= (eval-when (eval load) - (|initializeSetVariables| |$setOptions|) + (|initializeSetVariables| |$setOptions|)) @ @@ -10480,11 +10722,11 @@ which gets called with \verb|%describe%| ((null l) (|displaySetVariableSettings| settree '||)) (t (setq |$setOptionNames| - (do ((t1 settree (cdr t1)) t0 (|x| nil)) - ((or (atom t1) (progn (setq |x| (car t1)) nil)) (nreverse0 t0)) + (do ((t1 settree (cdr t1)) t0 (x nil)) + ((or (atom t1) (progn (setq x (car t1)) nil)) (nreverse0 t0)) (seq (exit - (setq t0 (cons (elt |x| 0) t0)))))) + (setq t0 (cons (elt x 0) t0)))))) (setq arg (|selectOption| (downcase (car l)) |$setOptionNames| '|optionError|)) (setq setdata (cons arg (lassoc arg settree))) @@ -10500,7 +10742,7 @@ which gets called with \verb|%describe%| (if (eq (elt l 1) 'default) '|%initialize%| (kdr l))) - (if (|functionp| (fifth setdata)) + (if (functionp (fifth setdata)) (funcall (fifth setdata) setfunarg) (|sayMSG| " Function not implemented.")) (when |$displaySetValue| @@ -11208,7 +11450,7 @@ This reports the traced functions (defun |trace1| (arg) (prog (|$traceNoisely| constructor |ops| |lops| temp1 opt a |oldL| |newOptions| |domain| |traceList| |optionList| |domainList| - |opList| |y| |varList| |argument|) + |opList| y |varList| |argument|) (declare (special |$traceNoisely|)) (return (seq @@ -11327,8 +11569,8 @@ This reports the traced functions (t nil))) (setq |varList| (cond - ((setq |y| (lassoc '|vars| |optionList|)) - (list (cons '|vars| |y|))) + ((setq y (lassoc '|vars| |optionList|)) + (list (cons '|vars| y))) (t nil))) (append |domainList| (append |opList| |varList|))))) (|optionList| (append |traceList| |optionList|)) @@ -11534,59 +11776,59 @@ This reports the traced functions <>= (defun |getTraceOption| (arg) - (prog (|l| |opts| key a |n|) + (prog (l |opts| key a |n|) (return (seq (progn (setq key (car arg)) - (setq |l| (cdr arg)) + (setq l (cdr arg)) (setq key (|selectOptionLC| key |$traceOptionList| '|traceOptionError|)) - (setq arg (cons key |l|)) + (setq arg (cons key l)) (cond ((memq key '(|nonquietly| |timer| |nt|)) arg) ((eq key '|break|) (cond - ((null |l|) (cons '|break| (cons '|before| nil))) + ((null l) (cons '|break| (cons '|before| nil))) (t (setq |opts| (prog (t0) (setq t0 nil) (return - (do ((t1 |l| (cdr t1)) (|y| nil)) + (do ((t1 l (cdr t1)) (y nil)) ((or (atom t1) - (progn (setq |y| (car t1)) nil)) + (progn (setq y (car t1)) nil)) (nreverse0 t0)) (seq (exit (setq t0 (cons - (|selectOptionLC| |y| '(|before| |after|) nil) t0)))))))) + (|selectOptionLC| y '(|before| |after|) nil) t0)))))))) (cond ((prog (t2) (setq t2 t) (return - (do ((t3 nil (null t2)) (t4 |opts| (cdr t4)) (|y| nil)) - ((or t3 (atom t4) (progn (setq |y| (car t4)) nil)) t2) + (do ((t3 nil (null t2)) (t4 |opts| (cdr t4)) (y nil)) + ((or t3 (atom t4) (progn (setq y (car t4)) nil)) t2) (seq (exit - (setq t2 (and t2 (identp |y|)))))))) + (setq t2 (and t2 (identp y)))))))) (cons '|break| |opts|)) (t (|stackTraceOptionError| (cons 's2it0008 (cons nil nil)))))))) ((eq key '|restore|) (cond - ((null |l|) arg) + ((null l) arg) (t (|stackTraceOptionError| (cons 's2it0009 (cons (cons (strconc ")" (|object2String| key)) nil) nil)))))) - ((eq key '|only|) (cons '|only| (|transOnlyOption| |l|))) + ((eq key '|only|) (cons '|only| (|transOnlyOption| l))) ((eq key '|within|) (cond - ((and (pairp |l|) - (eq (qcdr |l|) nil) - (progn (setq a (qcar |l|)) t) + ((and (pairp l) + (eq (qcdr l) nil) + (progn (setq a (qcar l)) t) (identp a)) arg) (t @@ -11598,10 +11840,10 @@ This reports the traced functions ((eq key '|cond|) '|when|) (t key))) (cond - ((and (pairp |l|) - (eq (qcdr |l|) nil) - (progn (setq a (qcar |l|)) t)) - (cons key |l|)) + ((and (pairp l) + (eq (qcdr l) nil) + (progn (setq a (qcar l)) t)) + (cons key l)) (t (|stackTraceOptionError| (cons 's2it0011 @@ -11610,9 +11852,9 @@ This reports the traced functions (|object2String| key)) nil) nil)))))) ((eq key '|depth|) (cond - ((and (pairp |l|) - (eq (qcdr |l|) nil) - (progn (setq |n| (qcar |l|)) t) + ((and (pairp l) + (eq (qcdr l) nil) + (progn (setq |n| (qcar l)) t) (fixp |n|)) arg) (t @@ -11620,10 +11862,10 @@ This reports the traced functions (cons 's2it0012 (cons (cons ")depth" nil) nil)))))) ((eq key '|count|) (cond - ((or (null |l|) - (and (pairp |l|) - (eq (qcdr |l|) nil) - (progn (setq |n| (qcar |l|)) t) + ((or (null l) + (and (pairp l) + (eq (qcdr l) nil) + (progn (setq |n| (qcar l)) t) (fixp |n|))) arg) (t @@ -11634,17 +11876,17 @@ This reports the traced functions (prog (t5) (setq t5 nil) (return - (do ((t6 |l| (cdr t6)) (|y| nil)) - ((or (atom t6) (progn (setq |y| (car t6)) nil)) (nreverse0 t5)) + (do ((t6 l (cdr t6)) (y nil)) + ((or (atom t6) (progn (setq y (car t6)) nil)) (nreverse0 t5)) (seq (exit - (setq t5 (cons (|getTraceOption,hn| |y|) t5))))))))) + (setq t5 (cons (|getTraceOption,hn| y) t5))))))))) ((memq key '(|local| |ops| |vars|)) (cond - ((or (null |l|) - (and (pairp |l|) (eq (qcdr |l|) nil) (eq (qcar |l|) '|all|))) + ((or (null l) + (and (pairp l) (eq (qcdr l) nil) (eq (qcar l) '|all|))) (cons key '|all|)) - ((|isListOfIdentifiersOrStrings| |l|) arg) + ((|isListOfIdentifiersOrStrings| l) arg) (t (|stackTraceOptionError| (cons 's2it0015 @@ -11652,10 +11894,10 @@ This reports the traced functions (cons (strconc ")" (|object2String| key)) nil) nil)))))) ((eq key '|varbreak|) (cond - ((or (null |l|) - (and (pairp |l|) (eq (qcdr |l|) nil) (eq (qcar |l|) '|all|))) + ((or (null l) + (and (pairp l) (eq (qcdr l) nil) (eq (qcar l) '|all|))) (cons '|varbreak| '|all|)) - ((|isListOfIdentifiers| |l|) arg) + ((|isListOfIdentifiers| l) arg) (t (|stackTraceOptionError| (cons 's2it0016 @@ -11663,7 +11905,7 @@ This reports the traced functions (cons (strconc ")" (|object2String| key)) nil) nil)))))) ((eq key '|mathprint|) (cond - ((null |l|) arg) + ((null l) arg) (t (|stackTraceOptionError| (cons 's2it0009 @@ -11851,20 +12093,20 @@ This reports the traced functions <>= (defun |transOnlyOption| (arg) - (prog (|y| |n|) + (prog (y |n|) (return (cond ((and (pairp arg) - (progn (setq |n| (qcar arg)) (setq |y| (qcdr arg)) t)) + (progn (setq |n| (qcar arg)) (setq y (qcdr arg)) t)) (cond ((fixp |n|) - (cons |n| (|transOnlyOption| |y|))) + (cons |n| (|transOnlyOption| y))) ((memq (setq |n| (upcase |n|)) '(V A C)) - (cons |n| (|transOnlyOption| |y|))) + (cons |n| (|transOnlyOption| y))) (t (|stackTraceOptionError| (cons 's2it0006 (cons (cons |n| nil) nil))) - (|transOnlyOption| |y|)))) + (|transOnlyOption| y)))) (t nil))))) @ @@ -11915,17 +12157,17 @@ This reports the traced functions <>= (defun |domainToGenvar| (arg) - (prog (|$doNotAddEmptyModeIfTrue| |y| |g|) + (prog (|$doNotAddEmptyModeIfTrue| y |g|) (declare (special |$doNotAddEmptyModeIfTrue|)) (return (progn (setq |$doNotAddEmptyModeIfTrue| t) (cond - ((and (setq |y| (|unabbrevAndLoad| arg)) - (eq (getdatabase (|opOf| |y|) 'constructorkind) '|domain|)) + ((and (setq y (|unabbrevAndLoad| arg)) + (eq (getdatabase (|opOf| y) 'constructorkind) '|domain|)) (progn - (setq |g| (|genDomainTraceName| |y|)) - (set |g| (|evalDomain| |y|)) |g|))))))) + (setq |g| (|genDomainTraceName| y)) + (set |g| (|evalDomain| y)) |g|))))))) @ @@ -12020,7 +12262,7 @@ This reports the traced functions <>= (defun |transTraceItem| (x) - (prog (|$doNotAddEmptyModeIfTrue| |value| |y|) + (prog (|$doNotAddEmptyModeIfTrue| |value| y) (declare (special |$doNotAddEmptyModeIfTrue|)) (return (progn @@ -12033,18 +12275,18 @@ This reports the traced functions '((|Mode|) (|Domain|) (|SubDomain| (|Domain|))))) (setq x (|objVal| |value|)) (cond - ((setq |y| (|domainToGenvar| x)) |y|) + ((setq y (|domainToGenvar| x)) y) (t x))) ((upper-case-p (elt (stringimage x) 0)) - (setq |y| (|unabbrev| x)) + (setq y (|unabbrev| x)) (cond - ((|constructor?| |y|) |y|) - ((and (pairp |y|) (|constructor?| (car |y|))) (car |y|)) - ((setq |y| (|domainToGenvar| x)) |y|) + ((|constructor?| y) y) + ((and (pairp y) (|constructor?| (car y))) (car y)) + ((setq y (|domainToGenvar| x)) y) (t x))) (t x))) ((vecp (car x)) (|transTraceItem| (|devaluate| (car x)))) - ((setq |y| (|domainToGenvar| x)) |y|) + ((setq y (|domainToGenvar| x)) y) (t (|throwKeyedMsg| 's2it0018 (cons x nil)))))))) @ @@ -12217,16 +12459,16 @@ This reports the traced functions <>= (defun |coerceTraceFunValue2E| (|traceName| |subName| |value|) - (prog (name |u|) + (prog (name u) (return (cond ((memq (setq name |subName|) |$mathTraceList|) (cond ((spadsysnamep (pname |traceName|)) (|coerceSpadFunValue2E| |value|)) - ((setq |u| (lassoc |subName| |$tracedMapSignatures|)) + ((setq u (lassoc |subName| |$tracedMapSignatures|)) (|objValUnwrap| (|coerceInteractive| - (|objNewWrap| |value| (CAR |u|)) + (|objNewWrap| |value| (CAR u)) |$OutputForm|))) (t |value|))) (t |value|))))) @@ -12393,10 +12635,10 @@ This reports the traced functions <>= (defun |lassocSub| (x |subs|) - (prog (|y|) + (prog (y) (return (cond - ((setq |y| (lassq x |subs|)) |y|) + ((setq y (lassq x |subs|)) y) (t x))))) @ @@ -12410,10 +12652,10 @@ This reports the traced functions <>= (defun |rassocSub| (x |subs|) - (prog (|y|) + (prog (y) (return (cond - ((setq |y| (|rassoc| x |subs|)) |y|) + ((setq y (|rassoc| x |subs|)) y) (t x))))) @ @@ -12576,16 +12818,16 @@ This reports the traced functions (prog (t0) (setq t0 nil) (return - (do ((t1 ops (cdr t1)) (|u| nil)) - ((or (atom t1) (progn (setq |u| (car t1)) nil)) (nreverse0 t0)) + (do ((t1 ops (cdr t1)) (u nil)) + ((or (atom t1) (progn (setq u (car t1)) nil)) (nreverse0 t0)) (seq (exit (cond - ((and (pairp |u|) + ((and (pairp u) (progn - (setq tmp1 (qcar |u|)) + (setq tmp1 (qcar u)) (and (pairp tmp1) (equal (qcar tmp1) opname)))) - (setq t0 (cons |u| t0)))))))))))))) + (setq t0 (cons u t0)))))))))))))) @ @@ -13171,25 +13413,25 @@ This reports the traced functions <>= (defun |letPrint| (x |val| |currentFunction|) - (prog (|y|) + (prog (y) (return (progn (cond ((and |$letAssoc| (or - (setq |y| (lassoc |currentFunction| |$letAssoc|)) - (setq |y| (lassoc '|all| |$letAssoc|)))) + (setq y (lassoc |currentFunction| |$letAssoc|)) + (setq y (lassoc '|all| |$letAssoc|)))) (cond - ((and (or (eq |y| '|all|) - (memq x |y|)) + ((and (or (eq y '|all|) + (memq x y)) (null (or (is_genvar x) (|isSharpVarWithNum| x) (gensymp x)))) (|sayBrightlyNT| (append (|bright| x) (cons '|: | nil))) (prin0 (|shortenForPrinting| |val|)) (terpri))) (cond - ((and (setq |y| (|hasPair| 'break |y|)) - (or (eq |y| '|all|) - (and (memq x |y|) + ((and (setq y (|hasPair| 'break y)) + (or (eq y '|all|) + (and (memq x y) (null (memq (elt (pname x) 0) '($ |#|))) (null (gensymp x))))) (|break| @@ -13228,18 +13470,18 @@ This reports the traced functions <>= (defun |letPrint2| (x |printform| |currentFunction|) - (prog (|$BreakMode| |flag| |y|) + (prog (|$BreakMode| |flag| y) (declare (special |$BreakMode|)) (return (progn (setq |$BreakMode| nil) (cond ((and |$letAssoc| - (or (setq |y| (lassoc |currentFunction| |$letAssoc|)) - (setq |y| (lassoc '|all| |$letAssoc|)))) + (or (setq y (lassoc |currentFunction| |$letAssoc|)) + (setq y (lassoc '|all| |$letAssoc|)))) (cond ((and - (or (eq |y| '|all|) (memq x |y|)) + (or (eq y '|all|) (memq x y)) (null (or (is_genvar x) (|isSharpVarWithNum| x) (gensymp x)))) (setq |$BreakMode| '|letPrint2|) (setq |flag| nil) @@ -13250,10 +13492,10 @@ This reports the traced functions (t nil)))) (cond ((and - (setq |y| (|hasPair| 'break |y|)) - (or (eq |y| '|all|) + (setq y (|hasPair| 'break y)) + (or (eq y '|all|) (and - (memq x |y|) + (memq x y) (null (memq (elt (pname x) 0) '($ |#|))) (null (gensymp x))))) (|break| @@ -13290,18 +13532,18 @@ This reports the traced functions <>= (defun |letPrint3| (x |xval| |printfn| |currentFunction|) - (prog (|$BreakMode| |flag| |y|) + (prog (|$BreakMode| |flag| y) (declare (special |$BreakMode|)) (return (progn (setq |$BreakMode| nil) (cond ((and |$letAssoc| - (or (setq |y| (lassoc |currentFunction| |$letAssoc|)) - (setq |y| (lassoc '|all| |$letAssoc|)))) + (or (setq y (lassoc |currentFunction| |$letAssoc|)) + (setq y (lassoc '|all| |$letAssoc|)))) (cond ((and - (or (eq |y| '|all|) (memq x |y|)) + (or (eq y '|all|) (memq x y)) (null (or (is_genvar x) (|isSharpVarWithNum| x) (gensymp x)))) (setq |$BreakMode| '|letPrint2|) (setq |flag| nil) @@ -13314,11 +13556,11 @@ This reports the traced functions (t nil)))) (cond ((and - (setq |y| (|hasPair| 'break |y|)) + (setq y (|hasPair| 'break y)) (or - (eq |y| '|all|) + (eq y '|all|) (and - (memq x |y|) + (memq x y) (null (memq (elt (pname x) 0) '($ |#|))) (null (gensymp x))))) (|break| @@ -13461,7 +13703,7 @@ This reports the traced functions <>= (defun |reportSpadTrace| (|header| t0) - (prog (|op| |sig| |n| |t| |msg| |namePart| |y| |tracePart|) + (prog (|op| |sig| |n| |t| |msg| |namePart| y |tracePart|) (return (progn (setq |op| (car t0)) @@ -13485,11 +13727,11 @@ This reports the traced functions (setq |namePart| nil) (setq |tracePart| (cond - ((and (pairp |t|) (progn (setq |y| (qcar |t|)) t) (null (null |y|))) + ((and (pairp |t|) (progn (setq y (qcar |t|)) t) (null (null y))) (cond - ((eq |y| '|all|) + ((eq y '|all|) (cons '|%b| (cons '|all| (cons '|%d| (cons '|vars| nil))))) - (t (cons '| vars: | (cons |y| nil))))) + (t (cons '| vars: | (cons y nil))))) (t nil))) (|sayBrightly| (append |msg| (append |namePart| |tracePart|))))))))) @@ -13921,7 +14163,7 @@ This reports the traced functions <>= (defun |?t| () - (prog (|llm| x |d| |l| |suffix|) + (prog (|llm| x |d| l |suffix|) (return (seq (cond @@ -13948,7 +14190,7 @@ This reports the traced functions (exit (cond ((and (pairp x) - (progn (setq |d| (qcar x)) (setq |l| (qcdr x)) t) + (progn (setq |d| (qcar x)) (setq l (qcdr x)) t) (|isDomainOrPackage| |d|)) (progn (setq |suffix| (cond ((|isDomain| |d|) "domain") (t "package"))) @@ -13959,7 +14201,7 @@ This reports the traced functions (cons (|devaluate| |d|) (cons '|%d| (cons ":" nil))))))) - (do ((t2 (|orderBySlotNumber| |l|) (cdr t2)) (x nil)) + (do ((t2 (|orderBySlotNumber| l) (cdr t2)) (x nil)) ((or (atom t2) (progn (setq x (car t2)) nil)) nil) (seq (exit @@ -13990,7 +14232,7 @@ This reports the traced functions <>= (defun |tracelet| (|fn| |vars|) - (prog ($traceletflag |$QuickLet| |l|) + (prog ($traceletflag |$QuickLet| l) (declare (special $traceletflag |$QuickLet|)) (return (progn @@ -14006,7 +14248,7 @@ This reports the traced functions (setq |vars| (cond ((eq |vars| '|all|) '|all|) - ((setq |l| (lassoc |fn| |$letAssoc|)) (|union| |vars| |l|)) + ((setq l (lassoc |fn| |$letAssoc|)) (|union| |vars| l)) (t |vars|))) (setq |$letAssoc| (cons (cons |fn| |vars|) |$letAssoc|)) (cond (|$letAssoc| (setletprintflag t))) @@ -14357,13 +14599,13 @@ recordFrame(systemNormal) == (prog (tmp2) (setq tmp2 nil) (return - (do ((tmp3 (cdr x) (cdr tmp3)) (|y| nil)) + (do ((tmp3 (cdr x) (cdr tmp3)) (y nil)) ((or (atom tmp3) - (progn (setq |y| (car tmp3)) nil)) + (progn (setq y (car tmp3)) nil)) (nreverse0 tmp2)) (seq (exit - (setq tmp2 (cons (cons (car |y|) (cdr |y|)) tmp2)))))))) + (setq tmp2 (cons (cons (car y) (cdr y)) tmp2)))))))) tmp0)))))))) (car |$frameRecord|))))))) @@ -15053,6 +15295,13 @@ The command synonym {\tt )apropos} is equivalent to \fnref{set}, and \fnref{show} +\defdollar{whatOptions} +<>= +(defvar |$whatOptions| '(|operations| |categories| |domains| |packages| + |commands| |synonyms| |things|)) + +@ + \defun{what} \begin{verbatim} what l == whatSpad2Cmd l @@ -15175,17 +15424,17 @@ filterAndFormatConstructors(constrType,label,patterns) == <>= (defun |filterAndFormatConstructors| (|constrType| |label| |patterns|) - (prog (|l|) + (prog (l) (return (progn (|centerAndHighlight| |label| $linelength (|specialChar| '|hbar|)) - (setq |l| + (setq l (|filterListOfStringsWithFn| |patterns| (|whatConstructors| |constrType|) (|function| cdr))) (cond (|patterns| (cond - ((null |l|) + ((null l) (|sayMessage| (cons " No " (cons |label| @@ -15204,7 +15453,7 @@ filterAndFormatConstructors(constrType,label,patterns) == (cons '|%b| (append (|blankList| |patterns|) (cons '|%d| nil)))))))))))) - (cond (|l| (|pp2Cols| |l|))))))) + (cond (l (|pp2Cols| l))))))) @ @@ -15695,13 +15944,131 @@ load the file \verb|exposed.lsp| to set up the exposure group information. @ +\chapter{Special Lisp Functions} + +\defmacro{identp} +<>= +(defmacro identp (x) + (if (atom x) + `(and ,x (symbolp ,x)) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (and ,xx (symbolp ,xx)))))) + +@ + +\defun{concat} +<>= +(defun concat (a b &rest l) + (if (bit-vector-p a) + (if l + (apply #'concatenate 'bit-vector a b l) + (concatenate 'bit-vector a b)) + (if l + (apply #'system:string-concatenate a b l) + (system:string-concatenate a b)))) + +@ + +\defun{functionp} +<>= +(defun |functionp| (fn) + (if (identp fn) + (and (fboundp fn) (not (macro-function fn))) + (functionp fn))) + +@ + +;; --------------------> NEW DEFINITION (override in msgdb.boot.pamphlet) +\defun{brightprint} +<>= +(defun brightprint (x) + (messageprint x)) + +@ + +;; --------------------> NEW DEFINITION (override in msgdb.boot.pamphlet) +\defun{brightprint-0} +<>= +(defun brightprint-0 (x) + (messageprint-1 x)) + +@ + +\defun{member} +<>= +(defun |member| (item sequence) + (cond + ((symbolp item) (member item sequence :test #'eq)) + ((stringp item) (member item sequence :test #'equal)) + ((and (atom item) (not (arrayp item))) (member item sequence)) + (t (member item sequence :test #'equalp)))) + +@ + +\defun{messageprint} +<>= +(defun messageprint (x) + (mapc #'messageprint-1 x)) + +@ + +\defun{messageprint-1} +<>= +(defun messageprint-1 (x) + (cond + ((or (eq x '|%l|) (equal x "%l")) (terpri)) + ((stringp x) (princ x)) + ((identp x) (princ x)) + ((atom x) (princ x)) + ((princ "(") + (messageprint-1 (car x)) + (messageprint-2 (cdr x)) + (princ ")")))) + +@ + +\defun{messageprint-2} +<>= +(defun messageprint-2 (x) + (if (atom x) + (unless x (progn (princ " . ") (messageprint-1 x))) + (progn (princ " ") (messageprint-1 (car x)) (messageprint-2 (cdr x))))) + +@ + +\defun{sayBrightly1} +<>= +(defun sayBrightly1 (x *standard-output*) + (if (atom x) + (progn (brightprint-0 x) (terpri) (force-output)) + (progn (brightprint x) (terpri) (force-output)))) + +@ + +\defdollar{algebraOutputStream} +<>= +(defvar |$algebraOutputStream| *standard-output*) + +@ + +\defun{sayMSG} +<>= +(defun |sayMSG| (x) + (declare (special |$algebraOutputStream|)) + (when x (sayBrightly1 x |$algebraOutputStream|))) + +@ + \chapter{The Interpreter} <>= (in-package "BOOT") <> <> +<> +<> <> <> <> @@ -15712,6 +16079,8 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> +<> +<> <> <> @@ -15739,6 +16108,7 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> <> +<> <> <> <> @@ -15746,6 +16116,9 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> <> +<> +<> +<> <> <> <> @@ -15764,6 +16137,8 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> +<> +<> <> <> @@ -15784,6 +16159,7 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> <> +<> <> <> @@ -15799,6 +16175,7 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> +<> <> <> <> @@ -15840,6 +16217,10 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> <> +<> +<> +<> +<> <> <> @@ -15897,8 +16278,12 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> <> +<> <> +<> <> +<> +<> <> <> <> @@ -15910,8 +16295,11 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> <> +<> +<> <> <> +<> <> <> <> @@ -15974,6 +16362,8 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> +<> + <> <> <> @@ -15995,6 +16385,8 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> +<> + @ \chapter{The Global Variables} \section{Star Global Variables} diff --git a/changelog b/changelog index 5c3e7c9..4f0404f 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,13 @@ +20090319 tpd src/axiom-website/patches.html 20090319.01.tpd.patch +20090319 tpd src/interp/vmlisp.lisp move top level cmd handling +20090319 tpd src/interp/setvars.boot move top level cmd handling +20090319 tpd src/interp/macros.lisp move top level cmd handling +20090319 tpd src/interp/intint.lisp move top level cmd handling +20090319 tpd src/interp/i-syscmd.boot move top level cmd handling +20090319 tpd src/interp/g-cndata.boot move top level cmd handling +20090319 tpd src/interp/bootfuns.lisp move top level cmd handling +20090319 tpd src/input/unittest1.input move top level cmd handling +20090319 tpd books/bookvol5 move top level cmd handling 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 diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 74c25dd..acb665a 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1011,5 +1011,7 @@ bookvol5 add )expose, add )set break resume
sockio.lisp restore sock-send-int
20090317.01.tpd.patch bookvol5 rewrite generated lisp into readable form
+20090319.01.tpd.patch +bookvol5 move top level command handling
diff --git a/src/input/unittest1.input.pamphlet b/src/input/unittest1.input.pamphlet index de5d841..c5d0dfa 100644 --- a/src/input/unittest1.input.pamphlet +++ b/src/input/unittest1.input.pamphlet @@ -17,12 +17,12 @@ Unit test the user level commands )set mes auto off )clear all ---S 1 of 47 +--S 1 of 70 )with API --R )library cannot find the file API. --E 1 ---S 2 of 47 +--S 2 of 70 )apropos matrix --R --ROperations whose names satisfy the above pattern(s): @@ -93,7 +93,7 @@ Unit test the user level commands --R --E 2 ---S 3 of 47 +--S 3 of 70 )what categories set --R --R------------------------------- Categories -------------------------------- @@ -112,7 +112,7 @@ Unit test the user level commands --R TSETCAT TriangularSetCategory --E 3 ---S 4 of 47 +--S 4 of 70 )what commands set --R --R--------------- System Commands for User Level: development --------------- @@ -124,7 +124,7 @@ Unit test the user level commands --R --E 4 ---S 5 of 47 +--S 5 of 70 )what domains set --R --R--------------------------------- Domains --------------------------------- @@ -147,7 +147,7 @@ Unit test the user level commands --R WUTSET WuWenTsunTriangularSet --E 5 ---S 6 of 47 +--S 6 of 70 )what operations set --R --R @@ -251,7 +251,7 @@ Unit test the user level commands --R issue the command )display op ruleset --E 6 ---S 7 of 47 +--S 7 of 70 )what packages set --R --R-------------------------------- Packages --------------------------------- @@ -268,7 +268,7 @@ Unit test the user level commands --R SRDCMPK SquareFreeRegularSetDecompositionPackage --E 7 ---S 8 of 47 +--S 8 of 70 )what synonym set --R --R------------------------- System Command Synonyms ------------------------- @@ -278,7 +278,7 @@ Unit test the user level commands --R --E 8 ---S 9 of 47 +--S 9 of 70 )what things set --R --R @@ -438,7 +438,7 @@ Unit test the user level commands --R --E 9 ---S 10 of 47 +--S 10 of 70 )apropos set --R --R @@ -598,7 +598,7 @@ Unit test the user level commands --R --E 10 ---S 11 of 47 +--S 11 of 70 )prompt --R---------------------------- The prompt Option ---------------------------- --R @@ -616,13 +616,13 @@ Unit test the user level commands --R --E 11 ---S 12 of 47 +--S 12 of 70 )version --R --IValue = "Saturday February 21, 2009 at 17:59:27 " --E 12 ---S 13 of 47 +--S 13 of 70 )zsys )from )c --R --R @@ -633,7 +633,7 @@ Unit test the user level commands --R --E 13 ---S 14 of 47 +--S 14 of 70 )zsys )from )d --R --R @@ -644,7 +644,7 @@ Unit test the user level commands --R --E 14 ---S 15 of 47 +--S 15 of 70 )zsys )from )dt --R --R @@ -655,7 +655,7 @@ Unit test the user level commands --R --E 15 ---S 16 of 47 +--S 16 of 70 )zsys )from )ct --R --R @@ -666,7 +666,7 @@ Unit test the user level commands --R --E 16 ---S 17 of 47 +--S 17 of 70 )zsys )from )ctl --R --R @@ -677,7 +677,7 @@ Unit test the user level commands --R --E 17 ---S 18 of 47 +--S 18 of 70 )zsys )from )ec --R --R @@ -688,7 +688,7 @@ Unit test the user level commands --R --E 18 ---S 19 of 47 +--S 19 of 70 )zsys )from )ect --R --R @@ -699,7 +699,7 @@ Unit test the user level commands --R --E 19 ---S 20 of 47 +--S 20 of 70 )zsys )from )e --R --R @@ -710,12 +710,12 @@ Unit test the user level commands --R --E 20 ---S 21 of 47 +--S 21 of 70 )zsys )from )version --R --E 21 ---S 22 of 47 +--S 22 of 70 )zsys )from )update --R --R @@ -726,7 +726,7 @@ Unit test the user level commands --R --E 22 ---S 23 of 47 +--S 23 of 70 )zsys )from )patch --R --R @@ -737,7 +737,7 @@ Unit test the user level commands --R --E 23 ---S 24 of 47 +--S 24 of 70 )zsys )from )there 1 --R --R @@ -746,24 +746,24 @@ Unit test the user level commands --R --E 24 ---S 25 of 47 +--S 25 of 70 )zsys )from )compare --R --R An argument is required for compare --E 25 ---S 26 of 47 +--S 26 of 70 )zsys )from )record --R --R An argument is required for record --E 26 ---S 27 of 47 +--S 27 of 70 )summary --R --E 27 ---S 28 of 47 +--S 28 of 70 --R)credits --RAn alphabetical listing of contributors to AXIOM: --RCyril Alberga Roy Adler Christian Aistleitner @@ -848,7 +848,7 @@ Unit test the user level commands --RBruno Zuercher Dan Zwillinger --E 28 ---S 29 of 47 +--S 29 of 70 )set expose --R---------------------------- The expose Option ---------------------------- --R @@ -879,7 +879,7 @@ Unit test the user level commands --R for more information. --E 29 ---S 30 of 47 +--S 30 of 70 )set expose add --R----------------------------- The add Option ------------------------------ --R The following groups are explicitly exposed in the current frame @@ -903,7 +903,7 @@ Unit test the user level commands --R for more information. --E 30 ---S 31 of 47 +--S 31 of 70 )set expose drop --R----------------------------- The drop Option ----------------------------- --R The following constructors are explicitly hidden in the current @@ -920,7 +920,7 @@ Unit test the user level commands --R for more information. --E 31 ---S 32 of 47 +--S 32 of 70 )set expose add group --R---------------------------- The group Option ----------------------------- --R The following groups are explicitly exposed in the current frame @@ -941,7 +941,7 @@ Unit test the user level commands --Rdefaults --E 32 ---S 33 of 47 +--S 33 of 70 )set expose add constructor --R------------------------- The constructor Option -------------------------- --R The following constructors are explicitly exposed in the current @@ -949,7 +949,7 @@ Unit test the user level commands --R there are no explicitly exposed constructors --E 33 ---S 34 of 47 +--S 34 of 70 )set expose drop group --R---------------------------- The group Option ----------------------------- --R When followed by one or more exposure group names, this option @@ -964,7 +964,7 @@ Unit test the user level commands --R anna --E 34 ---S 35 of 47 +--S 35 of 70 )set expose drop constructor --R------------------------- The constructor Option -------------------------- --R When followed by one or more constructor names, this option allows @@ -979,7 +979,7 @@ Unit test the user level commands --R there are no explicitly hidden constructors --E 35 ---S 36 of 47 +--S 36 of 70 )show SQMATRIX --R SquareMatrix(ndim: NonNegativeInteger,R: Ring) is a domain constructor --R Abbreviation for SquareMatrix is SQMATRIX @@ -1078,12 +1078,12 @@ Unit test the user level commands --R --E 36 ---S 37 of 47 +--S 37 of 70 )set expose add constructor SQMATRIX --I SquareMatrix is now explicitly exposed in frame frame0 --E 37 ---S 38 of 47 +--S 38 of 70 )show SQMATRIX --R SquareMatrix(ndim: NonNegativeInteger,R: Ring) is a domain constructor --R Abbreviation for SquareMatrix is SQMATRIX @@ -1182,7 +1182,7 @@ Unit test the user level commands --R --E 38 ---S 39 of 47 +--S 39 of 70 )set expose add --R----------------------------- The add Option ------------------------------ --R The following groups are explicitly exposed in the current frame @@ -1206,12 +1206,12 @@ Unit test the user level commands --R for more information. --E 39 ---S 40 of 47 +--S 40 of 70 )set expose drop constructor SQMATRIX --I SquareMatrix is now explicitly hidden in frame frame0 --E 40 ---S 41 of 47 +--S 41 of 70 )show SQMATRIX --R SquareMatrix(ndim: NonNegativeInteger,R: Ring) is a domain constructor --R Abbreviation for SquareMatrix is SQMATRIX @@ -1310,7 +1310,7 @@ Unit test the user level commands --R --E 41 ---S 42 of 47 +--S 42 of 70 )set expose --R---------------------------- The expose Option ---------------------------- --R @@ -1341,12 +1341,12 @@ Unit test the user level commands --R for more information. --E 42 ---S 43 of 47 +--S 43 of 70 )set expose drop group anna --I anna is no longer an exposure group for frame frame0 --E 43 ---S 44 of 47 +--S 44 of 70 )set expose --R---------------------------- The expose Option ---------------------------- --R @@ -1376,7 +1376,7 @@ Unit test the user level commands --R for more information. --E 44 ---S 45 of 47 +--S 45 of 70 )set expose add group --R---------------------------- The group Option ----------------------------- --R The following groups are explicitly exposed in the current frame @@ -1396,12 +1396,12 @@ Unit test the user level commands --Rdefaults --E 45 ---S 46 of 47 +--S 46 of 70 )set expose add group anna --I anna is now an exposure group for frame frame0 --E 46 ---S 47 of 47 +--S 47 of 70 )set expose --R---------------------------- The expose Option ---------------------------- --R @@ -1432,6 +1432,301 @@ Unit test the user level commands --R for more information. --E 47 +--S 48 of 70 +)display + + )display keyword arguments are + abbreviations + all + macros + modes + names + operations + properties + types + values + or abbreviations thereof + +--E 48 + +--S 49 of 70 +)display abb + You have requested that all abbreviations be displayed. As there are + several hundred abbreviations, please confirm your request by + typing y or yes and then pressing Enter : +n + Since you did not respond with y or yes the list of abbreviations + will not be displayed. +--E 49 + +--S 50 of 70 +)display all +Properties of %e : + This is a system-defined macro. + macro %e () == exp(1) +Properties of %i : + This is a system-defined macro. + macro %i () == complex(0,1) +Properties of %infinity : + This is a system-defined macro. + macro %infinity () == infinity() +Properties of %minusInfinity : + This is a system-defined macro. + macro %minusInfinity () == minusInfinity() +Properties of %pi : + This is a system-defined macro. + macro %pi () == pi() +Properties of %plusInfinity : + This is a system-defined macro. + macro %plusInfinity () == plusInfinity() +Properties of SF : + This is a system-defined macro. + macro SF () == DoubleFloat() +--E 50 + +--S 51 of 70 +)display macros + +System-defined macros: + macro %e () == exp(1) + macro %i () == complex(0,1) + macro %infinity () == infinity() + macro %minusInfinity () == minusInfinity() + macro %pi () == pi() + macro %plusInfinity () == plusInfinity() + macro SF () == DoubleFloat() +--E 51 + +--S 52 of 70 +)display modes + Type of value of %e: (none) + Type of value of %i: (none) + Type of value of %infinity: (none) + Type of value of %minusInfinity: (none) + Type of value of %pi: (none) + Type of value of %plusInfinity: (none) + Type of value of SF: (none) +--E 52 + +--S 53 of 70 +)display names + +Names of User-Defined Objects in the Workspace: + + * None * + +Names of System-Defined Objects in the Workspace: + +%e %i %infinity %minusInfinity +%pi %plusInfinity SF +--E 53 + +--S 54 of 70 +)display operations + You have requested that all information about all AXIOM operations + (functions) be displayed. As there are several hundred + operations, please confirm your request by typing y or yes and + then pressing Enter : +n + Since you did not respond with y or yes the list of operations will + not be displayed. +--E 54 + +--S 55 of 70 +)display properties +Properties of %e : + This is a system-defined macro. + macro %e () == exp(1) +Properties of %i : + This is a system-defined macro. + macro %i () == complex(0,1) +Properties of %infinity : + This is a system-defined macro. + macro %infinity () == infinity() +Properties of %minusInfinity : + This is a system-defined macro. + macro %minusInfinity () == minusInfinity() +Properties of %pi : + This is a system-defined macro. + macro %pi () == pi() +Properties of %plusInfinity : + This is a system-defined macro. + macro %plusInfinity () == plusInfinity() +Properties of SF : + This is a system-defined macro. + macro SF () == DoubleFloat() +--E 55 + +--S 56 of 70 +)display types + Type of value of %e: (none) + Type of value of %i: (none) + Type of value of %infinity: (none) + Type of value of %minusInfinity: (none) + Type of value of %pi: (none) + Type of value of %plusInfinity: (none) + Type of value of SF: (none) +--E 56 + +--S 57 of 70 +)display values + Value of %e: (none) + Value of %i: (none) + Value of %infinity: (none) + Value of %minusInfinity: (none) + Value of %pi: (none) + Value of %plusInfinity: (none) + Value of SF: (none) +--E 57 + +--S 58 of 70 +)display abb DHMATRIX + DHMATRIX abbreviates domain DenavitHartenbergMatrix +--E 58 + +--S 59 of 70 +)display abb DenavitHartenbergMatrix + DHMATRIX abbreviates domain DenavitHartenbergMatrix +--E 59 + +--S 60 of 70 +)display operations rotatex + +There is one exposed function called rotatex : + [1] D1 -> DenavitHartenbergMatrix D1 from DenavitHartenbergMatrix D1 + if D1 has Join(Field,TranscendentalFunctionCategory) + +Examples of rotatex from DenavitHartenbergMatrix + +--E 60 + +--S 61 of 70 +)set fortran calling + Current Values of calling Variables + +Variable Description Current Value +----------------------------------------------------------------------------- +tempfile set location of temporary data files /tmp/ +directory set location of generated FORTRAN files ./ +linker linker arguments (e.g. libraries to search) -lxlf + +--E 61 + +--S 62 of 70 +)set fortran calling tempfile +--------------------------- The tempfile Option --------------------------- + + Description: set location of temporary data files + + )set fortran calling tempfile is used to tell AXIOM where + to place intermediate FORTRAN data files . This must be the + name of a valid existing directory to which you have permission + to write (including the final slash). + + Syntax: + )set fortran calling tempfile DIRECTORYNAME + + The current setting is /tmp/ +--E 62 + +--S 63 of 70 +)set fortran calling tempfile /home/daly +--E 63 + +--S 64 of 70 +)set fortran calling tempfile +--------------------------- The tempfile Option --------------------------- + + Description: set location of temporary data files + + )set fortran calling tempfile is used to tell AXIOM where + to place intermediate FORTRAN data files . This must be the + name of a valid existing directory to which you have permission + to write (including the final slash). + + Syntax: + )set fortran calling tempfile DIRECTORYNAME + + The current setting is /home/daly/ +--E 64 + +--S 65 of 70 +)set fortran calling directory +-------------------------- The directory Option --------------------------- + + Description: set location of generated FORTRAN files + + )set fortran calling directory is used to tell AXIOM where + to place generated FORTRAN files. This must be the name + of a valid existing directory to which you have permission + to write (including the final slash). + + Syntax: + )set fortran calling directory DIRECTORYNAME + + The current setting is ./ +--E 65 + +--S 66 of 70 +)set fortran calling directory /home/daly/ +--E 66 + +--S 67 of 70 +)set fortran calling directory +-------------------------- The directory Option --------------------------- + + Description: set location of generated FORTRAN files + + )set fortran calling directory is used to tell AXIOM where + to place generated FORTRAN files. This must be the name + of a valid existing directory to which you have permission + to write (including the final slash). + + Syntax: + )set fortran calling directory DIRECTORYNAME + + The current setting is /home/daly/ +--E 67 + +--S 68 of 70 +)set fortran calling linker +---------------------------- The linker Option ---------------------------- + + Description: linker arguments (e.g. libraries to search) + + )set fortran calling linkerargs is used to pass arguments to the linker + when using mkFort to create functions which call Fortran code. + For example, it might give a list of libraries to be searched, + and their locations. + The string is passed verbatim, so must be the correct syntax for + the particular linker being used. + + Example: )set fortran calling linker "-lxlf" + + The current setting is -lxlf +--E 68 + +--S 69 of 70 +)set fortran calling linker "-TPD" +--E 69 + +--S 70 of 70 +)set fortran calling linker +---------------------------- The linker Option ---------------------------- + + Description: linker arguments (e.g. libraries to search) + + )set fortran calling linkerargs is used to pass arguments to the linker + when using mkFort to create functions which call Fortran code. + For example, it might give a list of libraries to be searched, + and their locations. + The string is passed verbatim, so must be the correct syntax for + the particular linker being used. + + Example: )set fortran calling linker "-lxlf" + + The current setting is -TPD +--E 70 )spool )lisp (bye) diff --git a/src/interp/bootfuns.lisp.pamphlet b/src/interp/bootfuns.lisp.pamphlet index e94b453..654856c 100644 --- a/src/interp/bootfuns.lisp.pamphlet +++ b/src/interp/bootfuns.lisp.pamphlet @@ -85,9 +85,6 @@ which will walk the structure $Y$ looking for this constant. #-:CCL (def-boot-val |$timerTicksPerSecond| INTERNAL-TIME-UNITS-PER-SECOND "for TEMPUS-FUGIT and $TOTAL-ELAPSED-TIME") -#+:CCL -(def-boot-val |$timerTicksPerSecond| 1000 - "for TEMPUS-FUGIT and $TOTAL-ELAPSED-TIME") (def-boot-val $boxString (concatenate 'string (list (code-char #x1d) (code-char #xe2))) "this string of 2 chars displays as a box") @@ -391,7 +388,6 @@ for primitive domains. Also used by putInLocalDomainReferences and optCal.") (def-boot-var |$suffix| "???") (def-boot-val |$Symbol| '(|Symbol|) "???") (def-boot-val |$SymbolOpt| '(|Symbol| . OPT) "???") -;(def-boot-var |$systemCommands| "Interpreter>System.boot") (def-boot-val |$systemCreation| (currenttime) "???") (def-boot-val |$systemLastChanged| |$systemCreation| "???") @@ -459,9 +455,7 @@ for primitive domains. Also used by putInLocalDomainReferences and optCal.") (if (memq u '(|%display%| |%describe%|)) (if |$printLoadMsgs| "on" "off") (seq - (setq |$printLoadMsgs| (and (listp u) (equal (car u) '|on|))) -#+:CCL (verbos (if |$printLoadMsgs| 2 0)) -))) + (setq |$printLoadMsgs| (and (listp u) (equal (car u) '|on|)))))) @ \eject diff --git a/src/interp/g-cndata.boot.pamphlet b/src/interp/g-cndata.boot.pamphlet index 7e09df9..4469086 100644 --- a/src/interp/g-cndata.boot.pamphlet +++ b/src/interp/g-cndata.boot.pamphlet @@ -126,11 +126,6 @@ mkUserConstructorAbbreviation(c,a,type) == installConstructor(c,type) setAutoLoadProperty(c) -abbQuery(x) == - abb := GETDATABASE(x,'ABBREVIATION) => - sayKeyedMsg("S2IZ0001",[abb,GETDATABASE(x,'CONSTRUCTORKIND),x]) - sayKeyedMsg("S2IZ0003",[x]) - installConstructor(cname,type) == (entry := getCDTEntry(cname,true)) => entry item := [cname,GETDATABASE(cname,'ABBREVIATION),nil] diff --git a/src/interp/i-syscmd.boot.pamphlet b/src/interp/i-syscmd.boot.pamphlet index 19de874..a73b79d 100644 --- a/src/interp/i-syscmd.boot.pamphlet +++ b/src/interp/i-syscmd.boot.pamphlet @@ -9,82 +9,6 @@ \eject \tableofcontents \eject -\begin{verbatim} -This file contains the BOOT code for the Axiom system command -and synonym processing facility. The code for )trace is in the file -TRACE BOOT. The list of system commands is $SYSCOMMANDS which is -initialized in SETQ LISP. - -\end{verbatim} -\section{Filenames change} -It appears that probe-file is now case-sensitive. In order to get around -this we include the file extensions in both upper and lower case in the -search lists. Lower case names are preferred. - -\section{handleNoParseCommands} -The system commands given by the global variable -[[|$noParseCommands|]]\cite{1} require essentially no -preprocessing/parsing of their arguments. Here we dispatch the -functions which implement these commands. - -There are four standard commands which receive arguments -- [[lisp]], -[[synonym]], [[system]] and [[boot]]. There are five standard commands -which do not receive arguments -- [[quit]], [[fin]], [[pquit]], -[[credits]] and [[copyright]]. As these commands do not necessarily -exhaust those mentioned in [[|$noParseCommands|]], we provide a -generic dispatch based on two conventions: commands which do not -require an argument name themselves, those which do have their names -prefixed by [[np]]. - -<>= -handleNoParseCommands(unab, string) == - string := stripSpaces string - spaceIndex := SEARCH('" ", string) - unab = "lisp" => - if (null spaceIndex) then - sayKeyedMsg("S2IV0005", NIL) - nil - else nplisp(stripLisp string) - unab = "boot" => - if (null spaceIndex) then - sayKeyedMsg("S2IV0005", NIL) - nil - else npboot(SUBSEQ(string, spaceIndex+1)) - unab = "system" => - if (null spaceIndex) then - sayKeyedMsg("S2IV0005", NIL) - nil - else npsystem(unab, string) - unab = "synonym" => - npsynonym(unab, (null spaceIndex => '""; SUBSEQ(string, spaceIndex+1))) - null spaceIndex => - FUNCALL unab - MEMBER(unab, '( quit _ - fin _ - pquit _ - credits _ - copyright )) => - sayKeyedMsg("S2IV0005", NIL) - nil - funName := INTERN CONCAT('"np",STRING unab) - FUNCALL(funName, SUBSEQ(string, spaceIndex+1)) - -@ -\section{TRUENAME change} -This change was made to make the open source Axiom work with the -new aldor compiler.z -This used to read: -\begin{verbatim} - STRCONC(TRUENAME(STRCONC(GETENV('"AXIOM"),'"/compiler/bin/")),"axiomxl ", asharpArgs, '" ", namestring args) -\end{verbatim} -but now reads: -<>= - STRCONC(STRCONC(GETENV('"ALDORROOT"),'"/bin/"),_ - "aldor ", asharpArgs, '" ", namestring args) -@ -Notice that we've introduced the [[ALDORROOT]] shell variable. -This will have to be pushed down from the top level Makefile. - \section{License} <>= -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. @@ -130,24 +54,6 @@ SETANDFILEQ($compileRecurrence,true) SETANDFILEQ($errorReportLevel,'warning) SETANDFILEQ($sourceFileTypes,'(INPUT SPAD BOOT LISP LISP370 META)) -SETANDFILEQ($whatOptions, '( _ - operations _ - categories _ - domains _ - packages _ - commands _ - synonyms _ - things _ - )) - -SETANDFILEQ($clearOptions, '( _ - modes _ - operations _ - properties _ - types _ - values _ - )) - SETANDFILEQ($countAssoc,'( (cache countCache) )) --% Top level system command @@ -211,19 +117,6 @@ hasOption(al,opt) == stringPrefix?(PNAME CAR pair,optPname) => found := pair found -selectOptionLC(x,l,errorFunction) == - selectOption(DOWNCASE object2Identifier x,l,errorFunction) - -selectOption(x,l,errorFunction) == - MEMBER(x,l) => x --exact spellings are always OK - null IDENTP x => - errorFunction => FUNCALL(errorFunction,x,u) - nil - u := [y for y in l | stringPrefix?(PNAME x,PNAME y)] - u is [y] => y - errorFunction => FUNCALL(errorFunction,x,u) - nil - terminateSystemCommand() == TERSYSCOMMAND() commandUserLevelError(x,u) == userLevelErrorMessage("command",x,u) @@ -460,30 +353,6 @@ displayValue($op,u,omitVariableNameIfTrue) == outputFormat(expr,objMode(u))] NIL ---% )edit - -edit l == editSpad2Cmd l - -editSpad2Cmd l == - l:= - null l => _/EDITFILE - CAR l - l := pathname l - oldDir := pathnameDirectory l - fileTypes := - pathnameType l => [pathnameType l] - $UserLevel = 'interpreter => '("input" "INPUT" "spad" "SPAD") - $UserLevel = 'compiler => '("input" "INPUT" "spad" "SPAD") - '("input" "INPUT" "spad" "SPAD" "boot" "BOOT" "lisp" "LISP" "meta" "META") - ll := - oldDir = '"" => pathname $FINDFILE (pathnameName l, fileTypes) - l - l := pathname ll - SETQ(_/EDITFILE,l) - rc := editFile l - updateSourceFiles l - rc - --% )load load args == loadSpad2Cmd args @@ -960,8 +829,6 @@ doSystemCommand string == nil nil -<> - npboot str == sex := string2BootTree str FORMAT(true, '"~&~S~%", sex) diff --git a/src/interp/intint.lisp.pamphlet b/src/interp/intint.lisp.pamphlet index a4e29f5..c3973f8 100644 --- a/src/interp/intint.lisp.pamphlet +++ b/src/interp/intint.lisp.pamphlet @@ -48,104 +48,68 @@ (in-package "BOOT") +(eval-when (eval load) + (setq |$useNewParser| T)) + +(defun |rePackageTran| (sex package) + (let (*package*) + (declare (special *package*)) + (setq *package* (find-package (string package))) + (|packageTran| sex))) + +(defun |packageTran| (sex) + (prog () + (return + (cond + ((symbolp sex) + (cond + ((eq *package* (symbol-package sex)) sex) + (t (intern (string sex))))) + ((consp sex) + (rplaca sex (|packageTran| (car sex))) + (rplacd sex (|packageTran| (cdr sex))) + sex) + (t sex))))) + +(defun |zeroOneTran| (sex) + (nsubst '|$EmptyMode| '? sex)) + (defun |intSayKeyedMsg| (key args) (|sayKeyedMsg| (|packageTran| key) (|packageTran| args))) -;;(defun |intMakeFloat| (int frac len exp) -;; (MAKE-FLOAT int frac len exp)) - -;;(defun |intSystemCommand| (command) -;; (catch 'SPAD_READER -;; (|systemCommand| (|packageTran| command)))) - -;;(defun |intUnAbbreviateKeyword| (keyword) -;; (|unAbbreviateKeyword| (|packageTran| keyword))) - (defun |intProcessSynonyms| (str) (let ((LINE str)) (declare (special LINE)) (|processSynonyms|) LINE)) -;; (defun |intNoParseCommands| () -;; |$noParseCommands|) - -;;(defun |intTokenCommands| () -;; |$tokenCommands|) - (defun |intInterpretPform| (pf) (|processInteractive| (|zeroOneTran| (|packageTran| (|pf2Sex| pf))) pf)) -;;(defun |intSpadThrow| () -;; (|spadThrow|)) - -;;(defun |intMKPROMPT| (should? step) -;; (if should? (PRINC (MKPROMPT)))) - (defvar |$intCoerceFailure| '|coerceFailure|) (defvar |$intTopLevel| '|top_level|) (defvar |$intSpadReader| 'SPAD_READER) (defvar |$intRestart| '|restart|) -;;(defun |intString2BootTree| (str) -;; (|string2BootTree| str)) - -;;(defun |intPackageTran| (sex) -;; (|packageTran| sex)) - -;;(defvar |$SessionManager| |$SessionManager|) -;;(defvar |$EndOfOutput| |$EndOfOutput|) - -;;(defun |intServerReadLine| (foo) -;; (|serverReadLine| foo)) - -;; (defun |intProcessSynonym| (str) -;; (|npProcessSynonym| str)) - (defun |SpadInterpretFile| (fn) (|SpadInterpretStream| 1 fn nil) ) (defun |intNewFloat| () (list '|Float|)) -;; (defun |intDoSystemCommand| (string) -;; (|doSystemCommand| string)) - (defun |intSetNeedToSignalSessionManager| () (setq |$NeedToSignalSessionManager| T)) -;; (defun |intKeyedSystemError| (msg args) -;; (|keyedSystemError| msg args)) - -;;#-:CCL -;;(defun |stashInputLines| (l) -;; (|stashInputLines| l)) - -;;(defun |setCurrentLine| (s) -;; (setq |$currentLine| s)) - (defun |intnplisp| (s) (setq |$currentLine| s) (|nplisp| |$currentLine|)) -;; (defun |intResetStackLimits| () (|resetStackLimits|)) - (defun |intSetQuiet| () (setq |$QuietCommand| T)) (defun |intUnsetQuiet| () (setq |$QuietCommand| NIL)) -;; (defun |expandTabs| (s) -;; (expand-tabs s)) - -;; #-:CCL -;; (defun |leaveScratchpad| () -;; (|leaveScratchpad|)) - -;;(defun |readingFile?| () -;; |$ReadingFile|) - @ \eject \begin{thebibliography}{99} diff --git a/src/interp/macros.lisp.pamphlet b/src/interp/macros.lisp.pamphlet index 117408c..3b06048 100644 --- a/src/interp/macros.lisp.pamphlet +++ b/src/interp/macros.lisp.pamphlet @@ -149,8 +149,6 @@ ends up being [[CONTAINED |$EmptyMode| Y]]. (defmacro |function| (name) `(FUNCTION ,name)) (defmacro |dispatchFunction| (name) `(FUNCTION ,name)) -(defun |functionp| (fn) - (if (identp fn) (and (fboundp fn) (not (macro-function fn))) (functionp fn))) (defun |macrop| (fn) (and (identp fn) (macro-function fn))) ; 6 PREDICATES @@ -1261,22 +1259,12 @@ LP (COND ((NULL X) (defun sayBrightlyNT1 (X *standard-output*) (if (ATOM X) (BRIGHTPRINT-0 X) (BRIGHTPRINT X))) -(defun sayBrightly1 (X *standard-output*) - (if (ATOM X) - (progn (BRIGHTPRINT-0 X) (TERPRI) (force-output)) - (progn (BRIGHTPRINT X) (TERPRI) (force-output)))) - -(defvar |$algebraOutputStream| *standard-output*) - (defun |saySpadMsg| (X) (if (NULL X) NIL (sayBrightly1 X |$algebraOutputStream|))) (defun |sayALGEBRA| (X) "Prints on Algebra output stream." (if (NULL X) NIL (sayBrightly1 X |$algebraOutputStream|))) -(defun |sayMSG| (X) - (if (NULL X) NIL (sayBrightly1 X |$algebraOutputStream|))) - (defun |sayMSGNT| (X) (if (NULL X) NIL (sayBrightlyNT1 X |$algebraOutputStream|))) @@ -1307,29 +1295,8 @@ LP (COND ((NULL X) ;; the following are redefined in MSGDB BOOT -;; --------------------> NEW DEFINITION (override in msgdb.boot.pamphlet) -(DEFUN BRIGHTPRINT (X) (MESSAGEPRINT X)) - -;; --------------------> NEW DEFINITION (override in msgdb.boot.pamphlet) -(DEFUN BRIGHTPRINT-0 (x) (MESSAGEPRINT-1 X)) - (defun SAY (&rest x) (progn (MESSAGEPRINT X) (TERPRI))) -(DEFUN MESSAGEPRINT (X) (mapc #'messageprint-1 X)) - -(DEFUN MESSAGEPRINT-1 (X) - (COND ((OR (EQ X '|%l|) (EQUAL X "%l")) (TERPRI)) - ((STRINGP X) (PRINC X)) - ((IDENTP X) (PRINC X)) - ((ATOM X) (PRINC X)) - ((PRINC "(") (MESSAGEPRINT-1 (CAR X)) - (MESSAGEPRINT-2 (CDR X)) (PRINC ")")))) - -(DEFUN MESSAGEPRINT-2 (X) - (if (ATOM X) - (if (NULL X) NIL (progn (PRINC " . ") (MESSAGEPRINT-1 X))) - (progn (PRINC " ") (MESSAGEPRINT-1 (CAR X)) (MESSAGEPRINT-2 (CDR X))))) - (DEFUN BLANKS (N &optional (stream *standard-output*)) "Print N blanks." (do ((i 1 (the fixnum(1+ i)))) ((> i N))(declare (fixnum i n)) (princ " " stream))) diff --git a/src/interp/setvars.boot.pamphlet b/src/interp/setvars.boot.pamphlet index f5e8b35..6d2e935 100644 --- a/src/interp/setvars.boot.pamphlet +++ b/src/interp/setvars.boot.pamphlet @@ -74,140 +74,6 @@ See the section expose in setvart.boot.pamphlet\cite{1} for more information. \end{verbatim} -\section{fortran calling} -See the section calling in servart.boot.pamphlet. -\begin{verbatim} - Current Values of calling Variables - -Variable Description Current Value ------------------------------------------------------------------ -tempfile set location of temporary data files /tmp/ -directory set location of generated FORTRAN files ./ -linker linker arguments (e.g. libraries to search) -lxlf - -\end{verbatim} -<>= -<> -<> -<> -<> -<> -<> -<> -@ -\subsection{setFortTmpDir} -<>= -setFortTmpDir arg == - - arg = "%initialize%" => - $fortranTmpDir := '"/tmp/" - - arg = "%display%" => - STRINGP $fortranTmpDir => $fortranTmpDir - PNAME $fortranTmpDir - - (null arg) or (arg = "%describe%") or (first arg = '_?) => - describeSetFortTmpDir() - - -- try to figure out what the argument is - - -- VM code - must be an accessed disk mode [mode] - not (mode := validateOutputDirectory arg) => - sayBrightly ['" Sorry, but your argument(s)",:bright arg, - '"is(are) not valid.",'%l] - describeSetFortTmpDir() - $fortranTmpDir := mode - -@ -\subsection{validateOutputDirectory} -<>= -validateOutputDirectory x == - AND(PATHNAME_-DIRECTORY(PROBE_-FILE(CAR(x))), NOT PATHNAME_-NAME (PROBE_-FILE(CAR(x)))) => - CAR(x) - NIL - -@ -\subsection{describeSetFortTmpDir} -<>= -describeSetFortTmpDir() == - sayBrightly LIST ( - '%b,'")set fortran calling tempfile",'%d,_ - '" is used to tell AXIOM where",'%l,_ - '" to place intermediate FORTRAN data files . This must be the ",'%l,_ - '" name of a valid existing directory to which you have permission ",'%l,_ - '" to write (including the final slash).",'%l,'%l,_ - '" Syntax:",'%l,_ - '" )set fortran calling tempfile DIRECTORYNAME",'%l,'%l,_ - '" The current setting is",'%b,$fortranTmpDir,'%d) - -@ -\subsection{setFortDir} -<>= -setFortDir arg == - arg = "%initialize%" => - $fortranDirectory := '"./" - - arg = "%display%" => - STRINGP $fortranDirectory => $fortranDirectory - PNAME $fortranDirectory - - (null arg) or (arg = "%describe%") or (first arg = '_?) => - describeSetFortDir() - - -- try to figure out what the argument is - - -- VM code - must be an accessed disk mode [mode] - not (mode := validateOutputDirectory arg) => - sayBrightly ['" Sorry, but your argument(s)",:bright arg, - '"is(are) not valid.",'%l] - describeSetFortDir() - $fortranDirectory := mode - -@ -\subsection{describeSetFortDir} -<>= -describeSetFortDir() == - sayBrightly LIST ( - '%b,'")set fortran calling directory",'%d,_ - '" is used to tell AXIOM where",'%l,_ - '" to place generated FORTRAN files. This must be the name ",'%l,_ - '" of a valid existing directory to which you have permission ",'%l,_ - '" to write (including the final slash).",'%l,'%l,_ - '" Syntax:",'%l,_ - '" )set fortran calling directory DIRECTORYNAME",'%l,'%l,_ - '" The current setting is",'%b,$fortranDirectory,'%d) - -@ -\subsection{setLinkerArgs} -<>= -setLinkerArgs arg == - - arg = "%initialize%" => - $fortranLibraries := '"-lxlf" - arg = "%display%" => object2String $fortranLibraries - (null arg) or (arg = "%describe%") or (first arg = '_?) => - describeSetLinkerArgs() - LISTP(arg) and STRINGP(first arg) => - $fortranLibraries := first(arg) - describeSetLinkerArgs() - -@ -\subsection{describeSetLinkerArgs} -<>= -describeSetLinkerArgs() == - sayBrightly LIST ( - '%b,'")set fortran calling linkerargs",'%d,_ - '" is used to pass arguments to the linker",'%l,_ - '" when using ",'%b,'"mkFort",'%d,_ - '" to create functions which call Fortran code.",'%l,_ - '" For example, it might give a list of libraries to be searched,",'%l,_ - '" and their locations.",'%l,_ - '" The string is passed verbatim, so must be the correct syntax for",'%l,_ - '" the particular linker being used.",'%l,'%l,_ - '" Example: )set fortran calling linker _"-lxlf_"",'%l,'%l,_ - '" The current setting is",'%b,$fortranLibraries,'%d) - -@ \section{functions} See the section functions in setvart.boot.pamphlet\cite{1} \begin{verbatim} @@ -1377,7 +1243,6 @@ describeSetStreamsCalculate() == sayKeyedMsg("S2IV0001",[$streamCount]) @ <<*>>= <> -<> <> <> <> @@ -1396,95 +1261,6 @@ describeSetStreamsCalculate() == sayKeyedMsg("S2IV0001",[$streamCount]) (IN-PACKAGE "BOOT" ) -;setFortTmpDir arg == -; arg = "%initialize%" => -; $fortranTmpDir := '"/tmp/" -; arg = "%display%" => -; STRINGP $fortranTmpDir => $fortranTmpDir -; PNAME $fortranTmpDir -; (null arg) or (arg = "%describe%") or (first arg = '_?) => -; describeSetFortTmpDir() -; -- try to figure out what the argument is -; -- VM code - must be an accessed disk mode [mode] -; not (mode := validateOutputDirectory arg) => -; sayBrightly ['" Sorry, but your argument(s)",:bright arg, -; '"is(are) not valid.",'%l] -; describeSetFortTmpDir() -; $fortranTmpDir := mode - -(DEFUN |setFortTmpDir| (|arg|) (PROG (|mode|) (RETURN (COND ((BOOT-EQUAL |arg| (QUOTE |%initialize%|)) (SPADLET |$fortranTmpDir| (MAKESTRING "/tmp/"))) ((BOOT-EQUAL |arg| (QUOTE |%display%|)) (COND ((STRINGP |$fortranTmpDir|) |$fortranTmpDir|) ((QUOTE T) (PNAME |$fortranTmpDir|)))) ((OR (NULL |arg|) (BOOT-EQUAL |arg| (QUOTE |%describe%|)) (BOOT-EQUAL (CAR |arg|) (QUOTE ?))) (|describeSetFortTmpDir|)) ((NULL (SPADLET |mode| (|validateOutputDirectory| |arg|))) (|sayBrightly| (CONS (MAKESTRING " Sorry, but your argument(s)") (APPEND (|bright| |arg|) (CONS (MAKESTRING "is(are) not valid.") (CONS (QUOTE |%l|) NIL))))) (|describeSetFortTmpDir|)) ((QUOTE T) (SPADLET |$fortranTmpDir| |mode|)))))) -;validateOutputDirectory x == -; AND(PATHNAME_-DIRECTORY(PROBE_-FILE(CAR(x))), NOT PATHNAME_-NAME (PROBE_-FILE(CAR(x)))) => -; CAR(x) -; NIL - -(DEFUN |validateOutputDirectory| (|x|) (COND ((AND (PATHNAME-DIRECTORY (PROBE-FILE (CAR |x|))) (NULL (PATHNAME-NAME (PROBE-FILE (CAR |x|))))) (CAR |x|)) ((QUOTE T) NIL))) -;describeSetFortTmpDir() == -; sayBrightly LIST ( -; '%b,'")set fortran calling tempfile",'%d,_ -; '" is used to tell AXIOM where",'%l,_ -; '" to place intermediate FORTRAN data files . This must be the ",'%l,_ -; '" name of a valid existing directory to which you have permission ",'%l,_ -; '" to write (including the final slash).",'%l,'%l,_ -; '" Syntax:",'%l,_ -; '" )set fortran calling tempfile DIRECTORYNAME",'%l,'%l,_ -; '" The current setting is",'%b,$fortranTmpDir,'%d) - -(DEFUN |describeSetFortTmpDir| NIL (|sayBrightly| (LIST (QUOTE |%b|) (MAKESTRING ")set fortran calling tempfile") (QUOTE |%d|) (MAKESTRING " is used to tell AXIOM where") (QUOTE |%l|) (MAKESTRING " to place intermediate FORTRAN data files . This must be the ") (QUOTE |%l|) (MAKESTRING " name of a valid existing directory to which you have permission ") (QUOTE |%l|) (MAKESTRING " to write (including the final slash).") (QUOTE |%l|) (QUOTE |%l|) (MAKESTRING " Syntax:") (QUOTE |%l|) (MAKESTRING " )set fortran calling tempfile DIRECTORYNAME") (QUOTE |%l|) (QUOTE |%l|) (MAKESTRING " The current setting is") (QUOTE |%b|) |$fortranTmpDir| (QUOTE |%d|)))) -;setFortDir arg == -; arg = "%initialize%" => -; $fortranDirectory := '"./" -; arg = "%display%" => -; STRINGP $fortranDirectory => $fortranDirectory -; PNAME $fortranDirectory -; (null arg) or (arg = "%describe%") or (first arg = '_?) => -; describeSetFortDir() -; -- try to figure out what the argument is -; -- VM code - must be an accessed disk mode [mode] -; not (mode := validateOutputDirectory arg) => -; sayBrightly ['" Sorry, but your argument(s)",:bright arg, -; '"is(are) not valid.",'%l] -; describeSetFortDir() -; $fortranDirectory := mode - -(DEFUN |setFortDir| (|arg|) (PROG (|mode|) (RETURN (COND ((BOOT-EQUAL |arg| (QUOTE |%initialize%|)) (SPADLET |$fortranDirectory| (MAKESTRING "./"))) ((BOOT-EQUAL |arg| (QUOTE |%display%|)) (COND ((STRINGP |$fortranDirectory|) |$fortranDirectory|) ((QUOTE T) (PNAME |$fortranDirectory|)))) ((OR (NULL |arg|) (BOOT-EQUAL |arg| (QUOTE |%describe%|)) (BOOT-EQUAL (CAR |arg|) (QUOTE ?))) (|describeSetFortDir|)) ((NULL (SPADLET |mode| (|validateOutputDirectory| |arg|))) (|sayBrightly| (CONS (MAKESTRING " Sorry, but your argument(s)") (APPEND (|bright| |arg|) (CONS (MAKESTRING "is(are) not valid.") (CONS (QUOTE |%l|) NIL))))) (|describeSetFortDir|)) ((QUOTE T) (SPADLET |$fortranDirectory| |mode|)))))) -;describeSetFortDir() == -; sayBrightly LIST ( -; '%b,'")set fortran calling directory",'%d,_ -; '" is used to tell AXIOM where",'%l,_ -; '" to place generated FORTRAN files. This must be the name ",'%l,_ -; '" of a valid existing directory to which you have permission ",'%l,_ -; '" to write (including the final slash).",'%l,'%l,_ -; '" Syntax:",'%l,_ -; '" )set fortran calling directory DIRECTORYNAME",'%l,'%l,_ -; '" The current setting is",'%b,$fortranDirectory,'%d) - -(DEFUN |describeSetFortDir| NIL (|sayBrightly| (LIST (QUOTE |%b|) (MAKESTRING ")set fortran calling directory") (QUOTE |%d|) (MAKESTRING " is used to tell AXIOM where") (QUOTE |%l|) (MAKESTRING " to place generated FORTRAN files. This must be the name ") (QUOTE |%l|) (MAKESTRING " of a valid existing directory to which you have permission ") (QUOTE |%l|) (MAKESTRING " to write (including the final slash).") (QUOTE |%l|) (QUOTE |%l|) (MAKESTRING " Syntax:") (QUOTE |%l|) (MAKESTRING " )set fortran calling directory DIRECTORYNAME") (QUOTE |%l|) (QUOTE |%l|) (MAKESTRING " The current setting is") (QUOTE |%b|) |$fortranDirectory| (QUOTE |%d|)))) -;setLinkerArgs arg == -; arg = "%initialize%" => -; $fortranLibraries := '"-lxlf" -; arg = "%display%" => object2String $fortranLibraries -; (null arg) or (arg = "%describe%") or (first arg = '_?) => -; describeSetLinkerArgs() -; LISTP(arg) and STRINGP(first arg) => -; $fortranLibraries := first(arg) -; describeSetLinkerArgs() - -(DEFUN |setLinkerArgs| (|arg|) (COND ((BOOT-EQUAL |arg| (QUOTE |%initialize%|)) (SPADLET |$fortranLibraries| (MAKESTRING "-lxlf"))) ((BOOT-EQUAL |arg| (QUOTE |%display%|)) (|object2String| |$fortranLibraries|)) ((OR (NULL |arg|) (BOOT-EQUAL |arg| (QUOTE |%describe%|)) (BOOT-EQUAL (CAR |arg|) (QUOTE ?))) (|describeSetLinkerArgs|)) ((AND (LISTP |arg|) (STRINGP (CAR |arg|))) (SPADLET |$fortranLibraries| (CAR |arg|))) ((QUOTE T) (|describeSetLinkerArgs|)))) -;describeSetLinkerArgs() == -; sayBrightly LIST ( -; '%b,'")set fortran calling linkerargs",'%d,_ -; '" is used to pass arguments to the linker",'%l,_ -; '" when using ",'%b,'"mkFort",'%d,_ -; '" to create functions which call Fortran code.",'%l,_ -; '" For example, it might give a list of libraries to be searched,",'%l,_ -; '" and their locations.",'%l,_ -; '" The string is passed verbatim, so must be the correct syntax for",'%l,_ -; '" the particular linker being used.",'%l,'%l,_ -; '" Example: )set fortran calling linker _"-lxlf_"",'%l,'%l,_ -; '" The current setting is",'%b,$fortranLibraries,'%d) - -(DEFUN |describeSetLinkerArgs| NIL (|sayBrightly| (LIST (QUOTE |%b|) (MAKESTRING ")set fortran calling linkerargs") (QUOTE |%d|) (MAKESTRING " is used to pass arguments to the linker") (QUOTE |%l|) (MAKESTRING " when using ") (QUOTE |%b|) (MAKESTRING "mkFort") (QUOTE |%d|) (MAKESTRING " to create functions which call Fortran code.") (QUOTE |%l|) (MAKESTRING " For example, it might give a list of libraries to be searched,") (QUOTE |%l|) (MAKESTRING " and their locations.") (QUOTE |%l|) (MAKESTRING " The string is passed verbatim, so must be the correct syntax for") (QUOTE |%l|) (MAKESTRING " the particular linker being used.") (QUOTE |%l|) (QUOTE |%l|) (MAKESTRING " Example: )set fortran calling linker \"-lxlf\"") (QUOTE |%l|) (QUOTE |%l|) (MAKESTRING " The current setting is") (QUOTE |%b|) |$fortranLibraries| (QUOTE |%d|)))) ;setFunctionsCache arg == ; $options : local := NIL ; arg = "%initialize%" => diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index 2478e04..9ee26d5 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -343,13 +343,6 @@ the calculation by repeated divisions using the radix itself. (defmacro |idChar?| (x) `(or (alphanumericp ,x) (member ,x '(#\? #\% #\' #\!) :test #'char=))) -(defmacro identp (x) - (if (atom x) - `(and ,x (symbolp ,x)) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (and ,xx (symbolp ,xx)))))) - (defmacro ifcar (x) (if (atom x) `(and (consp ,x) (qcar ,x)) @@ -1055,11 +1048,6 @@ the calculation by repeated divisions using the radix itself. (defun QSREMAINDER (a b) (the fixnum (rem (the fixnum a) (the fixnum b)))) - -;(defun IFCAR (x) (if (consp x) (car (the cons x)))) - -;(defun IFCDR (x) (if (consp x) (cdr (the cons x)))) - ; 13.3 Updating @@ -1077,20 +1065,6 @@ the calculation by repeated divisions using the radix itself. (defun VEC2LIST (vec) (coerce vec 'list)) -; note default test for union, intersection and set-difference is eql -;; following are defined so as to preserve ordering in union.lisp -;;(defun SETDIFFERENCE (l1 l2) (set-difference l1 l2 :test #'equalp)) -;;(defun SETDIFFERENCEQ (l1 l2) (set-difference l1 l2 :test #'eq)) -;;(defun |union| (l1 l2) (union l1 l2 :test #'equalp)) -;;(defun UNIONQ (l1 l2) (union l1 l2 :test #'eq)) -;;(defun |intersection| (l1 l2) (intersection l1 l2 :test #'equalp)) -;;(defun INTERSECTIONQ (l1 l2) (intersection l1 l2 :test #'eq)) -(defun |member| (item sequence) - (cond ((symbolp item) (member item sequence :test #'eq)) - ((stringp item) (member item sequence :test #'equal)) - ((and (atom item) (not (arrayp item))) (member item sequence)) - (T (member item sequence :test #'equalp)))) - (defun |remove| (list item &optional (count 1)) (if (integerp count) (remove item list :count count :test #'equalp) @@ -1103,14 +1077,10 @@ the calculation by repeated divisions using the radix itself. ; 14.2 Accessing -;(define-function 'lastnode #'last) -;(define-function 'lastpair #'last) (defun |last| (x) (car (lastpair x))) ; 14.3 Searching -#+:CCL (DEFMACRO |assoc| (X Y) `(ASSOC** ,X ,Y)) -#-:CCL (DEFUN |assoc| (X Y) "Return the pair associated with key X in association list Y." ; ignores non-nil list terminators @@ -1226,29 +1196,10 @@ can be restored. ; 17.1 Creation - -#-AKCL -(defun concat (a b &rest l) - (let ((type (cond ((bit-vector-p a) 'bit-vector) (t 'string)))) - (cond ((eq type 'string) - (setq a (string a) b (string b)) - (if l (setq l (mapcar #'string l))))) - (if l (apply #'concatenate type a b l) - (concatenate type a b))) ) -#+AKCL -(defun concat (a b &rest l) - (if (bit-vector-p a) - (if l (apply #'concatenate 'bit-vector a b l) - (concatenate 'bit-vector a b)) - (if l (apply #'system:string-concatenate a b l) - (system:string-concatenate a b)))) - (define-function 'strconc #'concat) (defun make-cvec (sint) (make-array sint :fill-pointer 0 :element-type 'string-char)) -;(define-function 'CVECP #'stringp) - (define-function 'getstr #'make-cvec) (defun make-full-cvec (sint &optional (char #\space))