github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-02-26 17:03:20 +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

2
Makefile
View File

@@ -7,7 +7,7 @@ SRC = system syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \
midas _teco_ emacs emacs1 rms klh syshst sra mrc ksc eak gren \
bawden _mail_ l lisp libdoc comlap lspsrc nilcom rwk chprog rg \
inquir acount gz sys decsys ecc alan sail kcc kcc_sy c games archy dcp \
spcwar rwg
spcwar rwg libmax rat z emaxim rz maxtul
DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc chprog
BIN = sys2 emacs _teco_ lisp liblsp alan inquir sail comlap c decsys moon

130
build/build.tcl
View File

@@ -1464,6 +1464,136 @@ respond "_" "liblsp;fasdmp fasl_rlb%;fasdmp\r"
respond "_" "\032"
type ":kill\r"
# libmax
# all libmax components (well almost all) require libmax;module fasl
# at compile time. Build it first.
respond "*" "complr\013"
respond "_" "libmax;module\r"
respond "_" "\032"
type ":kill\r"
# libmax;maxmac can't be compiled unless libmax;mforma is (first) compiled.
# However, libmax;mforma uses libmax;macmac. Hence you end up having to
# compile libmax;mforma first, then libmax;maxmac, and then compiling these
# both a second time. Otherwise, there are not incorrectly generated FASL
# files for each, but anything that depends on these two packages will also
# have errors during compilation.
respond "*" "complr\013"
respond "_" "\007"
respond "*" "(load '((libmax) module))"
respond "274534" "(maklap)"
respond "_" "libmax;mforma\r"
respond "_" "\032"
type ":kill\r"
respond "*" "complr\013"
respond "_" "\007"
respond "*" "(load '((libmax) module))"
respond "274534" "(maklap)"
respond "_" "libmax;maxmac\r"
respond "_" "\032"
type ":kill\r"
respond "*" "complr\013"
respond "_" "\007"
respond "*" "(load '((libmax) module))"
respond "274534" "(maklap)"
respond "_" "libmax;mforma\r"
respond "_" "\032"
type ":kill\r"
respond "*" "complr\013"
respond "_" "\007"
respond "*" "(load '((libmax) module))"
respond "274534" "(maklap)"
respond "_" "libmax;maxmac\r"
respond "_" "\032"
type ":kill\r"
# the following are required to compile some of the libmax;
# FASL files
#
respond "*" ":midas rwk;lfsdef fasl_rwk;lfsdef\r"
expect ":KILL"
respond "*" ":midas rat;ratlap fasl_rat;ratlap\r"
expect ":KILL"
respond "*" ":print maxdmp;..new. (udir)\r"
type ":vk\r"
respond "*" ":link maxdmp;ratlap fasl,rat;ratlap fasl\r"
respond "*" ":link libmax;lusets fasl,liblsp;\r"
respond "*" "complr\013"
respond "_" "\007"
respond "*" "(load '((libmax) module))"
respond "274534" "(maklap)"
respond "_" "libmax;ermsgx\r"
respond "_" "libmax;ermsgc\r"
respond "_" "z;fildir\r"
respond "_" "libmax;lmmac\r"
respond "_" "libmax;meta\r"
respond "_" "libmax;lmrund\r"
respond "_" "libmax;lmrun\r"
respond "_" "libmax;displm\r"
respond "_" "libmax;defopt\r"
respond "_" "libmax;mopers\r"
respond "_" "libmax;mrgmac\r"
respond "_" "libmax;nummac\r"
respond "_" "libmax;opshin\r"
respond "_" "libmax;edmac_emaxim;\r"
respond "_" "libmax;procs\r"
respond "_" "libmax;readm\r"
respond "_" "libmax;strmac\r"
respond "_" "libmax;transm\r"
respond "_" "libmax;rzmac_rz;macros\r"
respond "_" "libmax;transq\r"
respond "_" "libmax;mdefun\r"
respond "_" "\032"
type ":kill\r"
# build MAXTUL FASL files
respond "*" ":print maxerr;..new. (udir)\r"
type ":vk\r"
respond "*" ":print maxer1;..new. (udir)\r"
type ":vk\r"
respond "*" "complr\013"
respond "_" "maxtul;strmrg\r"
respond "_" "maxtul;defile\r"
respond "_" "maxtul;docgen\r"
respond "_" "maxtul;query\r"
respond "_" "maxtul;maxtul\r"
respond "_" "maxtul;toolm\r"
respond "_" "maxtul;dclmak\r"
respond "_" "maxtul;mailer\r"
respond "_" "maxtul;mcl\r"
respond "_" "maxtul;timepn\r"
respond "_" "maxtul;expand\r"
respond "_" "maxtul;fsubr!\r"
respond "_" "maxtul;error!\r"
respond "_" "\032"
type ":kill\r"
respond "*" "complr\013"
respond "_" "maxtul;fasmap\r"
respond "_" "\032"
type ":kill\r"
# define needs (for some reason) to be compiled separately.
# not doing this results in errors compiling macsyma sources,
# such as ELL; HYP >
#
respond "*" "complr\013"
respond "_" "\007"
respond "*" "(load '((libmax) module))"
respond "274534" "(maklap)"
respond "_" "libmax;define\r"
respond "_" "\032"
type ":kill\r"
bootable_tapes
# make output.tape

289
src/emaxim/edmac.106 Executable file
View File

