mirror of
https://github.com/PDP-10/its.git
synced 2026-03-02 09:56:20 +00:00
40 lines
1.4 KiB
Common Lisp
Executable File
40 lines
1.4 KiB
Common Lisp
Executable File
|
|
;;; -*-LISP-*-
|
|
|
|
;;; Purpose: to permit long names, like CADADADADDDR, to be easily
|
|
;;; macro-defined into appropriate sequences of CARs and CDRs.
|
|
;;; Use: (DEF-CARCDR CADADADADDDR CADADADDDDDR ... )
|
|
;;; where the names must have at least 5 A/D's.
|
|
|
|
;;; Produces a format internal to the compiler when being expanded
|
|
;;; for optimal compilation. For interpretation, produces a
|
|
;;; LAMBDA form with a composition of initial carcdr functions
|
|
;;; of up to 4 deep, which should be (already) defined primitively.
|
|
|
|
|
|
|
|
(DEFMACRO DEF-CARCDR L
|
|
`(PROGN 'COMPILE
|
|
,@(mapcar '(lambda (x) `(DEFPROP ,x C*R MACRO)) l)))
|
|
|
|
(DEFUN C*R (X)
|
|
(DECLARE (SPECIAL CARCDR)) ;Gets the complr's CARCDR variable
|
|
(LET (((NAME ARG1 . L) X))
|
|
(AND L (ERROR '|Extra args in call to C*R macro| X 'WRNG-NO-ARGS))
|
|
(AND (OR (< (LENGTH (SETQ L (EXPLODEC NAME))) 7)
|
|
(NOT (EQ (CAR L) 'C))
|
|
(NOT (EQ (CAR (SETQ L (NREVERSE (CDR L)))) 'R))
|
|
(DO L (SETQ L (NREVERSE (CDR L))) (CDR L) (NULL L)
|
|
(AND (NOT (MEMQ (CAR L) '(A D))) (RETURN 'T))))
|
|
(ERROR '|Invalid name for C*R macro| X 'WRNG-TYPE-ARG))
|
|
`(,(COND ((EQ COMPILER-STATE 'COMPILE) `(,carcdr ,@(nreverse l)))
|
|
(`(LAMBDA (X) ,(|c*r-expander/|| l 'X))))
|
|
,arg1)))
|
|
|
|
(DEFUN |c*r-expander/|| (L ARG)
|
|
(COND ((< (LENGTH L) 5) `(,(implode (nconc (list 'C) l '(R))) ,arg))
|
|
((LET* ((/3TAIL (NTHCDR 3 L)) (/4TAIL (CDR /3TAIL)))
|
|
(RPLACD /3TAIL () )
|
|
(|c*r-expander/|| L (|c*r-expander/|| /4TAIL ARG))))))
|
|
|