diff --git a/Makefile b/Makefile index 1ab19519..722c161b 100644 --- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ SRC = system syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ midas _teco_ emacs emacs1 rms klh syshst sra mrc ksc eak gren \ bawden _mail_ l lisp libdoc comlap lspsrc nilcom rwk chprog rg \ inquir acount gz sys decsys ecc alan sail kcc kcc_sy c games archy dcp \ - spcwar rwg + spcwar rwg libmax rat z emaxim rz maxtul DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc chprog BIN = sys2 emacs _teco_ lisp liblsp alan inquir sail comlap c decsys moon diff --git a/build/build.tcl b/build/build.tcl index 96b078f6..51eeee0c 100644 --- a/build/build.tcl +++ b/build/build.tcl @@ -1464,6 +1464,136 @@ respond "_" "liblsp;fasdmp fasl_rlb%;fasdmp\r" respond "_" "\032" type ":kill\r" +# libmax + +# all libmax components (well almost all) require libmax;module fasl +# at compile time. Build it first. + +respond "*" "complr\013" +respond "_" "libmax;module\r" +respond "_" "\032" +type ":kill\r" + +# libmax;maxmac can't be compiled unless libmax;mforma is (first) compiled. +# However, libmax;mforma uses libmax;macmac. Hence you end up having to +# compile libmax;mforma first, then libmax;maxmac, and then compiling these +# both a second time. Otherwise, there are not incorrectly generated FASL +# files for each, but anything that depends on these two packages will also +# have errors during compilation. + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((libmax) module))" +respond "274534" "(maklap)" +respond "_" "libmax;mforma\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((libmax) module))" +respond "274534" "(maklap)" +respond "_" "libmax;maxmac\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((libmax) module))" +respond "274534" "(maklap)" +respond "_" "libmax;mforma\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((libmax) module))" +respond "274534" "(maklap)" +respond "_" "libmax;maxmac\r" +respond "_" "\032" +type ":kill\r" + +# the following are required to compile some of the libmax; +# FASL files +# +respond "*" ":midas rwk;lfsdef fasl_rwk;lfsdef\r" +expect ":KILL" +respond "*" ":midas rat;ratlap fasl_rat;ratlap\r" +expect ":KILL" +respond "*" ":print maxdmp;..new. (udir)\r" +type ":vk\r" +respond "*" ":link maxdmp;ratlap fasl,rat;ratlap fasl\r" +respond "*" ":link libmax;lusets fasl,liblsp;\r" + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((libmax) module))" +respond "274534" "(maklap)" +respond "_" "libmax;ermsgx\r" +respond "_" "libmax;ermsgc\r" +respond "_" "z;fildir\r" +respond "_" "libmax;lmmac\r" +respond "_" "libmax;meta\r" +respond "_" "libmax;lmrund\r" +respond "_" "libmax;lmrun\r" +respond "_" "libmax;displm\r" +respond "_" "libmax;defopt\r" +respond "_" "libmax;mopers\r" +respond "_" "libmax;mrgmac\r" +respond "_" "libmax;nummac\r" +respond "_" "libmax;opshin\r" +respond "_" "libmax;edmac_emaxim;\r" +respond "_" "libmax;procs\r" +respond "_" "libmax;readm\r" +respond "_" "libmax;strmac\r" +respond "_" "libmax;transm\r" +respond "_" "libmax;rzmac_rz;macros\r" +respond "_" "libmax;transq\r" +respond "_" "libmax;mdefun\r" +respond "_" "\032" +type ":kill\r" + +# build MAXTUL FASL files + +respond "*" ":print maxerr;..new. (udir)\r" +type ":vk\r" +respond "*" ":print maxer1;..new. (udir)\r" +type ":vk\r" + +respond "*" "complr\013" +respond "_" "maxtul;strmrg\r" +respond "_" "maxtul;defile\r" +respond "_" "maxtul;docgen\r" +respond "_" "maxtul;query\r" +respond "_" "maxtul;maxtul\r" +respond "_" "maxtul;toolm\r" +respond "_" "maxtul;dclmak\r" +respond "_" "maxtul;mailer\r" +respond "_" "maxtul;mcl\r" +respond "_" "maxtul;timepn\r" +respond "_" "maxtul;expand\r" +respond "_" "maxtul;fsubr!\r" +respond "_" "maxtul;error!\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "maxtul;fasmap\r" +respond "_" "\032" +type ":kill\r" + +# define needs (for some reason) to be compiled separately. +# not doing this results in errors compiling macsyma sources, +# such as ELL; HYP > +# +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((libmax) module))" +respond "274534" "(maklap)" +respond "_" "libmax;define\r" +respond "_" "\032" +type ":kill\r" + bootable_tapes # make output.tape diff --git a/src/emaxim/edmac.106 b/src/emaxim/edmac.106 new file mode 100755 index 00000000..d5e827e0 --- /dev/null +++ b/src/emaxim/edmac.106 @@ -0,0 +1,289 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module edmac macro) + +#-lispm +(progn 'compile + (load-macsyma-macros lmrund) + (load-macsyma-macros-at-runtime 'lmrund) + ) + +;; Macsyma display-oriented expression editor +;; Macros and structure definitions +;; See EMAXIM;ED > and EMAXIM;EDCOM > for more information. +;; Written: Feb 17, 1979 By RZ, based on a version by CWH and BEE +;; Rewritten: June 2, 1979 by CWH for Macsyma Users' Conference +;; Alt: July 1, 1981 by GJC, annointing for NIL. + +;; Data Structures + +;; The smallest fundamental data unit is the expression -- this consists of a +;; macsyma expression, formatting information, a displayed region, and a +;; command region. Buffers consist of a collection of expressions and may +;; share expressions among one another. A subset of the expressions within a +;; buffer will be displayed in a window. Only complete sub expressions are +;; displayed, although REVEAL may be used to hide inner structure. + +(defstruct (expression) + body ;Body of the expression. A complete + ;subnode of this expression is always + ;displayed. + displayed ;The displayed portion of the expression. + ;Always a complete subnode. + region ;That portion of the expression which + ;subsequent commands will affect. May + ;be several branches of a subnode. + (save-pdl nil) ;Current way of keeping track of where + ;we are. + (region-length 1) ;Region length -- number of branches included + ;in region. Normally 1 unless extended with + ;extend-forward. + (operator nil) ;Operator of region node, i.e. this level + (operand nil) ;Entire node, i.e. the level itself + ;The are both nil when the region is the same + ;as the body. + expression-label ;Need some way of referring to expressions + ;within a buffer. This label is a symbol + ;and is bound to the body of the expression. + expression-height ;The height in characters of the expression. + ;Used by the redisplay. + (reveal-depth 0) ;If depth = 0, then reveal all of expression. + ;See Macsyma $REVEAL function. + (region-boxed? nil) ;Right now, this means that the expression + ;is current. + ) + +(defstruct (buffer) + buffer-name ;Name of the buffer. Used for moving between + ;them. + (expression-list nil) ;All of the expressions contained within + ;the buffer. Currently, all are displayed. + (current-exp nil) ;The current expression in this buffer. + (current-exp-distance-from-top 0) ;If this field is 0, then the + ;current expression is the top expression on + ;the screen. + (buffer-mode '|Expression|) ;Do we want this? + ) + + +;; Command definition macro + +;; Defines an editor command (and a lisp function) with the specified name. +;; The possible options are: +;; +;; (argument n) Makes "n" an entry in the bvl of the function. +;; Means that this function gets passed its argument +;; which it uses as it pleases. +;; +;; (discard-argument) This function doesn't use its argument and +;; and doesn't want to be iterated. If neither +;; of the above two argument options are specified, +;; then the character dispatcher will iterate the +;; command if an argument is given. +;; +;; (character c) Makes "c" an entry in the bvl of the function. Means +;; that this function gets passed the character which +;; invoked it. +;; +;; (read-key key "Key: ") This function wants a character to be typed +;; for purposes of description, assignment, etc. +;; Control and Meta prefixes are taken care of +;; by READ-KEY. +;; +;; (read-line file-name "File Name: ") This function wants a string +;; argument to be typed in the +;; minibuffer, terminated by a +;; carriage return. "file-name" +;; will be in the bvl of the function. +;; +;; (read-expression exp "Expression: ") This function wants a macsyma +;; expression as an argument. +;; Expression returned in the +;; macsyma internal format. +;; +;; Note that the CDDR of the forms starting with READ-LINE and READ-EXPRESSION +;; can be any arbitrary format string. Note also that the order in which these +;; forms appear in the bvl is critical. They must appear in the same order +;; as presented above. + +;; (defcom foo ((argument n) (character c) (read-line line "Type a ~A:" frobboz)) +;; "Random documentation" +;; (random-code)) --> +;; +;; (progn 'compile +;; (putprop 'foo 'ed-documentation "Random documentation") +;; (putprop 'foo 'ed-arg-action 'pass) +;; (putprop 'foo 'ed-char-action 'pass) +;; (defun foo (n c &optional (line (read-line "Type a ~A:" frobboz))) +;; (random-code))) + +(defmacro defcom (name option-list documentation &rest body) + (let ((arg-list nil) + (arg-action 'iterate) + (char-action 'discard)) + (mapcar + #'(lambda (option) + (caseq (car option) + (argument (push (cadr option) arg-list) + (setq arg-action 'pass)) + (discard-argument (setq arg-action 'discard)) + (character (push (cadr option) arg-list) + (setq char-action 'pass)) + (read-key + (or (memq '&optional arg-list) + (push '&optional arg-list)) + (push `(,(cadr option) (progn (minibuffer-clear) + (read-key nil t . ,(cddr option)))) + arg-list)) + ((read-line read-expression) + (or (memq '&optional arg-list) + (push '&optional arg-list)) + (push `(,(cadr option) (,(car option) . ,(cddr option))) + arg-list)) + (t (error "Unknown defcom option" (car option))))) + option-list) + (setq arg-list (nreverse arg-list)) + `(progn 'compile + (putprop ',name ,documentation 'ed-documentation) + (putprop ',name ',arg-action 'ed-arg-action) + (putprop ',name ',char-action 'ed-char-action) + #+maclisp + ,@(if (memq '&optional arg-list) `((declare (*lexpr ,name)))) + (defun ,name ,arg-list . ,body)))) + +;; Compatibility macros and other random stuff + +(defmacro string-capitalize (string) + `(string-append (string-upcase (substring ,string 0 1)) + (string-downcase (substring ,string 1)))) + + +;; Useful predicates for examining the state of an expression. +;; Please use these if possible so as to avoid dependence upon our +;; current form of expression representation. + +; (eq (body current-exp) (region current-exp)) is also a test for this. +(defmacro region-contains-top-node? () + '(null (save-pdl current-exp))) + +(defmacro region-contains-terminal-node? () + '(atom (cadr (region current-exp)))) + +; (eq (caar (save-pdl current-exp)) 'CDR) is also a test for this. +(defmacro region-contains-first-branch? () + '(eq (region current-exp) (operand current-exp))) + +(defmacro region-contains-last-branch? () + '(null (nthcdr (1+ (region-length current-exp)) + (region current-exp)))) + +(defmacro region-contains-entire-level? () + '(= (region-length current-exp) + (length (cdr (operand current-exp))))) + + +;; Declarations: + +(if (fboundp 'special) + (special buffer-list ;All of the buffers being used. + ;Maintained between invocations + current-buffer ;Contains the current expression. + current-exp ;Expression currently being edited. + + screen-exp-list ;Redisplay state information + screen-buffer-name ;Should be made intelligent about + screen-exp-list-length ;windows. + + previous-buffer ;Previously selected buffer + + single-char-table ;Dispatch table for single character commands + c-x-prefix-table ;Dispatch table for control-x prefix commands + single-char-table-size ;Size of array + c-x-prefix-table-size ;Size of array + + buffer-name-count ;For generating buffer names + kill-pdl ;pdl of deleted expressions + mark-pdl ;pdl of marks + need-full-redisplay ;When screen has been completely destroyed + ;Rename to full-redisplay? + supress-redisplay ;Deliberately supress redisplay until after + ;next command typed. + + char-to-descriptor-alist ;For converting between + descriptor-to-char-alist ;characters and their + ;description. + + idel-chars-available? ;Terminal control information + idel-lines-available? + overstrike-available? + 12-bit-kbd-available? + 12-bit-input ;Fixnum input stream for + ;Knight keyboards. + + %kbd-control ;Bit specifiers for the appropriate + %kbd-meta ;fields in the Lisp Machine character + %kbd-control-meta ;representation. + + *multiple-keystroke-char-typed* ;READ-KEY has to return + ;two values, but can't in Maclisp. Use this + ;global instead. Indicates that a control + ;or meta prefix was typed as a part of the + ;most recently typed character. + + expr-area-height ;Screen parameters. + minibuffer-height ;Single window only. + mode-line-vpos + minibuffer-vpos + )) + +(if (fboundp 'fixnum) + (fixnum screen-region-length buffer-name-count + single-char-table-size c-x-prefix-table-size + expr-area-height minibuffer-height + mode-line-vpos minibuffer-vpos + %kbd-control %kbd-meta %kbd-control-meta + )) + +;; Macsyma special variables + +(if (fboundp 'special) + (special $outchar $boxchar ttyheight linel $linenum)) + +(if (fboundp 'fixnum) + (fixnum ttyheight linel $linenum)) + +;; Special variables in MRG;DISPLA + +(load-macsyma-macros-at-runtime 'displm) + +;; Inter-module functions -- generally I/O stuff. + +(if (fboundp '*expr) + (*expr ed-prologue ed-epilogue enable-echoing disable-echoing + display-expression display-expressions display-mode-line + dctl-clear-lines dctl-scroll-region-up dctl-scroll-region-down + minibuffer-clear expr-area-clear read-char tv-beep + label-exp box-region unbox-region + region-as-mexp delete-expression top-level + make-current-exp make-current-buffer full-redisplay)) + +(if (fboundp '*lexpr) + (*lexpr set-key make-exp + read-key read-line read-expression + minibuffer-print char-to-descriptor + ed-error ed-internal-error + replace-region select-buffer)) + +(if (fboundp 'notype) + (notype (dctl-clear-lines fixnum fixnum) + (dctl-scroll-region-up fixnum fixnum fixnum) + (dctl-scroll-region-down fixnum fixnum fixnum))) + +;; Macsyma system functions. +(if (fboundp '*expr) + (*expr retrieve simplify ssimplifya nformat-all meval makelabel mset + $partfrac)) + +(sstatus feature emaxim-edmac) diff --git a/src/libmax/define.65 b/src/libmax/define.65 new file mode 100644 index 00000000..510a593e --- /dev/null +++ b/src/libmax/define.65 @@ -0,0 +1,523 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module define macro) + +(DECLARE (SPECIAL EOF-COMPILE-QUEUE)) + +;; Special form for declaring variables to be global throughout all +;; of Macsyma. Simulates Lisp Machine special variable annotation. +;; Syntax is: + +;; (DEFMVAR &OPTIONAL &REST ) + +;; The accepted flags are: +;; FIXNUM -- declares the variable to be a fixnum globally. +;; Automatically sets the SETTING-PREDICATE to be #'FIXP +;; FLONUM -- declares the variable to be a flonum globally. +;; Automatically sets the SETTING-PREDICATE to be #'FLOATP +;; NO-RESET -- prevents the switch from being reset to its initial +;; value when RESET() is done. +;; IN-CORE -- marks a variable defined in an out-of-core file +;; as being needed by in-core code. This makes sure +;; the variable is initialized in the in-core system. +;; MODIFIED-COMMANDS -- the next token is taken to be the name of a command +;; or a list of commands which this switch modifies. +;; Presumably, reverse pointers will also exist when +;; DEFMFUN is extended. +;; SETTING-PREDICATE -- the next token is a function which is called on the +;; variable and the value being assigned to it to make +;; sure that it is a valid setting. +;; SETTING-LIST -- the next token is a list of valid settings for switch. + +;; Some Examples: + +;; (DEFMVAR $LOADPRINT T +;; "Governs the printing of messages accompanying loading of files. +;; The following options are available: TRUE means always print the message; +;; 'LOADFILE means print only when the LOADFILE command is used; 'AUTOLOAD +;; means print only when a file is automatically loaded in (e.g. the +;; integration file SIN FASL); FALSE means never print the loading message." +;; MODIFIED-COMMANDS '($LOADFILE $BATCH) +;; SETTING-LIST '(T $AUTOLOAD $LOADFILE NIL) +;; NO-RESET) + +;; (DEFMVAR $CALCOMPNUM 20. +;; "The number of points plotted when the variable range +;; is specified as a closed interval. The default value is sufficient +;; for trying things out. 100 is a suitable value for final hard copy." +;; FIXNUM +;; MODIFIED-COMMANDS '($PLOT2 $PARAMPLOT2)) +;; +;; +;; DESCRIBE(CALCOMPNUM); will then print out: +;; +;; CALCOMPNUM [Default = 20, Currently = 20] - The number of points plotted +;; when the variable range is specified as a closed interval. The default +;; value is sufficient for trying things out. 100 is a suitable value for +;; final hard copy. This variable modifies the behavior of the PLOT2 and +;; PARAMPLOT2 commands. +;; +;; DESCRIBE(CALCOMPNUM,VERBOSE); might print out the above information and +;; then the documentation on the PLOT2 and PARAMPLOT2 commands. Likewise, +;; DESCRIBE(PLOT2); could describe PLOT2, and DESCRIBE(PLOT2,VERBOSE) could +;; describe all the switches which affect PLOT2 as well. + +;; This definition of DEFMVAR, and the code in this file, is for ITS only. +;; Other systems use the definition in LIBMAX;MAXMAC or hack their own. When +;; compiling for installation, send special variable declarations and +;; initializations to files on ALJABR. Initializations are kept there so that +;; Macsyma user level variables will be set even if the appropriate out-of-core +;; file isn't loaded and for the benefit of the RESET function. + +;; Note: If *you* are into hacking this, maybe think about having +;; work through the info in the STRING-FILE's on MAXERR. +;; This would keep compilations from doing a LOT of I/O. When CWH +;; first hacked this the DCL files where small. -GJC + +(DEFVAR DEFMVAR-RESET-INITS NIL + "List of symbol and initial value pairs for variables which can be reset.") +(DEFVAR DEFMVAR-NO-RESET-INITS NIL + "List of symbol and initial value pairs for variables which cannot be reset.") +(DEFVAR DEFMVAR-SPECIAL-DCLS NIL + "List of all symbols declared as global variables in the current file.") +(DEFVAR DEFMVAR-FIXNUM-DCLS NIL + "List of all global variables declared to be fixnums in the current file.") +(DEFVAR DEFMVAR-FLONUM-DCLS NIL + "List of all global variables declared to be flonums in the current file.") + +(DEFVAR PUNT-IN-SET-CAREFULLY NIL) + +(DEFVAR UPDATE-REMIND-LUSERS '("[DSK:MAXDOC;MDOC MAIL]")) + +(defun macsyma-compilation-p () + ;; a bit DWIM'ish to handle all existing instalation + ;; mechanisms. + (and (status feature complr) + (memq compiler-state '(maklap compile)) + (COND ((BOUNDP 'TEST-COMPILATION-P) + (NOT (EVAL 'TEST-COMPILATION-P))) + (T + (STATUS FEATURE MACSYMA-COMPLR))))) + +(DEFUN UPDATE-REMIND (TYPE OBJECT &REST STUFF) + (COND ((AND (macsyma-compilation-p) + (FBOUNDP 'FORMAT-MAIL) + (IF (ATOM OBJECT) + (= #/$ (GETCHARN OBJECT 1)) + T)) + (FORMAT-MAIL (CONS (STATUS UNAME) + UPDATE-REMIND-LUSERS) + "~ + ~&Hi, I just compiled the file ~A and it defines~ + ~%a new ~S called ~S. Here's some info on it, + ~%~S.~ + ~% + ~% yours truly, + ~% ~S.~ + ~%" + (namestring (truename infile)) + type object stuff + (status userid))))) + +(DEFMACRO DEFMVAR (VARIABLE &OPTIONAL (INITIAL-VALUE NIL IV-P) DOCUMENTATION + &REST FLAGS &AUX TYPE NO-RESET IN-CORE) + + (OR (GET VARIABLE 'SPECIAL) + (UPDATE-REMIND 'DEFMVAR VARIABLE + "INITIAL-VALUE=" + (IF (> (FLATC INITIAL-VALUE) 500.) + "too big to print, so see the source" + INITIAL-VALUE) + "DOCUMENTATION=" DOCUMENTATION + "MODES=" FLAGS)) + ;; Parse keywords. Do this in a more sophisticated way later. + (SETQ TYPE (COND ((MEMQ 'FIXNUM FLAGS) 'FIXNUM) + ((MEMQ 'FLONUM FLAGS) 'FLONUM) + (T NIL))) + (SETQ NO-RESET (MEMQ 'NO-RESET FLAGS)) + (SETQ IN-CORE (MEMQ 'IN-CORE FLAGS)) + ;; When compiling for installation, update various data bases. + (WHEN (macsyma-compilation-p) + (DEFINE-ASSURE-SETUP) + (PUSH VARIABLE DEFMVAR-SPECIAL-DCLS) + (CASEQ TYPE + (FIXNUM (PUSH VARIABLE DEFMVAR-FIXNUM-DCLS)) + (FLONUM (PUSH VARIABLE DEFMVAR-FLONUM-DCLS))) + ;; An initialization for the variable is always placed in the fasl + ;; file so that it can be used outside of Macsyma. For the benefit + ;; of the Macsyma user, all user-level variables are initialized + ;; when the Macsyma is created so that they may be examined before the + ;; out-of-core file is loaded. By default, user-level variables can + ;; be reset via the RESET command and get stuck on the RESET + ;; list. Those which are unaffected by this command are placed on + ;; the NO-RESET list. Lisp level variables defined in out-of-core + ;; files but referenced by in-core files also get placed on the + ;; NO-RESET list. + (WHEN (AND IV-P (OR (= (GETCHARN VARIABLE 1) #/$) IN-CORE)) + (IF (OR NO-RESET IN-CORE) + (PUSH (CONS VARIABLE INITIAL-VALUE) DEFMVAR-NO-RESET-INITS) + (PUSH (CONS VARIABLE INITIAL-VALUE) DEFMVAR-RESET-INITS)))) + ;; Only turn into DEFVAR when compiling. + (COND ((STATUS FEATURE COMPLR) + `(PROGN 'COMPILE + ,(IF IV-P + `(DEFVAR ,VARIABLE ,INITIAL-VALUE) + `(DEFVAR ,VARIABLE)) + ,@(IF TYPE `((DECLARE (,TYPE ,VARIABLE)))))) + (IV-P `(SET-CAREFULLY ',VARIABLE ,INITIAL-VALUE)) + ;; For the benefit of UREAD. + (T `',VARIABLE))) + +;; When running interpreted code, check to see if the variable already has +;; a value. If it does, and the value is different, then query the user +;; about changing its value. Be careful about circular structure. + +(DECLARE (*LEXPR Y-OR-N-P) (SPECIAL $LOADPRINT)) + +(DEFUN SET-CAREFULLY (SYMBOL NEW-VALUE &AUX OLD-VALUE ($LOADPRINT NIL)) + (COND ((NOT (BOUNDP SYMBOL)) (SET SYMBOL NEW-VALUE)) + (PUNT-IN-SET-CAREFULLY (SYMEVAL SYMBOL)) + (T (SETQ OLD-VALUE (SYMEVAL SYMBOL)) + (UNLESS (OR (EQUAL OLD-VALUE NEW-VALUE) + ;; For MacLisp pseudo-strings. + (AND (SYMBOLP OLD-VALUE) (SYMBOLP NEW-VALUE) + (SAMEPNAMEP OLD-VALUE NEW-VALUE))) + (LET ((PRINLEVEL 4) (PRINLENGTH 5)) + (FORMAT T "~&The symbol ~S already has value ~S.~%" SYMBOL OLD-VALUE) + (FORMAT T "Do you want to change it to ~S? " NEW-VALUE) + (IF (Y-OR-N-P "Do you?") (SET SYMBOL NEW-VALUE))))))) + +;; Special form for declaring functions known throughout all of Macsyma. +;; Simulates Lisp Machine global compilation environment. +;; Syntax is: + +;; (DEFMFUN [FEXPR] . body) + +;; Items in square brackets are optional. +;; Documentation and additional flags will be added later. + +(DEFVAR DEFMFUN-EXPR-DCLS NIL + "List of all symbols declared as EXPRs in the current file.") +(DEFVAR DEFMFUN-LEXPR-DCLS NIL + "List of all symbols declared as EXPRs in the current file.") +(DEFVAR DEFMFUN-FEXPR-DCLS NIL + "List of all symbols declared as EXPRs in the current file.") + +;; Next, we want to make this thing generate autoload properties. +;; Should determine if the file is in-core or out of core, though. + +(DEFMACRO DEFMFUN (FUNCTION BVL . BODY) + (OR (GETL (IF (ATOM FUNCTION) FUNCTION (CAR FUNCTION)) + '(*EXPR *LEXPR *FEXPR)) + (UPDATE-REMIND 'DEFMFUN FUNCTION + "ARGUMENT LIST=" BVL + "DOCUMENTATION STRINGS=" + (DO ((L BODY (CDR L)) + (DOC NIL)) + ((NULL (cdr l)) doc) + (IF (ATOM (CAR L)) (PUSH (CAR L) DOC))))) + (WHEN (STATUS FEATURE MACSYMA-COMPLR) + (DEFINE-ASSURE-SETUP) + (COND ((EQ BVL 'FEXPR) + (PUSH FUNCTION DEFMFUN-FEXPR-DCLS)) + ((OR (AND BVL (SYMBOLP BVL)) + (MEMQ '&OPTIONAL BVL) + (MEMQ '&REST BVL)) + (PUSH FUNCTION DEFMFUN-LEXPR-DCLS)) + (T (PUSH FUNCTION DEFMFUN-EXPR-DCLS)))) + `(DEFUN ,FUNCTION ,BVL . ,BODY)) + + + +(DEFMACRO DEFMSPEC (NAME BVL . BODY) + `(DEFUN (,NAME MFEXPR* + #+MACLISP MFEXPR*S + ) ,BVL . ,BODY)) + +(DEFMACRO DEFMSPEC-1 (NAME BVL . BODY) + ;; (DEFMSPEC-1 FOO (X) ...) is an exact replacement + ;; for (DEFMFUN FOO FEXPR (X) ...) + `(PROGN 'COMPILE + (DEFMFUN ,NAME FEXPR ,BVL . ,BODY) + (LET ((P (OR (GETL 'MSPEC-HOOK '(MFEXPR* MFEXPR*S)) + (ERROR 'MSPEC-HOOK NIL 'FAIL-ACT)))) + (REMPROP ',NAME (CAR P)) + (PUTPROP ',NAME (CADR P) (CAR P))))) + +(DEFVAR DEFINE-MODULE-NAME NIL + "A namelist which describes the module being compiled. For vanilla + files, it is simply the value of INFILE. For splitfiles, the FN1 + shows the name of the splitfile. We have to save the value of INFILE so + we can look at it later when the EOF-COMPILE-QUEUE is run. The input file + is closed at that point.") + +(DEFVAR DEFINE-SPLITFILE-NAME NIL + "If non-NIL, then we are processing a splitfile and this is a symbol which + is the name of the file which is split.") + +;; This function gets run whenever an DEFMFUN or DEFMVAR is encountered. +;; The first time it is entered for a given file being compiled, it +;; resets all the global variables. This is done at the beginning rather +;; than the end of a compilation since we may have to quit in the middle. +;; These variables must be reset in a function and not specified in DEFVAR's +;; since several files may get compiled for one loading of this file. + +;; This procedure modified 12/2/80 by CWH. Replace (TRUENAME INFILE) +;; with a namelist which is computed from both the INFILE and ONMLS +;; in order to work for splitfiles. ONMLS stands for output namelists. +;; Apparently, EOF-COMPILE-QUEUE gets run as each splitfile is finished. + +(DEFUN DEFINE-ASSURE-SETUP () + (UNLESS (MEMBER '(DECLARE (DEFINE-PROCESS-EOF)) EOF-COMPILE-QUEUE) + (PUSH '(DECLARE (DEFINE-PROCESS-EOF)) EOF-COMPILE-QUEUE) + ;; Get the directory and version number from the INFILE + ;; and the module name from (CAR ONMLS). + (LET ((I (TRUENAME INFILE)) + (O (CAR ONMLS))) + (UNLESS (EQ (CADR I) (CADR O)) + (SETQ DEFINE-SPLITFILE-NAME (CADR I))) + (SETQ DEFINE-MODULE-NAME (LIST (CDAR I) (CADR O) (CADDR I)))) + (SETQ DEFMVAR-SPECIAL-DCLS NIL) + (SETQ DEFMVAR-RESET-INITS NIL) + (SETQ DEFMVAR-NO-RESET-INITS NIL) + (SETQ DEFMFUN-EXPR-DCLS NIL) + (SETQ DEFMFUN-LEXPR-DCLS NIL) + (SETQ DEFMFUN-FEXPR-DCLS NIL))) + + +;; Set up filenames. + +(DEFVAR DEFINE-VAR-FILE #+ITS "MAXDOC;DCL VARS") +(DEFVAR DEFINE-FUNCTION-FILE #+ITS "MAXDOC;DCL FCTNS") +(DEFVAR DEFINE-RESET-INITS-FILE #+ITS "MAXDOC;INIT RESET") +(DEFVAR DEFINE-NO-RESET-INITS-FILE #+ITS "MAXDOC;INIT NORESE") +(DEFVAR DEFINE-TEMP-FILE #+ITS "MAXDOC;_DEFI_ OUTPUT") + +;; All the nice header hair etc. is *very* very slow, so I've put in the option +;; to punt all this, since it is only needed when a new variable or function +;; entry point is being introduced into the system, I.E. RARELY. This single +;; crude-switch allows be to punt entirely for now in files which I know are +;; ok. Later on, redo this whole thing, but right now I have to recompile LOTS +;; of files simply to test changes in the macro environment. -GJC +;; ITS needs keyed vfiles. -cwh + +(DEFVAR DEFINE-UPDATE-FILE T + "Switch which controls updating of DEFINE files. Set this to T, NIL, or + ASK in your MCOMPL init file.") + +;; This function gets run at the end of the file compilation. Processes global +;; variable declarations, external function declarations, initializations which +;; can be reset, and initializations which cannot be reset. + +(DEFUN DEFINE-PROCESS-EOF () + (WHEN (OR (EQ DEFINE-UPDATE-FILE T) + (AND (EQ DEFINE-UPDATE-FILE 'ASK) + (Y-OR-N-P "~&Update the DECLARE files?"))) + (DEFINE-UPDATE-FILE + DEFMVAR-SPECIAL-DCLS + DEFINE-VAR-FILE "Declarations" + ";; Declaration file for global variables known throughout Macsyma." + #'UPDATE-VAR-DCLS) + (DEFINE-UPDATE-FILE + (OR DEFMFUN-EXPR-DCLS DEFMFUN-LEXPR-DCLS DEFMFUN-FEXPR-DCLS) + DEFINE-FUNCTION-FILE "Declarations" + ";; Declaration file for external functions known throughout Macsyma." + #'UPDATE-FUNCTION-DCLS) + (DEFINE-UPDATE-FILE + DEFMVAR-RESET-INITS + DEFINE-RESET-INITS-FILE "Initializations" + ";; This is the initialization file for variables which can be reset." + #'UPDATE-RESET-INITS) + (DEFINE-UPDATE-FILE + DEFMVAR-NO-RESET-INITS + DEFINE-NO-RESET-INITS-FILE "Initializations" + ";; This is the initialization file for variables which cannot be reset." + #'UPDATE-NO-RESET-INITS))) + +;; General purpose function which goes through the hair of printing nice +;; headers, unwind-protects opening of the files, and flushes the old entry for +;; the file being compiled. Creating a specific entry is done by calling a +;; function specified above. We always pass through the file, even if we have +;; no entries to enter, so as to flush the old entry. + +(DEFUN DEFINE-UPDATE-FILE (DO-IT? FILE ENTRY-HEADER FILE-HEADER ENTRY-FUNCTION + &AUX LINE LINE-2) + (PHI ((IN-FILE (IF (PROBEF FILE) (OPEN FILE 'IN))) + (OUT-FILE (OPEN DEFINE-TEMP-FILE 'OUT))) + ;; Generate a new header and throw away the old one. + (FORMAT OUT-FILE ";; -*- Mode: Lisp; Package: Macsyma -*-~%") + (FORMAT OUT-FILE "~A~%" FILE-HEADER) + ;; THIS-FILE is set up by LIBMAX;MPRELU. + (FORMAT OUT-FILE ";; This file was generated by DEFINE version ~A.~%" + (GET 'DEFINE 'VERSION)) + (IF IN-FILE (DOTIMES (I 3) (READLINE IN-FILE))) + ;; Read and pass through everything in the file up to the end of + ;; the file. Throw away any entries dealing with our file. + (IF IN-FILE + (*CATCH 'EOF + (DO () (NIL) + (SETQ LINE (READLINE IN-FILE)) + (IF (NULL LINE) (*THROW 'EOF T)) + ;; An entry is assumed to begin with a blank line, a single + ;; line comment, and then a (DECLARE (COMMENT )) form. + (COND ((STRING-EQUAL LINE "") + (SETQ LINE (READLINE IN-FILE)) + (SETQ LINE-2 (READLINE IN-FILE)) + (LET ((FORM (READLIST (EXPLODEN LINE-2)))) + (COND ((AND (EQ (CAR FORM) 'DECLARE) + (EQ (CAADR FORM) 'COMMENT) + (EQ (CADADR FORM) (CADR DEFINE-MODULE-NAME))) + ;; Throw away all lines which follow + ;; until the next blank line. + (DO () (NIL) + (SETQ LINE (READLINE IN-FILE)) + (IF (NULL LINE) (*THROW 'EOF T)) + (WHEN (STRING-EQUAL LINE "") + (TERPRI OUT-FILE) + (RETURN T)))) + (T (FORMAT OUT-FILE "~%~A~%~A~%" LINE LINE-2))))) + (T (FORMAT OUT-FILE "~A~%" LINE)))))) + ;; Now spit ours out at the end of the file, if we have something + ;; to print. This orders the file chronologically -- last entry + ;; is the most recent. (STATUS USERID) is set to MACSYM in :MCL, + ;; so use (STATUS UNAME) instead. + (WHEN DO-IT? + (FORMAT OUT-FILE "~%;; ~A for ~A~@[~2G (~A split)~], compiled ~A by ~A.~%" + ENTRY-HEADER (NAMESTRING DEFINE-MODULE-NAME) + DEFINE-SPLITFILE-NAME (DEFINE-TIME-AND-DATE) (STATUS UNAME)) + (FORMAT OUT-FILE "(DECLARE (COMMENT ~A))~%" (CADR DEFINE-MODULE-NAME)) + (FUNCALL ENTRY-FUNCTION OUT-FILE))) + ;; This must be done after both files have been closed. + (IF (PROBEF FILE) (DELETEF FILE)) + (RENAMEF DEFINE-TEMP-FILE FILE)) + +(DEFUN DEFINE-TIME-AND-DATE () + (FORMAT NIL "~D//~D//~D ~D:~2,'0D" + (CADR (STATUS DATE)) (CADDR (STATUS DATE)) (CAR (STATUS DATE)) + (CAR (STATUS DAYTIME)) (CADR (STATUS DAYTIME)))) + + +;; Functions for specific types of entries in specific files. + +(DEFUN UPDATE-SYMBOL-LIST (FILE HEADER LIST &AUX (LENGTH (STRING-LENGTH HEADER))) + (WHEN LIST + (PRINC HEADER FILE) + (DOLIST (SYMBOL LIST) + ;; Format for 78 character screen width + (WHEN (> (+ (CHARPOS FILE) (FLATSIZE SYMBOL) 1) 78.) + (TERPRI FILE) + (DOTIMES (I LENGTH) (TYO #\SP FILE))) + (FORMAT FILE " ~S" SYMBOL)) + (FORMAT FILE "))~%"))) + +(DEFUN UPDATE-VAR-DCLS (FILE) + (UPDATE-SYMBOL-LIST FILE "(DECLARE (SPECIAL" DEFMVAR-SPECIAL-DCLS) + (UPDATE-SYMBOL-LIST FILE "(DECLARE (FIXNUM" DEFMVAR-FIXNUM-DCLS) + (UPDATE-SYMBOL-LIST FILE "(DECLARE (FLONUM" DEFMVAR-FLONUM-DCLS)) + +(DEFUN UPDATE-FUNCTION-DCLS (FILE) + (UPDATE-SYMBOL-LIST FILE "(DECLARE (*EXPR" DEFMFUN-EXPR-DCLS) + (UPDATE-SYMBOL-LIST FILE "(DECLARE (*LEXPR" DEFMFUN-LEXPR-DCLS) + (UPDATE-SYMBOL-LIST FILE "(DECLARE (*FEXPR" DEFMFUN-FEXPR-DCLS)) + +(DEFUN UPDATE-INIT-LIST (FILE LIST &AUX VAR INIT) + (FORMAT FILE "(SETQ") + (DOLIST (PAIR LIST) + (DESETQ (VAR . INIT) PAIR) + ;; Format for 78 character screen width + (IF (> (+ (CHARPOS FILE) (FLATSIZE VAR) (FLATSIZE INIT) 2) 78.) + (FORMAT FILE "~%~5X")) + ;; Print the variable name and the initialization to the file. + ;; Be careful for pseudo-strings. + (FORMAT FILE " ~S ~:[~;'~]~S" VAR (STRINGP INIT) INIT)) + (FORMAT FILE ")~%")) + +;; NREVERSE init lists so that the initializations get done in the order +;; they appear in the file. + +(DEFUN UPDATE-RESET-INITS (FILE) + (UPDATE-INIT-LIST FILE (NREVERSE DEFMVAR-RESET-INITS))) +(DEFUN UPDATE-NO-RESET-INITS (FILE) + (UPDATE-INIT-LIST FILE (NREVERSE DEFMVAR-NO-RESET-INITS))) + +(DEFVAR DEF-SUBR-ENTRY-POINTS T + "If NIL it just declares them, not actually defines them") + +(DEFVAR SUBR-ARGLIST-ALIST + ;; these also happen to be the symbolic names of the + ;; accumulators through which the arguments will be passed. + '((0 . ()) + (1 . (A)) + (2 . (A B)) + (3 . (A B C)) + (4 . (A B C D)) + (5 . (A B C D E)))) + +;;; Example: +;;; (DEF-SUBR-ENTRY-POINTS BAZ 3 (4 . QPRZN)) +;;; sets up optimization for (BAZ A B C D) => (QPRZN A B C D) + +(DEFUN PUT-TRANS (NAME FUNCTION FIRSTP) + (LET ((SOURCE-TRANS (DELQ FUNCTION (GET NAME 'SOURCE-TRANS)))) + (PUTPROP NAME + (IF FIRSTP + (CONS FUNCTION SOURCE-TRANS) + (NCONC SOURCE-TRANS (LIST FUNCTION))) + 'SOURCE-TRANS))) + +(DEFUN SUBR-ENTRY-OPTIMIZER (FORM) + (LET ((ENTRY (ASSOC (LENGTH (CDR FORM)) + (GET (CAR FORM) 'SUBR-ENTRY-ALIST)))) + (IF ENTRY + (VALUES (CONS (CDR ENTRY) (CDR FORM)) T) + (VALUES FORM NIL)))) + + +(comment +(DEFMACRO DEF-SUBR-ENTRY-POINTS (NAME &REST ARGUMENT-NUMBERS) + ;; This was found to be needed before the + ;; MERROR function really won on the PDP-10. + ;; -GJC + (LET ((SUBR-ENTRY-ALIST + (MAPCAR #'(LAMBDA (N) + (COND ((NUMBERP N) + (CONS N (SYMBOLCONC N NAME))) + ((AND (EQ (TYPEP N 'LIST)) + (SYMBOLP (CDR N))) + N) + (T + (ERROR "Cannot be defined as SUBR" + N + 'FAIL-ACT)))) + ARGUMENT-NUMBERS))) + (PUTPROP NAME SUBR-ENTRY-ALIST 'SUBR-ENTRY-ALIST) + (PUTPROP NAME 'SUBR-ENRY + `(PROGN + 'COMPILE + ,@(MAPCAR + #'(LAMBDA (NARGS-DOT-NAME) + (LET ((CELL (ASSOC (CAR NARGS-DOT-NAME) + SUBR-ARGLIST-ALIST))) + (OR CELL + (ERROR "Cannot be defined as SUBR" + NARGS-DOT-NAME + 'FAIL-ACT)) + `(DEFUN ,(CDR NARGS-DOT-NAME) + ,(CDR CELL) + +))))))))) + + + +;; To do: +;; Autoload properties +;; FIXNUM and FLONUM declarations for functions -- parameters and return values. +;; LOAD-TIME-INIT keyword for symbols like TTYHEIGHT, LINEL, etc. +;; Update MANUAL;MACSYM DOC automatically. +;; Implement SETTING-PREDICATE. Also ASSIGN properties. +;; (FORMAT X "~80,1,0,';<~; -*- Mode: Lisp; Package: Macsyma -*- ~;~>~%") +;; SYMBOL, BOOLEAN, etc. keywords for variables like FIXNUM, FLONUM +;; Automatically do the setting predicate. + diff --git a/src/libmax/defopt.8 b/src/libmax/defopt.8 new file mode 100644 index 00000000..c4cc19d4 --- /dev/null +++ b/src/libmax/defopt.8 @@ -0,0 +1,82 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module defopt macro) + +;; For defining optimizers which run on various systems. +;; Q: What is an optimizer? +;; A: A transformation which takes place in the compiler. + +;; ***==> Right now, DEFOPT is used just like you would a DEFMACRO <==*** +;; (defopt ) + +;; PDP-10 Maclisp: +;; SOURCE-TRANS property is a list of functions (F[1] F[2] ... F[n]). +;; F[k] is funcalled on the
, it returns (VALUES ). +;; If = NIL then compiler procedes to F[k+1] +;; If = T then compiler calls starts again with F[1]. + +;; LispMachine Lisp: +;; COMPILER:OPTIMIZERS property is a list of functions as in PDP-10 Maclisp. +;; F[k] returns . Stop condition is (EQ ). + +;; VAX NIL (with compiler "H"): +;; SOURCE-CODE-REWRITE property is a function, returns NIL if no rewrite, +;; else returns NCONS of result to recursively call compiler on. + +;; Multics Maclisp: +;; ??? +;; Franz Lisp: +;; ??? + +;; General note: +;; Having a list of optimizers with stop condition doesn't provide +;; any increase in power over having a single property. For example, +;; only two functions in LISPM lisp have more than one optimizer, and +;; no maclisp functions do. It just isn't very usefull or efficient +;; to use such a crude mechanism. What one really wants is to be able +;; to define a set of production rules in a simple pattern match +;; language. The optimizer for NTH is a case in point: +;; (NTH 0 X) => (CAR X) +;; (NTH 1 X) => (CADR X) +;; ... +;; This is defined on the LISPM as a single compiler:optimizers with +;; a hand-compiled pattern matcher. + +#+LISPM +(progn 'compile +(defmacro defopt-internal (name . other) + `(defun (,name opt) . ,other)) +(defun opt-driver (form) + (funcall (get (car form) 'opt) form)) +(defmacro defopt (name . other) + `(progn 'compile + ,(si:defmacro1 (cons name other) 'defopt-internal) + (defprop ,name (opt-driver) compiler:optimizers)))) +#+PDP10 +(progn 'compile +(defun opt-driver (form) + (values (apply (get (car form) 'opt) + (cdr form)) + t)) +;; pdp10 maclisp has argument destructuring available in +;; vanilla defun. +(defmacro defopt (name . other) + `(progn 'compile + (defun (,name opt) . ,other) + (defprop ,name (opt-driver) source-trans))) +) +#+NIL +(progn 'compile +(defun opt-driver (form) + (ncons (apply (get (car form) 'opt) (cdr form)))) +(defmacro defopt (name argl . other) + `(progn 'compile + (defun (,name opt) ,argl . ,other) + (defprop ,name opt-driver source-code-rewrite))) +) +#+(or Multics Franz) +(defmacro defopt (name argl . other) + `(defmacro ,name ,argl . ,other)) + diff --git a/src/libmax/displm.13 b/src/libmax/displm.13 new file mode 100755 index 00000000..13a8eb78 --- /dev/null +++ b/src/libmax/displm.13 @@ -0,0 +1,148 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module displm macro) + +(for-declarations + ;; evaluate for declarations + (SPECIAL + ^W ;If T, then no output goes to the console. + ^R ;If T, then output also goes to any + ;file opened by UWRITE. People learning + ;Lisp: there are better ways of doing IO + ;than this -- don't copy this scheme. + SMART-TTY ;LOADER sets this flag. If T, then + ;then this console can do cursor movement + ;and equations can be drawn in two dimensions. + RUBOUT-TTY ;If T, then console either selectively erasable + ;or is a glass tty. Characters can be rubbed + ;out in either case. + SCROLLP ;If T, then the console is scrolling. + ;This should almost always be equal to + ;(NOT SMART-TTY) except when somebody has + ;done :TCTYP SCROLL on a display console. + ;This is the %TSROL bit of the TTYSTS word. + + LINEL ;Width of screen. + TTYHEIGHT ;Height of screen. + + WIDTH HEIGHT DEPTH MAXHT MAXDP LEVEL SIZE LOP ROP BREAK RIGHT + BKPT BKPTWD BKPTHT BKPTDP BKPTLEVEL BKPTOUT LINES + OLDROW OLDCOL DISPLAY-FILE IN-P + MOREMSG MOREFLUSH MORE-^W MRATP $ALIASES ALIASLIST) + +(FIXNUM WIDTH HEIGHT DEPTH MAXHT MAXDP LEVEL SIZE RIGHT + BKPTWD BKPTHT BKPTDP BKPTLEVEL BKPTOUT + LINEL TTYHEIGHT OLDROW OLDCOL) + +(NOTYPE (TYO* FIXNUM) (SETCURSORPOS FIXNUM FIXNUM)) + +(*EXPR +TYO SETCURSORPOS MTERPRI FORCE-OUTPUT LINEAR-DISPLA + TTYINTSON TTYINTSOFF MORE-FUN GETOP + LBP RBP NFORMAT FULLSTRIP1 MAKSTRING $LISTP) + +;; stuff other packages might want to reference selectively. +(*expr displa dimension checkrat checkbreak) +;; looks like missplaced declarations to me. +;; does DISPLA really call $integrate? +(*lexpr $box $diff $expand $factor $integrate $multthru $ratsimp) +) + +;;; macros for the DISPLA package. + +(DEFMACRO TABLEN () #-(or Franz LISPM) (STATUS TABSIZE) #+(or Franz LISPM) 8) + +;; macros to handle systemic array differences. +;; NIL has various types of arrays, and supports *ARRAY in compatibility, +;; but might as well use the natural thing here, a vector. + +(DEFMACRO MAKE-LINEARRAY (SIZE) + #+LISPM `(MAKE-ARRAY ,SIZE ':TYPE 'ART-Q) + #+(or Maclisp Franz) `(*ARRAY NIL T ,SIZE) + #+NIL `(make-vector ,size) + ) + +(DEFMACRO SET-LINEARRAY (I X) + #+LISPM `(ASET ,X LINEARRAY ,I) + #+(or Maclisp Franz) `(STORE (ARRAYCALL T LINEARRAY ,I) ,X) + #+NIL `(VSET LINEARRAY ,I ,X) + ) + +(DEFMACRO LINEARRAY (J) + #+LISPM `(AREF LINEARRAY ,J) + #+(or Maclisp Franz) `(ARRAYCALL T LINEARRAY ,J) + #+NIL `(VREF LINEARRAY ,J) + ) + +(DEFMACRO LINEARRAY-DIM () + #+(OR LISPM MACLISP FRANZ) '(ARRAY-DIMENSION-N 1 LINEARRAY) + #+NIL '(VECTOR-LENGTH LINEARRAY)) + +(DEFMACRO CLEAR-LINEARRAY () + #+(OR LISPM MACLISP FRANZ) '(FILLARRAY LINEARRAY '(NIL)) + #+NIL '(DO ((J 0 (1+ J)) + (N (VECTOR-LENGTH LINEARRAY)) + (V LINEARRAY)) + ((= J N)) + (VSET V J ()))) + +;; (PUSH-STRING "foo" RESULT) --> (SETQ RESULT (APPEND '(#/o #/o #/f) RESULT)) +;; CHECK-ARG temporarily missing from Multics. + +(DEFMACRO PUSH-STRING (STRING SYMBOL) + #-(or Franz Multics) (CHECK-ARG STRING STRINGP "a string") + #-(or Franz Multics) (CHECK-ARG SYMBOL SYMBOLP "a symbol") + `(SETQ ,SYMBOL (APPEND ',(NREVERSE (EXPLODEN STRING)) ,SYMBOL))) + +;; Macros for setting up dispatch table. +;; Don't call this DEF-DISPLA, since it shouldn't be annotated by +;; TAGS and @. Syntax is: +;; (DISPLA-DEF [] [ | ] [] []) +;; If only one integer appears in the form, then it is taken to be an RBP. + +;; This should be modified to use GJC's dispatch scheme where the subr +;; object is placed directly on the symbol's property list and subrcall +;; is used when dispatching. + +(DEFMACRO DISPLA-DEF (OPERATOR DIM-FUNCTION &REST REST + &AUX L-DISSYM R-DISSYM LBP RBP) + (DOLIST (X REST) + (COND ((STRINGP X) + (IF L-DISSYM (SETQ R-DISSYM X) (SETQ L-DISSYM X))) + ((FIXP X) + (IF RBP (SETQ LBP RBP)) + (SETQ RBP X)) + (T (ERROR "Random object in DISPLA-DEF form" X)))) + (IF L-DISSYM + (SETQ L-DISSYM + (IF R-DISSYM + (CONS (EXPLODEN L-DISSYM) (EXPLODEN R-DISSYM)) + (EXPLODEN L-DISSYM)))) + `(PROGN 'COMPILE + (DEFPROP ,OPERATOR ,DIM-FUNCTION DIMENSION) + ,(IF L-DISSYM `(DEFPROP ,OPERATOR ,L-DISSYM DISSYM)) + ,(IF LBP `(DEFPROP ,OPERATOR ,LBP LBP)) + ,(IF RBP `(DEFPROP ,OPERATOR ,RBP RBP)))) + +;; Why must interrupts be turned off? Is there some problem with keeping +;; internal state consistent? If this is the case, then scheduling should be +;; inhibited on the Lispm as well. +;; Who's comment? It is obvious that there is this global array LINEARRAY, +;; which gets bashed during DISPLA. Seems like the best thing to do is +;; to use AREF and ASET on a special variable bound to an array pointer. +;; If a reentrant call to DISPLA is made, then just bind this variable +;; to a new array. -GJC +;; So it was written, so it shall be done, eventually. +;; Ah, got around to it... 9:32pm Wednesday, 2 December 1981 + +(DEFMACRO SAFE-PRINT (PRINT-FORM) + ;;`(WITHOUT-INTERRUPTS (LET ((^W T)) ,PRINT-FORM)) + ;; Still can't figure out what the ^W is bound for. - GJC + ;; Answer: SAFE-PRINT is used when the user types to + ;; --More Display?-- but has a WRITEFILE open. In that case, + ;; you want to write out to the file but not to the TTY. - JPG + #+PDP10 `(LET ((^W T)) ,PRINT-FORM) + #-PDP10 PRINT-FORM) + +(DEFMACRO LG-END-VECTOR (X Y) `(LG-DRAW-VECTOR ,X ,Y)) diff --git a/src/libmax/displm.14 b/src/libmax/displm.14 new file mode 100644 index 00000000..a87e6185 --- /dev/null +++ b/src/libmax/displm.14 @@ -0,0 +1,152 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module displm macro) + +(LOAD-MACSYMA-MACROS maxmac) + +(for-declarations + ;; evaluate for declarations + (SPECIAL + ^W ;If T, then no output goes to the console. + ^R ;If T, then output also goes to any + ;file opened by UWRITE. People learning + ;Lisp: there are better ways of doing IO + ;than this -- don't copy this scheme. + SMART-TTY ;LOADER sets this flag. If T, then + ;then this console can do cursor movement + ;and equations can be drawn in two dimensions. + RUBOUT-TTY ;If T, then console either selectively erasable + ;or is a glass tty. Characters can be rubbed + ;out in either case. + SCROLLP ;If T, then the console is scrolling. + ;This should almost always be equal to + ;(NOT SMART-TTY) except when somebody has + ;done :TCTYP SCROLL on a display console. + ;This is the %TSROL bit of the TTYSTS word. + + LINEL ;Width of screen. + TTYHEIGHT ;Height of screen. + + WIDTH HEIGHT DEPTH MAXHT MAXDP LEVEL SIZE LOP ROP BREAK RIGHT + BKPT BKPTWD BKPTHT BKPTDP BKPTLEVEL BKPTOUT LINES + OLDROW OLDCOL DISPLAY-FILE IN-P + MOREMSG MOREFLUSH MORE-^W MRATP $ALIASES ALIASLIST) + +(FIXNUM WIDTH HEIGHT DEPTH MAXHT MAXDP LEVEL SIZE RIGHT + BKPTWD BKPTHT BKPTDP BKPTLEVEL BKPTOUT + LINEL TTYHEIGHT OLDROW OLDCOL) + +(NOTYPE (TYO* FIXNUM) (SETCURSORPOS FIXNUM FIXNUM)) + +(*EXPR +TYO SETCURSORPOS MTERPRI FORCE-OUTPUT LINEAR-DISPLA + TTYINTSON TTYINTSOFF MORE-FUN GETOP + LBP RBP NFORMAT FULLSTRIP1 MAKSTRING $LISTP) + +;; stuff other packages might want to reference selectively. +(*expr displa dimension checkrat checkbreak) +;; looks like missplaced declarations to me. +;; does DISPLA really call $integrate? +(*lexpr $box $diff $expand $factor $integrate $multthru $ratsimp) +) + +;;; macros for the DISPLA package. + +(DEFMACRO TABLEN () #-(or Franz LISPM) (STATUS TABSIZE) #+(or Franz LISPM) 8) + +;; macros to handle systemic array differences. +;; NIL has various types of arrays, and supports *ARRAY in compatibility, +;; but might as well use the natural thing here, a vector. + +(DEFMACRO MAKE-LINEARRAY (SIZE) + #+LISPM `(MAKE-ARRAY ,SIZE ':TYPE 'ART-Q) + #+(or Maclisp Franz) `(*ARRAY NIL T ,SIZE) + #+NIL `(make-vector ,size) + ) + +(DEFMACRO SET-LINEARRAY (I X) + #+LISPM `(ASET ,X LINEARRAY ,I) + #+(or Maclisp Franz) `(STORE (ARRAYCALL T LINEARRAY ,I) ,X) + #+NIL `(VSET LINEARRAY ,I ,X) + ) + +(DEFMACRO LINEARRAY (J) + #+LISPM `(AREF LINEARRAY ,J) + #+(or Maclisp Franz) `(ARRAYCALL T LINEARRAY ,J) + #+NIL `(VREF LINEARRAY ,J) + ) + +(DEFMACRO LINEARRAY-DIM () + #+(OR LISPM MACLISP FRANZ) '(ARRAY-DIMENSION-N 1 LINEARRAY) + #+NIL '(VECTOR-LENGTH LINEARRAY)) + +(DEFMACRO CLEAR-LINEARRAY () + #+(OR LISPM MACLISP FRANZ) '(FILLARRAY LINEARRAY '(NIL)) + #+NIL '(DO ((J 0 (1+ J)) + (N (VECTOR-LENGTH LINEARRAY)) + (V LINEARRAY)) + ((= J N)) + (VSET V J ()))) + +;; (PUSH-STRING "foo" RESULT) --> (SETQ RESULT (APPEND '(#/o #/o #/f) RESULT)) +;; CHECK-ARG temporarily missing from Multics. + +(DEFMACRO PUSH-STRING (STRING SYMBOL) + #-(or Franz Multics) (CHECK-ARG STRING STRINGP "a string") + #-(or Franz Multics) (CHECK-ARG SYMBOL SYMBOLP "a symbol") + `(SETQ ,SYMBOL (APPEND ',(NREVERSE (EXPLODEN STRING)) ,SYMBOL))) + +;; Macros for setting up dispatch table. +;; Don't call this DEF-DISPLA, since it shouldn't be annotated by +;; TAGS and @. Syntax is: +;; (DISPLA-DEF [] [ | ] [] []) +;; If only one integer appears in the form, then it is taken to be an RBP. + +;; This should be modified to use GJC's dispatch scheme where the subr +;; object is placed directly on the symbol's property list and subrcall +;; is used when dispatching. + +(DEFMACRO DISPLA-DEF (OPERATOR DIM-FUNCTION &REST REST + &AUX L-DISSYM R-DISSYM LBP RBP) + (DOLIST (X REST) + (COND ((STRINGP X) + (IF L-DISSYM (SETQ R-DISSYM X) (SETQ L-DISSYM X))) + ((FIXP X) + (IF RBP (SETQ LBP RBP)) + (SETQ RBP X)) + (T (ERROR "Random object in DISPLA-DEF form" X)))) + (IF L-DISSYM + (SETQ L-DISSYM + (IF R-DISSYM + (CONS (EXPLODEN L-DISSYM) (EXPLODEN R-DISSYM)) + (EXPLODEN L-DISSYM)))) + `(PROGN 'COMPILE + (DEFPROP ,OPERATOR ,DIM-FUNCTION DIMENSION) + ,(IF L-DISSYM `(DEFPROP ,OPERATOR ,L-DISSYM DISSYM)) + ,(IF LBP `(DEFPROP ,OPERATOR ,LBP LBP)) + ,(IF RBP `(DEFPROP ,OPERATOR ,RBP RBP)))) + +;; Why must interrupts be turned off? Is there some problem with keeping +;; internal state consistent? If this is the case, then scheduling should be +;; inhibited on the Lispm as well. +;; Who's comment? It is obvious that there is this global array LINEARRAY, +;; which gets bashed during DISPLA. Seems like the best thing to do is +;; to use AREF and ASET on a special variable bound to an array pointer. +;; If a reentrant call to DISPLA is made, then just bind this variable +;; to a new array. -GJC +;; So it was written, so it shall be done, eventually. +;; Ah, got around to it... 9:32pm Wednesday, 2 December 1981 + +(DEFMACRO SAFE-PRINT (PRINT-FORM) + ;;`(WITHOUT-INTERRUPTS (LET ((^W T)) ,PRINT-FORM)) + ;; Still can't figure out what the ^W is bound for. - GJC + ;; Answer: SAFE-PRINT is used when the user types to + ;; --More Display?-- but has a WRITEFILE open. In that case, + ;; you want to write out to the file but not to the TTY. - JPG + #+PDP10 `(LET ((^W T)) ,PRINT-FORM) + #-PDP10 PRINT-FORM) + +(DEFMACRO LG-END-VECTOR (X Y) `(LG-DRAW-VECTOR ,X ,Y)) + + diff --git a/src/libmax/ermsgc.210 b/src/libmax/ermsgc.210 new file mode 100644 index 00000000..8f5a1964 --- /dev/null +++ b/src/libmax/ermsgc.210 @@ -0,0 +1,435 @@ +; -*- LISP -*- + +;;; Functions for MACSYMA error messages, macro-expansion-time stuff + +(macsyma-module ermsgc macro) + +(eval-when (compile eval) + (or (get 'IOTA 'VERSION) + (load "LIBLSP;IOTA")) + (or (get 'ERMSGX 'VERSION) + (load "LIBMAX;ERMSGX")) + ) + +(defstruct (message conc-name (constructor cons-a-message) list) + number + ;;Number of message in file + filepos + ;;Position of message in file + text) ;Body of message + +(declare (special file-number messages messages-initialized message-number + eval-munged-p fun-doc-alist var-doc-alist split-number + file-documentation chomphook toplevel-source-file + toplevel-source-file-author toplevel-source-file-date + string-file message-text-word-count onmls + eof-compile-queue eoc-eval ttynotes squid splitfile-hook)) + +(declare (ARRAY* (NOTYPE (err-file-array FIXNUM)))) + +(eval-when (eval compile) + (setq ibase 10. base 10.)) + +(cond ((not (boundp 'EOF-COMPILE-QUEUE)) ;Be sure it's really there + (setq EOF-COMPILE-QUEUE ()))) +(cond ((not (boundp 'EOC-EVAL)) + (setq EOC-EVAL nil))) +(cond ((not (boundp 'SPLITFILE-HOOK)) + (setq SPLITFILE-HOOK ()))) +(cond ((not (boundp 'CHOMPHOOK)) ;Be sure it's really there + (setq CHOMPHOOK nil))) + +(setq messages nil) ;No messages so far +(setq messages-initialized nil) ;Not initialized yet +(setq message-number 1) ;Messages are 1-origin +(setq eval-munged-p nil) ;We haven't yet output the eval-mungible + ;that we put at the end of the file +(setq fun-doc-alist nil) ;No function documentation yet +(setq var-doc-alist nil) ;No variable documentation yet +(setq file-documentation nil) ;No file documentation yet + +(declare (unspecial ARGS)) ;Not really special. Losing BREAK should + ;use something else + + +(defmacro increment-s (loc) + `(setf ,loc (1+ ,loc))) + + +;; USER-CALLED MACROS + +(defmacro MFERROR (handler format &REST data) + `(mferror1 ,handler (out-of-core-string ,format) ,@data)) + +(defmacro MCERROR (handler format &REST data) + `(mcerror1 ,handler (out-of-core-string ,format) ,@data))) + + +;; Self-Documentation stuff +;; (file-documentation "string") documents the file + +(defmacro file-documentation (string) + (if (memq compiler-state '(maklap compile)) + (setq file-documentation (create-message string))) + nil) + +(defvar *output-string-file-check* () + "Set T to output the string-filename before the next form") + +(defun collect-documents (form) + (if *output-string-file-check* + (let (( (*car . *cdr) form)) + (rplaca form 'progn) + (rplacd form `('compile (or (getl 'STRING-FILE-NAME '(EXPR FEXPR MACRO + SUBR LSUBR + FSUBR)) + (load '((MACSYM) ERMSGM))) + (string-file-name ',string-file) + (,*car . ,*cdr))) + (setq *output-string-file-check* () ))) + (cond ((atom form)) ;Huh? + ((memq (car form) '(DEFUN DEFMACRO DEFUN& MACRO DEFMFUN)) + (let (( ( () name vars doc . body) form)) + (cond ((and (symbolp doc) + body ;Not return value + (not (in-varlist doc vars))) + (if (not (atom name)) (setq name (car name))) + (push (cons name (create-message doc)) + fun-doc-alist))))) + ((memq (car form) '(DEFVAR DEFMVAR)) + (let (( ( () name () doc) form)) + (if doc + (push (cons name (create-message doc)) + var-doc-alist)))))) + +;; determine if a symbol is present in a DEFUN-style variable list as +;; a lambda-variable. + +(defun in-varlist (symbol vars) + (do ((vars vars (cdr vars)) + (opt-p)) + ((null vars) ()) + (if (eq symbol (car vars)) (return 't)) + (if (eq (car vars) '&optional) (setq opt-p 't)) + (if (not (atom (car vars))) + (if opt-p (if (or (eq symbol (caar vars)) + (eq symbol (caddar vars))) + (return 't)) + (if (in-pattern symbol vars) (return 't)))))) + +;; determine if a symbol is present in a pattern destructuring + +(defun in-pattern (symbol vars) + (if (atom vars) (eq symbol vars) + (or (in-pattern symbol (car vars)) + (in-pattern symbol (cdr vars))))) + +(push 'collect-documents chomphook) + +;; FIND-TOPLEVEL-SOURCE-FILE looks up the instack for the deepest-pushed +;; non-T input file. It setq's TOPLEVEL-SOURCE-FILE to the result. + +(defun find-toplevel-source-file () + (do ((files (reverse (cons infile instack)) (cdr files))) + ((null files) + (princ '|Can't find source file in instack -- ERMSGC| tyo) + (setq toplevel-source-file tyi)) + (if (filep (car files)) + (return + (prog1 (setq TOPLEVEL-SOURCE-FILE + (truename (car files))) + (setq TOPLEVEL-SOURCE-FILE-AUTHOR + (sixbit-to-ascii + (car (syscall 1 'RAUTH (car files))))) + (setq TOPLEVEL-SOURCE-FILE-DATE + (car (syscall 1 'RFDATE (car files))))))))) + +;; MAKE-STRING-FILE-NAME figures out what filename to use for an out-of-core +;; string file. + +(defun make-string-file-name () + (let (( ( () fn1 fn2) toplevel-source-file) + (BASE 10.) (*NOPOINT T) + (dir)) + (if (alphalessp fn1 'N) (setq dir 'MAXERR) + (setq dir 'MAXER1)) + (setq STRING-FILE `((DSK ,dir) ,fn1 ,fn2)) + (if (file-conflict-p string-file) + (do ((i 1 (1+ i)) + (efn2 (exploden fn2)) + (new-fn2)) + ((not (file-conflict-p string-file))) + (declare (fixnum i)) + (setq efn2 (nreverse efn2)) + (if (> (length efn2) + (- 5 (length (exploden i)))) + (rplacd (nthcdr (- 4 (length (exploden i))) efn2) () )) + (setq efn2 (nreverse efn2)) + (setq new-fn2 (append efn2 '(/!) (exploden i))) + (setq new-fn2 (maknam new-fn2)) + (setq string-file `((DSK ,dir) ,fn1 ,new-fn2)))) + string-file)) + +;; (FILE-CONFLICT-P filename) tests if the given string file conflicts +;; with the current source file (i.e. if it's for a different source file) + +(defun file-conflict-p (filename) + (if (probef filename) + (phi ((file (open-message-file filename))) + (or (not (equal toplevel-source-file + (cdr (or (assq 'filename (message-file-alist file)) + (assq 'source-file-name + (message-file-alist file)))))) + (not (equal toplevel-source-file-date + (cdr (assq 'source-file-creation-date + (message-file-alist file))))) + (not (eq (get 'ERMSGC 'VERSION) + (cdr (assq 'ERMSGC-VERSION (message-file-alist file))))) + )))) + + +;; INITIALIZE-MESSAGES finds the toplevel source file, looks up it's number +;; in the table, pushes a form onto EOC-EVAL to cause the database to be +;; written out. + +(defun initialize-messages () + (find-toplevel-source-file) + (make-string-file-name) + (format msgfiles "~&;initializing error messages.~%") + (push `(write-messages + '((SOURCE-FILE-NAME . ,toplevel-source-file) + (SOURCE-FILE-CREATION-DATE . ,toplevel-source-file-date) + (SOURCE-FILE-AUTHOR . ,toplevel-source-file-author) + (OUTPUT-FILE-NAME . ,(car ONMLS)))) + EOC-EVAL) + (push (subst () () + '(or (getl 'STRING-FILE-NAME '(EXPR FEXPR MACRO + SUBR LSUBR + FSUBR)) + (load '((MACSYM) ERMSGM)))) + EOF-COMPILE-QUEUE) + (push `(STRING-FILE-NAME ',STRING-FILE) EOF-COMPILE-QUEUE) + (push `(ERMSGC-SPLITFILE-HOOK ,STRING-FILE) SPLITFILE-HOOK) + (setq *output-string-file-check* T) + (setq messages nil) ;No messages so far + (setq message-number 1) ;Messages are 1-origin + (setq eval-munged-p nil) ;We haven't yet output the eval-mungible + ;that we put at the end of the file + (setq fun-doc-alist nil) ;No function documentation yet + (setq var-doc-alist nil) ;No variable documentation yet + (setq file-documentation nil) ;No file documentation yet + (setq messages-initialized t)) ;So we can avoid doing it the next time + + +(defmacro ermsgc-splitfile-hook (file) + (push `(ERMSGC-SPLITFILE-HOOK ,file) SPLITFILE-HOOK) + `(STRING-FILE-NAME ',file)) + +;; The following is an SFA handler for writing ascii to a fixnum file +;; It's fairly standard in its operation. + +;; First, some macros for the slots in the SFA + +(defmacro fixnum-ascii-fileobj (stream) + `(sfa-get ,stream 0)) + +(defmacro fixnum-ascii-accumulator (stream) + `(sfa-get ,stream 1)) + +(defmacro fixnum-ascii-charcnt (stream) + `(sfa-get ,stream 2)) + +(defun fixnum-ascii-stream-handler (self operation data) + (caseq operation + (WHICH-OPERATIONS '(OUT TYO FILEPOS FORCE-OUTPUT CLOSE + OPEN-FILE TRUENAME RENAMEF)) + (OPEN-FILE (setf (fixnum-ascii-fileobj self) + (open data '(fixnum out))) + (setf (fixnum-ascii-accumulator self) 0) + (setf (fixnum-ascii-charcnt self) 0) + self) + (TRUENAME (truename (fixnum-ascii-fileobj self))) + (RENAMEF (sfa-call self 'FORCE-OUTPUT nil) + (renamef (fixnum-ascii-fileobj self) data)) + (FORCE-OUTPUT + (cond ((not (zerop (fixnum-ascii-charcnt self))) + (out (fixnum-ascii-fileobj self) + (fixnum-ascii-accumulator self)) + (increment-s message-text-word-count) + (setf (fixnum-ascii-charcnt self) 0) + (setf (fixnum-ascii-accumulator self) 0) + nil))) + (FILEPOS + (cond ((null data) (filepos (fixnum-ascii-fileobj self))) + (T (sfa-call self 'FORCE-OUTPUT nil) + (filepos (fixnum-ascii-fileobj self) (car data))))) + (TYO + (cond ((minusp data)) + (T (setf (fixnum-ascii-accumulator self) + (+ (fixnum-ascii-accumulator self) + (lsh data (1+ (* (- 4 (fixnum-ascii-charcnt self)) + 7))))) + (cond ((= (fixnum-ascii-charcnt self) 4) + (force-output self)) + (T (increment-s (fixnum-ascii-charcnt self)))))) + T) + (OUT (sfa-call self 'FORCE-OUTPUT nil) + (out (fixnum-ascii-fileobj self) data)) + (CLOSE (sfa-call self 'FORCE-OUTPUT nil) + (close (fixnum-ascii-fileobj self))) + (T (error '|Unknown operation for fixnum-ascii stream| + operation 'wrng-type-arg)))) + +;; The following creates an SFA which writes ascii or binary to the file with +;; name supplied as an argument. + +(defun make-fixnum-ascii-stream (filename) + (sfa-call (sfa-create 'fixnum-ascii-stream-handler 3 'temp-stream) + 'open-file filename)) + +;; Create a new message, and return its code number + +(defmacro out-of-core-string (string) + (if (memq compiler-state '(maklap compile)) + (message-squid string) + string)) + +;;; MESSAGE-SQUID takes a string, and returns a SQUID form to access it as +;;; an out-of-core string + +(defun message-squid (format) + (if (not messages-initialized) (initialize-messages)) + `(,squid (allocate-message-index ',STRING-FILE ,(create-message format)))) + +;;; CREATE-MESSAGE causes an out-of-core string to exist, and returns +;;; it's message-number in the file + +(defun create-message (format) + (if (not messages-initialized) (initialize-messages)) + (push (cons-a-message TEXT format + NUMBER message-number) + messages) + (prog1 message-number + (setq message-number (1+ message-number)))) + +;; Write out all the messages to the specified filename + +(defun write-messages (file-info) + (cond ((not eval-munged-p) ;Can be called more than once + (setq messages + (sort (append messages nil) + #'(lambda (x y) + (< (message-number x) + (message-number y))))) + (phi ((out-stream + (make-fixnum-ascii-stream + (mergef '(_ERMSG OUTPUT) string-file)))) + (do ((n (1+ (length messages)) (1- n))) + ((zerop n)) + (declare (fixnum n)) + (out out-stream #.(car (pnget 'EMPTY 7)))) + (setq message-text-word-count 0) + (mapc #'(lambda (message) + (write-message message out-stream)) + messages) + (let ((old-filepos (filepos out-stream)) ;Output miscellaneous + (BASE 10.) (*NOPOINT () )) ;random info + (print `(MDOC (date . ,(status date)) + (time . ,(status daytim)) ;in ALIST format + (creator . ,(status uname)) + (message-count ,(length messages)) + (message-text-word-count . + ,message-text-word-count) + (ERMSGC-VERSION . ,(get 'ERMSGC 'VERSION)) + ,@file-info + (file-doc-index . ,file-documentation) + (var-doc-alist . ,var-doc-alist) + (fun-doc-alist . ,fun-doc-alist)) + out-stream) + (filepos out-stream 0) ;Record where it all went + (out out-stream old-filepos)) + + (mapc #'(lambda (message) ;And do the same for the messages + (out out-stream (message-filepos message))) + messages) + + (renamef out-stream (cdr (namelist string-file))) + + (if ttynotes + (format tyo "~&;Error file ~S written.~%" + (namestring (truename out-stream)))) + (setq eval-munged-p T)))) + (setq messages-initialized ())) + +;; The function WRITE-MESSAGE writes a message to the message file. +;; It also records the FILEPOS in the object + +(defun write-message (message out-stream) + (setf (message-filepos message) (filepos out-stream)) + (let ((text (message-text message))) + (cond ((atom text) (princ text out-stream)) + (T (mapc #'(lambda (x) + (princ x out-stream)) + text))) + (force-output out-stream) + (out out-stream 0))) ;mark the end + + +;; Take a fixnum of sixbit and produce a symbol with the appropriate PNAME + +(defun sixbit-to-ascii (number) + (do ((number number (lsh number 6)) + (characters nil)) + ((zerop number) (implode (nreverse characters))) + (push (+ (lsh (boole 1 number #.(LSH #o77 30.)) -30.) #o40) + characters))) + +(defvar consable-number 259259.) ;A number big enough to be consed + +; OPEN-MESSAGE-FILE returns a stream which supports TYI, FILEPOS, and CLOSE. +; The TYI returns -1 to mark the end of the string. + +(defun open-message-file (filename) + (let* ((namelist (mergef '((DNRF *) * *) filename)) + (message-file + (open (mergef namelist + (if (alphalessp (cadr namelist) 'N) "DSK:MAXERR;* >" + '"DSK:MAXER1;* >")) + '(IN FIXNUM))) + (sfa (sfa-create 'message-file-handler #.message-file-size + (namestring (truename message-file)))) + (IBASE 10.)) + (filepos message-file (in message-file)) ;Position to read dir + (setf (message-file-file sfa) message-file) + (setf (message-file-charno sfa) 5) + (setf (message-file-buffer-pointer sfa) (+ consable-number 1)) + (setf (message-file-alist sfa) (cdr (read sfa))) + (setf (message-file-header-count sfa) + (1+ (cadr (assq 'message-count (message-file-alist sfa))))) + (filepos message-file 0) + sfa)) + + +; MESSAGE-FILE-HANDLER supports TYI, IN, FILEPOS, TRUENAME, and CLOSE. + +(defun message-file-handler (self operation data) + (caseq operation + (WHICH-OPERATIONS '(TYI FILEPOS OPEN CLOSE IN TRUENAME)) + (TYI (if (= (message-file-charno self) 5) + (progn (setf (message-file-buffer self) + (in (message-file-file self))) + (setf (message-file-charno self) 1)) + (setf (message-file-charno self) + (1+ (message-file-charno self)))) + (logand #o177 + (lsh (message-file-buffer self) + (+ -36. (* 7 (message-file-charno self)))))) + (IN (in (message-file-file self))) + (FILEPOS + (if (null data) (filepos (message-file-file self)) + (filepos (message-file-file self) (car data)))) + (TRUENAME (truename (message-file-file self))) + (CLOSE (close (message-file-file self))) + (OPEN (open (message-file-file self))))) + + \ No newline at end of file diff --git a/src/libmax/ermsgx.5 b/src/libmax/ermsgx.5 new file mode 100644 index 00000000..4384d68b --- /dev/null +++ b/src/libmax/ermsgx.5 @@ -0,0 +1,46 @@ +;-*-LISP-*- + +;This file contains support macros for the STRMRG package. + +(macsyma-module ERMSGX macro) + +(eval-when (eval compile) + (or (get 'defsetf 'version) + (load '((LISP) defsetf)))) + +;; The fixnum which is stored into for buffering the whole-words we get +;; back from IN. This fixnum is DEPOSITed into. + +(defmacro message-file-buffer-pointer (message-file) + `(sfa-get ,message-file 0)) + +(defmacro message-file-buffer (message-file) + `(EXAMINE (MAKNUM (message-file-buffer-pointer ,message-file)))) + +;; The file array from which to read. Should be open in FIXNUM IN mode. + +(defmacro message-file-file (message-file) + `(sfa-get ,message-file 1)) + +;; The next character out of the fixnum which should be read in response to +;; TYI. Counted down from the left. When zero, a new word must be read first. + +(defmacro message-file-charno (message-file) + `(sfa-get ,message-file 2)) + +(defmacro message-file-header-count (message-file) + `(sfa-get ,message-file 3)) + +(defmacro message-file-header-offset (message-file) + `(sfa-get ,message-file 4)) + +(defmacro message-file-text-offset (message-file) + `(sfa-get ,message-file 5)) + +(defmacro message-file-alist (message-file) + `(sfa-get ,message-file 6)) + +(defvar message-file-size 7) + +(defsetf examine ((() loc) val) () + `(deposit ,loc ,val)) diff --git a/src/libmax/gprelu.22 b/src/libmax/gprelu.22 new file mode 100755 index 00000000..35173a69 --- /dev/null +++ b/src/libmax/gprelu.22 @@ -0,0 +1,86 @@ +;; -*- Mode: Lisp -*- + +;; This file is to be included by various randoms who want the the more winning +;; lisp-machine like lisp environment provided by LIBMAX;PRELUD, but who don't +;; want the other completely random things which are part of the macsyma +;; compilation environment. +;; 6:15pm Thursday, 5 January 1980 -GJC + +;; This file loads a part of the Macsyma compile-time environment. These +;; packages will be loaded when the source file is either compiled or +;; interpreted. They are not loaded by compiled code. For more information, +;; see LIBMAX;-READ- -THIS- and MAXDOC;LIBMAX >. + +(EVAL-WHEN + (EVAL COMPILE) + (OR (GET 'UMLMAC 'VERSION) (LOAD "LISP;UMLMAC")) + (OR (GET 'LMMAC 'VERSION) (LOAD "LIBMAX;LMMAC")) + (or (get 'mlmac 'version) (load '((lisp)mlmac))) + (or (get 'maxmac 'version) (load '((libmax)maxmac))) + (PUTPROP 'META-EVAL '((DSK LIBMAX)META) 'AUTOLOAD) + + (DEFMACRO AUTOLOAD-MACROS (FILE &REST MACROS) + `(PROGN (MAPC '(LAMBDA (U)(PUTPROP U ',FILE 'AUTOLOAD)) + ',MACROS) + (COND (COMPILER-STATE + (MAPC '(LAMBDA + (U) + (OR (GET U 'MACRO) + (PUTPROP U + '(LAMBDA (FORM) + (LOAD (GET (CAR FORM) + 'AUTOLOAD)) + FORM) + 'MACRO))) + ',MACROS))))) + (AUTOLOAD-MACROS ((LIBLSP)STRUCT) DEFSTRUCT) + (AUTOLOAD-MACROS ((LIBLSP)LOOP) LOOP) + (AUTOLOAD-MACROS ((LIBMAX)PROCS) + DEF-PROCEDURE-PROPERTY + CALL-PROCEDURE-PROPERTY) + (AUTOLOAD-MACROS ((LIBMAX)CLOSE) DEFCLOSURE CALL) + (AUTOLOAD-MACROS ((LIBMAX)OPSHIN) DEF-OPTIONS) + (AUTOLOAD-MACROS ((LIBMAX)READM) |DEF#\SYMBOL|) + (DEFPROP PARSE-OPTION-HEADER ((LIBMAX)OPSHIN) AUTOLOAD) + (SETQ MACRO-FILES '(UMLMAC LMMAC mlmac))) + + +;; Print macro versions in the unfasl file. + +(EVAL-WHEN (COMPILE) + (LET ((UNFASL (IF (EQ (CAAR (NAMELIST (CAR CMSGFILES))) 'DSK) + (CAR CMSGFILES) + (CADR CMSGFILES)))) + (FORMAT UNFASL "~%;; Compilation by ~A~%" + (STATUS UNAME)) + (FORMAT UNFASL ";; ~15A~A~%" + "Prelude file:" + (LET ((X (TRUENAME INFILE))) + (NAMESTRING (CONS (CDAR X) (CDR X))))) + (FORMAT UNFASL ";; ~15A" "Macro files:") + (FORMAT UNFASL "~{~<~%;; ~15X~:;~A ~A~>~^, ~}~%" + (MAPCAN #'(LAMBDA (X) `(,X ,(GET X 'VERSION))) + MACRO-FILES) + ))) + +;; Make DEFUN retain useful debugging information about the format +;; of the bound variable list. + +(DECLARE (SETQ DEFUN&-CHECK-ARGS T)) + +;; Place macros in fasl file, and include code for displacing within +;; the interpreter. + +(DECLARE (SETQ DEFMACRO-FOR-COMPILING T) + (SETQ DEFMACRO-DISPLACE-CALL T) + (MACROS T)) + +(EVAL-WHEN (EVAL LOAD COMPILE) + ; make sure DEFSTRUCT is always around + (mapc '(lambda (x) + (putprop x '((liblsp)struct) 'autoload)) + '(defstruct + defstruct-cons defstruct-ref + defstruct-expand-ref-macro defstruct-expand-cons-macro + defstruct-expand-alter-macro + defstruct-get-property defstruct-put-property))) \ No newline at end of file diff --git a/src/libmax/lmmac.87 b/src/libmax/lmmac.87 new file mode 100644 index 00000000..aae459ec --- /dev/null +++ b/src/libmax/lmmac.87 @@ -0,0 +1,284 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module lmmac macro) + +;; Lisp Machine compatibility package -- macros + +;; This file contains the compile time end of the Lisp Machine compatibility +;; package in LIBMAX. The macros defined here correspond to macros also +;; defined on the Lisp Machine and and for use in simulating string processing +;; by manipulating symbols. + +;; *** Currently, this file is used only on the PDP10 and in Franz. +;; *** NIL, LMLisp, and the extensions to Multics MacLisp define most +;; *** of these routines. + +;; This macro makes an attempt at turning FERROR into something reasonably +;; understandable by the maclisp error system. There are two possible +;; translations, depending upon the setting of LMMAC-FERROR-USE. The Lisp +;; Machine condition names are used. + +;; 1) If T, turn into (ERROR (FORMAT NIL ...) ...). That is, FORMAT will be +;; called to construct the message string, which is then passed to the +;; condition handler. This allows the use of the standard condition handlers, +;; but causes extra string-consing, and doesn't allow other condition handlers +;; to recieve the error information in a structured form. + +;; 2) If NIL, turn into (ERROR 'FORMAT (LIST ...) ...). Condition handlers +;; are to look for this control string specifically in order to distinguish +;; between errors signalled by ERROR and those by FERROR. It is the job of the +;; error handler to watch for this symbol and call FORMAT. + +(DEFVAR LMMAC-FERROR-USE T) + +;; This switch has three settings. Perhaps another setting for +;; looking at the *RSET flag is needed. + +;; T -- Always include argument checking code. +;; NIL -- Never include argument checking code. +;; EVAL -- Only include argument checking code when being interpreted. +;; Compiled code does not check arguments. + +(DEFVAR LMMAC-CHECK-ARG-USE 'EVAL) + +(EVAL-WHEN (EVAL) +(DEFMACRO CHECK-ARG (VAR-NAME PREDICATE DESCRIPTION) + (IF (ATOM PREDICATE) + (SETQ PREDICATE `(,PREDICATE ,VAR-NAME))) + (WHEN (OR (EQ LMMAC-CHECK-ARG-USE T) + (AND (EQ LMMAC-CHECK-ARG-USE 'EVAL) (NOT COMPILER-STATE))) + `(UNLESS ,PREDICATE + (FERROR ':WRONG-TYPE-ARGUMENT + "The argument ~S was ~S, when expected ~A." + ',VAR-NAME ,VAR-NAME ,DESCRIPTION)))) +) + + +;; Assorted macros. Some of these correspond to subrs on the Lisp Machine, +;; so be careful about applying. + +(DEFMACRO FIRST (FORM) `(CAR ,FORM)) +(DEFMACRO SECOND (FORM) `(CADR ,FORM)) +(DEFMACRO THIRD (FORM) `(CADDR ,FORM)) +(DEFMACRO FOURTH (FORM) `(CADDDR ,FORM)) +(DEFMACRO FIFTH (FORM) `(CAR (CDDDDR ,FORM))) +(DEFMACRO SIXTH (FORM) `(CADR (CDDDDR ,FORM))) +(DEFMACRO SEVENTH (FORM) `(CADDR (CDDDDR ,FORM))) + +(DEFMACRO REST1 (FORM) `(CDR ,FORM)) +(DEFMACRO REST2 (FORM) `(CDDR ,FORM)) +(DEFMACRO REST3 (FORM) `(CDDDR ,FORM)) +(DEFMACRO REST4 (FORM) `(CDDDDR ,FORM)) + + +(DEFMACRO / (ARG1 ARG2 &REST REST) `(<= ,ARG1 ,ARG2 . ,REST)) +(DEFMACRO / (ARG1 ARG2 &REST REST) `(>= ,ARG1 ,ARG2 . ,REST)) + +(DEFMACRO NEQ ARGS `(NOT (EQ . ,ARGS))) +(DEFMACRO / ARGS `(NOT (= . ,ARGS))) + +#+Franz +(DEFMACRO MAKE-LIST (NUM) + `(LOOP FOR I FROM 1 TO ,NUM COLLECT ())) + +;; Array stuff + +(DEFMACRO AREF (ARRAY . INDICES) + `(ARRAYCALL T ,ARRAY . ,INDICES)) + +(DEFMACRO ASET (OBJECT ARRAY . INDICES) + `(STORE (ARRAYCALL T ,ARRAY . ,INDICES) ,OBJECT)) + +(DEFMACRO MAKE-ARRAY (DIMENSION) + `(*ARRAY NIL T ,DIMENSION)) + +#+Franz +(DEFSETF AREF (EXPR VALUE) + `(STORE (ARRAYCALL T ,@(CDR EXPR)) ,VALUE)) + + +;; New control constructs + +;; (EVERY '(3 3.4 46) #'NUMBERP) --> T +;; (SOME '(A B 3) #'SYMBOLP) --> T +;; (EVERY '(3 A 4 B) #'NUMBERP CDDR) --> T + +;; Probably better named "EVERY-OF" and "SOME-OF". Then we could have +;; "FIRST-OF" for finding the first in a list satisfying the predicate. + +;; I believe the way the step argument is handled here is compatible +;; with the Lisp Machine, but should probably be changed to allow functions +;; which are specified at runtime. + +(DEFMACRO EVERY (LIST PRED &OPTIONAL (STEP 'CDR) &AUX (VAR (GENSYM))) + ;; Arguments are frequently reversed. + (IF (AND (NOT (ATOM LIST)) (EQ (CAR LIST) 'FUNCTION)) + (ERROR "First argument to EVERY must be a list" LIST 'WRNG-TYPE-ARG)) + `(DO ((,VAR ,LIST (,STEP ,VAR))) + ((NULL ,VAR) T) + (OR (FUNCALL ,PRED (CAR ,VAR)) (RETURN NIL)))) + +(DEFMACRO SOME (LIST PRED &OPTIONAL (STEP 'CDR) &AUX (VAR (GENSYM))) + ;; Arguments are frequently reversed. + (IF (AND (NOT (ATOM LIST)) (EQ (CAR LIST) 'FUNCTION)) + (ERROR "First argument to EVERY must be a list" LIST 'WRNG-TYPE-ARG)) + `(DO ((,VAR ,LIST (,STEP ,VAR))) + ((NULL ,VAR) NIL) + (AND (FUNCALL ,PRED (CAR ,VAR)) (RETURN T)))) + + +;; Function cell macros + +#+PDP10 (PROGN 'COMPILE + +;; FBOUNDP defined in LSPSRC;UMLMAC. FSET defined in MAXSRC;UTILS. + +;; Is this the right thing? +(DEFMACRO FSYMEVAL (SYMBOL) + `(LET ((X (GETL ,SYMBOL '(SUBR LSUBR FSUBR EXPR FEXPR ARRAY MACRO)))) + (IF (EQ (CAR X) 'MACRO) + (CONS 'MACRO (CADR X)) + (CADR X)))) + +(DEFMACRO FMAKUNBOUND (SYMBOL) + `(PROGN (REMPROP ,SYMBOL 'EXPR) + (REMPROP ,SYMBOL 'FEXPR) + (REMPROP ,SYMBOL 'SUBR) + (REMPROP ,SYMBOL 'LSUBR) + (REMPROP ,SYMBOL 'FSUBR) + (REMPROP ,SYMBOL 'EXPR) + (REMPROP ,SYMBOL 'MACRO))) + +) ;; End of #+PDP10 Function cell definitions + +#+Franz (PROGN 'COMPILE + +(DEFMACRO FBOUNDP (SYMBOL) `(GETD ,SYMBOL)) + +(DEFMACRO FSET (SYMBOL DEFINITION) + `(PUTD ,SYMBOL ,DEFINITION)) + +(DEFMACRO FSYMEVAL (SYMBOL) `(GETD ,SYMBOL)) + +(DEFMACRO FMAKUNBOUND (SYMBOL) `(PUTD ,SYMBOL NIL)) + +) ;; End of #+Franz Function cell definitions + + +;; String hacking functions. + +;; Since ITS currently lacks strings, define string functions to manipulate +;; pseudo-strings -- uninterned symbols which are self-bound. Many of these +;; functions are defined in LIBMAX;LMRUN, since there is too much code to make +;; macros practical. + +;; Takes a newly created symbol which is to become our new pseudo string +;; and sets it to itself. +#-Franz +(DEFMACRO MAKE-STRING-FROM-SYMBOL (SYMBOL) + `(LET ((SYMBOL ,SYMBOL)) + (SET SYMBOL SYMBOL))) + +#+Franz +(defmacro make-string-from-symbol (symbol) `(get_pname ,symbol)) + +;; Takes a list of characters and produces a string from it. + +(DEFMACRO MAKE-STRING-FROM-CHARS (CHARS) + `(MAKE-STRING-FROM-SYMBOL (MAKNAM ,CHARS))) + +;; These should be functions. Either that or fix them to use DEFOPEN or +;; ONCE-ONLY. + +;; Remove this next when MACSYMA gets into a modern LISP + +#+PDP10 +(or (getl 'array-dimension-n '(expr subr macro)) + (defun array-dimension-n (idx ary) + (nth idx (arraydims ary)))) + +#+Franz +(defmacro array-dimension-n (idx ary) + (let ((access (cond ((eq idx 1) 'cadr) ; simple cases + ((eq idx 2) 'caddr)))) + (cond (access `(,access (arraydims ,ary))) + (t `(nth ,idx (arraydims ,ary)))))) + + +;; Format of a PDP10 MacLisp obarray: +;; Low 511. cells are lists of symbols. +;; Cell 511. is unused. +;; Upper 128. cells contain single character objects, one object per cell. +;; A single character object appears both in the low 511 cells and in the +;; high 128. cells. + +;; While the following is cretinous, it isn't Carl's fault. If LISP changes +;; again, this will have to be changed. What it really means is: +;; (DEFMACRO INTERNEDP (SYMBOL) +;; `(MEMQ ,SYMBOL +;; (AREF OBARRAY (\ (SXHASH ,SYMBOL) +;; #,(GETDDTSYM 'OBTSIZ))))) +;; OBTSIZ is the amount of the obarray which contains buckets. +;; --RWK + +#+PDP10 +(DEFMACRO INTERNEDP (SYMBOL) + `(MEMQ ,SYMBOL (AREF OBARRAY (\ (SXHASH ,SYMBOL) #o777)))) + +;; Still need T/NIL check? + +#-Franz +(DEFMACRO STRINGP (STRING) + `(AND (SYMBOLP ,STRING) + (BOUNDP ,STRING) + (NOT (MEMQ ,STRING '(T NIL))) + (EQ ,STRING (SYMEVAL ,STRING)) + ;; Until they write INTERNEDP or get real strings. + (NOT (INTERNEDP ,STRING)) + )) + +(DEFMACRO STRING-LENGTH (STRING) `(FLATC ,STRING)) + +(DEFMACRO STRING-EQUAL STRINGS `(SAMEPNAMEP . ,STRINGS)) + +(DEFMACRO READ-FROM-STRING (STRING) `(READLIST (EXPLODEN ,STRING))) + +(DEFMACRO STRING-UPCASE (STRING) + `(MAKE-STRING-FROM-CHARS (MAPCAR #'CHAR-UPCASE (EXPLODEN ,STRING)))) + +(DEFMACRO STRING-DOWNCASE (STRING) + `(MAKE-STRING-FROM-CHARS (MAPCAR #'CHAR-DOWNCASE (EXPLODEN ,STRING)))) + +(DEFMACRO STRING-REVERSE (STRING) + `(MAKE-STRING-FROM-CHARS (NREVERSE (EXPLODEN ,STRING)))) + +(DEFMACRO STRING-NREVERSE (STRING) + `(STRING-REVERSE ,STRING)) + +;; MAKE-SYMBOL returns an uninterned symbol. Lisp Machine arglist is +;; (MAKE-SYMBOL pname &optional value definition plist package). Add this +;; later if needed. COPYSYMBOL creates a new symbol with the same print-name. +;; If second arg is t, then the property list is also copied. + +;; (DEFUN MAKE-SYMBOL (STRING) +;; (CHECK-ARG STRING STRINGP "a string") +;; (COPYSYMBOL STRING NIL)) + +(DEFMACRO MAKE-SYMBOL (STRING) + `(COPYSYMBOL ,STRING NIL)) + +;; (DEFUN GET-PNAME (SYMBOL) +;; (CHECK-ARG SYMBOL SYMBOLP "a symbol") +;; (MAKE-STRING-FROM-SYMBOL (COPYSYMBOL SYMBOL NIL))) + +(DEFMACRO GET-PNAME (SYMBOL) + `(MAKE-STRING-FROM-SYMBOL (COPYSYMBOL ,SYMBOL NIL))) + +;; Add multiple-value-list and multiple-value-bind to this. +;; Add new Lispm VALUES construct. +;; Add read-eval-print loop to LIBMAX;MDEBUG which prints all +;; values returned when function is called from top level. + + diff --git a/src/libmax/lmrun.43 b/src/libmax/lmrun.43 new file mode 100755 index 00000000..b14ab2db --- /dev/null +++ b/src/libmax/lmrun.43 @@ -0,0 +1,324 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module lmrun macro) + +;; Lisp Machine compatibility package -- runtime + +;; This file contains the run time end of the Lisp Machine compatibility +;; package in LIBMAX. Many of the functions defined here are for use in +;; simulating string processing manipulating symbols. The declarations for the +;; functions and globals defined here exist in LMRUND. + +;; *** Currently, this file is used only on the PDP10 and in Franz. +;; *** NIL, LMLisp, and the extensions to Multics MacLisp define most +;; *** of these routines. It is not used in Macsyma proper, but is +;; *** used by the display editor and other extensions. + +(load-macsyma-macros lmrund) + +;; List hacking functions. + +(DEFUN BUTLAST (LIST) + (CHECK-ARG LIST (OR (NULL LIST) (NOT (ATOM LIST))) "a list") + (COND ((NULL LIST) NIL) + (T (DO ((LIST LIST (CDR LIST)) + (NEW-LIST NIL (CONS (CAR LIST) NEW-LIST))) + ((NULL (CDR LIST)) (NREVERSE NEW-LIST)))))) + +(DEFUN NBUTLAST (LIST) + (CHECK-ARG LIST (OR (NULL LIST) (NOT (ATOM LIST))) "a list") + (COND ((NULL LIST) NIL) + (T (DO ((LIST LIST (CDR LIST))) + ((NULL (CDDR LIST)) (RPLACD LIST NIL))) + LIST))) + +(DEFUN FIRSTN (N LIST) + (DECLARE (FIXNUM N)) + (CHECK-ARG N (AND (FIXP N) (>= N 0)) "a non-negative integer") + (CHECK-ARG LIST (OR (NULL LIST) (NOT (ATOM LIST))) "a list") + (DO ((OLD-LIST LIST (CDR OLD-LIST)) + (NEW-LIST NIL (CONS (CAR OLD-LIST) NEW-LIST)) + (COUNT N (1- COUNT))) + ((OR (ZEROP COUNT) (NULL OLD-LIST)) (NREVERSE NEW-LIST)))) + +;; MEM works like MEMQ and MEMBER except that it can take an arbitrary +;; comparison predicate, i.e. (MEM 'EQ 3 LIST) = (MEMQ 3 LIST). + +(DEFUN MEM (PREDICATE ELEMENT LIST) + (CHECK-ARG LIST (OR (NULL LIST) (NOT (ATOM LIST))) "a list") + (DO ((LIST LIST (CDR LIST))) + ((NULL LIST) NIL) + (IF (FUNCALL PREDICATE ELEMENT (CAR LIST)) (RETURN T)))) + +;; FIND-POSITION-IN-LIST looks down LIST for an element which is eq to OBJECT, +;; like MEMQ. It reutrns the numeric index in the list at which it found the +;; first occurrence of OBJECT, or nil if it did not find it at all. +;; (find-position-in-list 'a '(a b c)) --> 0 +;; (find-position-in-list 'e '(a b c)) --> nil + +(DEFUN FIND-POSITION-IN-LIST (OBJECT LIST) + (CHECK-ARG LIST (OR (NULL LIST) (NOT (ATOM LIST))) "a list") + (DO ((L LIST (CDR L)) + (I 0 (1+ I))) + ((NULL L) NIL) + (DECLARE (FIXNUM I)) + (IF (EQ OBJECT (CAR L)) (RETURN I)))) + +;; Generalized ASSOC -- first argument is a comparison predicate which +;; is used instead of EQUAL. + +(DEFUN ASS (PREDICATE ITEM ALIST) + (CHECK-ARG ALIST (OR (NULL ALIST) (NOT (ATOM ALIST))) + "an association list") + (DOLIST (PAIR ALIST) + (IF (FUNCALL PREDICATE ITEM (CAR PAIR)) (RETURN PAIR)))) + +;; Reverse ASSQ -- like ASSQ but tries to find an element of the alist whose +;; cdr (not car) is EQ to the object. + +(DEFUN RASSQ (ITEM ALIST) + (CHECK-ARG ALIST (OR (NULL ALIST) (NOT (ATOM ALIST))) + "an association list") + (DOLIST (PAIR ALIST) + (IF (EQ ITEM (CDR PAIR)) (RETURN PAIR)))) + +;; Reverse ASSOC -- like ASSOC but tries to find an element of the alist +;; whose cdr (not car) is EQUAL to the object. + +(DEFUN RASSOC (ITEM ALIST) + (CHECK-ARG ALIST (OR (NULL ALIST) (NOT (ATOM ALIST))) + "an association list") + (DOLIST (PAIR ALIST) + (IF (EQUAL ITEM (CDR PAIR)) (RETURN PAIR))))) + + +;; Character and string manipulating functions. The associated macros are in +;; LIBMAX;LMMAC. Together, these two files implement a subset +;; of the Lisp Machine string primitives. + +;; Convert X into a character. + +(DEFUN CHARACTER (X) + (CASEQ (TYPEP X) + (FIXNUM X) + (SYMBOL (GETCHARN X 1)) + (T (FERROR ':WRONG-TYPE-ARGUMENT + "Cannot be coerced to a character -- ~S" X)))) + +;; Compare two characters ignoring case. These have to be macros +;; rather than subrs since they are often applied. + +(DEFUN CHAR-EQUAL (C1 C2) + (DECLARE (FIXNUM C1 C2)) + (= (CHAR-UPCASE C1) (CHAR-UPCASE C2))) + +(DEFUN CHAR-LESSP (C1 C2) + (DECLARE (FIXNUM C1 C2)) + (< (CHAR-UPCASE C1) (CHAR-UPCASE C2))) + +(DEFUN CHAR-UPCASE (C) + (DECLARE (FIXNUM C)) + (IF (<= #/a C #/z) (BIT-CLEAR #O 40 C) C)) + +(DEFUN CHAR-DOWNCASE (C) + (DECLARE (FIXNUM C)) + (IF (<= #/A C #/Z) (BIT-SET #O 40 C) C)) + +;; Should say (ASCII (LOGAND OBJECT #o 377)), but the ascii function only +;; looks at low order 8 bits anyway. + +(DEFUN STRING (X) + (CASEQ (TYPEP X) + (SYMBOL (GET-PNAME X)) + (FIXNUM (GET-PNAME (ASCII X))) + (T (FERROR ':WRONG-TYPE-ARGUMENT + "Cannot be coerced to a string -- ~S" X)))) + +;; The referencing mechanism for strings is zero based, i.e. the zeroth +;; character refers to the first one and the n-1 th character is the last if +;; the string is n characters long. The second argument is the initial +;; position from which to start building the substring, which continues up to +;; but not including the character specified by the third argument. If the +;; third argument is not present, it defaults to the length of the string. +;; of resultant string. If not given, build until end of string is reached. + +(DEFUN SUBSTRING (STRING BEGIN &OPTIONAL (END NIL)) + (LET* ((EXPLODED-STRING (EXPLODEN STRING)) + (LENGTH (LENGTH EXPLODED-STRING))) + (IF (NOT END) (SETQ END LENGTH)) + (IF (OR (< BEGIN 0) (> BEGIN LENGTH)) + (FERROR ':WRONG-TYPE-ARGUMENT + "Beginning subscript ~D out of range of string ~S" + BEGIN STRING)) + (IF (OR (< END 0) (> END LENGTH)) + (FERROR ':WRONG-TYPE-ARGUMENT + "Ending subscript ~D out of range of string ~S" + END STRING)) + (MAKE-STRING-FROM-CHARS + (FIRSTN (- END BEGIN) (NTHCDR BEGIN EXPLODED-STRING))))) + +;; This is better as a function than as a macro since the arguments may be +;; either strings or characters. + +(DEFUN STRING-APPEND (&REST STRINGS) + (MAKE-STRING-FROM-CHARS + (MAPCAN + #'(LAMBDA (S) + (COND ((SYMBOLP S) (EXPLODEN S)) + ((FIXP S) (NCONS S)) + (T (FERROR ':WRONG-TYPE-ARGUMENT + "Argument is not a string, symbol or character -- ~S" + S)))) + STRINGS)))) + +;; (DEFUN STRING-EQUAL (STRING-1 STRING-2 &OPTIONAL (BEGIN-1 0) (BEGIN-2 0) +;; (END-1 (STRING-LENGTH STRING-1)) +;; (END-2 (STRING-LENGTH (STRING-2)))) +;; (STRING-EQUAL-2-ARGS (SUBSTRING STRING-1 BEGIN-1 END-1) +;; (SUBSTRING STRING-2 BEGIN-2 END-2))) + +;; Compares two strings ignoring case. Check to see if they are eq +;; as an efficiency hack. + +(DEFUN STRING-EQUAL (STRING-1 STRING-2 &OPTIONAL (BEGIN-1 0) (BEGIN-2 0) + (END-1 NIL) (END-2 NIL)) + (COND ((EQ STRING-1 STRING-2) T) + (T (SETQ STRING-1 (EXPLODEN STRING-1)) + (SETQ STRING-2 (EXPLODEN STRING-2)) + (LET ((LENGTH-1 (LENGTH STRING-1)) + (LENGTH-2 (LENGTH STRING-2))) + (IF (NOT END-1) (SETQ END-1 LENGTH-1)) + (IF (NOT END-2) (SETQ END-2 LENGTH-2)) + (IF (= (- END-1 BEGIN-1) (- END-2 BEGIN-2)) + ;; Strings are the same length + (DO ((STRING-1 (FIRSTN (- END-1 BEGIN-1) (NTHCDR BEGIN-1 STRING-1)) + (CDR STRING-1)) + (STRING-2 (FIRSTN (- END-2 BEGIN-2) (NTHCDR BEGIN-2 STRING-2)) + (CDR STRING-2))) + ((NULL STRING-1) T) + (IF (NOT (CHAR-EQUAL (CAR STRING-1) (CAR STRING-2))) + (RETURN NIL)))))))) + +;; STRING-TRIM will return a substring of STRING with all characters in +;; CHAR-LIST stripped off the beginning and end. STRING-LEFT-TRIM and +;; STRING-RIGHT-TRIM work similarly. + +(SETQ WHITESPACE-CHAR-LIST '(#\TAB #\LF #\FORM #\RETURN #\SPACE)) + +(DEFUN STRING-TRIM (CHAR-LIST STRING) + (STRING-LEFT-TRIM CHAR-LIST + (STRING-RIGHT-TRIM CHAR-LIST STRING))) + +(DEFUN STRING-LEFT-TRIM (CHAR-LIST STRING) + (CHECK-ARG CHAR-LIST (OR (NULL CHAR-LIST) (NOT (ATOM CHAR-LIST))) + "a list of characters") + (COND ((NULL CHAR-LIST) STRING) + (T (DO ((STRING (EXPLODEN STRING) (CDR STRING))) + ((NULL STRING) "") + (COND ((MEM 'CHAR-EQUAL (CAR STRING) CHAR-LIST)) + (T (RETURN (MAKE-STRING-FROM-CHARS STRING)))))))) + +(DEFUN STRING-RIGHT-TRIM (CHAR-LIST STRING) + (CHECK-ARG CHAR-LIST (OR (NULL CHAR-LIST) (NOT (ATOM CHAR-LIST))) + "a list of characters") + (COND ((NULL CHAR-LIST) STRING) + (T (DO ((STRING (NREVERSE (EXPLODEN STRING)) (CDR STRING))) + ((NULL STRING) "") + (COND ((MEM 'CHAR-EQUAL (CAR STRING) CHAR-LIST)) + (T (RETURN (MAKE-STRING-FROM-CHARS (NREVERSE STRING))))))))) + +;; Search for a substring within a string. The search begins at BEGIN which +;; defaults to the beginning of the string. The value returned is the index of +;; the first character of the first instance of KEY, or NIL if none is found. + +(DEFUN STRING-SEARCH (KEY STRING &OPTIONAL (BEGIN 0)) + (DECLARE (FIXNUM BEGIN)) + (IF (> BEGIN (STRING-LENGTH STRING)) (LMRUN-INDEX-OUT-OF-RANGE BEGIN STRING)) + (SETQ KEY (EXPLODEN KEY)) + (LOOP FOR I FROM BEGIN + FOR LIST ON (NTHCDR BEGIN (EXPLODEN STRING)) + WHEN (STRING-SEARCH-ALIGNED-SUBLIST KEY LIST) RETURN I)) + +(DEFUN STRING-SEARCH-ALIGNED-SUBLIST (KEY LIST) + (DO ((LIST LIST (CDR LIST)) + (KEY KEY (CDR KEY))) + ((NULL KEY) T) + (COND ((NULL LIST) (RETURN NIL)) + ((NOT (CHAR-EQUAL (CAR LIST) (CAR KEY))) (RETURN NIL))))) + +;; Search for a character within a string. The search begins at BEGIN and +;; defaults to the beginning of the string. + +(DEFUN STRING-SEARCH-CHAR + (CHAR STRING &OPTIONAL (BEGIN 0) &AUX (LENGTH (STRING-LENGTH STRING))) + (DECLARE (FIXNUM CHAR BEGIN)) + (IF (> BEGIN LENGTH) (LMRUN-INDEX-OUT-OF-RANGE BEGIN STRING)) + (LOOP FOR I FROM BEGIN TO LENGTH + WHEN (CHAR-EQUAL CHAR (GETCHARN STRING (1+ I))) RETURN I)) + +;; Search for any character within a string except a specific one. The +;; search begins a BEGIN and defaults to the beginning of the string. + +(DEFUN STRING-SEARCH-NOT-CHAR + (CHAR STRING &OPTIONAL (BEGIN 0) &AUX (LENGTH (STRING-LENGTH STRING))) + (DECLARE (FIXNUM CHAR BEGIN)) + (IF (> BEGIN LENGTH) (LMRUN-INDEX-OUT-OF-RANGE BEGIN STRING)) + (LOOP FOR I FROM BEGIN TO LENGTH + UNLESS (CHAR-EQUAL CHAR (GETCHARN STRING (1+ I))) RETURN I)) + +(DEFUN LMRUN-INDEX-OUT-OF-RANGE (INDEX STRING) + (FERROR ':WRONG-TYPE-ARGUMENT + "Index ~D out of range of string ~S" INDEX STRING)) + + +;; User interaction -- mostly quick and dirty hacks. Should flush +;; this and convert to LSPSRC;YESNOP. + +(DEFVAR STANDARD-OUTPUT TYO) +(DEFVAR STANDARD-INPUT TYI) + +;; Should really make an sfa which binds together tyi and tyo, since one +;; can't tyi from tyo. +(DEFVAR QUERY-IO TYO) + +;; This really should take its arguments just as FORMAT does, and directly call +;; FORMAT. + +(DEFUN YES-OR-NO-P (&OPTIONAL (MESSAGE NIL M-P) (STREAM QUERY-IO)) + (IF M-P (PRINC MESSAGE STREAM)) + ;; Kludge + (DO ((RESPONSE (READLINE TYI) (READLINE TYI))) + (NIL) + (SETQ RESPONSE + (READ-FROM-STRING (STRING-TRIM WHITESPACE-CHAR-LIST RESPONSE))) + (CASEQ RESPONSE + ((YES T CAIN HAI JA) (RETURN T)) + ((NO NIL LO IE NYET) (RETURN NIL)) + (T (PRINC "(Yes or No) " STREAM))))) + +;; Quick kludge to make Y-OR-N-P work. Maybe we want to make MacLisp +;; streams look more like the LISPM's. + +(DEFMACRO WITHOUT-ECHOING (&REST FORMS) + `(LET ((STATUS-TTY (STATUS TTY))) + (UNWIND-PROTECT + (PROGN (SSTATUS TTY + (LOGAND (CAR STATUS-TTY) #O 070707070707) + (LOGAND (CADR STATUS-TTY) #O 070707070707)) + . ,FORMS) + (SSTATUS TTY (CAR STATUS-TTY) (CADR STATUS-TTY))))) + +(DEFUN Y-OR-N-P (&OPTIONAL (MESSAGE NIL M-P) (STREAM QUERY-IO)) + (IF M-P (PRINC MESSAGE STREAM)) + (WITHOUT-ECHOING + (DO ((RESPONSE (TYI TYI) (TYI TYI))) + (NIL) + (SETQ RESPONSE (CHAR-UPCASE RESPONSE)) + (CASEQ RESPONSE + ((#/Y #/T #\SP) (PRINC "Yes." STREAM) (RETURN T)) + ((#/N #\RUBOUT) (PRINC "No." STREAM) (RETURN NIL)) + (T (PRINC " (Y or N) " STREAM)))))) + +(PUTPROP 'LMRUN 'VERSION T) diff --git a/src/libmax/lmrund.1 b/src/libmax/lmrund.1 new file mode 100755 index 00000000..c875be74 --- /dev/null +++ b/src/libmax/lmrund.1 @@ -0,0 +1,33 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module lmrund macro) + + +;; Lisp Machine compatibility package -- declarations + +;; This file is a part of the Lisp Machine compatibility package in LIBMAX, +;; consisting of the files LMRUN, LMMAC, and LMINCL. It contains the +;; declarations for the functions and globals in LIBMAX;LMRUN. + +(if (fboundp '*expr) + (*expr butlast nbutlast firstn mem find-position-in-list + ass rassq rassoc + character char-equal char-lessp char-upcase char-downcase + string string-trim string-left-trim string-right-trim)) +(if (fboundp '*lexpr) + (*lexpr substring string-append string-equal + string-search string-search-char string-search-not-char + yes-or-no-p y-or-n-p)) +(if (fboundp 'fixnum) + (fixnum (character notype) + (char-upcase fixnum) + (char-downcase fixnum))) +(if (fboundp 'notyp) + (notype (firstn fixnum notype) + (char-equal fixnum fixnum) + (char-lessp fixnum fixnum))) +(if (fboundp 'special) + (special whitespace-char-list + standard-output standard-input query-io)) diff --git a/src/libmax/maxmac.227 b/src/libmax/maxmac.227 new file mode 100644 index 00000000..8f188e5a --- /dev/null +++ b/src/libmax/maxmac.227 @@ -0,0 +1,603 @@ +;; -*- Mode: Lisp; Package: Macsyma; -*- + +;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology +;; All Rights Reserved. + +;; Enhancements (c) Copyright 1983 Symbolics Inc. +;; All Rights Reserved. + +;; The data and information in the Enhancements is proprietary to, and +;; a valuable trade secret of, SYMBOLICS, INC., a Delaware corporation. +;; It is given in confidence by SYMBOLICS, and may not be used as the basis +;; of manufacture, or be reproduced or copied, or distributed to any other +;; party, in whole or in part, without the prior written consent of SYMBOLICS. + +(macsyma-module maxmac macro) + +;; This file contains miscellaneous macros used in Macsyma source files. +;; This file must run and compile in PDP10 Lisp, Multics Lisp, Franz Lisp, +;; and LMLisp. + +;; General purpose macros which are used in Lisp code, but not widely enough +;; accepted to be a part of Lisp systems. + +;; For evaluable declarations placed in macro files. This is a DWIM form +;; saying "evaluate this form if you think it matters." If we tried hard +;; we could come up with a better way to actually do it. -gjc + +(defmacro for-declarations (&rest l) + `(map-eval-for-declarations ',l)) + +(defun map-eval-for-declarations (l) (mapc #'eval-for-declarations l)) + +(defun eval-for-declarations (form) + (if (and (not (atom form)) + (symbolp (car form)) + ;; we want an fboundp which gives T for special forms too. + (OR (fboundp (car form)) + #+NIL (SI:MACRO-DEFINITION (CAR FORM)) + #+NIL (EQ (CAR FORM) 'SPECIAL))) + (eval form))) + +;; All these updating macros should be made from the same generalized +;; push/pop scheme as I mentioned to LispForum. As they are defined now +;; they have inconsistent return-values and multiple-evaluations of +;; arguments. -gjc + +(DEFMACRO ADDL (ITEM LIST) + `(OR (MEMQ ,ITEM ,LIST) (SETQ ,LIST (CONS ,ITEM ,LIST)))) + +#-Multics (PROGN 'COMPILE + + +(DEFMACRO INCREMENT (COUNTER &OPTIONAL INCREMENT) + (IF INCREMENT + `(SETF ,COUNTER (+ ,COUNTER ,INCREMENT)) + `(SETF ,COUNTER (1+ ,COUNTER)))) + + +(DEFMACRO DECREMENT (COUNTER &OPTIONAL DECREMENT) + (IF DECREMENT + `(SETF ,COUNTER (- ,COUNTER ,DECREMENT)) + `(SETF ,COUNTER (1- ,COUNTER)))) + +(DEFMACRO COMPLEMENT (SWITCH) `(SETF ,SWITCH (NOT ,SWITCH))) + +) ;; End of Lispm conditionalization. + + + +;; Number of bits of precision in a fixnum and in the fields of a flonum for +;; a particular machine. These variables should only be around at eval +;; and compile time. These variables should probably be set up in a prelude +;; file so they can be accessible to all Macsyma files. +;; (They now are. - JPG 06/19/83) + +;; 68K machine is still to be done. + +(eval-when (compile eval load) + (SETQ MACHINE-FIXNUM-PRECISION + #+(OR PDP10 H6180) 36. + #+(and LISPM CADR) 24. + #+(and LISPM 3600) 32. + #+NIL 30. + #+Franz 32. + + MACHINE-MANTISSA-PRECISION + #+(OR PDP10 H6180) 27. + #+(and LISPM CADR) 32. + #+(and LISPM 3600) 23. + #+(OR NIL Franz) 56. + + ;; Not used anymore, but keep it around anyway in case + ;; we need it later. + + MACHINE-EXPONENT-PRECISION + #+(OR PDP10 H6180) 8. + #+(and LISPM CADR) 11. + #+(and LISPM 3600) 8. + #+(OR NIL Franz) 8. + + ;; Used in some of the numerical routines and in the rational + ;; function package to decide when a number is equal to 0. + ;; Approximately the smallest positive flonum. + + MACHINE-SMALL-FLONUM + #+(OR PDP10 H6180) 1.0e-38 + #+(and LISPM CADR) 1.0e-38 + #+(and LISPM 3600) 2.0e-38 + #+(OR NIL Franz) 1.0e-38 + )) + + + +;; 'writefilep' and 'ttyoff' are system independent ways of expressing +;; the Maclisp ^R and ^W. +;; In Franz Lisp, we make writefilep equivalent to ptport, which isn't +;; exactly correct since ptport is not just a boolean variable. However +;; it works in most cases. +;; +(eval-when (compile eval load) + (defvar writefilep #-Franz '^R #+Franz 'ptport) + (defvar ttyoff '^W)) + +;; (IFN A B) --> (COND ((NOT A) B)) +;; (IFN A B C D) --> (COND ((NOT A) B) (T C D)) +;; (IFN A B) is equivalent to (OR A B) as (IF A B) is equivalent to (AND A B). + +(DEFMACRO IFN (PREDICATE THEN . ELSE) + (COND ((NULL ELSE) `(COND ((NOT ,PREDICATE) ,THEN))) + (T `(COND ((NOT ,PREDICATE) ,THEN) (T . ,ELSE))))) + +(DEFMACRO FN (BVL &REST BODY) + `(FUNCTION (LAMBDA ,BVL . ,BODY))) + +;; Like PUSH, but works at the other end. + +(DEFMACRO TUCHUS (LIST OBJECT) + `(SETF ,LIST (NCONC ,LIST (NCONS ,OBJECT)))) + +;; Copy a single cons, the top level and all levels (repectively) of a piece of +;; list structure. Something similar for strings, structures, etc. would be +;; useful. These functions should all be open-coded subrs. + +(DEFMACRO COPY-CONS (CONS) + (IF (ATOM CONS) + `(CONS (CAR ,CONS) (CDR ,CONS)) + (LET ((VAR (GENSYM))) + `(LET ((,VAR ,CONS)) `(CONS (CAR ,VAR) (CDR ,VAR)))))) + +(DEFMACRO COPY-TOP-LEVEL (LIST) `(APPEND ,LIST NIL)) +(DEFMACRO COPY-ALL-LEVELS (LIST) `(SUBST NIL NIL ,LIST)) + +;; Old names kept around for compatibility. + +(DEFMACRO COPY1* (LIST) `(APPEND ,LIST NIL)) +(DEFMACRO COPY1 (LIST) `(APPEND ,LIST NIL)) +#-Franz +(DEFMACRO COPY (LIST) `(SUBST NIL NIL ,LIST)) + +;; Use this instead of GETL when looking for "function" properties, +;; i.e. one of EXPR, SUBR, LSUBR, FEXPR, FSUBR, MACRO. +;; Use FBOUNDP, FSYMEVAL, or FMAKUNBOUND if possible. + +(DEFMACRO GETL-FUN (FUN L) + #+MacLisp `(GETL ,FUN ,L) + #+LISPM `(GETL-LM-FCN-PROP ,FUN ,L) + #+Franz `(GETL-FRANZ-FCN-PROP ,FUN ,L) + #+NIL `(GETL-NIL-FCN-PROP ,FUN ,L) + ) + +;; Non-destructive versions of DELQ and DELETE. Already part of NIL +;; and LMLisp. These should be rewritten as SUBRS and placed +;; in UTILS. The subr versions can be more memory efficient. + +#-(OR Lispm NIL Multics Franz) +(DEFMACRO REMQ (ITEM LIST &OPTIONAL (COUNT () COUNTING?)) + (IF COUNTING? `(DELQ ,ITEM (APPEND ,LIST NIL) ,COUNT) + `(DELQ ,ITEM (APPEND ,LIST NIL)))) + +#-(OR Lispm NIL Multics Franz) +(DEFMACRO REMOVE (ITEM LIST &OPTIONAL (COUNT () COUNTING?)) + (IF COUNTING? `(DELETE ,ITEM (APPEND ,LIST NIL) ,COUNT) + `(DELETE ,ITEM (APPEND ,LIST NIL)))) + +#-Lispm (DEFMACRO CATCH-ALL (FORM) `(*CATCH NIL ,FORM)) + +;; (EXCH A B) exchanges the bindings of A and B +;; Maybe it should turn into (PSETF A B B A)? + +(DEFMACRO EXCH (X Y) `(SETF ,X (PROG1 ,Y (SETF ,Y ,X)))) + +;; These are here for old code only. +;; Use FIFTH rather than CADDDDR. Better, use DEFSTRUCT. + +#-Franz (DEFMACRO CADDADR (X) `(CAR (CDDADR ,X))) +#-Franz (DEFMACRO CADDDDR (X) `(CAR (CDDDDR ,X))) + +;; The following is a bit cleaner than the kludgy (PROGN 'COMPILE . ) + +(DEFMACRO COMPILE-FORMS (&REST ) `(PROGN 'COMPILE . ,)) + + +;; The following macros pertain only to Macsyma. + +;; Widely used macro for printing error messages. We should be able +;; to come up with something better. On large address space systems +;; this should signal -- hack later. Soon to be flushed in favor +;; of new Macsyma error system. Yea! + +;; Obsolete. Use MERROR. + +(DEFMACRO ERLIST (MESSAGE) + (ERROR "ERLIST is obsolete, all calls to it have been removed, so where + did you dig this one up loser?" message)) + +;; All functions are present on non-autoloading systems. Definition +;; for autoloading systems is in SUPRV. + +#-PDP10 +(DEFMACRO FIND-FUNCTION (FUNCTION) FUNCTION NIL) + +;; Facility for loading auxilliary macro files such as RATMAC or MHAYAT. +;; Global macro files are loaded by the prelude file. + +#+LISPM (DEFUN MACRO-DIR (X) (FORMAT NIL "LMMAXQ;~A QFASL" X)) +#+PDP10 (DEFUN MACRO-DIR (X) `((LIBMAX) ,X)) +#+Franz (defun macro-dir (x) (cond ((cdr (assoc x '((rzmac . "rz//macros") + (mhayat . "rat//mhayat") + (ratmac . "rat//ratmac"))))) + (t (concat "libmax//" x)))) + + +(comment Sample definition only on + ITS see "LIBMAX;MODULE" + LISPM see "LMMAX;SYSDEF" + NIL see "VAXMAX;VAXCL" + Multics see "???" + Franz see "/usr/lib/lisp/machacks.l" +() +(defmacro macsyma-module (name &rest options) + (maybe-load-macros options) + (maybe-load-declarations options) + `(progn 'compile + (print '(loading ,name) msgfiles) + (defprop ,name t loaded?) + ,@(maybe-have-some-runtime-options options))) +) + +;; Except on the Lisp Machine, load the specified macro files. +;; On the Lisp Machine, the DEFSYSTEM facility is used for loading +;; macro files, so just check that the file is loaded. This is +;; a useful error check, has saved a lot of time since Defsystem +;; is far from fool-proof. See LMMAX;SYSDEF for the Lispm +;; definition of MACSYMA-MODULE. + +#+LISPM +(DEFUN LOAD-MACSYMA-MACROS-AT-RUNTIME (&REST L) + (MAPCAR #'(LAMBDA (X) + (IF (GET X 'MACSYMA-MODULE) + X + (FERROR NIL "Missing Macsyma macro file -- ~A" X))) + L)) +#-LISPM +(DEFUN LOAD-MACSYMA-MACROS-AT-RUNTIME (&REST L) + (MAPCAR #'(LAMBDA (X) + (OR (GET X 'VERSION) (LOAD (MACRO-DIR X))) + (LIST X (GET X 'VERSION))) + L)) + +(DEFMACRO LOAD-MACSYMA-MACROS (&REST MACRO-FILES) + `(COMMENT *MACRO*FILES* + ,(APPLY #'LOAD-MACSYMA-MACROS-AT-RUNTIME MACRO-FILES))) + +#+Multics +(defmacro find-documentation-file (x) + (cond ((eq x 'manual) + `(let ((filep (probef (list (catenate macsyma-dir ">documentation") + "macsyma.manual")))) + (cond (filep filep) + (t (error "Cannot find the Macsyma manual"))))) + ((eq x 'manual-index) + `(let ((filep (probef (list (catenate macsyma-dir ">documentation") + "macsyma.index.lisp")))) + (cond (filep filep) + (t (error "Cannot find the Macsyma manual index"))))) + (t (error "Unknown documentation: " x)))) + +#+Multics +(defmacro load-documentation-file (x) + `(load (find-documentation-file ,x))) + +;;;Reset the stream to its starting position. +#-LispM +(defmacro rewind-stream (stream) + `(filepos ,stream 0)) + +#+LispM +(defmacro rewind-stream (stream) + `(send ,stream ':rewind)) + +;; Used to temporarily bind contexts in such a way as to not cause +;; the context garbage collector to run. Used when you don't want to +;; stash away contexts for later use, but simply want to run a piece +;; of code in a new context which will be destroyed when the code finishes. +;; Note that this code COULD use an unwind-protect to be safe but since +;; it will not cause out and out errors we leave it out. + +(defmacro with-new-context (sub-context &rest forms) + `(let ((context (context ,@sub-context))) + (prog1 ,@forms + (context-unwinder)))) + + +;; For creating a macsyma evaluator variable binding context. +;; (MBINDING (VARIABLES &OPTIONAL VALUES FUNCTION-NAME) +;; ... BODY ...) + +(DEFMACRO MBINDING (VARIABLE-SPECIFICATION &REST BODY &AUX (TEMP (GENSYM))) + `(LET ((,TEMP ,(CAR VARIABLE-SPECIFICATION))) + ;; Don't optimize out this temporary, even if (CAR VARIABLE-SPECICIATION) + ;; is an ATOM. We don't want to risk side-effects. + ,(CASEQ (LENGTH VARIABLE-SPECIFICATION) + ((1) + `(MBINDING-SUB ,TEMP ,TEMP NIL ,@BODY)) + ((2) + `(MBINDING-SUB ,TEMP ,(CADR VARIABLE-SPECIFICATION) NIL ,@BODY)) + ((3) + `(MBINDING-SUB ,TEMP ,(CADR VARIABLE-SPECIFICATION) + ,(CADDR VARIABLE-SPECIFICATION) + ,@BODY)) + (T + (ERROR "Bad variable specification:" variable-specification))))) + +(DEFVAR MBINDING-USAGE + #+(and PDP10 Maclisp) 'PROG1 + #+(and Multics Maclisp) 'UNWIND-PROTECT + #+Franz 'PROG1 + #+LISPM 'UNWIND-PROTECT + #+NIL 'UNWIND-PROTECT + ) + +(DEFMACRO MBINDING-SUB (VARIABLES VALUES FUNCTION-NAME &REST BODY + &AUX (WIN (GENSYM))) + (CASEQ MBINDING-USAGE + ((PROG1) + `(PROG1 (PROGN (MBIND ,VARIABLES ,VALUES ,FUNCTION-NAME) ,@BODY) + (MUNBIND ,VARIABLES))) + ((UNWIND-PROTECT) + `(LET ((,WIN NIL)) + (UNWIND-PROTECT + (PROGN (MBIND ,VARIABLES ,VALUES ,FUNCTION-NAME) + (SETQ ,WIN T) + ,@BODY) + (IF ,WIN (MUNBIND ,VARIABLES))))) + ((PROGV) + `(LET ((,WIN (MBINDING-CHECK ,VARIABLES ,VALUES ,FUNCTION-NAME))) + (PROGV ,VARIABLES + ,WIN + ,@BODY))) + (T + (ERROR "Unknown setting of MBINDING-USAGE" MBINDING-USAGE)))) + +#+NIL +(DEFMACRO MDEFPROP (A B C) `(MPUTPROP ',A ',B ',C)) + +#-Franz ;; Franz uses a function definition in COMM. + ;; For MLISTP its arg is known not to be an atom. + ;; Otherwise, just use $LISTP. + ;; MLISTP exists just to support a Franz hack, so you can just + ;; ignore it. - JPG +(DEFMACRO MLISTP (X) `(EQ (CAAR ,X) 'MLIST)) + +;; How About MTYPEP like (MTYPEP EXP 'TAN) or (MTYPEP EXP '*) - Jim. +;; Better, (EQ (MTYPEP EXP) 'TAN). + +(DEFMACRO MTANP (X) + `(LET ((THING ,X)) + (AND (NOT (ATOM THING)) (EQ (CAAR THING) '%TAN)))) + +(DEFMACRO MATANP (X) + `(LET ((THING ,X)) + (AND (NOT (ATOM THING)) (EQ (CAAR THING) '%ATAN)))) + +;; Macros used in LIMIT, DEFINT, RESIDU. +;; If we get a lot of these, they can be split off into a separate macro +;; package. + +(DEFMACRO REAL-INFINITYP (X) `(MEMQ ,X REAL-INFINITIES)) + +(DEFMACRO INFINITYP (X) `(MEMQ ,X INFINITIES)) + +(DEFMACRO REAL-EPSILONP (X) `(MEMQ ,X INFINITESIMALS)) + +(DEFMACRO FREE-EPSILONP (X) + `(DO ((ONE-EPS INFINITESIMALS (CDR ONE-EPS))) + ((NULL ONE-EPS) T) + (IF (NOT (FREE (CAR ONE-EPS) ,X)) (RETURN ())))) + +(DEFMACRO FREE-INFP (X) + `(DO ((ONE-INF INFINITIES (CDR ONE-INF))) + ((NULL ONE-INF) T) + (IF (NOT (FREE (CAR ONE-INF) ,X)) (RETURN ())))) + +(DEFMACRO INF-TYPEP (X) + `(CAR (AMONGL INFINITIES ,X))) + +(DEFMACRO HOT-COEF (P) + `(PDIS (CADDR (CADR (RAT-NO-RATFAC ,P))))) + +;; Special form for declaring Macsyma external variables. It may be used for +;; User level variables, or those referenced by other Lisp programs. + +;; Syntax is: +;; (DEFMVAR &OPTIONAL . ) See +;; MC:LIBMAX;DEFINE > for complete documentation of syntax. The code in this +;; file for DEFMVAR is for non-ITS systems only. LIBMAX;DEFINE contains code +;; for ITS. Other systems may process the documentation information as they +;; wish. + +;; Be sure to expand into DEFVAR and not into (DECLARE (SPECIAL ...)) as +;; certain systems do other things with DEFVAR. The Lisp Machine, for +;; instance, annotates the file name. On Multics and the Lisp Machine, expand +;; into DEFCONST since the entire Macsyma system is present before user files +;; are loaded, so there is no need to do the BOUNDP check. + +#-(or Franz ITS) +(DEFMACRO DEFMVAR (VARIABLE &OPTIONAL (INITIAL-VALUE NIL IV-P) DOCUMENTATION + &REST FLAGS &AUX DEFINER TYPE) + DOCUMENTATION FLAGS ;; Ignored certain places. + (SETQ DEFINER #+(or Multics Lispm) 'DEFCONST + #-(or Multics Lispm) 'DEFVAR) + #-Lispm + (SETQ TYPE (COND ((MEMQ 'FIXNUM FLAGS) 'FIXNUM) + ((MEMQ 'FLONUM FLAGS) 'FLONUM) + (T NIL))) + `(PROGN 'COMPILE + ,(IF IV-P + `(,DEFINER ,VARIABLE ,INITIAL-VALUE) + `(,DEFINER ,VARIABLE #+LISPM () )) + ,@(IF TYPE `((DECLARE (,TYPE ,VARIABLE)))))) + +;; Special form for declaring Macsyma external procedures. Version for ITS +;; is in LIBMAX;DEFINE. +;; Franz version is in libmax/vdefine.l + +#-(or Franz ITS) +(DEFMACRO DEFMFUN (FUNCTION . REST) `(DEFUN ,FUNCTION . ,REST)) + +#-(or Franz ITS LISPM) +(DEFMACRO DEFMSPEC (FUNCTION . REST) + `(DEFUN (,FUNCTION MFEXPR*) . ,REST)) + +#+LISPM +(DEFPROP DEFMSPEC "Macsyma special form" SI:DEFINITION-TYPE-NAME) +#+LISPM +(DEFMACRO DEFMSPEC (FUNCTION . REST) + `(LOCAL-DECLARE ((SYS:FUNCTION-PARENT ,FUNCTION DEFMSPEC)) + (DEFUN (:PROPERTY ,FUNCTION MFEXPR*) . ,REST) + (SI:RECORD-SOURCE-FILE-NAME ',FUNCTION 'DEFMSPEC))) + +;;; The following MAUTOLOAD macro makes setting up autoload props for files +;;; on "standard" Macsyma directories easy, and clean. As an example, the +;;; code in SUPRV would look as folllows: +;;; +;;; (MAUTOLOAD (PURCOPY '(FASL DSK MACSYM)) +;;; (LIMIT $LIMIT $LDEFINT) +;;; (IRINTE INTE) +;;; (MATCOM $MATCHDECLARE $DEFMATCH $TELLSIMP $TELLSIMPAFTER $DEFRULE) +;;; (MATRUN $DISPRULE $REMRULE $APPLY1 $APPLYB1 $APPLY2 $APPLYB2 +;;; FINDBE FINDFUN FINDEXPON FINDBASE PART+ PART*) +;;; ... +;;; +;;; ((LISPT FASL DSK LIBLSP) $TECO $TSTRING $TECMAC $EMACS $EDIT) +;;; +;;; ... ) +;;; +;;; The reason the file-spec list evals, is so that one may do a PURCOPY as +;;; above, and also one could imagine having a status request here to obtain +;;; the canonical file spec's. +;;; Note that the first arg must be of the form (FN2 DEV DIR) if a file +;;; mask is being used; this macro could be much more elaborate. + +#+ITS +(DEFMACRO MAUTOLOAD (FN2-DEV-DIR &REST MASTER-LIST) + `(DOLIST (L ',MASTER-LIST) + (DO ((FILE (IF (ATOM (CAR L)) + (CONS (CAR L) ,FN2-DEV-DIR) + (CAR L))) + (FUNLIST (CDR L) (CDR FUNLIST))) + ((NULL FUNLIST)) + (PUTPROP (CAR FUNLIST) FILE 'AUTOLOAD)))) + +#-Multics +(DEFMACRO SYS-DEFAULTF (X) `(DEFAULTF ,X)) +;;; For #+Multics a function definition for SYS-DEFAULTF can be found +;;; in SUPRV. + +(defmacro sys-user-id () + #+Franz '(getenv '|USER|) + #+lispm 'user-id + #+Multics '(status uname) + #-(or Franz Multics lispm) '(status userid)) + +;;; Clearly this is just a hack for the franz case +;;; but I don't know how to get the real info. +(defmacro sys-free-memory () + #-(or Multics lispm NIL Franz) '(status memfree) + #+(or Multics lispm NIL Franz) 10000.) ;This should look at the pdir size + ;and mung it to give a good approximation. + +;; Setf hacking. +;; +;; +;;(defsetf GET ((() sym tag) value) T +;; (eval-ordered* '(nsym ntag nvalue) +;; `(,sym ,tag ,value) +;; '`((PUTPROP ,nsym ,nvalue ,ntag)))) + +#+PDP10 +(defsetf MGET ((() sym tag) value) T + (eval-ordered* '(nsym ntag nvalue) + `(,sym ,tag ,value) + '`((MPUTPROP ,nsym ,nvalue ,ntag)))) + +#+PDP10 +(defsetf $GET ((() sym tag) value) T + (eval-ordered* '(nsym ntag nvalue) + `(,sym ,tag ,value) + '`(($PUT ,nsym ,nvalue ,ntag)))) + +#+Franz +(defsetf mget (expr value) + `(mputprop ,(cadr expr) ,value ,(caddr expr))) + +#+Franz +(defsetf $get (expr value) + `($put ,(cadr expr) ,value ,(caddr expr))) + +#+NIL +(DEFPROP MGET SETF-MGET SI:SETF-SUBR) +#+NIL +(DEFPROP $GET SETF-$GET SI:SETF-SUBR) + +;;DIFFERENT version of setf on Multics and LM ...Bummer... -JIM 3/4/81 +#+MULTICS +(defsetf MGET (sym tag) value + `(MPUTPROP ,sym ,value ,tag)) + +#+MULTICS +(defsetf $GET (sym tag) value + `($PUT ,sym ,value ,tag)) + +#+LISPM +(DEFUN (:PROPERTY MGET SI:SETF) (REF VAL) + `(MPUTPROP ,(SECOND REF) ,VAL ,(THIRD REF))) + +#+LISPM +(DEFUN (:PROPERTY $GET SI:SETF) (REF VAL) + `($PUT ,(SECOND REF) ,VAL ,(THIRD REF))) + + +(defmacro initialize-random-seed () + #+PDP10 '(sstatus random 0) + #+LISPM () ;;(si:random-initialize si:random-array) obsolete. what now? + #+NIL '(si:random-number-seed 0) + ) + +;; These idiot macros are used in some places in macsyma. +;; The LISPM doesn't "go that high" with the series. DO NOT USE THESE +;; in new code. -gjc + +(DEFMACRO EIGHTH (FORM) `(CADDDR (CDDDDR ,FORM))) +(DEFMACRO NINTH (FORM) `(CAR (CDDDDR (CDDDDR ,FORM)))) +(DEFMACRO TENTH (FORM) `(CADR (CDDDDR (CDDDDR ,FORM)))) + +(DEFMACRO REST5 (FORM) `(CDR (CDDDDR ,FORM))) +(DEFMACRO REST6 (FORM) `(CDDR (CDDDDR ,FORM))) + +;;; We should probably move these into the compatibility package on +;;; mulitcs. + +#+Multics +(defmacro *break (breakp mess) + `(apply 'break `(,,mess ,',breakp))) + +;;; To satisfy GJC's speed mainia I resisted changing these in the +;;; code. -Jim. + +#-PDP10 +(defmacro +tyi (&rest args) + `(tyi ,@args)) + +#-PDP10 +(defmacro +tyo (&rest args) + `(tyo ,@args)) + +;;; Let the compiler know that x is a fixnum. I guess it will also +;;; then optimize the call to +. +#+Multics +(defmacro fixnum-identity (x) + `(+ ,x)) + + \ No newline at end of file diff --git a/src/libmax/mdefun.57 b/src/libmax/mdefun.57 new file mode 100755 index 00000000..eed43d25 --- /dev/null +++ b/src/libmax/mdefun.57 @@ -0,0 +1,150 @@ +;;; -*- Mode: Lisp; Package: Macsyma -*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Compilation environment for TRANSLATED MACSYMA code. ;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module mdefun macro) + +;(TRANSL-MODULE MDEFUN) IS CORRECT. But doesn't work in the MPRELU +;; environment. + +(load-macsyma-macros transm) + +;;; $FIX_NUM_ARGS_FUNCTION $VARIABLE_NUM_ARGS_FUNCTION. + +(DEFVAR *KNOWN-FUNCTIONS-INFO-STACK* NIL + "When MDEFUN-TR expands it puts stuff here for MFUNCTION-CALL + to use.") + +(DEFVAR *UNKNOWN-FUNCTIONS-INFO-STACK* NIL + "When MFUNCTION-CALL expands without info from + *KNOWN-FUNCTIONS-INFO-STACK* it puts stuff here to be barfed + at the end of compilation.") + +(DEFUN (MDEFUN-TR MACRO) (FORM) + (error "obsolete macro form, please retranslate source code" + form 'fail-act)) + +(DEFUN (MDEFUN MACRO)(FORM) + (error "obsolete macro form, please retranslate source code" + form 'fail-act)) + +;;; DEFMTRFUN will be the new standard. +;;; It will punt macsyma fexprs since the macro scheme is now +;;; available. I have tried to generalize this enough to do +;;; macsyma macros also. + +;;; (DEFMTRFUN-EXTERNAL ($FOO <&restp>)) + + +#+PDP10 +(DEFUN COMPILER-STATE () COMPILER-STATE) +#+LISPM +(DEFUN COMPILER-STATE () (Y-OR-N-P "Is COMPILER-STATE true?")) +#-(OR LISPM PDP10) +(DEFUN COMPILER-STATE () T) + + +(defun (defmtrfun-external macro) (form) + (let (((name mode prop restp) (cadr form))) + #+pdp10 + (and (eq prop 'mdefine) (COMPILER-STATE) + (PUSH-INFO NAME (COND (RESTP 'LEXPR) + (T 'EXPR)) + *KNOWN-FUNCTIONS-INFO-STACK*)) + `(declare (,(cond (restp '*lexpr) (t '*expr)) + ,name) + ;; FLONUM declaration is most important + ;; for numerical work on the pdp-10. + ,@(IF (AND (EQ PROP 'MDEFINE) (EQ MODE '$FLOAT)) + `((FLONUM (,NAME)))) + ) + )) + +;;; (DEFMTRFUN ($FOO <&restp>) . BODY) +;;; If the MODE is numeric it should do something about the +;;; numebr declarations for compiling. Also, the information about the +;;; modes of the arguments should not be thrown away. + +;;; For the LISPM this sucks, since &REST is built-in. + +(DEFUN (DEFMTRFUN MACRO) (FORM) + (LET (( ((NAME MODE PROP RESTP . ARRAY-FLAG) ARGL . BODY) (CDR FORM)) + (DEF-HEADER)) + + (AND ARRAY-FLAG + ;; old DEFMTRFUN's might have this extra bit NIL + ;; new ones will have (NIL) or (T) + (SETQ ARRAY-FLAG (CAR ARRAY-FLAG))) + + (SETQ DEF-HEADER + (COND ((EQ PROP 'MDEFINE) + (COND (ARRAY-FLAG #-LISPM `(,NAME A-EXPR A-SUBR) + #+LISPM `(:PROPERTY ,NAME A-SUBR)) + (T NAME))) + (T `(,NAME TRANSLATED-MMACRO)))) + #+PDP10 + (AND (EQ PROP 'MDEFINE) (COMPILER-STATE) (NOT ARRAY-FLAG) + (PUSH-INFO NAME (COND (RESTP 'LEXPR) + (T 'EXPR)) + *KNOWN-FUNCTIONS-INFO-STACK*)) + + `(PROGN 'COMPILE + ,@(AND (NOT ARRAY-FLAG) `((REMPROP ',NAME 'TRANSLATE))) + ,@(AND MODE `((DEFPROP ,NAME ,MODE + ,(COND (ARRAY-FLAG 'ARRAYFUN-MODE) + (T 'FUNCTION-MODE))))) + ,@(COND (ARRAY-FLAG + ;; when loading in hashed array properties + ;; most exist or be created. Other + ;; array properties must be consistent if + ;; they exist. + `((INSURE-ARRAY-PROPS ',NAME ',MODE + ',(LENGTH ARGL))))) + ,@(COND ((AND (EQ PROP 'MDEFINE) (NOT ARRAY-FLAG)) + `((COND ((STATUS FEATURE MACSYMA) + (mputprop ',name t + ,(COND + ((NOT RESTP) + ''$fixed_num_args_function) + (T + ''$variable_num_args_function))))) + ,(COND ((NOT RESTP) + `(ARGS ',NAME '(NIL . ,(LENGTH ARGL)))))))) + (DEFUN ,DEF-HEADER ,(COND ((NOT RESTP) ARGL) + (T '|mlexpr NARGS|)) + ,@(COND ((NOT RESTP) + BODY) + (t + (LET ((NL (1- (LENGTH ARGL)))) + `((COND ((< |mlexpr NARGS| ,NL) + ($ERROR + 'ERROR ',NAME + '| takes no less than | + ,NL + ',(COND ((= NL 1) + '| argument.|) + (T + '| arguments.|)))) + (T + ((LAMBDA ,ARGL + ,@BODY) + ;; this conses up the + ;; calls to ARGS and LISTIFY. + ,@(DO ((J 1 (1+ J)) + (P-ARGL NIL)) + ((> J NL) + (PUSH + `(CONS + '(MLIST) + (LISTIFY + (- ,NL + |mlexpr NARGS|))) + P-ARGL) + (NREVERSE P-ARGL)) + (PUSH `(ARG ,J) + P-ARGL))))))))))))) + + + diff --git a/src/libmax/meta.89 b/src/libmax/meta.89 new file mode 100755 index 00000000..28ce25ea --- /dev/null +++ b/src/libmax/meta.89 @@ -0,0 +1,749 @@ +;;;;;;;;;;;;;;;;;;; -*- Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;(macsyma-module meta macro) + +;;; GJC Some time in July 1980. +;;; a very simple meta evaluator for lisp code. +;;; the main use of this is for looking at functions +;;; which are candidates for open compilation. +;;; No. Also used to implement atomic macros in order to implement +;;; lexical DEFCLOSURE. Also used in the macsyma->lisp translator +;;; to gronk environments. Also used to implement lexicaly local macros... + +#-Lispm +(herald meta-evaluator) + +(eval-when (eval) ;trivial utilities + (defun ldm () (load '|libmax;meta >|)) + (defmacro defo (&rest form) `(def-subr-open ,@form)) + (defun oexp (x) (open-subr-expander x))) + +(eval-when (compile eval) + (or (fboundp 'defstruct) + (load '((liblsp)struct)))) + +(defstruct (meta-var conc-name #+maclisp (TYPE NAMED-HUNK) #+lispm named) + (eval-p 0) + (setq-p 0) + special-p + name + VALUE + IN-LOOP-P ;; T if found free a PROG context. + IN-FUNARG-P + CERTAIN-EVAL-P ;; T if certain to get evaluated. + ;; NIL if it might not get evaluated due to + ;; RETURN, GO, or THROW. + ORDER ;; the evaluation order of the first time evaluated. + ) + +;;; (META-EVAL &OPTIONAL ) +;;; returns a list of meta-var structures of the interesting variables, +;;; when the var-subst-list is given it meta-substitutes for corresponding +;;; interesting variables. + +;;; this does no alpha conversion, it is a one-pass +;;; tree walker with a method for each kind of node. +;;; Furthermore, this is for lexical variables only. + +(defvar *meta-var-stack* nil) +(defvar *meta-var-eval-order-index* 0) +(DEFVAR *META-SUBST-P* NIL) +;;; if non nil then meta-eval is doing substitution, +;;; otherwise, the value returned by meta-eval is a list of +;;; meta-vars. +(DEFVAR *META-FREE-VARS* NIL) +(DEFVAR *META-CHECKING-FOR-FREE-VARS-P* NIL) +(DEFVAR *META-IN-LOOP-CONTEXT-P* nil) +(DEFVAR *META-IN-FUNARG-CONTEXT-P* NIL) +(DEFVAR *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL) + +(defmacro bind-meta-eval-state (&rest body) + `(let ((*meta-var-stack* nil) + (*meta-var-eval-order-index* 0) + (*meta-subst-p* nil) + (*meta-free-vars* nil) + (*meta-checking-for-free-vars-p* nil) + (*meta-in-loop-context-p* nil) + (*META-IN-CERTAIN-EVAL-CONTEXT-P* T) + (*META-IN-FUNARG-CONTEXT-P* NIL)) + ,@body)) + +(defmacro special-p (x) `(get ,x 'special)) +;;; this is a system-dependant macro. In maclisp it only +;;; works in the compiler. +;;; Assuming: that the special declarations of variables are +;;; inherited in the local context. If this were not true then +;;; it would save a lot of hair and confusion, but it is true. + +(defun meta-symeval (sym &aux (meta (get sym 'meta-var))) + (COND ((EQ META 'BOUND) SYM) + (META + ;; not interested in this variable otherwise. + (setq *meta-var-eval-order-index* + (1+ *meta-var-eval-order-index*)) + (alter-meta-var meta + IN-LOOP-P *META-IN-LOOP-CONTEXT-P* + IN-FUNARG-P *META-IN-FUNARG-CONTEXT-P* + special-p (special-p sym) + eval-p (1+ (meta-var-eval-p meta)) + CERTAIN-EVAL-P (OR (META-VAR-CERTAIN-EVAL-P META) + *META-IN-CERTAIN-EVAL-CONTEXT-P*) + order (or (meta-var-order meta) + *meta-var-eval-order-index*)) + + (META-VAR-VALUE META)) + (*META-CHECKING-FOR-FREE-VARS-P* + ; in this state we a looking for all free variables. + ; so create a new cell for this one. + (setq *meta-var-eval-order-index* (1+ *meta-var-eval-order-index*)) + (let ((cell (make-meta-var + IN-LOOP-P *meta-in-loop-context-p* + IN-FUNARG-P *META-IN-FUNARG-CONTEXT-P* + special-p (special-p sym) + name sym + eval-p 1 + CERTAIN-EVAL-P *META-IN-CERTAIN-EVAL-CONTEXT-P* + order *meta-var-eval-order-index*))) + (setf (get sym 'meta-var) cell) + (push cell *meta-free-vars*))) + (T SYM))) + +(defun meta-set (sym) + (or (symbolp sym) + (meta-eval-error "Attempt to set non symbol" sym)) + (let ((meta (get sym 'meta-var))) + (cond ((eq meta 'bound) sym) + (meta + (setf (meta-var-setq-p meta) (1+ (meta-var-setq-p meta))) + (setf (meta-var-special-p meta) (special-p sym)) + (meta-var-value meta)) + (*meta-checking-for-free-vars-p* + (let ((cell (make-meta-var setq-p 1 + value sym + special-p (special-p sym) + name sym))) + (setf (get sym 'Meta-var) cell) + (push cell *meta-free-vars*)) + sym)))) + +(DEFMACRO META-BINDV (VARL &REST BODY + &AUX (VARLG (GENSYM))) + `(LET ((,VARLG ,VARL)) + (META-BINDPUSH ,VARLG) + (UNWIND-PROTECT (PROGN ,@BODY) + (META-POPV ,VARLG)))) + +(DEFUN META-BINDPUSH (VARL) + (MAPC #'(LAMBDA (V) + (OR (SYMBOLP V) + (META-EVAL-ERROR "Attempt to bind non symbol" V)) + (PUSH (GET V 'META-VAR) *META-VAR-STACK*) + (SETF (GET V 'META-VAR) 'BOUND)) + VARL)) + +(DEFUN META-POPV (VARL) + (MAPC #'(LAMBDA (V) + (SETF (GET V 'META-VAR) + (POP *META-VAR-STACK*))) + VARL)) + + +(DEFUN META-EVAL (FORM + &OPTIONAL + (VARS NIL VARS-p) (SUBST-LIST)) + (bind-meta-eval-state + (or vars-p + (setq *META-CHECKING-FOR-FREE-VARS-P* t)) + (and subst-list + (setq *meta-subst-p* + (or (= (length vars) (length subst-list)) + (meta-eval-error + "In compatible var and subst-var lengths" + (list vars subst-list))))) + + (META-BINDV + VARS + (UNWIND-PROTECT + (PROGN + (COND (*META-SUBST-P* + (MAPC #'(LAMBDA (VAR VAL) + (SETF (GET VAR 'META-VAR) + (MAKE-META-VAR VALUE VAL + NAME VAR))) + VARS subst-list)) + (*meta-checking-for-free-vars-p*) + (T + (MAPC #'(LAMBDA (V) + (SETF (GET V 'META-VAR) + (MAKE-META-VAR name v))) + VARS))) + (LET ((RESULT (META-EVAL-SUB FORM))) + (COND (*META-SUBST-P* RESULT) + (*meta-checking-for-free-vars-p* + *meta-free-vars*) + (t + (MAPCAR #'(LAMBDA (V) (GET V 'META-VAR)) VARS))))) + (MAPC #'(LAMBDA (V) + (SETF (GET (META-VAR-NAME V) 'META-VAR) NIL)) + *META-FREE-VARS*))))) + +(DEFVAR *META-SPECIAL-FORMS* NIL) +;;; a self document. + +;;; DEFMETA-SPECIAL and METACALL are a team. + +(DEFMACRO DEFMETA-SPECIAL (NAME &REST BODY) + `(PROGN 'COMPILE + (DEFUN (,NAME META-EVAL) (*META-FORM*) + ,@BODY) + (OR (MEMQ ',NAME *META-SPECIAL-FORMS*) + (PUSH ',NAME *META-SPECIAL-FORMS*)))) + +(DEFMACRO METACALL (&REST ARGS) `(FUNCALL ,@ARGS)) + +(DEFMACRO DEFMETA-PROP-SPECIAL (NAME PROP) + `(PROGN 'COMPILE + (PUTPROP ',NAME #',PROP 'META-EVAL) + (OR (MEMQ ',NAME *META-SPECIAL-FORMS*) + (PUSH ',NAME *META-SPECIAL-FORMS*)))) + +(DEFUN META-EVAL-ERROR (A B) + (ERROR (FORMAT NIL "~A encountered during meta evaluation." A) + B + 'fail-act)) + + +(DEFUN META-SPECIALP (OP &AUX (DISP (GET OP 'META-EVAL))) + #+Maclisp + (COND (DISP DISP) + ((GET OP 'MACRO) + #'(LAMBDA (FORM) + (META-EVAL-SUB + (FUNCALL (GET (CAR FORM) 'MACRO) FORM)))) + ((OR (GET OP 'SUBR) + (GET OP 'LSUBR) + (GET OP 'EXPR)) + #'META-EVAL-ARGS-AND-APPLY) + ((GET OP 'FSUBR) + (META-EVAL-ERROR "Uknown special form" OP)) + (T + #'META-EVAL-ARGS-AND-APPLY)) + #+Lispm + (COND (DISP DISP) + ((FBOUNDP OP) + (LET ((BINDING (FSYMEVAL OP))) + (COND ((FUNCTIONP OP) + #'META-EVAL-ARGS-AND-APPLY) + ((AND (LISTP BINDING) (EQ (CAR BINDING) 'MACRO)) + #'(LAMBDA (FORM) + (META-EVAL-SUB + (FUNCALL (CDR (FSYMEVAL (CAR FORM))) FORM)))) + ((FUNCTIONP OP T) + (META-EVAL-ERROR "Uknown special form" OP)) + (T + (META-EVAL-ERROR "BUG: strange function kind?"))))) + (T + #'META-EVAL-ARGS-AND-APPLY))) + +(DEFUN META-EVAL-ARGS-AND-APPLY (FORM) + (PROG1 (COND (*META-SUBST-P* + (CONS (CAR FORM) (META-EVAL-ARGS (CDR FORM)))) + (T (META-EVAL-ARGS (CDR FORM)))) + ;; here is where we need a real-live data base. + ;; there are whole classes of side-effects to think about. + (AND (FUNCTION-DOES-THROW-P (CAR FORM)) + (SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL)))) + +(DEFUN FUNCTION-DOES-THROW-P (NAME) + ; well, meta-eval the function body and see! + ; assume the worst about unknown functions. + ; That is the correct way to do it. + ; (I don't mention the assertion data-base one would need to + ; resolve circularities in unknown functions.) + ; for testing just assume no throwing around. + (GET NAME 'THROW-P)) + +(DEFUN META-EVAL-ARGS (FORM) + (COND (*META-SUBST-P* + (MAPCAR #'META-EVAL-SUB FORM)) + (T (MAPC #'META-EVAL-SUB FORM)))) + +(DEFUN META-EVAL-SUB (FORM) + (COND ((NULL FORM) FORM) + ((ATOM FORM) + (COND ((EQ T FORM) FORM) + ((SYMBOLP FORM) + (META-SYMEVAL FORM)) + (T FORM))) + (T + (LET ((OP (CAR FORM))) + (COND ((ATOM OP) + (COND ((SYMBOLP OP) + (METACALL (META-SPECIALP OP) FORM)) + (T + (META-EVAL-ERROR + "Non symbolic atom in operator position" + OP)))) + ((EQ (CAR OP)'LAMBDA) + (SETQ FORM (META-EVAL-ARGS (CDR FORM))) + (SETQ OP (META-EVAL-FIXED-LAMBDA OP)) + (COND (*META-SUBST-P* + (CONS OP FORM)))) + (T + (META-EVAL-ERROR + "Non-lambda expression in operator position" + OP))))))) + + +(DEFMETA-SPECIAL QUOTE *META-FORM*) + +(DEFUN META-FUNCTION-*FUNCTION (*META-FORM*) + (SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL) + (LET ((*META-IN-FUNARG-CONTEXT-P* T)) + (OR (= (LENGTH *META-FORM*) 2) + (META-EVAL-ERROR + "Wrong number of args" *META-FORM*)) + (COND ((ATOM (CADR *META-FORM*)) *META-FORM*) + ((EQ (CAR (CADR *META-FORM*)) 'LAMBDA) + (LET ((RESULT (META-EVAL-SUB (CADR *META-FORM*)))) + (COND (*META-SUBST-P* + (LIST (CAR *META-FORM*) RESULT))))) + (T + (META-EVAL-ERROR + "Non-lambda expression in FUNCTION construct" + *META-FORM*))))) + +(DEFMETA-PROP-SPECIAL FUNCTION META-FUNCTION-*FUNCTION) +(DEFMETA-PROP-SPECIAL *FUNCTION META-FUNCTION-*FUNCTION) + +(DEFUN META-EVAL-FIXED-LAMBDA (*META-FORM*) + ; (LAMBDA ARGS . BODY) + (COND ((CDR *META-FORM*) + (COND ((AND (CADR *META-FORM*) (ATOM (CADR *META-FORM*))) + (META-EVAL-ERROR + "Bad lambda list internally" (cadr *META-FORM*))) + (T + (LET ((BODY + (META-BINDV + (CADR *META-FORM*) + (META-EVAL-ARGS (CDDR *META-FORM*))))) + (COND (*META-SUBST-P* + (LIST* (CAR *META-FORM*) + (CADR *META-FORM*) + BODY))))))) + (T + (META-EVAL-ERROR + "Bad lambda expression" *META-FORM*)))) + +(DEFMETA-SPECIAL PROGN (META-EVAL-ARGS-AND-APPLY *META-FORM*)) + +(DEFMETA-SPECIAL SETQ + (DO ((ARGS (CDR *META-FORM*)) + (VAR)(VAL) + (NEWBODY NIL)) + ((NULL ARGS) + (COND (*META-SUBST-P* + ; might as well turn it into a SETF + ; this is a useful thing for atomic macros. + (CONS 'SETF (NREVERSE NEWBODY))))) + (SETQ VAR (META-SET (POP ARGS))) + (AND *META-SUBST-P* (PUSH VAR NEWBODY)) + (OR ARGS + (META-EVAL-ERROR "Setq with odd number of arguments" + *META-FORM*)) + (SETQ VAL (META-EVAL-SUB (POP ARGS))) + (AND *META-SUBST-P* (PUSH VAL NEWBODY)) + )) + +(DEFUN VAR-OF-LET-PAIR (LET-PAIR) + ;; LET-PAIR can be FOO or (FOO) or (FOO BAR) + (COND ((ATOM LET-PAIR) LET-PAIR) + (T (CAR LET-PAIR)))) + +(DEFUN CODE-OF-LET-PAIR (LET-PAIR) + (COND ((ATOM LET-PAIR) NIL) + ((NULL (CDR LET-PAIR)) NIL) + (T (CADR LET-PAIR)))) + +(DEFMETA-SPECIAL META-LET + (DO ((LET-PAIRS (CADR *META-FORM*) (CDR LET-PAIRS)) + (BODY `(PROGN ,@(CDDR *META-FORM*))) + (VARS NIL (CONS (VAR-OF-LET-PAIR (CAR LET-PAIRS)) VARS)) + (VALS NIL + (CONS (EVAL (CODE-OF-LET-PAIR (CAR LET-PAIRS))) VALS))) + ((NULL LET-PAIRS)) + (PROGV VARS + VALS + (META-EVAL-SUB BODY)))) + +(DEFMETA-SPECIAL PROG + + (let ((*meta-in-loop-context-p* *meta-in-loop-context-p*)) + ; We go along evaluating the forms in the prog. + ; Our state changes if we see a TAG, a GO, or a RETURN. + (COND ((CDR *META-FORM*) + (COND ((AND (CADR *META-FORM*) (ATOM (CADR *META-FORM*))) + (META-EVAL-ERROR + "Bad PROG var list" (CADR *META-FORM*))) + (T + (META-BINDV + (CADR *META-FORM*) + (COND (*META-SUBST-P* + `(PROG ,(CADR *META-FORM*) + ,@(MAPCAR + #'(LAMBDA + (U) + (COND ((ATOM U) + (SETQ *META-IN-LOOP-CONTEXT-P* T) + U) + (T + (META-EVAL-SUB U)))) + (CDDR *META-FORM*)))) + (T + (MAPC #'(LAMBDA (U) + (COND ((ATOM U) + (SETQ *META-IN-LOOP-CONTEXT-P* T)) + (T + (META-EVAL-SUB U)))) + (CDDR *META-FORM*)))))) + (T + (META-EVAL-ERROR "Bad PROG" *META-FORM*))))))) + +(DEFMETA-SPECIAL GO + (PROG1 + (COND ((CDR *META-FORM*) + (COND ((ATOM (CADR *META-FORM*)) *META-FORM*) + (T + (META-EVAL-ARGS-AND-APPLY *META-FORM*)))) + (T + (META-EVAL-ERROR "Bad GO form" *META-FORM*))) + (SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL))) + +(DEFMETA-SPECIAL RETURN + (PROG1 (META-EVAL-ARGS-AND-APPLY *META-FORM*) + (SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL))) + +(COMMENT | +CATCH-BARRIER UWRITE SUBRCALL ARRAY UFILE DEFUN SETF STORE +UKILL BREAK PROG UREAD UPROBE UAPPEND CRUNIT EVAL-WHEN ERRSET +FUNCTION COND DECLARE CATCH *FUNCTION +FASLOAD PROGV DO GCTWA GO THROW POP LSUBRCALL OR STATUS SIGNP +ARRAYCALL INCLUDE CATCHALL *CATCH ERR COMMENT SSTATUS AND +QUOTE UCLOSE PUSH UNWIND-PROTECT CASEQ SETQ DEFPROP +|) + +(DEFUN IDENTITY1 (X) X) +(DEFMACRO DEFMETA-SPECIAL-IDENTITY (X) `(DEFMETA-PROP-SPECIAL ,X IDENTITY1)) + +(DEFMETA-SPECIAL-IDENTITY UWRITE) +(DEFMETA-SPECIAL-IDENTITY UFILE) +(DEFMETA-SPECIAL-IDENTITY UKILL) +(DEFMETA-SPECIAL-IDENTITY UREAD) +(DEFMETA-SPECIAL-IDENTITY UPROBE) +(DEFMETA-SPECIAL-IDENTITY UCLOSE) +(DEFMETA-SPECIAL-IDENTITY UAPPEND) +(DEFMETA-SPECIAL-IDENTITY CRUNIT) +(DEFMETA-SPECIAL-IDENTITY FASLOAD) +(DEFMETA-SPECIAL-IDENTITY DEFPROP) +(DEFMETA-SPECIAL-IDENTITY COMMENT) +(DEFMETA-SPECIAL-IDENTITY INCLUDE) + +(DEFUN META-EVAL-AND-OR-ARGS (ARGS) + (COND (*META-SUBST-P* + (LIST* (PROG1 (META-EVAL-SUB (CAR ARGS)) + (SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL)) + (META-EVAL-ARGS (CDR ARGS)))) + (T + (META-EVAL-SUB (CAR ARGS)) + (SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL) + (META-EVAL-ARGS (CDR ARGS))))) + +(DEFUN META-EVAL-AND-OR (*META-FORM*) + (COND (*META-SUBST-P* + (CONS (CAR *META-FORM*) (META-EVAL-AND-OR-ARGS (CDR *META-FORM*)))) + (T (META-EVAL-AND-OR-ARGS (CDR *META-FORM*))))) + +(DEFMETA-PROP-SPECIAL AND META-EVAL-AND-OR) +(DEFMETA-PROP-SPECIAL OR META-EVAL-AND-OR) + +(DEFMETA-SPECIAL COND + (DO ((FORMS (CDR *META-FORM*) (CDR FORMS)) + (CLAUSE) (NEWBODY)) + ((NULL FORMS) + (COND (*META-SUBST-P* + `(COND ,@(NREVERSE NEWBODY))))) + (AND (ATOM (CAR FORMS)) + (META-EVAL-ERROR "Bad COND clause" (CAR FORMS))) + ; will side-effect *META-IN-CERTAIN-EVAL-CONTEXT-P* + (SETQ CLAUSE (META-EVAL-AND-OR-ARGS (CAR FORMS))) + (AND *META-SUBST-P* + (PUSH CLAUSE NEWBODY)))) + + +(DEFUN META-CALL-SERIES (*META-FORM* + &AUX + (RESULT (META-EVAL-ARGS (CDDR *META-FORM*)))) + (COND (*META-SUBST-P* + (LIST* (CAR *META-FORM*) + (CADR *META-FORM*) + RESULT)))) + +(DEFMETA-PROP-SPECIAL SUBRCALL META-CALL-SERIES) +(DEFMETA-PROP-SPECIAL LSUBRCALL META-CALL-SERIES) +(DEFMETA-PROP-SPECIAL ARRAYCALL META-CALL-SERIES) +(DEFMETA-PROP-SPECIAL ERRSET META-EVAL-ARGS-AND-APPLY) +(DEFMETA-SPECIAL-IDENTITY ARRAY) +(DEFMETA-SPECIAL BREAK ; (BREAK ) + (COND ((= (LENGTH *META-FORM*) 3) + (LET ((RESULT (META-EVAL-SUB (CADDR *META-FORM*)))) + (COND (*META-SUBST-P* + (LIST (CAR *META-FORM*) + (CADR *META-FORM*) + RESULT))))) + (T + (META-EVAL-ERROR "Bad BREAK form" *META-FORM*)))) +(DEFMETA-SPECIAL DEFUN + (META-EVAL-ERROR "DEFUN in the middle of code" *META-FORM*)) +(DEFMETA-SPECIAL EVAL-WHEN + (META-EVAL-ERROR "EVAL-WHEN inside code" *META-FORM*)) + +(DEFMETA-SPECIAL + DECLARE + (COND (*META-SUBST-P* + (CONS 'DECLARE + (MAPCAR #'META-EVAL-ARGS-AND-APPLY + (CDR *META-FORM*)))) + (t + ; this part depends on meta-symeval + (mapc #'(lambda + (dform) + (cond ((atom dform)) + ((eq (car dform) 'special) + (mapc #'(lambda + (var) + (cond ((atom var) + (let ((meta + (get var 'meta-var))) + (cond ((eq meta 'bound)) + (meta + (setf (meta-var-special-p meta) + t)) + (*META-CHECKING-FOR-FREE-VARS-P* + ; a local declaration for + ; a global variable? + ; poo-poo. + nil) + (t nil)))))) + (cdr dform))))) + (cdr *meta-form*))))) + +(DEFMETA-SPECIAL STORE + (OR (= (LENGTH *META-FORM*) 3) + (META-EVAL-ERROR "Wrong number of args to STORE" *META-FORM*)) + (LET ((RES (META-EVAL-ARGS (CDR *META-FORM*)))) + (COND (*META-SUBST-P* + (CONS 'STORE RES))))) + +;;; the obsolete catch and throw. second arg is the tag. un-evaluated. + +(DEFUN META-EVAL-CATCH-THROW (*META-FORM*) + (PROG1 + (CASEQ (LENGTH *META-FORM*) + (2 (META-EVAL-ARGS-AND-APPLY *META-FORM*)) + (3 (COND (*META-SUBST-P* + (LIST* (CAR *META-FORM*) + (META-EVAL-SUB (CADR *META-FORM*)) + (CDDR *META-FORM*))) + (T (META-EVAL-SUB (CADR *META-FORM*))))) + (T + (META-EVAL-ERROR + "Wrong number of args" *META-FORM*))) + (SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL))) + +(DEFMETA-PROP-SPECIAL CATCH meta-eval-catch-throw) +(DEFMETA-PROP-SPECIAL THROW meta-eval-catch-throw) + + +(DEFMETA-PROP-SPECIAL *CATCH META-EVAL-ARGS-AND-APPLY) +(DEFMETA-PROP-SPECIAL CATCHALL META-EVAL-ARGS-AND-APPLY) +(DEFMETA-PROP-SPECIAL CATCH-BARRIER META-EVAL-ARGS-AND-APPLY) +(DEFMETA-PROP-SPECIAL UNWIND-PROTECT META-EVAL-ARGS-AND-APPLY) + +(DEFMETA-SPECIAL ERR + (COND ((> (LENGTH *META-FORM*) 1) + (LET ((RES (META-EVAL-SUB (CADR *META-FORM*)))) + (COND (*META-SUBST-P* + (LIST* 'ERR RES (CDDR *META-FORM*)))))) + (T *META-FORM*))) + +(DEFMETA-PROP-SPECIAL PROGV META-EVAL-ARGS-AND-APPLY) + +#.(PROGN (SETQ DO-NULL-SLOT '%%%DO-NULL-SLOT%%%) NIL) + +(DEFUN DO-INIT-FORM-META-CHECK (U) + (COND ((OR (NULL U) (ATOM U)) + (META-EVAL-ERROR + "Bad DO var iterate form" U)) + ((CDR U) + (META-EVAL-SUB (CADR U))) + (T + '#.DO-NULL-SLOT))) + +(DEFUN DO-ITER-FORM-META-CHECK (U) + (COND ((NULL (CDDR U)) '#.DO-NULL-SLOT) + (T (META-EVAL-SUB (CADDR U))))) + +(DEFMETA-SPECIAL DO ; (DO () ...) + (let ((*meta-in-loop-context-p* *META-IN-LOOP-CONTEXT-P*)) + + (OR (> (LENGTH *META-FORM*) 2) + (META-EVAL-ERROR "Bad DO form" *META-FORM*)) + (AND (CADR *META-FORM*) + (ATOM (CADR *META-FORM*)) + (META-EVAL-ERROR "Bad DO var list" (CADR *META-FORM*))) + (LET (INIT-FORMS ITER-FORMS VARS ENDFORMS BODY) + (COND (*META-SUBST-P* + (SETQ INIT-FORMS + (MAPCAR #'DO-INIT-FORM-META-CHECK + (CADR *META-FORM*)))) + (T (MAPC #'DO-INIT-FORM-META-CHECK (CADR *META-FORM*)))) + (SETQ VARS (MAPCAR #'CAR (CADR *META-FORM*))) + (META-BINDV + VARS + (SETQ *META-IN-LOOP-CONTEXT-P* T) + (AND (OR (NULL (CADDR *META-FORM*)) + (ATOM (CADDR *META-FORM*))) + (META-EVAL-ERROR "Bad end clause in DO" + (CADDR *META-FORM*))) + (SETQ ENDFORMS (META-EVAL-AND-OR-ARGS (CADDR *META-FORM*))) + (COND (*META-SUBST-P* + (SETQ ITER-FORMS + (MAPCAR #'DO-ITER-FORM-META-CHECK + (CADR *META-FORM*)))) + (T (MAPC #'DO-ITER-FORM-META-CHECK + (CADR *META-FORM*)))) + (SETQ BODY (META-EVAL-ARGS (CDDDR *META-FORM*)))) + (COND (*META-SUBST-P* + `(DO ,(MAPCAR + #'(LAMBDA (VAR INIT ITER) + (COND ((EQ INIT + '#.DO-NULL-SLOT) + (LIST VAR)) + ((EQ ITER + '#.DO-NULL-SLOT) + (LIST VAR INIT)) + (T + (LIST VAR INIT ITER)))) + VARS INIT-FORMS ITER-FORMS) + ,ENDFORMS + ,@BODY)))))) + +(DEFMETA-SPECIAL-IDENTITY GCTWA) + +(DEFMETA-SPECIAL SIGNP ; (SIGNP C X) + (OR (= (LENGTH *META-FORM*) 3) + (ERROR "Wrong number of args to SIGNP" *META-FORM*)) + (LET ((RES (META-EVAL-SUB (CADDR *META-FORM*)))) + (COND (*META-SUBST-P* + (LIST 'SIGNP (CADR *META-FORM*) RES))))) + +(DEFUN META-STATUS-SSTATUS-EVAL (*META-FORM*) + (COND ((< (LENGTH *META-FORM*) 3) *META-FORM*) + (T + (CASEQ (CADR *META-FORM*) + ((FEATURE NOFEATURE) *META-FORM*) + (T + (LET ((RESULT (META-EVAL-ARGS (CDDR *META-FORM*)))) + (COND (*META-SUBST-P* + (LIST* (CAR *META-FORM*) + (CADR *META-FORM*) + RESULT))))))))) + + +(DEFMETA-PROP-SPECIAL STATUS META-STATUS-SSTATUS-EVAL) +(DEFMETA-PROP-SPECIAL SSTATUS META-STATUS-SSTATUS-EVAL) + + +; this next are new fsubrs. which have macro properties in the compiler. + +(DEFUN CASEQ-META-EVAL (CASE) + (COND ((ATOM CASE) + (META-EVAL-ERROR "Bad CASEQ clause" CASE)) + (*META-SUBST-P* + (CONS (CAR CASE) (META-EVAL-ARGS (CDR CASE)))) + (T (META-EVAL-ARGS (CDR CASE))))) + +(DEFMETA-SPECIAL CASEQ + (OR (CDR *META-FORM*) + (META-EVAL-ERROR "Bad CASEQ form" *META-FORM*)) + (LET ((CASEQ (META-EVAL-SUB (CADR *META-FORM*)))) + (SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL) + (COND (*META-SUBST-P* + (LIST* 'CASEQ CASEQ + (MAPCAR #'CASEQ-META-EVAL + (CDDR *META-FORM*)))) + (T + (MAPC #'CASEQ-META-EVAL + (CDDR *META-FORM*)))))) + +#+Maclisp +(progn 'compile + +(DEFMETA-SPECIAL PUSH + (META-EVAL-SUB (+INTERNAL-PUSH-X (CDR *META-FORM*) NIL))) +(DEFMETA-SPECIAL POP + (META-EVAL-SUB (+INTERNAL-POP-X (CDR *META-FORM*) NIL))) +(DEFMETA-SPECIAL SETF + (META-EVAL-SUB (+INTERNAL-SETF-X (CDR *META-FORM*) NIL))) + +(SETQ *META-EVAL-MISSING* NIL) +(MAPATOMS #'(LAMBDA (U) + (AND (GET U 'FSUBR) + (NOT (OR (GET U 'MACRO) + (GET U 'META-EVAL))) + (PUSH U *META-EVAL-MISSING*)))) +) + + +#+Maclisp +(defmacro defopen (fname argl &rest body) + `(progn 'compile + (eval-when (compile) + (defprop ,fname (integrate-subr) source-trans) + (defprop ,fname (,(preprocess-argl argl) + ,(preprocess-body body)) + open-coding-info)) + (defun ,fname ,argl ,@body))) + + +#+Maclisp +(defun preprocess-argl (argl) + (mapcar #'(lambda (x) + (if (memq x '(&rest &optional &aux)) + (error "not allowed in defopen, -sorry" x) + x)) + argl)) + +(defun preprocess-body (body) + (if (null (cdr body)) + (car body) + `(Progn ,@body))) + +(defun integrate-subr (form) + (values (integrate-subr-1 form) t)) + +(defun integrate-subr-1 (form) + (let ((info (get (car form) 'open-coding-info))) + (let ((argl (car info)) + (body (cadr info))) + (if (= (length (cdr form)) + (length argl)) + (let ((temps (mapcar #'(lambda (ignore) (gensym)) argl))) + `((lambda ,temps + ,(meta-eval body argl temps)) + ,@(cdr form))) + (integrate-subr-1 (error "wrong number of arguments in form" form + 'wrng-no-args)))))) + diff --git a/src/libmax/mforma.104 b/src/libmax/mforma.104 new file mode 100644 index 00000000..585df733 --- /dev/null +++ b/src/libmax/mforma.104 @@ -0,0 +1,393 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module mforma macro) + +;;; A mini version of FORMAT for macsyma error messages, and other +;;; user interaction. +;;; George J. Carrette - 10:59am Tuesday, 21 October 1980 + +;;; This file is used at compile-time for macsyma system code in general, +;;; and also for MAXSRC;MFORMT > and MAXSRC;MERROR >. +;;; Open-coding of MFORMAT is supported, as are run-time MFORMAT string +;;; interpretation. In all cases syntax checking of the MFORMAT string +;;; at compile-time is done. + +;;; For the prettiest output the normal mode here will be to +;;; cons up items to pass as MTEXT forms. + +;;; Macro definitions for defining a format string interpreter. +;;; N.B. All of these macros expand into forms which contain free +;;; variables, i.e. they assume that they will be expanded in the +;;; proper context of an MFORMAT-LOOP definition. It's a bit +;;; ad-hoc, and not as clean as it should be. +;;; (Macrofy DEFINE-AN-MFORMAT-INTERPRETER, and give the free variables +;;; which are otherwise invisible, better names to boot.) + +;;; There are 3 definitions of MFORMAT. +;;; [1] The interpreter. +;;; [2] The compile-time syntax checker. +;;; [3] The open-compiler. + +;; Some commentary as to what the hell is going on here would be greatly +;; appreciated. This is probably very elegant code, but I can't figure +;; it out. -cwh +;; This is macros defining macros defining function bodies man. +;; top-level side-effects during macroexpansion consing up shit +;; for an interpreter loop. I only do this to save address space (sort of +;; kidding.) -gjc + +(DEFMACRO DEF-MFORMAT (&OPTIONAL (TYPE '||)) + ;; Call to this macro at head of file. + (PUTPROP TYPE NIL 'MFORMAT-OPS) + (PUTPROP TYPE NIL 'MFORMAT-STATE-VARS) + `(PROGN 'COMPILE + (DEFMACRO ,(SYMBOLCONC 'DEF-MFORMAT-OP TYPE) + (CHAR &REST BODY) + `(+DEF-MFORMAT-OP ,',TYPE ,CHAR ,@BODY)) + (DEFMACRO ,(SYMBOLCONC 'DEF-MFORMAT-VAR TYPE) + (VAR VAL INIT) + `(+DEF-MFORMAT-VAR ,',TYPE ,VAR ,VAL ,INIT)) + (DEFMACRO ,(SYMBOLCONC 'MFORMAT-LOOP TYPE) + (&REST ENDCODE) + `(+MFORMAT-LOOP ,',TYPE ,@ENDCODE)))) + +(defmacro +def-mformat-var (TYPE var val INIT-CONDITION) + (LET #+LISPM ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA)) #-LISPM NIL + ;; How about that bullshit LISPM conditionalization put in + ;; by BEE? It is needed of course or else conses will go away. -gjc + (PUSH (LIST VAR VAL) + (CDR (OR (ASSOC INIT-CONDITION (GET TYPE 'MFORMAT-STATE-VARS)) + (CAR (PUSH (NCONS INIT-CONDITION) + (GET TYPE 'MFORMAT-STATE-VARS))))))) + `',VAR) + +(defmacro +def-mformat-op (TYPE char &rest body) + ; can also be a list of CHAR's + (LET #+LISPM ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA)) #-LISPM NIL + (IF (ATOM CHAR) (SETQ CHAR (LIST CHAR))) + (PUSH (CONS CHAR BODY) (GET TYPE 'MFORMAT-OPS)) + `',(MAKNAM (NCONC (EXPLODEN "MFORMAT-") + (MAPCAR #'ASCII CHAR))))) + +(DEFMACRO POP-MFORMAT-ARG () + `(COND ((= ARG-INDEX N) + (ERROR "Ran out of mformat args" (LISTIFY N) 'FAIL-ACT)) + (T (PROGN (SETQ ARG-INDEX (1+ ARG-INDEX)) + (ARG ARG-INDEX))))) + +(DEFMACRO LEFTOVER-MFORMAT-ARGS? () + ;; To be called after we are done. + '(OR (= ARG-INDEX N) + (ERROR "Extra mformat args" (LISTIFY N) 'FAIL-ACT))) + +(DEFMACRO BIND-MFORMAT-STATE-VARS (TYPE &REST BODY) + `(LET ,(DO ((L NIL) + (V (GET TYPE 'MFORMAT-STATE-VARS) (CDR V))) + ((NULL V) L) + (DO ((CONDS (CDR (CAR V)) (CDR CONDS))) + ((NULL CONDS)) + (PUSH (CAR CONDS) L))) + ,@BODY)) + +(DEFMACRO POP-MFORMAT-STRING () + '(IF (NULL STRING) + (ERROR "Runout of MFORMAT string" NIL 'FAIL-ACT) + (POP STRING))) + +(DEFMACRO NULL-MFORMAT-STRING () '(NULL STRING)) +(DEFMACRO TOP-MFORMAT-STRING () + '(IF (NULL STRING) + (ERROR "Runout of MFORMAT string" NIL 'FAIL-ACT) + (CAR STRING))) + +(DEFMACRO CDR-MFORMAT-STRING () + `(SETQ STRING (CDR STRING))) + +(DEFMACRO MFORMAT-DISPATCH-ON-CHAR (TYPE) + `(PROGN (COND ,@(MAPCAR #'(LAMBDA (PAIR) + `(,(IF (ATOM (CAR PAIR)) + `(= CHAR ,(CAR PAIR)) + `(OR-1 ,@(MAPCAR + #'(LAMBDA (C) + `(= CHAR,C)) + (CAR PAIR)))) + ,@(CDR PAIR))) + (GET TYPE 'MFORMAT-OPS)) + ;; perhaps optimize the COND to use ">" "<". + (t + (error "Unknown format op." (ascii char) 'FAIL-ACT))) + ,@(MAPCAR #'(LAMBDA (STATE) + `(IF ,(CAR STATE) + (SETQ ,@(APPLY #'APPEND (CDR STATE))))) + (GET TYPE 'MFORMAT-STATE-VARS)))) + +(DEFMACRO OR-1 (FIRST &REST REST) + ;; So the style warnings for one argument case to OR don't + ;; confuse us. + (IF (NULL REST) FIRST `(OR ,FIRST ,@REST))) + +(DEFMACRO WHITE-SPACE-P (X) + `(MEMBER ,X '(#\LF #\CR #\SP #\TAB #\VT #\FF))) + +(DEFMACRO +MFORMAT-LOOP (TYPE &REST end-code) + `(BIND-MFORMAT-STATE-VARS + ,TYPE + (DO ((CHAR)) + ((NULL-MFORMAT-STRING) + (LEFTOVER-MFORMAT-ARGS?) + ,@end-code) + (SETQ CHAR (POP STRING)) + (COND ((= CHAR #/~) + (DO () + (NIL) + (SETQ CHAR (POP-MFORMAT-STRING)) + (COND ((= CHAR #/@) + (SETQ /@-FLAG T)) + ((= CHAR #/:) + (SETQ /:-FLAG T)) + ((= CHAR #/~) + (PUSH CHAR TEXT-TEMP) + (RETURN NIL)) + ((WHITE-SPACE-P CHAR) + (DO () + ((NOT (WHITE-SPACE-P (TOP-MFORMAT-STRING)))) + (CDR-MFORMAT-STRING)) + (RETURN NIL)) + ((OR (< CHAR #/0) (> CHAR #/9)) + (MFORMAT-DISPATCH-ON-CHAR ,TYPE) + (RETURN NIL)) + (T + (SETQ PARAMETER + (+ (- CHAR #/0) + (* 10. PARAMETER)) + PARAMETER-P T))))) + + (T + (PUSH CHAR TEXT-TEMP)))))) + + +;;; The following definitions of MFORMAT ops are for compile-time, +;;; the runtime definitions are in MFORMT. + +(defvar WANT-OPEN-COMPILED-MFORMAT NIL) +(defvar CANT-OPEN-COMPILE-MFORMAT NIL) + +(DEF-MFORMAT -C) + +(DEF-MFORMAT-VAR-C /:-FLAG NIL T) +(DEF-MFORMAT-VAR-C /@-FLAG NIL T) +(DEF-MFORMAT-VAR-C PARAMETER 0 T) +(DEF-MFORMAT-VAR-C PARAMETER-P NIL T) +(DEF-MFORMAT-VAR-C TEXT-TEMP NIL NIL) +(DEF-MFORMAT-VAR-C CODE NIL NIL) + +(DEFMACRO EMITC (X) + `(PUSH ,X CODE)) + +(DEFMACRO PUSH-TEXT-TEMP-C () + '(AND TEXT-TEMP + (PROGN (EMITC `(PRINC ',(MAKNAM (NREVERSE TEXT-TEMP)) ,STREAM)) + (SETQ TEXT-TEMP NIL)))) + +(DEF-MFORMAT-OP-C (#/% #/&) + (COND (WANT-OPEN-COMPILED-MFORMAT + (PUSH-TEXT-TEMP-C) + (IF (= CHAR #/&) + (EMITC `(CURSORPOS 'A ,STREAM)) + (EMITC `(TERPRI ,STREAM)))))) + +(DEF-MFORMAT-OP-C #/M + (COND (WANT-OPEN-COMPILED-MFORMAT + (PUSH-TEXT-TEMP-C) + (EMITC `(,(IF /:-FLAG 'MGRIND 'DISPLAF) + (,(IF @-FLAG 'GETOP 'PROGN) + ,(POP-MFORMAT-ARG)) + ,STREAM))) + (T (POP-MFORMAT-ARG)))) + +(DEF-MFORMAT-OP-C (#/A #/S) + (COND (WANT-OPEN-COMPILED-MFORMAT + (PUSH-TEXT-TEMP-C) + (EMITC `(,(IF (= CHAR #/A) 'PRINC 'PRIN1) + ,(POP-MFORMAT-ARG) + ,STREAM))) + (T (POP-MFORMAT-ARG)))) + +(DEFUN OPTIMIZE-PRINT-INST (L) + ;; Should remove extra calls to TERPRI around DISPLA. + ;; Mainly want to remove (PRINC FOO NIL) => (PRINC FOO) + ;; although I'm not sure this is correct. geezz. + (DO ((NEW NIL)) + ((NULL L) `(PROGN ,@NEW)) + (LET ((A (POP L))) + (COND ((EQ (CAR A) 'TERPRI) + (COND ((EQ (CADR A) NIL) + (PUSH '(TERPRI) NEW)) + (T (PUSH A NEW)))) + ((AND (EQ (CADDR A) NIL) + (NOT (EQ (CAR A) 'MGRIND))) + (COND ((EQ (CAR A) 'DISPLAF) + (PUSH `(DISPLA ,(CADR A)) NEW)) + (T + (PUSH `(,(CAR A) ,(CADR A)) NEW)))) + (T + (PUSH A NEW)))))) + +(DEFMACRO NORMALIZE-STREAM (STREAM) + STREAM + #+ITS `(IF (EQ ,STREAM 'TERMINAL-IO) + (SETQ ,STREAM 'TYO)) + #-ITS NIL) + +(DEFUN MFORMAT-TRANSLATE-OPEN N + (LET ((STREAM (ARG 1)) + (STRING (EXPLODEN (ARG 2))) + (WANT-OPEN-COMPILED-MFORMAT T) + (CANT-OPEN-COMPILE-MFORMAT NIL) + (ARG-INDEX 2)) + (NORMALIZE-STREAM STREAM) + (MFORMAT-LOOP-C + (PROGN (PUSH-TEXT-TEMP-C) + (IF CANT-OPEN-COMPILE-MFORMAT + (ERROR "CAN'T OPEN COMPILE MFORMAT ON THIS CASE." + (LISTIFY N) + 'FAIL-ACT + )) + (OPTIMIZE-PRINT-INST CODE))))) + +(DEFUN MFORMAT-SYNTAX-CHECK N + (LET ((ARG-INDEX 2) + (STREAM NIL) + (STRING (EXPLODEN (ARG 2))) + (WANT-OPEN-COMPILED-MFORMAT NIL)) + (MFORMAT-LOOP-C NIL))) + + +(defmacro progn-pig (&rest l) `(progn ,@l)) + +(DEFUN PROCESS-MESSAGE-ARGUMENT (X) + ;; Return NIL if we have already processed this + ;; message argument, NCONS of object if not + ;; processed. + (IF (AND (NOT (ATOM X)) + (MEMQ (CAR X) '(OUT-OF-CORE-STRING PROGN-pig))) + NIL + (NCONS (IF (AND (STRINGP X) (STATUS FEATURE ITS)) + `(OUT-OF-CORE-STRING ,X) + `(PROGN-pig ,X))))) + +(DEFUN MFORMAT-TRANSLATE (ARGUMENTS COMPILING?) + (LET (((STREAM STRING . OTHER-SHIT) ARGUMENTS)) + (let ((mess (process-message-argument string))) + (COND ((NULL MESS) NIL) + ('On-the-other-hand + (SETQ MESS (CAR MESS)) + (NORMALIZE-STREAM STREAM) + (IF (AND (STRINGP STRING) COMPILING?) + (LEXPR-FUNCALL #'MFORMAT-SYNTAX-CHECK + STREAM STRING OTHER-SHIT)) + `(,(OR (CDR (ASSOC (+ 2 ; two leading args. + (LENGTH OTHER-SHIT)) + '((2 . *MFORMAT-2) + (3 . *MFORMAT-3) + (4 . *MFORMAT-4) + (5 . *MFORMAT-5)))) + 'MFORMAT) + ,STREAM + ,MESS + ,@OTHER-SHIT)))))) + +(DEFUN MTELL-TRANSLATE (ARGUMENTS COMPILING?) + (LET (((STRING . OTHER-SHIT) ARGUMENTS)) + (LET ((MESS (PROCESS-MESSAGE-ARGUMENT STRING))) + (COND ((NULL MESS) NIL) + ('ON-THE-OTHER-HAND + (SETQ MESS (CAR MESS)) + (IF (AND (STRINGP STRING) COMPILING?) + (LEXPR-FUNCALL #'MFORMAT-SYNTAX-CHECK + NIL STRING OTHER-SHIT)) + `(,(OR (CDR (ASSOC (+ 1 (LENGTH OTHER-SHIT)) + '((1 . MTELL1) + (2 . MTELL2) + (3 . MTELL3) + (4 . MTELL4) + (5 . MTELL5)))) + 'MTELL) + ,MESS + ,@OTHER-SHIT)))))) + +(DEFMACRO MFORMAT-OPEN (STREAM STRING &REST OTHER-SHIT) + (IF (NOT (STRINGP STRING)) + (ERROR "Not a string, can't open-compile the MFORMAT call" + STRING 'FAIL-ACT) + (LEXPR-FUNCALL #'MFORMAT-TRANSLATE-OPEN + STREAM + STRING + OTHER-SHIT))) + +(DEFMACRO MTELL-OPEN (MESSAGE &REST OTHER-SHIT) + `(MFORMAT-OPEN NIL ,MESSAGE . ,OTHER-SHIT)) + +(DEFUN MERROR-TRANSLATE (ARGUMENTS COMPILING?) + (LET (((MESSAGE . OTHER-SHIT) ARGUMENTS)) + (LET ((MESS (PROCESS-MESSAGE-ARGUMENT MESSAGE))) + (COND ((NULL MESS) NIL) + ('ON-THE-OTHER-HAND + (IF (AND (STRINGP MESSAGE) COMPILING?) + (LEXPR-FUNCALL #'MFORMAT-SYNTAX-CHECK + NIL + MESSAGE OTHER-SHIT)) + (SETQ MESS (CAR MESS)) + `(,(OR (CDR (ASSOC (+ 1 (LENGTH OTHER-SHIT)) + '((1 . *MERROR-1) + (2 . *MERROR-2) + (3 . *MERROR-3) + (4 . *MERROR-4) + (5 . *MERROR-5)))) + 'MERROR) + ,MESS + ,@OTHER-SHIT)))))) + +(DEFUN ERRRJF-TRANSLATE (ARGUMENTS COMPILING?) + (LET (((MESSAGE . OTHER-SHIT) ARGUMENTS)) + (LET ((MESS (PROCESS-MESSAGE-ARGUMENT MESSAGE))) + (COND ((NULL MESS) NIL) + ('ON-THE-OTHER-HAND + (IF (AND (STRINGP MESSAGE) COMPILING?) + (LEXPR-FUNCALL #'MFORMAT-SYNTAX-CHECK + NIL + MESSAGE OTHER-SHIT)) + (SETQ MESS (CAR MESS)) + `(,(OR (CDR (ASSOC (+ 1 (LENGTH OTHER-SHIT)) + '((1 . *ERRRJF-1)))) + 'ERRRJF) + ,MESS ,@OTHER-SHIT)))))) +#+PDP10 +(PROGN 'COMPILE + +(DEFUN GET-TRANSLATOR (OP) + (OR (GET OP 'TRANSLATOR) + (GET-TRANSLATOR (ERROR "has no translator" OP 'wrng-type-arg)))) + +(DEFVAR SOURCE-TRANS-DRIVE NIL) +(DEFUN SOURCE-TRANS-DRIVE (FORM) + (LET ((X (FUNCALL (GET-TRANSLATOR (CAR FORM)) (CDR FORM) T))) + (WHEN (AND X SOURCE-TRANS-DRIVE) + (PRINT FORM TYO) + (PRINC "==>" TYO) + (PRINT X TYO)) + (IF (NULL X) (VALUES FORM NIL) (VALUES X T)))) +(DEFUN PUT-SOURCE-TRANS-DRIVE (OP TR) + (PUTPROP OP '(SOURCE-TRANS-DRIVE) 'SOURCE-TRANS) + (PUTPROP OP TR 'TRANSLATOR)) + +(PUT-SOURCE-TRANS-DRIVE 'MFORMAT 'MFORMAT-TRANSLATE) +(PUT-SOURCE-TRANS-DRIVE 'MTELL 'MTELL-TRANSLATE) +(PUT-SOURCE-TRANS-DRIVE 'MERROR 'MERROR-TRANSLATE) +(PUT-SOURCE-TRANS-DRIVE 'ERRRJF 'ERRRJF-TRANSLATE) +) + +;;; Other systems won't get the syntax-checking at compile-time +;;; unless we hook into their way of doing optimizers. diff --git a/src/libmax/module.9 b/src/libmax/module.9 new file mode 100644 index 00000000..b84a6e44 --- /dev/null +++ b/src/libmax/module.9 @@ -0,0 +1,138 @@ +;;-*-LISP-*- +;; +;; Temporary macsyma module definition. +;; The compiler must first load this file, or the file +;; "LIBMAX;MODULE DEF" + +(HERALD MACSYMA-MODULE) + +(DEFPROP MACSYMA-MODULE MACSYMA-MODULE-MACRO MACRO) + +;; These should be structures rather than sets of special variables. + +(DEFVAR NEEDED-MACRO-FILES) +(DEFVAR EVALUATOR-OPTIONS NIL) +(DEFVAR COMPILER-OPTIONS NIL) +(DEFVAR RUNTIME-OPTIONS NIL) + +(DEFVAR NEEDED-MACRO-FILES-RUNTIME NIL) +(DEFVAR EVALUATOR-OPTIONS-RUNTIME NIL) +(DEFVAR COMPILER-OPTIONS-RUNTIME NIL) +(DEFVAR RUNTIME-OPTIONS-RUNTIME NIL) + +(DEFVAR NEEDED-MACRO-FILES-MACRO NIL) +(DEFVAR EVALUATOR-OPTIONS-MACRO NIL) +(DEFVAR COMPILER-OPTIONS-MACRO NIL) +(DEFVAR RUNTIME-OPTIONS-MACRO NIL) + +(DEFVAR LOADED-MACRO-FILES () + "This is really macro files that were attempted to be loaded, + and is used by the annotater. The version property of the + macro file really tells if it is loaded.") + +(OR (MEMQ 'MACSYMA-MODULE LOADED-MACRO-FILES) + (PUSH 'MACSYMA-MODULE LOADED-MACRO-FILES)) + +(DEFVAR LOAD-MACRO-FILE-TELL NIL) +(DEFVAR MACRO-MODULE-LOAD-STACK NIL) + +(DEFUN LOAD-MACRO-FILE (NAME &OPTIONAL (FILE "DSK:LIBMAX;")) + (OR (MEMQ NAME LOADED-MACRO-FILES) + (PUSH NAME LOADED-MACRO-FILES)) + (COND ((GET NAME 'VERSION) + (IF LOAD-MACRO-FILE-TELL + (FORMAT MSGFILES + "~&; ~A version ~A already loaded.~%" + NAME (GET NAME 'VERSION)))) + ('ELSE + (IF LOAD-MACRO-FILE-TELL + (FORMAT MSGFILES + "~&; Attempting to load ~A~%" NAME)) + (IF (MEMQ NAME MACRO-MODULE-LOAD-STACK) + (IF LOAD-MACRO-FILE-TELL + (FORMAT MSGFILES + "~&; but ~A is already being loaded. ~ + Therefore I will punt.~%" + NAME)) + (LET ((MACRO-MODULE-LOAD-STACK + (CONS NAME MACRO-MODULE-LOAD-STACK))) + (LOAD (MERGEF FILE NAME))))))) + +(DEFVAR LOAD-DCL-DATABASE T) + +(DEFUN LOAD-DCL-DATABASE () + (COND (LOAD-DCL-DATABASE + (FORMAT MSGFILES "~&; Loading declarations~%") + (LOAD-DCL-DATABASE-FILE "MAXDOC;DCL FCTNS") + (LOAD-DCL-DATABASE-FILE "MAXDOC;DCL VARS")))) + +(DEFUN LOAD-DCL-DATABASE-FILE (FN) + (LET (STREAM) + (UNWIND-PROTECT + (PROGN (SETQ STREAM (OPEN FN)) + (DO ((FORM)) + ((NULL (SETQ FORM (READ STREAM ())))) + (EVAL (CADR FORM)))) + (AND STREAM (CLOSE STREAM))))) + +(DEFUN MACSYMA-MODULE-MACRO (FORM) + (LET (((NAME . OPTIONS) (CDR FORM))) + (COND ((NULL OPTIONS) + (IF COMPILER-STATE (LOAD-DCL-DATABASE)) + (SETQ NEEDED-MACRO-FILES NEEDED-MACRO-FILES-RUNTIME) + (SETQ EVALUATOR-OPTIONS EVALUATOR-OPTIONS-RUNTIME) + (SETQ COMPILER-OPTIONS COMPILER-OPTIONS-RUNTIME) + (SETQ RUNTIME-OPTIONS RUNTIME-OPTIONS-RUNTIME)) + ((MEMQ 'MACRO OPTIONS) + (SETQ NEEDED-MACRO-FILES NEEDED-MACRO-FILES-MACRO) + (SETQ EVALUATOR-OPTIONS EVALUATOR-OPTIONS-MACRO) + (SETQ COMPILER-OPTIONS COMPILER-OPTIONS-MACRO) + (SETQ RUNTIME-OPTIONS RUNTIME-OPTIONS-MACRO) + (PUSH `(PROGN 'COMPILE + (HERALD ,NAME) + (DEFVAR LOADED-MACRO-FILES NIL) + (OR (MEMQ ',NAME LOADED-MACRO-FILES) + (PUSH ',NAME LOADED-MACRO-FILES))) + RUNTIME-OPTIONS))) + (MAPCAR #'(LAMBDA (U)(APPLY #'LOAD-MACRO-FILE U)) + NEEDED-MACRO-FILES) + (COND ((MEMQ COMPILER-STATE '(MAKLAP COMPILE)) + (mapc #'eval compiler-options) + (ANNOTATE-UNFASL-FILE))) + (IF (NOT COMPILER-STATE) + (mapc #'eval evaluator-options)) + `(progn 'COMPILE ,@runtime-options))) + +(DECLARE (SPECIAL TEST-COMPILATION-P)) + +(DEFUN ANNOTATE-UNFASL-FILE () + (LET ((UNFASL (IF (EQ (CAAR (NAMELIST (CAR CMSGFILES))) 'DSK) + (CAR CMSGFILES) + (CADR CMSGFILES)))) + (FORMAT UNFASL "~%;; Macsyma ~:[test~;installation~] compilation by ~A.~%" + (AND (NOT (AND (BOUNDP 'TEST-COMPILATION-P) + TEST-COMPILATION-P)) + (STATUS FEATURE MACSYMA-COMPLR)) + (STATUS UNAME)) + (FORMAT UNFASL + ";; Macsyma compilation environment version ~A~%;; dumped on ~A by ~A~%" + (GET 'MCOMPILER 'VERSION) + (GET 'MCOMPILER 'DATE) + (GET 'MCOMPILER 'UNAME)) + (FORMAT UNFASL ";; ~15A" "Macro files:") + (FORMAT UNFASL "~{~<~%;; ~15X~:;~A ~A~>~^, ~}~%" + (MAPCAN #'(LAMBDA (X) `(,X ,(GET X 'VERSION))) + LOADED-MACRO-FILES) + ))) + + +(DEFUN AUTOLOAD-MACRO (NAME FILE &OPTIONAL (FUNCTION (SYMBOLCONC NAME '| MACRO|))) + (COND ((NOT (GET NAME 'MACRO)) + (PUTPROP NAME FUNCTION 'MACRO) + (PUTPROP FUNCTION FILE 'AUTOLOAD)))) + + +;; Compiler and Evaluator Options, get 'em from another file, for +;; ease of hackery! + +(LOAD "DSK:LIBMAX;MODULE OPTIONS") diff --git a/src/libmax/module.option b/src/libmax/module.option new file mode 100644 index 00000000..e34a31ed --- /dev/null +++ b/src/libmax/module.option @@ -0,0 +1,132 @@ +;;-*-LISP-*- +;; Evaluator, Compiler, and Runtime options for macsyma source files. + +;; Various autoloads + +(PUTPROP 'Y-OR-N-P "LIBMAX;LMRUN" 'AUTOLOAD) + +(AUTOLOAD-MACRO 'LOOP "LIBLSP;LOOP" 'LOOP-TRANSLATE) +;; This probably isn't used any more. Replacement is Lispm +;; WITH-OPEN-FILE form. The only place which might use it would +;; be LIBMAX;DEFINE, which should be converted. -cwh +(AUTOLOAD-MACRO 'PHI "LIBLSP;IOTA") +(AUTOLOAD-MACRO 'DEFSTRUCT "LIBLSP;STRUCT") +(AUTOLOAD-MACRO 'TRANSL-MODULE "LIBMAX;TRANSM") +(AUTOLOAD-MACRO 'GCALL-BIND "LIBMAX;NUMMAC") +(AUTOLOAD-MACRO 'DEF-PROCEDURE-PROPERTY "LIBMAX;PROCS") +(AUTOLOAD-MACRO 'CALL-PROCEDURE-PROPERTY "LIBMAX;PROCS") +(AUTOLOAD-MACRO 'DEFCLOSURE "LIBMAX;CLOSE") +(AUTOLOAD-MACRO 'CALL "LIBMAX;CLOSE") +(AUTOLOAD-MACRO 'DEF-OPTIONS "LIBMAX;OPSHIN") +(AUTOLOAD-MACRO '|DEF#\SYMBOL| "LIBMAX;READM") + +(DEFPROP PARSE-OPTION-HEADER "LIBMAX;OPSHIN" AUTOLOAD) +(DEFPROP META-EVAL "LIBMAX;META" AUTOLOAD) + + +;; RUNTIME, to support files used by the macsyma user. + +(SETQ NEEDED-MACRO-FILES-RUNTIME + '((LMMAC) + (MAXMAC) + (DEFINE) + (MOPERS) + (UMLMAC "DSK:LISP;"))) + + + +(SETQ EVALUATOR-OPTIONS-RUNTIME +'( + ;; This switch controls whether DEFUN uses the ARGS property for argument count + ;; checking or generates in-line code and error messages. When disabled, a + ;; message like "between 2 to 4 arguments expected" will be printed. When + ;; enabled, something like "EXP and VAR are required arguments; UPPER-BOUND and + ;; LOWER-BOUND are optional" can be printed since the arglist will be saved. + ;; At eval time, this is enabled to facilitate debugging. At compile time, + ;; this is disabled to save address space. This can be overridden locally for + ;; files which want to print more informative error messages. + (SETQ DEFUN&-CHECK-ARGS T) + ;; Some conditionalizations depend upon the machine architecture and not the + ;; operating system. This allows one to distinguish between them, i.e. one + ;; should do #+PDP10 rather than #+(OR ITS DEC20). + ;; Turn on (STATUS FEATURE GC) to include gc code. + (SSTATUS FEATURE PDP10) + (SSTATUS FEATURE GC) + ;; To facilitate debugging, don't displace macros. This prevents repeated + ;; expansion, but makes life easier for programs like STEP which don't know + ;; about MACROEXPANDED. + (SETQ MACRO-EXPANSION-USE 'MACROMEMO) + ;; so old code gets gc'd, flush it from the Macromemo hash table!!! + (FLUSH-MACROMEMOS () ()) + + ;; This guy has an icky macro properties in the compiler. + + (DEFUN MTELL-OPEN (&REST L) (APPLY #'MFORMAT (CONS NIL L))) + (DEFUN MFORMAT-OPEN (&REST L) (APPLY #'MFORMAT L)) + + ;; Use a winning FSUBR for LET in the interpreter. + ;; Saves core and eyestrain. + (PROGN (DEFPROP LET LETFEX FEXPR) + (DEFPROP LET* LET*FEX FEXPR) + (DEFPROP DESETQ DESETQFEX FEXPR) + (DEFPROP LETFEX |DSK:LIBLSP;LETFEX FASL| AUTOLOAD) + (DEFPROP LET*FEX |DSK:LIBLSP;LETFEX FASL| AUTOLOAD) + (DEFPROP DESETQFEX |DSK:LIBLSP;LETFEX FASL| AUTOLOAD)) + )) + +(SETQ COMPILER-OPTIONS-RUNTIME +'((SETQ DEFUN&-CHECK-ARGS NIL) + ;; Don't place macros in the fasl file. Don't load DEFMAX package at runtime. + ;; Macro packages should include LIBMAX;MPRELU >. Should macro calls be + ;; displaced at eval time? There are good arguments for and against this. + (SETQ DEFMACRO-FOR-COMPILING NIL) + (SETQ DEFMACRO-DISPLACE-CALL NIL) + (MACROS NIL) + ;; Use an ASCII encoding scheme (rather than SIXBIT) for in line messages + ;; produced by PRINC of a string or symbol. This should be on by default. + (SETQ USE-STRT7 T) + (setq ibase 10. base 10. *nopoint nil) + ;; FEATURES: + (SSTATUS FEATURE PDP10) + (SSTATUS FEATURE GC) + ;; When compiling via :CL, don't bother splitting up files. + ;; Only split when debugging via :MCL. + (COND ((NOT (STATUS FEATURE MACSYMA-COMPLR)) + (DEFUN SPLITFILE FEXPR (X) NIL))) + (LOAD-MACSYMA-MACROS MFORMA ERMSGC) + )) + +(SETQ RUNTIME-OPTIONS-RUNTIME NIL) + + +;; MACRO, to support files used by macsyma system programmers to make +;; RUNTIME files. i.e. various syntactical extensions to the system. + +(SETQ NEEDED-MACRO-FILES-MACRO + '((UMLMAC "DSK:LISP;") + (MAXMAC) + (LMMAC) + (MFORMA))) + +(SETQ EVALUATOR-OPTIONS-MACRO +'( + ;; FEATURES: + (STATUS FEATURE PDP10) + )) + +(SETQ COMPILER-OPTIONS-MACRO +'( + ;; Make DEFUN generate inline code for args checking. This is only + ;; for compile and eval time usage, so we don't lose anything. + (SETQ DEFUN&-CHECK-ARGS T) + ;; Compile macros and put them in the fasl file. + (SETQ DEFMACRO-FOR-COMPILING T) + (MACROS T) + ;; Use an ASCII encoding scheme (rather than SIXBIT) for in line messages + ;; produced by PRINC of a string or symbol. + (SETQ USE-STRT7 T) + ;; FEATURES: + (STATUS FEATURE PDP10) + )) + +(SETQ RUNTIME-OPTIONS-MACRO NIL) diff --git a/src/libmax/mopers.48 b/src/libmax/mopers.48 new file mode 100644 index 00000000..3348d5e6 --- /dev/null +++ b/src/libmax/mopers.48 @@ -0,0 +1,119 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module mopers macro) +(load-macsyma-macros defopt) +(load-macsyma-macros-at-runtime 'defopt) + +;; This file is the compile-time half of the OPERS package, an interface to the +;; Macsyma general representaton simplifier. When new expressions are being +;; created, the macros in this file or the functions in NOPERS should be called +;; rather than the entrypoints in SIMP such as SIMPLIFYA or SIMPLUS. + +;; The basic functions are ADD, SUB, MUL, DIV, POWER, NCMUL, NCPOWER, INV. +;; Each of these functions assume that their arguments are simplified. Some +;; functions will have a "*" adjoined to the end of the name (as in ADD*). +;; These do not assume that their arguments are simplified. The above +;; functions are the only entrypoints to this package. + +;; The functions ADD2, MUL2, and MUL3 are for use internal to this package +;; and should not be called externally. + +;; I have added the macro DEFGRAD as an interface to the $DERIVATIVE function +;; for use by macsyma programers who want to do a bit of lisp programming. -GJC + +(defmacro =0 (x) `(equal ,x 0)) +(defmacro =1 (x) `(equal ,x 1)) + +;; Addition -- call ADD with simplified operands; ADD* with unsimplified +;; operands. + +(defopt add (&rest terms) + (cond ((= (length terms) 2) `(add2 . ,terms)) + (t `(addn (list . ,terms) t)))) + +(defopt add* (&rest terms) + (cond ((= (length terms) 2) `(add2* . ,terms)) + (t `(addn (list . ,terms) nil)))) + +;; Multiplication -- call MUL or NCMUL with simplified operands; MUL* or NCMUL* +;; with unsimplified operands. + +(defopt mul (&rest factors) + (cond ((= (length factors) 2) `(mul2 . ,factors)) + ((= (length factors) 3) `(mul3 . ,factors)) + (t `(muln (list . ,factors) t)))) + +(defopt mul* (&rest factors) + (cond ((= (length factors) 2) `(mul2* . ,factors)) + (t `(muln (list . ,factors) nil)))) + +;; the rest here can't be DEFOPT's because there aren't interpreted versions yet. + +(defmacro inv (x) `(power ,x -1)) +(defmacro inv* (x) `(power* ,x -1)) + +(defmacro ncmul (&rest factors) + (cond ((= (length factors) 2) `(ncmul2 . ,factors)) + (t `(ncmuln (list . ,factors) t)))) + +;; (TAKE '(%TAN) X) = tan(x) +;; This syntax really loses. Not only does this syntax lose, but this macro +;; has to look like a subr. Otherwise, the definition would look like +;; (DEFMACRO TAKE ((NIL (OPERATOR)) . ARGS) ...) + +;; (TAKE A B) --> (SIMPLIFYA (LIST A B) T) +;; (TAKE '(%SIN) A) --> (SIMP-%SIN (LIST '(%SIN) A) 1 T) + +(defmacro take (operator &rest args &aux simplifier) + (setq simplifier + (and (not (atom operator)) + (eq (car operator) 'quote) + (cdr (assq (caadr operator) '((%atan . simp-%atan) + (%tan . simp-%tan) + (%log . simpln) + (mabs . simpabs) + (%sin . simp-%sin) + (%cos . simp-%cos) + ($atan2 . simpatan2) + ))))) + (cond (simplifier `(,simplifier (list ,operator . ,args) 1 t)) + (t `(simplifya (list ,operator . ,args) t)))) + +(defmacro min%i () ''((MTIMES SIMP) -1 $%I)) ;-%I +(defmacro 1//2 () ''((RAT SIMP) 1 2)) ;1/2 +(defmacro half () ''((RAT SIMP) 1 2)) ;1/2 +(defmacro I//2 () ''((MTIMES SIMP) ((RAT SIMP) 1 2) $%I)) ;%I/2 + +;; On PDP-10s, this is a function so as to save address space. A one argument +;; call is shorter than a two argument call, and this function is called +;; several places. In Franz, Multics, and the LISPM, this macros out on the +;; assumption that calls are more expensive than the additional memory. + +#+(or Lispm Multics Franz) +(defopt simplify (x) `(simplifya ,x nil)) + + +;; Multics Lisp is broken in that it doesn't grab the subr definition +;; when applying. If the macro definition is there first, it tries that and +;; loses. +#+Multics (if (get 'simplify 'subr) (remprop 'simplify 'macro)) + +;; A hand-made DEFSTRUCT for dealing with the Macsyma MDO structure. +;; Used in GRAM, etc. for storing/retrieving from DO structures. + +(DEFMACRO MAKE-MDO () '(LIST (LIST 'MDO) NIL NIL NIL NIL NIL NIL NIL)) + +(DEFMACRO MDO-OP (X) `(CAR (CAR ,X))) + +(DEFMACRO MDO-FOR (X) `(CAR (CDR ,X))) +(DEFMACRO MDO-FROM (X) `(CAR (CDDR ,X))) +(DEFMACRO MDO-STEP (X) `(CAR (CDDDR ,X))) +(DEFMACRO MDO-NEXT (X) `(CAR (CDDDDR ,X))) +(DEFMACRO MDO-THRU (X) `(CAR (CDR (CDDDDR ,X)))) +(DEFMACRO MDO-UNLESS (X) `(CAR (CDDR (CDDDDR ,X)))) +(DEFMACRO MDO-BODY (X) `(CAR (CDDDR (CDDDDR ,X)))) + +(DEFMACRO DEFGRAD (NAME ARGUMENTS . BODY) + `(DEFPROP ,NAME (,ARGUMENTS . ,BODY) GRAD)) diff --git a/src/libmax/mopers.49 b/src/libmax/mopers.49 new file mode 100755 index 00000000..1ba3a390 --- /dev/null +++ b/src/libmax/mopers.49 @@ -0,0 +1,119 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module mopers macro) +(load-macsyma-macros defopt) +(load-macsyma-macros-at-runtime 'defopt) + +;; This file is the compile-time half of the OPERS package, an interface to the +;; Macsyma general representaton simplifier. When new expressions are being +;; created, the macros in this file or the functions in NOPERS should be called +;; rather than the entrypoints in SIMP such as SIMPLIFYA or SIMPLUS. + +;; The basic functions are ADD, SUB, MUL, DIV, POWER, NCMUL, NCPOWER, INV. +;; Each of these functions assume that their arguments are simplified. Some +;; functions will have a "*" adjoined to the end of the name (as in ADD*). +;; These do not assume that their arguments are simplified. The above +;; functions are the only entrypoints to this package. + +;; The functions ADD2, MUL2, and MUL3 are for use internal to this package +;; and should not be called externally. + +;; I have added the macro DEFGRAD as an interface to the $DERIVATIVE function +;; for use by macsyma programers who want to do a bit of lisp programming. -GJC + +(defmacro =0 (x) `(equal ,x 0)) +(defmacro =1 (x) `(equal ,x 1)) + +;; Addition -- call ADD with simplified operands; ADD* with unsimplified +;; operands. + +(defopt add (&rest terms) + (cond ((= (length terms) 2) `(add2 . ,terms)) + (t `(addn (list . ,terms) t)))) + +(defopt add* (&rest terms) + (cond ((= (length terms) 2) `(add2* . ,terms)) + (t `(addn (list . ,terms) nil)))) + +;; Multiplication -- call MUL or NCMUL with simplified operands; MUL* or NCMUL* +;; with unsimplified operands. + +(defopt mul (&rest factors) + (cond ((= (length factors) 2) `(mul2 . ,factors)) + ((= (length factors) 3) `(mul3 . ,factors)) + (t `(muln (list . ,factors) t)))) + +(defopt mul* (&rest factors) + (cond ((= (length factors) 2) `(mul2* . ,factors)) + (t `(muln (list . ,factors) nil)))) + +;; the rest here can't be DEFOPT's because there aren't interpreted versions yet. + +(defmacro inv (x) `(power ,x -1)) +(defmacro inv* (x) `(power* ,x -1)) + +(defmacro ncmul (&rest factors) + (cond ((= (length factors) 2) `(ncmul2 . ,factors)) + (t `(ncmuln (list . ,factors) t)))) + +;; (TAKE '(%TAN) X) = tan(x) +;; This syntax really loses. Not only does this syntax lose, but this macro +;; has to look like a subr. Otherwise, the definition would look like +;; (DEFMACRO TAKE ((NIL (OPERATOR)) . ARGS) ...) + +;; (TAKE A B) --> (SIMPLIFYA (LIST A B) T) +;; (TAKE '(%SIN) A) --> (SIMP-%SIN (LIST '(%SIN) A) 1 T) + +(defmacro take (operator &rest args &aux simplifier) + (setq simplifier + (and (not (atom operator)) + (eq (car operator) 'quote) + (cdr (assq (caadr operator) '((%atan . simp-%atan) + (%tan . simp-%tan) + (%log . simpln) + (mabs . simpabs) + (%sin . simp-%sin) + (%cos . simp-%cos) + ($atan2 . simpatan2) + ))))) + (cond (simplifier `(,simplifier (list ,operator . ,args) 1 t)) + (t `(simplifya (list ,operator . ,args) t)))) + +(defmacro min%i () ''((MTIMES SIMP) -1 $%I)) ;-%I +(defmacro 1//2 () ''((RAT SIMP) 1 2)) ;1/2 +(defmacro half () ''((RAT SIMP) 1 2)) ;1/2 +(defmacro I//2 () ''((MTIMES SIMP) ((RAT SIMP) 1 2) $%I)) ;%I/2 + +;; On PDP-10s, this is a function so as to save address space. A one argument +;; call is shorter than a two argument call, and this function is called +;; several places. In Franz, Multics, and the LISPM, this macros out on the +;; assumption that calls are more expensive than the additional memory. + +#+(or Lispm Multics Franz NIL) +(defopt simplify (x) `(simplifya ,x nil)) + + +;; Multics Lisp is broken in that it doesn't grab the subr definition +;; when applying. If the macro definition is there first, it tries that and +;; loses. +#+Multics (if (get 'simplify 'subr) (remprop 'simplify 'macro)) + +;; A hand-made DEFSTRUCT for dealing with the Macsyma MDO structure. +;; Used in GRAM, etc. for storing/retrieving from DO structures. + +(DEFMACRO MAKE-MDO () '(LIST (LIST 'MDO) NIL NIL NIL NIL NIL NIL NIL)) + +(DEFMACRO MDO-OP (X) `(CAR (CAR ,X))) + +(DEFMACRO MDO-FOR (X) `(CAR (CDR ,X))) +(DEFMACRO MDO-FROM (X) `(CAR (CDDR ,X))) +(DEFMACRO MDO-STEP (X) `(CAR (CDDDR ,X))) +(DEFMACRO MDO-NEXT (X) `(CAR (CDDDDR ,X))) +(DEFMACRO MDO-THRU (X) `(CAR (CDR (CDDDDR ,X)))) +(DEFMACRO MDO-UNLESS (X) `(CAR (CDDR (CDDDDR ,X)))) +(DEFMACRO MDO-BODY (X) `(CAR (CDDDR (CDDDDR ,X)))) + +(DEFMACRO DEFGRAD (NAME ARGUMENTS . BODY) + `(DEFPROP ,NAME (,ARGUMENTS . ,BODY) GRAD)) diff --git a/src/libmax/mrgmac.21 b/src/libmax/mrgmac.21 new file mode 100644 index 00000000..f360495e --- /dev/null +++ b/src/libmax/mrgmac.21 @@ -0,0 +1,357 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module mrgmac macro) + +#-LISPM +(DEFMACRO FIX-LM BODY + `(PROGN . ,BODY)) + +#+LISPM +(DEFMACRO FIX-LM (&BODY BODY) + `(LET ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA)) + . ,BODY)) + +;; The GRAM and DISPLA packages manipulate lists of fixnums, representing +;; lists of characters. This syntax facilitates typing them in. +;; {abc} reads as (#/a #/b #/c), unquoted. + +(DEFUN CHAR-LIST-SYNTAX-ON () + (FIX-LM + (SETSYNTAX '/{ 'MACRO + #'(LAMBDA () (DO ((C (TYI) (TYI)) (NL)) + ((= #/} C) (NREVERSE NL)) + (SETQ NL (CONS C NL))))) + T)) + +(DEFUN CHAR-LIST-SYNTAX-OFF () + (FIX-LM + #+(OR MACLISP NIL) (SETSYNTAX '/{ 'MACRO NIL) + #+Franz (setsyntax '/{ 2) + #+LISPM (SET-SYNTAX-FROM-DESCRIPTION #/{ 'SI:ALPHABETIC))) + +;; This sets up the syntax for a simple mode system defined later on +;; in this file. As usual, it is poorly documented. + +(DEFUN MODE-SYNTAX-ON () + ;; :A:B:C --> (SEL A B C) + ;; A component selection facility. :A:B:C is like (C (B A)) in the + ;; DEFSATRUCT world. + (FIX-LM + (SETSYNTAX '/: 'MACRO + #'(LAMBDA () (DO ((L (LIST (READ)) (CONS (READ) L))) + ((NOT (= #/: (TYIPEEK))) (CONS 'SEL (NREVERSE L))) + (TYI)))) + + ;; --> (SELECTOR A B C) Used when defining a mode. + (SETSYNTAX '/< 'MACRO + #'(LAMBDA () + (COND ((= #\SPACE (TYIPEEK)) '|<|) + ((= #/= (TYIPEEK)) (TYI) '|<=|) + (T (DO ((S (READ) (READ)) (NL)) + ((EQ '/> S) (CONS 'SELECTOR (NREVERSE NL))) + (SETQ NL (CONS S NL))))))) + + ;; Needed as a single character object. Used when defining a mode. + (SETSYNTAX '/> 'MACRO + #'(LAMBDA () + (COND ((NOT (= #/= (TYIPEEK))) '/>) + (T (TYI) '|>=|)))) + T)) + +(DEFUN MODE-SYNTAX-OFF () + (FIX-LM + #+(OR MACLISP NIL) (PROGN (SETSYNTAX '/: 'MACRO NIL) + (SETSYNTAX '/< 'MACRO NIL) + (SETSYNTAX '/> 'MACRO NIL)) + #+LISPM (PROGN (SI:SET-SYNTAX-BITS #/: '(0 . 23)) + (SET-SYNTAX-FROM-DESCRIPTION #/> 'SI:ALPHABETIC) + (SET-SYNTAX-FROM-DESCRIPTION #/< 'SI:ALPHABETIC)) + #+Franz (progn (setsyntax '/: 2) + (setsyntax '/< 2) + (setsyntax '/> 2)))) + +;; Loading this file used to turn on the mode syntax. Its been turned off +;; now and hopefully no files left rely on it. Files which want to +;; use that syntax should call (MODE-SYNTAX-ON) during read time. + +#+MACLISP +(DEFUN DEFINE-MACRO (NAME LAMBDA-EXP) + (PUTPROP NAME LAMBDA-EXP 'MACRO)) + +#+LISPM +(DEFUN DEFINE-MACRO (NAME LAMBDA-EXP) + (FIX-LM + (COND ((ATOM LAMBDA-EXP) (SETQ LAMBDA-EXP (FSYMEVAL LAMBDA-EXP)))) + (FSET NAME (CONS 'MACRO LAMBDA-EXP)))) + +#+Franz +(defun define-macro (name lambda-exp) + (putd name `(macro (dummy-arg) (,lambda-exp dummy-arg)))) + +#+NIL +(DEFUN DEFINE-MACRO (NAME LAMBDA-EXP) + (ADD-MACRO-DEFINITION NAME LAMBDA-EXP)) + +;; LAMBIND* and PROGB* are identical, similar to LET, but contain an implicit +;; PROG. On the Lisp Machine, PROG is extended to provide this capability. + +(DEFMACRO LAMBIND* (VAR-LIST . BODY) `(LET ,VAR-LIST (PROG NIL . ,BODY))) +(DEFMACRO PROGB* (VAR-LIST . BODY) `(LET ,VAR-LIST (PROG NIL . ,BODY))) + +(DEFUN MAPAND MACRO (X) + `(DO ((L ,(CADDR X) (CDR L))) ((NULL L) T) + (IFN (,(CADR X) (CAR L)) (RETURN NIL)))) + +(DEFUN MAPOR MACRO (X) + `(DO L ,(CADDR X) (CDR L) (NULL L) + (IF (FUNCALL ,(CADR X) (CAR L)) (RETURN T)))) + +;; (MAPLAC #'1+ '(1 2 3)) --> '(2 3 4), but the original list is rplaca'd +;; rather than a new list being consed up. + +(DEFMACRO MAPLAC (FUNCTION LIST) + `(DO L ,LIST (CDR L) (NULL L) (RPLACA L (FUNCALL ,FUNCTION (CAR L))))) + +(DEFUN PUT MACRO (X) `(PUTPROP . ,(CDR X))) +(DEFUN REM MACRO (X) `(REMPROP . ,(CDR X))) + +(DEFMACRO COPYP (L) `(CONS (CAR ,L) (CDR ,L))) +(DEFMACRO COPYL (L) `(APPEND ,L NIL)) + +(DEFMACRO ECONS (X Y) `(APPEND ,X (LIST ,Y))) + +#-Franz +(progn 'compile + (DEFMACRO CAAADAR (X) `(CAAADR (CAR ,X))) + (DEFMACRO CAAADDR (X) `(CAAADR (CDR ,X))) + (DEFMACRO CAADAAR (X) `(CAADAR (CAR ,X))) + (DEFMACRO CAADADR (X) `(CAADAR (CDR ,X))) + (DEFMACRO CADAAAR (X) `(CADAAR (CAR ,X))) + (DEFMACRO CADADDR (X) `(CADADR (CDR ,X))) + (DEFMACRO CADDAAR (X) `(CADDAR (CAR ,X))) + (DEFMACRO CADDDAR (X) `(CADDDR (CAR ,X))) + (DEFMACRO CDADADR (X) `(CDADAR (CDR ,X))) + (DEFMACRO CDADDDR (X) `(CDADDR (CDR ,X))) + (DEFMACRO CDDDDDR (X) `(CDDDDR (CDR ,X)))) + +(DEFMACRO TELL (&REST ARGS) `(DISPLA (LIST '(MTEXT) . ,ARGS))) + + + +(DECLARE (SPECIAL NAME BAS MOBJECTS SELECTOR) (*EXPR MODE)) + +(SETQ MOBJECTS NIL) + +(DEFPROP MODE (C-MODE S-MODE A-MODE) MODE) + +(DEFUN C-MODE MACRO (X) `(LIST . ,(CDR X))) + +(DEFUN S-MODE MACRO (X) + (COND ((EQ 'C (CADDR X)) `(CAR ,(CADR X))) + ((EQ 'SEL (CADDR X)) `(CADR ,(CADR X))) + ((EQ '_ (CADDR X)) `(CADDR ,(CADR X))))) + +(DEFUN A-MODE MACRO (X) + (COND ((EQ 'C (CADDR X)) `(RPLACA (CADR X) ,(CADDDR X))) + ((EQ 'SEL (CADDR X)) `(RPLACA (CDR ,(CADR X)) ,(CADDDR X))) + ((EQ '_ (CADDR X)) `(RPLACA (CDDR ,(CADR X)) ,(CADDDR X))))) + +(DEFUN DEFMODE MACRO (X) + (LET ((SELECTOR (MEMQ 'SELECTOR (CDDDDR X)))) + (DEFINE-MODE (CADR X) (CADDDR X)) + (MAPC 'EVAL (CDDDDR X)) + `',(CADR X))) + +(DEFUN DEFINE-MODE (NAME DESC) + (PROG (C S A DUMMY) + (SETQ DUMMY (EXPLODEC NAME) + C (IMPLODE (APPEND '(C -) DUMMY)) + S (IMPLODE (APPEND '(S -) DUMMY)) + A (IMPLODE (APPEND '(A -) DUMMY))) + (DEFINE-MACRO C (DEFC DESC)) + (DEFINE-MACRO S (DEFS DESC)) + (DEFINE-MACRO A (DEFA DESC)) + (PUT NAME (C-MODE C S A) 'MODE) + (RETURN NAME))) + + +(DEFUN DEFC (DESC) (LET ((BAS 'X)) `(LAMBDA (X) ,(DEFC1 DESC)))) + +(DEFUN DEFC1 (DESC) + (COND ((ATOM DESC) (LIST 'QUOTE DESC)) + ((EQ 'SELECTOR (CAR DESC)) + (COND ((NOT (NULL (CDDDR DESC))) (LIST 'QUOTE (CADDDR DESC))) + (T (SETQ BAS (LIST 'CDR BAS)) + (LIST 'CAR BAS)))) + ((EQ 'ATOM (CAR DESC)) + `(LIST 'C-ATOM '',(MAPCAR 'CADR (CDR DESC)) (CONS 'LIST (CDR X)))) + ((EQ 'CONS (CAR DESC)) `(LIST 'CONS ,(DEFC1 (CADR DESC)) ,(DEFC1 (CADDR DESC)))) + ((EQ 'LIST (CAR DESC)) + (DO ((L (CDR DESC) (CDR L)) (NL)) + ((NULL L) `(LIST 'LIST . ,(NREVERSE NL))) + (SETQ NL (CONS (DEFC1 (CAR L)) NL)))) + ((EQ 'STRUCT (CAR DESC)) (DEFC1 (CONS 'LIST (CDR DESC)))) + (T (LIST 'QUOTE DESC)))) + + +(DEFUN DEFS (DESC) + `(LAMBDA (X) (COND . ,(NREVERSE (DEFS1 DESC '(CADR X) NIL))))) + +(DEFUN DEFS1 (DESC BAS RESULT) + (COND ((ATOM DESC) RESULT) + ((EQ 'SELECTOR (CAR DESC)) + (PUT (CADR DESC) (CONS (CONS NAME (CADDR DESC)) (GET (CADR DESC) 'MODES)) 'MODES) + (PUT NAME (CONS (CONS (CADR DESC) (CADDR DESC)) (GET NAME 'SELS)) 'SELS) + (IF SELECTOR (DEFINE-MACRO (CADR DESC) 'SELECTOR)) + (CONS `((EQ ',(CADR DESC) (CADDR X)) ,BAS) RESULT)) + ((EQ 'ATOM (CAR DESC)) + (DO L (CDR DESC) (CDR L) (NULL L) + (PUT (CADAR L) (CONS (CONS NAME (CADDAR L)) (GET (CADAR L) 'MODES)) 'MODES) + (PUT NAME (CONS (CONS (CADAR L) (CADDAR L)) (GET NAME 'SELS)) 'SELS) + (IF SELECTOR (DEFINE-MACRO (CADAR L) 'SELECTOR))) + (CONS `((MEMQ (CADDR X) ',(MAPCAR 'CADR (CDR DESC))) (LIST 'GET ,BAS (LIST 'QUOTE (CADDR X)))) + RESULT)) + ((EQ 'CONS (CAR DESC)) + (SETQ RESULT (DEFS1 (CADR DESC) `(LIST 'CAR ,BAS) RESULT)) + (DEFS1 (CADDR DESC) `(LIST 'CDR ,BAS) RESULT)) + ((EQ 'LIST (CAR DESC)) + (DO L (CDR DESC) (CDR L) (NULL L) + (SETQ RESULT (DEFS1 (CAR L) `(LIST 'CAR ,BAS) RESULT) + BAS `(LIST 'CDR ,BAS))) + RESULT) + ((EQ 'STRUCT (CAR DESC)) (DEFS1 (CONS 'LIST (CDR DESC)) BAS RESULT)) + (T RESULT))) + +(DEFUN DEFA (DESC) + `(LAMBDA (X) (COND . ,(NREVERSE (DEFA1 DESC '(CADR X) NIL NIL))))) + +(DEFUN DEFA1 (DESC BAS CDR RESULT) + (COND ((ATOM DESC) RESULT) + ((EQ 'SELECTOR (CAR DESC)) + (SETQ BAS (COND ((NOT CDR) `(LIST 'CAR (LIST 'RPLACA ,(CADDR BAS) (CADDDR X)))) + (T `(LIST 'CDR (LIST 'RPLACD ,(CADDR BAS) (CADDDR X)))))) + (CONS `((EQ ',(CADR DESC) (CADDR X)) ,BAS) RESULT)) + ((EQ 'ATOM (CAR DESC)) + (LIST `(T (LIST 'A-ATOM (CADR X) (LIST 'QUOTE (CADDR X)) (CADDDR X))))) + ((EQ 'CONS (CAR DESC)) + (SETQ RESULT (DEFA1 (CADR DESC) `(LIST 'CAR ,BAS) NIL RESULT)) + (DEFA1 (CADDR DESC) `(LIST 'CDR ,BAS) T RESULT)) + ((EQ 'LIST (CAR DESC)) + (DO L (CDR DESC) (CDR L) (NULL L) + (SETQ RESULT (DEFA1 (CAR L) `(LIST 'CAR ,BAS) NIL RESULT) + BAS `(LIST 'CDR ,BAS))) + RESULT) + ((EQ 'STRUCT (CAR DESC)) (DEFA1 (CONS 'LIST (CDR DESC)) BAS CDR RESULT)) + (T RESULT))) + + +(DEFUN MODE (X) (CDR (ASSOC X MOBJECTS))) + +#-NIL +(DEFUN MODEDECLARE FEXPR (X) + (MAPC '(LAMBDA (L) (MAPC '(LAMBDA (V) (PUSH (CONS V (CAR L)) MOBJECTS)) + (CDR L))) + X)) +#+NIL +(DEFMACRO MODEDECLARE (&REST X) + ;; I BET THIS FUNCTION IS NEVER EVEN CALLED ANYPLACE. + (MAPC (LAMBDA (L) + (DECLARE (SPECIAL L)) + (MAPC (LAMBDA (V) (PUSH (CONS V (CAR L)) MOBJECTS)) + (CDR L))) + X) + `',X) + +(DEFUN NDM-ERR (X) + (TERPRI) + (PRINC '|Cannot determine the mode of |) (PRINC X) + (ERROR 'NDM-ERR)) + +(DEFUN NSM-ERR (X) + (TERPRI) + (PRINC '|No such mode as |) (PRINC X) + (ERROR 'NSM-ERR)) + +(DEFUN SEL-ERR (B S) + (TERPRI) + (PRINC '/:) (PRINC B) + (DO () ((NULL S)) (PRINC '/:) (PRINC (CAR S)) (SETQ S (CDR S))) + (PRINC '|is an impossible selection|) + (ERROR 'SEL-ERR)) + +(DEFUN IA-ERR (X) + (TERPRI) + (PRINC '|Cannot assign |) (PRINC X) + (ERROR 'IA-ERR)) + +(DEFUN SEL MACRO (X) + (LET ((S (FSEL (MODE (CADR X)) (CDDR X)))) + (COND ((NULL S) (SEL-ERR (CADR X) (CDDR X))) + (T (SETQ X (CADR X)) + (DO () ((NULL (CDR S)) X) + (SETQ X (CONS (CADR (GET (CAR S) 'MODE)) (RPLACA S X)) S (CDDR S)) + (RPLACD (CDDR X) NIL)))))) + +(DEFUN FSEL (M SELS) ; This has a bug in it. + (COND ((NULL SELS) (LIST M)) + ((NULL M) + (DO L (GET (CAR SELS) 'MODES) (CDR L) (NULL L) + (IF (SETQ M (FSEL (CDAR L) (CDR SELS))) + (RETURN (CONS (CAAR L) (CONS (CAR SELS) M)))))) + ((LET (DUM) + (IF (SETQ DUM (ASSQ (CAR SELS) (GET M 'SELS))) + (CONS M (CONS (CAR SELS) (FSEL (CDR DUM) (CDR SELS))))))) + (T (DO ((L (GET M 'SELS) (CDR L)) (DUM)) ((NULL L)) + (IF (SETQ DUM (FSEL (CDAR L) SELS)) + (RETURN (CONS M (CONS (CAAR L) DUM)))))))) + +(DEFUN SELECTOR (X) + (IF (NULL (CDDR X)) `(SEL ,(CADR X) ,(CAR X)) + `(_ (SEL ,(CADR X) ,(CAR X)) ,(CADDR X)))) + + +(DEFUN _ MACRO (X) `(STO . ,(CDR X))) + +(DEFUN STO MACRO (X) + (DO ((L (CDR X) (CDDR L)) (S) (NL)) + ((NULL L) `(PROGN . ,(NREVERSE NL))) + (COND ((ATOM (CAR L)) (SETQ NL (CONS `(SETQ ,(CAR L) ,(CADR L)) NL))) + ((AND (EQ 'SEL (CAAR L)) (SETQ S (FSEL (MODE (CADAR L)) (CDDAR L)))) + (SETQ X (CADAR L)) + (DO L (CDDR S) (CDDR L) (NULL (CDR L)) + (SETQ X (CONS (CADR (GET (CAR L) 'MODE)) (RPLACA L X))) + (RPLACD (CDDR X) NIL)) + (SETQ NL (CONS (LIST (CADDR (GET (CAR S) 'MODE)) X (CADR S) (CADR L)) NL))) + (T (IA-ERR (CAR L)))))) + + +;; (C-ATOM '(AGE WEIGHT MARRIED) '(21 130 NIL)) creates a plist-structure +;; with slot names as properties. This should use SETPLIST instead +;; of RPLACD. +;; None of these functions are needed at compile time. + +;; (DEFUN C-ATOM (SELS ARGS) +;; (DO ((NL)) ((NULL SELS) (RPLACD (INTERN (GENSYM)) (NREVERSE NL))) +;; (IF (CAR ARGS) (SETQ NL (CONS (CAR ARGS) (CONS (CAR SELS) NL)))) +;; (SETQ SELS (CDR SELS) ARGS (CDR ARGS)))) + +;; (DEFUN A-ATOM (BAS SEL VAL) +;; (COND ((NULL VAL) (REMPROP BAS SEL) NIL) +;; (T (PUTPROP BAS VAL SEL)))) + +;; (DEFUN DSSQ (X L) +;; (DO () ((NULL L)) +;; (COND ((EQ X (CDAR L)) (RETURN (CAR L))) +;; (T (SETQ L (CDR L)))))) + + +(DEFMACRO CONS-EXP (OP . ARGS) `(SIMPLIFY (LIST (LIST ,OP) . ,ARGS))) + + + +;; Local Modes: +;; Mode: LISP +;; Comment Col: 40 +;; End: diff --git a/src/libmax/mrgmac.22 b/src/libmax/mrgmac.22 new file mode 100644 index 00000000..959bbb2d --- /dev/null +++ b/src/libmax/mrgmac.22 @@ -0,0 +1,356 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module mrgmac macro) + +#-LISPM +(DEFMACRO FIX-LM BODY + `(PROGN . ,BODY)) + +#+LISPM +(DEFMACRO FIX-LM (&BODY BODY) + `(LET ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA)) + . ,BODY)) + +;; The GRAM and DISPLA packages manipulate lists of fixnums, representing +;; lists of characters. This syntax facilitates typing them in. +;; {abc} reads as (#/a #/b #/c), unquoted. + +(DEFUN CHAR-LIST-SYNTAX-ON () + (FIX-LM + (SETSYNTAX '/{ 'MACRO + #'(LAMBDA () (DO ((C (TYI) (TYI)) (NL)) + ((= #/} C) (NREVERSE NL)) + (SETQ NL (CONS C NL))))) + T)) + +(DEFUN CHAR-LIST-SYNTAX-OFF () + (FIX-LM + #+(OR MACLISP NIL) (SETSYNTAX '/{ 'MACRO NIL) + #+Franz (setsyntax '/{ 2) + #+LISPM (SET-SYNTAX-FROM-DESCRIPTION #/{ 'SI:ALPHABETIC))) + +;; This sets up the syntax for a simple mode system defined later on +;; in this file. As usual, it is poorly documented. + +(DEFUN MODE-SYNTAX-ON () + ;; :A:B:C --> (SEL A B C) + ;; A component selection facility. :A:B:C is like (C (B A)) in the + ;; DEFSATRUCT world. + (FIX-LM + (SETSYNTAX '/: 'MACRO + #'(LAMBDA () (DO ((L (LIST (READ)) (CONS (READ) L))) + ((NOT (= #/: (TYIPEEK))) (CONS 'SEL (NREVERSE L))) + (TYI)))) + + ;; --> (SELECTOR A B C) Used when defining a mode. + (SETSYNTAX '/< 'MACRO + #'(LAMBDA () + (COND ((= #\SPACE (TYIPEEK)) '|<|) + ((= #/= (TYIPEEK)) (TYI) '|<=|) + (T (DO ((S (READ) (READ)) (NL)) + ((EQ '/> S) (CONS 'SELECTOR (NREVERSE NL))) + (SETQ NL (CONS S NL))))))) + + ;; Needed as a single character object. Used when defining a mode. + (SETSYNTAX '/> 'MACRO + #'(LAMBDA () + (COND ((NOT (= #/= (TYIPEEK))) '/>) + (T (TYI) '|>=|)))) + T)) + +(DEFUN MODE-SYNTAX-OFF () + (FIX-LM + #+(OR MACLISP NIL) (PROGN (SETSYNTAX '/: 'MACRO NIL) + (SETSYNTAX '/< 'MACRO NIL) + (SETSYNTAX '/> 'MACRO NIL)) + #+LISPM (PROGN (SI:SET-SYNTAX-BITS #/: '(0 . 23)) + (SET-SYNTAX-FROM-DESCRIPTION #/> 'SI:ALPHABETIC) + (SET-SYNTAX-FROM-DESCRIPTION #/< 'SI:ALPHABETIC)) + #+Franz (progn (setsyntax '/: 2) + (setsyntax '/< 2) + (setsyntax '/> 2)))) + +;; Loading this file used to turn on the mode syntax. Its been turned off +;; now and hopefully no files left rely on it. Files which want to +;; use that syntax should call (MODE-SYNTAX-ON) during read time. + +#+MACLISP +(DEFUN DEFINE-MACRO (NAME LAMBDA-EXP) + (PUTPROP NAME LAMBDA-EXP 'MACRO)) + +#+LISPM +(DEFUN DEFINE-MACRO (NAME LAMBDA-EXP) + (FIX-LM + (COND ((ATOM LAMBDA-EXP) (SETQ LAMBDA-EXP (FSYMEVAL LAMBDA-EXP)))) + (FSET NAME (CONS 'MACRO LAMBDA-EXP)))) + +#+Franz +(defun define-macro (name lambda-exp) + (putd name `(macro (dummy-arg) (,lambda-exp dummy-arg)))) + +#+NIL +(DEFUN DEFINE-MACRO (NAME LAMBDA-EXP) + (ADD-MACRO-DEFINITION NAME LAMBDA-EXP)) + +;; LAMBIND* and PROGB* are identical, similar to LET, but contain an implicit +;; PROG. On the Lisp Machine, PROG is extended to provide this capability. + +(DEFMACRO LAMBIND* (VAR-LIST . BODY) `(LET ,VAR-LIST (PROG NIL . ,BODY))) +(DEFMACRO PROGB* (VAR-LIST . BODY) `(LET ,VAR-LIST (PROG NIL . ,BODY))) + +(DEFUN MAPAND MACRO (X) + `(DO ((L ,(CADDR X) (CDR L))) ((NULL L) T) + (IFN (,(CADR X) (CAR L)) (RETURN NIL)))) + +(DEFUN MAPOR MACRO (X) + `(DO L ,(CADDR X) (CDR L) (NULL L) + (IF (FUNCALL ,(CADR X) (CAR L)) (RETURN T)))) + +;; (MAPLAC #'1+ '(1 2 3)) --> '(2 3 4), but the original list is rplaca'd +;; rather than a new list being consed up. + +(DEFMACRO MAPLAC (FUNCTION LIST) + `(DO L ,LIST (CDR L) (NULL L) (RPLACA L (FUNCALL ,FUNCTION (CAR L))))) + +(DEFUN PUT MACRO (X) `(PUTPROP . ,(CDR X))) +(DEFUN REM MACRO (X) `(REMPROP . ,(CDR X))) + +(DEFMACRO COPYP (L) `(CONS (CAR ,L) (CDR ,L))) +(DEFMACRO COPYL (L) `(APPEND ,L NIL)) + +(DEFMACRO ECONS (X Y) `(APPEND ,X (LIST ,Y))) + +#-Franz +(progn 'compile + (DEFMACRO CAAADAR (X) `(CAAADR (CAR ,X))) + (DEFMACRO CAAADDR (X) `(CAAADR (CDR ,X))) + (DEFMACRO CAADAAR (X) `(CAADAR (CAR ,X))) + (DEFMACRO CAADADR (X) `(CAADAR (CDR ,X))) + (DEFMACRO CADAAAR (X) `(CADAAR (CAR ,X))) + (DEFMACRO CADADDR (X) `(CADADR (CDR ,X))) + (DEFMACRO CADDAAR (X) `(CADDAR (CAR ,X))) + (DEFMACRO CADDDAR (X) `(CADDDR (CAR ,X))) + (DEFMACRO CDADADR (X) `(CDADAR (CDR ,X))) + (DEFMACRO CDADDDR (X) `(CDADDR (CDR ,X))) + (DEFMACRO CDDDDDR (X) `(CDDDDR (CDR ,X)))) + +(DEFMACRO TELL (&REST ARGS) `(DISPLA (LIST '(MTEXT) . ,ARGS))) + + + +(DECLARE (SPECIAL NAME BAS MOBJECTS SELECTOR) (*EXPR MODE)) + +(SETQ MOBJECTS NIL) + +(DEFPROP MODE (C-MODE S-MODE A-MODE) MODE) + +(DEFUN C-MODE MACRO (X) `(LIST . ,(CDR X))) + +(DEFUN S-MODE MACRO (X) + (COND ((EQ 'C (CADDR X)) `(CAR ,(CADR X))) + ((EQ 'SEL (CADDR X)) `(CADR ,(CADR X))) + ((EQ '_ (CADDR X)) `(CADDR ,(CADR X))))) + +(DEFUN A-MODE MACRO (X) + (COND ((EQ 'C (CADDR X)) `(RPLACA (CADR X) ,(CADDDR X))) + ((EQ 'SEL (CADDR X)) `(RPLACA (CDR ,(CADR X)) ,(CADDDR X))) + ((EQ '_ (CADDR X)) `(RPLACA (CDDR ,(CADR X)) ,(CADDDR X))))) + +(DEFUN DEFMODE MACRO (X) + (LET ((SELECTOR (MEMQ 'SELECTOR (CDDDDR X)))) + (DEFINE-MODE (CADR X) (CADDDR X)) + (MAPC 'EVAL (CDDDDR X)) + `',(CADR X))) + +(DEFUN DEFINE-MODE (NAME DESC) + (PROG (C S A DUMMY) + (SETQ DUMMY (EXPLODEC NAME) + C (IMPLODE (APPEND '(C -) DUMMY)) + S (IMPLODE (APPEND '(S -) DUMMY)) + A (IMPLODE (APPEND '(A -) DUMMY))) + (DEFINE-MACRO C (DEFC DESC)) + (DEFINE-MACRO S (DEFS DESC)) + (DEFINE-MACRO A (DEFA DESC)) + (PUT NAME (C-MODE C S A) 'MODE) + (RETURN NAME))) + + +(DEFUN DEFC (DESC) (LET ((BAS 'X)) `(LAMBDA (X) ,(DEFC1 DESC)))) + +(DEFUN DEFC1 (DESC) + (COND ((ATOM DESC) (LIST 'QUOTE DESC)) + ((EQ 'SELECTOR (CAR DESC)) + (COND ((NOT (NULL (CDDDR DESC))) (LIST 'QUOTE (CADDDR DESC))) + (T (SETQ BAS (LIST 'CDR BAS)) + (LIST 'CAR BAS)))) + ((EQ 'ATOM (CAR DESC)) + `(LIST 'C-ATOM '',(MAPCAR 'CADR (CDR DESC)) (CONS 'LIST (CDR X)))) + ((EQ 'CONS (CAR DESC)) `(LIST 'CONS ,(DEFC1 (CADR DESC)) ,(DEFC1 (CADDR DESC)))) + ((EQ 'LIST (CAR DESC)) + (DO ((L (CDR DESC) (CDR L)) (NL)) + ((NULL L) `(LIST 'LIST . ,(NREVERSE NL))) + (SETQ NL (CONS (DEFC1 (CAR L)) NL)))) + ((EQ 'STRUCT (CAR DESC)) (DEFC1 (CONS 'LIST (CDR DESC)))) + (T (LIST 'QUOTE DESC)))) + + +(DEFUN DEFS (DESC) + `(LAMBDA (X) (COND . ,(NREVERSE (DEFS1 DESC '(CADR X) NIL))))) + +(DEFUN DEFS1 (DESC BAS RESULT) + (COND ((ATOM DESC) RESULT) + ((EQ 'SELECTOR (CAR DESC)) + (PUT (CADR DESC) (CONS (CONS NAME (CADDR DESC)) (GET (CADR DESC) 'MODES)) 'MODES) + (PUT NAME (CONS (CONS (CADR DESC) (CADDR DESC)) (GET NAME 'SELS)) 'SELS) + (IF SELECTOR (DEFINE-MACRO (CADR DESC) 'SELECTOR)) + (CONS `((EQ ',(CADR DESC) (CADDR X)) ,BAS) RESULT)) + ((EQ 'ATOM (CAR DESC)) + (DO L (CDR DESC) (CDR L) (NULL L) + (PUT (CADAR L) (CONS (CONS NAME (CADDAR L)) (GET (CADAR L) 'MODES)) 'MODES) + (PUT NAME (CONS (CONS (CADAR L) (CADDAR L)) (GET NAME 'SELS)) 'SELS) + (IF SELECTOR (DEFINE-MACRO (CADAR L) 'SELECTOR))) + (CONS `((MEMQ (CADDR X) ',(MAPCAR 'CADR (CDR DESC))) (LIST 'GET ,BAS (LIST 'QUOTE (CADDR X)))) + RESULT)) + ((EQ 'CONS (CAR DESC)) + (SETQ RESULT (DEFS1 (CADR DESC) `(LIST 'CAR ,BAS) RESULT)) + (DEFS1 (CADDR DESC) `(LIST 'CDR ,BAS) RESULT)) + ((EQ 'LIST (CAR DESC)) + (DO L (CDR DESC) (CDR L) (NULL L) + (SETQ RESULT (DEFS1 (CAR L) `(LIST 'CAR ,BAS) RESULT) + BAS `(LIST 'CDR ,BAS))) + RESULT) + ((EQ 'STRUCT (CAR DESC)) (DEFS1 (CONS 'LIST (CDR DESC)) BAS RESULT)) + (T RESULT))) + +(DEFUN DEFA (DESC) + `(LAMBDA (X) (COND . ,(NREVERSE (DEFA1 DESC '(CADR X) NIL NIL))))) + +(DEFUN DEFA1 (DESC BAS CDR RESULT) + (COND ((ATOM DESC) RESULT) + ((EQ 'SELECTOR (CAR DESC)) + (SETQ BAS (COND ((NOT CDR) `(LIST 'CAR (LIST 'RPLACA ,(CADDR BAS) (CADDDR X)))) + (T `(LIST 'CDR (LIST 'RPLACD ,(CADDR BAS) (CADDDR X)))))) + (CONS `((EQ ',(CADR DESC) (CADDR X)) ,BAS) RESULT)) + ((EQ 'ATOM (CAR DESC)) + (LIST `(T (LIST 'A-ATOM (CADR X) (LIST 'QUOTE (CADDR X)) (CADDDR X))))) + ((EQ 'CONS (CAR DESC)) + (SETQ RESULT (DEFA1 (CADR DESC) `(LIST 'CAR ,BAS) NIL RESULT)) + (DEFA1 (CADDR DESC) `(LIST 'CDR ,BAS) T RESULT)) + ((EQ 'LIST (CAR DESC)) + (DO L (CDR DESC) (CDR L) (NULL L) + (SETQ RESULT (DEFA1 (CAR L) `(LIST 'CAR ,BAS) NIL RESULT) + BAS `(LIST 'CDR ,BAS))) + RESULT) + ((EQ 'STRUCT (CAR DESC)) (DEFA1 (CONS 'LIST (CDR DESC)) BAS CDR RESULT)) + (T RESULT))) + + +(DEFUN MODE (X) (CDR (ASSOC X MOBJECTS))) + +#-NIL +(DEFUN MODEDECLARE FEXPR (X) + (MAPC '(LAMBDA (L) (MAPC '(LAMBDA (V) (PUSH (CONS V (CAR L)) MOBJECTS)) + (CDR L))) + X)) +#+NIL +(DEFMACRO MODEDECLARE (&REST X) + ;; I BET THIS FUNCTION IS NEVER EVEN CALLED ANYPLACE. + (MAPC (LAMBDA (L) + (DECLARE (SPECIAL L)) + (MAPC (LAMBDA (V) (PUSH (CONS V (CAR L)) MOBJECTS)) + (CDR L))) + X) + `',X) + +;; Do not make this (ERROR 'NDM-ERR). It won't work on the Lisp machine. + +(DEFUN NDM-ERR (X) + (TERPRI) + (PRINC "Cannot determine the mode of ") (PRINC X) + (ERROR "NDM-ERR")) + +(DEFUN NSM-ERR (X) + (TERPRI) + (PRINC "No such mode as ") (PRINC X) + (ERROR "NSM-ERR")) + +(DEFUN SEL-ERR (B S) + (TERPRI) + (TYO #/:) (PRINC B) + (DO () ((NULL S)) (TYO #/:) (PRINC (CAR S)) (SETQ S (CDR S))) + (PRINC "is an impossible selection") + (ERROR "SEL-ERR")) + +(DEFUN IA-ERR (X) + (TERPRI) + (PRINC "Cannot assign ") (PRINC X) + (ERROR "IA-ERR")) + +(DEFUN SEL MACRO (X) + (LET ((S (FSEL (MODE (CADR X)) (CDDR X)))) + (COND ((NULL S) (SEL-ERR (CADR X) (CDDR X))) + (T (SETQ X (CADR X)) + (DO () ((NULL (CDR S)) X) + (SETQ X (CONS (CADR (GET (CAR S) 'MODE)) (RPLACA S X)) S (CDDR S)) + (RPLACD (CDDR X) NIL)))))) + +(DEFUN FSEL (M SELS) ; This has a bug in it. + (COND ((NULL SELS) (LIST M)) + ((NULL M) + (DO L (GET (CAR SELS) 'MODES) (CDR L) (NULL L) + (IF (SETQ M (FSEL (CDAR L) (CDR SELS))) + (RETURN (CONS (CAAR L) (CONS (CAR SELS) M)))))) + ((LET (DUM) + (IF (SETQ DUM (ASSQ (CAR SELS) (GET M 'SELS))) + (CONS M (CONS (CAR SELS) (FSEL (CDR DUM) (CDR SELS))))))) + (T (DO ((L (GET M 'SELS) (CDR L)) (DUM)) ((NULL L)) + (IF (SETQ DUM (FSEL (CDAR L) SELS)) + (RETURN (CONS M (CONS (CAAR L) DUM)))))))) + +(DEFUN SELECTOR (X) + (IF (NULL (CDDR X)) `(SEL ,(CADR X) ,(CAR X)) + `(_ (SEL ,(CADR X) ,(CAR X)) ,(CADDR X)))) + + +(DEFUN _ MACRO (X) `(STO . ,(CDR X))) + +(DEFUN STO MACRO (X) + (DO ((L (CDR X) (CDDR L)) (S) (NL)) + ((NULL L) `(PROGN . ,(NREVERSE NL))) + (COND ((ATOM (CAR L)) (SETQ NL (CONS `(SETQ ,(CAR L) ,(CADR L)) NL))) + ((AND (EQ 'SEL (CAAR L)) (SETQ S (FSEL (MODE (CADAR L)) (CDDAR L)))) + (SETQ X (CADAR L)) + (DO L (CDDR S) (CDDR L) (NULL (CDR L)) + (SETQ X (CONS (CADR (GET (CAR L) 'MODE)) (RPLACA L X))) + (RPLACD (CDDR X) NIL)) + (SETQ NL (CONS (LIST (CADDR (GET (CAR S) 'MODE)) X (CADR S) (CADR L)) NL))) + (T (IA-ERR (CAR L)))))) + +;; (C-ATOM '(AGE WEIGHT MARRIED) '(21 130 NIL)) creates a plist-structure +;; with slot names as properties. This should use SETPLIST instead +;; of RPLACD. +;; None of these functions are needed at compile time. + +;; (DEFUN C-ATOM (SELS ARGS) +;; (DO ((NL)) ((NULL SELS) (RPLACD (INTERN (GENSYM)) (NREVERSE NL))) +;; (IF (CAR ARGS) (SETQ NL (CONS (CAR ARGS) (CONS (CAR SELS) NL)))) +;; (SETQ SELS (CDR SELS) ARGS (CDR ARGS)))) + +;; (DEFUN A-ATOM (BAS SEL VAL) +;; (COND ((NULL VAL) (REMPROP BAS SEL) NIL) +;; (T (PUTPROP BAS VAL SEL)))) + +;; (DEFUN DSSQ (X L) +;; (DO () ((NULL L)) +;; (COND ((EQ X (CDAR L)) (RETURN (CAR L))) +;; (T (SETQ L (CDR L)))))) + + +(DEFMACRO CONS-EXP (OP . ARGS) `(SIMPLIFY (LIST (LIST ,OP) . ,ARGS))) + +;; Local Modes: +;; Mode: LISP +;; Comment Col: 40 +;; End: diff --git a/src/libmax/numerm.21 b/src/libmax/numerm.21 new file mode 100644 index 00000000..ac413c3e --- /dev/null +++ b/src/libmax/numerm.21 @@ -0,0 +1,89 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module numerm macro) + +;;; Macros for interface of lisp numerical routines to macsyma, +;;; for use with the functions in Maxsrc;Numer. + +(defmacro make-array$ (&rest l) + #+(or Maclisp NIL) + `(*array nil 'flonum ,@l) + #+LISPM + `(make-array (list ,@l) ':type 'art-float) + ) + + +(defmacro make-array% (&rest l) + #+(or Maclisp NIL) + `(*array nil 'fixnum ,@l) + #+Lispm + `(make-array (list ,@l) ':type 'art-q) + ) + +(defmacro aref$ (&rest l) + #+(or Maclisp NIL) + `(arraycall flonum ,@l) + #+(or Franz Lispm) + `(aref ,@l) + ) + +(defmacro aref% (&rest l) + #+(OR Maclisp NIL) + `(arraycall fixnum ,@l) + #+Lispm + `(aref ,@l) + ) + +(defmacro free-array% (a) + #+Maclisp + `(*rearray ,a) + #+(OR Lispm NIL) + ;; not useful to call return-array unless it is at end of area. + ;; programs do better to save arrays as a resource, this works + ;; in maclisp too. + a + ) +(defmacro free-array$ (a) + #+maclisp + `(*rearray ,a) + #+(OR Lispm NIL) + a + ) + + +(DEFMACRO DEFBINDTRAMP$ (NARGS) + (LET ((BIND-TRAMP$ #-Multics (SYMBOLCONC 'bind-tramp nargs '$) + #+Multics (implode (mapcan 'exploden + (list 'bind-tramp nargs '$)))) + (TRAMP$ #-Multics (SYMBOLCONC 'tramp nargs '$) + #+Multics (implode (mapcan 'exploden (list 'tramp nargs '$))))) +;;;When Multics gets symbolconc the above conditionalization can be removed. + `(PROGN 'COMPILE + (IF (FBOUNDP 'SPECIAL) (SPECIAL ,TRAMP$)) + (DEFMACRO ,BIND-TRAMP$ (F G &REST BODY) + `(LET ((,',TRAMP$)) + (LET ((,F (MAKE-TRAMP$ ,G ,',NARGS))) + ,@BODY)))))) + +(DEFBINDTRAMP$ 1) +(DEFBINDTRAMP$ 2) +(DEFBINDTRAMP$ 3) + +(defmacro fcall$ (&rest l) + #+Maclisp + `(subrcall flonum ,@l) + #+(OR Lispm NIL Franz) + `(funcall ,@l) + ) + +;; Central location for some important declarations. +#+Maclisp +(IF (FBOUNDP 'FLONUM) + (FLONUM (GCALL1$ NIL NIL) + (GCALL2$ NIL NIL NIL) + (MTO-FLOAT NIL) + )) + + diff --git a/src/libmax/nummac.19 b/src/libmax/nummac.19 new file mode 100644 index 00000000..aa1d3a8b --- /dev/null +++ b/src/libmax/nummac.19 @@ -0,0 +1,102 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module nummac macro) + +;;; macros for "numerical" code. + + +(DEFVAR *FLOAT-GENCALL-STACK* NIL "set up by GCALL-LET") + +#+Multics +(defmacro flonum-identity (x) + `(+$ ,x)) +#+Multics +(defmacro fixnum-identity (x) + `(+ ,x)) + +(DEFUN GET-S (IND V) + (CDR (ASSQ V (CDR (ASSQ IND *FLOAT-GENCALL-STACK*))))) +(DEFUN PUT-S (IND VAL V) + (LET ((FRAME (ASSQ IND *FLOAT-GENCALL-STACK*))) + (COND (FRAME + (SETF (CDR FRAME) + (CONS (CONS V VAL) (CDR FRAME)))) + (T + (PUSH `(,IND (,V . ,VAL)) *FLOAT-GENCALL-STACK*))))) + +(comment '| +;What you do is +(gcall-bind (f g h) ... + ; and then inside the body of this form you can do + (gcall f x) + ; which will be a fast call like (funcall f x) + ; but with hacks. + ) +|) + +(DEFMACRO GCALL (F X &optional (erst nil erst-p)) + `(#+maclisp + FLONUM-IDENTITY + #+lispm + PROGN + (COND #+maclisp + (,(GET-S F 'SUBRCALL-FLONUMP) + (SUBRCALL FLONUM ,F ,X)) + #+maclisp + (,(GET-S F 'SUBRCALLP) + (SUBRCALL T ,F ,X)) + (,(GET-S F 'LISPCALLP) + (FUNCALL ,F ,X)) + (T (FMAPPLY ,F (LIST ,X) + ,@(if erst-p (list erst) nil)))))) + +(EVAL-WHEN (COMPILE EVAL) + (DEFMACRO CONCAT (A B) + `(IMPLODE (APPEND (EXPLODEN ,A) (EXPLODEN ,B))))) + +(DEFMACRO GCALL-BIND (FUNLIST &REST BODY) + `(LET* (,@(APPLY 'APPEND + (MAPCAR #'(LAMBDA (FUN) + (AND (ATOM FUN) (SETQ FUN (LIST FUN FUN))) + (LET* ((FF (CAR FUN)) + (FS (CADR FUN)) + #+maclisp + (SUBRCALL-FLONUMP + (CONCAT '|subr$p~| FS)) + + #+maclisp + (SUBRCALLP (CONCAT '|subrp~| FS)) + (LISPCALLP (CONCAT '|lispp~| FS))) + #+maclisp + (PUT-S FF SUBRCALL-FLONUMP + 'SUBRCALL-FLONUMP) + #+maclisp + (PUT-S FF SUBRCALLP 'SUBRCALLP) + (PUT-S FF LISPCALLP 'LISPCALLP) + `(#+maclisp + (,SUBRCALL-FLONUMP (SUBRCALL$P ,FS)) + #+maclisp + (,SUBRCALLP (SUBRCALLP ,FS)) + (,LISPCALLP (NOT (MACSYMACALLP ,FS))) + #+maclisp + (,FF (COND (,SUBRCALLP ,SUBRCALLP) + (T ,FS))) + #+lispm + (,FF ,FS)))) + FUNLIST))) + ,@BODY)) + + +#+maclisp +(DEFMACRO AREF$ (&REST ARGS) + `(ARRAYCALL FLONUM ,@ARGS)) +#+maclisp +(DEFMACRO ASET$ (VAL &REST ARGS) + `(STORE (ARRAYCALL FLONUM ,@ARGS) ,VAL)) + + + + + \ No newline at end of file diff --git a/src/libmax/opshin.3 b/src/libmax/opshin.3 new file mode 100644 index 00000000..f165640d --- /dev/null +++ b/src/libmax/opshin.3 @@ -0,0 +1,111 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module opshin macro) + +;;; GJC 7:24pm Saturday, 20 September 1980 + +;;; For parsing standard option lists. + +;;; ::= | ( . ) +;;; ::= ( . ) | () +;;; ::= | () | ( ) + +(DEFVAR OPTION-MASTER) + +(DEFUN PARSE-OPTION-HEADER (OPTION-MASTER HEADER) + (PARSE-OPTION OPTION-MASTER (COND ((ATOM HEADER) + `((NAME ,HEADER))) + ((ATOM (CAR HEADER)) + `((NAME ,(CAR HEADER)) + ,@(CDR HEADER))) + (T + (OPTION-PARSE-ERROR + "bad name designation in header." + HEADER))))) + +(DEFUN PARSE-OPTION (OPTION-MASTER LIST) + (PARSE-OPTION-SUB (OR (GET OPTION-MASTER 'OPTION-ACTIONS) + (ERROR "has no option actions." + OPTION-MASTER + 'FAIL-ACT)) + (COPY-TOP-LEVEL LIST) NIL)) + +(DEFUN OPTION-PARSE-ERROR (MESS THING) + (FORMAT MSGFILES "~&; Error parsing option for ~A" OPTION-MASTER) + (ERROR MESS THING 'FAIL-ACT)) + +(DEFUN STANDARD-T (DONE NAME) + (CONS (CONS NAME T) DONE)) + +(DEFUN STANDARD-VAL (DONE NAME VAL) + (CONS (CONS NAME VAL) DONE)) + +(DEFUN STANDARD-%%EMPTY%% (DONE NAME) + (CONS (CONS NAME '%%EMPTY%%) DONE)) + +(DEFSTRUCT (OPTION-ACTION CONC-NAME) + NAME + (DOCUMENT "") + (IF-ATOM #'STANDARD-T) + (IF-VAL #'STANDARD-VAL) + (IF-NOT #'STANDARD-%%EMPTY%%)) + +(DEFUN PARSE-OPTION-SUB (OPTION-ACTIONS LIST DONE) + (COND ((NULL OPTION-ACTIONS) + (IF (NULL LIST) DONE + (OPTION-PARSE-ERROR "unknown option." list))) + (T + (LET* ((ACTION (CAR OPTION-ACTIONS)) + (NAME (OPTION-ACTION-NAME ACTION)) + (SLOT (GET-OPTION-SLOT NAME LIST))) + (PARSE-OPTION-SUB + (CDR OPTION-ACTIONS) + (DELETE SLOT LIST) + (COND ((null slot) + (FUNCALL (OPTION-ACTION-IF-NOT ACTION) + DONE NAME)) + ((ATOM SLOT) + (FUNCALL (OPTION-ACTION-IF-ATOM ACTION) + DONE NAME)) + (T + (CASEQ (LENGTH SLOT) + (1 + (FUNCALL (OPTION-ACTION-IF-VAL ACTION) + DONE NAME NIL)) + (2 + (FUNCALL (OPTION-ACTION-IF-VAL ACTION) + DONE NAME (CADR SLOT))) + (T + (OPTION-PARSE-ERROR + "bad option spec." slot)))))))))) + +(DEFUN GET-OPTION-SLOT (NAME LIST) + (COND ((NULL LIST) NIL) + ((ATOM (CAR LIST)) + (IF (EQ NAME (CAR LIST)) + (CAR LIST) + (GET-OPTION-SLOT NAME (CDR LIST)))) + ((ATOM (CAAR LIST)) + (IF (EQ NAME (CAAR LIST)) + (CAR LIST) + (GET-OPTION-SLOT NAME (CDR LIST)))) + ('ELSE + (OPTION-PARSE-ERROR "bad option spec name." (CAAR LIST))))) + +(COMMENT |example| +(DEF-OPTION FOO + (NAME) + (BAZ + DOCUMENT "Stupid option to use." + IF-ATOM (LAMBDA (FOO BAR) (BAZ FOO BAR))))) + +(DEFMACRO DEF-OPTION (NAME &REST OPTION) + `(PUTPROP ',NAME + (LIST ,@(MAPCAR #'(LAMBDA (U) + `(MAKE-OPTION-ACTION + NAME ',(IF (ATOM U) U (CAR U)) + ,@(IF (ATOM U) NIL (CDR U)))) + OPTION)) + 'OPTION-ACTIONS)) \ No newline at end of file diff --git a/src/libmax/procs.16 b/src/libmax/procs.16 new file mode 100644 index 00000000..52b79a4c --- /dev/null +++ b/src/libmax/procs.16 @@ -0,0 +1,89 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module procs macro) + +;;; Fast dispatching off the property list with SUBRCALL. +;;; MARCH 1980. -GJC + +;;; The advantages: +;;; [1] (SUBRCALL NIL (GET (CAR FORM) 'FOO) FORM) is fast! (PUSHJ P @ 0 P) +;;; [2] Creates no extra symbols of the kind |NAME FOO|. +;;; The problems with using SUBRCALL: +;;; [1] Only have subrs in compiled code. +;;; [2] System-dependant. +;;; [3] Fixed number of arguments. + +;;; This macro package fixes problems [1] and [2]. +;;; Number [3] isn't a problem for the parsers, translators and tree-walkers +;;; in macsyma. + +(defun verify-as-subr-argument-list (property l n) + (if (or (memq '&rest l) + (memq '&optional l)) + (error (list "bad argument list for a" property "property.") l) + (let ((length (- (length l) + (length (memq '&aux l))))) + (if (eq n '*) + (if (< length 6.) + length + (error (list "argument list too long for a" property "property.") l)) + (if (= n length) + length + (error (list "argument list for a" property "property must be" + n "long.") + l)))))) + + +(defun a-def-property (name argl body property n) + (verify-as-subr-argument-list property argl n) + (cond ((status feature pdp10) + (cond ((memq compiler-state '(maklap compile)) + `(defun (,name nil ,property) ,argl . ,body)) + ('else + (let ((f (symbolconc name '- property))) + `(progn (defprop ,name ,(make-jcall n f) ,property) + (defun ,f ,argl . ,body)))))) + ('else + `(defun (,name ,property) ,argl . ,body)))) + +(defmacro def-def-property (name sample-arglist) + + `(defmacro ,(symbolconc 'def- name '-property) (name argl . body) + (a-def-property name argl body ',name + ',(verify-as-subr-argument-list 'def-def-property + sample-arglist + '*)))) + +#+PDP10 +(progn 'compile +(defun make-jcall (number-of-arguments name-to-call) + (boole 7 13._27. + (lsh number-of-arguments 23.) + (maknum name-to-call))) +;; SUBRCALL does argument checking in the interpreter, so +;; the FIXNUM's won't pass as subr-pointers. +;; The following code must be compiled in order to run interpreted code +;; which uses SUBR-CALL and DEF-DEF-PROPERTY. +(defun subr-call-0 (f) (subrcall nil f)) +(defun subr-call-1 (f a) (subrcall nil f a)) +(defun subr-call-2 (f a b) (subrcall nil f a b)) +(defun subr-call-3 (f a b c) (subrcall nil f a b c)) +(defun subr-call-4 (f a b c d) (subrcall nil f a b c d)) +(defun subr-call-5 (f a b c d e)(subrcall nil f a b c d e)) +(DEFMACRO SUBR-CALL (F &REST L) + (IF (MEMQ COMPILER-STATE '(MAKLAP COMPILE)) + `(SUBRCALL NIL ,F ,@L) + `(,(cdr (assoc (length l) + '((0 . subrcall-0) + (1 . subrcall-1) + (2 . subrcall-2) + (3 . subrcall-3) + (4 . subrcall-4) + (5 . subrcall-5)))) + ,f ,@l))) +) + +#-PDP10 +(DEFMACRO SUBR-CALL (F &REST L) `(FUNCALL ,F ,@L)) \ No newline at end of file diff --git a/src/libmax/readm.3 b/src/libmax/readm.3 new file mode 100755 index 00000000..13eee9ae --- /dev/null +++ b/src/libmax/readm.3 @@ -0,0 +1,26 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module readm macro) + +;;; Macros dealing with the lisp reader. + +#+MACLISP(DEFVAR /#-SYMBOLIC-CHARACTERS-TABLE) + +(DEFMACRO |DEF#\SYMBOL| (SYM NUM) + #+MACLISP + `(PROGN 'COMPILE + (LET ((F (CAR (STATUS MACRO #/#)))) + (OR (FBOUNDP F) + (LOAD (GET F 'AUTOLOAD)))) + (LET ((SLOT (ASSOC ',SYM /#-SYMBOLIC-CHARACTERS-TABLE))) + (AND SLOT (NOT (EQUAL ',NUM (CDR SLOT))) + (FORMAT MSGFILES + '|~&; Warning: Redefining #\~S from ~S to ~S| + ',SYM (CDR SLOT) ',NUM)) + (OR (EQUAL SLOT '(,SYM . ,NUM)) + (PUSH '(,SYM . ,NUM) /#-SYMBOLIC-CHARACTERS-TABLE))) + ',(FORMAT NIL "#\~S => ~S" SYM NUM)) + #-MACLISP + (ERROR "I don't know how to hack DEF#\SYMBOL here.")) \ No newline at end of file diff --git a/src/libmax/strmac.4 b/src/libmax/strmac.4 new file mode 100644 index 00000000..89dea89b --- /dev/null +++ b/src/libmax/strmac.4 @@ -0,0 +1,112 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module strmac macro) + +;; Data Representation macros. + +;; Hand coded macros for manipulating data structures in a simple +;; way, yet still preserving some abstraction. Replacement for the mode +;; package. We no longer know the type of things at run-time, so the names +;; of each macro must reflect the type of its operand, e.g. +;; RAT-NUMER versus MRAT-NUMER. + +(DEFMACRO MAKE-G-REP (OPERATOR . OPERANDS) + `(LIST (LIST ,OPERATOR) . ,OPERANDS)) +(DEFMACRO MAKE-G-REP-SIMP (OPERATOR . OPERANDS) + `(LIST (LIST ,OPERATOR) . ,OPERANDS)) + +(DEFMACRO G-REP-OPERATOR (EXP) `(CAAR ,EXP)) +(DEFMACRO G-REP-OPERANDS (EXP) `(CDR ,EXP)) +(DEFMACRO G-REP-FIRST-OPERAND (EXP) + `(CADR ,EXP)) + +(DEFMACRO MAKE-MPLUS ARGS `(LIST '(MPLUS) . ,ARGS)) +(DEFMACRO MAKE-MPLUS-L (LIST) `(CONS '(MPLUS) ,LIST)) +(DEFMACRO MAKE-MPLUS-SIMP ARGS `(LIST '(MPLUS SIMP) . ,ARGS)) +(DEFMACRO MAKE-MPLUS-SIMP-L (LIST) `(CONS '(MPLUS SIMP) ,LIST)) + +(DEFMACRO MAKE-MTIMES ARGS `(LIST '(MTIMES) . ,ARGS)) +(DEFMACRO MAKE-MTIMES-L (LIST) `(CONS '(MTIMES) ,LIST)) +(DEFMACRO MAKE-MTIMES-SIMP ARGS `(LIST '(MTIMES SIMP) . ,ARGS)) +(DEFMACRO MAKE-MTIMES-SIMP-L (LIST) `(CONS '(MTIMES SIMP) ,LIST)) + +; losing MACLISP doesn't like BASE as a variable name !! +(DEFMACRO MAKE-MEXPT (thing-being-raised-to-power EXPT) + `(LIST '(MEXPT) ,thing-being-raised-to-power ,EXPT)) +(DEFMACRO MAKE-MEXPT-L (LIST) `(CONS '(MEXPT) ,LIST)) +(DEFMACRO MAKE-MEXPT-SIMP (thing-being-raised-to-power EXPT) + `(LIST '(MEXPT SIMP) ,thing-being-raised-to-power ,EXPT)) +(DEFMACRO MAKE-MEXPT-SIMP-L (LIST) `(CONS '(MEXPT SIMP) ,LIST)) + +(DEFMACRO MEXPT-BASE (MEXPT) `(CADR ,MEXPT)) +(DEFMACRO MEXPT-EXPT (MEXPT) `(CADDR ,MEXPT)) + +(DEFMACRO MAKE-MEQUAL (LHS RHS) `(LIST '(MEQUAL) ,LHS ,RHS)) +(DEFMACRO MAKE-MEQUAL-L (LIST) `(CONS '(MEQUAL) ,LIST)) +(DEFMACRO MAKE-MEQUAL-SIMP (LHS RHS) `(LIST '(MEQUAL SIMP) ,LHS ,RHS)) +(DEFMACRO MAKE-MEQUAL-SIMP-L (LIST) `(CONS '(MEQUAL SIMP) ,LIST)) + +(DEFMACRO MEQUAL-LHS (MEQUAL) `(CADR ,MEQUAL)) +(DEFMACRO MEQUAL-RHS (MEQUAL) `(CADDR ,MEQUAL)) + +(DEFMACRO MAKE-MLIST ARGS `(LIST '(MLIST) . ,ARGS)) +(DEFMACRO MAKE-MLIST-L (LIST) `(CONS '(MLIST) ,LIST)) +(DEFMACRO MAKE-MLIST-SIMP ARGS `(LIST '(MLIST SIMP) . ,ARGS)) +(DEFMACRO MAKE-MLIST-SIMP-L (LIST) `(CONS '(MLIST SIMP) ,LIST)) + +(DEFMACRO MAKE-MTEXT ARGS `(LIST '(MTEXT) . ,ARGS)) + +(DEFMACRO MAKE-RAT ARGS `(LIST '(RAT) . ,ARGS)) +(DEFMACRO MAKE-RAT-SIMP ARGS `(LIST '(RAT SIMP) . ,ARGS)) +(DEFMACRO MAKE-RAT-BODY (NUMER DENOM) `(CONS ,NUMER ,DENOM)) +(DEFMACRO RAT-NUMER (RAT) `(CADR ,RAT)) +(DEFMACRO RAT-DENOM (RAT) `(CADDR ,RAT)) + +;; Schematic of MRAT form: +;; ((MRAT SIMP ) . ) + +;; Schematic of and : +;; ( ...) + +;; Representation for X^2+1: +;; ((MRAT SIMP ($X) (G0001)) (G0001 2 1 0 1) . 1) + +;; Representation for X+Y: +;; ((MRAT SIMP ($X $Y) (G0001 G0002)) (G0001 1 1 0 (G0002 1 1)) . 1) + +(DEFMACRO MRAT-BODY (MRAT) `(CDR ,MRAT)) +(DEFMACRO MRAT-NUMER (MRAT) `(CADR ,MRAT)) +(DEFMACRO MRAT-DENOM (MRAT) `(CDDR ,MRAT)) + +(DEFMACRO MAKE-MRAT (VARLIST GENVARS NUMER DENOM) + `((MRAT ,VARLIST ,GENVARS) ,NUMER . ,DENOM)) + +(DEFMACRO MAKE-MRAT-BODY (NUMER DENOM) `(CONS ,NUMER ,DENOM)) + +;; Data structures used only in this file. + +(DEFMACRO TRIG-CANNON (OPERATOR) `(GET ,OPERATOR 'TRIG-CANNON)) + +;; Linear equation -- cons of linear term and constant term. + +(DEFMACRO MAKE-LINEQ (LINEAR CONSTANT) `(CONS ,LINEAR ,CONSTANT)) +(DEFMACRO LINEQ-LINEAR (LINEQ) `(CAR ,LINEQ)) +(DEFMACRO LINEQ-CONSTANT (LINEQ) `(CDR ,LINEQ)) + +;; Solutions -- a pair of polynomial/multiplicity lists + +(DEFMACRO MAKE-SOLUTION (WINS LOSSES) `(CONS ,WINS ,LOSSES)) +(DEFMACRO SOLUTION-WINS (SOLUTION) `(CAR ,SOLUTION)) +(DEFMACRO SOLUTION-LOSSES (SOLUTION) `(CDR ,SOLUTION)) + +;; Polynomials -- these appear in the numerator or denominator +;; of MRAT forms. This doesn't handle the case of a coefficient +;; polynomial. + +(DEFMACRO MAKE-MRAT-POLY (VAR TERMS) `(CONS ,VAR ,TERMS)) +(DEFMACRO POLY-VAR (POLY) `(CAR ,POLY)) +(DEFMACRO POLY-TERMS (POLY) `(CDR ,POLY)) + + diff --git a/src/libmax/tprelu.47 b/src/libmax/tprelu.47 new file mode 100755 index 00000000..10ec885f --- /dev/null +++ b/src/libmax/tprelu.47 @@ -0,0 +1,43 @@ +;;; -*- Mode: Lisp; Package: Macsyma -*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Compilation environment for TRANSLATED MACSYMA code. ;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(COMMENT PLEASE HAVE MERCY ON THE USER O GREAT COMPLR) + + +;;; At compile time load macro packages. +(EVAL-WHEN (COMPILE) + (DEFUN VERLOAD (NAME FILE) + (COND ((GET NAME 'VERSION)) + (T (LOAD FILE) + (PUSH NAME MACRO-FILES)))) + (SETQ MACRO-FILES NIL) + (COND ((STATUS FEATURE ITS) + (VERLOAD 'MAXMAC "LIBMAX;MAXMAC FASL") + (VERLOAD 'MOPERS "LIBMAX;MOPERS FASL") + (VERLOAD 'TRANSQ "LIBMAX;TRANSQ FASL") + (VERLOAD 'MDEFUN "MACSYM;MDEFUN FASL") + (VERLOAD 'DCL "MAXDOC;DCL FASL") + ;; important declarations not yet in DCL FASL + (VERLOAD 'TDCL "MAXDOC;TDCL FASL") + ) + ((STATUS FEATURE Multics) T) + (T + (ERROR '|Unknown system -- see MC:LIBMAX;TINCLU >|))) + #+PDP10 + (UNFASL-ANNOTATE-VERSIONS) + + (SETQ *TRD-MSYMEVAL-INIT-VARS* NIL + *KNOWN-FUNCTIONS-INFO-STACK* NIL + *UNKNOWN-FUNCTIONS-INFO-STACK* NIL) + (PUSH '(COMPILE-FORMS-TO-COMPILE-QUEUE) EOF-COMPILE-QUEUE) + (PUSH '(UNKNOWN-FUNCTIONS-COMMENT) EOF-COMPILE-QUEUE)) + +(DECLARE (FLONUM (MARRAYREF1$ NIL NIL) + (MARRAYSET1$ FLONUM NIL NIL))) +(DECLARE (*LEXPR RETLIST_TR)) + +(putprop 'application-operator (get '$arrayapply 'autoload) 'autoload) diff --git a/src/libmax/transm.129 b/src/libmax/transm.129 new file mode 100644 index 00000000..e304a5a5 --- /dev/null +++ b/src/libmax/transm.129 @@ -0,0 +1,546 @@ +;;; -*- Mode: Lisp; Package: Macsyma -*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Macros for TRANSL source compilation. ;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module transm macro) +(load-macsyma-macros procs) +(load-macsyma-macros-at-runtime 'procs) + +(DEFVAR TRANSL-MODULES NIL) + +;;; Simple but effective single-level module definitions +;;; and utilities which work through property lists. +;;; Information has to be in various places: +;;; [1] Compile-time of the TRANSLATOR itself. +;;; [2] Runtime of the translator. +;;; [3] Translate-time of user-code +;;; [4] Compile-time of user-code. +;;; [5] Runtime of user-code. +;;; [6] "Utilities" or documentation-time of user-code. + +;;; -GJC + +;;; Note: Much of the functionality here was in use before macsyma as +;;; a whole got such mechanisms, however we must admit that the macsyma +;;; user-level (and non-modular global only) INFOLISTS of FUNCTIONS and VALUES, +;;; inspired this, motivated by my characteristic lazyness. + +(DEFMACRO ENTERQ (THING LIST) + ;; should be a DEF-ALTERANT + `(OR (MEMQ ,THING ,LIST) + (SETF ,LIST (CONS ,THING ,LIST)))) + +(DEFMACRO DEF-TRANSL-MODULE (NAME &REST PROPERTIES) + `(PROGN + (ENTerQ ',NAME TRANSL-MODULES) + ,@(MAPCAR #'(LAMBDA (P) + `(DEFPROP ,NAME + ,(IF (ATOM P) T (CDR P)) + ,(IF (ATOM P) P (CAR P)))) + PROPERTIES))) + +(DEF-TRANSL-MODULE TRANSS TTIME-AUTO) +(DEF-TRANSL-MODULE TRANSL TTIME-AUTO (FIRST-LOAD TRDATA DCL)) +(DEF-TRANSL-MODULE TRUTIL TTIME-AUTO) +(DEF-TRANSL-MODULE TRANS1 TTIME-AUTO) +(DEF-TRANSL-MODULE TRANS2 TTIME-AUTO) +(DEF-TRANSL-MODULE TRANS3 TTIME-AUTO) +(DEF-TRANSL-MODULE TRANS4 TTIME-AUTO) +(DEF-TRANSL-MODULE TRANS5 TTIME-AUTO) +(DEF-TRANSL-MODULE TRANSF TTIME-AUTO) +(DEF-TRANSL-MODULE TROPER TTIME-AUTO) +(DEF-TRANSL-MODULE TRPRED TTIME-AUTO) + +(DEF-TRANSL-MODULE MTAGS TTIME-AUTO) +(DEF-TRANSL-MODULE MDEFUN) +(DEF-TRANSL-MODULE TRANSQ) +(DEF-TRANSL-MODULE FCALL NO-LOAD-AUTO) +(DEF-TRANSL-MODULE ACALL NO-LOAD-AUTO) +(DEF-TRANSL-MODULE TRDATA NO-LOAD-AUTO) +(DEF-TRANSL-MODULE MCOMPI TTIME-AUTO) + +(DEF-TRANSL-MODULE DCL pseudo) ; more data +(DEFPROP DCL MAXDOC FASL-DIR) + +(DEF-TRANSL-MODULE TRMODE TTIME-AUTO + NO-LOAD-AUTO + ;; Temporary hack, TRANSL AUTOLOADs should be + ;; in a different file from functional autoloads. + ) + +(DEF-TRANSL-MODULE TRHOOK HYPER) +(DEF-TRANSL-MODULE TRANSL-AUTOLOAD PSEUDO) + +(eval-when (eval compile load) + (LOAD-MACSYMA-MACROS PROCS)) +#+ITS +(DEFUN TR-FASL-FILE-NAME (FOO) + (NAMESTRING `((dsk ,(get! foo 'fasl-dir)) ,foo fasl))) + +#+Multics +(defun tr-fasl-file-name (foo) + (NAMESTRING `,(executable-dir foo))) + +#+ITS +(defvar transl-autoload-oldio-name "DSK:MACSYM;TRANSL AUTOLO") + +#+Multics +(defvar transl-autoload-oldio-name (NAMESTRING (executable-dir 'transl/.autoload))) + +(DEFVAR MODULE-STACK NIL) + +(DEFMACRO TRANSL-MODULE (NAME) + (IF (NOT (MEMQ NAME TRANSL-MODULES)) + (ERROR "Not a TRANSL-MODULE, see LIBMAX;TRANSM >")) + #+PDP10 + (PROGN (PUSH NAME MODULE-STACK) + (PUSH '(EVAL-WHEN (COMPILE EVAL) + (TRANSL-MODULE-DO-IT) + (POP MODULE-STACK)) + EOF-COMPILE-QUEUE) + (PUTPROP NAME NIL 'FUNCTIONS) + (PUTPROP NAME NIL 'TR-PROPS) + (PUTPROP NAME NIL 'VARIABLES) + (DO ((L TRANSL-MODULES (CDR L))) + ((NULL L)) + (IF (EQ (CAR L) NAME) NIL + (LOAD-MODULE-INFO (CAR L)))) + ) + #+PDP10 + `(PROGN 'COMPILE + (DEFPROP ,NAME + ,(CADDR (NAMELIST (TRUENAME INFILE))) + VERSION) + (PROGN + ,(IF (NOT (GET NAME 'NO-LOAD-AUTO)) + `(OR (GET 'TRANSL-AUTOLOAD 'VERSION) + ($LOAD ',transl-autoload-oldio-name))) + ,@(MAPCAR #'(LAMBDA (U) + `(OR (GET ',U 'VERSION) + ($LOAD + ',(TR-FASL-FILE-NAME U)))) + (GET NAME 'FIRST-LOAD)))) + #-PDP10 + '(COMMENT THERE ARE REASONABLE THINGS TO DO HERE) + ) + +#+PDP10 + +(DEFUN LAMBDA-TYPE (ARGLIST) + (COND ((NULL ARGLIST) + '(*EXPR . (NIL . 0))) + ((ATOM ARGLIST) + '(*LEXPR . NIL)) + (T + ;; (FOO BAR &OPTIONAL ... &REST L &AUX) + ;; #O776 is the MAX MAX. + (DO ((MIN 0) + (MAX 0) + (OPTIONAL NIL) + (L ARGLIST (CDR L))) + ((NULL L) + (IF (= MIN MAX) + `(*EXPR . (NIL . ,MIN)) + `(*LEXPR . (,MIN . ,MAX)))) + (CASEQ (CAR L) + ((&REST) + (SETQ MAX #o776) + (SETQ L NIL)) + ((&OPTIONAL) + (SETQ OPTIONAL T)) + ((&AUX) + (SETQ L NIL)) + (t + (IF (AND (SYMBOLP (CAR L)) + (= #/& (GETCHARN (CAR L) 1))) + (RETURN + (LAMBDA-TYPE + (ERROR (LIST "arglist has unknown &keword" (CAR L)) + ARGLIST 'WRNG-TYPE-ARG)))) + (OR OPTIONAL (SETQ MIN (1+ MIN))) + (SETQ MAX (1+ MAX)))))))) + +(def-def-property translate (form)) + +(DEFMACRO DEF%TR (NAME LAMBDA-LIST &REST BODY) + (COND ((AND (NULL BODY) (SYMBOLP LAMBDA-LIST)) + `(DEF-SAME%TR ,NAME ,LAMBDA-LIST)) + (T + #+PDP10 + (ENTERQ NAME (GET (CAR MODULE-STACK) 'TR-PROPS)) + `(def-translate-property ,NAME + ,LAMBDA-LIST ,@BODY)))) + +(DEFMACRO DEF-SAME%TR (NAME SAME-AS) + ;; right now MUST be used in the SAME file. + #+PDP10 + (ENTERQ NAME (GET (CAR MODULE-STACK) 'TR-PROPS)) + `(PUTPROP ',NAME + (OR (GET ',SAME-AS 'TRANSLATE) + (ERROR '|No TRANSLATE property to alias.| ',SAME-AS)) + 'TRANSLATE)) + +(DEFMACRO DEF%TR-INHERIT (FROM &REST OTHERS) + #+PDP10 + (mapc #'(lambda (name) + (enterq name (get (car module-stack) 'tr-props))) + others) + `(LET ((TR-PROP (OR (GET ',FROM 'TRANSLATE) + (ERROR '|No TRANSLATE property to alias.| ',FROM)))) + (MAPC #'(LAMBDA (NAME) (PUTPROP NAME TR-PROP 'TRANSLATE)) + ',OTHERS))) + +#+PDP10 +(DEFUN PUT-LAMBDA-TYPE (NAME ARGL) + (LET ((LAMBDA-TYPE (LAMBDA-TYPE ARGL))) + (PUTPROP NAME T (CAR LAMBDA-TYPE)) + (ARGS NAME (CDR LAMBDA-TYPE)))) + + +(DEFMACRO DEFTRFUN (NAME ARGL &REST BODY) + #+PDP10 + (PROGN (ENTERQ NAME (GET (CAR MODULE-STACK) 'FUNCTIONS)) + (PUT-LAMBDA-TYPE NAME ARGL)) + `(DEFUN ,NAME ,ARGL ,@BODY)) + +(DEFMACRO DEFTRVAR (NAME VALUE &REST IGNORE-DOC) + ;; to be used to put the simple default value in + ;; the autoload file. Should be generalized to include + ;; BINDING methods. + #+PDP10 + (PROGN (ENTERQ NAME (GET (CAR MODULE-STACK) 'VARIABLES)) + (PUTPROP NAME (IF (FBOUNDP 'MACRO-EXPAND) + (MACRO-EXPAND VALUE) + VALUE) + 'VALUE)) + `(DEFVAR ,NAME ,VALUE)) + +#+PDP10 +(PROGN 'COMPILE + +(defun get! (a b) (or (get a b) (get! (error (list "undefined" b "property") + a 'wrng-type-arg) + b))) + +(defun print-defprop (symbol prop stream) + (print `(defprop ,symbol ,(get symbol prop) ,prop) stream)) + +(defun save-module-info (module stream) + (putprop module `(,(status uname) ,(status dow) ,(status date)) + 'last-compiled) + (print-defprop module 'last-compiled stream) + (print-defprop module 'functions stream) + (print-defprop module 'variables stream) + (print-defprop module 'tr-props stream) + (DO ((VARIABLES (get module 'VARIABLES) (CDR VARIABLES))) + ((NULL VARIABLES)) + (print-defprop (car variables) 'value stream) + ;; *NB* + ;; this depends on knowing about the internal workings + ;; of the maclisp compiler!!!! + (print `(defprop ,(car variables) + (special ,(car variables)) + special) + stream) + ) + (DO ((FUNCTIONS (GET MODULE 'FUNCTIONS) (CDR FUNCTIONS))) + ((NULL FUNCTIONS)) + ;; *NB* depends on maclisp compiler. + (LET ((X (GETL (CAR FUNCTIONS) '(*LEXPR *EXPR)))) + (IF X + (PRINT-DEFPROP (CAR FUNCTIONS) (CAR X) STREAM))) + (LET ((X (ARGS (CAR FUNCTIONS)))) + (IF X + (PRINT `(ARGS ',(CAR FUNCTIONS) ',X) STREAM))))) + +(defun save-enable-module-info (module stream) + ;; this outputs stuff to be executed in the context + ;; of RUNTIME of the modules, using information gotten + ;; by the SAVE done by the above function. + (print `(defprop ,module ,(tr-fasl-file-name module) fasload) stream) + ;; FASLOAD property lets us share the TR-FASL-FILE-NAME + ;; amoung the various autoload properties. + (print `(map1-put-if-nil ',(get module 'functions) + (get ',module 'fasload) + 'autoload) + stream) + (print `(map1-put-if-nil ',(get module 'tr-props) + (get ',module 'fasload) + 'autoload-translate) + stream) + (print `(map1-put-if-nil ',(get module 'tr-props) + (or (get 'autoload-translate 'subr) + (error 'autoload-translate 'subr + 'fail-act)) + 'translate) + stream) + (do ((variables (get module 'variables) (cdr variables))) + ((null variables)) + (print `(or (boundp ',(car variables)) + (setq ,(car variables) ,(get (car variables) 'value))) + stream))) + +(eval-when (compile eval) + (or (get 'iota 'macro) (load '|liblsp;iota fasl|))) + +(DEFUN TRANSL-MODULE-DO-IT (&AUX (BASE 10.) (*NOPOINT NIL)) + (let ((module (CAR MODULE-STACK))) + (cond ((AND (GET module 'ttime-auto) + (macsyma-compilation-p)) + (iota ((f `((dsk ,(get! module 'dir)) + ,module _auto_) 'out)) + (and ttynotes (format tyo "~&;MODULE : ~A~%" MODULE)) + (save-module-info module f) + (renamef f "* AUTOLO")) + (INSTALL-TRANSL-AUTOLOADS))))) + +(defun load-module-info (module) + (IF (AND (GET MODULE 'TTIME-AUTO) + ;; Assume we are the only MCL compiling + ;; a transl module at this time. + (NOT (GET MODULE 'LAST-COMPILED))) + (LET ((FILE `((dsk ,(get! module 'dir)) + ,module autolo))) + (COND ((PROBEF FILE) + (AND TTYNOTES + (FORMAT TYO "~&;Loading ~A info~%" + file)) + (LOAD FILE)) + (T + (AND TTYNOTES + (FORMAT TYO "~&; ~A NOT FOUND~%" + file))))))) + +(defvar autoload-install-file "dsk:macsyma;transl autoload") + +(DEFUN UNAME-TIMEDATE (FORMAT-STREAM) + (LET (((YEAR MONTH DAY) (STATUS DATE)) + ((HOUR MINUTE SECOND) (STATUS DAYTIME))) + (FORMAT FORMAT-STREAM + "by ~A on ~A, ~ + ~[January~;February~;March~;April~;May~;June~;July~;August~ + ~;September~;October~;November~;December~] ~ + ~D, 19~D, at ~D:~2,'0D:~2,'0D" + (status uname) + (status dow) + (1- month) day year + hour minute second))) + +(defun install-transl-autoloads () + (MAPC #'LOAD-MODULE-INFO TRANSL-MODULES) + (iota ((f (mergef "* _TEMP" + autoload-install-file) + '(out ascii))) + (PRINT `(progn + (DEFPROP TRANSL-AUTOLOAD ,(Uname-timedate nil) VERSION) + (OR (GET 'TRANSL-AUTOLOAD 'SUBR) + (load '((dsk macsym)trhook fasl))) + (setq transl-modules + ',transl-modules)) + F) + (DO ((MODULES TRANSL-MODULES (CDR MODULES))) + ((NULL MODULES) + (renamef f autoload-install-file)) + (and (get (car modules) 'ttime-auto) + (save-enable-module-info (car modules) f))))) + +(defun tr-tagS () + ;; trivial convenience utility. + (iota ((f `((dsk ,(get 'transl 'dir)) transl ntags) 'out)) + (do ((l transl-modules (cdr l))) + ((null l) + (close f) + (valret + (symbolconc '|:TAGS | (NAMESTRING F) '| +|))) + (or (get (car l) 'pseudo) + (format f "DSK:~A;~A >~%,LISP~%~%" + (get! (car l) 'dir) (car l)))))) + +;;; end of #+PDP10 I/O code. + +) + +;;; in PDP-10 maclisp OP is a subr-pointer. +;;; system-dependance macro-fied away in PROCS. + +(DEFMACRO TPROP-CALL (OP FORM) + `(subr-call ,op ,form)) + +(DEFMACRO DEF-AUTOLOAD-TRANSLATE (&REST FUNS) + #+PDP10 + `(LET ((A-SUBR (OR (GET 'AUTOLOAD-TRANSLATE 'SUBR) + (ERROR 'LOSE 'AUTOLOAD-TRANSLATE 'FAIL-ACT)))) + (mapc '(lambda (u) + (or (get u 'translate) + (putprop u A-SUBR 'TRANSLATE))) + ',FUNS)) + #-PDP10 + `(COMMENT *AUTOLOADING?* ,@FUNS)) + + +;;; declarations for the TRANSL PACKAGE. + +(FOR-DECLARATIONS + (SPECIAL *TRANSL-SOURCES*) + ;; The warning an error subsystem. + (SPECIAL TR-ABORT ; set this T if you want to abort. + *TRANSLATION-MSGS-FILES*) ; the stream to print messages to. + (*LEXPR WARN-UNDEDECLARED + TR-NARGS-CHECK + WARN-MEVAL + WARN-MODE + WARN-FEXPR + TELL) + + (*LEXPR PUMP-STREAM ; file hacking + ) + + ;; State variables. + + (SPECIAL PRE-TRANSL-FORMS* ; push onto this, gets output first into the + ; transl file. + *WARNED-UN-DECLARED-VARS* + *WARNED-FEXPRS* + *WARNED-MODE-VARS* + *WARNED-UNDEFINED-VARS* + WARNED-UNDEFINED-VARIABLES + TR-ABORT + TRANSL-FILE + *IN-COMPFILE* + *IN-TRANSLATE-FILE* + *IN-TRANSLATE* + *PRE-TRANSL-FORMS* + *NEW-AUTOLOAD-ENTRIES* ; new entries created by TRANSL. + ) + + ;; General entry points. + + (*EXPR TRANSLATE + ;; Takes a macsyma form, returns a form + ;; such that the CAR is the MODE and the + ;; CDR is the equivalent lisp form. + ;; For the meaning of the second argument to TRANSLATE + ;; see the code. When calling TRANSLATE from outside of + ;; itself, the second arg is always left out. + TR-ARGS ; mapcar of translate, strips off the modes. + DTRANSLATE ; CDR TRANSLATE + CALL-AND-SIMP ; (MODE F ARGL) generates `(,F ,@ARGL) + ;; sticks on the mode and a SIMPLIFY if needed. + ARRAY-MODE + FUNCTION-MODE + VALUE-MODE + TBIND ; For META binding of variables. + TUNBIND ; unbind. + TUNBINDS ; a list. + TBOUNDP ; is the variable lexicaly bound? + TEVAL ; get the var replacement. Now this is always + ;; the same as the var itself. BUT it could be use + ;; to do internal-mode stuff. + + PUSH-PRE-TRANSL-FORM + + ) + (*LEXPR TR-LOCAL-EXP + ;; conses up a lambda, calls, translate, strips... + TR-LAMBDA + ;; translate only a standard lambda expression + ) + + (*EXPR FREE-LISP-VARS + PUSH-DEFVAR + TR-TRACE-EXIT + TR-TRACE-ENTRY + side-effect-free-check + tbound-free-vars) + + (*EXPR TRANSLATE-FUNCTION TR-MFUN DCONVX) + + ;; these special declarations are for before DEFMVAR + (SPECIAL $ERREXP $LOADPRINT $NUMER $SAVEDEF $NOLABELS $FUNCTIONS $PROPS + $FILENAME $FILENUM $DIREC $DEVICE MUNBOUND $VALUES $TRANSRUN + ST OLDST $VERSION + REPHRASE $PACKAGEFILE + DSKFNP) + + ;; end of COMPLR declarations section. + ) + +(defmacro bind-transl-state (&rest forms) + ;; this binds all transl state variables to NIL. + ;; and binds user-settable variables to themselves. + ;; $TRANSCOMPILE for example can be set to TRUE while translating + ;; a file, yet will only affect that file. + ;; Called in 3 places, for compactness maybe this should be a PROGV + ;; which references a list of variables? + `(let (*WARNED-UN-DECLARED-VARS* + *WARNED-FEXPRS* + *WARNED-MODE-VARS* + *WARNED-UNDEFINED-VARS* + WARNED-UNDEFINED-VARIABLES + TR-ABORT + TRANSL-FILE + *IN-COMPFILE* + *IN-TRANSLATE-FILE* + *IN-TRANSLATE* + *PRE-TRANSL-FORMS* + *NEW-AUTOLOAD-ENTRIES* + ($TR_SEMICOMPILE $TR_SEMICOMPILE) + (ARRAYS NIL) + (EXPRS NIL) + (LEXPRS NIL) + (FEXPRS NIL) + (SPECIALS NIL) + (DECLARES NIL) + ($TRANSCOMPILE $TRANSCOMPILE) + ($TR_NUMER $TR_NUMER) + DEFINED_VARIABLES) + ,@FORMS)) + +#-Multics +(DEFMACRO TR-FORMAT (STRING &REST ARGL) + `(MFORMAT *TRANSLATION-MSGS-FILES* + ,STRING ,@ARGL)) + +;;; Is MFORMAT really prepared in general to handle +;;; the above form. Certainly not on Multics. +#+Multics +(defmacro tr-format (string &rest argl) + `(cond ((listp *translation-msgs-files*) + (mapcar '(lambda (file) + (mformat file ,string ,@argl)) + *translation-msgs-files*)) + (t (mformat *translation-msgs-files* ,string ,@argl)))) + +;;; for debugging convenience: +(DEFMACRO TR (EXP) `(BIND-TRANSL-STATE (TRANSLATE ,EXP))) + +;;; These are used by MDEFUN and MFUNCTION-CALL. +;;; N.B. this has arguments evaluated twice because I am too lazy to +;;; use a LET around things. + +(DEFMACRO PUSH-INFO (NAME INFO STACK) + `(LET ((*INFO* (ASSQ ,NAME ,STACK))) + (COND (*INFO* ;;; should check for compatibility of INFO here. + ) + (T + (PUSH (CONS ,NAME ,INFO) ,STACK))))) + +(DEFMACRO GET-INFO (NAME STACK) + `(CDR (ASSQ ,NAME ,STACK))) + +(DEFMACRO POP-INFO (NAME STACK) + `(LET ((*INFO* (ASSQ ,NAME ,STACK))) + (COND (*INFO* + (SETQ ,STACK (DELETE *INFO* ,STACK)) + (CDR *INFO*)) + (T NIL)))) + +(DEFMACRO TOP-IND (STACK) + `(COND ((NULL ,STACK) NIL) + (T + (CAAR ,STACK)))) + + diff --git a/src/libmax/transq.87 b/src/libmax/transq.87 new file mode 100644 index 00000000..9cab413f --- /dev/null +++ b/src/libmax/transq.87 @@ -0,0 +1,360 @@ +;;; -*- Mode: Lisp; Package: Macsyma -*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Compilation environment for TRANSLATED MACSYMA code. ;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; this are COMPILE-TIME macros for TRANSLATE MACSYMA code. +;;; these guys are either SUBR's LSUBR's or FEXPRS in the interpreter. +;;; (ask me about why I used FEXPRS sometime ok.) -gjc. + +(macsyma-module transq macro) +(load-macsyma-macros transm defopt) + +;;; Already defined in transl module. +#-LispM +(DEFVAR $TR_SEMICOMPILE NIL) ; T if expanding for expr code. + +;;; function for putting good info in the UNFASL file. + +#+PDP10 + +(PROGN 'COMPILE + +(DECLARE (SPECIAL CMSGFILES)) + +(DEFVAR MACRO-FILES NIL) + +(DEFUN UNFASL-ANNOTATE-VERSIONS () + (LET ((UNFASL (IF (EQ (CAAR (NAMELIST (CAR CMSGFILES))) 'DSK) + (CAR CMSGFILES) + (CADR CMSGFILES)))) + (FORMAT UNFASL '|~%;; Compilation by ~A~%| + (STATUS UNAME)) + (FORMAT UNFASL '|;; ~15A~A~%| + '|Prelude file:| + (LET ((X (TRUENAME INFILE))) + (NAMESTRING (CONS (CDAR X) (CDR X))))) + (FORMAT UNFASL '|;; ~15A| '|Macro files:|) + (FORMAT UNFASL '|~{~<~%;; ~15X~:;~A ~A~>~^, ~}~%| + (DO ((L NIL (CONS (GET (CAR X) 'VERSION) (CONS (CAR X) L))) + (X MACRO-FILES (CDR X))) + ((NULL X) (NREVERSE L)))))) +;; END of #+PDP10 +) + +(defmacro def-mtrvar (v a &optional (priority 1)) + priority + ;; ignored variable around for TRANSLATED files pre + ;; 3:03pm Thursday, 11 March 1982 -gjc + `(progn 'compile + (declare (special ,v)) + (if (or (not (boundp ',v)) + ;; a SYMBOL SET to ITSELF is considered to be + ;; UNBOUND for our purposes in Macsyma. + (eq ,v ',v)) + (setq ,v ,a)))) + +(DEFOPT TRD-MSYMEVAL (VAR &rest ignore) + VAR) + +(DEFVAR *MAX-EXPT$-EXPAND* 7) + +(DEFOPT EXPT$ (BAS EXP) + (if (not (fixp exp)) + (ERROR `(|Internal TRANSL error. Call GJC| ,BAS ,EXP))) + (LET* ((ABS-EXP (ABS EXP)) + (FULL-EXP (COND ((NOT (> EXP *MAX-EXPT$-EXPAND*)) + `(INTERNAL-EXPT$ ,BAS ,ABS-EXP)) + (T + `(^$ ,BAS ,ABS-EXP))))) + (COND ((MINUSP EXP) + `(//$ ,FULL-EXP)) + (T FULL-EXP)))) + +(DEFOPT INTERNAL-EXPT$ (EXP-BASE POS-EXP) + (COND ((= POS-EXP 0) + ;; BROM wrote X^0 for symmetry in his code, and this + ;; macro did some infinite looping! oops. + ;; X^0 can only happen in hand-written code, in macros + ;; the general-representation simplifier will get rid + ;; of it. + 1.0) + ((= POS-EXP 1) + EXP-BASE) + ((NOT (ATOM EXP-BASE)) + (LET ((SYM (GENSYM))) + `(LET ((,SYM ,EXP-BASE)) + (DECLARE (FLONUM ,SYM)) + (INTERNAL-EXPT$ ,SYM ,POS-EXP)))) + ((= POS-EXP 2) + `(*$ ,EXP-BASE ,EXP-BASE)) + ((= POS-EXP 3) `(*$ (*$ ,EXP-BASE ,EXP-BASE) ,EXP-BASE)) + ((= POS-EXP 4) + `(INTERNAL-EXPT$ (INTERNAL-EXPT$ ,EXP-BASE 2) 2)) + ((= pos-EXP 5) + `(*$ (INTERNAL-EXPT$ ,EXP-BASE 4) ,EXP-BASE)) + ((= pos-exp 6) + `(internal-expt$ (internal-expt$ ,EXP-BASE 3) 2)) + ((= pos-exp 7) + `(*$ ,EXP-BASE (internal-expt$ ,EXP-BASE 6))) + (T + `(*$ ,@(LISTN EXP-BASE POS-EXP))))) + +;;; There is a real neat and fancy way to do the above for arbitrary N +;;; repeated squaring in a recrusive fashion. It is trivial to do +;;; and should be done at some point. + +;; (LISTN 'A 3) --> (A A A) + +(DEFUN LISTN (X N) + (DO ((L NIL (CONS X L))) + ((MINUSP (SETQ N (1- N))) L))) + +#+PDP10 +(PROGN 'COMPILE + +(DEFVAR *KNOWN-FUNCTIONS-INFO-STACK* NIL + "When MDEFUN expands it puts stuff here for MFUNCTION-CALL + to use.") +(DEFVAR *UNKNOWN-FUNCTIONS-INFO-STACK* NIL + "When MFUNCTION-CALL expands without info from + *KNOWN-FUNCTIONS-INFO-STACK* it puts stuff here to be barfed + at the end of compilation.") + +(DEFOPT MFUNCTION-CALL (F &REST ARGL + &AUX (INFO (GET-INFO F *KNOWN-FUNCTIONS-INFO-STACK*))) + (COND ((OR (MEMQ INFO '(LEXPR EXPR)) + (GETL F '(*EXPR *LEXPR))) + `(,F ,@ARGL)) + ((GET F '*FEXPR) + (FORMAT MSGFILES + "~&(COMMENT *MACSYMA* unhandled FEXPR ~S may barf)~%" + F) + `(,F ,@ARGL)) + ((EQ INFO 'LUSER) + (COMMENT ???) + `(APPLY ',F ',ARGL)) + (T + (PUSH-INFO F ARGL *UNKNOWN-FUNCTIONS-INFO-STACK*) + `(funcall (progn ',f) ,@argl)))) + +;;; A call to this macro is pushed onto the EOF-COMPILE-QUEUE +(DECLARE (SPECIAL TTYNOTES)) +(DEFMACRO UNKNOWN-FUNCTIONS-COMMENT () + (LET ((UNKNOWNS (RESOLVE-KNOWN-AND-UNKNOWN-FUNCTIONS)) + (M1 "*MACSYMA* ") + (M2 " + -are user functions used but not defined in this file.")) + (COND (UNKNOWNS + (SETQ UNKNOWNS + `(COMMENT ,M1 ,UNKNOWNS ,M2)) + (COND (TTYNOTES + (TERPRI TYO) + (PRINT UNKNOWNS TYO) + (TERPRI TYO))) + UNKNOWNS)))) + +(DEFUN RESOLVE-KNOWN-AND-UNKNOWN-FUNCTIONS () + (DO ((UN)) + ((NULL *UNKNOWN-FUNCTIONS-INFO-STACK*) + UN) + (LET ((IND (TOP-IND *UNKNOWN-FUNCTIONS-INFO-STACK*))) + (POP-INFO IND *UNKNOWN-FUNCTIONS-INFO-STACK*) + (COND ((POP-INFO IND *KNOWN-FUNCTIONS-INFO-STACK*)) + (T + (PUSH IND UN)))))) +;; END OF #+PDP10 +) + +#-PDP10 +(DEFOPT MFUNCTION-CALL (F &REST L) + (CONS F L)) + +;;; macros for compiled environments. + +;;; (FUNGEN&ENV-for-meval . ) +;;; will define a function globally with a unique name +;;; (defun ). And return +;;; `(() ,@> . ). The resulting expression may +;;; then be passed to a function which will bind variables from +;;; the and possibly other variables free in +;;; and then call MEVAL on the expression. +;;; FUNGEN&ENV-FOR-MEVALSUMARG will also make sure that the +;;; has an mevalsumarg property of T. +;;; the expression was translated using TR-LAMBDA. + +(DEFVAR *INFILE-NAME-KEY* '|| + "This is a key gotten from the infile name, in the interpreter + other completely hackish things with FSUBRS will go on.") + +#+Maclisp +(DEFUN GEN-NAME ( &OPTIONAL K &AUX (N '#,(*ARRAY NIL 'FIXNUM 1))) + (STORE (ARRAYCALL FIXNUM N 0) (1+ (ARRAYCALL FIXNUM N 0))) + (AND K (STORE (ARRAYCALL FIXNUM N 0) K)) + (IMPLODE (APPEND (EXPLODEN *INFILE-NAME-KEY*) + (EXPLODEN '|-tr-gen-|) + (EXPLODEN (ARRAYCALL FIXNUM N 0))))) + +#+LISPM +(PROGN 'COMPILE +(defvar a-random-counter-for-gen-name 0) +(DEFUN GEN-NAME (&OPTIONAL IGNORE) + (intern (format nil "~A ~A #~D" + (status site) + (time:print-current-time ()) + (setq a-random-counter-for-gen-name + (1+ a-random-counter-for-gen-name))))) +) + +(DEFUN ENSURE-A-CONSTANT-FOR-MEVAL (EXP) + (COND ((OR (NUMBERP EXP) (MEMQ EXP '(T NIL))) + EXP) + (T + `(LET ((VAL ,EXP)) + (COND ((OR (NUMBERP VAL) (MEMQ VAL '(T NIL))) + VAL) + (T (LIST '(MQUOTE SIMP) VAL))))))) + +(DEFMACRO PROC-EV (X) + `(MAPCAR #'ENSURE-A-CONSTANT-FOR-MEVAL ,X)) + +(defvar forms-to-compile-queue ()) + +(defmacro compile-forms-to-compile-queue () + (IF FORMS-TO-COMPILE-QUEUE + (NCONC (LIST 'PROGN ''COMPILE) + (PROG1 FORMS-TO-COMPILE-QUEUE + (SETQ FORMS-TO-COMPILE-QUEUE NIL)) + '((COMPILE-FORMS-TO-COMPILE-QUEUE))))) + +(DEFUN EMIT-DEFUN (EXP) + (IF $TR_SEMICOMPILE (SETQ EXP `(PROGN ,EXP))) + #-LISPM + (SETQ FORMS-TO-COMPILE-QUEUE (NCONC FORMS-TO-COMPILE-QUEUE (LIST EXP))) + #+LISPM + (let ((default-cons-area working-storage-area)) + (SETQ FORMS-TO-COMPILE-QUEUE (NCONC FORMS-TO-COMPILE-QUEUE (LIST (COPYTREE EXP)))))) + +(DEFOPT FUNGEN&ENV-FOR-MEVAL (EV EV-LATE EXP + &AUX (NAME (GEN-NAME))) + (EMIT-DEFUN `(DEFUN ,NAME (,@EV ,@EV-LATE) ,EXP)) + `(LIST* '(,NAME) ,@(PROC-EV EV) + ',EV-LATE)) + +(DEFOPT FUNGEN&ENV-FOR-MEVALSUMARG (EV EV-LATE TR-EXP MAC-EXP + &AUX (NAME (GEN-NAME))) + (EMIT-DEFUN + `(DEFUN ,NAME (,@EV-LATE) + (LET ((,EV (GET ',NAME 'SUMARG-ENV))) + ,TR-EXP))) + + (EMIT-DEFUN + `(DEFUN (,NAME MEVALSUMARG-MACRO) (*IGNORED*) + (MBINDING (',EV (GET ',NAME 'SUMARG-ENV)) + (MEVALATOMS ',MAC-EXP)))) + + `(PROGN (PUTPROP ',NAME (LIST ,@EV) 'SUMARG-ENV) + (LIST '(,NAME) ',@EV-LATE))) + +;;; the lambda forms. + +(DEFOPT M-TLAMBDA (&REST L &AUX (NAME (GEN-NAME))) + (EMIT-DEFUN `(DEFUN ,NAME ,@L)) + + ;; just in case this is getting passed in as + ;; SUBST(LAMBDA([U],...),"FOO",...) + ;; this little operator property will make sure the right thing + ;; happens! + + (EMIT-DEFUN + `(DEFPROP ,NAME APPLICATION-OPERATOR OPERATORS)) + ;; must be 'NAME since #'NAME doesn't point to the operators + ;; property. + `',NAME) + +(defmacro pop-declare-statement (l) + `(and (not (atom (car ,l))) + (eq (caar ,l) 'declare) + (pop ,l))) + +(DEFOPT M-TLAMBDA& (ARGL &REST BODY &AUX (NAME (GEN-NAME))) + (EMIT-DEFUN + `(DEFUN ,NAME (,@(REVERSE (CDR (REVERSE ARGL))) + &REST ,@(LAST ARGL)) + ,(pop-declare-statement body) + (SETQ ,(CAR (LAST ARGL)) + (CONS '(MLIST) ,(CAR (LAST ARGL)))) + ,@BODY)) + + (EMIT-DEFUN `(DEFPROP ,NAME APPLICATION-OPERATOR OPERATORS)) + `',NAME) + +(DEFUN FOR-EVAL-THEN-QUOTE (VAR) + `(list 'QUOTE ,VAR)) + +(DEFUN FOR-EVAL-THEN-QUOTE-ARGL (ARGL) + (MAPCAR 'FOR-EVAL-THEN-QUOTE ARGL)) + +;; Problem: You can pass a lambda expression around in macsyma +;; because macsyma "general-rep" has a CAR which is a list. +;; Solution: Just as well anyway. + +(DEFOPT M-TLAMBDA&ENV ((REG-ARGL ENV-ARGL) &REST BODY + &AUX (NAME (GEN-NAME))) + (EMIT-DEFUN `(DEFUN ,NAME (,@ENV-ARGL ,@REG-ARGL) + ,@BODY)) + + + `(MAKE-ALAMBDA ',REG-ARGL + (LIST* ',NAME ,@(FOR-EVAL-THEN-QUOTE-ARGL ENV-ARGL) ',REG-ARGL))) + +(DEFOPT M-TLAMBDA&ENV& ((REG-ARGL ENV-ARGL) &REST BODY &AUX (NAME (GEN-NAME))) + (EMIT-DEFUN `(DEFUN ,NAME (,@ENV-ARGL ,@REG-ARGL) ,@BODY)) + `(MAKE-ALAMBDA '*N* + (LIST* ',NAME ,@(FOR-EVAL-THEN-QUOTE-ARGL ENV-ARGL) + ',(DO ((N (LENGTH REG-ARGL)) + (J 1 (1+ J)) + (L NIL)) + ((= J N) + (PUSH `(CONS '(MLIST) (LISTIFY (- ,(1- N) *N*))) L) + (NREVERSE L)) + (PUSH `(ARG ,J) L))))) + +;;; this is the important case for numerical hackery. + +(DEFUN DECLARE-SNARF (BODY) + (COND ((AND (NOT (ATOM (CAR BODY))) + (EQ (CAAR BODY) 'DECLARE)) + (LIST (CAR BODY))) + (T NIL))) + + +;;; I will use the special variable given by the NAME as a pointer to +;;; an environment. + +(DEFOPT M-TLAMBDA-I (MODE ENV ARGL &REST BODY + &AUX (NAME (GEN-NAME)) + (DECLAREP (DECLARE-SNARF BODY))) + (cond ((eq mode '$float) + (EMIT-DEFUN `(DECLARE (FLONUM (,NAME ,@(LISTN NIL (LENGTH ARGL)))))) + (EMIT-DEFUN `(DEFPROP ,NAME T FLONUM-COMPILED)))) + (EMIT-DEFUN + `(DEFUN ,NAME ,ARGL + ,@DECLAREP + (LET ((,ENV ,NAME)) + ,@(COND (DECLAREP (CDR BODY)) + (T BODY))))) + (EMIT-DEFUN `(SETQ ,NAME ',(LISTN NIL (LENGTH ENV)))) + `(PROGN (SET-VALS-INTO-LIST ,ENV ,NAME) + (QUOTE ,NAME))) + +;;; This is not optimal code. +;;; I.E. IT SUCKS ROCKS. + +(DEFMACRO SET-VALS-INTO-LIST (ARGL VAR) + (DO ((J 0 (1+ J)) + (ARGL ARGL (CDR ARGL)) + (L NIL + `((SETF (NTH ,J ,VAR) ,(CAR ARGL)) ,@L))) + ((NULL ARGL) `(PROGN ,@L)))) diff --git a/src/maxtul/dclmak.9 b/src/maxtul/dclmak.9 new file mode 100755 index 00000000..ffd0b700 --- /dev/null +++ b/src/maxtul/dclmak.9 @@ -0,0 +1,95 @@ +;;;-*-lisp-*- +;;; (DECLARE-FILE-MAKE) takes the include-file-style files +;;; of declarations and makes them into a loadable file +;;; which may be compiled. +;;; George Carrette 4:15pm Thursday, 21 August 1980 + +(DEFVAR DCL-OUTPUT "DSK:MAXDOC;DCL LOAD") +(DEFVAR DCL-INPUT '("DSK:MAXDOC;DCL FCTNS" + "DSK:MAXDOC;DCL VARS" + "DSK:MAXDOC;DCL FEXPR" + )) + +#.(PROGN (SETQ FILE-NAME-MAX-LENGTH 6) NIL) + +(DEFUN TEMP-FILENAME (NAME) + ; returns a temporary file name by convention. + (SETQ NAME (NAMELIST NAME)) + `(,(CAR NAME) + ,(CADR NAME) + ,(IMPLODE (CONS #/_ + (NCONC (LET ((L (EXPLODEN (CADDR NAME)))) + (COND ((< (LENGTH L) + (1- #.FILE-NAME-MAX-LENGTH)) + L) + (T + (NREVERSE + (NTHCDR (- (LENGTH L) + (- #.FILE-NAME-MAX-LENGTH 2)) + (NREVERSE L)))))) + '(#/_)))))) + +(DEFUN DCL-FILE-FORM-MUNGER (FORM STREAM) + (COND ((ATOM FORM)) + ((EQ (CAR FORM) 'DECLARE) + (POP FORM) + (DO () + ((NULL FORM)) + (DCL-FILE-FORM-MUNGER (POP FORM) STREAM))) + ((EQ (CAR FORM) 'COMMENT)) + (T + (CORRECT-PRINT FORM STREAM)))) + +(DEFVAR DCL-FILE-FORM-MUNGER #'DCL-FILE-FORM-MUNGER) + +(DEFUN CORRECT-PRINT (FORM STREAM) + (LET ((PRINLEVEL NIL) + (PRINLENGTH NIL) + (BASE 10.) + (*NOPOINT NIL)) + (PRINT FORM STREAM))) + + +(DEFUN DECLARE-FILE-MAKE () + (LET ((FO (OPEN (TEMP-FILENAME DCL-OUTPUT) '(OUT DSK ASCII BLOCK))) + (FI NIL) + (EOF (LIST NIL))) ;unique EOF object. + (UNWIND-PROTECT + (DO ((L (PROGN (CORRECT-PRINT + `(DEFPROP DCL + ,(TIME:PRINT-CURRENT-TIME NIL) + VERSION) + FO) + DCL-INPUT) + (CDR L))) + ((NULL L) + (CLOSE FO) + (AND (PROBEF DCL-OUTPUT) + (DELETEF DCL-OUTPUT)) + (RENAMEF FO DCL-OUTPUT)) + (SETQ FI (OPEN (CAR L) '(IN DSK ASCII BLOCK))) + (DO ((FORM (READ FI EOF) (READ FI EOF))) + ((EQ FORM EOF) + (CLOSE FI)) + (FUNCALL DCL-FILE-FORM-MUNGER FORM FO))) + (AND FI (CLOSE FI)) + (CLOSE FO)))) + +(DEFUN MAP-FILES (DCL-FILE-FORM-MUNGER DCL-INPUT DCL-OUTPUT) + (DECLARE-FILE-MAKE)) + +(DEFUN LISPM-DCL-FILE-FORM-MUNGER (FORM STREAM) + (COND ((ATOM FORM)) + ((EQ (CAR FORM) 'DECLARE) + (POP FORM) + (DO () + ((NULL FORM)) + (DCL-FILE-FORM-MUNGER (POP FORM) STREAM))) + ((EQ (CAR FORM) 'COMMENT)) + ((EQ (CAR FORM) 'SPECIAL) + (CORRECT-PRINT FORM STREAM)))) + +(DEFUN LISPM-DECLARE-FILE-MAKE () + (LET ((DCL-OUTPUT "DSK:MAXDOC;DCL LISPM") + (DCL-FILE-FORM-MUNGER #'LISPM-DCL-FILE-FORM-MUNGER)) + (DECLARE-FILE-MAKE))) diff --git a/src/maxtul/defile.16 b/src/maxtul/defile.16 new file mode 100755 index 00000000..9b84283b --- /dev/null +++ b/src/maxtul/defile.16 @@ -0,0 +1,208 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; The macsyma source files. This documentation is used +;;; during compiliation of the macsyma system, during the loading +;;; of the macsyma system, and during runtime by the error message +;;; system. -GJC, 9:00pm Friday, 24 October 1980 + +(INCLUDEF "LIBMAX;GPRELUDE >") + +(HERALD DEFMFILE) + +(DEFSTRUCT (MACSYMA-SOURCE-FILE NAMED-HUNK CONC-NAME default-pointer) + ;; The following are relevant to all files: + DIR ;; The ITS directory it may be found on. + NAME ;; The ITS first file name. + VERSION ;; The ITS version number of latest version. + MAINTAINERS ;; The primary loosers hacking this file. + UNFASL-HEADER ;; of installed version. + CODESIZE ;; in machine words. + (SYSTEMS-FOR '(ITS MACLISP PDP-10 FRANZ LISPM NIL)) + (SYSTEMS-NOT-FOR NIL) + + ;; The following are relevant for runtime files: + GOEDEL-NUMBER ;; used by the error message system. + GENPREFIX ;; prefix to generated symbols in the file, + ;; generated in the compiler, which must be + ;; unique at load time. + (IN-CORE NIL) ;; precedence order of loading for IN-CORE PDP10, + ;; NIL if not IN-CORE. + (LANGUAGE 'LISP) ;; for TAGS. + TAGS-PRECEDENCE ;; also for TAGS. + + ;; The following is relevant mainly on MC-ITS for installed files. + (FASL-DIR 'MACSYM) ;; Directory to put the compiled FASL code, + (UNFASL-DIR 'MUNFAS) ;; for the compiler comments, + (ERRMSG-DIR 'MAXERR) ;; for error messages and documentation + ;; strings. + (SPLIT NIL) ;; Uses SPLITfile on PDP10. + ;; This also implies something about FASL-DIR. + + ;; The following are relevant for macro packages: + GLOBAL-COMPILE ;; T if for all of runtime macsyma. + SELECTIVE-COMPILE ;; A list of files which reference. + MACRO-COMPILE ;; A list of macro files which use this + ;; macro file. If there is circularity + ;; refer to the documentation in the files + ;; for how to resolve it. + ) + +(DEFMACRO DEF-DISP-STRUCT (NAME) + (DO ((L (DEFSTRUCT-DESCRIPTION-SLOT-ALIST + (OR (GET NAME 'DEFSTRUCT-DESCRIPTION) + (ERROR "No DEFSTRUCT description." NAME 'FAIL-ACT))) + (CDR L)) + (ARGS NIL) + (STRING (EXPLODEN "~&"))) + ((NULL L) + (SETQ STRING `',(MAKNAM STRING)) ; should be LIST-TO-STRING + (SETQ ARGS (NREVERSE ARGS)) + `(DEFUN ,(SYMBOLCONC 'DISP- NAME) (EXP STREAM) + (FORMAT STREAM + ,STRING + ,@ARGS))) + (PUSH `(,(DEFSTRUCT-SLOT-DESCRIPTION-REF-MACRO-NAME (CDAR L)) EXP) + ARGS) + (SETQ STRING + (NCONC STRING (EXPLODEN (CAAR L)) (EXPLODEN " : ~S~%"))))) + +(DEF-DISP-STRUCT MACSYMA-SOURCE-FILE) + +#-LISPM ; useful lisp machine function. + +(PROGN 'COMPILE + +(IF (STATUS FEATURE COMPLR) + (*LEXPR DEL)) + +(DEFUN DEL (PREDICATE ITEM LIST &OPTIONAL (N #.(LSH -1 -1))) ; maximum FIXNUM. + (COND ((ATOM PREDICATE) + (LET ((FUNCTION (GETL PREDICATE '(SUBR LSUBR EXPR)))) + (CASEQ (CAR FUNCTION) + (SUBR + (DEL*1 (CADR FUNCTION) ITEM LIST N)) + (LSUBR + (DEL*2 (CADR FUNCTION) ITEM LIST N)) + (EXPR + (DEL*3 (CADR FUNCTION) ITEM LIST N)) + (T + (ERROR "Unbound function as arg to DEL" PREDICATE))))) + ('ELSE + (DEL*3 PREDICATE ITEM LIST N)))) + +(DEFMACRO DEFDEL* (NUMB &REST CALLER &AUX (NAME (SYMBOLCONC 'DEL* NUMB))) + `(DEFUN ,NAME (PREDICATE ITEM LIST N) + (COND ((OR (NULL LIST) (ZEROP N)) LIST) + ((,@CALLER PREDICATE ITEM (CAR LIST)) + (,NAME PREDICATE ITEM (CDR LIST) (1- N))) + ('ELSE + (RPLACD LIST (,NAME PREDICATE ITEM (CDR LIST) N)))))) +(DEFDEL* 1 SUBRCALL NIL) +(DEFDEL* 2 LSUBRCALL NIL) +(DEFDEL* 3 FUNCALL) + +(IF (STATUS FEATURE COMPLR) (*EXPR ASS)) + +(DEFUN ASS (PREDICATE ITEM LIST) + (DO () + ((NULL LIST) NIL) + (LET ((A (POP LIST))) + (IF (FUNCALL PREDICATE ITEM A) + (RETURN A))))) + +; end of #-LISPM +) + +(DEFMACRO DEFMFILE (DIR NAME &REST OPTIONS) + `(SETQ MACSYMA-SOURCE-FILES + (ADD-MACSYMA-SOURCE-FILE + (MAKE-MACSYMA-SOURCE-FILE DIR ',DIR + NAME ',NAME + ,@OPTIONS) + MACSYMA-SOURCE-FILES))) + +;(DEFMACRO DEFMFILES (DIR &REST CLAUSES)) + +(DEFVAR MACSYMA-SOURCE-FILES NIL) + +(DEFUN ADD-MACSYMA-SOURCE-FILE (SOURCE-STRUCT LIST) + (SETQ SOURCE-STRUCT + (DEFAULTY-MACSYMA-SOURCE-FILE SOURCE-STRUCT)) + (CONS SOURCE-STRUCT + (DEL #'(LAMBDA (S-MATCH S) + (COND ((EQ (MACSYMA-SOURCE-FILE-NAME S) + (MACSYMA-SOURCE-FILE-NAME S-MATCH)) + (FORMAT MSGFILES + "~&(COMMENT *REDEFINING SOURCE FILE*~%") + (DISP-MACSYMA-SOURCE-FILE S MSGFILES) + (FORMAT MSGFILES "~&; as") + (DISP-MACSYMA-SOURCE-FILE S-MATCH MSGFILES) + (TYO #/) MSGFILES) + T) + (T NIL))) + SOURCE-STRUCT + LIST))) + +(DEFVAR MACSYMA-SOURCE-FILES-GOEDEL-INDEX 0) + +(DEFUN INIT-MACSYMA-SOURCE-FILES () + (SETQ MACSYMA-SOURCE-FILES-GOEDEL-INDEX 0 + MACSYMA-SOURCE-FILES NIL)) + +(DEFUN DEFAULTY-MACSYMA-SOURCE-FILE (S) + (LET ((IND MACSYMA-SOURCE-FILES-GOEDEL-INDEX)) + (SETQ MACSYMA-SOURCE-FILES-GOEDEL-INDEX (1+ IND)) + ; would could do all sorts of consistency checking here. + (ALTER-MACSYMA-SOURCE-FILE + S + GOEDEL-NUMBER IND + GENPREFIX (MAKE-GENPREFIX IND) + TAGS-PRECEDENCE (IF (MACSYMA-SOURCE-FILE-IN-CORE S) + ; JPG likes this option. + (MACSYMA-SOURCE-FILE-IN-CORE S) + (+ 10000. IND))) + (IF (MACSYMA-SOURCE-FILE-SPLIT S) + (ALTER-MACSYMA-SOURCE-FILE + S + FASL-DIR 'MAXOUT + UNFASL-DIR 'MAXOUT)) + (IF (MACSYMA-SOURCE-FILE-IN-CORE S) + (SETF (MACSYMA-SOURCE-FILE-FASL-DIR S) 'MAXDMP)) + (IF (NOT (MACSYMA-SOURCE-FILE-MAINTAINERS S)) + (SETF (MACSYMA-SOURCE-FILE-MAINTAINERS S) + (LIST (MACSYMA-SOURCE-FILE-DIR S)))) + (IF (MACRO-FILE-P S) + (ALTER-MACSYMA-SOURCE-FILE + S + FASL-DIR (MACSYMA-SOURCE-FILE-DIR S) + UNFASL-DIR (MACSYMA-SOURCE-FILE-UNFASL-DIR S))) + S)) + + +(DEFUN MAKE-GENPREFIX (GOEDEL-NUMBER) + (IF (GREATERP GOEDEL-NUMBER + (1- (LSH 1 (* 7 4)))) + ; thats (TIMES 2.68 (EXP 10. 8.)) source files! + (ERROR "Goedel number is too large" GOEDEL-NUMBER 'FAIL-ACT)) + ; be a compact as possible, be obscure to be unique, + ; keep the symbol pname under one PDP10 word in size. + (DO ((N #\BS ; thats Back-Space, not Bull-Shit. + (LOGIOR (LSH N 7) (LOGAND K #o177))) + (K GOEDEL-NUMBER (LSH K -7)) + (J 0 (1+ J))) + ((= J 4.) + ; am only taking 4 least significant ASCII's. + (SETQ N (LSH N 1)) ; LSB is not part of the game. + ; PNPUT takes a list of FIXNUMs in the internal representation + ; of Maclisp pnames. Trailing ^@ are ignored by EXPLODEN + ; FLATC, PRINT. + (PNPUT (LIST N) NIL)))) + +(IF (STATUS FEATURE COMPLR) (*EXPR MACRO-FILE-P)) + +(DEFUN MACRO-FILE-P (X) + (OR (MACSYMA-SOURCE-FILE-GLOBAL-COMPILE X) + (MACSYMA-SOURCE-FILE-SELECTIVE-COMPILE X) + (MACSYMA-SOURCE-FILE-MACRO-COMPILE X))) \ No newline at end of file diff --git a/src/maxtul/docgen.37 b/src/maxtul/docgen.37 new file mode 100755 index 00000000..c0a3a618 --- /dev/null +++ b/src/maxtul/docgen.37 @@ -0,0 +1,335 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; To generate TAGS file, CODESIZE file, and files used by the macsyma +;;; loader. -GJC 11:41pm Saturday, 25 October 1980 +;;; See end of file for function to call. + +(INCLUDEF "LIBMAX;GPRELUDE >") + +(EVAL-WHEN (EVAL COMPILE LOAD) + (OR (GET 'DEFMFILE 'VERSION) + (LOAD '((MAXTUL) DEFILE))) + (OR (FBOUNDP 'FASDUMP) + (DEFPROP FASDUMP ((DSK LIBLSP) FASDMP) AUTOLOAD))) + +(DECLARE (*EXPR FASDUMP)) + +(DEFVAR INFO-LOADED NIL) + +(DEFUN LOAD-INFO () + (COND ((NOT INFO-LOADED) + (IF (OR (NOT (BOUNDP 'MACSYMA-SOURCE-FILES)) + (NULL MACSYMA-SOURCE-FILES)) + (LOAD '((MAXDOC) FILES))) + (MAPC #'SET-PRESENT-VERSION MACSYMA-SOURCE-FILES) + (SETQ INFO-LOADED T)))) + + +(DEFUN GEN-NTAGS (&AUX OUTSTREAM WINP (NAME "DSK:MACSYM;MACSYM NTAGS")) + (LOAD-INFO) + (UNWIND-PROTECT + (PROGN + (SETQ OUTSTREAM (OPEN (TEMP-FILENAME NAME) 'OUT)) + (DO ((L (SORT (APPEND MACSYMA-SOURCE-FILES NIL) + #'(LAMBDA + (A B) + (< (MACSYMA-SOURCE-FILE-TAGS-PRECEDENCE A) + (MACSYMA-SOURCE-FILE-TAGS-PRECEDENCE B)))) + (CDR L))) + ((NULL L)) + (FORMAT OUTSTREAM + "DSK:~A;~A >~%0,~A~%~%" + (MACSYMA-SOURCE-FILE-DIR (CAR L)) + (MACSYMA-SOURCE-FILE-NAME (CAR L)) + (MACSYMA-SOURCE-FILE-LANGUAGE (CAR L)))) + + (SETQ WINP T)) + + ;; unwind protected. + (IF WINP (RENAMEF OUTSTREAM NAME) (IF OUTSTREAM (CLOSE OUTSTREAM))))) + + +;;; Moby assed function to gronk UNFASL files. + +(DEFUN SET-CODESIZE (S OB EOF &AUX (FILE `((,(MACSYMA-SOURCE-FILE-UNFASL-DIR S)) + ,(MACSYMA-SOURCE-FILE-NAME S) + UNFASL))) + (COND ((MACRO-FILE-P S)) + ((PROBEF FILE) + (CNAMEF OB FILE) + ;; a file object is an argument so that + ;; GCing of file objects can be avoided. + (UNWIND-PROTECT + (PROGN + (OPEN OB 'IN) + (DO ((FORM (LET ((F (READ OB EOF))) + (READ OB EOF) + ;; To get '(ASSEMBLED BY ...) + (SETF (MACSYMA-SOURCE-FILE-UNFASL-HEADER S) + (NAMELIST (CAR (LAST (CADR F))))) + F) + (READ OB EOF)) + (SPLITS NIL) + (PREVIOUS-POSSIBLE-SPLIT NIL) + ;; Only enter a name into SPLITS if there + ;; are forms after the '(THIS IS THE UNFASL FOR *) + ;; which indicate that the FASL file is actually + ;; produced. + (FORMS-IN-SPLIT? NIL) + (CODESIZE 0)) + ((EQ FORM EOF) + (SETF (MACSYMA-SOURCE-FILE-CODESIZE S) CODESIZE) + (IF FORMS-IN-SPLIT? + (PUSH PREVIOUS-POSSIBLE-SPLIT SPLITS)) + (IF SPLITS + (SETF (MACSYMA-SOURCE-FILE-SPLIT S) SPLITS)) + S) + + ;; Pick up the comments in the fasl file, + ;; split-files will have multiple such comments. + ;; HAND-COMPILED pattern MATCHQ + (COND ((ATOM FORM)) + ((EQ (CAR FORM) 'QUOTE) + (SETQ FORM (CADR FORM)) + (COND ((ATOM FORM) + (SETQ FORMS-IN-SPLIT? T)) + ((EQ (CAR FORM) 'THIS) + ;; (THIS IS THE UNFASL FOR *) + (READ OB EOF) + ;; (ASSEMBLED BY *) + (IF FORMS-IN-SPLIT? + (PUSH PREVIOUS-POSSIBLE-SPLIT SPLITS)) + (SETQ FORMS-IN-SPLIT? NIL) + (SETQ PREVIOUS-POSSIBLE-SPLIT + (CADR (NAMELIST + (CAR (LAST FORM)))))) + (T + (SETQ FORMS-IN-SPLIT? T)))) + ((EQ (CAR FORM) 'COMMENT) + (SETQ FORMS-IN-SPLIT? T) + ;;`(COMMENT **FASL** TOTAL = ,X WORDS) + ;;`(COMMENT **FASL** ,X TOTAL) + (SETQ FORM (CDR FORM)) + (COND ((EQ (CAR FORM) '**FASL**) + (SETQ FORM (CDR FORM)) + (COND ((EQ (CAR FORM) 'TOTAL) + (SETQ CODESIZE + (+ CODESIZE + (CADDR FORM)))) + ((EQ (CADR FORM) 'TOTAL) + ;; For old UNFASL files. + (IF (FIXP (CAR FORM)) + (SETQ CODESIZE + (+ CODESIZE + (CAR FORM))))))))) + (T + (SETQ FORMS-IN-SPLIT? T))))) + ;; unwind protected + (CLOSE OB))) + (T + (FORMAT MSGFILES + "~&; Can't find UNFASL file for ~A~%" + (NAMESTRING FILE))))) + +(DEFUN CODESIZE-SUB (OUTSTREAM L WHERE COUNT) + (FORMAT OUTSTREAM + "~2%The following are statistics for ~A-core files:~%" WHERE) + (DO ((SUM 0)) + ((NULL L) + (FORMAT OUTSTREAM + "~%The total is: ~D." SUM) + (CONS COUNT SUM)) + (SETQ COUNT (1+ COUNT) + SUM (+ SUM (OR (MACSYMA-SOURCE-FILE-CODESIZE (CAR L)) 0))) + (FORMAT OUTSTREAM + "~%~3D. ~28S~5D.~%" + COUNT + (OR (MACSYMA-SOURCE-FILE-UNFASL-HEADER (CAR L)) + `((DSK ,(MACSYMA-SOURCE-FILE-DIR (CAR L))) + ,(MACSYMA-SOURCE-FILE-NAME (CAR L)))) + (MACSYMA-SOURCE-FILE-CODESIZE (CAR L))) + (SETQ L (CDR L)))) + +(DEFUN IN-CORE-FILES (L) + (SORT (DEL #'(LAMBDA (IGNORE S) (NOT (MACSYMA-SOURCE-FILE-IN-CORE S))) + NIL + (APPEND L NIL)) + #'(LAMBDA (A B) + (< (MACSYMA-SOURCE-FILE-IN-CORE A) + (MACSYMA-SOURCE-FILE-IN-CORE B))))) + +(DEFUN INTERSECTIONP (X1 X2) + (DO () + ((NULL X1) NIL) + (IF (MEMQ (POP X1) X2) (RETURN T)))) + +(DEFUN OUT-OF-CORE-FILES (L) + (SORT (DEL #'(LAMBDA (IGNORE S) + (OR (MACSYMA-SOURCE-FILE-IN-CORE S) + (MACRO-FILE-P S) + (NOT (EQ (MACSYMA-SOURCE-FILE-LANGUAGE S) + 'LISP)) + (INTERSECTIONP + '(PDP10 ITS) + (MACSYMA-SOURCE-FILE-SYSTEMS-NOT-FOR S)) + (NOT (INTERSECTIONP + '(PDP10 ITS) + (MACSYMA-SOURCE-FILE-SYSTEMS-FOR S))))) + NIL + (APPEND L NIL)) + #'(LAMBDA (A B) + (< (MACSYMA-SOURCE-FILE-GOEDEL-NUMBER A) + (MACSYMA-SOURCE-FILE-GOEDEL-NUMBER B))))) + +(DEFUN GEN-CODEL (&AUX INSTREAM OUTSTREAM WINP (NAME "MAXDOC;CODEL >") + (EOF (LIST NIL)) TEMP GRAND-SUM) + (LOAD-INFO) + (UNWIND-PROTECT + (PROGN + (SETQ INSTREAM (OPEN '((NUL)) 'IN)) + (CLOSE INSTREAM) + (CNAMEF INSTREAM '((DSK))) ; get rid of NUL device atribute. + ;; going to be reading in LOTS of symbols then throwing them out. + (GCTWA T) + (DO ((L MACSYMA-SOURCE-FILES (CDR L))) + ((NULL L)) + (SET-CODESIZE (CAR L) INSTREAM EOF)) + (SETQ OUTSTREAM (OPEN (TEMP-FILENAME NAME) 'OUT)) + (FORMAT-TIMEDATE OUTSTREAM) + (FORMAT OUTSTREAM + "~2%The Macsyma system code-size in PDP-10 words.~ + ~%Macsyma-source-files version ~A." + (Get 'macsyma-source-files 'version)) + (SETQ TEMP (CODESIZE-SUB OUTSTREAM + (IN-CORE-FILES MACSYMA-SOURCE-FILES) + "in" + 0) + GRAND-SUM (CDR TEMP)) + (SETQ TEMP (CODESIZE-SUB OUTSTREAM + (OUT-OF-CORE-FILES MACSYMA-SOURCE-FILES) + "out-of" + (CAR TEMP)) + GRAND-SUM (+ GRAND-SUM (CDR TEMP))) + (FORMAT OUTSTREAM + "~3%The grand total is: ~D.~%" GRAND-SUM) + (SETQ WINP T)) + ;; unwind protected + (IF WINP (RENAMEF OUTSTREAM NAME) (IF OUTSTREAM (CLOSE OUTSTREAM))))) + +(DEFUN SET-MACSYMA-SOURCE-FILE-CODESIZE (OB &AUX INSTREAM) + ;; one-time call entry point. + (SETQ INSTREAM (OPEN '((NUL)) 'IN)) + (CLOSE INSTREAM) + (CNAMEF INSTREAM '((DSK))) + (SET-CODESIZE OB INSTREAM (LIST NIL))) + +(DEFUN GEN-COMPLR-CHECK (&AUX OUTSTREAM WINP (NAME "MAXDOC;MCLDAT >")) + (LOAD-INFO) + ;; used by :MCL + (UNWIND-PROTECT + (PROGN + (SETQ OUTSTREAM (OPEN (TEMP-FILENAME NAME) 'OUT)) + (FORMAT OUTSTREAM "; Compiler source file database.~%; ") + (FORMAT-TIMEDATE OUTSTREAM) + (FORMAT OUTSTREAM "~%(SETQ MACSYMA-FILE-NAMES NIL)") + (DO ((L MACSYMA-SOURCE-FILES (CDR L))) + ((NULL L)) + (LET* ((F (CAR L)) + (NAME (MACSYMA-SOURCE-FILE-NAME F))) + (FORMAT OUTSTREAM + "~ + ~%(PUSH '~S MACSYMA-FILE-NAMES)~ + ~%(DEFPROP ~S ~S DIR)~ + ~%(DEFPROP ~S ~S GENPREFIX)" + NAME + NAME + (MACSYMA-SOURCE-FILE-DIR F) + NAME + (MACSYMA-SOURCE-FILE-GENPREFIX F) + ) + (IF (MACRO-FILE-P (CAR L)) + (FORMAT OUTSTREAM + "~%(DEFPROP ~S T MACRO-FILE)" + NAME) + (FORMAT OUTSTREAM + "~ + ~%(DEFPROP ~S ~S UNFASL-DIR)~ + ~%(DEFPROP ~S ~S FASL-DIR)~ + ~%(DEFPROP ~S ~S ERRMSG-DIR)~ + ~%(DEFPROP ~S ~S IN-CORE)" + NAME + (MACSYMA-SOURCE-FILE-UNFASL-DIR F) + NAME + (MACSYMA-SOURCE-FILE-FASL-DIR F) + NAME + (MACSYMA-SOURCE-FILE-ERRMSG-DIR F) + NAME + (MACSYMA-SOURCE-FILE-IN-CORE F))))) + (TERPRI OUTSTREAM) + (SETQ WINP T)) + ;; unwind protected. + (IF WINP (RENAMEF OUTSTREAM NAME) (IF OUTSTREAM (CLOSE OUTSTREAM)))) + + (FASL-IZE NAME)) + +(DEFUN DOWNCASE-s (THING &OPTIONAL (N 0)) + (SETQ THING (EXPLODEN THING)) + (DO ((L (NTHCDR N THING) (CDR L))) + ((NULL L) (MAKNAM THING)) + (LET ((C (CAR L))) + (IF (NOT (OR (> C #/Z) (< C #/A))) + (SETF (CAR L) + (+ C (- #/a #/A))))))) + +(DEFUN FORMAT-TIMEDATE (STREAM) + (LET (((YEAR MONTH DAY)(STATUS DATE)) + ((HOUR MINUTE) (STATUS DAYTIME)) + (DOW (STATUS DOW)) + (AM NIL)) + (COND ((< HOUR 12.) + (SETQ AM T) + (IF (= HOUR 0) (SETQ HOUR 12.))) + ((> HOUR 12.) + (SETQ HOUR (- HOUR 12.)))) + (FORMAT STREAM + "~A, ~ + ~[January~;Februrary~;March~;April~;May~;June~;July~ + ~;August~;September~;October~;November~;December~:;FOO~] ~ + ~D, 19~2,'0D ~D:~2,'0D~:[pm~;am~]" + (DOWNCASE-S DOW 1) + (1- MONTH) DAY YEAR HOUR MINUTE AM))) + + + +(DEFUN FASL-IZE (FILE &AUX (NAME (MERGEF '((* *) * FASL) FILE)) + INSTREAM (EOF (LIST NIL))) + (UNWIND-PROTECT + (PROGN + (SETQ INSTREAM (OPEN FILE 'IN)) + (DO ((L (LIST `(COMMENT ,(TRUENAME INSTREAM))) + (CONS FORM L)) + (FORM `(COMMENT ,(FORMAT-TIMEDATE NIL)) + (READ INSTREAM EOF))) + ((EQ FORM EOF) + (SETQ L (NREVERSE L)) + (FASDUMP NAME ; FASDUMP has its own WINP settup. + L ; non-hashed stuff. + NIL ; hashed stuff. + NIL ; Alist for substructures. + )))) + (IF INSTREAM (CLOSE INSTREAM)))) + +(DEFUN SET-PRESENT-VERSION (X) + (LET* ((FILE-NAME `((DSK ,(MACSYMA-SOURCE-FILE-DIR X)) + ,(MACSYMA-SOURCE-FILE-NAME X) + >)) + (TRUE-FILE-NAME (PROBEF FILE-NAME))) + (COND (TRUE-FILE-NAME + (SETF (MACSYMA-SOURCE-FILE-VERSION X) + (CADDR TRUE-FILE-NAME))) + (T + (FORMAT MSGFILES + "~&; Hey, I can't find the macsyma source file ~A.~%" + (NAMESTRING FILE-NAME)))))) \ No newline at end of file diff --git a/src/maxtul/error!.1 b/src/maxtul/error!.1 new file mode 100755 index 00000000..3a3827da --- /dev/null +++ b/src/maxtul/error!.1 @@ -0,0 +1,99 @@ +;;-*-LISP-*- +;; FIND 'DEM ERROR MESSAGES! +;; 4:32pm Saturday, 18 July 1981 -George Carrete. + +;; Each function will get an MERROR, MFORMAT, MTELL, and ERRRJF +;; property which will be a string. From this we can generate +;; a report on all macsyma error messages and wisecracks. +;; Super neato. + +;; Note: Due to pdp-10 address space problems or maclisp problems, +;; hard to tell which, we aren't doing a two-pass operation. + +(eval-when (eval compile) + (or (get 'defmfile 'version) + (load '((Maxtul)defile))) + (or (get 'toolm 'version) + (load '((maxtul)toolm)))) + +(declare (special current-module macsyma-source-file faslread-type + faslread-object)) + +(DEFVAR MESSAGE-FUNCTIONS-TABLE + '((MERROR *MERROR-1 *MERROR-2 *MERROR-3 *MERROR-4 *MERROR-5) + (MFORMAT *MFORMAT-2 *MFORMAT-3 *MFORMAT-4 *MFORMAT-5) + (MTELL MTELL1 MTELL2 MTELL3 MTELL4 MTELL5) + (ERRRJF *ERRRJF-1))) + +(MAPC #'(LAMBDA (L) + (MAPC #'(LAMBDA (F) (PUTPROP F (CAR L) 'DA-FUNCTION)) + L)) + MESSAGE-FUNCTIONS-TABLE) + +(DEFVAR MESSAGE-FUNCTIONS (MAPCAR #'CAR MESSAGE-FUNCTIONS-TABLE)) +(DEFVAR MESSAGE-FUNCTIONS-FLATSIZE + (APPLY #'MAX (MAPCAR #'FLATSIZE MESSAGE-FUNCTIONS))) + +(DEFVAR CURRENT-PLIST NIL) +(DEFVAR CURRENT-MESSAGE NIL) + +(DEFUN FIND-MESSAGES-IN-MODULE (M &AUX + (CURRENT-PLIST (LIST NIL)) + (CURRENT-MESSAGE NIL)) + (MAP-OVER-FASL-INFO-IN-MODULE + #'MESSAGE-SNOOP + M + '(QLIST ENTRY CALL MIN))) + +(DEFUN MESSAGE-SNOOP (FORM) + (CASEQ FASLREAD-TYPE + ((QLIST) + (COND ((AND (EQ (TYPEP FORM) 'HUNK2) + (EQ (CAR FORM) (FASLREADSQUID FASLREAD-OBJECT)) + (EQ (CADR FORM) 'ALLOCATE-MESSAGE-INDEX)) + (SETQ CURRENT-MESSAGE (CHECK-OUT-OF-CORE-STRING (EVAL (CDR FORM)))) + (PUTPROP CURRENT-MESSAGE T '+INTERNAL-STRING-MARKER)))) + ((CALL) + (LET ((DA-FUNCTION (GET FORM 'DA-FUNCTION))) + (COND (DA-FUNCTION + (ADDPROP? CURRENT-PLIST CURRENT-MESSAGE DA-FUNCTION) + (SETQ CURRENT-MESSAGE NIL))))) + ((ENTRY) + (COND ((CDR CURRENT-PLIST) + (SETF (CAR CURRENT-PLIST) (LIST FORM CURRENT-MODULE)) + (OUTPUT-MESSAGE-PLIST CURRENT-PLIST) + (SETQ CURRENT-PLIST (LIST NIL))))))) + +(defun find-all-MESSAGES (&aux (modules (macsyma-runtime-modules))) + (format msgfiles + "~&; Looking in the following modules for MESSAGES:~ + ~%~S~%" + modules) + (mapc #'find-MESSAGES-IN-MODULE modules)) + +(DEFUN OUTPUT-MESSAGE-PLIST (S) + (FORMAT MSGFILES "~&(~S" (CAR S)) + (DO ((L MESSAGE-FUNCTIONS (CDR L)) + (M)) + ((NULL L) + (FORMAT MSGFILES ")~%")) + (COND ((SETQ M (GET S (CAR L))) + (FORMAT MSGFILES "~% ~S~vx (" + (CAR L) + (- MESSAGE-FUNCTIONS-FLATSIZE (FLATSIZE (CAR L)))) + (DO () + ((NULL M) + (PRINC ")" MSGFILES)) + (PRIN1 (POP M) MSGFILES) + (IF M (FORMAT MSGFILES "~% ~vX " + MESSAGE-FUNCTIONS-FLATSIZE))))))) + +(deftoolage module-messages () + "look for messages in a module" + (find-messages-in-module + (car (completing-read "Module-> " (macsyma-runtime-modules))))) + +(deftoolage find-all-messages () + "Map over all FASL files for FSUBRS finding." + "Use the Report-on-fsubrs command after this to see summary" + (find-all-messages)) \ No newline at end of file diff --git a/src/maxtul/expand.10 b/src/maxtul/expand.10 new file mode 100755 index 00000000..779568da --- /dev/null +++ b/src/maxtul/expand.10 @@ -0,0 +1,122 @@ +;;; -*- LISP -*- +;;; +;;; EXPAND: A package for macroexpanding files +;;; +;;; 1:20am Saturday, 6 October 1979 :KMP +;;; 4:31am Sunday, 30 March 1980 :GJC EOF-COMPILE-QUEUE +;;; 5:43pm Thursday, 16 April 1981 :GJC KLEANED UP FOR USE IN MCL. + +(HERALD EXPAND) + +(EVAL-WHEN (COMPILE EVAL) + (OR (GET 'IOTA 'VERSION) (LOAD '((LIBLSP)IOTA)))) + +(DEFUN COPY MACRO (X) `(SUBST NIL NIL ,(CADR X))) + +(DEFVAR LISP->LISP NIL) + +(DECLARE (SPECIAL EOF-COMPILE-QUEUE) + (*EXPR MACRO-EXPAND)) + +(DEFUN LISP->LISP (INPUT-FILE &OPTIONAL (OUTPUT-FILE "")) + (SETQ OUTPUT-FILE (MERGEF OUTPUT-FILE "* MACROD")) + (SETQ OUTPUT-FILE (MERGEF OUTPUT-FILE INPUT-FILE)) + (LET ((EOF-COMPILE-QUEUE NIL)) + (IOTA ((INFILE INPUT-FILE 'IN) + (OUTSTREAM (MERGEF "* _ACRO_" OUTPUT-FILE) 'OUT)) + (LISP->LISP\WORKER INFILE OUTSTREAM) + (DO ((MORE-STUFF EOF-COMPILE-QUEUE + EOF-COMPILE-QUEUE)) + ((NULL MORE-STUFF)) + ;; this might not be exactly the way COMPLR handles it. + (SETQ EOF-COMPILE-QUEUE NIL) + (PRINT '(COMMENT **EXPAND** START OF EOF-COMPILE-QUEUE) + OUTSTREAM) + (LISP->LISP\WORKER-FROM-LIST (REVERSE MORE-STUFF) + T OUTSTREAM) + (PRINT '(COMMENT **EXPAND** END OF EOF-COMPILE-QUEUE) + OUTSTREAM)) + (RENAMEF OUTSTREAM OUTPUT-FILE) + ))) + +(DEFUN LISP->LISP\WORKER (INFILE OUTSTREAM) + (DO ((FORM (READ INFILE INFILE) + (READ INFILE INFILE)) + (OUTFILES (NCONS OUTSTREAM)) + (LISP->LISP T) + (/^Q T) + (/^R T) + (/^W T)) + ((EQ FORM INFILE)) + (SPRINTER (COND ((ATOM FORM) FORM) + (T + (LISP->LISP\MUNG-TOPLEVEL FORM + INFILE + OUTSTREAM)))))) + +(DEFMACRO POPR (X L) + `(COND ((NULL ,X) ,L) + (T (POP ,X)))) + +(DEFUN LISP->LISP\WORKER-FROM-LIST (IN-LIST INFILE OUTSTREAM + &AUX (IN-FORMS IN-LIST)) + (DO ((FORM (POPR IN-FORMS IN-LIST) + (POPR IN-FORMS IN-LIST)) + (OUTFILES (NCONS OUTSTREAM)) + (LISP->LISP T) + (/^Q T) + (/^R T) + (/^W T)) + ((EQ FORM IN-LIST)) ;;; IN-LIST IS UNIQUE IF NON-CIRCULAR + (SPRINTER (COND ((ATOM FORM) FORM) + (T + (LISP->LISP\MUNG-TOPLEVEL FORM + INFILE + OUTSTREAM)))))) + + +(DEFUN LISP->LISP\MUNG-TOPLEVEL (FORM INFILE OUTSTREAM) + (LET ((FUN (GET (CAR FORM) 'LISP->LISP\MUNGING-FUNCTION))) + (COND (FUN (FUNCALL FUN FORM INFILE OUTSTREAM)) + (T + (MACRO-EXPAND FORM))))) + +(DEFUN (DECLARE LISP->LISP\MUNGING-FUNCTION) (FORM () ()) + (MAPC 'EVAL (COPY (CDR FORM))) + (MACRO-EXPAND FORM)) + +(DEFUN (EVAL-WHEN LISP->LISP\MUNGING-FUNCTION) (FORM () ()) + ;; EVAL-WHEN-LOAD ISN'T TAKEN CARE OF, IT SHOULD CALL + ;; THE MUNG-FORM-LIST FUNCTION + (COND ((MEMQ 'COMPILE (CADR FORM)) + (MAPC 'EVAL (COPY (CDDR FORM))))) + (MACRO-EXPAND FORM)) + +(DEFUN (INCLUDE LISP->LISP\MUNGING-FUNCTION) (FORM () OUTSTREAM) + (PRINT `(COMMENT **EXPAND** INSERTING FILE ,(CADR FORM)) OUTSTREAM) + (IOTA ((INFILE (CADR FORM) 'IN)) + (LISP->LISP\WORKER INFILE OUTSTREAM)) + `(COMMENT **EXPAND** DONE INSERTING FILE ,(CADR FORM))) + +(DEFUN (INCLUDEF LISP->LISP\MUNGING-FUNCTION) (FORM INFILE OUTSTREAM) + (LET ((FILENAME (EVAL (CADR FORM)))) + (FUNCALL (GET 'INCLUDE 'LISP->LISP\MUNGING-FUNCTION) + (LIST '*DUMMY* FILENAME) INFILE OUTSTREAM))) + +(DEFUN (DEFUN LISP->LISP\MUNGING-FUNCTION) (FORM () ()) + ;(COND ((MEMQ (CADDR FORM) '(/&OPTIONAL /&REST /&WHOLE /&AUX)) + (RPLACA FORM 'DEFUN/&) + (MACRO-EXPAND FORM)) + + +(DECLARE (SPECIAL MACRO-FILES)) + +(DEFUN (LOAD-MACSYMA-MACROS LISP->LISP\MUNGING-FUNCTION) (FORM () ()) + `(COMMENT *** LOADING MACSYMA MACROS *** + ,@(MAPCAR + #'(LAMBDA (X) + (OR (GET X 'VERSION) + (PROGN (LOAD (MACRO-DIR X)) + (PUSH X MACRO-FILES))) + (MACRO-DIR X)) + (CDR FORM)))) \ No newline at end of file diff --git a/src/maxtul/fasmap.5 b/src/maxtul/fasmap.5 new file mode 100755 index 00000000..748c28bb --- /dev/null +++ b/src/maxtul/fasmap.5 @@ -0,0 +1,101 @@ +;;-*-LISP-*- +;; For mapping over da objects in da FASL files +;; of Macsyma. 6:36pm Wednesday, 15 July 1981 +;; -George Carrette. + +;; Functions of interest: + +;; (MACSYMA-RUNTIME-MODULES) returns list of module names. + +;; (MAP-OVER-FASL-INFO-IN-MODULE +;; &optional ) +;; During the mapping the following special variables are bound: +;; CURRENT-MODULE +;; MACSYMA-SOURCE-FILE +;; FASLREAD-TYPE + +;; (ADDPROP? ) good for gathering info. + + +(eval-when (eval compile) + (or (get 'defmfile 'version) + (load '((Maxtul)defile)))) + +(declare (special faslread-type) + (*expr faslread faslreadclose) + (*lexpr faslreadopen)) + + +(defvar current-module) +(defvar macsyma-source-file) +(defvar faslread-object) + +(DEFUN ADDPROP? (SYMBOL OBJECT KEY) + ;; Returns NIL if it is info already known, non-nil if not known. + (LET ((L (GET SYMBOL KEY))) + (IF (MEMQ OBJECT L) + NIL + (PUTPROP SYMBOL (CONS OBJECT L) KEY)))) + +(defun macsyma-runtime-modules () + (sort (mapcan #'(lambda (u) + (if (not (macro-file-p u)) + (list (macsyma-source-file-name u)))) + macsyma-source-files) + #'alphalessp)) + +(DEFUN MAP-OVER-FASL-INFO-IN-MODULE (F CURRENT-MODULE + &OPTIONAL + (OPTIONS () OPTIONS-P)) + (LET ((MACSYMA-SOURCE-FILE (ASS #'(LAMBDA (A B) + (EQ A (MACSYMA-SOURCE-FILE-NAME B))) + CURRENT-MODULE + MACSYMA-SOURCE-FILES))) + (IF (NULL MACSYMA-SOURCE-FILE) + (FORMAT MSGFILES "~&; Module not a macsyma-source-file : ~S~%" + current-module) + (LET ((SOURCE-FILE (NAMESTRING `((DSK ,(MACSYMA-SOURCE-FILE-DIR)) + ,(MACSYMA-SOURCE-FILE-NAME) + >))) + (FASL-FILES (CONS (MACSYMA-SOURCE-FILE-NAME) + (MACSYMA-SOURCE-FILE-SPLIT)))) + (IF (MEMQ (CAR FASL-FILES) (CDR FASL-FILES)) + (SETQ FASL-FILES (CDR FASL-FILES))) + (FORMAT MSGFILES + "~&; For source file ~A~%" source-file) + (do ((l fasl-files (cdr l))) + ((null l)) + (LET ((Filename (NAMESTRING `((DSK ,(MACSYMA-SOURCE-FILE-FASL-DIR)) + ,(CAR L) FASL))) + (ff-object)) + (IF (NOT (PROBEF Filename)) + (FORMAT MSGFILES + "~&; Possible file ~A not found.~%" Filename) + (unwind-protect + (map-over-fasl-info-in-object + f + (setq ff-object + (if options-p + (faslreadopen filename options) + (faslreadopen filename)))) + (faslreadclose ff-object))))))))) + +(defun map-over-fasl-info-in-object (f ff-object) + (let ((faslread-type nil) + (faslread-object ff-object) + #+complr + (fast-f (or (and (symbolp f) + (eq (car (getl f '(subr lsubr expr fexpr fsubr))) + 'subr) + (get f 'subr)) + ;; ask me about this code someday. -gjc + (boole 7 13._27. + (lsh 1 23.) + (maknum f))))) + (do ((form)) + (nil) + (setq form (faslread ff-object)) + (if (eq faslread-type 'eof) (return nil)) + #+complr (subrcall nil fast-f form) + #-complr (funcall f form) + ))) \ No newline at end of file diff --git a/src/maxtul/fsubr!.5 b/src/maxtul/fsubr!.5 new file mode 100755 index 00000000..34aabc60 --- /dev/null +++ b/src/maxtul/fsubr!.5 @@ -0,0 +1,144 @@ +;;-*-LISP-*- +;; FIND 'DEM FSUBRS! +;; We want to find all places that define FSUBRS, +;; and all places that knowingly call FSUBRS as if +;; they were regular functions. This is for getting rid +;; of such hackery to help Transportability to NIL. -gjc + +;; If somebody has done (declare (*fexpr foobar)) then +;; (foobar ...) the not very common case, or, +;; (apply 'foobar <...>) the common case we are really after, +;; compiles into +;; (JCALL 17 'FOOBAR) +;; which is a UUO that, when FOOBAR has an FSUBR property, +;; acts the same as (JCALL1 'FOOBAR) if FOOBAR had a SUBR property. +;; That is, just like a regular subr call of one argument. + +(eval-when (eval compile) + (or (get 'defmfile 'version) + + (load '((Maxtul)defile))) + (or (get 'toolm 'version) + (load '((maxtul)toolm)))) + +(declare (special current-module macsyma-source-file faslread-type)) + +;; For each FSUBR keep a FSUBR-DEFINED-IN property. +;; For each FSUBR keep a FSUBR-REFERENCED-IN property. + +(defun fsubr-snoop (frob) + (caseq faslread-type + (call + (if (= (cadr frob) #o17) + (if (addprop? (caddr frob) + current-module + 'fsubr-referenced-in) + (format msgfiles + "~&; Got an fsubr reference! -> ~S~%" + (caddr frob))))) + (entry + (if (eq (cadr frob) 'fsubr) + (if (addprop? (car frob) + current-module + 'fsubr-defined-in) + (format msgfiles + "~&; Got an fsubr definition! -> ~S~%" + (car frob) + )))))) + +(defun find-fsubrs-in-module (m) + (map-over-fasl-info-in-module + #'fsubr-snoop + m + '(entry call))) + +(defun find-all-fsubrs (&aux (modules (macsyma-runtime-modules))) + (format msgfiles + "~&; Looking in the following modules for FSUBRS:~ + ~%~S~%" + modules) + (mapc #'find-fsubrs-in-module modules)) + +(defvar report-on-fsubrs ()) + +(defun report-on-fsubrs (&AUX report-on-fsubrs) + (mapatoms #'(lambda (p) + (if (or (get p 'fsubr-defined-in) + (get p 'fsubr-referenced-in)) + (push p report-on-fsubrs)))) + (setq report-on-fsubrs (sort report-on-fsubrs #'alphalessp)) + (mapc #'(lambda (p) + (format MSGFILES "~ + ~&(~S~ + ~% fsubr-defined-in ~S~ + ~% fsubr-referenced-in ~S) ~%" + p + (get p 'fsubr-defined-in) + (get p 'fsubr-referenced-in))) + report-on-fsubrs) + report-on-fsubrs) + +(defun read-a-module () + (car (completing-read "Module-> " (macsyma-runtime-modules)))) + +(deftoolage module-fsubrs () + "look for FSUBR hackery in a module" + (find-fsubrs-in-module (read-a-module))) + + +(deftoolage report-on-fsubrs () + "Output a report of all info in the environment on fsubrs" + (report-on-fsubrs)) + +(deftoolage find-all-fsubrs () + "Map over all FASL files for FSUBRS finding." + "Use the Report-on-fsubrs command after this to see summary" + (find-all-fsubrs)) + + +(defun defmspec-entries-in-module (m) + (map-over-fasl-info-in-module + #'(lambda (entry) + (cond ((eq (cadr entry) 'mfexpr*s) + (format msgfiles "~&; Got one: ~S~%" (car entry)) + (putprop (car entry) t '*fexpr)))) + m + '(entry))) + +(deftoolage defmspec-forms-in-module () + "Find DEFMSPEC definitions in a module" + (defmspec-entries-in-module (read-a-module))) + +(deftoolage find-all-defmspecs () + "Map over modules gathering DEFMSPEC properties" + (let ((Modules (macsyma-runtime-modules))) + (format msgfiles + "~&; Looking for DEFMSPEC in the following modules:~%~S" + modules) + (mapc #'Defmspec-entries-in-module modules))) + + +(deftoolage generate-defmspec-declare-file () + "Generate the file MAXDOC;DCL FEXPR" + (let ((stream)) + (unwind-protect + (progn (setq stream (open "DSK:MAXDOC;DCL _FEXP_" 'OUT)) + (format stream + "~&; *FEXPR declarations are fake, actually these are~ + ~%; all DEFMSPEC's and this information is used only~ + ~%; by the Macsyma->Lisp translator. -gjc~%~%") + (format stream + "(*FEXPR ") + (let ((out-stream stream) + (j 0)) + (declare (special out-stream j)) + (mapatoms #'(lambda (a) + (cond ((get a '*fexpr) + (if (zerop (\ j 5.)) + (terpri out-stream)) + (setq j (1+ j)) + (princ " " out-stream) + (prin1 a out-stream)))))) + (princ ") " stream) + (renamef stream "* FEXPR")) + (if stream (close stream))))) diff --git a/src/maxtul/mailer.2 b/src/maxtul/mailer.2 new file mode 100755 index 00000000..91519201 --- /dev/null +++ b/src/maxtul/mailer.2 @@ -0,0 +1,37 @@ +;;;-*-lisp-*- + +(herald mailer) + +;;; a standard norman mailer. + +;;; example. +;;; (FORMAT-MAIL 'GJC +;;; "Hey man, what time is ~:[lunch~;dinner~]?" dinnerp) + +(DEFUN FORMAT-MAIL (TO-LUSERS STRING &REST ARGUMENTS + &AUX STREAM WINP) + (IF (ATOM TO-LUSERS) + (SETQ TO-LUSERS (LIST TO-LUSERS))) + + (UNWIND-PROTECT + (PROGN + (SETQ STREAM (OPEN "DSK:.MAIL.;MCL _TEMP" 'OUT)) + (FORMAT STREAM + "~ + ~&FROM-PROGRAM:The Mathlab ~A Program~ + ~%FROM-XUNAME:~A~ + ~%FROM-UNAME:~A~ + ~{~%RCPT:(~A)~}~ + ~%TEXT;-1~%" + + (STATUS SUBSYS) + (STATUS SUBSYS) + (STATUS UNAME) + TO-LUSERS) + + (LEXPR-FUNCALL #'FORMAT STREAM STRING ARGUMENTS) + (SETQ WINP T)) + ;; unwind-protected + (IF WINP + (RENAMEF STREAM "DSK:.MAIL.;MAIL >") ; actually "sends" the mail. + (IF STREAM (DELETEF STREAM))))) \ No newline at end of file diff --git a/src/maxtul/maxtul.61 b/src/maxtul/maxtul.61 new file mode 100755 index 00000000..b3c74581 --- /dev/null +++ b/src/maxtul/maxtul.61 @@ -0,0 +1,258 @@ +;-*-LISP-*- +; maxima utilities. initialy set up for string file manglement. +; -RWK November 1980. +; restructed with a DEFTOOLAGE, & merged in my CODESIZE file +; maker, TAGS file maker, data-base maker for the macsyma->lisp +; translator, MCL (macsyma source file compiler) check file maker. +; Comment: Arguments to DEFTOOLAGE should act as more than just +; documentation, should be processed by the command loop, +; don't have time for this now. +; -GJC 4:08pm Thursday, 4 December 1980 +; added a standard argument reader. +; N.B. Inferiour JOB stuff isn't really handled properly for +; ^Z ^P P and the like. +; -GJC 2:47pm Friday, 19 December 1980 + +(HERALD MAXTUL) + +(eval-when (eval compile) + (or (get 'defmfile 'version) + (load '((maxtul)defile))) + (or (get 'IOTA 'VERSION) + (load '((LIBLSP)IOTA))) + (or (get 'ERMSGX 'VERSION) + (load '((LIBMAX) ERMSGX))) + (or (get 'TTY 'VERSION) + (load '((LIBLSP) TTY)))) + +(declare (*EXPR OPEN-MESSAGE-FILE LISPM-DECLARE-FILE-MAKE FASL-IZE DECLARE-FILE-MAKE + DISP-MACSYMA-SOURCE-FILE GEN-CODEL GEN-COMPLR-CHECK GEN-NTAGS + MERGE-INCORE-SYSTEM GET-STRING-FILE-NAME READ-UNTIL-CR + DISPLAY-STRING-FILES-NO-FASLS COMPLETING-READ GET-MFD-INDEXES)) + +(eval-when (eval compile load) + (or (get 'toolm 'version) + (load '((maxtul)toolm)))) + +(defun dump-it () + (gc) + (pure-suspend () '|MAXTUL;TS MAXTUL|) + (load '((MAXDOC)FILES)) + (load '((MAXDOC)MCLDAT)) + (get-mfd-indexes) ;Just in case + (sstatus tople '(command-loop))) + +(defun ^^-INT (stream ignore-char) + (tyi stream) + (sstatus tople '(command-loop)) + (^g)) +(sstatus ttyint #^^ #'^^-INT) + +(defvar toolage nil) + +(defvar command) + +(defun command-loop () + (do ((command)) + (NIL) + (setq command (car (completing-read '"MAXIMUM TOOLAGE>" toolage))) + (apply (or (get command 'toolage) + #'(lambda ignore-n + (format t "~&BUG: no toolage for ~S~%" + command))) + (read-argument-list (get command 'toolage-args))))) + +(defun read-argument-list (l) + (mapcar #'read-argument l)) + +(defun read-argument (desc) + (if (atom desc) (setq desc (cons 's-exp desc))) + (caseq (car desc) + (s-exp + (print (cdr desc) t) + (read t)) + (string + (read-until-cr (cdr desc))) + (t + (error "unknown type of argument to read-argument" desc + 'fail-act)))) + +(deftoolage load-info () + "Recompile MAXDOC;FILES and reload." + (ljob-run-job 'complr '|DSK:SYS;TS CL| "MAXDOC;FILES (T)") + (setq info-loaded nil) + (load-info)) + +(deftoolage load-file ((string . |Filename-> |)) + "Lisp Load a file" + (load (mergef |Filename-> | "DSK:MAXTUL;FOO *"))) + +(deftoolage REAP-STRING-DISPLAY () + "Displays the out-of-core string files from MAXERR and MAXER1" + "which do not have findable FASL files." + (display-string-files-no-fasls)) + +(deftoolage GET-FASL-STRING-FILE ((string . |(FASL file) |)) + "Tells the name of the string file which goes with that FASL file" + (let* ((filename (namelist |(FASL file) |)) + (fasldir (get (cadr filename) 'fasl-dir)) + (answer)) + (if fasldir + (setq filename + (mergef filename `((DSK ,fasldir) * FASL)))) + (setq answer (get-string-file-name filename)) + (format T "~&FASL file: ~A --> String file: ~A" + (namestring filename) + (if answer (namestring answer) + "[NONE]")))) + +(deftoolage GET-STRING-FILE-INFO ((string . |(String file) |)) + "Abstracts the information from the string file directory" + (display-string-file-info |(String file) |)) + +(deftoolage MERGE-INCORE-SYSTEM () + "Merge together the out-of-core strings for the" + "in-core files in preparation for a new MACSYMA dump." + (merge-incore-system)) + +(deftoolage gen-tags () + "Generate NTAGS file." + (format t "~&; Generating NTAGS file.~%") + (GEN-NTAGS) + (VALRET ": I'm using a VALRET :TAGS MACSYMA;MACSYMA NTAGSî:CONTINUEî") + (FORMAT T "~&; Now, do :MOVE MACSYMA;MACSYMA NTAGS, MACSYMA TAGS~ + ~%; after verifying that things are ok.~%")) + +(DEFUN MOVE-FILE (X Y) + (IF (NOT (PROBEF X)) + (ERROR "file-not-found" x 'IO-LOSSAGE)) + (IF (PROBEF Y) (DELETEF Y)) + (RENAMEF X Y)) + +(deftoolage gen-mcl-check () + "Generate MCL data base" + (gen-complr-check)) + +(deftoolage gen-codel () + "Generate MAXDOC;CODEL > listing of CODE-SIZEs" + (GEN-CODEL)) + +(deftoolage display-macsyma-source-file-info ((string . |(first name) |)) + "using information presently in the environment" + (let* ((name (cadr (namelist |(first name) |))) + ;; uppcase and intern the name with NAMELIST. + (ob + (ass #'(lambda (name item) + (eq name + (macsyma-source-file-name item))) + name + macsyma-source-files))) + (cond (ob + (cursorpos 'c) + (disp-macsyma-source-file ob t)) + (t + (format t "~&; No data for ~A" name))))) + +(deftoolage declare-file-make () + "Update the declare file used by translated code." + (declare-file-make) + (let ((f "DSK:MAXDOC;DCL LOAD")) + (format t "~&; ~A written, making FASL now." f) + (fasl-ize f))) + +(deftoolage lispm-declare-file-make () + "Update declare file used by a bare lisp machine." + (lispm-declare-file-make)) + +(deftoolage QUIT () + "To lisp TOPLEVEL" + (sstatus tople nil) + (^g)) + +(deftoolage KILL-JOB () + "Kill job" + (if (memq (car (completing-read "Kill job. [Confirm?] " + '(yes help no maybe why-not what who-me))) + '(yes maybe why-not)) + (QUIT))) + +(deftoolage HELP () + "Print this cruft." + (cursorpos 'c) + (format t "~ + ~&Welcome to the MACSYMA TOOL~ + ~%The following commands are currently implemented:") + (mapc #'(lambda (cmd) + (format t + "~&~A ~{~A ~}~%~{ ~A~%~}" + cmd + (get cmd 'toolage-args) + (or (get cmd 'toolage-doc) + '("BUG: no documentation for this!")))) + toolage) + (format t + "~ + ~&The command reader completes on altmode or space,~ + ~%so the long command names should not deter you.~ + ~%")) + +(defun msgfiles-int (stream char) + (if (= char (tyipeek () stream -1)) + (tyi stream)) + (format t + "~&; ~:[Pushing T onto~;Deleting T from~] msgfiles.~%" + (memq t msgfiles)) + (if (memq t msgfiles) + (setq msgfiles (delq t msgfiles)) + (push t msgfiles))) + +(sstatus ttyint #^N #'msgfiles-int) + +(defvar wall-file ()) +(deftoolage wallpaper () + "Toggle wallpaper output" + (cond (wall-file + (setq msgfiles (delq wall-file msgfiles)) + (close wall-file) + (format t "~&; Wall-paper file was ~S~%" + (namestring (truename wall-file))) + (setq wall-file nil)) + ('else + (format t "~&; Opening wall-paper file.~%") + (setq wall-file (open "DSK:MAXTUL;WALL >" 'OUT)) + (push wall-file msgfiles)))) + + + +(defun display-string-file-info (file) + (phi ((message-file (open-message-file file))) + (let* ((truename (truename message-file)) + (alist (message-file-alist message-file)) + (temp (or (cdr (assq 'source-file-name alist)) + (cdr (assq 'filename alist)))) + (source-files (if temp (ncons temp) + (or (cdr (assq 'filenames alist)) '()))) + (author (or (cdr (assq 'source-file-author alist)) '|???|)) + (creator (or (cdr (assq 'creator alist)) '|???|)) + (fasl (cdr (assq 'output-file-name alist))) + (funs (mapcar #'CAR (cdr (assq 'fun-doc-alist alist)))) + (vars (mapcar #'CAR (cdr (assq 'var-doc-alist alist))))) + (format t "~&Filename: ~A~%~ + Creator: ~A~%~ + Source files: ~A~%~ + Author: ~A~%~ + Output file: ~A~%~ + Documented variables: ~S~%~ + Documented functions: ~S~%~ + Total number of strings: ~D~%" + (namestring truename) + creator + (mapcar #'namestring source-files) + author + (namestring fasl) + vars funs + (cadr (assq 'message-count alist)))))) + +(or (get 'breaklevel 'version) + (load '((liblsp)break))) +(sstatus breaklevel '(Breaklevel)) diff --git a/src/maxtul/mcl.59 b/src/maxtul/mcl.59 new file mode 100755 index 00000000..963162c5 --- /dev/null +++ b/src/maxtul/mcl.59 @@ -0,0 +1,186 @@ +;;;-*-LISP-*- + +;;; Utilities for compiling and installing Macsyma. +;;; GJC - 7:21pm Monday, 27 October 1980 +(HERALD MCL) +(OR (GET 'USER-QUERY 'VERSION) (LOAD '((maxtul)QUERY))) +(or (get 'mailer 'version) (load '((maxtul)mailer))) +(OR (GET 'BREAKLEVEL 'VERSION) + (LOAD "LIBLSP;BREAK")) +(PUSH 'TTY-RETURN BREAK-VARS) +(PUSH '(LAMBDA (IGNORE) (FORMAT MSGFILES "~&;Still inside break level~%")) + BREAK-VALS) +(SSTATUS BREAKLEVEL '(BREAKLEVEL)) +(DEFVAR TEST-COMPILATION-P NIL) + +(DEFUN TEST-JNAME-P () + (LET ((JNAME (STATUS JNAME))) + (AND (> (FLATC JNAME) 3.) + (= (GETCHARN JNAME 1) #/T) + (= (GETCHARN JNAME 2) #/M) + (= (GETCHARN JNAME 3) #/C) + (= (GETCHARN JNAME 4) #/L)))) + +(DEFUN ERRSET-BREAK (IGNORE-WHO-KNOWS-WHAT) + (*BREAK T "ERRSET-BREAK. P to continue lossage.")) + +(DEFVAR MCL-BEFORE-PROC NIL) +(DEFVAR MCL-AFTER-PROC NIL) + +;;; The first time this function gets called with (STATUS JCL) +;;; the rest of the time with NIL. + +(DECLARE (SPECIAL MSDIR ; From COMPLR, tells what DIR to put UNFASL. + TTYNOTES ; T if output junk to TTY. + )) + +(DEFUN *MAKLAP-DRIVER* (JCLP) + (DO () (NIL) + (OR JCLP (CURSORPOS 'A TYO)) + (AND (TEST-JNAME-P) + (SETQ TEST-COMPILATION-P T)) + (OR JCLP (SETQ TTYNOTES T)) + (let ((FILENAME (namelist (cond (jclp (implode jclp)) + (t (read-file-name )))))) + (MCL-FILE FILENAME JCLP)) + (AND JCLP (QUIT)))) + + +(DEFUN MCL-FILE (NAME JCLP) + (LET ((((DEV DIR) FN1 FN2) NAME)) + (LET ((FASL-DIR (GET FN1 'FASL-DIR)) + (UNFASL-DIR (GET FN1 'UNFASL-DIR)) + PRESENT-VERSION PRESENT-NAME) + (SETQ PRESENT-NAME + (PROBEF (MERGEF NAME + `((DSK ,(GET FN1 'DIR)) ,FN1 >))) + PRESENT-VERSION (CADDR PRESENT-NAME)) + (COND ((NOT FASL-DIR) + (FORMAT MSGFILES + "~ + ~&; ~A is not a known Macsyma system source." + (NAMESTRING NAME)) + (COND ((Y-OR-N-OR-?-P + "Do you want to compile anyway" + "Output will go to the MACSYM directory.") + (FORMAT MSGFILES + "~&; Please update MAXDOC;FILES >") + (MAIL-REMINDER NAME) + (SETQ FASL-DIR 'MACSYM) + (SETQ UNFASL-DIR 'MAXOUT) + (MCL-SUB FN1 FN2 DEV DIR + UNFASL-DIR FASL-DIR PRESENT-VERSION + PRESENT-NAME JCLP)))) + (T + (MCL-SUB FN1 FN2 DEV DIR UNFASL-DIR FASL-DIR PRESENT-VERSION + PRESENT-NAME JCLP)))))) + + +(DEFUN MCL-SUB (FN1 FN2 DEV DIR UNFASL-DIR FASL-DIR PRESENT-VERSION PRESENT-NAME + JCLP) + (IF (EQ DIR '*) + ;; So a user could type :MCL SIMP + ;; for example + (SETQ DIR (OR (GET FN1 'DIR) '*))) + (SSTATUS FEATURE MACSYMA-COMPLR) + (COND (TEST-COMPILATION-P + (MAKE-LAP FN1 FN2 DEV DIR DIR DIR JCLP)) + (t + (COND ((COND ((SAMEPNAMEP (INSTALLED-VERSION FN1) + PRESENT-VERSION) + (FORMAT MSGFILES + "~&; ~A has alread been compiled." + (NAMESTRING PRESENT-NAME)) + (Y-OR-N-OR-?-P "Compile anyway." + (NAMESTRING PRESENT-NAME))) + (T T)) + (MAKE-LAP FN1 FN2 DEV DIR UNFASL-DIR FASL-DIR JCLP)))))) + +(DEFUN MAKE-LAP (FN1 FN2 DEV DIR MSDIR FASL-DIR PROCEDE?) ; historical name. + (UNWIND-PROTECT + (PROGN + (MAPC #'EVAL MCL-BEFORE-PROC) + (COND (PROCEDE? + (APPLY #'MAKLAP + ;; awful, have to fake it out to think it was + ;; passed via JCL from the COMPLR top-level init + ;; function! + (EXPLODEN (FORMAT NIL + "DSK:~A;~A FASL_~A:~A;~A ~A" + FASL-DIR FN1 + DEV DIR FN1 FN2)))) + (T + (APPLY #'MAKLAP + ;; of course its an FSUBR which takes OLD-IO filespec + ;; in MIDAS style. + `((,FN1 FASL DSK ,FASL-DIR) + (,FN1 ,FN2 ,DEV ,DIR)))))) + ;; unwind protected + (MAPC #'EVAL MCL-AFTER-PROC))) + +(DEFUN MAIL-REMINDER (FILE) + (FORMAT-MAIL (LIST "GJC MC" (STATUS UNAME)) + "~ + ~%The file ~A was compiled and installed into the macsyma~ + ~%system, but was not a known source file.~ + ~%Please update MAXDOC;FILES and//or give me more information.~ + ~%~ + ~% - yours truly,~ + ~% The Macsyma Compiler.~%" + (NAMESTRING FILE))) + +(DEFUN INSTALLED-VERSION (FN1 &AUX INSTREAM + (NAME `((DSK ,(GET FN1 'UNFASL-DIR)) ,FN1 UNFASL))) + ; duplicates functionality in DOCGEN, although not by much, + ; SET-CODESIZE reads the whole UNFASL file, so we don't want to + ; use that. + (IF (PROBEF NAME) + (UNWIND-PROTECT + (PROGN + (SETQ INSTREAM (OPEN NAME 'IN)) + ; (QUOTE (THIS IS THE UNFASL FOR ((DSK FOO) BAR N))) + (CADDR (CAR (LAST (CADR (READ INSTREAM)))))) + (IF INSTREAM (CLOSE INSTREAM))) + (FORMAT MSGFILES + "~&; Unfasl file ~A not found.~%" + NAME))) + +(sstatus ttyint #^N #'ttynotes-toggle) + +(defun ttynotes-toggle (stream char) + (if (= char (tyipeek () stream -1)) + (tyi stream)) + (FORMAT T "~&; Setting TTYNOTES to ~S~%" + (setq ttynotes (not ttynotes)))) + +(defun present-version (f) + (caddr (probef `((dsk ,(get f 'dir)) ,f >)))) + +(defun todo () (setq todo + (mapcan #'(lambda (f) + (if (get f 'macro-file) nil + (if (samepnamep (present-version f) + (installed-version f)) + nil + (list f)))) + macsyma-file-names))) +(defun todoi () (setq todoi (mapcan #'(lambda (u) (if (get u 'in-core) + (list u))) + todo))) + +(defun doit (f) (mcl-file `((* *) ,f *) nil)) + +(if (probef "dsk:maxtul;files todo") + (load "dsk:maxtul;files todo")) + +(defun findout (&aux s) + (unwind-protect + (let ((msgfiles + (setq s (open "dsk:maxtul;files _todo_" 'out)))) + (todo) + (todoi) + (print `(setq when ,(time:print-current-date nil)) s) + (print `(setq todo ',todo) s) + (print `(setq todoi ',todoi) s) + (renamef s "dsk:maxtul;files todo")) + (if s (close s)))) \ No newline at end of file diff --git a/src/maxtul/mcldmp.(init) b/src/maxtul/mcldmp.(init) new file mode 100755 index 00000000..9c92b4cf --- /dev/null +++ b/src/maxtul/mcldmp.(init) @@ -0,0 +1,146 @@ +;;;-*-LISP-*- +;;; COMPLR init file which sets things up to dump TS MCL. + +(defun load-em (dir files) + (mapc #'(lambda (u) + (print u msgfiles) + (or (get u 'version) + (load `((,dir),u)))) + files)) + +(defun ob-hack (obarray symbol) (readlist (explode symbol))) + +(defvar jnames-which-act-like-cl '(cl umcl)) + +(defmacro docn (&rest forms) + `(progn ,@(mapcar #'(lambda (form) + `(progn (print ',form msgfiles) + (princ "=> " msgfiles) + (prin1 ,form msgfiles) + (princ " " msgfiles))) + forms))) + +(defun mcl-verno () + (TERPRI) + (PRINC "Macsyma source compiler ") + (PRINC (GET 'Mcompiler 'VERSION)) + (COMPLRVERNO)) + +(defun dump-mcl (verno &optional + tty-p + (*pure-setting t) + &AUX DSKMSG (BASE 10.) DUMPFILE MES-FILE TF + msgfiles) + (if tty-p (push tyo msgfiles)) + (let ((*pure *pure-setting)) + (setq TF "dsk:maxtul;mcl _undu_" + DUMPFILE (format nil "dsk:maxtul;mcldmp ~D" verno) + mes-file (format nil "dsk:maxtul;mcldms ~D" verno) + dskmsg (open TF 'out)) + (push dskmsg msgfiles) + (putprop 'mcompiler verno 'version) + (docn *pure + *sharing-file-list* + dumpfile + mes-file + (setq error-break-environment (cons obarray readtable)) + (setq *nopoint nil) + (*rset t) + (get 'complr 'version) + (get 'mcompiler 'version) + (get 'sharable 'version) + (status lispverno) + (status date) + (status dow) + (status daytime) + (status uname) + (status userid) + (status jname) + (status subsys)) + + (load-em 'maxtul '(timepn)) + + (timeprogn + (time-origin) + ;; workhorse section of code timed for the heck of it. + + (or (status feature defstruct) ;; good ole ALAN has to be different. + (load-em 'liblsp '(struct))) + (load-em 'lisp '(format setf umlmac evonce)) + (load-em 'liblsp '(debug IOTA smurf time)) + (load-em 'MAXTUL '(MCL EXPAND)) + (load-em 'libmax ;; should use MAXDOC FILES data. + '(module LMMAC MAXMAC MFORMA DEFINE MOPERS ERMSGC + TRANSM PROCS NUMERM)) + (load-em 'maxdoc '(dcl mcldat)) + (time-origin) + (OR (MEMBER '(SETQ MESSAGES-INITIALIZED NIL) MCL-AFTER-PROC) + (PUSH '(SETQ MESSAGES-INITIALIZED NIL) MCL-AFTER-PROC)) + (let ((^d t)) (gc)) + (docn (setq errset #'errset-break) + (status memfree) + (status features)) + (mapatoms #'(lambda (sym) + (cond ((get sym 'version) + (format msgfiles "~%~A ~A" + sym (get sym 'version)))))) + ;; end of workhorse section. + ) + + (progn ;; clean up message files. + (setq msgfiles (delete dskmsg msgfiles)) + (renamef dskmsg mes-file) + (if (probef tf)(deletef tf))) + + + (FORMAT-MAIL `(,(STATUS UNAME) GJC) + "~ + ~&Dump of ~A in the following *sharing-file-list* :~ + ~%~S~ + ~%~ + ~% -yours truly~ + ~% NJADP (not just another dumb program)~ + ~%" + (namestring dumpfile) + *sharing-file-list*) + (putprop 'mcompiler + (time:print-current-date ()) + 'date) + (putprop 'mcompiler + (status uname) + 'uname) + + (pure-suspend 'p dumpfile) + + ;; next form gets evaluated when lisp is resurected. + (sstatus toplevel + ;; smart lisp calls eval on this form when we + ;; get out of the scope of this function call + ;; to (DUMP-MCL). + '(progn + (sstatus toplevel nil) + (sstatus gctime 0) + (time-origin 'set nil) + (announce-&-load-init-file + 'mcompiler + nil + (format nil "DSK:MAXTUL;MCLFIX ~D" + (get 'mcompiler 'version))) + + + (cond ((memq (status subsys) + jnames-which-act-like-cl) + (SETQ TEST-COMPILATION-P T) + (#.(ob-hack sobarray 'complr-tople-after-suspend))) + (t + ;; error during INIT goes to + ;; standard READ-EVAL-PRINT. + ;; like wow man. here we are, ready to + ;; forge ahead into the unknown macroworld. + (sstatus toplevel '(*maklap-driver* nil)) + (*maklap-driver* (status jcl)))))) + ;; this is the end man. don't put any more shit after this. + )) + +(princ " +Do ^G then (DUMP-MCL /"version/") to dump a new MCL" tyo) diff --git a/src/maxtul/mcldmp.midas b/src/maxtul/mcldmp.midas new file mode 100755 index 00000000..853d9579 --- /dev/null +++ b/src/maxtul/mcldmp.midas @@ -0,0 +1,19 @@ +title MCL - Macsyma Compiler bootstrap-loader + +;; It is IMPORTANT that the indentation of the valret string contain no TABs! +;; --kmp + +mcl: .value [ asciz \:TERPRI + :Macsyma Source Compiler + :TERPRI + L MAXTUL;.GOOD. COMPLR + : Save old XUNAME in location 60  + .XUNAME/ + 60/ 1Q + .XUNAME/ 1'MAXTUL + .HSNAME/ 1'MAXTUL + 0G :VP \ ] +killme: .logout 1, ; This should never be reached, but just in case + jrst killme ; Try until it's good and dead + +end mcl diff --git a/src/maxtul/query.6 b/src/maxtul/query.6 new file mode 100755 index 00000000..bc3abe69 --- /dev/null +++ b/src/maxtul/query.6 @@ -0,0 +1,103 @@ +;;;-*-LISP-*- + +;;; user-query interfaces. + +(HERALD USER-QUERY) + +(EVAL-WHEN (EVAL COMPILE) + (OR (GET 'DO-WITH-TTY-ON 'MACRO)(LOAD '|LIBLSP;TTY FASL|))) + + +(DEFVAR TTY-RETURN-STACK NIL) + +(DEFUN READ-HASH-SEQ () + (DO ((K 0 (+ CHAR (* K 256))) + (CHAR (TYI TYI)(TYI TYI))) + ((= CHAR #\CR) K))) + +(DEFUN READ-PASS-WORD () + (DO-WITH-TTY-OFF + (DO ((K1)(K2)) + (()) + (*CATCH 'RE-READ-PASS-WORD + (LET ((TTY-RETURN-STACK + (CONS '(PROGN (TERPRI TYO) + (PRINC "Interrupted, try again." TYO) + (*THROW 'RE-READ-PASS-WORD NIL)) + TTY-RETURN-STACK))) + (CLEAR-INPUT TYI) + (TERPRI TYO) + (PRINC '|Input password->| TYO) + (SETQ K1 (READ-HASH-SEQ)) + (PRINC '|again->| TYO) + (SETQ K2 (READ-HASH-SEQ)) + (AND (= K1 K2) (RETURN K1)) + (PRINC '|passwords didn't match, try again.| TYO)))))) + + +(DEFUN READ-FILE-NAME (&OPTIONAL (PROBE-TEST NIL)) + (DO ((N)) + (()) + (SETQ N (READ-UNTIL-CR '|File name->|)) + (COND ((EQ N '||)) + (T + (SETQ N (ERRSET (NAMELIST N) T)) + (AND N (COND ((OR (NOT PROBE-TEST) (PROBEF (CAR N))) + (RETURN (CAR N))) + (T + (PRINC (NAMESTRING (CAR N)) TYO) + (PRINC '| is not an existing file.| TYO)))))))) + +(DEFVAR PROMPT) +(DEFVAR INPUT-CHAR-STACK NIL) + +(DEFUN RE-DISPLAY () + (PROGN (PRINC PROMPT TYO) + (MAPC #'(LAMBDA (X) (TYO X TYO)) + (REVERSE INPUT-CHAR-STACK)))) + +(DEFUN READ-UNTIL-CR (PROMPT &AUX TTY-RETURN-STACK INPUT-CHAR-STACK) + (PUSH '(PROGN (CURSORPOS 'A TYO) + (RE-DISPLAY)) + TTY-RETURN-STACK) + (cursorpos 'a tyo) + (PRINC PROMPT TYO) + (DO ((C (TYI TYI)(TYI TYI))) + ((= C #\CR) + (IMPLODE (NREVERSE INPUT-CHAR-STACK))) + (COND ((= C #\RUBOUT) + (COND (INPUT-CHAR-STACK + (RUBOUT (POP INPUT-CHAR-STACK) TYO)))) + ((= C #\FF) + (RE-DISPLAY)) + (T (PUSH C INPUT-CHAR-STACK))))) + +(DEFUN TTY-RETURN (&REST IGNORED) + (AND TTY-RETURN-STACK (EVAL (CAR TTY-RETURN-STACK)))) + +(SETQ TTY-RETURN 'TTY-RETURN) + +(DEFUN READ-CHARACTER (PROMPT &AUX INPUT-CHAR-STACK TTY-RETURN-STACK) + (PUSH '(PROGN (CURSORPOS 'A TYO) (RE-DISPLAY)) + TTY-RETURN-STACK) + (RE-DISPLAY) + (DO ((C (TYI TYI) (TYI TYI))) + ((NOT (= C #\FF)) C) + (RE-DISPLAY))) + +(DEFUN Y-or-n-or-?-p (MESSAGE &OPTIONAL (EXPLAIN)) + (FORMAT TYO "~&~A " MESSAGE) + (DO ((C)) + (NIL) + (SETQ C (READ-CHARACTER '|(Y or N)?|)) + (CASEQ C + ((#/Y #/y) + (PRINC "es." TYO) + (RETURN T)) + ((#/N #/n) + (PRINC "o." TYO) + (RETURN NIL)) + ((#/? #/h #/H) + (IF EXPLAIN (FORMAT TYO "~&~A~%" EXPLAIN)) + (FORMAT TYO "~&~A " MESSAGE)) + (T NIL)))) \ No newline at end of file diff --git a/src/maxtul/strmrg.70 b/src/maxtul/strmrg.70 new file mode 100755 index 00000000..d53c8cc1 --- /dev/null +++ b/src/maxtul/strmrg.70 @@ -0,0 +1,190 @@ +;-*-LISP-*- + +;This file contains the code to merge a set of string files into one. +;Also needed is ERMSGC, to handle writing of the new file + +(herald STRMRG) + +(declare (*lexpr get-directory get-mfd-indexes)) + +(eval-when (compile eval) + (or (get 'iota 'version) + (load "liblsp;iota")) + (or (get 'lmmac 'version) + (load "libmax;lmmac")) + (or (get 'umlmac 'version) + (load "lisp;umlmac")) + (or (get 'ERMSGX 'VERSION) + (load "LIBMAX;ERMSGX"))) + +(eval-when (load eval) + (or (get 'ERMSGC 'VERSION) + (load "LIBMAX;ERMSGC"))) + +(eval-when (load eval compile) + (or (get 'FILDIR 'VERSION) + (load "Z;FILDIR"))) + +(defvar merge-files-prints T "T ==> Print what files are being merged") + +;;; (MERGE-MESSAGE-FILES ) +;;; merges the input files into a single message file in the output file. +;;; The output file's directory will include an ALIST of string filenames +;;; and index offsets. ALLOCATE-MESSAGE-INDEX should look at this directory +;;; and add in offset to the index it is given. + +(defun merge-message-files (output inputs) + (let ((header-counts 1) + (files) (offset 0) (directory-position 0) + (message-text-word-count 0)) + (declare (fixnum header-counts offset directory-position)) + (dolist (file inputs) ;Collect a list of input SFA's + (push (setq file (open-message-file file)) + files) + (setf (message-file-header-offset file) header-counts) + (setq header-counts + (+ header-counts (message-file-header-count file))) + (setq message-text-word-count + (+ message-text-word-count + (or (cdr (assq 'message-text-word-count + (message-file-alist file))) + 0))) + (close file)) + (setq files (nreverse files)) + (phi ((outfile (make-fixnum-ascii-stream + (mergef '(_STRMG OUTPUT) output)))) + (if merge-files-prints + (format msgfiles + "~&Merging the files:~%~S~&Into file: ~A~%" + (mapcar #'NAMESTRING inputs) + (namestring output))) + (dotimes (() header-counts) + (out outfile #.(car (pnget 'EMPTY 7)))) + (dolist (file files) + (open file) + (filepos file (message-file-header-count file)) + (setf (message-file-text-offset file) offset) + (let ((errset ())) + (errset ;Cretinous IN + (do () (()) + (out outfile (in file)) + (setq offset (1+ offset))) + () )) + (close file)) + (setq directory-position (filepos outfile)) + (filepos outfile 0) + (out outfile directory-position) + (dolist (file files) + (open file) + (filepos file 0) + (dotimes (() (message-file-header-count file)) + (out outfile (+ (in file) (message-file-text-offset file) + (- header-counts + (message-file-header-count file))))) + (close file)) + (filepos outfile directory-position) + (print + `(MDOC (files . + ,(mapcar #'(lambda (file) + `(,(truename file) . + ,(message-file-header-offset file))) + files)) + (message-count . ,(1- header-counts)) + (creator . ,(status uname)) + (date . ,(status date)) + (time . ,(status daytime))) + outfile) + (renamef outfile (cdr (namelist output)))))) + + +(defprop FASLREADOPEN ((DSK RLB) FASLRO FASL) AUTOLOAD) +(defprop LOAD-INFO ((DSK MAXTUL) DOCGEN FASL) AUTOLOAD) + +;;; (GET-STRING-FILE-NAME file) gives the string-file filename for this FASL +;;; file, or NIL if none. + +(declare (special FASLREAD-TYPE)) + +(defun get-string-file-name (file) + (setq file (mergef '((DNRF *) * FASL) file)) + (let ((faslread-object ())) + (unwind-protect + (progn + (setq faslread-object (faslreadopen file '(MIN EVAL))) + (do ((entry (faslread faslread-object) (faslread faslread-object))) + ((eq faslread-type 'EOF)) + (if (and (eq faslread-type 'EVAL) + (eq (car entry) 'STRING-FILE-NAME)) + (return (cadr (cadr entry)))))) ;flush QUOTE + (if faslread-object (faslreadclose faslread-object))))) + +(declare (special MACSYMA-SOURCE-FILES)) + +(eval-when (eval compile) + (or (get 'defile 'version) + (load '((maxtul) defile)))) + +(defun merge-incore-system (&aux temp) + (load-info) + (merge-message-files `((DSK MAXDMP) INCORE >) + (mapcan #'(lambda (mfile) + (setq temp + (get-string-file-name + `((DSK ,(macsyma-source-file-fasl-dir mfile)) + ,(macsyma-source-file-name mfile) FASL))) + (if temp (ncons temp))) + (in-core-files macsyma-source-files)))) + +(setq ibase 10. base 10.) + +(defun FASL-FILE-EXISTS-P (file) + (phi ((message-file (open-message-file file))) + (let* ((truename (truename message-file)) + (fasl (mergef '((DNRF *) * FASL) + (cdr (assq 'output-file-name + (message-file-alist message-file))))) + (src (cdr (or (assq 'source-file-name + (message-file-alist message-file)) + (assq 'filename + (message-file-alist message-file))))) + (home `((DNRF ,(get (cadr truename) 'fasl-dir)) + ,(cadr truename) FASL)) + (src-fasl (mergef '((DNRF *) * FASL) + `(,(car src) ,(cadr src) FASL))) + (creator (cdr (assq 'creator (message-file-alist message-file))))) + (or (and fasl + (probef fasl) + (equal (get-string-file-name fasl) truename)) + (and src + (not (equal home fasl)) + (probef home) + (equal (get-string-file-name home) truename)) + (and (not (equal src-fasl fasl)) + (not (equal home home)) + (probef src-fasl) + (equal (get-string-file-name src-fasl) truename)) + (and creator + (setq creator `((DSK ,creator) ,(cadr truename) FASL)) + (not (equal src-fasl creator)) + (not (equal home creator)) + (not (equal fasl creator)) + (probef creator) + (equal (get-string-file-name creator) truename)))))) + +(defun display-string-files-no-fasls () + (cursorpos 'c) + (format t "~&****** MAXERR; ******") + (mapc #'(lambda (file) + (if (not (fasl-file-exists-p + `((DSK MAXERR) ,(file-block-fn1 file) + ,(file-block-fn2 file)))) + (send file 'display))) + (file-directory-files (get-directory 'maxerr))) + (format T "~&****** MAXER1; ******") + (mapc #'(lambda (file) + (if (not (fasl-file-exists-p + `((DSK MAXER1) ,(file-block-fn1 file) + ,(file-block-fn2 file)))) + (send file 'display))) + (file-directory-files (get-directory 'maxer1))) + () ) diff --git a/src/maxtul/timepn.1 b/src/maxtul/timepn.1 new file mode 100755 index 00000000..bd82094e --- /dev/null +++ b/src/maxtul/timepn.1 @@ -0,0 +1,60 @@ +;;;-*-lisp-*- + +(herald timepn) + +(defun (timeprogn macro) (form) + (displace form + `(unwind-protect + (progn (time-origin 'push) + ,@(cdr form)) + (time-origin 'pop)))) + + +(defvar last-gctime nil) +(defvar last-runtime nil) +(defvar last-realtime nil) + + +(defun time-origin (&optional (updatep nil) + (printp (not (eq updatep 'push)))) + (let ((realtime (time)) + (runtime (runtime)) + (gctime (status gctime))) + (if + printp + (let ((rel-realtime (-$ realtime (car last-realtime))) + (rel-runtime (- runtime (car last-runtime))) + (rel-gctime (- gctime (car last-gctime)))) + (format + msgfiles + "~&;~D.~3,'0D cpu sec. ~D% gc ~D.~D realtime (~D%)~:[ so far~]" + (// rel-runtime 1000000.) + (\ (// rel-runtime 1000.) 1000.) + (quotient (times 100. rel-gctime) + rel-runtime) + (ifix rel-realtime) + (\ (ifix (*$ 10.0 rel-realtime)) 10.) + (ifix (//$ (*$ 1.0e-4 (float rel-runtime)) + rel-realtime)) + updatep))) + + (caseq updatep + (set + (setf (car last-realtime) realtime) + (setf (car last-gctime) gctime) + (setf (car last-runtime) runtime)) + (push + (push realtime last-realtime) + (push gctime last-gctime) + (push runtime last-runtime)) + (pop + (pop last-realtime) + (pop last-gctime) + (pop last-runtime))))) + +(time-origin 'push) + +(sstatus ttyint #^] #'(lambda (stream char) + (if (= char (tyipeek -1 stream)) + (tyi stream)) + (time-origin))) \ No newline at end of file diff --git a/src/maxtul/toolm.1 b/src/maxtul/toolm.1 new file mode 100755 index 00000000..36a756db --- /dev/null +++ b/src/maxtul/toolm.1 @@ -0,0 +1,26 @@ +;;;-*-LISP-*- +;;; A macro for tooling up! + +(herald toolm) + +;;; The formal argument list of a DEFTOOLAGE has arguments which +;;; are atoms, meaning (s-exp . ) or ( . ) +;;; where the is used by the command-argument-reader. + +(defmacro deftoolage (name args &rest body &aux documents) + (do () + ((or (null (cdr body)) + (not (atom (car body))))) + (push (pop body) documents)) + `(progn 'compile + (defun (,name toolage) + ,(mapcar #'(lambda (arg) + (if (atom arg) arg (cdr arg))) + args) + ,@body) + (defprop ,name ,documents toolage-doc) + (defprop ,name ,args toolage-args) + (or (memq ',name toolage) + (setq toolage (nconc toolage '(,name)))))) + + diff --git a/src/rat/ratlap.10 b/src/rat/ratlap.10 new file mode 100755 index 00000000..7115b834 --- /dev/null +++ b/src/rat/ratlap.10 @@ -0,0 +1,431 @@ + +; ** (c) Copyright 1981 Massachusetts Institute of Technology ** + +TITLE RATLAP + +.FASL +.INSRT SYS:.FASL DEFS + +; ALL ROUTINES EXPECT MODULUS TO BE EITHER NIL OR 2 +; OR AN ODD NUMBER +; ALL ROUTINES EXCEPT CMOD EXPECT THEIR ARGUMENTS TO BE +; BETWEEN PLUS AND MINUS HMODULUS INCLUSIVE. +.BEGIN G9001 +.ENTRY CMOD SUBR 0 + SKIPN C,.SPECIAL MODULUS + POPJ P, + EXCH A,C + JSP T,NVSKIP + JRST MDBIGP + + EXCH A,C + MOVE R,TT + JSP T,NVSKIP + JRST BIGMOD + + CAIN R,2 + JRST MOD2 + IDIV TT,R +MODRET: MOVE F,R + LSH F,-1 + MOVM TT,D + CAMLE TT,F + SUB TT,R + JUMPGE D,FIX1 + MOVNS TT + JRST FIX1 + +BIGMOD: CAIN R,2 + JRST MOD2A + PUSH FXP,R + MOVE B,C + CALL 2,.FUNCTION REMAINDER + MOVE TT,(A) + MOVE D,TT + POP FXP,R + JRST MODRET + +MOD2A: HLRZ TT,(TT) + MOVE TT,(TT) +MOD2: ANDI TT,A + JRST FIX1 + +.ENTRY CPLUS SUBR 0 + SKIPN C,.SPECIAL MODULUS + JCALL 2,.FUNCTION *PLUS + EXCH A,C + JSP T,NVSKIP + JRST CPLBIG + + MOVE D,(B) + MOVE R,(C) + EXCH TT,R + CAIN R,2 + JRST MOD2P + ADD D,TT + JRST MODRET + +MOD2P: XOR TT,D + JRST MOD2 + +CPLBIG: EXCH A,C + CALL 2,.FUNCTION *PLUS + JRST MDBIG1 + +.ENTRY CTIMES SUBR 0 + SKIPN C,.SPECIAL MODULUS + JCALL 2,.FUNCTION *TIMES + EXCH A,C + JSP T,NVSKIP + JRST BIGCTM + + MOVE D,(B) + MOVE R,(C) + EXCH TT,R + CAIN R,2 + JRST MOD2T + MUL TT,D + DIV TT,R + JRST MODRET + +MOD2T: AND TT,D + JRST MOD2 + +BIGCTM: EXCH A,C + CALL 2,.FUNCTION *TIMES + JRST MDBIG1 + +.ENTRY CEXPT SUBR 0 + SKIPN C,.SPECIAL MODULUS + JCALL 2,.FUNCTION EXPT + EXCH A,C + JSP T,NVSKIP + JRST BGCEXP + + MOVE R,TT + EXCH A,B + JSP T,NVSKIP + JRST BGCEX2 + + MOVE D,TT + EXCH A,C + MOVE TT,(A) + TDNN TT,[-2 ] + POPJ P, + CAIN R,2 + JRST MOD2 + PUSH FXP,R + MOVE T,TT + MOVE F,D + MOVEI D,A + TRNE F,A + MOVE D,T +EXLOOP: LSH F,-1 + JUMPE F,XRET + MUL T,T + DIV T,(FXP) + MOVE T,TT + TRNN F,A + JRST EXLOOP + MUL D,T + DIV D,(FXP) + MOVE D,R + JRST EXLOOP + +XRET: POP FXP,R + JRST MODRET + +BGCEX2: MOVE B,A +BGCEXP: MOVE A,C + CALL 2,.FUNCTION CBEXPT + JRST MDBIG1 + +.ENTRY CRECIP SUBR 0 + MOVE B,.SPECIAL MODULUS + EXCH A,B + JSP T,NVSKIP + JRST INVBIG + + MOVE D,(B) + EXCH TT,D + SKIPG TT + ADD TT,D + MOVEI T, + MOVEI F,A + PUSH FXP,D +LOOP: CAIN TT,A + JRST INVRET + JUMPE TT,ERR + IDIV D,TT + IMUL D,F + SUB T,D + EXCH T,F + MOVE D,TT + MOVE TT,R + JRST LOOP + +INVRET: MOVE D,F + POP FXP,R + JRST MODRET + +ERR: CALL 0,.FUNCTION TERPRI + MOVEI A,.ATOM INVERSE/ OF/ ZERO/ DIVISOR? + JCALL 1,.FUNCTION MERROR +MDBIGP: MOVE A,C +MDBIG1: MOVE B,.SPECIAL MODULUS + CALL 2,.FUNCTION REMAINDER + PUSH P,A + CALL 1,.FUNCTION ABS + MOVEI B,.ATOM #2 + CALL 2,.FUNCTION *TIMES + MOVE B,.SPECIAL MODULUS + CALL 2,.FUNCTION *GREAT + JUMPE A,POPAJ + + POP P,A + MOVE B,.SPECIAL MODULUS + SKIPL (A) + JCALL 2,.FUNCTION *DIF + JCALL 2,.FUNCTION *PLUS + +INVBIG: EXCH A,B + PUSH P,A + PUSH P,B + SKIPGE (A) + CALL 2,.FUNCTION *PLUS + MOVEM A,-1(P) +INVB2: PUSH P,(P) + PUSH P,-2(P) + PUSH P,[.ATOM #0 ] + PUSH P,[.ATOM #1 ] + JSP T,NPUSH+-3 + MOVEM A,-10(P) + JRST G0035 + +G0034: MOVE A,-5(P) + CALL 1,.FUNCTION ZEROP + JUMPN A,ERR + MOVE B,-5(P) + MOVE A,-6(P) + CALL 2,.FUNCTION *QUO + MOVE B,-5(P) + MOVEM A,-2(P) + CALL 2,.FUNCTION *TIMES + MOVE B,A + MOVE A,-6(P) + CALL 2,.FUNCTION *DIF + MOVE B,-2(P) + MOVEM A,(P) + MOVE A,-3(P) + CALL 2,.FUNCTION *TIMES + MOVE B,A + MOVE A,-4(P) + CALL 2,.FUNCTION *DIF + MOVE AR2A,-5(P) + MOVE AR1,(P) + MOVE C,-3(P) + MOVEM A,-1(P) + MOVEM A,-3(P) + MOVEM C,-4(P) + MOVEM AR1,-5(P) + MOVEM AR2A,-6(P) +G0035: MOVEI B,.ATOM #1 + MOVE A,-5(P) + CALL 2,.FUNCTION EQUAL + JUMPE A,G0034 + MOVE A,-3(P) + CALL 1,.FUNCTION CMOD +G0048: SUB P,[11,,11] + POPJ P, +.END G9001 + +.SXEVAL (AND (NCONC (SETQ PRD19 (QUOTE (#1 #2 #2 #4 #2 #4 #2 #4 #6 #2 + #6 ))) (CDDDR PRD19 )) (QUOTE (THIS WAS THE LAP FOR RAT3D /34 DSK RJ +F ))) +.BEGIN G9002 +.ENTRY CFACTOR SUBR 0 + PUSH P,A + JSP T,SPECBIND + .SPECIAL ANS + .SPECIAL K + PUSH P,[.ATOM #0 ] + PUSH P,[.ATOM #2 ] + SKIPE .SPECIAL $FACTORFLAG + JRST G3216 + MOVEI A,.ATOM #1 + CALL 1,.FUNCTION NCONS + MOVE B,-2(P) + CALL 2,.FUNCTION XCONS + JRST G3219 + +G3216: CALL 1,.FUNCTION FLOATP + JUMPE A,G3220 + MOVEI A,.ATOM FACTOR/ GIVEN/ FLOATING/ ARG + CALL 1,.FUNCTION ERROR + JRST G3215 + +G3220: MOVE B,-2(P) + MOVEI A,.ATOM #0 + CALL 2,.FUNCTION EQUAL + JUMPE A,G3222 + MOVEI A,.ATOM #1 + CALL 1,.FUNCTION NCONS + MOVEI B,.ATOM #0 + CALL 2,.FUNCTION XCONS + JRST G3219 + +G3222: MOVEI B,.ATOM #-1 + MOVE A,-2(P) + CALL 2,.FUNCTION EQUAL + JUMPE A,G3226 + MOVEI A,.ATOM #1 + CALL 1,.FUNCTION NCONS + MOVEI B,.ATOM #-1 + CALL 2,.FUNCTION XCONS + JRST G3219 + +G3226: MOVE A,-2(P) + CALL 1,.FUNCTION MINUSP + JUMPE A,G3230 + MOVE A,-2(P) + CALL 1,.FUNCTION MINUS + CALL 1,.FUNCTION CFACTOR + MOVEI B,.ATOM #1 + CALL 2,.FUNCTION XCONS + MOVEI B,.ATOM #-1 + CALL 2,.FUNCTION XCONS + JRST G3219 + +G3230: MOVEI B,.ATOM #2 + MOVE A,-2(P) + CALL 2,.FUNCTION *LESS + JUMPE A,G3215 + MOVEI A,.ATOM #1 + CALL 1,.FUNCTION NCONS + MOVE B,-2(P) + CALL 2,.FUNCTION XCONS + JRST G3219 + +G3215: MOVE AR2A,.SPECIAL PRD19 + MOVEM AR2A,.SPECIAL K +G3214: MOVE B,(P) + MOVE A,-2(P) + CALL 2,.FUNCTION REMAINDER + MOVE T,(A) + JUMPE T,WON + MOVE B,(P) + CAIN B,.ATOM #5 + JRST G005 +G3245: HLRZ A,@.SPECIAL K + CALL 2,.FUNCTION *PLUS + MOVEM A,(P) + SKIPE B,.SPECIAL $INTFACLIM + CALL 2,.FUNCTION *LESS + JUMPE A,FDONE + MOVE A,(P) + HRRZ B,@.SPECIAL K + MOVEM B,.SPECIAL K + MOVE B,A + CALL 2,.FUNCTION *TIMES + MOVE B,-2(P) + CALL 2,.FUNCTION *GREAT + JUMPE A,G3214 +FDONE: MOVEI B,.ATOM #1 + MOVE A,-2(P) + CALL 2,.FUNCTION *GREAT + JUMPE A,G3255 + MOVE B,.SPECIAL ANS + MOVEI A,.ATOM #1 + CALL 2,.FUNCTION CONS + MOVE B,-2(P) + CALL 2,.FUNCTION XCONS + JRST G3219 + +G3255: MOVE A,.SPECIAL ANS +G3219: SUB P,[3,,3] + JRST UNBIND + +WON: MOVE A,-1(P) + CALL 1,.FUNCTION ADD1 + MOVE B,(P) + MOVEM A,-1(P) + MOVE A,-2(P) + CALL 2,.FUNCTION *QUO + MOVEM A,-2(P) + MOVE B,(P) + CALL 2,.FUNCTION REMAINDER + MOVE T,(A) + JUMPE T,WON +GOTIN: MOVE B,.SPECIAL ANS + MOVEI A,.ATOM #0 + EXCH A,-1(P) + CALL 2,.FUNCTION CONS + MOVE B,(P) + CALL 2,.FUNCTION XCONS + MOVEM A,.SPECIAL ANS + MOVE B,(P) +G005: MOVE A,-2(P) + CAIL B,.ATOM #5 + JSP T,NVSKIP + JRST G3245 + + JRST GFAST + + JRST G3245 + +GFAST: MOVE D,(B) + IDIVI D,36 + IMULI D,36 +GFASL: MOVE R,TT + IDIVI R,7(D) + SKIPN F + JSP B,GOT1 + MOVE R,TT + IDIVI R,13(D) + SKIPN F + JSP B,GOT1 + MOVE R,TT + IDIVI R,15(D) + SKIPN F + JSP B,GOT1 + MOVE R,TT + IDIVI R,21(D) + SKIPN F + JSP B,GOT1 + MOVE R,TT + IDIVI R,23(D) + SKIPN F + JSP B,GOT1 + MOVE R,TT + IDIVI R,27(D) + SKIPN F + JSP B,GOT1 + MOVE R,TT + IDIVI R,35(D) + SKIPN F + JSP B,GOT1 + MOVE R,TT + IDIVI R,37(D) + SKIPN F + JSP B,GOT1 + CAIG R,52(D) + JRST FDONE + ADDI D,36 + JRST GFASL + +GOT1: AOS -1(P) + MOVE TT,R + IDIVI R,@-3(B) + JUMPE F,GOT1 + JSP T,FXCONS + MOVEM A,-2(P) + MOVEI TT,@-3(B) + JSP T,FXCONS + MOVEM A,(P) + JRST GOTIN + +.END G9002 + + +FASEND + \ No newline at end of file diff --git a/src/rwk/lfsdef.39 b/src/rwk/lfsdef.39 new file mode 100644 index 00000000..d5817bdb --- /dev/null +++ b/src/rwk/lfsdef.39 @@ -0,0 +1,37 @@ +; -*-MIDAS-*- + +TITLE LISP ITS Filesystem definitions + +.INSRT SYS:.FASL DEFS + +.FASL + +VERPRT LFSDEF + +define DEFSYM /ARG + + ARG + + IRPW FUG,,[ARG] + + IRPS x,y,[ FUG ] + DEFLSYM X,\ + .ISTOP + TERMIN + TERMIN +TERMIN + + +DEFINE DEFLSYM X,Y + +IF2 [PRINTX |(DEFVAR FS-X #o!Y) +| +] + .SXEVAL (SETQ FS-X # ) + .SXEVAL (COND ((STATUS FEATURE COMPLR) + (SPECIAL FS-X))) +TERMIN + +.INSRT SYSENG;FSDEFS > + +FASEND diff --git a/src/rz/macros.47 b/src/rz/macros.47 new file mode 100644 index 00000000..c81442fa --- /dev/null +++ b/src/rz/macros.47 @@ -0,0 +1,116 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module rzmac macro) + +;;; ***************************************************************** +;;; ***** MACROS ******* ASSORTED MACROS FOR GENERAL REPRESENTATION * +;;; ***************************************************************** + +(defmacro repeat (index limit . body) + `(do ((,index 0 (1+ ,index))) + ((not (< ,index ,limit))) . ,body)) + +(defmacro logor frobs `(boole 7 . ,frobs)) + +(defmacro add-to-set (set frob) + `((lambda (temp) + (or (memq temp ,set) + (setq ,set (cons temp ,set)))) + ,frob)) + +#+ITS +(defmacro compiling () + `(and (boundp 'compiler-state) + (not (eq compiler-state 'toplevel)))) +#-ITS +(defmacro compiling nil t) + +(defun *bind* macro (l) + ((lambda (bindings body) + (nconc (list 'do (mapcar (fn (q) + (cond ((atom q) + (list q)) + ((eq (cadr q) '|<-|) + (list (car q) (caddr q))) + (t q))) + bindings) + nil) + (maplist (fn (x) (cond ((null (cdr x)) + (cons 'return x)) + ((car x)))) + body))) + (cadr l) (cddr l))) + +(defmacro displace2 (form new-car new-cdr) + `(rplaca (rplacd ,form ,new-cdr) ,new-car)) + +;; Returns the negation of VALUE if PREDICATE is true. Otherwise, just +;; returns VALUE. + +(defmacro negate-if (predicate value &aux (temp (gensym))) + `(let ((,temp ,predicate)) + (cond (,temp (neg ,value)) + (t ,value)))) + +(defmacro either (which first second) + `(cond (,which ,first) (,second))) + +;; Setq's the first variable to VALUE if SWITCH is true, and sets the second +;; variable otherwise. + +(defmacro set-either (first-var second-var switch value &aux (temp (gensym))) + `(let ((,temp ,value)) + (cond (,switch (setq ,first-var ,temp)) + (t (setq ,second-var ,temp))))) + +(defmacro \* (&rest l) `(remainder . ,l)) + + +(comment Symbolic Arithmetic Macros) + +(defmacro m+ body `(add* . ,body)) + +(defmacro m* body `(mul* . ,body)) + +(defmacro m1+ (x) `(add* 1 ,x)) + +(defmacro m1- (x) `(add* -1 ,x)) + +(defmacro m// (a1 &optional (a2 nil 2args)) + (cond (2args `(div* ,a1 ,a2)) + (t `(inv* ,a1)))) + +(defmacro m- (a1 &optional (a2 nil 2args)) + (cond (2args `(sub* ,a1 ,a2)) + (t `(mul* -1 ,a1)))) + +(defmacro m^ (b e) `(power* ,b ,e)) + +(defmacro m+l (l) `(addn ,l nil)) + +(defmacro m*l (l) `(muln ,l nil)) + +;With +(defmacro m+t body `(add . ,body)) + +(defmacro m*t body `(mul . ,body)) + +(defmacro m1+t (x) `(add 1 ,x)) + +(defmacro m1-t (x) `(add -1 ,x)) + +(defmacro m//t (a1 &optional (a2 nil 2args)) + (cond (2args `(div ,a1 ,a2)) + (t `(inv ,a1)))) + +(defmacro m-t (a1 &optional (a2 nil 2args)) + (cond (2args `(sub ,a1 ,a2)) + (t `(neg ,a1)))) + +(defmacro m^t (b e) `(power ,b ,e)) + +(defmacro m+lt (l) `(addn ,l ,t)) + +(defmacro m*lt (l) `(muln ,l ,t)) diff --git a/src/z/fildir.34 b/src/z/fildir.34 new file mode 100644 index 00000000..234c3a48 --- /dev/null +++ b/src/z/fildir.34 @@ -0,0 +1,121 @@ +;-*-LISP-*- + +(eval-when (EVAL LOAD COMPILE) + (or (get 'DEFVST 'VERSION) + (load '((LISP) DEFVST))) + (or (get 'LFSDEF 'VERSION) + (load '((RWK) LFSDEF)))) + +(eval-when (eval compile) + (or (get 'IOTA 'VERSION) + (load '((LIBLSP) IOTA))) + (or (get 'UMLMAC 'VERSION) + (LOAD '((LISP) UMLMAC)))) + +(eval-when (eval load) + (or (get 'ERMSGC 'VERSION) + (load '((LIBMAX) ERMSGC)))) + +(defvst FILE-DIRECTORY + MACHINE + NAME + FILES) + +(defvst FILE-BLOCK + FN1 + FN2 + RANDOM + DATE + RDATE) + +(defmacro bp (bp) + (and (symbolp bp) (boundp bp) (setq bp (symeval bp))) + (if (fixnump bp) + (lsh bp -24.) + `(lsh ,bp -24.))) + +(defmacro temp-array (idx) + `(arraycall fixnum temp-array ,idx)) + + +(defvar temp-array (*array () 'fixnum 1024.)) + +(defun get-directory (name &optional (machine (STATUS SITE))) + (iota ((dir (mergef '((* *) |.FILE.| |(DIR)|) + `((,machine ,name) * *)) + '(IN FIXNUM))) + (let ((ldir)) + (dotimes (i 1024.) + (setf (temp-array i) (in dir))) + (setq ldir (cons-a-file-directory + NAME (sixbit-to-ascii (temp-array FS-UDNAME)) + MACHINE machine)) + (do ((i (temp-array FS-UDNAMP) (+ i FS-LUNBLK)) + (files)) + ((> i 1023.) (setf (file-directory-files ldir) + (nreverse files))) + (IF (zerop (logand (lsh (temp-array (+ i FS-UNRNDM)) -18.) + (lsh FS-UNIGFL -18.))) + (push (CONS-A-FILE-BLOCK + FN1 (sixbit-to-ascii (temp-array (+ i fs-unfn1))) + FN2 (sixbit-to-ascii (temp-array (+ i fs-unfn2))) + RANDOM (temp-array (+ i fs-unrndm)) + DATE (temp-array (+ i fs-undate)) + RDATE (temp-array (+ i fs-unref))) + files))) + ldir))) + + +(defun date-to-ascii (date) + (format () "~D//~D//~D" + (ldb #o2704 date) + (ldb #o2205 date) + (ldb #o3307 date))) + +(defun date-time-to-ascii (date) + (let* ((hours (// (logand #o777777 date) #.(* 60. 60. 2))) + (temp (\ (logand #o777777 date) #.(* 60. 60. 2))) + (minutes (// temp #.(* 60. 2))) + (temp (\ temp #.(* 60. 2))) + (seconds (// temp 2.))) + (format () + "~A ~2D:~2,48D:~2,48D" + (date-to-ascii date) + hours minutes seconds))) + +(defvar MFD-INDEX-ALIST () "ALIST of (mfd-index . dir-name)") + +(defun get-mfd-indexes (&optional (machine (status site))) + (iota ((mfd `((,machine foo) |M.F.D.| |(FILE)|) '(IN FIXNUM))) + (dotimes (i 1024.) + (setf (temp-array i) (in mfd))) + (do ((i (temp-array fs-mdnamp) (+ i fs-lmnblk))) + ((> i 1023.)) + (declare (fixnum i)) + (if (not (zerop (temp-array i))) + (progn + (putprop (sixbit-to-ascii (temp-array i)) + (// (- i 24.) 2) + 'MFD-INDEX) + (push `(,(// (- i 24.) 2) . ,(sixbit-to-ascii (temp-array i))) + MFD-INDEX-ALIST)))))) + + +(defmethod* (display file-block-class) (self) + "Display a file" + (format T "~&~6A ~6A ~A (~A) (~A)" + (file-block-fn1 self) + (file-block-fn2 self) + (date-time-to-ascii (file-block-date self)) + (date-to-ascii (logand (lsh -1 18.) (file-block-rdate self))) + (get-name-from-mfd-index (ldb (bp fs-unauth) (file-block-rdate self))))) + +(defun get-name-from-mfd-index (idx) + (if (= idx #o777) '|???| + (cond ((cdr (assoc idx mfd-index-alist))) + (t '|???|)))) + +(defun display-files (files) + (cursorpos 'c) + (mapc #'(lambda (file) (send file 'display)) files) + ()) diff --git a/tools/sims b/tools/sims index c9d38331..60ba615f 160000 --- a/tools/sims +++ b/tools/sims @@ -1 +1 @@ -Subproject commit c9d383316470e8d66ed3949ca7507d349bc094b2 +Subproject commit 60ba615f9423dfe0e463a647b8f3dd6193f9c8ca