@@ -0,0 +1,289 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module edmac macro)
#-lispm
(progn 'compile
(load-macsyma-macros lmrund)
(load-macsyma-macros-at-runtime 'lmrund)
)
;; Macsyma display-oriented expression editor
;; Macros and structure definitions
;; See EMAXIM;ED > and EMAXIM;EDCOM > for more information.
;; Written: Feb 17, 1979 By RZ, based on a version by CWH and BEE
;; Rewritten: June 2, 1979 by CWH for Macsyma Users' Conference
;; Alt: July 1, 1981 by GJC, annointing for NIL.
;; Data Structures
;; The smallest fundamental data unit is the expression -- this consists of a
;; macsyma expression, formatting information, a displayed region, and a
;; command region. Buffers consist of a collection of expressions and may
;; share expressions among one another. A subset of the expressions within a
;; buffer will be displayed in a window. Only complete sub expressions are
;; displayed, although REVEAL may be used to hide inner structure.
(defstruct (expression)
body ;Body of the expression. A complete
;subnode of this expression is always
;displayed.
displayed ;The displayed portion of the expression.
;Always a complete subnode.
region ;That portion of the expression which
;subsequent commands will affect. May
;be several branches of a subnode.
(save-pdl nil) ;Current way of keeping track of where
;we are.
(region-length 1) ;Region length -- number of branches included
;in region. Normally 1 unless extended with
;extend-forward.
(operator nil) ;Operator of region node, i.e. this level
(operand nil) ;Entire node, i.e. the level itself
;The are both nil when the region is the same
;as the body.
expression-label ;Need some way of referring to expressions
;within a buffer. This label is a symbol
;and is bound to the body of the expression.
expression-height ;The height in characters of the expression.
;Used by the redisplay.
(reveal-depth 0) ;If depth = 0, then reveal all of expression.
;See Macsyma $REVEAL function.
(region-boxed? nil) ;Right now, this means that the expression
;is current.
)
(defstruct (buffer)
buffer-name ;Name of the buffer. Used for moving between
;them.
(expression-list nil) ;All of the expressions contained within
;the buffer. Currently, all are displayed.
(current-exp nil) ;The current expression in this buffer.
(current-exp-distance-from-top 0) ;If this field is 0, then the
;current expression is the top expression on
;the screen.
(buffer-mode '|Expression|) ;Do we want this?
)
;; Command definition macro
;; Defines an editor command (and a lisp function) with the specified name.
;; The possible options are:
;;
;; (argument n) Makes "n" an entry in the bvl of the function.
;; Means that this function gets passed its argument
;; which it uses as it pleases.
;;
;; (discard-argument) This function doesn't use its argument and
;; and doesn't want to be iterated. If neither
;; of the above two argument options are specified,
;; then the character dispatcher will iterate the
;; command if an argument is given.
;;
;; (character c) Makes "c" an entry in the bvl of the function. Means
;; that this function gets passed the character which
;; invoked it.
;;
;; (read-key key "Key: ") This function wants a character to be typed
;; for purposes of description, assignment, etc.
;; Control and Meta prefixes are taken care of
;; by READ-KEY.
;;
;; (read-line file-name "File Name: ") This function wants a string
;; argument to be typed in the
;; minibuffer, terminated by a
;; carriage return. "file-name"
;; will be in the bvl of the function.
;;
;; (read-expression exp "Expression: ") This function wants a macsyma
;; expression as an argument.
;; Expression returned in the
;; macsyma internal format.
;;
;; Note that the CDDR of the forms starting with READ-LINE and READ-EXPRESSION
;; can be any arbitrary format string. Note also that the order in which these
;; forms appear in the bvl is critical. They must appear in the same order
;; as presented above.
;; (defcom foo ((argument n) (character c) (read-line line "Type a ~A:" frobboz))
;; "Random documentation"
;; (random-code)) -->
;;
;; (progn 'compile
;; (putprop 'foo 'ed-documentation "Random documentation")
;; (putprop 'foo 'ed-arg-action 'pass)
;; (putprop 'foo 'ed-char-action 'pass)
;; (defun foo (n c &optional (line (read-line "Type a ~A:" frobboz)))
;; (random-code)))
(defmacro defcom (name option-list documentation &rest body)
(let ((arg-list nil)
(arg-action 'iterate)
(char-action 'discard))
(mapcar
#'(lambda (option)
(caseq (car option)
(argument (push (cadr option) arg-list)
(setq arg-action 'pass))
(discard-argument (setq arg-action 'discard))
(character (push (cadr option) arg-list)
(setq char-action 'pass))
(read-key
(or (memq '&optional arg-list)
(push '&optional arg-list))
(push `(,(cadr option) (progn (minibuffer-clear)
(read-key nil t . ,(cddr option))))
arg-list))
((read-line read-expression)
(or (memq '&optional arg-list)
(push '&optional arg-list))
(push `(,(cadr option) (,(car option) . ,(cddr option)))
arg-list))
(t (error "Unknown defcom option" (car option)))))
option-list)
(setq arg-list (nreverse arg-list))
`(progn 'compile
(putprop ',name ,documentation 'ed-documentation)
(putprop ',name ',arg-action 'ed-arg-action)
(putprop ',name ',char-action 'ed-char-action)
#+maclisp
,@(if (memq '&optional arg-list) `((declare (*lexpr ,name))))
(defun ,name ,arg-list . ,body))))
;; Compatibility macros and other random stuff
(defmacro string-capitalize (string)
`(string-append (string-upcase (substring ,string 0 1))
(string-downcase (substring ,string 1))))
;; Useful predicates for examining the state of an expression.
;; Please use these if possible so as to avoid dependence upon our
;; current form of expression representation.
; (eq (body current-exp) (region current-exp)) is also a test for this.
(defmacro region-contains-top-node? ()
'(null (save-pdl current-exp)))
(defmacro region-contains-terminal-node? ()
'(atom (cadr (region current-exp))))
; (eq (caar (save-pdl current-exp)) 'CDR) is also a test for this.
(defmacro region-contains-first-branch? ()
'(eq (region current-exp) (operand current-exp)))
(defmacro region-contains-last-branch? ()
'(null (nthcdr (1+ (region-length current-exp))
(region current-exp))))
(defmacro region-contains-entire-level? ()
'(= (region-length current-exp)
(length (cdr (operand current-exp)))))
;; Declarations:
(if (fboundp 'special)
(special buffer-list ;All of the buffers being used.
;Maintained between invocations
current-buffer ;Contains the current expression.
current-exp ;Expression currently being edited.
screen-exp-list ;Redisplay state information
screen-buffer-name ;Should be made intelligent about
screen-exp-list-length ;windows.
previous-buffer ;Previously selected buffer
single-char-table ;Dispatch table for single character commands
c-x-prefix-table ;Dispatch table for control-x prefix commands
single-char-table-size ;Size of array
c-x-prefix-table-size ;Size of array
buffer-name-count ;For generating buffer names
kill-pdl ;pdl of deleted expressions
mark-pdl ;pdl of marks
need-full-redisplay ;When screen has been completely destroyed
;Rename to full-redisplay?
supress-redisplay ;Deliberately supress redisplay until after
;next command typed.
char-to-descriptor-alist ;For converting between
descriptor-to-char-alist ;characters and their
;description.
idel-chars-available? ;Terminal control information
idel-lines-available?
overstrike-available?
12-bit-kbd-available?
12-bit-input ;Fixnum input stream for
;Knight keyboards.
%kbd-control ;Bit specifiers for the appropriate
%kbd-meta ;fields in the Lisp Machine character
%kbd-control-meta ;representation.
*multiple-keystroke-char-typed* ;READ-KEY has to return
;two values, but can't in Maclisp. Use this
;global instead. Indicates that a control
;or meta prefix was typed as a part of the
;most recently typed character.
expr-area-height ;Screen parameters.
minibuffer-height ;Single window only.
mode-line-vpos
minibuffer-vpos
))
(if (fboundp 'fixnum)
(fixnum screen-region-length buffer-name-count
single-char-table-size c-x-prefix-table-size
expr-area-height minibuffer-height
mode-line-vpos minibuffer-vpos
%kbd-control %kbd-meta %kbd-control-meta
))
;; Macsyma special variables
(if (fboundp 'special)
(special $outchar $boxchar ttyheight linel $linenum))
(if (fboundp 'fixnum)
(fixnum ttyheight linel $linenum))
;; Special variables in MRG;DISPLA
(load-macsyma-macros-at-runtime 'displm)
;; Inter-module functions -- generally I/O stuff.
(if (fboundp '*expr)
(*expr ed-prologue ed-epilogue enable-echoing disable-echoing
display-expression display-expressions display-mode-line
dctl-clear-lines dctl-scroll-region-up dctl-scroll-region-down
minibuffer-clear expr-area-clear read-char tv-beep
label-exp box-region unbox-region
region-as-mexp delete-expression top-level
make-current-exp make-current-buffer full-redisplay))
(if (fboundp '*lexpr)
(*lexpr set-key make-exp
read-key read-line read-expression
minibuffer-print char-to-descriptor
ed-error ed-internal-error
replace-region select-buffer))
(if (fboundp 'notype)
(notype (dctl-clear-lines fixnum fixnum)
(dctl-scroll-region-up fixnum fixnum fixnum)
(dctl-scroll-region-down fixnum fixnum fixnum)))
;; Macsyma system functions.
(if (fboundp '*expr)
(*expr retrieve simplify ssimplifya nformat-all meval makelabel mset
$partfrac))
(sstatus feature emaxim-edmac)

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

95
src/maxtul/dclmak.9 Executable file
View File

@@ -0,0 +1,95 @@
;;;-*-lisp-*-
;;; (DECLARE-FILE-MAKE) takes the include-file-style files
;;; of declarations and makes them into a loadable file
;;; which may be compiled.
;;; George Carrette 4:15pm Thursday, 21 August 1980
(DEFVAR DCL-OUTPUT "DSK:MAXDOC;DCL LOAD")
(DEFVAR DCL-INPUT '("DSK:MAXDOC;DCL FCTNS"
"DSK:MAXDOC;DCL VARS"
"DSK:MAXDOC;DCL FEXPR"
))
#.(PROGN (SETQ FILE-NAME-MAX-LENGTH 6) NIL)
(DEFUN TEMP-FILENAME (NAME)
; returns a temporary file name by convention.
(SETQ NAME (NAMELIST NAME))
`(,(CAR NAME)
,(CADR NAME)
,(IMPLODE (CONS #/_
(NCONC (LET ((L (EXPLODEN (CADDR NAME))))
(COND ((< (LENGTH L)
(1- #.FILE-NAME-MAX-LENGTH))
L)
(T
(NREVERSE
(NTHCDR (- (LENGTH L)
(- #.FILE-NAME-MAX-LENGTH 2))
(NREVERSE L))))))
'(#/_))))))
(DEFUN DCL-FILE-FORM-MUNGER (FORM STREAM)
(COND ((ATOM FORM))
((EQ (CAR FORM) 'DECLARE)
(POP FORM)
(DO ()
((NULL FORM))
(DCL-FILE-FORM-MUNGER (POP FORM) STREAM)))
((EQ (CAR FORM) 'COMMENT))
(T
(CORRECT-PRINT FORM STREAM))))
(DEFVAR DCL-FILE-FORM-MUNGER #'DCL-FILE-FORM-MUNGER)
(DEFUN CORRECT-PRINT (FORM STREAM)
(LET ((PRINLEVEL NIL)
(PRINLENGTH NIL)
(BASE 10.)
(*NOPOINT NIL))
(PRINT FORM STREAM)))
(DEFUN DECLARE-FILE-MAKE ()
(LET ((FO (OPEN (TEMP-FILENAME DCL-OUTPUT) '(OUT DSK ASCII BLOCK)))
(FI NIL)
(EOF (LIST NIL))) ;unique EOF object.
(UNWIND-PROTECT
(DO ((L (PROGN (CORRECT-PRINT
`(DEFPROP DCL
,(TIME:PRINT-CURRENT-TIME NIL)
VERSION)
FO)
DCL-INPUT)
(CDR L)))
((NULL L)
(CLOSE FO)
(AND (PROBEF DCL-OUTPUT)
(DELETEF DCL-OUTPUT))
(RENAMEF FO DCL-OUTPUT))
(SETQ FI (OPEN (CAR L) '(IN DSK ASCII BLOCK)))
(DO ((FORM (READ FI EOF) (READ FI EOF)))
((EQ FORM EOF)
(CLOSE FI))
(FUNCALL DCL-FILE-FORM-MUNGER FORM FO)))
(AND FI (CLOSE FI))
(CLOSE FO))))
(DEFUN MAP-FILES (DCL-FILE-FORM-MUNGER DCL-INPUT DCL-OUTPUT)
(DECLARE-FILE-MAKE))
(DEFUN LISPM-DCL-FILE-FORM-MUNGER (FORM STREAM)
(COND ((ATOM FORM))
((EQ (CAR FORM) 'DECLARE)
(POP FORM)
(DO ()
((NULL FORM))
(DCL-FILE-FORM-MUNGER (POP FORM) STREAM)))
((EQ (CAR FORM) 'COMMENT))
((EQ (CAR FORM) 'SPECIAL)
(CORRECT-PRINT FORM STREAM))))
(DEFUN LISPM-DECLARE-FILE-MAKE ()
(LET ((DCL-OUTPUT "DSK:MAXDOC;DCL LISPM")
(DCL-FILE-FORM-MUNGER #'LISPM-DCL-FILE-FORM-MUNGER))
(DECLARE-FILE-MAKE)))

208
src/maxtul/defile.16 Executable file
View File

@@ -0,0 +1,208 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The macsyma source files. This documentation is used
;;; during compiliation of the macsyma system, during the loading
;;; of the macsyma system, and during runtime by the error message
;;; system. -GJC, 9:00pm Friday, 24 October 1980
(INCLUDEF "LIBMAX;GPRELUDE >")
(HERALD DEFMFILE)
(DEFSTRUCT (MACSYMA-SOURCE-FILE NAMED-HUNK CONC-NAME default-pointer)
;; The following are relevant to all files:
DIR ;; The ITS directory it may be found on.
NAME ;; The ITS first file name.
VERSION ;; The ITS version number of latest version.
MAINTAINERS ;; The primary loosers hacking this file.
UNFASL-HEADER ;; of installed version.
CODESIZE ;; in machine words.
(SYSTEMS-FOR '(ITS MACLISP PDP-10 FRANZ LISPM NIL))
(SYSTEMS-NOT-FOR NIL)
;; The following are relevant for runtime files:
GOEDEL-NUMBER ;; used by the error message system.
GENPREFIX ;; prefix to generated symbols in the file,
;; generated in the compiler, which must be
;; unique at load time.
(IN-CORE NIL) ;; precedence order of loading for IN-CORE PDP10,
;; NIL if not IN-CORE.
(LANGUAGE 'LISP) ;; for TAGS.
TAGS-PRECEDENCE ;; also for TAGS.
;; The following is relevant mainly on MC-ITS for installed files.
(FASL-DIR 'MACSYM) ;; Directory to put the compiled FASL code,
(UNFASL-DIR 'MUNFAS) ;; for the compiler comments,
(ERRMSG-DIR 'MAXERR) ;; for error messages and documentation
;; strings.
(SPLIT NIL) ;; Uses SPLITfile on PDP10.
;; This also implies something about FASL-DIR.
;; The following are relevant for macro packages:
GLOBAL-COMPILE ;; T if for all of runtime macsyma.
SELECTIVE-COMPILE ;; A list of files which reference.
MACRO-COMPILE ;; A list of macro files which use this
;; macro file. If there is circularity
;; refer to the documentation in the files
;; for how to resolve it.
)
(DEFMACRO DEF-DISP-STRUCT (NAME)
(DO ((L (DEFSTRUCT-DESCRIPTION-SLOT-ALIST
(OR (GET NAME 'DEFSTRUCT-DESCRIPTION)
(ERROR "No DEFSTRUCT description." NAME 'FAIL-ACT)))
(CDR L))
(ARGS NIL)
(STRING (EXPLODEN "~&")))
((NULL L)
(SETQ STRING `',(MAKNAM STRING)) ; should be LIST-TO-STRING
(SETQ ARGS (NREVERSE ARGS))
`(DEFUN ,(SYMBOLCONC 'DISP- NAME) (EXP STREAM)
(FORMAT STREAM
,STRING
,@ARGS)))
(PUSH `(,(DEFSTRUCT-SLOT-DESCRIPTION-REF-MACRO-NAME (CDAR L)) EXP)
ARGS)
(SETQ STRING
(NCONC STRING (EXPLODEN (CAAR L)) (EXPLODEN " : ~S~%")))))
(DEF-DISP-STRUCT MACSYMA-SOURCE-FILE)
#-LISPM ; useful lisp machine function.
(PROGN 'COMPILE
(IF (STATUS FEATURE COMPLR)
(*LEXPR DEL))
(DEFUN DEL (PREDICATE ITEM LIST &OPTIONAL (N #.(LSH -1 -1))) ; maximum FIXNUM.
(COND ((ATOM PREDICATE)
(LET ((FUNCTION (GETL PREDICATE '(SUBR LSUBR EXPR))))
(CASEQ (CAR FUNCTION)
(SUBR
(DEL*1 (CADR FUNCTION) ITEM LIST N))
(LSUBR
(DEL*2 (CADR FUNCTION) ITEM LIST N))
(EXPR
(DEL*3 (CADR FUNCTION) ITEM LIST N))
(T
(ERROR "Unbound function as arg to DEL" PREDICATE)))))
('ELSE
(DEL*3 PREDICATE ITEM LIST N))))
(DEFMACRO DEFDEL* (NUMB &REST CALLER &AUX (NAME (SYMBOLCONC 'DEL* NUMB)))
`(DEFUN ,NAME (PREDICATE ITEM LIST N)
(COND ((OR (NULL LIST) (ZEROP N)) LIST)
((,@CALLER PREDICATE ITEM (CAR LIST))
(,NAME PREDICATE ITEM (CDR LIST) (1- N)))
('ELSE
(RPLACD LIST (,NAME PREDICATE ITEM (CDR LIST) N))))))
(DEFDEL* 1 SUBRCALL NIL)
(DEFDEL* 2 LSUBRCALL NIL)
(DEFDEL* 3 FUNCALL)
(IF (STATUS FEATURE COMPLR) (*EXPR ASS))
(DEFUN ASS (PREDICATE ITEM LIST)
(DO ()
((NULL LIST) NIL)
(LET ((A (POP LIST)))
(IF (FUNCALL PREDICATE ITEM A)
(RETURN A)))))
; end of #-LISPM
)
(DEFMACRO DEFMFILE (DIR NAME &REST OPTIONS)
`(SETQ MACSYMA-SOURCE-FILES
(ADD-MACSYMA-SOURCE-FILE
(MAKE-MACSYMA-SOURCE-FILE DIR ',DIR
NAME ',NAME
,@OPTIONS)
MACSYMA-SOURCE-FILES)))
;(DEFMACRO DEFMFILES (DIR &REST CLAUSES))
(DEFVAR MACSYMA-SOURCE-FILES NIL)
(DEFUN ADD-MACSYMA-SOURCE-FILE (SOURCE-STRUCT LIST)
(SETQ SOURCE-STRUCT
(DEFAULTY-MACSYMA-SOURCE-FILE SOURCE-STRUCT))
(CONS SOURCE-STRUCT
(DEL #'(LAMBDA (S-MATCH S)
(COND ((EQ (MACSYMA-SOURCE-FILE-NAME S)
(MACSYMA-SOURCE-FILE-NAME S-MATCH))
(FORMAT MSGFILES
"~&(COMMENT *REDEFINING SOURCE FILE*~%")
(DISP-MACSYMA-SOURCE-FILE S MSGFILES)
(FORMAT MSGFILES "~&; as")
(DISP-MACSYMA-SOURCE-FILE S-MATCH MSGFILES)
(TYO #/) MSGFILES)
T)
(T NIL)))
SOURCE-STRUCT
LIST)))
(DEFVAR MACSYMA-SOURCE-FILES-GOEDEL-INDEX 0)
(DEFUN INIT-MACSYMA-SOURCE-FILES ()
(SETQ MACSYMA-SOURCE-FILES-GOEDEL-INDEX 0
MACSYMA-SOURCE-FILES NIL))
(DEFUN DEFAULTY-MACSYMA-SOURCE-FILE (S)
(LET ((IND MACSYMA-SOURCE-FILES-GOEDEL-INDEX))
(SETQ MACSYMA-SOURCE-FILES-GOEDEL-INDEX (1+ IND))
; would could do all sorts of consistency checking here.
(ALTER-MACSYMA-SOURCE-FILE
S
GOEDEL-NUMBER IND
GENPREFIX (MAKE-GENPREFIX IND)
TAGS-PRECEDENCE (IF (MACSYMA-SOURCE-FILE-IN-CORE S)
; JPG likes this option.
(MACSYMA-SOURCE-FILE-IN-CORE S)
(+ 10000. IND)))
(IF (MACSYMA-SOURCE-FILE-SPLIT S)
(ALTER-MACSYMA-SOURCE-FILE
S
FASL-DIR 'MAXOUT
UNFASL-DIR 'MAXOUT))
(IF (MACSYMA-SOURCE-FILE-IN-CORE S)
(SETF (MACSYMA-SOURCE-FILE-FASL-DIR S) 'MAXDMP))
(IF (NOT (MACSYMA-SOURCE-FILE-MAINTAINERS S))
(SETF (MACSYMA-SOURCE-FILE-MAINTAINERS S)
(LIST (MACSYMA-SOURCE-FILE-DIR S))))
(IF (MACRO-FILE-P S)
(ALTER-MACSYMA-SOURCE-FILE
S
FASL-DIR (MACSYMA-SOURCE-FILE-DIR S)
UNFASL-DIR (MACSYMA-SOURCE-FILE-UNFASL-DIR S)))
S))
(DEFUN MAKE-GENPREFIX (GOEDEL-NUMBER)
(IF (GREATERP GOEDEL-NUMBER
(1- (LSH 1 (* 7 4))))
; thats (TIMES 2.68 (EXP 10. 8.)) source files!
(ERROR "Goedel number is too large" GOEDEL-NUMBER 'FAIL-ACT))
; be a compact as possible, be obscure to be unique,
; keep the symbol pname under one PDP10 word in size.
(DO ((N #\BS ; thats Back-Space, not Bull-Shit.
(LOGIOR (LSH N 7) (LOGAND K #o177)))
(K GOEDEL-NUMBER (LSH K -7))
(J 0 (1+ J)))
((= J 4.)
; am only taking 4 least significant ASCII's.
(SETQ N (LSH N 1)) ; LSB is not part of the game.
; PNPUT takes a list of FIXNUMs in the internal representation
; of Maclisp pnames. Trailing ^@ are ignored by EXPLODEN
; FLATC, PRINT.
(PNPUT (LIST N) NIL))))
(IF (STATUS FEATURE COMPLR) (*EXPR MACRO-FILE-P))
(DEFUN MACRO-FILE-P (X)
(OR (MACSYMA-SOURCE-FILE-GLOBAL-COMPILE X)
(MACSYMA-SOURCE-FILE-SELECTIVE-COMPILE X)
(MACSYMA-SOURCE-FILE-MACRO-COMPILE X)))

335
src/maxtul/docgen.37 Executable file
View File

@@ -0,0 +1,335 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; To generate TAGS file, CODESIZE file, and files used by the macsyma
;;; loader. -GJC 11:41pm Saturday, 25 October 1980
;;; See end of file for function to call.
(INCLUDEF "LIBMAX;GPRELUDE >")
(EVAL-WHEN (EVAL COMPILE LOAD)
(OR (GET 'DEFMFILE 'VERSION)
(LOAD '((MAXTUL) DEFILE)))
(OR (FBOUNDP 'FASDUMP)
(DEFPROP FASDUMP ((DSK LIBLSP) FASDMP) AUTOLOAD)))
(DECLARE (*EXPR FASDUMP))
(DEFVAR INFO-LOADED NIL)
(DEFUN LOAD-INFO ()
(COND ((NOT INFO-LOADED)
(IF (OR (NOT (BOUNDP 'MACSYMA-SOURCE-FILES))
(NULL MACSYMA-SOURCE-FILES))
(LOAD '((MAXDOC) FILES)))
(MAPC #'SET-PRESENT-VERSION MACSYMA-SOURCE-FILES)
(SETQ INFO-LOADED T))))
(DEFUN GEN-NTAGS (&AUX OUTSTREAM WINP (NAME "DSK:MACSYM;MACSYM NTAGS"))
(LOAD-INFO)
(UNWIND-PROTECT
(PROGN
(SETQ OUTSTREAM (OPEN (TEMP-FILENAME NAME) 'OUT))
(DO ((L (SORT (APPEND MACSYMA-SOURCE-FILES NIL)
#'(LAMBDA
(A B)
(< (MACSYMA-SOURCE-FILE-TAGS-PRECEDENCE A)
(MACSYMA-SOURCE-FILE-TAGS-PRECEDENCE B))))
(CDR L)))
((NULL L))
(FORMAT OUTSTREAM
"DSK:~A;~A >~%0,~A~%~%"
(MACSYMA-SOURCE-FILE-DIR (CAR L))
(MACSYMA-SOURCE-FILE-NAME (CAR L))
(MACSYMA-SOURCE-FILE-LANGUAGE (CAR L))))
(SETQ WINP T))
;; unwind protected.
(IF WINP (RENAMEF OUTSTREAM NAME) (IF OUTSTREAM (CLOSE OUTSTREAM)))))
;;; Moby assed function to gronk UNFASL files.
(DEFUN SET-CODESIZE (S OB EOF &AUX (FILE `((,(MACSYMA-SOURCE-FILE-UNFASL-DIR S))
,(MACSYMA-SOURCE-FILE-NAME S)
UNFASL)))
(COND ((MACRO-FILE-P S))
((PROBEF FILE)
(CNAMEF OB FILE)
;; a file object is an argument so that
;; GCing of file objects can be avoided.
(UNWIND-PROTECT
(PROGN
(OPEN OB 'IN)
(DO ((FORM (LET ((F (READ OB EOF)))
(READ OB EOF)
;; To get '(ASSEMBLED BY ...)
(SETF (MACSYMA-SOURCE-FILE-UNFASL-HEADER S)
(NAMELIST (CAR (LAST (CADR F)))))
F)
(READ OB EOF))
(SPLITS NIL)
(PREVIOUS-POSSIBLE-SPLIT NIL)
;; Only enter a name into SPLITS if there
;; are forms after the '(THIS IS THE UNFASL FOR *)
;; which indicate that the FASL file is actually
;; produced.
(FORMS-IN-SPLIT? NIL)
(CODESIZE 0))
((EQ FORM EOF)
(SETF (MACSYMA-SOURCE-FILE-CODESIZE S) CODESIZE)
(IF FORMS-IN-SPLIT?
(PUSH PREVIOUS-POSSIBLE-SPLIT SPLITS))
(IF SPLITS
(SETF (MACSYMA-SOURCE-FILE-SPLIT S) SPLITS))
S)
;; Pick up the comments in the fasl file,
;; split-files will have multiple such comments.
;; HAND-COMPILED pattern MATCHQ
(COND ((ATOM FORM))
((EQ (CAR FORM) 'QUOTE)
(SETQ FORM (CADR FORM))
(COND ((ATOM FORM)
(SETQ FORMS-IN-SPLIT? T))
((EQ (CAR FORM) 'THIS)
;; (THIS IS THE UNFASL FOR *)
(READ OB EOF)
;; (ASSEMBLED BY *)
(IF FORMS-IN-SPLIT?
(PUSH PREVIOUS-POSSIBLE-SPLIT SPLITS))
(SETQ FORMS-IN-SPLIT? NIL)
(SETQ PREVIOUS-POSSIBLE-SPLIT
(CADR (NAMELIST
(CAR (LAST FORM))))))
(T
(SETQ FORMS-IN-SPLIT? T))))
((EQ (CAR FORM) 'COMMENT)
(SETQ FORMS-IN-SPLIT? T)
;;`(COMMENT **FASL** TOTAL = ,X WORDS)
;;`(COMMENT **FASL** ,X TOTAL)
(SETQ FORM (CDR FORM))
(COND ((EQ (CAR FORM) '**FASL**)
(SETQ FORM (CDR FORM))
(COND ((EQ (CAR FORM) 'TOTAL)
(SETQ CODESIZE
(+ CODESIZE
(CADDR FORM))))
((EQ (CADR FORM) 'TOTAL)
;; For old UNFASL files.
(IF (FIXP (CAR FORM))
(SETQ CODESIZE
(+ CODESIZE
(CAR FORM)))))))))
(T
(SETQ FORMS-IN-SPLIT? T)))))
;; unwind protected
(CLOSE OB)))
(T
(FORMAT MSGFILES
"~&; Can't find UNFASL file for ~A~%"
(NAMESTRING FILE)))))
(DEFUN CODESIZE-SUB (OUTSTREAM L WHERE COUNT)
(FORMAT OUTSTREAM
"~2%The following are statistics for ~A-core files:~%" WHERE)
(DO ((SUM 0))
((NULL L)
(FORMAT OUTSTREAM
"~%The total is: ~D." SUM)
(CONS COUNT SUM))
(SETQ COUNT (1+ COUNT)
SUM (+ SUM (OR (MACSYMA-SOURCE-FILE-CODESIZE (CAR L)) 0)))
(FORMAT OUTSTREAM
"~%~3D. ~28S~5D.~%"
COUNT
(OR (MACSYMA-SOURCE-FILE-UNFASL-HEADER (CAR L))
`((DSK ,(MACSYMA-SOURCE-FILE-DIR (CAR L)))
,(MACSYMA-SOURCE-FILE-NAME (CAR L))))
(MACSYMA-SOURCE-FILE-CODESIZE (CAR L)))
(SETQ L (CDR L))))
(DEFUN IN-CORE-FILES (L)
(SORT (DEL #'(LAMBDA (IGNORE S) (NOT (MACSYMA-SOURCE-FILE-IN-CORE S)))
NIL
(APPEND L NIL))
#'(LAMBDA (A B)
(< (MACSYMA-SOURCE-FILE-IN-CORE A)
(MACSYMA-SOURCE-FILE-IN-CORE B)))))
(DEFUN INTERSECTIONP (X1 X2)
(DO ()
((NULL X1) NIL)
(IF (MEMQ (POP X1) X2) (RETURN T))))
(DEFUN OUT-OF-CORE-FILES (L)
(SORT (DEL #'(LAMBDA (IGNORE S)
(OR (MACSYMA-SOURCE-FILE-IN-CORE S)
(MACRO-FILE-P S)
(NOT (EQ (MACSYMA-SOURCE-FILE-LANGUAGE S)
'LISP))
(INTERSECTIONP
'(PDP10 ITS)
(MACSYMA-SOURCE-FILE-SYSTEMS-NOT-FOR S))
(NOT (INTERSECTIONP
'(PDP10 ITS)
(MACSYMA-SOURCE-FILE-SYSTEMS-FOR S)))))
NIL
(APPEND L NIL))
#'(LAMBDA (A B)
(< (MACSYMA-SOURCE-FILE-GOEDEL-NUMBER A)
(MACSYMA-SOURCE-FILE-GOEDEL-NUMBER B)))))
(DEFUN GEN-CODEL (&AUX INSTREAM OUTSTREAM WINP (NAME "MAXDOC;CODEL >")
(EOF (LIST NIL)) TEMP GRAND-SUM)
(LOAD-INFO)
(UNWIND-PROTECT
(PROGN
(SETQ INSTREAM (OPEN '((NUL)) 'IN))
(CLOSE INSTREAM)
(CNAMEF INSTREAM '((DSK))) ; get rid of NUL device atribute.
;; going to be reading in LOTS of symbols then throwing them out.
(GCTWA T)
(DO ((L MACSYMA-SOURCE-FILES (CDR L)))
((NULL L))
(SET-CODESIZE (CAR L) INSTREAM EOF))
(SETQ OUTSTREAM (OPEN (TEMP-FILENAME NAME) 'OUT))
(FORMAT-TIMEDATE OUTSTREAM)
(FORMAT OUTSTREAM
"~2%The Macsyma system code-size in PDP-10 words.~
~%Macsyma-source-files version ~A."
(Get 'macsyma-source-files 'version))
(SETQ TEMP (CODESIZE-SUB OUTSTREAM
(IN-CORE-FILES MACSYMA-SOURCE-FILES)
"in"
0)
GRAND-SUM (CDR TEMP))
(SETQ TEMP (CODESIZE-SUB OUTSTREAM
(OUT-OF-CORE-FILES MACSYMA-SOURCE-FILES)
"out-of"
(CAR TEMP))
GRAND-SUM (+ GRAND-SUM (CDR TEMP)))
(FORMAT OUTSTREAM
"~3%The grand total is: ~D.~%" GRAND-SUM)
(SETQ WINP T))
;; unwind protected
(IF WINP (RENAMEF OUTSTREAM NAME) (IF OUTSTREAM (CLOSE OUTSTREAM)))))
(DEFUN SET-MACSYMA-SOURCE-FILE-CODESIZE (OB &AUX INSTREAM)
;; one-time call entry point.
(SETQ INSTREAM (OPEN '((NUL)) 'IN))
(CLOSE INSTREAM)
(CNAMEF INSTREAM '((DSK)))
(SET-CODESIZE OB INSTREAM (LIST NIL)))
(DEFUN GEN-COMPLR-CHECK (&AUX OUTSTREAM WINP (NAME "MAXDOC;MCLDAT >"))
(LOAD-INFO)
;; used by :MCL
(UNWIND-PROTECT
(PROGN
(SETQ OUTSTREAM (OPEN (TEMP-FILENAME NAME) 'OUT))
(FORMAT OUTSTREAM "; Compiler source file database.~%; ")
(FORMAT-TIMEDATE OUTSTREAM)
(FORMAT OUTSTREAM "~%(SETQ MACSYMA-FILE-NAMES NIL)")
(DO ((L MACSYMA-SOURCE-FILES (CDR L)))
((NULL L))
(LET* ((F (CAR L))
(NAME (MACSYMA-SOURCE-FILE-NAME F)))
(FORMAT OUTSTREAM
"~
~%(PUSH '~S MACSYMA-FILE-NAMES)~
~%(DEFPROP ~S ~S DIR)~
~%(DEFPROP ~S ~S GENPREFIX)"
NAME
NAME
(MACSYMA-SOURCE-FILE-DIR F)
NAME
(MACSYMA-SOURCE-FILE-GENPREFIX F)
)
(IF (MACRO-FILE-P (CAR L))
(FORMAT OUTSTREAM
"~%(DEFPROP ~S T MACRO-FILE)"
NAME)
(FORMAT OUTSTREAM
"~
~%(DEFPROP ~S ~S UNFASL-DIR)~
~%(DEFPROP ~S ~S FASL-DIR)~
~%(DEFPROP ~S ~S ERRMSG-DIR)~
~%(DEFPROP ~S ~S IN-CORE)"
NAME
(MACSYMA-SOURCE-FILE-UNFASL-DIR F)
NAME
(MACSYMA-SOURCE-FILE-FASL-DIR F)
NAME
(MACSYMA-SOURCE-FILE-ERRMSG-DIR F)
NAME
(MACSYMA-SOURCE-FILE-IN-CORE F)))))
(TERPRI OUTSTREAM)
(SETQ WINP T))
;; unwind protected.
(IF WINP (RENAMEF OUTSTREAM NAME) (IF OUTSTREAM (CLOSE OUTSTREAM))))
(FASL-IZE NAME))
(DEFUN DOWNCASE-s (THING &OPTIONAL (N 0))
(SETQ THING (EXPLODEN THING))
(DO ((L (NTHCDR N THING) (CDR L)))
((NULL L) (MAKNAM THING))
(LET ((C (CAR L)))
(IF (NOT (OR (> C #/Z) (< C #/A)))
(SETF (CAR L)
(+ C (- #/a #/A)))))))
(DEFUN FORMAT-TIMEDATE (STREAM)
(LET (((YEAR MONTH DAY)(STATUS DATE))
((HOUR MINUTE) (STATUS DAYTIME))
(DOW (STATUS DOW))
(AM NIL))
(COND ((< HOUR 12.)
(SETQ AM T)
(IF (= HOUR 0) (SETQ HOUR 12.)))
((> HOUR 12.)
(SETQ HOUR (- HOUR 12.))))
(FORMAT STREAM
"~A, ~
~[January~;Februrary~;March~;April~;May~;June~;July~
~;August~;September~;October~;November~;December~:;FOO~] ~
~D, 19~2,'0D ~D:~2,'0D~:[pm~;am~]"
(DOWNCASE-S DOW 1)
(1- MONTH) DAY YEAR HOUR MINUTE AM)))
(DEFUN FASL-IZE (FILE &AUX (NAME (MERGEF '((* *) * FASL) FILE))
INSTREAM (EOF (LIST NIL)))
(UNWIND-PROTECT
(PROGN
(SETQ INSTREAM (OPEN FILE 'IN))
(DO ((L (LIST `(COMMENT ,(TRUENAME INSTREAM)))
(CONS FORM L))
(FORM `(COMMENT ,(FORMAT-TIMEDATE NIL))
(READ INSTREAM EOF)))
((EQ FORM EOF)
(SETQ L (NREVERSE L))
(FASDUMP NAME ; FASDUMP has its own WINP settup.
L ; non-hashed stuff.
NIL ; hashed stuff.
NIL ; Alist for substructures.
))))
(IF INSTREAM (CLOSE INSTREAM))))
(DEFUN SET-PRESENT-VERSION (X)
(LET* ((FILE-NAME `((DSK ,(MACSYMA-SOURCE-FILE-DIR X))
,(MACSYMA-SOURCE-FILE-NAME X)
>))
(TRUE-FILE-NAME (PROBEF FILE-NAME)))
(COND (TRUE-FILE-NAME
(SETF (MACSYMA-SOURCE-FILE-VERSION X)
(CADDR TRUE-FILE-NAME)))
(T
(FORMAT MSGFILES
"~&; Hey, I can't find the macsyma source file ~A.~%"
(NAMESTRING FILE-NAME))))))

99
src/maxtul/error!.1 Executable file
View File

@@ -0,0 +1,99 @@
;;-*-LISP-*-
;; FIND 'DEM ERROR MESSAGES!
;; 4:32pm Saturday, 18 July 1981 -George Carrete.
;; Each function will get an MERROR, MFORMAT, MTELL, and ERRRJF
;; property which will be a string. From this we can generate
;; a report on all macsyma error messages and wisecracks.
;; Super neato.
;; Note: Due to pdp-10 address space problems or maclisp problems,
;; hard to tell which, we aren't doing a two-pass operation.
(eval-when (eval compile)
(or (get 'defmfile 'version)
(load '((Maxtul)defile)))
(or (get 'toolm 'version)
(load '((maxtul)toolm))))
(declare (special current-module macsyma-source-file faslread-type
faslread-object))
(DEFVAR MESSAGE-FUNCTIONS-TABLE
'((MERROR *MERROR-1 *MERROR-2 *MERROR-3 *MERROR-4 *MERROR-5)
(MFORMAT *MFORMAT-2 *MFORMAT-3 *MFORMAT-4 *MFORMAT-5)
(MTELL MTELL1 MTELL2 MTELL3 MTELL4 MTELL5)
(ERRRJF *ERRRJF-1)))
(MAPC #'(LAMBDA (L)
(MAPC #'(LAMBDA (F) (PUTPROP F (CAR L) 'DA-FUNCTION))
L))
MESSAGE-FUNCTIONS-TABLE)
(DEFVAR MESSAGE-FUNCTIONS (MAPCAR #'CAR MESSAGE-FUNCTIONS-TABLE))
(DEFVAR MESSAGE-FUNCTIONS-FLATSIZE
(APPLY #'MAX (MAPCAR #'FLATSIZE MESSAGE-FUNCTIONS)))
(DEFVAR CURRENT-PLIST NIL)
(DEFVAR CURRENT-MESSAGE NIL)
(DEFUN FIND-MESSAGES-IN-MODULE (M &AUX
(CURRENT-PLIST (LIST NIL))
(CURRENT-MESSAGE NIL))
(MAP-OVER-FASL-INFO-IN-MODULE
#'MESSAGE-SNOOP
M
'(QLIST ENTRY CALL MIN)))
(DEFUN MESSAGE-SNOOP (FORM)
(CASEQ FASLREAD-TYPE
((QLIST)
(COND ((AND (EQ (TYPEP FORM) 'HUNK2)
(EQ (CAR FORM) (FASLREADSQUID FASLREAD-OBJECT))
(EQ (CADR FORM) 'ALLOCATE-MESSAGE-INDEX))
(SETQ CURRENT-MESSAGE (CHECK-OUT-OF-CORE-STRING (EVAL (CDR FORM))))
(PUTPROP CURRENT-MESSAGE T '+INTERNAL-STRING-MARKER))))
((CALL)
(LET ((DA-FUNCTION (GET FORM 'DA-FUNCTION)))
(COND (DA-FUNCTION
(ADDPROP? CURRENT-PLIST CURRENT-MESSAGE DA-FUNCTION)
(SETQ CURRENT-MESSAGE NIL)))))
((ENTRY)
(COND ((CDR CURRENT-PLIST)
(SETF (CAR CURRENT-PLIST) (LIST FORM CURRENT-MODULE))
(OUTPUT-MESSAGE-PLIST CURRENT-PLIST)
(SETQ CURRENT-PLIST (LIST NIL)))))))
(defun find-all-MESSAGES (&aux (modules (macsyma-runtime-modules)))
(format msgfiles
"~&; Looking in the following modules for MESSAGES:~
~%~S~%"
modules)
(mapc #'find-MESSAGES-IN-MODULE modules))
(DEFUN OUTPUT-MESSAGE-PLIST (S)
(FORMAT MSGFILES "~&(~S" (CAR S))
(DO ((L MESSAGE-FUNCTIONS (CDR L))
(M))
((NULL L)
(FORMAT MSGFILES ")~%"))
(COND ((SETQ M (GET S (CAR L)))
(FORMAT MSGFILES "~% ~S~vx ("
(CAR L)
(- MESSAGE-FUNCTIONS-FLATSIZE (FLATSIZE (CAR L))))
(DO ()
((NULL M)
(PRINC ")" MSGFILES))
(PRIN1 (POP M) MSGFILES)
(IF M (FORMAT MSGFILES "~% ~vX "
MESSAGE-FUNCTIONS-FLATSIZE)))))))
(deftoolage module-messages ()
"look for messages in a module"
(find-messages-in-module
(car (completing-read "Module-> " (macsyma-runtime-modules)))))
(deftoolage find-all-messages ()
"Map over all FASL files for FSUBRS finding."
"Use the Report-on-fsubrs command after this to see summary"
(find-all-messages))

122
src/maxtul/expand.10 Executable file
View File

@@ -0,0 +1,122 @@
;;; -*- LISP -*-
;;;
;;; EXPAND: A package for macroexpanding files
;;;
;;; 1:20am Saturday, 6 October 1979 :KMP
;;; 4:31am Sunday, 30 March 1980 :GJC EOF-COMPILE-QUEUE
;;; 5:43pm Thursday, 16 April 1981 :GJC KLEANED UP FOR USE IN MCL.
(HERALD EXPAND)
(EVAL-WHEN (COMPILE EVAL)
(OR (GET 'IOTA 'VERSION) (LOAD '((LIBLSP)IOTA))))
(DEFUN COPY MACRO (X) `(SUBST NIL NIL ,(CADR X)))
(DEFVAR LISP->LISP NIL)
(DECLARE (SPECIAL EOF-COMPILE-QUEUE)
(*EXPR MACRO-EXPAND))
(DEFUN LISP->LISP (INPUT-FILE &OPTIONAL (OUTPUT-FILE ""))
(SETQ OUTPUT-FILE (MERGEF OUTPUT-FILE "* MACROD"))
(SETQ OUTPUT-FILE (MERGEF OUTPUT-FILE INPUT-FILE))
(LET ((EOF-COMPILE-QUEUE NIL))
(IOTA ((INFILE INPUT-FILE 'IN)
(OUTSTREAM (MERGEF "* _ACRO_" OUTPUT-FILE) 'OUT))
(LISP->LISP\WORKER INFILE OUTSTREAM)
(DO ((MORE-STUFF EOF-COMPILE-QUEUE
EOF-COMPILE-QUEUE))
((NULL MORE-STUFF))
;; this might not be exactly the way COMPLR handles it.
(SETQ EOF-COMPILE-QUEUE NIL)
(PRINT '(COMMENT **EXPAND** START OF EOF-COMPILE-QUEUE)
OUTSTREAM)
(LISP->LISP\WORKER-FROM-LIST (REVERSE MORE-STUFF)
T OUTSTREAM)
(PRINT '(COMMENT **EXPAND** END OF EOF-COMPILE-QUEUE)
OUTSTREAM))
(RENAMEF OUTSTREAM OUTPUT-FILE)
)))
(DEFUN LISP->LISP\WORKER (INFILE OUTSTREAM)
(DO ((FORM (READ INFILE INFILE)
(READ INFILE INFILE))
(OUTFILES (NCONS OUTSTREAM))
(LISP->LISP T)
(/^Q T)
(/^R T)
(/^W T))
((EQ FORM INFILE))
(SPRINTER (COND ((ATOM FORM) FORM)
(T
(LISP->LISP\MUNG-TOPLEVEL FORM
INFILE
OUTSTREAM))))))
(DEFMACRO POPR (X L)
`(COND ((NULL ,X) ,L)
(T (POP ,X))))
(DEFUN LISP->LISP\WORKER-FROM-LIST (IN-LIST INFILE OUTSTREAM
&AUX (IN-FORMS IN-LIST))
(DO ((FORM (POPR IN-FORMS IN-LIST)
(POPR IN-FORMS IN-LIST))
(OUTFILES (NCONS OUTSTREAM))
(LISP->LISP T)
(/^Q T)
(/^R T)
(/^W T))
((EQ FORM IN-LIST)) ;;; IN-LIST IS UNIQUE IF NON-CIRCULAR
(SPRINTER (COND ((ATOM FORM) FORM)
(T
(LISP->LISP\MUNG-TOPLEVEL FORM
INFILE
OUTSTREAM))))))
(DEFUN LISP->LISP\MUNG-TOPLEVEL (FORM INFILE OUTSTREAM)
(LET ((FUN (GET (CAR FORM) 'LISP->LISP\MUNGING-FUNCTION)))
(COND (FUN (FUNCALL FUN FORM INFILE OUTSTREAM))
(T
(MACRO-EXPAND FORM)))))
(DEFUN (DECLARE LISP->LISP\MUNGING-FUNCTION) (FORM () ())
(MAPC 'EVAL (COPY (CDR FORM)))
(MACRO-EXPAND FORM))
(DEFUN (EVAL-WHEN LISP->LISP\MUNGING-FUNCTION) (FORM () ())
;; EVAL-WHEN-LOAD ISN'T TAKEN CARE OF, IT SHOULD CALL
;; THE MUNG-FORM-LIST FUNCTION
(COND ((MEMQ 'COMPILE (CADR FORM))
(MAPC 'EVAL (COPY (CDDR FORM)))))
(MACRO-EXPAND FORM))
(DEFUN (INCLUDE LISP->LISP\MUNGING-FUNCTION) (FORM () OUTSTREAM)
(PRINT `(COMMENT **EXPAND** INSERTING FILE ,(CADR FORM)) OUTSTREAM)
(IOTA ((INFILE (CADR FORM) 'IN))
(LISP->LISP\WORKER INFILE OUTSTREAM))
`(COMMENT **EXPAND** DONE INSERTING FILE ,(CADR FORM)))
(DEFUN (INCLUDEF LISP->LISP\MUNGING-FUNCTION) (FORM INFILE OUTSTREAM)
(LET ((FILENAME (EVAL (CADR FORM))))
(FUNCALL (GET 'INCLUDE 'LISP->LISP\MUNGING-FUNCTION)
(LIST '*DUMMY* FILENAME) INFILE OUTSTREAM)))
(DEFUN (DEFUN LISP->LISP\MUNGING-FUNCTION) (FORM () ())
;(COND ((MEMQ (CADDR FORM) '(/&OPTIONAL /&REST /&WHOLE /&AUX))
(RPLACA FORM 'DEFUN/&)
(MACRO-EXPAND FORM))
(DECLARE (SPECIAL MACRO-FILES))
(DEFUN (LOAD-MACSYMA-MACROS LISP->LISP\MUNGING-FUNCTION) (FORM () ())
`(COMMENT *** LOADING MACSYMA MACROS ***
,@(MAPCAR
#'(LAMBDA (X)
(OR (GET X 'VERSION)
(PROGN (LOAD (MACRO-DIR X))
(PUSH X MACRO-FILES)))
(MACRO-DIR X))
(CDR FORM))))

101
src/maxtul/fasmap.5 Executable file
View File

@@ -0,0 +1,101 @@
;;-*-LISP-*-
;; For mapping over da objects in da FASL files
;; of Macsyma. 6:36pm Wednesday, 15 July 1981
;; -George Carrette.
;; Functions of interest:
;; (MACSYMA-RUNTIME-MODULES) returns list of module names.
;; (MAP-OVER-FASL-INFO-IN-MODULE
;; <FUNCTION> <MODULE-NAME> &optional <FASLREADOPEN-OPTIONS>)
;; During the mapping the following special variables are bound:
;; CURRENT-MODULE
;; MACSYMA-SOURCE-FILE
;; FASLREAD-TYPE
;; (ADDPROP? <SYMBOL> <OBJECT> <KEY>) good for gathering info.
(eval-when (eval compile)
(or (get 'defmfile 'version)
(load '((Maxtul)defile))))
(declare (special faslread-type)
(*expr faslread faslreadclose)
(*lexpr faslreadopen))
(defvar current-module)
(defvar macsyma-source-file)
(defvar faslread-object)
(DEFUN ADDPROP? (SYMBOL OBJECT KEY)
;; Returns NIL if it is info already known, non-nil if not known.
(LET ((L (GET SYMBOL KEY)))
(IF (MEMQ OBJECT L)
NIL
(PUTPROP SYMBOL (CONS OBJECT L) KEY))))
(defun macsyma-runtime-modules ()
(sort (mapcan #'(lambda (u)
(if (not (macro-file-p u))
(list (macsyma-source-file-name u))))
macsyma-source-files)
#'alphalessp))
(DEFUN MAP-OVER-FASL-INFO-IN-MODULE (F CURRENT-MODULE
&OPTIONAL
(OPTIONS () OPTIONS-P))
(LET ((MACSYMA-SOURCE-FILE (ASS #'(LAMBDA (A B)
(EQ A (MACSYMA-SOURCE-FILE-NAME B)))
CURRENT-MODULE
MACSYMA-SOURCE-FILES)))
(IF (NULL MACSYMA-SOURCE-FILE)
(FORMAT MSGFILES "~&; Module not a macsyma-source-file : ~S~%"
current-module)
(LET ((SOURCE-FILE (NAMESTRING `((DSK ,(MACSYMA-SOURCE-FILE-DIR))
,(MACSYMA-SOURCE-FILE-NAME)
>)))
(FASL-FILES (CONS (MACSYMA-SOURCE-FILE-NAME)
(MACSYMA-SOURCE-FILE-SPLIT))))
(IF (MEMQ (CAR FASL-FILES) (CDR FASL-FILES))
(SETQ FASL-FILES (CDR FASL-FILES)))
(FORMAT MSGFILES
"~&; For source file ~A~%" source-file)
(do ((l fasl-files (cdr l)))
((null l))
(LET ((Filename (NAMESTRING `((DSK ,(MACSYMA-SOURCE-FILE-FASL-DIR))
,(CAR L) FASL)))
(ff-object))
(IF (NOT (PROBEF Filename))
(FORMAT MSGFILES
"~&; Possible file ~A not found.~%" Filename)
(unwind-protect
(map-over-fasl-info-in-object
f
(setq ff-object
(if options-p
(faslreadopen filename options)
(faslreadopen filename))))
(faslreadclose ff-object)))))))))
(defun map-over-fasl-info-in-object (f ff-object)
(let ((faslread-type nil)
(faslread-object ff-object)
#+complr
(fast-f (or (and (symbolp f)
(eq (car (getl f '(subr lsubr expr fexpr fsubr)))
'subr)
(get f 'subr))
;; ask me about this code someday. -gjc
(boole 7 13._27.
(lsh 1 23.)
(maknum f)))))
(do ((form))
(nil)
(setq form (faslread ff-object))
(if (eq faslread-type 'eof) (return nil))
#+complr (subrcall nil fast-f form)
#-complr (funcall f form)
)))

144
src/maxtul/fsubr!.5 Executable file
View File

@@ -0,0 +1,144 @@
;;-*-LISP-*-
;; FIND 'DEM FSUBRS!
;; We want to find all places that define FSUBRS,
;; and all places that knowingly call FSUBRS as if
;; they were regular functions. This is for getting rid
;; of such hackery to help Transportability to NIL. -gjc
;; If somebody has done (declare (*fexpr foobar)) then
;; (foobar ...) the not very common case, or,
;; (apply 'foobar <...>) the common case we are really after,
;; compiles into
;; (JCALL 17 'FOOBAR)
;; which is a UUO that, when FOOBAR has an FSUBR property,
;; acts the same as (JCALL1 'FOOBAR) if FOOBAR had a SUBR property.
;; That is, just like a regular subr call of one argument.
(eval-when (eval compile)
(or (get 'defmfile 'version)
(load '((Maxtul)defile)))
(or (get 'toolm 'version)
(load '((maxtul)toolm))))
(declare (special current-module macsyma-source-file faslread-type))
;; For each FSUBR keep a FSUBR-DEFINED-IN property.
;; For each FSUBR keep a FSUBR-REFERENCED-IN property.
(defun fsubr-snoop (frob)
(caseq faslread-type
(call
(if (= (cadr frob) #o17)
(if (addprop? (caddr frob)
current-module
'fsubr-referenced-in)
(format msgfiles
"~&; Got an fsubr reference! -> ~S~%"
(caddr frob)))))
(entry
(if (eq (cadr frob) 'fsubr)
(if (addprop? (car frob)
current-module
'fsubr-defined-in)
(format msgfiles
"~&; Got an fsubr definition! -> ~S~%"
(car frob)
))))))
(defun find-fsubrs-in-module (m)
(map-over-fasl-info-in-module
#'fsubr-snoop
m
'(entry call)))
(defun find-all-fsubrs (&aux (modules (macsyma-runtime-modules)))
(format msgfiles
"~&; Looking in the following modules for FSUBRS:~
~%~S~%"
modules)
(mapc #'find-fsubrs-in-module modules))
(defvar report-on-fsubrs ())
(defun report-on-fsubrs (&AUX report-on-fsubrs)
(mapatoms #'(lambda (p)
(if (or (get p 'fsubr-defined-in)
(get p 'fsubr-referenced-in))
(push p report-on-fsubrs))))
(setq report-on-fsubrs (sort report-on-fsubrs #'alphalessp))
(mapc #'(lambda (p)
(format MSGFILES "~
~&(~S~
~% fsubr-defined-in ~S~
~% fsubr-referenced-in ~S) ~%"
p
(get p 'fsubr-defined-in)
(get p 'fsubr-referenced-in)))
report-on-fsubrs)
report-on-fsubrs)
(defun read-a-module ()
(car (completing-read "Module-> " (macsyma-runtime-modules))))
(deftoolage module-fsubrs ()
"look for FSUBR hackery in a module"
(find-fsubrs-in-module (read-a-module)))
(deftoolage report-on-fsubrs ()
"Output a report of all info in the environment on fsubrs"
(report-on-fsubrs))
(deftoolage find-all-fsubrs ()
"Map over all FASL files for FSUBRS finding."
"Use the Report-on-fsubrs command after this to see summary"
(find-all-fsubrs))
(defun defmspec-entries-in-module (m)
(map-over-fasl-info-in-module
#'(lambda (entry)
(cond ((eq (cadr entry) 'mfexpr*s)
(format msgfiles "~&; Got one: ~S~%" (car entry))
(putprop (car entry) t '*fexpr))))
m
'(entry)))
(deftoolage defmspec-forms-in-module ()
"Find DEFMSPEC definitions in a module"
(defmspec-entries-in-module (read-a-module)))
(deftoolage find-all-defmspecs ()
"Map over modules gathering DEFMSPEC properties"
(let ((Modules (macsyma-runtime-modules)))
(format msgfiles
"~&; Looking for DEFMSPEC in the following modules:~%~S"
modules)
(mapc #'Defmspec-entries-in-module modules)))
(deftoolage generate-defmspec-declare-file ()
"Generate the file MAXDOC;DCL FEXPR"
(let ((stream))
(unwind-protect
(progn (setq stream (open "DSK:MAXDOC;DCL _FEXP_" 'OUT))
(format stream
"~&; *FEXPR declarations are fake, actually these are~
~%; all DEFMSPEC's and this information is used only~
~%; by the Macsyma->Lisp translator. -gjc~%~%")
(format stream
"(*FEXPR ")
(let ((out-stream stream)
(j 0))
(declare (special out-stream j))
(mapatoms #'(lambda (a)
(cond ((get a '*fexpr)
(if (zerop (\ j 5.))
(terpri out-stream))
(setq j (1+ j))
(princ " " out-stream)
(prin1 a out-stream))))))
(princ ") " stream)
(renamef stream "* FEXPR"))
(if stream (close stream)))))

37
src/maxtul/mailer.2 Executable file
View File

@@ -0,0 +1,37 @@
;;;-*-lisp-*-
(herald mailer)
;;; a standard norman mailer.
;;; example.
;;; (FORMAT-MAIL 'GJC
;;; "Hey man, what time is ~:[lunch~;dinner~]?" dinnerp)
(DEFUN FORMAT-MAIL (TO-LUSERS STRING &REST ARGUMENTS
&AUX STREAM WINP)
(IF (ATOM TO-LUSERS)
(SETQ TO-LUSERS (LIST TO-LUSERS)))
(UNWIND-PROTECT
(PROGN
(SETQ STREAM (OPEN "DSK:.MAIL.;MCL _TEMP" 'OUT))
(FORMAT STREAM
"~
~&FROM-PROGRAM:The Mathlab ~A Program~
~%FROM-XUNAME:~A~
~%FROM-UNAME:~A~
~{~%RCPT:(~A)~}~
~%TEXT;-1~%"
(STATUS SUBSYS)
(STATUS SUBSYS)
(STATUS UNAME)
TO-LUSERS)
(LEXPR-FUNCALL #'FORMAT STREAM STRING ARGUMENTS)
(SETQ WINP T))
;; unwind-protected
(IF WINP
(RENAMEF STREAM "DSK:.MAIL.;MAIL >") ; actually "sends" the mail.
(IF STREAM (DELETEF STREAM)))))

258
src/maxtul/maxtul.61 Executable file
View File

@@ -0,0 +1,258 @@
;-*-LISP-*-
; maxima utilities. initialy set up for string file manglement.
; -RWK November 1980.
; restructed with a DEFTOOLAGE, & merged in my CODESIZE file
; maker, TAGS file maker, data-base maker for the macsyma->lisp
; translator, MCL (macsyma source file compiler) check file maker.
; Comment: Arguments to DEFTOOLAGE should act as more than just
; documentation, should be processed by the command loop,
; don't have time for this now.
; -GJC 4:08pm Thursday, 4 December 1980
; added a standard argument reader.
; N.B. Inferiour JOB stuff isn't really handled properly for
; ^Z ^P P and the like.
; -GJC 2:47pm Friday, 19 December 1980
(HERALD MAXTUL)
(eval-when (eval compile)
(or (get 'defmfile 'version)
(load '((maxtul)defile)))
(or (get 'IOTA 'VERSION)
(load '((LIBLSP)IOTA)))
(or (get 'ERMSGX 'VERSION)
(load '((LIBMAX) ERMSGX)))
(or (get 'TTY 'VERSION)
(load '((LIBLSP) TTY))))
(declare (*EXPR OPEN-MESSAGE-FILE LISPM-DECLARE-FILE-MAKE FASL-IZE DECLARE-FILE-MAKE
DISP-MACSYMA-SOURCE-FILE GEN-CODEL GEN-COMPLR-CHECK GEN-NTAGS
MERGE-INCORE-SYSTEM GET-STRING-FILE-NAME READ-UNTIL-CR
DISPLAY-STRING-FILES-NO-FASLS COMPLETING-READ GET-MFD-INDEXES))
(eval-when (eval compile load)
(or (get 'toolm 'version)
(load '((maxtul)toolm))))
(defun dump-it ()
(gc)
(pure-suspend () '|MAXTUL;TS MAXTUL|)
(load '((MAXDOC)FILES))
(load '((MAXDOC)MCLDAT))
(get-mfd-indexes) ;Just in case
(sstatus tople '(command-loop)))
(defun ^^-INT (stream ignore-char)
(tyi stream)
(sstatus tople '(command-loop))
(^g))
(sstatus ttyint #^^ #'^^-INT)
(defvar toolage nil)
(defvar command)
(defun command-loop ()
(do ((command))
(NIL)
(setq command (car (completing-read '"MAXIMUM TOOLAGE>" toolage)))
(apply (or (get command 'toolage)
#'(lambda ignore-n
(format t "~&BUG: no toolage for ~S~%"
command)))
(read-argument-list (get command 'toolage-args)))))
(defun read-argument-list (l)
(mapcar #'read-argument l))
(defun read-argument (desc)
(if (atom desc) (setq desc (cons 's-exp desc)))
(caseq (car desc)
(s-exp
(print (cdr desc) t)
(read t))
(string
(read-until-cr (cdr desc)))
(t
(error "unknown type of argument to read-argument" desc
'fail-act))))
(deftoolage load-info ()
"Recompile MAXDOC;FILES and reload."
(ljob-run-job 'complr '|DSK:SYS;TS CL| "MAXDOC;FILES (T)")
(setq info-loaded nil)
(load-info))
(deftoolage load-file ((string . |Filename-> |))
"Lisp Load a file"
(load (mergef |Filename-> | "DSK:MAXTUL;FOO *")))
(deftoolage REAP-STRING-DISPLAY ()
"Displays the out-of-core string files from MAXERR and MAXER1"
"which do not have findable FASL files."
(display-string-files-no-fasls))
(deftoolage GET-FASL-STRING-FILE ((string . |(FASL file) |))
"Tells the name of the string file which goes with that FASL file"
(let* ((filename (namelist |(FASL file) |))
(fasldir (get (cadr filename) 'fasl-dir))
(answer))
(if fasldir
(setq filename
(mergef filename `((DSK ,fasldir) * FASL))))
(setq answer (get-string-file-name filename))
(format T "~&FASL file: ~A --> String file: ~A"
(namestring filename)
(if answer (namestring answer)
"[NONE]"))))
(deftoolage GET-STRING-FILE-INFO ((string . |(String file) |))
"Abstracts the information from the string file directory"
(display-string-file-info |(String file) |))
(deftoolage MERGE-INCORE-SYSTEM ()
"Merge together the out-of-core strings for the"
"in-core files in preparation for a new MACSYMA dump."
(merge-incore-system))
(deftoolage gen-tags ()
"Generate NTAGS file."
(format t "~&; Generating NTAGS file.~%")
(GEN-NTAGS)
(VALRET ": I'm using a VALRET :TAGS MACSYMA;MACSYMA NTAGSî:CONTINUEî")
(FORMAT T "~&; Now, do :MOVE MACSYMA;MACSYMA NTAGS, MACSYMA TAGS~
~%; after verifying that things are ok.~%"))
(DEFUN MOVE-FILE (X Y)
(IF (NOT (PROBEF X))
(ERROR "file-not-found" x 'IO-LOSSAGE))
(IF (PROBEF Y) (DELETEF Y))
(RENAMEF X Y))
(deftoolage gen-mcl-check ()
"Generate MCL data base"
(gen-complr-check))
(deftoolage gen-codel ()
"Generate MAXDOC;CODEL > listing of CODE-SIZEs"
(GEN-CODEL))
(deftoolage display-macsyma-source-file-info ((string . |(first name) |))
"using information presently in the environment"
(let* ((name (cadr (namelist |(first name) |)))
;; uppcase and intern the name with NAMELIST.
(ob
(ass #'(lambda (name item)
(eq name
(macsyma-source-file-name item)))
name
macsyma-source-files)))
(cond (ob
(cursorpos 'c)
(disp-macsyma-source-file ob t))
(t
(format t "~&; No data for ~A" name)))))
(deftoolage declare-file-make ()
"Update the declare file used by translated code."
(declare-file-make)
(let ((f "DSK:MAXDOC;DCL LOAD"))
(format t "~&; ~A written, making FASL now." f)
(fasl-ize f)))
(deftoolage lispm-declare-file-make ()
"Update declare file used by a bare lisp machine."
(lispm-declare-file-make))
(deftoolage QUIT ()
"To lisp TOPLEVEL"
(sstatus tople nil)
(^g))
(deftoolage KILL-JOB ()
"Kill job"
(if (memq (car (completing-read "Kill job. [Confirm?] "
'(yes help no maybe why-not what who-me)))
'(yes maybe why-not))
(QUIT)))
(deftoolage HELP ()
"Print this cruft."
(cursorpos 'c)
(format t "~
~&Welcome to the MACSYMA TOOL~
~%The following commands are currently implemented:")
(mapc #'(lambda (cmd)
(format t
"~&~A ~{~A ~}~%~{ ~A~%~}"
cmd
(get cmd 'toolage-args)
(or (get cmd 'toolage-doc)
'("BUG: no documentation for this!"))))
toolage)
(format t
"~
~&The command reader completes on altmode or space,~
~%so the long command names should not deter you.~
~%"))
(defun msgfiles-int (stream char)
(if (= char (tyipeek () stream -1))
(tyi stream))
(format t
"~&; ~:[Pushing T onto~;Deleting T from~] msgfiles.~%"
(memq t msgfiles))
(if (memq t msgfiles)
(setq msgfiles (delq t msgfiles))
(push t msgfiles)))
(sstatus ttyint #^N #'msgfiles-int)
(defvar wall-file ())
(deftoolage wallpaper ()
"Toggle wallpaper output"
(cond (wall-file
(setq msgfiles (delq wall-file msgfiles))
(close wall-file)
(format t "~&; Wall-paper file was ~S~%"
(namestring (truename wall-file)))
(setq wall-file nil))
('else
(format t "~&; Opening wall-paper file.~%")
(setq wall-file (open "DSK:MAXTUL;WALL >" 'OUT))
(push wall-file msgfiles))))
(defun display-string-file-info (file)
(phi ((message-file (open-message-file file)))
(let* ((truename (truename message-file))
(alist (message-file-alist message-file))
(temp (or (cdr (assq 'source-file-name alist))
(cdr (assq 'filename alist))))
(source-files (if temp (ncons temp)
(or (cdr (assq 'filenames alist)) '(<NONE?>))))
(author (or (cdr (assq 'source-file-author alist)) '|???|))
(creator (or (cdr (assq 'creator alist)) '|???|))
(fasl (cdr (assq 'output-file-name alist)))
(funs (mapcar #'CAR (cdr (assq 'fun-doc-alist alist))))
(vars (mapcar #'CAR (cdr (assq 'var-doc-alist alist)))))
(format t "~&Filename: ~A~%~
Creator: ~A~%~
Source files: ~A~%~
Author: ~A~%~
Output file: ~A~%~
Documented variables: ~S~%~
Documented functions: ~S~%~
Total number of strings: ~D~%"
(namestring truename)
creator
(mapcar #'namestring source-files)
author
(namestring fasl)
vars funs
(cadr (assq 'message-count alist))))))
(or (get 'breaklevel 'version)
(load '((liblsp)break)))
(sstatus breaklevel '(Breaklevel))

186
src/maxtul/mcl.59 Executable file
View File

@@ -0,0 +1,186 @@
;;;-*-LISP-*-
;;; Utilities for compiling and installing Macsyma.
;;; GJC - 7:21pm Monday, 27 October 1980
(HERALD MCL)
(OR (GET 'USER-QUERY 'VERSION) (LOAD '((maxtul)QUERY)))
(or (get 'mailer 'version) (load '((maxtul)mailer)))
(OR (GET 'BREAKLEVEL 'VERSION)
(LOAD "LIBLSP;BREAK"))
(PUSH 'TTY-RETURN BREAK-VARS)
(PUSH '(LAMBDA (IGNORE) (FORMAT MSGFILES "~&;Still inside break level~%"))
BREAK-VALS)
(SSTATUS BREAKLEVEL '(BREAKLEVEL))
(DEFVAR TEST-COMPILATION-P NIL)
(DEFUN TEST-JNAME-P ()
(LET ((JNAME (STATUS JNAME)))
(AND (> (FLATC JNAME) 3.)
(= (GETCHARN JNAME 1) #/T)
(= (GETCHARN JNAME 2) #/M)
(= (GETCHARN JNAME 3) #/C)
(= (GETCHARN JNAME 4) #/L))))
(DEFUN ERRSET-BREAK (IGNORE-WHO-KNOWS-WHAT)
(*BREAK T "ERRSET-BREAK. P to continue lossage."))
(DEFVAR MCL-BEFORE-PROC NIL)
(DEFVAR MCL-AFTER-PROC NIL)
;;; The first time this function gets called with (STATUS JCL)
;;; the rest of the time with NIL.
(DECLARE (SPECIAL MSDIR ; From COMPLR, tells what DIR to put UNFASL.
TTYNOTES ; T if output junk to TTY.
))
(DEFUN *MAKLAP-DRIVER* (JCLP)
(DO () (NIL)
(OR JCLP (CURSORPOS 'A TYO))
(AND (TEST-JNAME-P)
(SETQ TEST-COMPILATION-P T))
(OR JCLP (SETQ TTYNOTES T))
(let ((FILENAME (namelist (cond (jclp (implode jclp))
(t (read-file-name ))))))
(MCL-FILE FILENAME JCLP))
(AND JCLP (QUIT))))
(DEFUN MCL-FILE (NAME JCLP)
(LET ((((DEV DIR) FN1 FN2) NAME))
(LET ((FASL-DIR (GET FN1 'FASL-DIR))
(UNFASL-DIR (GET FN1 'UNFASL-DIR))
PRESENT-VERSION PRESENT-NAME)
(SETQ PRESENT-NAME
(PROBEF (MERGEF NAME
`((DSK ,(GET FN1 'DIR)) ,FN1 >)))
PRESENT-VERSION (CADDR PRESENT-NAME))
(COND ((NOT FASL-DIR)
(FORMAT MSGFILES
"~
~&; ~A is not a known Macsyma system source."
(NAMESTRING NAME))
(COND ((Y-OR-N-OR-?-P
"Do you want to compile anyway"
"Output will go to the MACSYM directory.")
(FORMAT MSGFILES
"~&; Please update MAXDOC;FILES >")
(MAIL-REMINDER NAME)
(SETQ FASL-DIR 'MACSYM)
(SETQ UNFASL-DIR 'MAXOUT)
(MCL-SUB FN1 FN2 DEV DIR
UNFASL-DIR FASL-DIR PRESENT-VERSION
PRESENT-NAME JCLP))))
(T
(MCL-SUB FN1 FN2 DEV DIR UNFASL-DIR FASL-DIR PRESENT-VERSION
PRESENT-NAME JCLP))))))
(DEFUN MCL-SUB (FN1 FN2 DEV DIR UNFASL-DIR FASL-DIR PRESENT-VERSION PRESENT-NAME
JCLP)
(IF (EQ DIR '*)
;; So a user could type :MCL SIMP
;; for example
(SETQ DIR (OR (GET FN1 'DIR) '*)))
(SSTATUS FEATURE MACSYMA-COMPLR)
(COND (TEST-COMPILATION-P
(MAKE-LAP FN1 FN2 DEV DIR DIR DIR JCLP))
(t
(COND ((COND ((SAMEPNAMEP (INSTALLED-VERSION FN1)
PRESENT-VERSION)
(FORMAT MSGFILES
"~&; ~A has alread been compiled."
(NAMESTRING PRESENT-NAME))
(Y-OR-N-OR-?-P "Compile anyway."
(NAMESTRING PRESENT-NAME)))
(T T))
(MAKE-LAP FN1 FN2 DEV DIR UNFASL-DIR FASL-DIR JCLP))))))
(DEFUN MAKE-LAP (FN1 FN2 DEV DIR MSDIR FASL-DIR PROCEDE?) ; historical name.
(UNWIND-PROTECT
(PROGN
(MAPC #'EVAL MCL-BEFORE-PROC)
(COND (PROCEDE?
(APPLY #'MAKLAP
;; awful, have to fake it out to think it was
;; passed via JCL from the COMPLR top-level init
;; function!
(EXPLODEN (FORMAT NIL
"DSK:~A;~A FASL_~A:~A;~A ~A"
FASL-DIR FN1
DEV DIR FN1 FN2))))
(T
(APPLY #'MAKLAP
;; of course its an FSUBR which takes OLD-IO filespec
;; in MIDAS style.
`((,FN1 FASL DSK ,FASL-DIR)
(,FN1 ,FN2 ,DEV ,DIR))))))
;; unwind protected
(MAPC #'EVAL MCL-AFTER-PROC)))
(DEFUN MAIL-REMINDER (FILE)
(FORMAT-MAIL (LIST "GJC MC" (STATUS UNAME))
"~
~%The file ~A was compiled and installed into the macsyma~
~%system, but was not a known source file.~
~%Please update MAXDOC;FILES and//or give me more information.~
~%~
~% - yours truly,~
~% The Macsyma Compiler.~%"
(NAMESTRING FILE)))
(DEFUN INSTALLED-VERSION (FN1 &AUX INSTREAM
(NAME `((DSK ,(GET FN1 'UNFASL-DIR)) ,FN1 UNFASL)))
; duplicates functionality in DOCGEN, although not by much,
; SET-CODESIZE reads the whole UNFASL file, so we don't want to
; use that.
(IF (PROBEF NAME)
(UNWIND-PROTECT
(PROGN
(SETQ INSTREAM (OPEN NAME 'IN))
; (QUOTE (THIS IS THE UNFASL FOR ((DSK FOO) BAR N)))
(CADDR (CAR (LAST (CADR (READ INSTREAM))))))
(IF INSTREAM (CLOSE INSTREAM)))
(FORMAT MSGFILES
"~&; Unfasl file ~A not found.~%"
NAME)))
(sstatus ttyint #^N #'ttynotes-toggle)
(defun ttynotes-toggle (stream char)
(if (= char (tyipeek () stream -1))
(tyi stream))
(FORMAT T "~&; Setting TTYNOTES to ~S~%"
(setq ttynotes (not ttynotes))))
(defun present-version (f)
(caddr (probef `((dsk ,(get f 'dir)) ,f >))))
(defun todo () (setq todo
(mapcan #'(lambda (f)
(if (get f 'macro-file) nil
(if (samepnamep (present-version f)
(installed-version f))
nil
(list f))))
macsyma-file-names)))
(defun todoi () (setq todoi (mapcan #'(lambda (u) (if (get u 'in-core)
(list u)))
todo)))
(defun doit (f) (mcl-file `((* *) ,f *) nil))
(if (probef "dsk:maxtul;files todo")
(load "dsk:maxtul;files todo"))
(defun findout (&aux s)
(unwind-protect
(let ((msgfiles
(setq s (open "dsk:maxtul;files _todo_" 'out))))
(todo)
(todoi)
(print `(setq when ,(time:print-current-date nil)) s)
(print `(setq todo ',todo) s)
(print `(setq todoi ',todoi) s)
(renamef s "dsk:maxtul;files todo"))
(if s (close s))))

146
src/maxtul/mcldmp.(init) Executable file
View File

@@ -0,0 +1,146 @@
;;;-*-LISP-*-
;;; COMPLR init file which sets things up to dump TS MCL.
(defun load-em (dir files)
(mapc #'(lambda (u)
(print u msgfiles)
(or (get u 'version)
(load `((,dir),u))))
files))
(defun ob-hack (obarray symbol) (readlist (explode symbol)))
(defvar jnames-which-act-like-cl '(cl umcl))
(defmacro docn (&rest forms)
`(progn ,@(mapcar #'(lambda (form)
`(progn (print ',form msgfiles)
(princ "=> " msgfiles)
(prin1 ,form msgfiles)
(princ " " msgfiles)))
forms)))
(defun mcl-verno ()
(TERPRI)
(PRINC "Macsyma source compiler ")
(PRINC (GET 'Mcompiler 'VERSION))
(COMPLRVERNO))
(defun dump-mcl (verno &optional
tty-p
(*pure-setting t)
&AUX DSKMSG (BASE 10.) DUMPFILE MES-FILE TF
msgfiles)
(if tty-p (push tyo msgfiles))
(let ((*pure *pure-setting))
(setq TF "dsk:maxtul;mcl _undu_"
DUMPFILE (format nil "dsk:maxtul;mcldmp ~D" verno)
mes-file (format nil "dsk:maxtul;mcldms ~D" verno)
dskmsg (open TF 'out))
(push dskmsg msgfiles)
(putprop 'mcompiler verno 'version)
(docn *pure
*sharing-file-list*
dumpfile
mes-file
(setq error-break-environment (cons obarray readtable))
(setq *nopoint nil)
(*rset t)
(get 'complr 'version)
(get 'mcompiler 'version)
(get 'sharable 'version)
(status lispverno)
(status date)
(status dow)
(status daytime)
(status uname)
(status userid)
(status jname)
(status subsys))
(load-em 'maxtul '(timepn))
(timeprogn
(time-origin)
;; workhorse section of code timed for the heck of it.
(or (status feature defstruct) ;; good ole ALAN has to be different.
(load-em 'liblsp '(struct)))
(load-em 'lisp '(format setf umlmac evonce))
(load-em 'liblsp '(debug IOTA smurf time))
(load-em 'MAXTUL '(MCL EXPAND))
(load-em 'libmax ;; should use MAXDOC FILES data.
'(module LMMAC MAXMAC MFORMA DEFINE MOPERS ERMSGC
TRANSM PROCS NUMERM))
(load-em 'maxdoc '(dcl mcldat))
(time-origin)
(OR (MEMBER '(SETQ MESSAGES-INITIALIZED NIL) MCL-AFTER-PROC)
(PUSH '(SETQ MESSAGES-INITIALIZED NIL) MCL-AFTER-PROC))
(let ((^d t)) (gc))
(docn (setq errset #'errset-break)
(status memfree)
(status features))
(mapatoms #'(lambda (sym)
(cond ((get sym 'version)
(format msgfiles "~%~A ~A"
sym (get sym 'version))))))
;; end of workhorse section.
)
(progn ;; clean up message files.
(setq msgfiles (delete dskmsg msgfiles))
(renamef dskmsg mes-file)
(if (probef tf)(deletef tf)))
(FORMAT-MAIL `(,(STATUS UNAME) GJC)
"~
~&Dump of ~A in the following *sharing-file-list* :~
~%~S~
~%~
~% -yours truly~
~% NJADP (not just another dumb program)~
~%"
(namestring dumpfile)
*sharing-file-list*)
(putprop 'mcompiler
(time:print-current-date ())
'date)
(putprop 'mcompiler
(status uname)
'uname)
(pure-suspend 'p dumpfile)
;; next form gets evaluated when lisp is resurected.
(sstatus toplevel
;; smart lisp calls eval on this form when we
;; get out of the scope of this function call
;; to (DUMP-MCL).
'(progn
(sstatus toplevel nil)
(sstatus gctime 0)
(time-origin 'set nil)
(announce-&-load-init-file
'mcompiler
nil
(format nil "DSK:MAXTUL;MCLFIX ~D"
(get 'mcompiler 'version)))
(cond ((memq (status subsys)
jnames-which-act-like-cl)
(SETQ TEST-COMPILATION-P T)
(#.(ob-hack sobarray 'complr-tople-after-suspend)))
(t
;; error during INIT goes to
;; standard READ-EVAL-PRINT.
;; like wow man. here we are, ready to
;; forge ahead into the unknown macroworld.
(sstatus toplevel '(*maklap-driver* nil))
(*maklap-driver* (status jcl))))))
;; this is the end man. don't put any more shit after this.
))
(princ "
Do ^G then (DUMP-MCL /"version/") to dump a new MCL" tyo)

19
src/maxtul/mcldmp.midas Executable file
View File

@@ -0,0 +1,19 @@
title MCL - Macsyma Compiler bootstrap-loader
;; It is IMPORTANT that the indentation of the valret string contain no TABs!
;; --kmp
mcl: .value [ asciz \:TERPRI
:Macsyma Source Compiler
:TERPRI
L MAXTUL;.GOOD. COMPLR
: Save old XUNAME in location 60 
.XUNAME/
60/ 1Q
.XUNAME/ 1'MAXTUL
.HSNAME/ 1'MAXTUL
0G :VP \ ]
killme: .logout 1, ; This should never be reached, but just in case
jrst killme ; Try until it's good and dead
end mcl

103
src/maxtul/query.6 Executable file
View File

@@ -0,0 +1,103 @@
;;;-*-LISP-*-
;;; user-query interfaces.
(HERALD USER-QUERY)
(EVAL-WHEN (EVAL COMPILE)
(OR (GET 'DO-WITH-TTY-ON 'MACRO)(LOAD '|LIBLSP;TTY FASL|)))
(DEFVAR TTY-RETURN-STACK NIL)
(DEFUN READ-HASH-SEQ ()
(DO ((K 0 (+ CHAR (* K 256)))
(CHAR (TYI TYI)(TYI TYI)))
((= CHAR #\CR) K)))
(DEFUN READ-PASS-WORD ()
(DO-WITH-TTY-OFF
(DO ((K1)(K2))
(())
(*CATCH 'RE-READ-PASS-WORD
(LET ((TTY-RETURN-STACK
(CONS '(PROGN (TERPRI TYO)
(PRINC "Interrupted, try again." TYO)
(*THROW 'RE-READ-PASS-WORD NIL))
TTY-RETURN-STACK)))
(CLEAR-INPUT TYI)
(TERPRI TYO)
(PRINC '|Input password->| TYO)
(SETQ K1 (READ-HASH-SEQ))
(PRINC '|again->| TYO)
(SETQ K2 (READ-HASH-SEQ))
(AND (= K1 K2) (RETURN K1))
(PRINC '|passwords didn't match, try again.| TYO))))))
(DEFUN READ-FILE-NAME (&OPTIONAL (PROBE-TEST NIL))
(DO ((N))
(())
(SETQ N (READ-UNTIL-CR '|File name->|))
(COND ((EQ N '||))
(T
(SETQ N (ERRSET (NAMELIST N) T))
(AND N (COND ((OR (NOT PROBE-TEST) (PROBEF (CAR N)))
(RETURN (CAR N)))
(T
(PRINC (NAMESTRING (CAR N)) TYO)
(PRINC '| is not an existing file.| TYO))))))))
(DEFVAR PROMPT)
(DEFVAR INPUT-CHAR-STACK NIL)
(DEFUN RE-DISPLAY ()
(PROGN (PRINC PROMPT TYO)
(MAPC #'(LAMBDA (X) (TYO X TYO))
(REVERSE INPUT-CHAR-STACK))))
(DEFUN READ-UNTIL-CR (PROMPT &AUX TTY-RETURN-STACK INPUT-CHAR-STACK)
(PUSH '(PROGN (CURSORPOS 'A TYO)
(RE-DISPLAY))
TTY-RETURN-STACK)
(cursorpos 'a tyo)
(PRINC PROMPT TYO)
(DO ((C (TYI TYI)(TYI TYI)))
((= C #\CR)
(IMPLODE (NREVERSE INPUT-CHAR-STACK)))
(COND ((= C #\RUBOUT)
(COND (INPUT-CHAR-STACK
(RUBOUT (POP INPUT-CHAR-STACK) TYO))))
((= C #\FF)
(RE-DISPLAY))
(T (PUSH C INPUT-CHAR-STACK)))))
(DEFUN TTY-RETURN (&REST IGNORED)
(AND TTY-RETURN-STACK (EVAL (CAR TTY-RETURN-STACK))))
(SETQ TTY-RETURN 'TTY-RETURN)
(DEFUN READ-CHARACTER (PROMPT &AUX INPUT-CHAR-STACK TTY-RETURN-STACK)
(PUSH '(PROGN (CURSORPOS 'A TYO) (RE-DISPLAY))
TTY-RETURN-STACK)
(RE-DISPLAY)
(DO ((C (TYI TYI) (TYI TYI)))
((NOT (= C #\FF)) C)
(RE-DISPLAY)))
(DEFUN Y-or-n-or-?-p (MESSAGE &OPTIONAL (EXPLAIN))
(FORMAT TYO "~&~A " MESSAGE)
(DO ((C))
(NIL)
(SETQ C (READ-CHARACTER '|(Y or N)?|))
(CASEQ C
((#/Y #/y)
(PRINC "es." TYO)
(RETURN T))
((#/N #/n)
(PRINC "o." TYO)
(RETURN NIL))
((#/? #/h #/H)
(IF EXPLAIN (FORMAT TYO "~&~A~%" EXPLAIN))
(FORMAT TYO "~&~A " MESSAGE))
(T NIL))))

190
src/maxtul/strmrg.70 Executable file
View File

@@ -0,0 +1,190 @@
;-*-LISP-*-
;This file contains the code to merge a set of string files into one.
;Also needed is ERMSGC, to handle writing of the new file
(herald STRMRG)
(declare (*lexpr get-directory get-mfd-indexes))
(eval-when (compile eval)
(or (get 'iota 'version)
(load "liblsp;iota"))
(or (get 'lmmac 'version)
(load "libmax;lmmac"))
(or (get 'umlmac 'version)
(load "lisp;umlmac"))
(or (get 'ERMSGX 'VERSION)
(load "LIBMAX;ERMSGX")))
(eval-when (load eval)
(or (get 'ERMSGC 'VERSION)
(load "LIBMAX;ERMSGC")))
(eval-when (load eval compile)
(or (get 'FILDIR 'VERSION)
(load "Z;FILDIR")))
(defvar merge-files-prints T "T ==> Print what files are being merged")
;;; (MERGE-MESSAGE-FILES <output-file> <list-of-input-files>)
;;; merges the input files into a single message file in the output file.
;;; The output file's directory will include an ALIST of string filenames
;;; and index offsets. ALLOCATE-MESSAGE-INDEX should look at this directory
;;; and add in offset to the index it is given.
(defun merge-message-files (output inputs)
(let ((header-counts 1)
(files) (offset 0) (directory-position 0)
(message-text-word-count 0))
(declare (fixnum header-counts offset directory-position))
(dolist (file inputs) ;Collect a list of input SFA's
(push (setq file (open-message-file file))
files)
(setf (message-file-header-offset file) header-counts)
(setq header-counts
(+ header-counts (message-file-header-count file)))
(setq message-text-word-count
(+ message-text-word-count
(or (cdr (assq 'message-text-word-count
(message-file-alist file)))
0)))
(close file))
(setq files (nreverse files))
(phi ((outfile (make-fixnum-ascii-stream
(mergef '(_STRMG OUTPUT) output))))
(if merge-files-prints
(format msgfiles
"~&Merging the files:~%~S~&Into file: ~A~%"
(mapcar #'NAMESTRING inputs)
(namestring output)))
(dotimes (() header-counts)
(out outfile #.(car (pnget 'EMPTY 7))))
(dolist (file files)
(open file)
(filepos file (message-file-header-count file))
(setf (message-file-text-offset file) offset)
(let ((errset ()))
(errset ;Cretinous IN
(do () (())
(out outfile (in file))
(setq offset (1+ offset)))
() ))
(close file))
(setq directory-position (filepos outfile))
(filepos outfile 0)
(out outfile directory-position)
(dolist (file files)
(open file)
(filepos file 0)
(dotimes (() (message-file-header-count file))
(out outfile (+ (in file) (message-file-text-offset file)
(- header-counts
(message-file-header-count file)))))
(close file))
(filepos outfile directory-position)
(print
`(MDOC (files .
,(mapcar #'(lambda (file)
`(,(truename file) .
,(message-file-header-offset file)))
files))
(message-count . ,(1- header-counts))
(creator . ,(status uname))
(date . ,(status date))
(time . ,(status daytime)))
outfile)
(renamef outfile (cdr (namelist output))))))
(defprop FASLREADOPEN ((DSK RLB) FASLRO FASL) AUTOLOAD)
(defprop LOAD-INFO ((DSK MAXTUL) DOCGEN FASL) AUTOLOAD)
;;; (GET-STRING-FILE-NAME file) gives the string-file filename for this FASL
;;; file, or NIL if none.
(declare (special FASLREAD-TYPE))
(defun get-string-file-name (file)
(setq file (mergef '((DNRF *) * FASL) file))
(let ((faslread-object ()))
(unwind-protect
(progn
(setq faslread-object (faslreadopen file '(MIN EVAL)))
(do ((entry (faslread faslread-object) (faslread faslread-object)))
((eq faslread-type 'EOF))
(if (and (eq faslread-type 'EVAL)
(eq (car entry) 'STRING-FILE-NAME))
(return (cadr (cadr entry)))))) ;flush QUOTE
(if faslread-object (faslreadclose faslread-object)))))
(declare (special MACSYMA-SOURCE-FILES))
(eval-when (eval compile)
(or (get 'defile 'version)
(load '((maxtul) defile))))
(defun merge-incore-system (&aux temp)
(load-info)
(merge-message-files `((DSK MAXDMP) INCORE >)
(mapcan #'(lambda (mfile)
(setq temp
(get-string-file-name
`((DSK ,(macsyma-source-file-fasl-dir mfile))
,(macsyma-source-file-name mfile) FASL)))
(if temp (ncons temp)))
(in-core-files macsyma-source-files))))
(setq ibase 10. base 10.)
(defun FASL-FILE-EXISTS-P (file)
(phi ((message-file (open-message-file file)))
(let* ((truename (truename message-file))
(fasl (mergef '((DNRF *) * FASL)
(cdr (assq 'output-file-name
(message-file-alist message-file)))))
(src (cdr (or (assq 'source-file-name
(message-file-alist message-file))
(assq 'filename
(message-file-alist message-file)))))
(home `((DNRF ,(get (cadr truename) 'fasl-dir))
,(cadr truename) FASL))
(src-fasl (mergef '((DNRF *) * FASL)
`(,(car src) ,(cadr src) FASL)))
(creator (cdr (assq 'creator (message-file-alist message-file)))))
(or (and fasl
(probef fasl)
(equal (get-string-file-name fasl) truename))
(and src
(not (equal home fasl))
(probef home)
(equal (get-string-file-name home) truename))
(and (not (equal src-fasl fasl))
(not (equal home home))
(probef src-fasl)
(equal (get-string-file-name src-fasl) truename))
(and creator
(setq creator `((DSK ,creator) ,(cadr truename) FASL))
(not (equal src-fasl creator))
(not (equal home creator))
(not (equal fasl creator))
(probef creator)
(equal (get-string-file-name creator) truename))))))
(defun display-string-files-no-fasls ()
(cursorpos 'c)
(format t "~&****** MAXERR; ******")
(mapc #'(lambda (file)
(if (not (fasl-file-exists-p
`((DSK MAXERR) ,(file-block-fn1 file)
,(file-block-fn2 file))))
(send file 'display)))
(file-directory-files (get-directory 'maxerr)))
(format T "~&****** MAXER1; ******")
(mapc #'(lambda (file)
(if (not (fasl-file-exists-p
`((DSK MAXER1) ,(file-block-fn1 file)
,(file-block-fn2 file))))
(send file 'display)))
(file-directory-files (get-directory 'maxer1)))
() )

60
src/maxtul/timepn.1 Executable file
View File

@@ -0,0 +1,60 @@
;;;-*-lisp-*-
(herald timepn)
(defun (timeprogn macro) (form)
(displace form
`(unwind-protect
(progn (time-origin 'push)
,@(cdr form))
(time-origin 'pop))))
(defvar last-gctime nil)
(defvar last-runtime nil)
(defvar last-realtime nil)
(defun time-origin (&optional (updatep nil)
(printp (not (eq updatep 'push))))
(let ((realtime (time))
(runtime (runtime))
(gctime (status gctime)))
(if
printp
(let ((rel-realtime (-$ realtime (car last-realtime)))
(rel-runtime (- runtime (car last-runtime)))
(rel-gctime (- gctime (car last-gctime))))
(format
msgfiles
"~&;~D.~3,'0D cpu sec. ~D% gc ~D.~D realtime (~D%)~:[ so far~]"
(// rel-runtime 1000000.)
(\ (// rel-runtime 1000.) 1000.)
(quotient (times 100. rel-gctime)
rel-runtime)
(ifix rel-realtime)
(\ (ifix (*$ 10.0 rel-realtime)) 10.)
(ifix (//$ (*$ 1.0e-4 (float rel-runtime))
rel-realtime))
updatep)))
(caseq updatep
(set
(setf (car last-realtime) realtime)
(setf (car last-gctime) gctime)
(setf (car last-runtime) runtime))
(push
(push realtime last-realtime)
(push gctime last-gctime)
(push runtime last-runtime))
(pop
(pop last-realtime)
(pop last-gctime)
(pop last-runtime)))))
(time-origin 'push)
(sstatus ttyint #^] #'(lambda (stream char)
(if (= char (tyipeek -1 stream))
(tyi stream))
(time-origin)))

26
src/maxtul/toolm.1 Executable file
View File

@@ -0,0 +1,26 @@
;;;-*-LISP-*-
;;; A macro for tooling up!
(herald toolm)
;;; The formal argument list of a DEFTOOLAGE has arguments which
;;; are atoms, meaning (s-exp . <variable>) or (<type> . <variable>)
;;; where the <type> is used by the command-argument-reader.
(defmacro deftoolage (name args &rest body &aux documents)
(do ()
((or (null (cdr body))
(not (atom (car body)))))
(push (pop body) documents))
`(progn 'compile
(defun (,name toolage)
,(mapcar #'(lambda (arg)
(if (atom arg) arg (cdr arg)))
args)
,@body)
(defprop ,name ,documents toolage-doc)
(defprop ,name ,args toolage-args)
(or (memq ',name toolage)
(setq toolage (nconc toolage '(,name))))))

431
src/rat/ratlap.10 Executable file
View File

@@ -0,0 +1,431 @@
; ** (c) Copyright 1981 Massachusetts Institute of Technology **
TITLE RATLAP
.FASL
.INSRT SYS:.FASL DEFS
; ALL ROUTINES EXPECT MODULUS TO BE EITHER NIL OR 2
; OR AN ODD NUMBER
; ALL ROUTINES EXCEPT CMOD EXPECT THEIR ARGUMENTS TO BE
; BETWEEN PLUS AND MINUS HMODULUS INCLUSIVE.
.BEGIN G9001
.ENTRY CMOD SUBR 0
SKIPN C,.SPECIAL MODULUS
POPJ P,
EXCH A,C
JSP T,NVSKIP
JRST MDBIGP
EXCH A,C
MOVE R,TT
JSP T,NVSKIP
JRST BIGMOD
CAIN R,2
JRST MOD2
IDIV TT,R
MODRET: MOVE F,R
LSH F,-1
MOVM TT,D
CAMLE TT,F
SUB TT,R
JUMPGE D,FIX1
MOVNS TT
JRST FIX1
BIGMOD: CAIN R,2
JRST MOD2A
PUSH FXP,R
MOVE B,C
CALL 2,.FUNCTION REMAINDER
MOVE TT,(A)
MOVE D,TT
POP FXP,R
JRST MODRET
MOD2A: HLRZ TT,(TT)
MOVE TT,(TT)
MOD2: ANDI TT,A
JRST FIX1
.ENTRY CPLUS SUBR 0
SKIPN C,.SPECIAL MODULUS
JCALL 2,.FUNCTION *PLUS
EXCH A,C
JSP T,NVSKIP
JRST CPLBIG
MOVE D,(B)
MOVE R,(C)
EXCH TT,R
CAIN R,2
JRST MOD2P
ADD D,TT
JRST MODRET
MOD2P: XOR TT,D
JRST MOD2
CPLBIG: EXCH A,C
CALL 2,.FUNCTION *PLUS
JRST MDBIG1
.ENTRY CTIMES SUBR 0
SKIPN C,.SPECIAL MODULUS
JCALL 2,.FUNCTION *TIMES
EXCH A,C
JSP T,NVSKIP
JRST BIGCTM
MOVE D,(B)
MOVE R,(C)
EXCH TT,R
CAIN R,2
JRST MOD2T
MUL TT,D
DIV TT,R
JRST MODRET
MOD2T: AND TT,D
JRST MOD2
BIGCTM: EXCH A,C
CALL 2,.FUNCTION *TIMES
JRST MDBIG1
.ENTRY CEXPT SUBR 0
SKIPN C,.SPECIAL MODULUS
JCALL 2,.FUNCTION EXPT
EXCH A,C
JSP T,NVSKIP
JRST BGCEXP
MOVE R,TT
EXCH A,B
JSP T,NVSKIP
JRST BGCEX2
MOVE D,TT
EXCH A,C
MOVE TT,(A)
TDNN TT,[-2 ]
POPJ P,
CAIN R,2
JRST MOD2
PUSH FXP,R
MOVE T,TT
MOVE F,D
MOVEI D,A
TRNE F,A
MOVE D,T
EXLOOP: LSH F,-1
JUMPE F,XRET
MUL T,T
DIV T,(FXP)
MOVE T,TT
TRNN F,A
JRST EXLOOP
MUL D,T
DIV D,(FXP)
MOVE D,R
JRST EXLOOP
XRET: POP FXP,R
JRST MODRET
BGCEX2: MOVE B,A
BGCEXP: MOVE A,C
CALL 2,.FUNCTION CBEXPT
JRST MDBIG1
.ENTRY CRECIP SUBR 0
MOVE B,.SPECIAL MODULUS
EXCH A,B
JSP T,NVSKIP
JRST INVBIG
MOVE D,(B)
EXCH TT,D
SKIPG TT
ADD TT,D
MOVEI T,
MOVEI F,A
PUSH FXP,D
LOOP: CAIN TT,A
JRST INVRET
JUMPE TT,ERR
IDIV D,TT
IMUL D,F
SUB T,D
EXCH T,F
MOVE D,TT
MOVE TT,R
JRST LOOP
INVRET: MOVE D,F
POP FXP,R
JRST MODRET
ERR: CALL 0,.FUNCTION TERPRI
MOVEI A,.ATOM INVERSE/ OF/ ZERO/ DIVISOR?
JCALL 1,.FUNCTION MERROR
MDBIGP: MOVE A,C
MDBIG1: MOVE B,.SPECIAL MODULUS
CALL 2,.FUNCTION REMAINDER
PUSH P,A
CALL 1,.FUNCTION ABS
MOVEI B,.ATOM #2
CALL 2,.FUNCTION *TIMES
MOVE B,.SPECIAL MODULUS
CALL 2,.FUNCTION *GREAT
JUMPE A,POPAJ
POP P,A
MOVE B,.SPECIAL MODULUS
SKIPL (A)
JCALL 2,.FUNCTION *DIF
JCALL 2,.FUNCTION *PLUS
INVBIG: EXCH A,B
PUSH P,A
PUSH P,B
SKIPGE (A)
CALL 2,.FUNCTION *PLUS
MOVEM A,-1(P)
INVB2: PUSH P,(P)
PUSH P,-2(P)
PUSH P,[.ATOM #0 ]
PUSH P,[.ATOM #1 ]
JSP T,NPUSH+-3
MOVEM A,-10(P)
JRST G0035
G0034: MOVE A,-5(P)
CALL 1,.FUNCTION ZEROP
JUMPN A,ERR
MOVE B,-5(P)
MOVE A,-6(P)
CALL 2,.FUNCTION *QUO
MOVE B,-5(P)
MOVEM A,-2(P)
CALL 2,.FUNCTION *TIMES
MOVE B,A
MOVE A,-6(P)
CALL 2,.FUNCTION *DIF
MOVE B,-2(P)
MOVEM A,(P)
MOVE A,-3(P)
CALL 2,.FUNCTION *TIMES
MOVE B,A
MOVE A,-4(P)
CALL 2,.FUNCTION *DIF
MOVE AR2A,-5(P)
MOVE AR1,(P)
MOVE C,-3(P)
MOVEM A,-1(P)
MOVEM A,-3(P)
MOVEM C,-4(P)
MOVEM AR1,-5(P)
MOVEM AR2A,-6(P)
G0035: MOVEI B,.ATOM #1
MOVE A,-5(P)
CALL 2,.FUNCTION EQUAL
JUMPE A,G0034
MOVE A,-3(P)
CALL 1,.FUNCTION CMOD
G0048: SUB P,[11,,11]
POPJ P,
.END G9001
.SXEVAL (AND (NCONC (SETQ PRD19 (QUOTE (#1 #2 #2 #4 #2 #4 #2 #4 #6 #2
#6 ))) (CDDDR PRD19 )) (QUOTE (THIS WAS THE LAP FOR RAT3D /34 DSK RJ
F )))
.BEGIN G9002
.ENTRY CFACTOR SUBR 0
PUSH P,A
JSP T,SPECBIND
.SPECIAL ANS
.SPECIAL K
PUSH P,[.ATOM #0 ]
PUSH P,[.ATOM #2 ]
SKIPE .SPECIAL $FACTORFLAG
JRST G3216
MOVEI A,.ATOM #1
CALL 1,.FUNCTION NCONS
MOVE B,-2(P)
CALL 2,.FUNCTION XCONS
JRST G3219
G3216: CALL 1,.FUNCTION FLOATP
JUMPE A,G3220
MOVEI A,.ATOM FACTOR/ GIVEN/ FLOATING/ ARG
CALL 1,.FUNCTION ERROR
JRST G3215
G3220: MOVE B,-2(P)
MOVEI A,.ATOM #0
CALL 2,.FUNCTION EQUAL
JUMPE A,G3222
MOVEI A,.ATOM #1
CALL 1,.FUNCTION NCONS
MOVEI B,.ATOM #0
CALL 2,.FUNCTION XCONS
JRST G3219
G3222: MOVEI B,.ATOM #-1
MOVE A,-2(P)
CALL 2,.FUNCTION EQUAL
JUMPE A,G3226
MOVEI A,.ATOM #1
CALL 1,.FUNCTION NCONS
MOVEI B,.ATOM #-1
CALL 2,.FUNCTION XCONS
JRST G3219
G3226: MOVE A,-2(P)
CALL 1,.FUNCTION MINUSP
JUMPE A,G3230
MOVE A,-2(P)
CALL 1,.FUNCTION MINUS
CALL 1,.FUNCTION CFACTOR
MOVEI B,.ATOM #1
CALL 2,.FUNCTION XCONS
MOVEI B,.ATOM #-1
CALL 2,.FUNCTION XCONS
JRST G3219
G3230: MOVEI B,.ATOM #2
MOVE A,-2(P)
CALL 2,.FUNCTION *LESS
JUMPE A,G3215
MOVEI A,.ATOM #1
CALL 1,.FUNCTION NCONS
MOVE B,-2(P)
CALL 2,.FUNCTION XCONS
JRST G3219
G3215: MOVE AR2A,.SPECIAL PRD19
MOVEM AR2A,.SPECIAL K
G3214: MOVE B,(P)
MOVE A,-2(P)
CALL 2,.FUNCTION REMAINDER
MOVE T,(A)
JUMPE T,WON
MOVE B,(P)
CAIN B,.ATOM #5
JRST G005
G3245: HLRZ A,@.SPECIAL K
CALL 2,.FUNCTION *PLUS
MOVEM A,(P)
SKIPE B,.SPECIAL $INTFACLIM
CALL 2,.FUNCTION *LESS
JUMPE A,FDONE
MOVE A,(P)
HRRZ B,@.SPECIAL K
MOVEM B,.SPECIAL K
MOVE B,A
CALL 2,.FUNCTION *TIMES
MOVE B,-2(P)
CALL 2,.FUNCTION *GREAT
JUMPE A,G3214
FDONE: MOVEI B,.ATOM #1
MOVE A,-2(P)
CALL 2,.FUNCTION *GREAT
JUMPE A,G3255
MOVE B,.SPECIAL ANS
MOVEI A,.ATOM #1
CALL 2,.FUNCTION CONS
MOVE B,-2(P)
CALL 2,.FUNCTION XCONS
JRST G3219
G3255: MOVE A,.SPECIAL ANS
G3219: SUB P,[3,,3]
JRST UNBIND
WON: MOVE A,-1(P)
CALL 1,.FUNCTION ADD1
MOVE B,(P)
MOVEM A,-1(P)
MOVE A,-2(P)
CALL 2,.FUNCTION *QUO
MOVEM A,-2(P)
MOVE B,(P)
CALL 2,.FUNCTION REMAINDER
MOVE T,(A)
JUMPE T,WON
GOTIN: MOVE B,.SPECIAL ANS
MOVEI A,.ATOM #0
EXCH A,-1(P)
CALL 2,.FUNCTION CONS
MOVE B,(P)
CALL 2,.FUNCTION XCONS
MOVEM A,.SPECIAL ANS
MOVE B,(P)
G005: MOVE A,-2(P)
CAIL B,.ATOM #5
JSP T,NVSKIP
JRST G3245
JRST GFAST
JRST G3245
GFAST: MOVE D,(B)
IDIVI D,36
IMULI D,36
GFASL: MOVE R,TT
IDIVI R,7(D)
SKIPN F
JSP B,GOT1
MOVE R,TT
IDIVI R,13(D)
SKIPN F
JSP B,GOT1
MOVE R,TT
IDIVI R,15(D)
SKIPN F
JSP B,GOT1
MOVE R,TT
IDIVI R,21(D)
SKIPN F
JSP B,GOT1
MOVE R,TT
IDIVI R,23(D)
SKIPN F
JSP B,GOT1
MOVE R,TT
IDIVI R,27(D)
SKIPN F
JSP B,GOT1
MOVE R,TT
IDIVI R,35(D)
SKIPN F
JSP B,GOT1
MOVE R,TT
IDIVI R,37(D)
SKIPN F
JSP B,GOT1
CAIG R,52(D)
JRST FDONE
ADDI D,36
JRST GFASL
GOT1: AOS -1(P)
MOVE TT,R
IDIVI R,@-3(B)
JUMPE F,GOT1
JSP T,FXCONS
MOVEM A,-2(P)
MOVEI TT,@-3(B)
JSP T,FXCONS
MOVEM A,(P)
JRST GOTIN
.END G9002
FASEND

37
src/rwk/lfsdef.39 Normal file
View File

@@ -0,0 +1,37 @@
; -*-MIDAS-*-
TITLE LISP ITS Filesystem definitions
.INSRT SYS:.FASL DEFS
.FASL
VERPRT LFSDEF
define DEFSYM /ARG
ARG
IRPW FUG,,[ARG]
IRPS x,y,[ FUG ]
DEFLSYM X,\<X>
.ISTOP
TERMIN
TERMIN
TERMIN
DEFINE DEFLSYM X,Y
IF2 [PRINTX |(DEFVAR FS-X #o!Y)
|
]
.SXEVAL (SETQ FS-X #<Y> )
.SXEVAL (COND ((STATUS FEATURE COMPLR)
(SPECIAL FS-X)))
TERMIN
.INSRT SYSENG;FSDEFS >
FASEND

116
src/rz/macros.47 Normal file
View File

@@ -0,0 +1,116 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module rzmac macro)
;;; *****************************************************************
;;; ***** MACROS ******* ASSORTED MACROS FOR GENERAL REPRESENTATION *
;;; *****************************************************************
(defmacro repeat (index limit . body)
`(do ((,index 0 (1+ ,index)))
((not (< ,index ,limit))) . ,body))
(defmacro logor frobs `(boole 7 . ,frobs))
(defmacro add-to-set (set frob)
`((lambda (temp)
(or (memq temp ,set)
(setq ,set (cons temp ,set))))
,frob))
#+ITS
(defmacro compiling ()
`(and (boundp 'compiler-state)
(not (eq compiler-state 'toplevel))))
#-ITS
(defmacro compiling nil t)
(defun *bind* macro (l)
((lambda (bindings body)
(nconc (list 'do (mapcar (fn (q)
(cond ((atom q)
(list q))
((eq (cadr q) '|<-|)
(list (car q) (caddr q)))
(t q)))
bindings)
nil)
(maplist (fn (x) (cond ((null (cdr x))
(cons 'return x))
((car x))))
body)))
(cadr l) (cddr l)))
(defmacro displace2 (form new-car new-cdr)
`(rplaca (rplacd ,form ,new-cdr) ,new-car))
;; Returns the negation of VALUE if PREDICATE is true. Otherwise, just
;; returns VALUE.
(defmacro negate-if (predicate value &aux (temp (gensym)))
`(let ((,temp ,predicate))
(cond (,temp (neg ,value))
(t ,value))))
(defmacro either (which first second)
`(cond (,which ,first) (,second)))
;; Setq's the first variable to VALUE if SWITCH is true, and sets the second
;; variable otherwise.
(defmacro set-either (first-var second-var switch value &aux (temp (gensym)))
`(let ((,temp ,value))
(cond (,switch (setq ,first-var ,temp))
(t (setq ,second-var ,temp)))))
(defmacro \* (&rest l) `(remainder . ,l))
(comment Symbolic Arithmetic Macros)
(defmacro m+ body `(add* . ,body))
(defmacro m* body `(mul* . ,body))
(defmacro m1+ (x) `(add* 1 ,x))
(defmacro m1- (x) `(add* -1 ,x))
(defmacro m// (a1 &optional (a2 nil 2args))
(cond (2args `(div* ,a1 ,a2))
(t `(inv* ,a1))))
(defmacro m- (a1 &optional (a2 nil 2args))
(cond (2args `(sub* ,a1 ,a2))
(t `(mul* -1 ,a1))))
(defmacro m^ (b e) `(power* ,b ,e))
(defmacro m+l (l) `(addn ,l nil))
(defmacro m*l (l) `(muln ,l nil))
;With
(defmacro m+t body `(add . ,body))
(defmacro m*t body `(mul . ,body))
(defmacro m1+t (x) `(add 1 ,x))
(defmacro m1-t (x) `(add -1 ,x))
(defmacro m//t (a1 &optional (a2 nil 2args))
(cond (2args `(div ,a1 ,a2))
(t `(inv ,a1))))
(defmacro m-t (a1 &optional (a2 nil 2args))
(cond (2args `(sub ,a1 ,a2))
(t `(neg ,a1))))
(defmacro m^t (b e) `(power ,b ,e))
(defmacro m+lt (l) `(addn ,l ,t))
(defmacro m*lt (l) `(muln ,l ,t))

121
src/z/fildir.34 Normal file
View File

@@ -0,0 +1,121 @@
;-*-LISP-*-
(eval-when (EVAL LOAD COMPILE)
(or (get 'DEFVST 'VERSION)
(load '((LISP) DEFVST)))
(or (get 'LFSDEF 'VERSION)
(load '((RWK) LFSDEF))))
(eval-when (eval compile)
(or (get 'IOTA 'VERSION)
(load '((LIBLSP) IOTA)))
(or (get 'UMLMAC 'VERSION)
(LOAD '((LISP) UMLMAC))))
(eval-when (eval load)
(or (get 'ERMSGC 'VERSION)
(load '((LIBMAX) ERMSGC))))
(defvst FILE-DIRECTORY
MACHINE
NAME
FILES)
(defvst FILE-BLOCK
FN1
FN2
RANDOM
DATE
RDATE)
(defmacro bp (bp)
(and (symbolp bp) (boundp bp) (setq bp (symeval bp)))
(if (fixnump bp)
(lsh bp -24.)
`(lsh ,bp -24.)))
(defmacro temp-array (idx)
`(arraycall fixnum temp-array ,idx))
(defvar temp-array (*array () 'fixnum 1024.))
(defun get-directory (name &optional (machine (STATUS SITE)))
(iota ((dir (mergef '((* *) |.FILE.| |(DIR)|)
`((,machine ,name) * *))
'(IN FIXNUM)))
(let ((ldir))
(dotimes (i 1024.)
(setf (temp-array i) (in dir)))
(setq ldir (cons-a-file-directory
NAME (sixbit-to-ascii (temp-array FS-UDNAME))
MACHINE machine))
(do ((i (temp-array FS-UDNAMP) (+ i FS-LUNBLK))
(files))
((> i 1023.) (setf (file-directory-files ldir)
(nreverse files)))
(IF (zerop (logand (lsh (temp-array (+ i FS-UNRNDM)) -18.)
(lsh FS-UNIGFL -18.)))
(push (CONS-A-FILE-BLOCK
FN1 (sixbit-to-ascii (temp-array (+ i fs-unfn1)))
FN2 (sixbit-to-ascii (temp-array (+ i fs-unfn2)))
RANDOM (temp-array (+ i fs-unrndm))
DATE (temp-array (+ i fs-undate))
RDATE (temp-array (+ i fs-unref)))
files)))
ldir)))
(defun date-to-ascii (date)
(format () "~D//~D//~D"
(ldb #o2704 date)
(ldb #o2205 date)
(ldb #o3307 date)))
(defun date-time-to-ascii (date)
(let* ((hours (// (logand #o777777 date) #.(* 60. 60. 2)))
(temp (\ (logand #o777777 date) #.(* 60. 60. 2)))
(minutes (// temp #.(* 60. 2)))
(temp (\ temp #.(* 60. 2)))
(seconds (// temp 2.)))
(format ()
"~A ~2D:~2,48D:~2,48D"
(date-to-ascii date)
hours minutes seconds)))
(defvar MFD-INDEX-ALIST () "ALIST of (mfd-index . dir-name)")
(defun get-mfd-indexes (&optional (machine (status site)))
(iota ((mfd `((,machine foo) |M.F.D.| |(FILE)|) '(IN FIXNUM)))
(dotimes (i 1024.)
(setf (temp-array i) (in mfd)))
(do ((i (temp-array fs-mdnamp) (+ i fs-lmnblk)))
((> i 1023.))
(declare (fixnum i))
(if (not (zerop (temp-array i)))
(progn
(putprop (sixbit-to-ascii (temp-array i))
(// (- i 24.) 2)
'MFD-INDEX)
(push `(,(// (- i 24.) 2) . ,(sixbit-to-ascii (temp-array i)))
MFD-INDEX-ALIST))))))
(defmethod* (display file-block-class) (self)
"Display a file"
(format T "~&~6A ~6A ~A (~A) (~A)"
(file-block-fn1 self)
(file-block-fn2 self)
(date-time-to-ascii (file-block-date self))
(date-to-ascii (logand (lsh -1 18.) (file-block-rdate self)))
(get-name-from-mfd-index (ldb (bp fs-unauth) (file-block-rdate self)))))
(defun get-name-from-mfd-index (idx)
(if (= idx #o777) '|???|
(cond ((cdr (assoc idx mfd-index-alist)))
(t '|???|))))
(defun display-files (files)
(cursorpos 'c)
(mapc #'(lambda (file) (send file 'display)) files)
())

2
tools/sims

Submodule tools/sims updated: c9d3833164...60ba615f94