General Information

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

{code}
(EDIT E EF H L S C X PASTE EQUAL GETCMD MAPCAR COMMANDS PSET SETP R A D B LI RE CONZ PRE I DEL G PP P PPRINT PPAUX MULTARGS PPARGS TABRET FORMATS LPAR BLANK RPAR LINE-WIDTH NCONC PU LOCK UNLOCK GETLST)
(DEFINEQ EDIT '(LAMBDA (S-EXP) (PROG (CURR PREV X) T (PSET S-EXP) (SETQ PREV (LIST S-EXP)) LOOP (POKE 128 0) (COND ((EQ (SETQ X (GETCMD (QUOTE "Edit> "))) (QUOTE EX)) (RETURN (QUOTE EXIT)))) (POKE 128 63) (COND ((EQ X (QUOTE T)) (GO T)) ((MEMBER X COMMANDS) (APPLY* X)) ((PRIN2 (LIST (QUOTE ILL) (QUOTE COMMAND-->) X)) (TERPRI))) (GO LOOP)))
)
(DEFINEQ E '(LAMBDA NIL ((LAMBDA (X) (PROGN (SETQ S-EXP (COND ((EVAL X)) (T (POKE 128 0) (PRIN1 (QUOTE Creating-->)) (PRINT X) (SET X (GETLST (GETCMD (QUOTE "Input> "))))))) (GO T))) (READ)))
)
(DEFINEQ EF '(LAMBDA NIL ((LAMBDA (X) (PROGN (SETQ S-EXP (COND ((GETD X)) (T (POKE 128 0) (PRIN1 (QUOTE Creating-->)) (PRINT X) (DEFINE X (GETLST (GETCMD (QUOTE "Input> "))))))) (GO T))) (READ)))
)
(DEFINEQ H '(LAMBDA NIL (PRIN1 (LIST (QUOTE COMMANDS:) COMMANDS)))
)
(DEFINEQ L '(LAMBDA NIL ((LAMBDA (FILE) (PROGN (LOAD FILE) (PRIN1 (QUOTE "Loaded--> ")) (PRINT (EVAL FILE)))) (GETCMD (QUOTE "File> "))))
)
(DEFINEQ S '(LAMBDA NIL (PROGN (SAVE (EVAL (GETCMD (QUOTE "Properties> "))) (GETCMD (QUOTE "File> "))) (PRINT (QUOTE Saved))))
)
(DEFINEQ C '(LAMBDA NIL (DIR (READ)))
)
(SETQ X 'S
)
(DEFINEQ X '(LAMBDA NIL (PROGN (PASTE CURR (READ) (READ)) (PSET CURR)))
)
(DEFINEQ PASTE '(LAMBDA (X Y Z) (COND ((EQUAL X)) ((ATOM X)) ((EQUAL (CAR X) Y) (RPLACA X Z) (PASTE (CDR X) Y Z)) (T (PASTE (CAR X) Y Z) (PASTE (CDR X) Y Z))))
)
(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 GETCMD '(LAMBDA (X) (PROGN (POKE 128 0) (TERPRI) (PRIN1 X) (READ)))
)
(DEFINEQ MAPCAR '(LAMBDA (X FN) (COND ((EQ X) NIL) (T (CONS (APPLY* FN (CAR X)) (MAPCAR (CDR X) FN)))))
)
(SETQ COMMANDS '(A D B P R DEL I G LI RE PP PRE C E EF X S L H PU LOCK UNLOCK)
)
(DEFINEQ PSET '(LAMBDA (L) (PRINT (CAR (SETQ CURR L))))
)
(DEFINEQ SETP '(LAMBDA (FUNCTION) (COND ((ATOM (APPLY* FUNCTION CURR)) (PRINT (QUOTE End_of_list))) (T (SETQ PREV (CONS CURR PREV)) (PSET (APPLY* FUNCTION CURR)))))
)
(DEFINEQ R '(LAMBDA NIL (PRINT (CAR (RPLACA CURR (READ)))))
)
(SETQ A '(A)
)
(DEFINEQ A '(LAMBDA NIL (SETP (QUOTE CDR)))
)
(DEFINEQ D '(LAMBDA NIL (SETP (QUOTE CAR)))
)
(DEFINEQ B '(LAMBDA NIL (COND ((EQ (CDR PREV)) (PRINT (QUOTE Top_of_list)) (PSET CURR)) (T (PSET (CAR PREV)) (SETQ PREV (CDR PREV)))))
)
(DEFINEQ LI '(LAMBDA NIL (PSET (RPLACA CURR (LIST (CAR CURR)))))
)
(DEFINEQ RE '(LAMBDA NIL (COND ((ATOM (CAR CURR)) (PRIN1 (QUOTE Not_a_list)) (TERPRI)) (T (PROG NIL (NCONC (CAR CURR) (CDR CURR)) (PSET (CONZ CURR (CAR (CAR CURR)) (CDR (CAR CURR))))))))
)
(DEFINEQ CONZ '(LAMBDA (X Y Z) (RPLACA (RPLACD X Z) Y))
)
(DEFINEQ PRE '(LAMBDA NIL (PSET (RPLACA CURR (CONS (READ) (LIST (CAR CURR))))))
)
(DEFINEQ I '(LAMBDA NIL (PROG NIL (RPLACD CURR (CONS (READ) (CDR CURR))) (A)))
)
(DEFINEQ DEL '(LAMBDA NIL (PROG NIL ((LAMBDA (X) (COND ((EQ CURR X) (CONZ CURR (CAR (CDR CURR)) (CDR (CDR CURR)))) ((EQ CURR (CDR X)) (RPLACD X (CDR CURR))) (T (RPLACA X (CDR CURR))))) (CAR PREV)) (B)))
)
(DEFINEQ G '(LAMBDA NIL (PROG (X Y) (SETQ Y CURR) L (SETQ X (GETCMD (QUOTE "Group> "))) (COND ((EQ X (QUOTE A)) (COND ((EQ (CDR Y)) (PRINT (QUOTE End_of_list))) (T (PRINT (CAR (SETQ Y (CDR Y))))))) ((EQ X (QUOTE G)) (RETURN (COND ((EQ CURR Y) (LI)) (T (CONZ CURR (CONS (CAR CURR) (CDR CURR)) (CDR Y)) (RPLACD Y NIL) (PRINT (CAR CURR)))))) (T (RETURN (PRINT (QUOTE Aborted))))) (GO L)))
)
(DEFINEQ PP '(LAMBDA NIL (PPRINT S-EXP 2))
)
(DEFINEQ P '(LAMBDA NIL (PPRINT (CAR CURR) 2))
)
(DEFINEQ PPRINT '(LAMBDA (X IND) (PROG (TFLG) (PPAUX X IND) (TERPRI)))
)
(DEFINEQ PPAUX '(LAMBDA (X INDTN) (COND ((ATOM X) (PRIN2 X) (SETQ TFLG)) ((ATOM (CAR X)) ((LAMBDA (Y) (COND (Y (MULTARGS X INDTN (CDR Y))) ((PROGN (PRIN1 LPAR) (PRIN2 (CAR X)) (PPARGS (CDR X) INDTN) (PRIN1 RPAR) (SETQ TFLG))))) (ASSOC (CAR X) FORMATS))) (((LAMBDA (IND1) (PROGN (PRIN1 LPAR) (SETQ TFLG T) (PPAUX (CAR X) IND1) (TABRET INDTN) (PPARGS (CDR X) IND1) (PRIN1 RPAR) (SETQ TFLG))) (+ INDTN)))))
)
(DEFINEQ MULTARGS '(LAMBDA (X INDTN L) ((LAMBDA (INDTN2) (PROGN (TABRET INDTN) (PRIN1 LPAR) (PRIN2 (CAR X)) (PRIN1 BLANK) (PPAUX (CAR (CDR X)) INDTN2) (COND ((CDR (CDR X)) (MAPCAR (CDR (CDR X)) (QUOTE (LAMBDA (Y) (PROG NIL (TABRET INDTN2) (PPAUX Y INDTN2))))))) (PRIN1 RPAR) (SETQ TFLG))) (+ INDTN (CAR L))))
)
(DEFINEQ PPARGS '(LAMBDA (X INDTN) (PROG NIL LOOP (COND ((EQ X) (RETURN))) (PRIN1 BLANK) (PPAUX (CAR X) INDTN) (SETQ X (CDR X)) (GO LOOP)))
)
(DEFINEQ TABRET '(LAMBDA (N) (PROG NIL (COND (TFLG (RETURN)) ((TERPRI))) (SETQ TFLG T) (COND ((> N LINE-WIDTH) (TERPRI) (TAB (SUB N LINE-WIDTH))) ((TAB N)))))
)
(SETQ FORMATS '((COND 6) (LAMBDA 2) (PROG 6) (PROGN 7) (AND 5) (OR 4) (MAPCAR 8) (NLAMBDA 2) (MACRO 2))
)
(SETQ LPAR '"("
)
(SETQ BLANK '" "
)
(SETQ RPAR ')
)
(SETQ LINE-WIDTH '39
)
(DEFINEQ NCONC '(LAMBDA (X Y) (PROGN (RPLACD (LAST X) Y) X))
)
(DEFINEQ PU '(LAMBDA NIL ((LAMBDA (X) (PROGN (COND ((EQ (GETCMD (QUOTE "Enter 'Y' to delete> ")) (QUOTE Y)) (XIO 33 7 0 0 X) (CLOSE 7))) (DIR))) (READ)))
)
(DEFINEQ LOCK '(LAMBDA NIL ((LAMBDA (X) (PROGN (XIO 35 7 0 0 X) (CLOSE 7))) (READ)))
)
(DEFINEQ UNLOCK '(LAMBDA NIL ((LAMBDA (X) (PROG (STAT) (SETQ STAT (XIO 36 7 0 0 X)) (COND ((EQ STAT 1)) (T (PRIN1 (QUOTE SYSTEM ERROR:)) (PRINT STAT))) (CLOSE 7))) (READ)))
)
(DEFINEQ GETLST '(LAMBDA (X) (COND ((ATOM X) (LIST X)) (X)))
)
NIL

{code}