(setq |SCCS-machacks| "@(#)machacks.l 1.2 11/7/80") ;; machacks - maclisp compatibility package. ;; When this file is fasl'ed into a lisp, it will change the syntax to ;; maclisp's syntax and will define functions know to the standard maclisp. ; ; this file will be fasled whenever the -m switch is set for compilation. ; (declare (macros t)) ;-- macsyma-env ; This really isn't part of the maclisp compatibility package but we put ; it here to allow us to bootstrap the macsyma macro packages. ; (def macsyma-env ; put at the beginning of each macsyma file (macro (l) `(include |libmax//prelud.l|))) (def coutput (lambda (msg) (print msg) ; should go to unfasl port (terpr))) ;--- displace ; This is useful after a macro has been expanded and you want to save the ; interpreter the trouble of expanding the macro again. ; [This is really only useful for interpretation] (defun displace (old-form new-form) (cond ((atom old-form) (error '|Not able to displace this form| old-form)) ((atom new-form) (rplaca old-form 'progn) (rplacd old-form (list new-form))) (t (rplaca old-form (car new-form)) (rplacd old-form (cdr new-form))))) ;--- caseq ; use is ; (caseq expr ; (match1 do1) ; (match2 do2) ; (t doifallelsefails)) (def caseq (macro (form) ((lambda (x) `((lambda (,x) (cond ,@(mapcar '(lambda (ff) (cond ((eq (car ff) 't) `(t ,(cadr ff))) (t `((eq ,x ',(car ff)) ,(cadr ff))))) (cddr form)))) ,(cadr form))) (gensym 'Z)))) ;A winning macro to store things anywhere: (stolen from AI:ALAN;LSPENV) ;(SETF (CADR X) 3) --> (RPLACA (CDR X) 3) (DEFMACRO SETF (EXPR VAL) (COND ((ATOM EXPR) (OR (SYMBOLP EXPR) (ERROR '|-- SETF can't handle this.| EXPR)) `(SETQ ,EXPR ,VAL)) (T (DO ((Y)) (()) (OR (SYMBOLP (CAR EXPR)) (ERROR '|-- SETF can't handle this.| EXPR)) (AND (SETQ Y (GET (CAR EXPR) 'SETF-EXPAND)) (RETURN (FUNCALL Y EXPR VAL))) (OR (SETQ Y (GET (CAR EXPR) 'MACRO)) (ERROR '|-- SETF can't handle this.| EXPR)) (SETQ EXPR (FUNCALL Y EXPR)))))) (DEFMACRO DEFSETF (NAME VARS &REST BODY) `(DEFPROP ,NAME (LAMBDA ,VARS . ,BODY) SETF-EXPAND)) (DEFSETF CAR (E V) `(RPLACA ,(CADR E) ,V)) (DEFSETF CAAR (E V) `(RPLACA (CAR ,(CADR E)) ,V)) (DEFSETF CADR (E V) `(RPLACA (CDR ,(CADR E)) ,V)) (DEFSETF CAAAR (E V) `(RPLACA (CAAR ,(CADR E)) ,V)) (DEFSETF CADAR (E V) `(RPLACA (CDAR ,(CADR E)) ,V)) (DEFSETF CAADR (E V) `(RPLACA (CADR ,(CADR E)) ,V)) (DEFSETF CADDR (E V) `(RPLACA (CDDR ,(CADR E)) ,V)) (DEFSETF CAAAAR (E V) `(RPLACA (CAAAR ,(CADR E)) ,V)) (DEFSETF CADAAR (E V) `(RPLACA (CDAAR ,(CADR E)) ,V)) (DEFSETF CAADAR (E V) `(RPLACA (CADAR ,(CADR E)) ,V)) (DEFSETF CADDAR (E V) `(RPLACA (CDDAR ,(CADR E)) ,V)) (DEFSETF CAAADR (E V) `(RPLACA (CAADR ,(CADR E)) ,V)) (DEFSETF CADADR (E V) `(RPLACA (CDADR ,(CADR E)) ,V)) (DEFSETF CAADDR (E V) `(RPLACA (CADDR ,(CADR E)) ,V)) (DEFSETF CADDDR (E V) `(RPLACA (CDDDR ,(CADR E)) ,V)) (DEFSETF CDR (E V) `(RPLACD ,(CADR E) ,V)) (DEFSETF CDAR (E V) `(RPLACD (CAR ,(CADR E)) ,V)) (DEFSETF CDDR (E V) `(RPLACD (CDR ,(CADR E)) ,V)) (DEFSETF CDAAR (E V) `(RPLACD (CAAR ,(CADR E)) ,V)) (DEFSETF CDDAR (E V) `(RPLACD (CDAR ,(CADR E)) ,V)) (DEFSETF CDADR (E V) `(RPLACD (CADR ,(CADR E)) ,V)) (DEFSETF CDDDR (E V) `(RPLACD (CDDR ,(CADR E)) ,V)) (DEFSETF CDAAAR (E V) `(RPLACD (CAAAR ,(CADR E)) ,V)) (DEFSETF CDDAAR (E V) `(RPLACD (CDAAR ,(CADR E)) ,V)) (DEFSETF CDADAR (E V) `(RPLACD (CADAR ,(CADR E)) ,V)) (DEFSETF CDDDAR (E V) `(RPLACD (CDDAR ,(CADR E)) ,V)) (DEFSETF CDAADR (E V) `(RPLACD (CAADR ,(CADR E)) ,V)) (DEFSETF CDDADR (E V) `(RPLACD (CDADR ,(CADR E)) ,V)) (DEFSETF CDADDR (E V) `(RPLACD (CADDR ,(CADR E)) ,V)) (DEFSETF CDDDDR (E V) `(RPLACD (CDDDR ,(CADR E)) ,V)) (DEFSETF CXR (E V) `(RPLACX ,(CADR E) ,(CADDR E) ,V)) (DEFSETF NTH (E V) `(RPLACA (NTHCDR ,(CADR E) ,(CADDR E)) ,V)) (DEFSETF ARRAYCALL (E V) `(STORE ,E ,V)) (DEFSETF GET (E V) `(PUTPROP ,(CADR E) ,V ,(CADDR E))) (DEFSETF PLIST (E V) `(SETPLIST ,(CADR E) ,V)) (DEFSETF SYMEVAL (E V) `(SET ,(CADR E) ,V)) (DEFSETF ARG (E V) `(SETARG ,(CADR E) ,V)) (DEFSETF ARGS (E V) `(ARGS ,(CADR E) ,V)) (DEFSETF SFA-GET (E V) `(SFA-STORE ,(CADR E) ,(CADDR E) ,V)) (DEFSETF EXAMINE (E V) `(DEPOSIT ,(CADR E) ,V)) (defmacro list* (&rest forms) (cond ((null forms) nil) ((null (cdr forms)) (car forms)) (t (construct-list* forms)))) (defmacro ttf (&rest l) `(list* . , l)) (defun construct-list* (forms) (setq forms (reverse forms)) (do ((forms (cddr forms) (cdr forms)) (return-form `(cons ,(cadr forms) ,(car forms)) `(cons ,(car forms) ,return-form))) ((null forms) return-form))) ;; lexpr-funcall is a cross between apply and funcall. The last arguments ;; is a list of the rest of the arguments (defmacro lexpr-funcall (func &rest args) `(apply ,func (list* ,@args))) ; contents of the file libmax;macros all of these functions are ; (by default) in maclisp ;; (IF X P Q1 Q2 ...) --> (COND (X P) (T Q1 Q2 ...)) ;; It is important that (IF NIL