Lisp Macros#

General Information

Author: Datasoft
Language: LISP
Compiler/Interpreter: InterLisp/65

(FUNCALL DEFPROP PUTPROP NCONC GET MAPCAR EQUAL DELETE SUBST REVERSE REMPROP CONZ GENSYM DEFUN MACFNS)
(DEFINEQ FUNCALL '(MACRO (S) (CONS (QUOTE APPLY*) (CDR S)))
)
(DEFINEQ DEFPROP '(NLAMBDA (A) ((LAMBDA (ID PROP NAME) (PROGN (COND ((ASSOC NAME MACFNS) (DEFINE ID (CONS (CAR (CDR (ASSOC NAME MACFNS))) (CDR PROP)))) ((EQ (EVAL ID)) (SET ID (LIST NAME PROP))) (T (SET ID (CONS NAME (CONS PROP (EVAL ID)))))) ID)) (CAR A) (CAR (CDR A)) (CAR (CDR (CDR A)))))
)
(DEFINEQ PUTPROP '(LAMBDA (ID PROP NAME) (PROGN (COND ((ASSOC NAME MACFNS) (DEFINE ID (CONS (CAR (CDR (ASSOC NAME MACFNS))) (CDR PROP)))) ((EQ (EVAL ID)) (SET ID (LIST NAME PROP))) (T (SET ID (CONS NAME (CONS PROP (EVAL ID)))))) ID))
)
(DEFINEQ NCONC '(LAMBDA (X Y) (PROGN (RPLACD (LAST X) Y) X))
)
(DEFINEQ GET '(LAMBDA (ID NAME) (COND ((ASSOC NAME MACFNS) (CONS (QUOTE LAMBDA) (CDR (GETD ID)))) ((CAR (CDR (MEMBER NAME (EVAL ID)))))))
)
(DEFINEQ MAPCAR '(LAMBDA (X FN) (COND ((EQ X) NIL) (T (CONS (APPLY* FN (CAR X)) (MAPCAR (CDR X) FN)))))
)
(DEFINEQ EQUAL '(LAMBDA (X Y) (COND ((ATOM X) (EQ X Y)) ((ATOM Y) (EQ X Y)) ((AND (EQUAL (CAR X) (CAR Y)) (EQUAL (CDR X) (CDR Y))))))
)
(DEFINEQ DELETE '(LAMBDA (X Y) (COND ((EQ Y) NIL) ((EQUAL X (CAR Y)) (DELETE X (CDR Y))) ((CONZ Y (CAR Y) (DELETE X (CDR Y))))))
)
(DEFINEQ SUBST '(LAMBDA (X Y Z) (COND ((EQUAL Y Z) X) ((ATOM Z) Z) ((CONS (SUBST X Y (CAR Z)) (SUBST X Y (CDR Z))))))
)
(DEFINEQ REVERSE '(LAMBDA (X) (COND ((ATOM X) X) ((APPEND (REVERSE (CDR X)) (LIST (CAR X))))))
)
(DEFINEQ REMPROP '(LAMBDA (ID NAME) (COND ((ASSOC NAME MACFNS) (DEFINE ID NIL) ID) (T ((LAMBDA (Y) (COND ((EQ Y) Y) (T ((LAMBDA (Z) (CONZ Z (CAR (CDR Z)) (CDR (CDR Z)))) (DELETE (CAR (CDR Y)) Y)) ID))) (MEMBER NAME (EVAL ID))))))
)
(DEFINEQ CONZ '(LAMBDA (X Y Z) (RPLACA (RPLACD X Z) Y))
)
(DEFINEQ GENSYM '(LAMBDA NIL (PACK (CONS (QUOTE G0) (RPLACA (QUOTE (0)) (+ (CAR (CAR (CDR (CAR (CDR (CAR (CDR (CDR (CAR (CDR (CAR (CDR (CDR (GETD (QUOTE GENSYM))))))))))))))) 1)))))
)
(DEFINEQ DEFUN '(MACRO (S) (CONS (QUOTE DEFPROP) (CONS (CAR (CDR S)) ((LAMBDA (X) (COND ((ASSOC X MACFNS) (LIST (CONS (QUOTE LAMBDA) (CDR (CDR (CDR S)))) X)) ((LIST (CONS (QUOTE LAMBDA) (CDR (CDR S))) (QUOTE EXPR))))) (CAR (CDR (CDR S)))))))
)
(SETQ MACFNS '((EXPR LAMBDA) (FEXPR NLAMBDA) (MACRO MACRO))
)
NIL