perm filename FORLSP.LSP[DEN,LMM]1 blob
sn#034883 filedate 1973-04-14 generic text, type T, neo UTF8
(DEFPROP FORLSPFNS
(FORLSPFNS DEFLIST
RPLACNODE
MAKEMAKECOPY
REMOVEIS
RECORD
RECDO
REMOVEOF
COMPOSE
COMPOSE1
COMPOSE2
COMPOSE3
COMPOSE4
#CONS
#REPLACE
VARNAME
GONEXTN
PLUSSIGNTESTSET
PLUSSIGNPV
INITL
PLUSSIGNNEXT
*FOR
|
CONDIT
SETIT
NEGATE
*IF
THENCLAUSE
QUOTEIT1
QUOTEIT2
FOR
IF
REPLACE
FULLEXPANSION
DEFAULT
GSET
ADVISE
ADVISE1
SAVEFN1
ARGLIST
NARGS
FIRSTN)
VALUE)
(DEFPROP DEFLIST
(LAMBDA(L PROP)
(PROG (VAL)
LP (COND ((NULL L) (RETURN VAL)))
(PUTPROP (CAAR L) (CADAR L) PROP)
(SETQ VAL (CONS (CAAR L) VAL))
(SETQ L (CDR L))
(GO LP)))
EXPR)
(DEFPROP RPLACNODE
(LAMBDA(OLD NEW)
(PROG2 (RPLACA OLD (CAR NEW)) (RPLACD OLD (CDR NEW))))
EXPR)
(DEFPROP MAKEMAKECOPY
(LAMBDA(X)
(COND ((MEMQ (CAR X) (QUOTE (LIST COPY))) X)
((AND (EQ (CAR X) (QUOTE APPEND)) (CDDR X)) X)
(T (LIST (QUOTE APPEND) X NIL))))
EXPR)
(DEFPROP REMOVEIS
(LAMBDA(FORM)
(COND ((NULL FORM) NIL)
((EQ (CAR FORM) (QUOTE IS)) (REMOVEIS (CDR FORM)))
((EQ (CAR FORM) (QUOTE =)) (REMOVEIS (CDR FORM)))
(T (CONS (CAR FORM) (REMOVEIS (CDR FORM))))))
EXPR)
(DEFPROP RECORD
(LAMBDA(NAME FIELD)
(PROG NIL
(PUTPROP NAME FIELD (QUOTE RECORD))
(PUTPROP NAME
(LIST (QUOTE LAMBDA)
(QUOTE (RECORDVAR))
(LIST (QUOTE COMPOSE)
(QUOTE (REMOVEIS RECORDVAR))
(LIST (QUOTE QUOTE) FIELD)))
(QUOTE MACRO))
(RECDO FIELD (QUOTE X))))
EXPR)
(DEFPROP RECDO
(LAMBDA(FORMAT DEF)
(COND
((NULL FORMAT) NIL)
((NOT (ATOM FORMAT))
(RECDO (CAR FORMAT) (LIST (QUOTE CAR) DEF))
(RECDO (CDR FORMAT) (LIST (QUOTE CDR) DEF)))
(T
(PUTPROP
FORMAT
(LIST
(QUOTE LAMBDA)
(QUOTE (RECORDFIELDVAR))
(LIST
(QUOTE SUBST)
(QUOTE
(COND
((NULL (CDDR (SETQ RECORDFIELDVAR (REMOVEOF RECORDFIELDVAR))))
(CADR RECORDFIELDVAR))
(T (CDR RECORDFIELDVAR))))
(QUOTE (QUOTE X))
(LIST (QUOTE QUOTE) DEF)))
(QUOTE MACRO)))))
EXPR)
(DEFPROP REMOVEOF
(LAMBDA(L)
(COND ((NULL L) NIL)
((EQ (CAR L) (QUOTE OF)) (REMOVEOF (CDR L)))
(T (CONS (CAR L) (REMOVEOF (CDR L))))))
EXPR)
(DEFPROP COMPOSE
(LAMBDA(L FIELD)
(COND ((EQ (CADR L) (QUOTE FROM))
(COND ((ATOM (CADDR L)) (COMPOSE1 L FIELD (CADDR L)))
(T
(LIST (LIST (QUOTE LAMBDA)
(QUOTE (COMPOSEVAR))
(COMPOSE1 L FIELD (QUOTE COMPOSEVAR)))
(CADDR L)))))
(T (COMPOSE1 L FIELD (QUOTE COMPOSEVAR)))))
EXPR)
(DEFPROP COMPOSE1
(LAMBDA(L FIELD DEF)
(PROG (K)
(RETURN
(COND ((SETQ K (COMPOSE2 L FIELD DEF)) (CAR K))
(T (COMPOSE3 L FIELD DEF))))))
EXPR)
(DEFPROP COMPOSE2
(LAMBDA(L FIELD DEF)
(COND ((NULL FIELD) NIL)
((ATOM FIELD)
(COND ((GET L FIELD)
(LIST (SUBST DEF (QUOTE **) (GET L FIELD))))
(T NIL)))
((EQ (CAR FIELD) (QUOTE ID))
(LIST (LIST (QUOTE QUOTE) (CDR FIELD))))
(T
(PROG (KA KD)
(SETQ KD (COMPOSE2 L (CDR FIELD) (LIST (QUOTE CDR) DEF)))
(SETQ KA (COMPOSE2 L (CAR FIELD) (LIST (QUOTE CAR) DEF)))
(COND ((AND (NULL KA) (NULL KD)) (RETURN NIL)))
(RETURN
(LIST
(#CONS
(COND (KA (CAR KA))
(T
(COMPOSE1 L
(CAR FIELD)
(LIST (QUOTE CAR) DEF))))
(COND (KD (CAR KD))
(T
(COMPOSE1 L
(CDR FIELD)
(LIST (QUOTE CDR) DEF)))))))))))
EXPR)
(DEFPROP COMPOSE3
(LAMBDA(L FIELD DEF)
(COND ((EQ (QUOTE FROM) (CADR L)) DEF) (T (COMPOSE4 FIELD))))
EXPR)
(DEFPROP COMPOSE4
(LAMBDA(FIELD)
(COND ((NULL FIELD) NIL)
((ATOM FIELD)
((LAMBDA (X) (COND (X (LIST (QUOTE QUOTE) (COPY X))) (T NIL)))
(GET FIELD (QUOTE RECDEFAULT))))
(T (#CONS (COMPOSE4 (CAR FIELD)) (COMPOSE4 (CDR FIELD))))))
EXPR)
(DEFPROP #CONS
(LAMBDA(CARPART CDRPART)
(COND ((NOT CDRPART) (LIST (QUOTE LIST) CARPART))
((EQ (CAR CDRPART) (QUOTE LIST))
(CONS (QUOTE LIST) (CONS CARPART (CDR CDRPART))))
(T (LIST (QUOTE CONS) CARPART CDRPART))))
EXPR)
(DEFPROP #REPLACE
(LAMBDA(CARPART CDRPART)
(COND ((NULL CARPART) CDRPART)
((NULL CDRPART) CARPART)
((AND (EQ (CAR CARPART) (QUOTE RPLACA))
(EQ (CAR CDRPART) (QUOTE RPLACD))
(EQUAL (CADR CARPART) (CADR CDRPART)))
(LIST (QUOTE RPLACD) CARPART (CADDR CDRPART)))
(T (LIST (QUOTE PROG2) CARPART CDRPART))))
EXPR)
(DEFPROP VARNAME
(LAMBDA (VARNL) (LIST (QUOTE |) (CADR VARNL) (QUOTE VAR)))
MACRO)
(DEFPROP GONEXTN
(LAMBDA(DUMMY)
(QUOTE
(LIST (QUOTE GO)
(COND ((EQUAL N 1.) (QUOTE RETURN))
(T (| (QUOTE NEXT) (SUB1 N)))))))
MACRO)
(DEFPROP PLUSSIGNTESTSET
(LAMBDA(TSLS)
(LIST (QUOTE CAR)
(LIST (QUOTE SETQ)
(QUOTE TESTSET)
(LIST (QUOTE CONS) (CADR TSLS) (QUOTE TESTSET)))))
MACRO)
(DEFPROP PLUSSIGNPV
(LAMBDA(PVL)
(LIST (QUOTE CAR)
(LIST (QUOTE SETQ)
(QUOTE PV)
(LIST (QUOTE CONS) (CADR PVL) (QUOTE PV)))))
MACRO)
(DEFPROP INITL
(LAMBDA(INITLLS)
(LIST (QUOTE PROG1)
(LIST (QUOTE SETQ) (QUOTE TEM) (CADR INITLLS))
(LIST (QUOTE SETQ)
(QUOTE INIT)
(LIST (QUOTE CONS)
(LIST (QUOTE SETIT) (QUOTE TEM) (CADDR INITLLS))
(QUOTE INIT)))))
MACRO)
(DEFPROP PLUSSIGNNEXT
(LAMBDA(ITEMLIST)
(LIST (QUOTE CAR)
(LIST (QUOTE SETQ)
(QUOTE NEXT)
(LIST (QUOTE CONS) (CADR ITEMLIST) (QUOTE NEXT)))))
MACRO)
(DEFPROP *FOR
(LAMBDA(L)
(PROG (N FV
PV
EPILOGUE
PROLOGUE
DOFORM
DOTYPE
VAR
RANGE
LST
VARNEXT
NEXT
NEXTS
N2
N3
INIT
TESTSET
DOVAL
TEM)
(SETQ N 1.)
FORLOOP
(COND
((EQ (CAR L) (QUOTE NEW)) (PLUSSIGNPV (CAR (SETQ L (CDR L))))))
(SETQ VAR (CAR L))
(SETQ RANGE (CADDR L))
(PLUSSIGNNEXT (SETQ VARNEXT (VARNAME (QUOTE NEXT))))
(COND
((EQ (CADR L) (QUOTE IN))
(PLUSSIGNTESTSET
(CONDIT
(NEGATE
(INITL (PLUSSIGNPV (SETQ LST (VARNAME (QUOTE LIST))))
RANGE))
(GONEXTN)))
(PLUSSIGNTESTSET (SETIT VAR (LIST (QUOTE CAR) LST)))
(PLUSSIGNNEXT (SETIT LST (LIST (QUOTE CDR) LST))))
((EQ (CADR L) (QUOTE ON))
(PLUSSIGNTESTSET (CONDIT (NEGATE VAR) (GONEXTN)))
(PLUSSIGNNEXT
(SETIT (INITL VAR RANGE) (LIST (QUOTE CDR) VAR))))
((MEMB (CADR L) (QUOTE (:= ←)))
(SETQ
N2
(COND
((ATOM (CADR RANGE)) (CADR RANGE))
(T
(INITL (PLUSSIGNPV (VARNAME (QUOTE MAX))) (CADR RANGE)))))
(SETQ
N3
(COND
((CDDR RANGE)
(COND
((ATOM (CADDR RANGE)) (CADDR RANGE))
(T
(INITL (PLUSSIGNPV (VARNAME (QUOTE INC)))
(CADDR RANGE)))))
((AND (NUMBERP (CAR RANGE))
(NUMBERP (CADR RANGE))
(GREATERP (CAR RANGE) (CADR RANGE)))
-1.)
(T 1.)))
(INITL VAR (CAR RANGE))
(AND (NOT (MEMB N2 (QUOTE (∞ INFINITY))))
(PLUSSIGNTESTSET
(CONDIT
(COND
((NOT (NUMBERP N3))
(LIST
(QUOTE COND)
(LIST (LIST (QUOTE MINUSP) N3)
(LIST (QUOTE LESSP) VAR N2))
(LIST
T
(LIST (QUOTE OR)
(LIST (QUOTE ZEROP) N3)
(LIST (QUOTE GREATERP) VAR N2)))))
((MINUSP N3) (LIST (QUOTE LESSP) VAR N2))
(T (LIST (QUOTE GREATERP) VAR N2)))
(GONEXTN))))
(PLUSSIGNNEXT (SETIT VAR (LIST (QUOTE PLUS) VAR N3))))
((EQ (CADR L) (QUOTE IS)) (PLUSSIGNTESTSET (SETIT VAR RANGE)))
(T (ERROR "INVALID FOR TYPE")))
(SETQ L (CDDDR L))
ASLOOP
(COND
((EQ (CAR L) (QUOTE AS))
(SETQ L (CDR L))
(SETQ NEXTS (APPEND NEXTS NEXT))
(SETQ NEXT NIL)
(GO FORLOOP))
((MEMQ (CAR L) (QUOTE (IF WHEN)))
(PLUSSIGNTESTSET
(CONDIT (NEGATE (CADR L)) (LIST (QUOTE GO) VARNEXT)))
(SETQ L (CDDR L)))
((EQ (CAR L) (QUOTE UNTIL))
(PLUSSIGNNEXT (CONDIT (CADR L) (GONEXTN)))
(SETQ L (CDDR L)))
((EQ (CAR L) (QUOTE WHILE))
(PLUSSIGNTESTSET (CONDIT (NEGATE (CADR L)) (GONEXTN)))
(SETQ L (CDDR L)))
(T (GO FORTEST)))
(GO ASLOOP)
FORTEST
(SETQ PROLOGUE
(APPEND TESTSET (LIST (| (QUOTE LOOP) N)) INIT PROLOGUE))
(SETQ
EPILOGUE
(CONS
(| (QUOTE NEXT) N)
(APPEND
(REVERSE NEXT)
(REVERSE NEXTS)
(CONS (LIST (QUOTE GO) (| (QUOTE LOOP) N)) EPILOGUE))))
(SETQ TESTSET (SETQ INIT (SETQ NEXT (SETQ NEXTS NIL))))
(COND
((EQ (CAR L) (QUOTE FOR))
(SETQ L (CDR L))
(SETQ N (ADD1 N))
(GO FORLOOP)))
(SETQ DOTYPE (CAR L))
(SETQ DOVAL (CAR (LAST L)))
(PLUSSIGNPV (QUOTE FOR-VALUE))
(SETQ FV (QUOTE FOR-VALUE))
(SETQ
DOFORM
(COND
((EQ DOTYPE (QUOTE OR))
(CONDIT (SETIT (QUOTE FOR-VALUE) DOVAL)
(QUOTE (RETURN FOR-VALUE))))
((EQ DOTYPE (QUOTE AND))
(INITL (QUOTE FOR-VALUE) T)
(CONDIT (NEGATE (SETIT (QUOTE FOR-VALUE) DOVAL))
(QUOTE (RETURN NIL))))
((MEMQ DOTYPE (QUOTE (PROGN PROG2)))
(SETIT (QUOTE FOR-VALUE) DOVAL))
((EQ DOTYPE (QUOTE DO)) DOVAL)
(T
(SETIT
(QUOTE FOR-VALUE)
(COND
((EQ DOTYPE (QUOTE LIST))
(LIST (QUOTE NCONC)
(QUOTE FOR-VALUE)
(LIST (QUOTE LIST) DOVAL)))
((EQ DOTYPE (QUOTE NCONC))
(LIST (QUOTE NCONC) (QUOTE FOR-VALUE) DOVAL))
((EQ DOTYPE (QUOTE XLIST))
(LIST (QUOTE CONS) DOVAL (QUOTE FOR-VALUE)))
((EQ DOTYPE (QUOTE APPEND))
(LIST (QUOTE NCONC)
(QUOTE FOR-VALUE)
(MAKEMAKECOPY DOVAL)))
(T (LIST DOTYPE DOVAL (QUOTE FOR-VALUE))))))))
(COND
((EQ (CAR (SETQ L (CDR L))) (QUOTE FIRST))
(INITL (QUOTE FOR-VALUE) (CADR L))
(SETQ L (CDDR L)))
((MEMQ DOTYPE (QUOTE (PLUS IPLUS TIMES ITIMES MAX MIN)))
(INITL
(QUOTE FOR-VALUE)
(CDR
(ASSOC
DOTYPE
(QUOTE
((PLUS . 0.) (MAX . -99999.)
(MIN . 99999.)
(IPLUS . 0.)
(TIMES . 1.)
(ITIMES . 1.))))))))
(RETURN
(CONS
(QUOTE PROG)
(CONS
PV
(APPEND INIT
(REVERSE PROLOGUE)
(REVERSE (CDR (REVERSE L)))
(LIST DOFORM)
EPILOGUE
(LIST (QUOTE RETURN) (LIST (QUOTE RETURN) FV))))))))
EXPR)
(DEFPROP |
(LAMBDA(STR VAL)
(READLIST (NCONC (EXPLODE STR) (CONS (QUOTE *) (EXPLODE VAL)))))
EXPR)
(DEFPROP CONDIT
(LAMBDA (PRD DO) (LIST (QUOTE COND) (LIST PRD DO)))
EXPR)
(DEFPROP SETIT
(LAMBDA(VAR VAL)
(COND ((NOT (EQUAL VAR VAL)) (LIST (QUOTE SETQ) VAR VAL)) (T NIL)))
EXPR)
(DEFPROP NEGATE
(LAMBDA(EXP)
(COND ((MEMQ (CAR EXP) (QUOTE (NOT NULL))) (CADR EXP))
(T (LIST (QUOTE NOT) EXP))))
EXPR)
(DEFPROP *IF
(LAMBDA(L)
(COND (L
(CONS (CONS (CAR L)
(COND ((NOT (EQ (CADR L) (QUOTE THEN)))
(ERROR L
(QUOTE
"NO CORRESPONDING THEN IN IF")))
(T (SETQ L (CDDR L)) (THENCLAUSE))))
(COND ((NULL L) NIL)
((EQ (CAR L) (QUOTE ELSEIF)) (*IF (CDR L)))
((EQ (CAR (SETQ L (CDR L))) (QUOTE IF))
(*IF (CDR L)))
(T (LIST (CONS T (THENCLAUSE)))))))
(T NIL)))
EXPR)
(DEFPROP THENCLAUSE
(LAMBDA NIL
(COND ((OR (NULL L) (MEMQ (CAR L) (QUOTE (ELSE ELSEIF)))) (LIST NIL))
((OR (NOT (CDR L)) (MEMQ (CADR L) (QUOTE (ELSE ELSEIF))))
((LAMBDA (X Y) X) (LIST (CAR L)) (SETQ L (CDR L))))
(T (CONS (CAR L) (PROG2 (SETQ L (CDR L)) (THENCLAUSE))))))
EXPR)
(DEFPROP QUOTEIT1
(LAMBDA(X M)
(COND ((OR (NULL X) (NUMBERP X) (EQ X T)) X)
((SETQ M (QUOTEIT2 X M)) M)
(T (LIST (QUOTE QUOTE) X))))
EXPR)
(DEFPROP QUOTEIT2
(LAMBDA(X N)
(COND
((ATOM X) NIL)
((EQ (CAR X) (QUOTE ¬))
(COND
((ATOM (CDR X)) (CDR X))
((NULL (CDDR X)) (LIST (QUOTE LIST) (CADR X)))
(T
((LAMBDA(D E)
(COND
((EQ (CAR D) (QUOTE LIST))
(CONS (QUOTE LIST) (CONS E (CDR D))))
(T (LIST (QUOTE CONS) E D))))
(QUOTEIT1 (CDDR X))
(CADR X)))))
((NULL (CDR X))
(COND ((SETQ N (QUOTEIT2 (CAR X) N)) (LIST (QUOTE LIST) N))
(T NIL)))
(T
(PROG (M)
(SETQ M (QUOTEIT2 (CAR X) N))
(SETQ N (QUOTEIT2 (CDR X) N))
(COND ((AND (NULL M) (NULL N)) (RETURN NIL)))
(COND
((AND (NULL M)
(SETQ M (CAR X))
(NOT (NUMBERP M))
(NOT (EQ M T)))
(SETQ M (LIST (QUOTE QUOTE) M))))
(RETURN
(COND
((EQ (CAR N) (QUOTE LIST)) (CONS (CAR N) (CONS M (CDR N))))
(T
(LIST
(QUOTE CONS)
M
(COND
((AND (NULL N)
(SETQ N (CDR X))
(NOT (NUMBERP N))
(NOT (EQ N T)))
(LIST (QUOTE QUOTE) N))
(T N))))))))))
EXPR)
(DEFPROP FOR
(LAMBDA (FOR-EXPRESSION) (*FOR (CDR FOR-EXPRESSION)))
MACRO)
(DEFPROP IF
(LAMBDA (IF-EXPRESSION) (CONS (QUOTE COND) (*IF (CDR IF-EXPRESSION))))
MACRO)
(DEFPROP REPLACE
(LAMBDA(REPLACEXP)
(PROG (REPLACE1 REPLACE2)
(SETQ REPLACE1 (FULLEXPANSION (CADR REPLACEXP)))
(SETQ REPLACE2 (CADDR REPLACEXP))
(RETURN
(LIST (COND ((EQ (CAR REPLACE1) (QUOTE CAR)) (QUOTE RPLACA))
((EQ (CAR REPLACE1) (QUOTE CDR)) (QUOTE RPLACD))
(ERROR (QUOTE "REPLACE CAN'T")
(LIST REPLACE1 REPLACE2)))
(CADR REPLACE1)
REPLACE2))))
MACRO)
(DEFPROP FULLEXPANSION
(LAMBDA(X)
(COND ((MEMQ (CAR X)
(QUOTE
(CAAR CADR
CDAR
CDDR
CDDAR
CDDDR
CDDDAR
CDDDDR
CADDAR
CADDDR
CADAR
CADDR
CDADAR
CDADDR
CAADAR
CAADDR
CDAAR
CDADR
CDDAAR
CDDADR
CADAAR
CADADR
CAAAR
CAADR
CDAAAR
CDAADR
CAAAAR
CAAADR)))
(LIST (READLIST
(LIST (QUOTE C) (CADR (EXPLODE (CAR X))) (QUOTE R)))
(LIST (READLIST
(CONS (QUOTE C) (CDDR (EXPLODE (CAR X)))))
(CADR X))))
((GET (CAR X) (QUOTE MACRO))
(FULLEXPANSION (APPLY (GET (CAR X) (QUOTE MACRO)) (LIST X))))
(T X)))
EXPR)
(DEFPROP DEFAULT
(LAMBDA (FIELD VALUE) (DEFLIST (LIST VALUE) (QUOTE RECDEFAULT)))
EXPR)
(DEFPROP GSET
(LAMBDA(VAR VAL)
(PROG2 (COND ((GET VAR (QUOTE SPECIAL))) (T (SPECIAL (LIST VAR))))
(SET VAR VAL)))
EXPR)
(DEFPROP ADVISE
(LAMBDA(FN WHEN WHAT)
(PUTPROP
FN
(LIST (QUOTE LAMBDA)
(ARGLIST FN)
(LIST (QUOTE PROG)
(CONS (QUOTE !VALUE)
(COND ((EQ WHEN (QUOTE BIND)) WHAT) (T NIL)))
(LIST (QUOTE SETQ)
(QUOTE !VALUE)
(LIST (QUOTE PROG)
NIL
(COND ((EQ WHEN (QUOTE BEFORE)) WHAT)
(T NIL))
(LIST (QUOTE RETURN)
(SAVEFN1 FN (ARGLIST FN)))))
(COND ((EQ WHEN (QUOTE AFTER)) WHAT) (T NIL))
(QUOTE (RETURN !VALUE))))
(QUOTE EXPR)))
EXPR)
(DEFPROP ADVISE1
(LAMBDA(FN WHEN ARGLIST WHAT)
(PUTPROP
FN
(LIST (QUOTE LAMBDA)
ARGLIST
(LIST (QUOTE PROG)
(CONS (QUOTE !VALUE)
(COND ((EQ WHEN (QUOTE BIND)) WHAT) (T NIL)))
(LIST (QUOTE SETQ)
(QUOTE !VALUE)
(LIST (QUOTE PROG)
NIL
(COND ((EQ WHEN (QUOTE BEFORE)) WHAT)
(T NIL))
(LIST (QUOTE RETURN) (SAVEFN1 FN ARGLIST))))
(COND ((EQ WHEN (QUOTE AFTER)) WHAT) (T NIL))
(QUOTE (RETURN !VALUE))))
(QUOTE EXPR)))
EXPR)
(DEFPROP SAVEFN1
(LAMBDA(FN ARGLIST)
(PROG (AT)
(SETQ AT (INTERN (GENSYM)))
(COND ((GET FN (QUOTE EXPR))
(PUTPROP AT (GET FN (QUOTE EXPR)) (QUOTE EXPR)))
((GET FN (QUOTE SUBR))
(PUTPROP AT (GET FN (QUOTE SUBR)) (QUOTE SUBR))))
(RETURN (CONS AT ARGLIST))))
EXPR)
(DEFPROP ARGLIST
(LAMBDA(FN)
(FIRSTN (QUOTE (ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9 ARG10))
(NARGS FN)))
EXPR)
(DEFPROP NARGS
(LAMBDA(FN)
(COND ((GET FN (QUOTE EXPR)) (LENGTH (CADR (GET FN (QUOTE EXPR)))))
(T 5.)))
EXPR)
(DEFPROP FIRSTN
(LAMBDA(L N)
(COND ((EQUAL N 0.) NIL)
(T (CONS (CAR L) (FIRSTN (CDR L) (SUB1 N))))))
EXPR)