github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-04-26 12:17:41 +00:00
Code Issues Releases Wiki Activity

Adds LIBMAX AND MAXTUL FASL files. These are prerequisites for

Browse Source 
building and running Macsyma.  Resolves #710 and #711.
This commit is contained in:
Eric Swenson
2018-03-07 14:37:42 -08:00
committed by Lars Brinkhoff
parent aefb232db9
commit 19dfa40b9e
53 changed files with 9962 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

523
src/libmax/define.65 Normal file
View File

@@ -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 <name> &OPTIONAL <initial-value> <documentation> &REST <flags>)
;; 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 <name> [FEXPR] <arglist> . 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 <module>)) 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.

82
src/libmax/defopt.8 Normal file
View File

@@ -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 <name> <arlist> <body-boo>)
;; PDP-10 Maclisp:
;; SOURCE-TRANS property is a list of functions (F[1] F[2] ... F[n]).
;; F[k] is funcalled on the <FORM>, it returns (VALUES <NEW-FORM> <FLAG>).
;; If <FLAG> = NIL then compiler procedes to F[k+1]
;; If <FLAG> = 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 <NEW-FORM>. Stop condition is (EQ <FORM> <NEW-FORM>).
;; 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))

148
src/libmax/displm.13 Executable file
View File

@@ -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 [<operator>] [<dissym> | <l-dissym> <r-dissym>] [<lbp>] [<rbp>])
;; 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 <RETURN> 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))

152
src/libmax/displm.14 Normal file
View File

@@ -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 [<operator>] [<dissym> | <l-dissym> <r-dissym>] [<lbp>] [<rbp>])
;; 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 <RETURN> 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))

435
src/libmax/ermsgc.210 Normal file
View File

@@ -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)))))

46
src/libmax/ermsgx.5 Normal file
View File

@@ -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))

86
src/libmax/gprelu.22 Executable file
View File

@@ -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)))

284
src/libmax/lmmac.87 Normal file
View File

@@ -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.

324
src/libmax/lmrun.43 Executable file
View File

@@ -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)

33
src/libmax/lmrund.1 Executable file
View File

@@ -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))

603
src/libmax/maxmac.227 Normal file
View File

@@ -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 . <FORMS>)
(DEFMACRO COMPILE-FORMS (&REST <FORMS>) `(PROGN 'COMPILE . ,<FORMS>))
;; 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 <name> &OPTIONAL <initial-value> <documentation> . <flags>) 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))

150
src/libmax/mdefun.57 Executable file
View File

@@ -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 <mode> <property> <&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 <mode> <property> <&restp>) <ARGL> . 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)))))))))))))

749
src/libmax/meta.89 Executable file
View File

@@ -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 <FORM> &OPTIONAL <INTERESTING-VARS> <VAR-SUBST-LIST>)
;;; 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 <TAG> <PRED>)
(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 (<FORML>) ...)
(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))))))

393
src/libmax/mforma.104 Normal file
View File

@@ -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.

138
src/libmax/module.9 Normal file
View File

@@ -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")

132
src/libmax/module.option Normal file
View File

@@ -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)

119
src/libmax/mopers.48 Normal file
View File

@@ -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))

119
src/libmax/mopers.49 Executable file
View File

@@ -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))

357
src/libmax/mrgmac.21 Normal file
View File

@@ -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))))
;; <A B C> --> (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:

356
src/libmax/mrgmac.22 Normal file
View File

@@ -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))))
;; <A B C> --> (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:

89
src/libmax/numerm.21 Normal file
View File

@@ -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)
))

102
src/libmax/nummac.19 Normal file
View File

@@ -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))

111
src/libmax/opshin.3 Normal file
View File

@@ -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.
;;; <Option-header> ::= <name> | (<name> . <option-list>)
;;; <option-list> ::= (<option-slot> . <option-list>) | ()
;;; <option-slot> ::= <name> | (<name>) | (<name> <value>)
(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))

89
src/libmax/procs.16 Normal file
View File

@@ -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))

26
src/libmax/readm.3 Executable file
View File

@@ -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."))

112
src/libmax/strmac.4 Normal file
View File

@@ -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 <varlist> <genvars>) <numer> . <denom>)
;; Schematic of <numer> and <denom>:
;; (<genvar> <exponent 1> <coefficient 1> ...)
;; 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))

43
src/libmax/tprelu.47 Executable file
View File

@@ -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)

546
src/libmax/transm.129 Normal file
View File

@@ -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))))

360
src/libmax/transq.87 Normal file
View File

@@ -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 <eval vars list> <late eval vars list> . <EXP>)
;;; will define a function globally with a unique name
;;; (defun <name> <list of variables> <exp>). And return
;;; `((<name>) ,@<eval>> . <late eval>). The resulting expression may
;;; then be passed to a function which will bind variables from
;;; the <late eval vars list> and possibly other variables free in
;;; <exp> and then call MEVAL on the expression.
;;; FUNGEN&ENV-FOR-MEVALSUMARG will also make sure that the <name>
;;; 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))))