mirror of
https://github.com/PDP-10/its.git
synced 2026-03-02 01:50:24 +00:00
285 lines
9.1 KiB
Common Lisp
285 lines
9.1 KiB
Common Lisp
;;;;;;;;;;;;;;;;;;; -*- 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.
|
||
|
||
|