[dei.comp.hp28] LISP for hp48

ares@alessia.dei.unipd.it (Nicola Catacchio 259126) (05/20/91)

	This is an inplementation of Mc Carthy's LISP 1.5 , interpreter and
compiler.For any explanation, refer to:
Mc Carty J. et alii.:LISP 1.5 Programmer's Manual.The MIT press,1965.
	The only modification is that the Lisp function eval has been renamed
EVL , for obvious reasons ;-}   


|------------------------------------------------------------------------------|
|Nicola Catacchio        |E-mail:  ares@alessia.unipd.it                       |
|Universita' di Padova   |mail  :  Cannaregio 4389, Venezia, Italy             |
| )/A                    |tel.# :  041/5222516                                 |
|  A A                   |                                                     |
| A   A    RR   E EE   SSSS                                                    |
|AAAAAAA--R--R-E-E--E-S--------------------------------------------------------|
A       A RRR    E  E  SSSS
          R         E      S
           R        E    SS
-----------------------------CUT----------------------------------------
%%HP: T(3)A(R)F(.);
DIR
  LISP
    \<< { "` " 31 EVL
33 " \183 " 25.2 }
STOKEYS -63 SF -62
SF
    \>>
  XAMP
    DIR
      FATT
        \<< \-> X
          \<<
            CASE X
0 > SO
              THEN
X X 1 - FATT *
              END 1
            END
          \>>
        \>>
      P { DEFUN
FATT { X } { COND {
{ > X 0 } { * X {
FATT { - X 1 } } }
} { T 1 } } }
      SORTN
        \<< \-> N
          \<<
            CASE N
0 < SO
              THEN
NIL
              END N
2 MOD SO
              THEN
N 1 - SORTN N 1
\->LIST APPEND
              END N
N 1 - SORTN CONS
            END
          \>>
        \>>
      DINSPOT
