perm filename CONVRT.LSP[P,BGB] blob
sn#009282 filedate 1974-04-16 generic text, type T, neo UTF8
00100 (PUTPROP @DIFFERENCE (GET @*DIF @SUBR) @SUBR)
00200
00300 (PUTPROP @SASSQ (GET @SASSOC @SUBR) @SUBR)
00400
00500 (PUTPROP @MAPC# (GET @MAPC @SUBR) @SUBR)
00600
00700 (PUTPROP @MAPCAR# (GET @MAPCAR @SUBR) @SUBR)
00800
00900 (PUTPROP @ASSQ (GET @ASSOC @SUBR) @SUBR)
01000
01100 (PUTPROP @PUTPROP1 (GET @PUTPROP @SUBR) @SUBR)
01200
01300 (PUTPROP @APPLY# (GET @APPLY @LSUBR) @LSUBR)
01400
01500 (PUTPROP (QUOTE THPUSH)
01600 (QUOTE (LAMBDA (A) (LIST (QUOTE SETQ)
01700 (CADR A)
01800 (LIST (QUOTE CONS) (CADDR A) (CADR A)))))
01900 (QUOTE MACRO))
02000
02100 (PUTPROP (QUOTE THTRACE)
02200 (QUOTE (LAMBDA (L)
02300 (PROG NIL
02400 (DSKIN (P RPO) (THTRAC./13))
02500 (REMPROP (QUOTE THTRACE) (QUOTE MACRO))
02600 (RETURN (LIST (QUOTE QUOTE)(EVAL L))))))
02700 (QUOTE MACRO))
02800
02900 (PUTPROP (QUOTE THEOREM) T (QUOTE SWAPIT))
03000
03100 (SETQ THTRACE NIL)
03200
03300
03400 (OR (GETL @THERT @(FSUBR FEXPR))(DF THERT (L) NIL)))
03500
03600 (DF DECLARE (L)NIL))
03700
03800 (DECLARE (*FEXPR LAMBDA# SSTATUS DEFUN DECLARE GENPREFIX ERT THERT))
03900 (DECLARE (*EXPR SPRINT))
04000
04100 (SETQ PURE NIL)
04200
04300 (SETQ ERRLIST NIL)
00100 (DEFPROP MAPCAR (LAMBDA L
00200 (COND ((GREATERP L 3)(PRINT @(MAPCAR OF 3 ARG LISTS))(ERR))
00300 ((EQUAL L 2)(MAPCAR# (ARG 1)(ARG 2)))
00400 (T (COND ((OR (NULL (ARG 2))(NULL (ARG 3)))NIL)
00500 (T (CONS ((ARG 1)(CAR (ARG 2))(CAR (ARG 3)))
00600 (MAPCAR (ARG 1)(CDR (ARG 2))(CDR (ARG 3)))))))))EXPR)
00700
00800 (DF ERT (L) (APPLY (QUOTE THERT) L)))
00900
01000 (DE ASSOC (A L)
01100 (COND ((NULL L) NIL)
01200 ((EQUAL A (CAAR L))(CAR L))
01300 (T (ASSOC A (CDR L)))))
01400
01500 (DEFPROP PAGEBPORG (LAMBDA () NIL)EXPR)
01600
01700 (DEFPROP GENPREFIX (LAMBDA (L) NIL) FEXPR)
01800
01900 (DEFPROP MIN (LAMBDA N
02000 (PROG (V)
02100 (SETQ V (ARG N))
02200 A (SETQ N(SUB1 N))
02300 (COND ((ZEROP N)(RETURN V))
02400 ((LESSP (ARG N) V) (SETQ V (ARG N))))
02500 (GO A)))EXPR)
02600
02700 (DEFPROP MAX (LAMBDA N
02800 (PROG (V )
02900 (SETQ V (ARG N))
03000 A (SETQ N(SUB1 N))
03100 (COND ((ZEROP N)(RETURN V))
03200 ((GREATERP (ARG N) V)(SETQ V (ARG N))))
03300 (GO A)))EXPR)
03400
03500 (DEFPROP RANDOM (LAMBDA ()
03600 (QUOTIENT (TIMES (EXAMINE 15)(EXAMINE 16) ) (MAX (EXAMINE 15)(EXAMINE 16)))
03700 )EXPR)
03800
03900 (DEFPROP DEFUN
04000 (LAMBDA (L)
04100 (COND ((AND(ATOM (CADR L))(NOT(NULL (CADR L))))
04200 (PUTPROP (CAR L)
04300 (APPEND @(LAMBDA)
04400 (LIST (CADDR L))
04500 (COND ((GREATERP (LENGTH (CDDDR L)) 1)
04600 (LIST (APPEND @(PROG NIL)
04700 (COND (T (RPLACA (LAST(CDDDR L))
04800 (LIST @RETURN (CAR(LAST(CDDDR L)))))
04900 (CDDDR L))))))
05000 (T (CDDDR L))))
05100 (CADR L))
05200 (CAR L))
05300 (T
05400 (PUTPROP (CAR L)
05500 (APPEND @(LAMBDA)
05600 (LIST (CADR L))
05700 (COND ((GREATERP (LENGTH (CDDR L)) 1)
05800 (LIST(APPEND @(PROG NIL)
05900 (COND (T (RPLACA (LAST(CDDR L))
06000 (LIST @RETURN (CAR(LAST(CDDR L)))))
06100 (CDDR L))))))
06200 (T (CDDR L))))
06300 (QUOTE EXPR))
06400 (CAR L))))FEXPR)
06500
06600
06700
06800 (DEFPROP SSTATUS (LAMBDA (L)(QUOTE SSTATUS))FEXPR)
06900
07000 (DEFPROP AND (LAMBDA (L)
07100 (AND# (CDR L))) MACRO)
07200
07300 (DEFPROP AND# (LAMBDA (L)
07400 (COND ((NULL (CDR L))(LIST (QUOTE COND)(LIST (CAR L))))
07500 (T (LIST (QUOTE COND)(LIST (CAR L)(AND# (CDR L)))))))EXPR)
07600
07700 (DEFPROP OR (LAMBDA (L)
07800 (OR# (CDR L)))
07900 MACRO)
08000
08100 (DEFPROP OR# (LAMBDA (L)
08200 (APPEND (QUOTE (COND))(MAPCAR (FUNCTION LIST) L)))
08300 EXPR)
08400
08500
08600
08700
08800 (DEFPROP LAMBDA# (LAMBDA (L) (COND (T (PRINT @LAMBDA#CALLED)
08900 (LIST (QUOTE COND) (CONS (QUOTE T) (CDR L)))))) FEXPR)
09000
09100 (DEFPROP MAPC (LAMBDA L
09200 (COND ((GREATERP L 4)(PRINT @(MAPC OF FOUR ARG LISTS))(ERR))
09300 ((EQUAL L 2)(MAPC# (ARG 1)(ARG 2)) (ARG 2) )
09400 ((EQUAL L 3)
09500 (PROG (A B)
09600 (SETQ A (ARG 2))(SETQ B (ARG 3))
09700 L1 (AND (OR (NULL A)(NULL B))(RETURN (ARG 2)) )
09800 ((ARG 1)(CAR A)(CAR B))
09900 (SETQ A (CDR A))(SETQ B (CDR B))
10000 (GO L1 )))
10100 (T (PROG (A B C) (SETQ A (ARG 2))(SETQ B (ARG 3))(SETQ C(ARG 4))
10200 L1 (AND (OR (NULL A)(NULL B)(NULL C))(RETURN (ARG 2)))
10300 ((ARG 1)(CAR A)(CAR B)(CAR C))
10400 (SETQ A(CDR A))(SETQ B (CDR B))(SETQ C(CDR C))
10500 (GO L1)))))EXPR)
10600
10700 (DECLARE (SPECIAL R F L))
10800
10900 (DEFPROP MAPCAN
11000 (LAMBDA(F L)
11100 (PROG (R)
11200 (MAPC(FUNCTION (LAMBDA(X)(SETQ R(NCONC R (F X)))))L)
11300 (RETURN R)))
11400 EXPR)
11500
11600 (DECLARE (UNSPECIAL R F L))
11700
11800 (DECLARE (SPECIAL ERRLIST))
11900
12000 (DEFPROP RESTART
12100 (LAMBDA NIL (PROG NIL (MAPC (FUNCTION EVAL) ERRLIST) (RETURN @EXIT) ))
12200 EXPR)
12300
12400 (DECLARE (UNSPECIAL ERRLIST))
12500
12600 (DEFPROP MEMQ (LAMBDA (E L)
12700 (COND ((NULL L) NIL)
12800 ((NOT (ATOM (CAR L)))(MEMQ E (CDR L)))
12900 ((EQ E (CAR L)) L)
13000 (T (MEMQ E (CDR L)))))EXPR)
13100
13200 (DEFPROP MEMBER (LAMBDA (E L)
13300 (COND ((NULL L) NIL)
13400 ((EQUAL E (CAR L)) L)
13500 (T (MEMBER E (CDR L)))))EXPR)
13600
13700
13800 (DEFPROP APPLY (LAMBDA L
13900 (PROG ()
14000 (RETURN
14100 (COND ((GETL (ARG 1) (QUOTE (EXPR SUBR %%TRACE)))
14200 (APPLY# (ARG 1)(ARG 2)))
14300 ((EVAL (CONS (ARG 1)(ARG 2))))))))EXPR)
14400
14500
14600 (PUTPROP @AND @(LAMBDA (L)
14700 (AND# (CDR L))) @MACRO)
14800
14900 (PUTPROP @OR @(LAMBDA (L)
15000 (OR# (CDR L)))
15100 @MACRO)
15200
15300 (DF TH (L)(PROG ()
15400 (PRINC @THEOREM:/ / )
15500 (PRINC (CAR L))
15600 (TERPRI)
15700 (SPRINT (GET (CAR L) @THEOREM) 0 1) ))
15800
15900 (QUOTE (END OF FILE))