;;;;;;;;;;;;;;;;;;; -*- 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.