"{DEFUN INSPOT
{L}{COND 
{L{{\Gl{K}{
APPEND{ADDTO{
CAR L}K}K}}{INSPOT
{CDR L}}}}{T{ LIST NIL }}"
      DADDTO
"{DEFUN ADDTO
{O L}{COND
{L{CONS
{CONS O{CAR L}}
{ADDTO O{CDR L}}"
      DREV
"{DEFUN REV{X}
{COND 
{{CDR X}{APPEND 
{REV{CDR X}}
{LIST{CAR X}}}}
{T X}}}"
      DFLAT
"{DEFUN FLAT{X}
{COND 
{{AND{ATOM X}X}
{LIST X}}
{X{APPEND
{FLAT{CAR X}}
{FLAT{CDR X}}}}}}"
      DDEPTHF
"{DEFUN DEPTHF
{L X}{{\Gl{C}
{COND
{{SAME{CAR C}X}C}
{T{DEPTHF{APPEND
{CDR C}{CDR L}}X}}}}
{CAR L}}"
      DSORTN
"{DEFUN SORTN
{N}{COND 
{{< N 0}NIL}
{{MOD N 2}
{APPEND{SORTN{- N 1}}
{LIST N}}}
{T{CONS N
{SORTN{- N 1"
    END
  EVL
    \<<
      IF DUP TYPE 5
-
      THEN EVAL
      ELSE OBJ\->
        IF DUP
        THEN 1 -
\->LIST
          IF { \Gl
COND DEFINE LIST `
PROGRAM DEFUN LABEL
} 3 PICK POS
          THEN SWAP
EVAL
          ELSE
EVLIS APPLY
          END
        ELSE DROP {
}
        END
      END
    \>>
  APPLY
    \<< OBJ\-> 1 + ROLL
      IFERR RCL
      THEN
      END EVL
    \>>
  `
    \<<
      IF DUP TYPE
      THEN OBJ\->
DROP
      ELSE GETI
      END
    \>>
  \183
    \<<
"Dot Notation Error:
Bad form"
DOERR
    \>>
  DEFUN
    \<< DUP CAR SWAP
1 '\Gl' PUT 1 \->LIST
PROGRAM SWAP STO
NIL
    \>>
  \Gl
    \<< OBJ\-> DROP
\->STR "EVL " + " \-> "
ROT \->STR 2 OVER
SIZE 2 - SUB + SWAP
BRCK + OBJ\->
    \>>
  CONS
    \<<
      IF DUP TYPE 5
\=/
      THEN '\183' SWAP
3
      ELSE LIST\-> 1
+
      END \->LIST
    \>>
  CAR
    \<< 1 GET
    \>>
  CDR
    \<<
      IF DUP '\183'
POS 2 -
      THEN 2 9999
SUB
      ELSE 3 GET
      END
    \>>
  EQ
    \<< \=/ NULL
    \>>
  ATOM
    \<< DUP TYPE 5 -
1 ROT NULL 1 \->LIST
IFTE
    \>>
  LABEL
    \<< OBJ\-> DROP
SWAP "{} \-> " OVER +
"\<< \->STR OBJ\-> DUP "
+ SWAP \->STR +
" STO EVL " + OBJ\->
    \>>
  DEFINE
    \<< OBJ\-> 1 -
\->LIST
      \<<
      \>> 3 PICK STO
PROGRAM SWAP STO
NIL
    \>>
  COND
    \<< { { T NIL } }
+ 1 0
      DO DROP GETI
      UNTIL OBJ\->
DROP SWAP EVL SO
      END ROT ROT
DROP2 EVL
    \>>
  NULL
    \<< SO 'NIL' 1
IFTE
    \>>
  EVLIS
    \<<
      IF DUP SIZE
      THEN { } SWAP
1
        DO GETI EVL
4 ROLL SWAP 1 \->LIST
+ ROT ROT
        UNTIL DUP 1
==
        END DROP2
      END
    \>>
  NIL { }
  NOT
    \<< SO 'NIL' 'T'
IFTE
    \>>
  OR
    \<< SO 'T' ROT 1
\->LIST IFTE
    \>>
  AND
    \<< SO SWAP 1
\->LIST 'NIL' IFTE
    \>>
  SO
    \<< { NIL { } 0 }
SWAP POS NOT
    \>>
  OS
    \<< { NIL { } 0 }
OVER POS 'NIL' ROT
1 \->LIST IFTE
    \>>
  PROGRAM
    \<<
      IF DUP TYPE
      THEN CAR CMP
BRCK OBJ\->
      ELSE GETI
      END
    \>>
  LIST
    \<< EVLIS
    \>>
  CMP
    \<<
      IF DUP ATOM
SO
      THEN DUP TYPE
        CASE 18 \>=
          THEN BRCK
          END
        END
        IF DUP { }
SAME
        THEN \->STR
        ELSE " " +
        END
      ELSE OBJ\-> 1 -
\->LIST SWAP
        CASE DUP
'COND' SAME
          THEN DROP
{ { T NIL } } +
"CASE " SWAP 1
            WHILE
GETI OBJ\-> DROP OVER
'T' SAME NOT SO
            REPEAT
SWAP CMP "SO THEN "
+ SWAP CMP + "END "
+ 4 ROLL SWAP + ROT
ROT
            END 4
ROLLD 3 DROPN CMP
"END " + +
          END DUP
'\Gl' SAME
          THEN DROP
OBJ\-> DROP " \-> " ROT
\->STR 2 OVER SIZE 1
- SUB + SWAP CMP
BRCK +
          END DUP
'LABEL' SAME
          THEN DROP
OBJ\-> DROP SWAP
"\<<\>>\-> " OVER + ROT
CMP BRCK "DUP " +
ROT \->STR +
" STO EVAL " + BRCK
+
          END {
DEFINE DEFUN } OVER
POS
          THEN SWAP
\->STR SWAP +
          END DUP
'LIST' SAME
          THEN DROP
DUP CMLIS SWAP SIZE
\->STR + " \->LIST " +
          END DUP
'`' SAME
          THEN DROP
CAR CMP "'" SWAP +
"'" +
          END DUP
'PROGRAM' SAME
          THEN DROP
CAR CMP BRCK
          END DUP
TYPE
          CASE DUP
6 ==
            THEN
DROP DUP
              IF
VTYPE 5 ==
              THEN
\->STR " RCL EVL " +
              ELSE
CMP
              END
            END 5
==
            THEN
CMP
            END
\->STR
          END " " +
SWAP CMLIS SWAP +
        END
      END
    \>>
  CMLIS
    \<< " " SWAP
      IF DUP SIZE
      THEN 1
        DO GETI
          IF { `
PROGRAM } OVER POS
          THEN EVAL
\->STR
          ELSE CMP
          END 4
ROLL SWAP + ROT ROT
DUP
        UNTIL 1 ==
        END DROP
      END DROP
    \>>
  MEMBER
    \<< SWAP POS NOT
NULL
    \>>
  APPEND
    \<< \-> X Y
      \<<
        CASE X ATOM
SO NOT
          THEN X
CAR X CDR Y APPEND
CONS
          END Y
        END
      \>>
    \>>
  SET
    \<< DUP ROT STO
    \>>
  F { }
  BRCK
    \<< "\<<" SWAP \->STR
+ "\>>" +
    \>>
  \GaENTER
    \<< "{" SWAP +
OBJ\->
      IF 1 FS?
      THEN CMP OBJ\->
      ELSE EVL
      END
    \>>
  T 1
  CST { EVL CMP `
" \183 " \Gl NIL CAR CDR
CONS APPLY ATOM
PROGRAM LIST DEFUN
DEFINE MEMBER COND
APPEND NULL SET AND
OR NOT }
  NAME
    \<< \->STR # 23317d
SYSEVAL
    \>>
END