From ddbf4d79dbbd729c2729bacac760ec8eb94eba2d Mon Sep 17 00:00:00 2001 From: Eric Swenson Date: Tue, 25 Sep 2018 22:38:42 -0700 Subject: [PATCH] Fixed llogo. --- src/llogo/error.2 | 776 +++++++++++++++++++++++++++++++ src/llogo/loader.2 | 201 ++++++++ src/llogo/primit.2 | 1089 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 2066 insertions(+) create mode 100644 src/llogo/error.2 create mode 100644 src/llogo/loader.2 create mode 100644 src/llogo/primit.2 diff --git a/src/llogo/error.2 b/src/llogo/error.2 new file mode 100644 index 00000000..67a64705 --- /dev/null +++ b/src/llogo/error.2 @@ -0,0 +1,776 @@ +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ERROR > -- DEBUGGING PRIMITIVES ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; + +(DECLARE (OR (STATUS FEATURE DEFINE) + (COND ((STATUS FEATURE ITS) + ;;MULTICS? + (FASLOAD DEFINE FASL DSK LLOGO))))) + +(SAVE-VERSION-NUMBER ERROR) + +(DECLARE (GENPREFIX ERROR)) + +;;; TRACE, GRIND, GRINDEF AND LAP MUST HAVE SPECIAL PARSING +;;; PROPERTIES. ANY FUNCTION WHICH HAS AUTOLOAD PROPERTY +;;; MUST TELL PARSER HOW IT WANTS TO BE PARSED. THE PARSER +;;; HAS NO WAY OF KNOWING WHAT IS GOING TO HAPPEN TO A FUNCTION +;;; WHEN ITS DEFINITION IS READ IN. + +(DEFINE TRACE (PARSE F)) + +(DEFINE GRINDEF (PARSE F)) + +(DEFINE GRIND (PARSE F)) + +[(OR ITS DEC10) (DEFINE LAP (PARSE F))] + +[(AND (NOT BIBOP) (NOT MULTICS)) (SETQ GC-DAEMON 'GC-DAEMON) + (DEFUN GC-DAEMON (X) + ;;GC-DAEMON SERVICE FN. X = 3 DOTTED PAIRS + ;;WHOSE CAR IS BEFORE GC, CDR AFTER GC. THE + ;;PAIRS ARE FOR LIST, FIX AND FLO SPACE. + ;;CURRENTLY A MESSAGE IS PRINTED. + (OR + (> (CDDAR X) 512.) + (COND + ((< (CDDAR X) 100.) + ;;AVAIBLE SPACE BELOW 100. WORDS -- + ;;EXTREME STORAGE CRUNCH. + (GCTWA) + (TYPE + '";FREE SPACE VERY TIGHT. LESS THAN 100 WORDS" + EOL) + (AND + (STATUS FEATURE TRACE) + (TYPE + '";ERASING TRACE" + EOL) + (REMTRACE)) + (AND + (OR (STATUS FEATURE GRIND) + (STATUS FEATURE GRINDEF)) + (TYPE + '";ERASING GRIND PACKAGE" + EOL) + (REMGRIND))) + ((< (CDDAR X) 512.) + ;;AVAILABLE SPACE MORE THAN 100 WORDS BUT + ;;LESS THAN .5 BLOCKS. + (GCTWA) + (TYPE + '";FREE SPACE LESS THAN HALF-BLOCK" + EOL)))))] + +[BIBOP (SETQ GC-OVERFLOW 'GC-OVERFLOW-HANDLER) + (DEFUN GC-OVERFLOW-HANDLER (X) + (IOG + NIL + (TYPE EOL + '";YOU HAVE RUN OUT OF " + X + '" SPACE. MORE?: ") + ;;Ask if more memory desired. + (COND + ((ASK) + (TYPE '"; OK. (") + ;;If so, allocate some. + (ALLOC + (LIST + X + (LIST NIL + (LET ((NEW-ALLOC (+ (CDR (SASSQ X + '((LIST . 1400.) + (FIXNUM . 1400.) + (FLONUM . 600.) + (BIGNUM . 400.) + (SYMBOL . 400.) + (SAR . 100.)) + '(LAMBDA NIL + '(NIL . 400.)))) + (CADR (GET (CONS NIL (ALLOC T)) X))))) + (DPRINC NEW-ALLOC) + NEW-ALLOC) + NIL))) + (TYPE '" WORDS)" EOL)) + ((ERROR '"SPACE CAN'T BE EXPANDED" + X + 'GC-LOSSAGE))))) + (SETQ GC-LOSSAGE 'GC-LOSSAGE-HANDLER) + (DEFUN GC-LOSSAGE-HANDLER (WHAT-TYPE) + (LIST + (ERRBREAK + (LIST WHAT-TYPE + '" STORAGE CAPACITY EXCEEDED")))) + (SETQ PDL-OVERFLOW 'STACK-OVERFLOW-HANDLER)] + +[(OR BIBOP MULTICS) (DEFUN STACK-OVERFLOW-HANDLER (STACK-TYPE) + (IOG + NIL + (TYPE + EOL + '";TOO MANY RECURSIONS. USED " + (STATUS PDLSIZE STACK-TYPE) + '" WORDS. CONTINUE ANYWAY? ") + (COND + ((ASK) + (TYPE '"; OK.") + (TERPRI) + (ALLOC (LIST STACK-TYPE + (MIN (STATUS PDLROOM STACK-TYPE) + (+ (GET (CONS NIL (ALLOC T)) + STACK-TYPE) + 400.))))) + ((ERROR + '"SPACE OVERFLOW. CAN'T GET ANY MORE SPACE. " + STACK-TYPE)))))] + +;;; TYPE CHECKING FUNCTIONS. + +(DECLARE (MACROS NIL)) + +;(DEFUN SYMBOLP (X) (AND (EQ (TYPEP X) 'SYMBOL) X)) + +(DEFUN VARIABLEP (CHECKER VAR) + ;;USED BY EDIT, LIST TO DECIDE LEGALITY OF VARIABLE NAME. + (COND + ((AND (SYMBOLP VAR) (EQ (GETCHAR VAR 1.) ':)) VAR) + ((ERRBREAK + CHECKER + (LIST VAR + '" IS NOT A VALID VARIABLE NAME"))))) + +(DEFUN NUMBER? (CHECKER NUMBER) + (COND ((NUMBERP NUMBER) NUMBER) + ((ERRBREAK CHECKER + (LIST NUMBER + '" IS NOT A NUMBER"))))) + +(DEFUN PROCEDUREP (CHECKER CHECKED) + (COND + ((NOT (SYMBOLP CHECKED)) + (ERRBREAK + CHECKER + (LIST CHECKED + '" IS NOT A VALID PROCEDURE NAME"))) + ((EQ (GETCHAR CHECKED 1.) ':) + (ERRBREAK + CHECKER + (LIST + CHECKED + '" LOOKS LIKE A VARIABLE NAME -NOT A VALID PROCEDURE NAME"))) + ((ABBREVIATIONP CHECKED)) + ((MEMQ CHECKED :CONTENTS) CHECKED) + ((GETL CHECKED '(SUBR FSUBR LSUBR)) + (ERRBREAK CHECKER + (LIST CHECKED + '" IS A COMPILED FUNCTION"))) + ((ERRBREAK + CHECKER + (LIST CHECKED + '" IS NOT A DEFINED PROCEDURE "))))) + +(DEFUN REREAD-ERROR (MESSAGE) + ;;CAUSES MESSAGE TO BE PRINTED AND LINE REREAD. + (IOG NIL + (COND (REREAD-ERROR? (ERR 'REREAD)) + (T (TYPE '/; MESSAGE EOL) + (LET ((NEW-LINE (REPAIR-LINE OLD-LINE))) + (TYPE '";CONTINUING EVALUATION" + EOL) + (THROW NEW-LINE PARSELINE)))))) + +(DEFUN PASS2-ERROR (MESSAGE) + ;;IN THE SAME VEIN AS REREAD-ERROR EXCEPT INTENDED TO CATCH PASS2 ERRORS. + ;;THROWS BACK TO PASS2 [AND LINE IF CALLED BY IT] + (IOG NIL + (LET ((PROMPTER '>)) + (TYPE '/; MESSAGE EOL) + (MAPC 'DPRINC OLD-LINE) + (DTERPRI) + (DPRINC PROMPTER) + (LET ((NEW-LINE (LINE NIL))) + (TYPE '";CONTINUING EVALUATION" + EOL) + (THROW NEW-LINE PASS2))))) + +;;*PAGE + +;;; BREAKPOINT FUNCTIONS AND STACK HACKING +;;; :ERRBREAK = T --> LOGO BREAK POINT HAPPENS AUTOMATICALLY ON ERRORS. +;;; :LISPBREAK = T ---> LISP BREAK ON ERRORS. + +(SETQ :ERRBREAK NIL :LISPBREAK NIL) + +(DEFINE DEBUG NIL (SETQ :ERRBREAK (NOT :ERRBREAK))) + +(DEFINE TOPLEVEL NIL (IOC G)) + +;;UP, DOWN, PRINTUP, PRINTDOWN ARE FOR USE INSIDE FRAMEUP BREAKS. +;;;(UP) GOES UP TO THE NEXT FRAME ON THE STACK. +;;;(UP ) GO UP FRAMES. +;;;(UP ) GO SEARCHING UP THE STACK FOR AN INVOCATION OF +;;;(UP ) FIND THE TH INVOCATION OF UP THE STACK. +;;;DOWN IS SIMILAR, EXCEPT PROCEEDS DOWN THE STACK. +;;;DOWN IS EQUIVALENT TO (UP ... - ) +;;THE FUNCTIONS WORK BY THROWING A LIST BACK TO A CATCH IN FRAMEUP. +;;;FORMAT OF LIST IS: +;;; ( <1 IF UP, -1 IF DOWN>) + +(DEFUN FRAMEUP-THROW (TYPE HOW-MANY-ARGS ARGLIST DIRECTION) + (THROW + (CONS TYPE + (LET ((HOW-MANY-FRAMES (CAR (LAST ARGLIST))) + (FIND-FUNCTION (AND (SYMBOLP (CAR ARGLIST)) (CAR ARGLIST)))) + (COND ((ZEROP HOW-MANY-ARGS) (LIST NIL 1. DIRECTION)) + ((> HOW-MANY-ARGS 2.) + (TYPE '";TOO MANY INPUTS TO " + TYPE + EOL) + '(NIL 0. 1.)) + ((FIXP HOW-MANY-FRAMES) + (LIST FIND-FUNCTION + (ABS HOW-MANY-FRAMES) + (COND ((MINUSP (* DIRECTION HOW-MANY-FRAMES)) -1.) + (1.)))) + (FIND-FUNCTION (LIST FIND-FUNCTION 1. DIRECTION)) + (T (TYPE '";WRONG TYPE INPUTS TO " + TYPE + EOL) + '(NIL 0. 1.))))) + FRAMEUP-BREAK)) + +(DEFINE UP N (FRAMEUP-THROW 'UP N (LISTIFY N) 1.)) + +[(OR ITS DEC10) (ARGS 'UP '(0. . 2.))] + +(DEFINE DOWN N (FRAMEUP-THROW 'DOWN N (LISTIFY N) -1.)) + +[(OR ITS DEC10) (ARGS 'DOWN '(0. . 2.))] + +;;PRINTUP AND PRINTDOWN ARE LIKE UP AND DOWN, EXCEPT THAT THEY JUST PRINT OUT EVERY +;;FRAME BETWEEN THE CURRENT AND DESTINATION FRAMES RATHER THAN MOVING THE +;;BREAKPOINT. THE BREAKPOINT IS NOT AFFECTED. + +(DEFINE PRINTUP N (FRAMEUP-THROW 'PRINTUP N (LISTIFY N) 1.)) + +[(OR ITS DEC10) (ARGS 'PRINTUP '(0. . 2.))] + +(DEFINE PRINTDOWN N (FRAMEUP-THROW 'PRINTDOWN N (LISTIFY N) -1.)) + +[(OR ITS DEC10) (ARGS 'PRINTDOWN '(0. . 2.))] + +;;EXIT CAUSES THE FORM IN THE CURRENT FRAME TO RETURN WITH THE SPECIFIED VALUE. +;;DEFAULTS TO NIL. + +(DEFINE EXIT ARGS + [ITS (UNBIND-ACTIVATE)] + (THROW (LIST 'EXIT (AND (= ARGS 1.) (ARG 1.))) FRAMEUP-BREAK)) + +[(OR ITS DEC10) (ARGS 'EXIT '(0. . 1.))] + +(DEFINE CONTINUE (ABB CO P $P) ARGS + [ITS (UNBIND-ACTIVATE)] + (THROW (CONS 'CONTINUE (AND (= ARGS 1.) (LIST (ARG 1.)))) + FRAMEUP-BREAK)) + +[(OR ITS DEC10) (ARGS 'CONTINUE '(0. . 1.))] + +;;THE USER IS PUT IN A BREAKPOINT FROM WHICH HE CAN USE THE FUNCTIONS UP, DOWN, AND +;;EXIT TO MOVE THE BREAKPOINT AROUND THE STACK. FORMAT OF A LISP FRAME IS +;;; (
) +;;;FRAMEUP REQUIRES *RSET = T. +;;; + +(DEFUN FRAMEUP (CONTINUE-VALUE FRAME FRAME-PRINT BREAK-LOOP) + (DO ((FRAME-NUMBER 0.) + (FORM (CADDR FRAME)) + (ENV (CADDDR FRAME)) + (*RSET) + (NEW-FRAME) + ;;;TO INITIALIZE STACK POINTER, MUST LEAVE + ;;;ERROR OR FRAMEUP FRAMES. + (STACK-POINTER (CADR FRAME)) + (CAUGHT) + (SECOND-CAUGHT)) + (NIL) + (TYPE '";BREAKPOINT FRAME " + FRAME-NUMBER + '": ") + (EXPR-CALL FRAME-PRINT FORM) + (SETQ CAUGHT (CATCH (APPLY BREAK-LOOP NIL ENV) FRAMEUP-BREAK) + ;;UNLABELLED THROWS OUT OF THIS LOOP ARE HIGHLY DISCOURAGED. + SECOND-CAUGHT (CADR CAUGHT)) + (AND (EQ (CAR CAUGHT) 'EXIT) (FRETURN STACK-POINTER SECOND-CAUGHT)) + (AND (EQ (CAR CAUGHT) 'CONTINUE) + (RETURN (COND ((CDR CAUGHT) SECOND-CAUGHT) (CONTINUE-VALUE)))) + (DO ((HOW-MANY-FRAMES (CADDR CAUGHT)) + ;;;IF LOOKING FOR A PARTICULAR FN, COUNT-THIS-FRAME + ;;;IS TRUE ONLY FOR RELEVANT FRAMES. + (COUNT-THIS-FRAME T) + ;;;DIRECTION = 1 IF UP, -1 IF DOWN. + (DIRECTION (CADDDR CAUGHT)) + (PRINTFRAMES (AND (MEMQ (CAR CAUGHT) '(PRINTUP PRINTDOWN)) + (CONS FRAME-NUMBER FRAME)))) + ((OR (AND COUNT-THIS-FRAME (ZEROP HOW-MANY-FRAMES)) + ;;;GO DOWN TOO FAR?? + (AND (MINUSP DIRECTION) (ZEROP FRAME-NUMBER)) + ;;;GO UP TOO FAR?? + (NULL (SETQ NEW-FRAME (EVALFRAME (* DIRECTION STACK-POINTER))))) + (AND PRINTFRAMES + (SETQ FRAME-NUMBER (CAR PRINTFRAMES) + FRAME (CDR PRINTFRAMES) + STACK-POINTER (CADR FRAME) + FORM (CADDR FRAME) + ENV (CADDDR FRAME)))) + (SETQ FRAME NEW-FRAME + FRAME-NUMBER (+ FRAME-NUMBER DIRECTION) + STACK-POINTER (CADR FRAME) + FORM (CADDR FRAME) + ENV (CADDDR FRAME) + COUNT-THIS-FRAME (OR (NULL SECOND-CAUGHT) + (AND (NOT (ATOM FORM)) + (EQ (CAR FORM) SECOND-CAUGHT)))) + (AND COUNT-THIS-FRAME (DECREMENT HOW-MANY-FRAMES)) + (AND PRINTFRAMES + (TYPE '";FRAME " + FRAME-NUMBER + '": ") + (EXPR-CALL FRAME-PRINT FORM) + (DTERPRI))))) + +;;IS THIS BREAK LOOP ENTIRELY CORRECT? GLS CLAIMS NOT. ERROR KEEPS OLD VALUE OF +? + +(DEFUN LISP-BREAK-LOOP FEXPR (USELESS) + (DO ((^W) + (^Q) + (^R) + (+) + (- -) + (OBARRAY LISP-OBARRAY) + (READTABLE LISP-READTABLE)) + (NIL) + (DTERPRI) + (SETQ + - - (READ)) + (COND + ;;ALT-P CONTINUES WITH DEFAULT LIKE OLD BREAK. DOLLAR-P FOR + ;;BENEFIT OF ALTMODE-LESS MULTICS HACKERS. + ((MEMQ - '($P P)) (CONTINUE)) + ;;ALSO SIMULATE (RETURN ..) KLUDGE. + ((AND (NOT (ATOM -)) (EQ (CAR -) 'RETURN)) + (CONTINUE (EVAL (CADR -)))) + ((ERRSET (DPRINT (SETQ * (EVAL -)))))))) + +(DEFUN LOGO-BREAK-LOOP NIL + (DO ((^W) + (^Q) + (^R) + (PROMPTER '%) + (LOGOVALUE) + (OLD-LINE OLD-LINE) + (FN FN) + (PROG PROG) + (TITLE TITLE) + (REQUEST? NIL)) + ;;REBIND ANYTHING WHICH MIGHT BE ADVERSELY AFFECTED BY A BREAKPOINT. + (NIL) + (ERRSET (SETQ LOGOVALUE (TOP-LEVEL))))) + +;;HANDLES ARG CHECKING, ETC. FOR BOTH LISPBREAK AND LOGOBREAK. + +(DEFUN BREAK-POINT (ARG-LIST ENV UP-TO FRAME-PRINT BREAK-LOOP) + (LET ((HOW-MANY-ARGS (LENGTH ARG-LIST)) (^W NIL) (^Q NIL) (^R NIL)) + (COND ((> HOW-MANY-ARGS 3.) + (ERRBREAK UP-TO '"TOO MANY ARGS")) + ((AND (> HOW-MANY-ARGS 1.) (NULL (EVAL (CADR ARG-LIST) ENV))) + NO-VALUE) + (T (AND (PLUSP HOW-MANY-ARGS) + (TYPE EOL + '";BREAKPOINT " + (CAR ARG-LIST) + EOL)) + (FRAMEUP (AND (= HOW-MANY-ARGS 3.) (EVAL (CADDR ARG-LIST) ENV)) + UP-TO + FRAME-PRINT + BREAK-LOOP))))) + +;;YEAH, I KNOW I'M REDEFINING BREAK. AVOID WARNING MESSAGE. + +(REMPROP 'BREAK 'FSUBR) + +(DEFINE LISPBREAK (ABB BREAK) FEXPR (ARGS ENV) + [ITS (BIND-ACTIVATE-LISP)] + (BREAK-POINT ARGS + ENV + (STACK-SEARCH (EVALFRAME NIL) 'LISPBREAK) + (EXPR-FUNCTION DPRINC) + (FUNCTION LISP-BREAK-LOOP))) + +(DEFPROP LISPBREAK ((PARSE-BREAK)) PARSE) +(DEFPROP LISPBREAK (UNPARSE-EXPR-FORM) PARSE) + +(DEFINE LOGOBREAK (ABB PAUSE) FEXPR (ARGS ENV) + [ITS (BIND-ACTIVATE-LOGO)] + (BREAK-POINT ARGS + ENV + (STACK-SEARCH (EVALFRAME NIL) 'LOGOBREAK) + (EXPR-FUNCTION UNPARSE-PRINT-FORM) + (FUNCTION LOGO-BREAK-LOOP))) + +(DEFPROP LOGOBREAK ((PARSE-BREAK)) PARSE) +(DEFPROP LOGOBREAK (UNPARSE-EXPR-FORM) UNPARSE) + +;;*PAGE + + +(SSTATUS TTYINT #^^ 'TOGGLE-WORLD) + +(DEFUN TOGGLE-WORLD (IGNORE) + ;;^^ SWITCHES BACK AND FORTH BETWEEN LOGO AND LISP. + (NOINTERRUPT NIL) + (COND ((EQ OBARRAY LISP-OBARRAY) + [ITS (DO I (LISTEN) (1- I) (= I 0.) (TYI))] + (LOGO) + ;;ERR FORCES BACK TO TOP LEVEL. + (ERR)) + (T (TYPE '* EOL) + [ITS (DO I (LISTEN) (1- I) (= I 0.) (TYI))] + (LISP)))) + +(SSTATUS TTYINT #^H 'CONTROL-H-BREAK) + +(DEFUN CONTROL-H-BREAK (^H) + ;;^H ENTERS A LISP BREAK FROM EITHER LOGO OR LISP. + (NOINTERRUPT NIL) + [ITS (BIND-ACTIVATE-LISP)] + (BREAK-POINT '(CONTROL-H) + NIL + (STACK-SEARCH (EVALFRAME NIL) 'CONTROL-H-BREAK) + (EXPR-FUNCTION DPRINC) + 'LISP-BREAK-LOOP)) + +(SSTATUS TTYINT #^A 'CONTROL-A-BREAK) + +(DEFUN CONTROL-A-BREAK (USELESS) + ;;CONTROL-A ENTERS A LOGO BREAK. + (NOINTERRUPT NIL) + [ITS (BIND-ACTIVATE-LOGO)] + (BREAK-POINT '(CONTROL-A) + NIL + (STACK-SEARCH (EVALFRAME NIL) 'CONTROL-A-BREAK) + (EXPR-FUNCTION UNPARSE-PRINT-FORM) + 'LOGO-BREAK-LOOP)) + +(DEFUN STACK-SEARCH (START-FRAME LOOKING-FOR) + ;;FINDS THE FIRST CALL TO LOOKING-FOR ON THE STACK SEARCHING UPWARD FROM + ;;START-FRAME USING EVALFRAME. + (DO ((THIS-FRAME START-FRAME (EVALFRAME STACK-POINTER)) + (STACK-POINTER (CADR START-FRAME) (CADR THIS-FRAME))) + ((OR (NULL THIS-FRAME) (EQ (CAADDR THIS-FRAME) LOOKING-FOR)) THIS-FRAME))) + +(DEFUN STACK-HACK (START-FRAME MESSAGE) + ;;SEARCHES STACK FOR BAD FORM, USER FUNCTION, LINE NUMBER. PRINTS ERROR + ;;MESSAGES. + (COND ((EQ (CAR (CADDR START-FRAME)) 'ERRBREAK) + ;;DON'T USE FRAME WITH CALL TO ERRBREAK FUNCTION. + (SETQ START-FRAME (EVALFRAME (CADR START-FRAME))))) + (DO + ((PROG-FRAME (STACK-SEARCH START-FRAME 'PROG) + ;;SEARCH FOR FRAME CONTAINING PROG. + (STACK-SEARCH ABOVE-PROG 'PROG)) + (ABOVE-PROG) + (USER-FUNCTION)) + ((COND + ((NULL PROG-FRAME)) + ((MEMQ + (SETQ USER-FUNCTION + (CAADDR (SETQ ABOVE-PROG (EVALFRAME (CADR PROG-FRAME))))) + :CONTENTS) + ;;LOGO USER FUNCTIONS DISTINGUISHED BY BEING MEMQ :CONTENTS. FRAME + ;;IMMEDIATELY BENEATH LOGO USER FUNCTION IS ALWAYS A PROG. + (LET ((BAD-LINE-NUMBER (ERROR-LINE-NUMBER PROG-FRAME)) + (PROG) + (THIS-LINE) + (NEXT-TAG) + (LAST-LINE)) + (TYPE '";ERROR IN LINE " + BAD-LINE-NUMBER + '" OF " + USER-FUNCTION + '": ") + (MAPC '(LAMBDA (BAD-LINE-FORM) (UNPARSE-PRINT-FORM BAD-LINE-FORM) + (DPRINC '/ )) + (GETLINE (CADDR PROG-FRAME) BAD-LINE-NUMBER)) + (TERPRI) + T))) + (TYPE '";COULDN'T EVALUATE ") + (UNPARSE-PRINT-FORM (CADDR START-FRAME)) + (TYPE EOL '";BECAUSE " MESSAGE) + (OR :ERRBREAK :LISPBREAK (ERR 'ERRBREAK)) + ;;NO BREAKPOINT, CAUSE ERROR BACK TO TOP LEVEL. + (DTERPRI) + (BREAK-POINT NIL + NIL + START-FRAME + (COND (:ERRBREAK (EXPR-FUNCTION UNPARSE-PRINT-FORM)) + ((EXPR-FUNCTION DPRINC))) + (COND (:ERRBREAK 'LOGO-BREAK-LOOP) + ('LISP-BREAK-LOOP)))))) + +(DEFUN ERROR-LINE-NUMBER (PROG-FRAME) + ;;RETURNS THE LINE NUMBER CONTAINING THE FORM WHICH CAUSED THE ERROR IN THE + ;;LOGO USER FUNCTION CONTAINED IN PROG-FRAME. + (LET + ((LINE-FORM (CADDR (EVALFRAME (- (CADR PROG-FRAME)))))) + ;;LINE-FORM IS THE FORM DIRECTLY BENEATH PROG ON STACK, THAT IS, TOP LEVEL + ;;FORM OF THE LINE. + (COND + ((EQ (CAR LINE-FORM) 'PARSEMACRO) (CADR (CADDR LINE-FORM))) + ;;IF ERROR CAUSED WITHIN PARSEMACRO, SIMPLY EXTRACT THE LINE NUMBER FROM + ;;THE PARSEMACRO FORM. SINCE PARSE CLOBBERED IN, FORM IN PROG WON'T MATCH + ;;FORM ON STACK ANYWAY. + ((DO + ((REST-PROG (CDDR (CADDR PROG-FRAME)) (CDR REST-PROG)) + (BAD-LINE-NUMBER 0.) + (THIS-FORM)) + ((COND + ((NUMBERP (SETQ THIS-FORM (CAR REST-PROG))) + ;;NEXT LINE NUMBER. + (SETQ BAD-LINE-NUMBER THIS-FORM) + NIL) + ;;FIND THE RIGHT FORM, RETURN BAD-LINE-NUMBER. + ((EQ LINE-FORM THIS-FORM)) + ((NULL REST-PROG) + ;;RAN OFF THE END OF THE PROG -- SOMETHING WRONG! + (PRINT + '"SYSTEM BUG -- ERROR-LINE-NUMBER COULDN'T FIND FORM") + ;;STANDARD ERROR BREAK WON'T DO HERE, AS THIS IS CALLED BY IT, WOULD + ;;LIKELY LEAD TO INFINITE RECURSION. + (LISP-BREAK-LOOP))) + BAD-LINE-NUMBER)))))) + +;;ERRBREAK A REMNANT OF OBSOLETE ERROR HANDLING CODE. + +(DEFUN ERRBREAK ARGS (ERROR (ARG 2.) 'ERRBREAK 'FAIL-ACT)) + +[(OR ITS DEC10) (ARGS 'ERRBREAK '(NIL . 2.))] + +(SETQ FAIL-ACT 'FAIL-ACT) + +(DEFUN FAIL-ACT (ERRS) + [(OR ITS DEC10) (LOGO-ERROR)] + [MULTICS (COND ((EQ ERRS 'ERRBREAK) (LOGO-ERROR)) + ((LISP-ERROR (SUBSTR (CAADDR (ERRFRAME NIL)) 6.))))]) + +(DEFUN LOGO-ERROR NIL (LISP-ERROR (CAADDR (ERRFRAME NIL)))) + +(DEFUN LISP-ERROR (MESSAGE) + (LIST (STACK-HACK (EVALFRAME (CADR (ERRFRAME NIL))) MESSAGE))) + +(SETQ UNBND-VRBL 'UNBND-VRBL) + +(DEFUN UNBND-VRBL (UNBOUND-VARIABLE) + (LISP-ERROR (LIST (CAR UNBOUND-VARIABLE) + '"IS AN UNBOUND VARIABLE"))) + +(DEFUN UNDF-FNCTN (ERRS) + (LISP-ERROR (LIST (CAR ERRS) + '"IS AN UNDEFINED PROCEDURE"))) + +(SETQ UNDF-FNCTN 'UNDF-FNCTN) + +(DEFUN WRNG-TYPE-ARG (ERRS) + (LET + ((BAD-ARGUMENT (CAR ERRS)) + (UNHAPPY-FUNCTION + (UNPARSE-FUNCTION-NAME (CAADDR (EVALFRAME (ERRORFRAME)))))) + (LISP-ERROR + (COND ((EQ BAD-ARGUMENT NO-VALUE) + (LIST '"AN ARGUMENT TO" + UNHAPPY-FUNCTION + '"WAS SOMETHING THAT DIDN'T OUTPUT")) + ((LIST '"THE INPUT" + BAD-ARGUMENT + 'TO + UNHAPPY-FUNCTION + '"IS OF THE WRONG TYPE")))))) + +(SETQ WRNG-TYPE-ARG 'WRNG-TYPE-ARG) + +(DEFUN UNSEEN-GO-TAG (ERRS) + (LISP-ERROR + (COND + ((EQ (CAR ERRS) 'FRAMEUP-BREAK) + '"YOU TRIED TO USE A BREAKPOINT FUNCTION BUT YOU'RE NOT IN A BREAKPOINT") + ((LIST (CAR ERRS) '"IS AN UNDEFINED TAG"))))) + +(SETQ UNSEEN-GO-TAG 'UNSEEN-GO-TAG) + +(DEFUN ERRORFRAME NIL (AND (ERRFRAME NIL) (CADR (ERRFRAME NIL)))) + +(DEFINE ERRSET (PARSE 1. 2.)) + +;;CHANGING THE NUMBER OF INPUTS TO A FUNCTION CAN CAUSE LINES TYPED PREVIOUSLY TO +;;NOW BE INCORRECTLY PARSED. THIS HANDLER ATTEMPTS TO RECOVER WHERE POSSIBLE BY +;;REPARSING THE LINE. NOTE THAT ONE CAN'T WIN IN GENERAL, AS SIDE EFFECTS DURING +;;PARTIAL EXECUTION OF A LINE CANNOT BE UNDONE. A SOMEWHAT BETTER VERSION OF THIS +;;MIGHT USE FRETURN TO RETURN THE RESULT OF A NOW-CORRECT LINE FROM A HIGHER FRAME +;;THAN THE FORM CURRENTLY UNDER EXECUTION; SAY, THE WHOLE LINE, OR THE PROG. A MORE +;;RADICAL SOLUTION WOULD BE TO MAINTAIN A SUPERPROCEDURE TREE WHICH WOULD REPARSE +;;ALL CALLS TO A FUNCTION IF TITLE CHANGES. + +(DEFUN WRONG-NO-ARGS (ERRS) + (LET + ((CULPRIT (CAAR ERRS))) + ;;IF LOGO USER FUNCTION CAUSED THE ERROR, TRY REPARSING, ELSE GIVE UP. + (COND ((MEMQ CULPRIT :CONTENTS) + (DO ((PROG-FRAME (STACK-SEARCH (ERRFRAME NIL) 'PROG) + ;;SEARCH FOR FRAME CONTAINING PROG. + (STACK-SEARCH ABOVE-PROG 'PROG)) + (ABOVE-PROG) + (USER-FUNCTION) + (REPARSED-LINE)) + ((COND ((NULL PROG-FRAME) (LISP-ERROR (WNA ERRS))) + ((MEMQ (SETQ USER-FUNCTION + (CAADDR (SETQ ABOVE-PROG + (EVALFRAME (CADR PROG-FRAME))))) + :CONTENTS) + (SETQ REPARSED-LINE + (RETRY-PARSE USER-FUNCTION + (CADDR PROG-FRAME) + (ERROR-LINE-NUMBER PROG-FRAME))) + T)) + (COND (REPARSED-LINE) ((LISP-ERROR (WNA ERRS))))))) + ((LISP-ERROR (WNA ERRS)))))) + +(DEFUN RETRY-PARSE (REPARSED-PROCEDURE PROG BAD-LINE-NUMBER) + (LET + ((^W T) (NEXT-TAG NIL) (LAST-LINE NIL) (THIS-LINE NIL) (PARSED)) + ;;REPARSE THE LINE. ERRSET AS PARSE MAY GENERATE ERROR, IN WHICH CASE WE + ;;LOSE. IF PARSE OCCURS SUCCESSFULLY, MODIFY PROCEDURE, AND RETURN THE + ;;PARSED FORMS TO TRY AGAIN. + (SETQ + PARSED + (ERRSET (PARSELINE (PASS2 (UNPARSE-LOGO-LINE (GETLINE PROG + BAD-LINE-NUMBER))) + ;;THE T MEANS JUST ERR IF PARSING ERROR, DON'T TRY TO + ;;EDIT. SEE PARSELINE, REREAD-ERROR. + T) + NIL)) + (COND ((NOT (ATOM PARSED)) + ;;ATOM PARSED INDICATES PARSING ERROR, LIKELY TOO FEW ARGUMENTS + ;;STILL, SO NOT AN EDIT TITLE SCREW. + (SETQ ^W NIL PARSED (CAR PARSED)) + ;;ERRSET RETURNS A LIST OF THE RESULT IF NO ERROR. + (TYPE '";REPARSING LINE " + BAD-LINE-NUMBER + '" OF " + REPARSED-PROCEDURE + '" AS " + PARSED + EOL) + (ADDLINE PROG (APPEND (CONS BAD-LINE-NUMBER PARSED) NIL)) + ;;ADD A COPY AS LINE GETS MUNGED DURING PROCEDURE EDITING, AND MUST + ;;RETURN A CLEAN COPY. + (LIST (CONS 'PROGN PARSED)))))) + +(DEFUN WNA (ERRS) + ;;FIGURE OUT HOW MANY ARGUMENTS THE FUNCTION EXPECTED, AND PRINT OUT + ;;APPROPRIATE ERROR MESSAGE. + (LET ((CULPRIT (CAAR ERRS)) (EXPECTED NIL)) + (COND ((SETQ EXPECTED (ARGS CULPRIT)) + ;;ARGS PROPERTY. LSUBR OR SUBR. + (CCONS (UNPARSE-FUNCTION-NAME CULPRIT) + '" EXPECTED " + (COND ((NULL (CAR EXPECTED)) + (LIST (CDR EXPECTED) + '" INPUTS")) + ((LIST '" BETWEEN" + (CAR EXPECTED) + '" AND " + (CDR EXPECTED) + '" INPUTS"))))) + ((SETQ EXPECTED (GET CULPRIT 'EXPR)) + (LIST (UNPARSE-FUNCTION-NAME CULPRIT) + '" EXPECTED" + (LENGTH (CADR EXPECTED)) + '" INPUTS")) + ;;CAN'T FIGURE OUT HOW MANY ARGUMENTS WANTED. + ((LIST '"WRONG NUMBER OF INPUTS TO " + (UNPARSE-FUNCTION-NAME CULPRIT)))))) + +(SETQ WRNG-NO-ARGS 'WRONG-NO-ARGS) + +(*RSET T) + +;(SSTATUS INTERRUPT 18. 'FASLOADER) + +(DEFUN FASLOADER (FILE) + ;;REDEFINE AUTOMATIC FASLOADER FOR TRACE, GRIND, LAP, ETC. TO FASLOAD STUFF + ;;FROM THE LISP OBARRAY. THEREFORE IT IS CALLABLE FROM LOGO. + ;;; + ;;ALSO, IT'S NICE IF AUTOMATIC FASLOADER IS TRANSPARENT TO CURRENT DEFAULT + ;;FILENAME AND DIRECTORY. + (LET ((OBARRAY LISP-OBARRAY) + (READTABLE LISP-READTABLE) + (CRFILE (STATUS CRFILE)) + (CRUNIT (CRUNIT))) + ;;READTABLE REBOUND SO THAT CHARACTER READMACROS DEFINED BY FASLOADED + ;;FILE WILL NOT AFFECT LOGO READTABLE. I.E. DOUBLE-QUOTE AND SQUARE + ;;BRACKET MACROS DEFINED BY FILE DEFINE >. + [(OR ITS DEC10) (APPLY 'FASLOAD (CDR FILE))] + [MULTICS (LOAD (CDR FILE))] + (APPLY 'CRUNIT CRUNIT) + (APPLY 'SSTATUS (CONS 'CRFILE CRFILE)))) + +(SETQ *RSET-TRAP NIL) + +;;RSET BREAK TURNED OFF. HENCE, EXECUTING (LISP) WILL NOT RESULT IN BREAK. RSET +;;SERVICES ERRORS THAT REACH THE TOPLEVEL. +;;; + +(DECLARE (MACROS T)) + +;;MISCELLANEOUS SYSTEM DEBUGGING FEATURES. + +[ITS (DEFPROP LOAD-TECO (LISPT FASL DSK /.TECO/.) AUTOLOAD) + (DEFPROP START-TECO (LISPT FASL DSK /.TECO/.) AUTOLOAD) + (DEFPROP MEV (STEPMM FASL DSK COMMON) AUTOLOAD) + (DEFUN TECO NIL (COND (TECO? (P)) ((SETQ TECO? T) (LOAD-TECO) (G)))) + (SETQ TECO? NIL)] + +;;; +;;THIS FUNCTION SHOULD BE USED TO REPORT BUGS IN LISP LOGO. IT RELIEVES THE NAIVE +;;USER ABOUT HAVING TO KNOW ABOUT :BUG IN DDT. IT WRITES A FILE BUG > ON LLOGO; +;;CONTAINING THE USER'S GRIPE. + +[(OR ITS MULTICS) (DEFINE FEATURE (ABB BUG) FEXPR (COMPLAINT) + (LET + ((^W T) + (^R T) + (CRUNIT (CRUNIT)) + (CRFILE (STATUS CRFILE)) + [ITS (JNAME (STATUS JNAME))]) + (UWRITE [ITS DSK + LLOGO]) + (PRINC COMPLAINT) + (TERPRI) + (UFILE [ITS BUG + >] + [MULTICS LLOGO + BUG]) + [ITS (VALRET + (ATOMIZE + '":QMAIL BUG-LLOGO ILLOGO;BUG >" + EOL + JNAME + '"JP")) + (UKILL BUG > DSK LLOGO)] + [MULTICS (CLINE + "MAIL LLOGO.BUG HENRY ESG;DELETE LLOGO.BUG")] + (APPLY 'CRUNIT CRUNIT) + (APPLY 'SSTATUS (CONS 'CRFILE CRFILE))) + '";THANK YOU FOR YOUR PATIENCE.")] + diff --git a/src/llogo/loader.2 b/src/llogo/loader.2 new file mode 100644 index 00000000..a86211c2 --- /dev/null +++ b/src/llogo/loader.2 @@ -0,0 +1,201 @@ + + +(COMMENT NO ALLOCATION) + +(PUTPROP (CAR (STATUS UREAD)) (CADR (STATUS UREAD)) 'VERSION) + +;;;LOADER > READS IN THE FN "CREATE". (CREATE ) WILL +;;;READ IN THE NECESSARY FASL FILES AND DUMP THE JOB OUT AS +;;;TS NLLOGO OR TS LLOGO, ETC, ON LLOGO;. (CREATE) WILL SIMPLY +;;;PRODUCE AN INTERPRETIVE VERSION WITHOUT DUMPING. + +(DECLARE (COUTPUT (READ))) + +(load "ioc") + +(DEFUN HOW-BIG NIL + (REMPROP 'HOW-BIG 'EXPR) + ((LAMBDA (FREE) + ((LAMBDA (GC-DAEMON) (GCTWA) (GC)) + (FUNCTION (LAMBDA (GC-STATISTICS) (SETQ FREE GC-STATISTICS)))) + (CONS (PAGEBPORG) + (MAPCAR '(LAMBDA (SPACE) + (CONS (- (STATUS SPCSIZE SPACE) + (CDDR (ASSOC SPACE FREE))) + (ERRSET (STATUS PURSIZE SPACE) NIL))) + (STATUS SPCNAMES)))) + NIL)) + +(DECLARE (COUTPUT (READ))) + +(DEFUN CREATE NIL + (REMPROP 'CREATE 'FEXPR) + (REMPROP 'HOW-BIG 'EXPR) + (*RSET T) + ((LAMBDA (DUMP) + (AND (STATUS FEATURE ITS) + (COND ((MEMQ 'I (STATUS JCL)) + (AND (STATUS FEATURE BIBOP) + (ALLOC '(LIST (25000. 30000. NIL) + SYMBOL + (3000. 5000. NIL) + FIXNUM + (4000. 8000. NIL)))) + (MAPC + '(LAMBDA (SOURCE-FILE) + (APPLY 'UREAD + (CONS SOURCE-FILE '(> DSK LLOGO))) + (MAPC 'PRINC + (LIST 'READING + '/ + (CAR (STATUS UREAD)) + '/ + (CADR (STATUS UREAD)))) + (TERPRI) + (DO ((^Q T) (FORM) (END-OF-FILE (GENSYM))) + ((OR (NULL ^Q) + (EQ END-OF-FILE + (SETQ FORM (READ END-OF-FILE)))) + (SETQ ^Q NIL)) + (EVAL FORM))) + (GET 'LLOGO 'FILES)) + (DEFPROP LLOGO (INTERPRETIVE LOGO) VERSION)) + (T (SETQ NOUUO NIL) + (AND (STATUS FEATURE BIBOP) + (SETQ PUTPROP (APPEND '(PARSE UNPARSE) + PUTPROP) + PURE T + *PURE T) + ;;THE VALUE OF PURE IS NUMBER OF PAGES FOR UUO + ;;LINKS. THE VALUE OF PUTPROP IS A LIST OF + ;;INDICATORS PERMITTING PURIFICATION OF THE + ;;CORRESPONDING PROPERTIES. + (ALLOC '(LIST (10000. 20000. NIL) + SYMBOL + (2000. 3000. NIL) + FIXNUM + (3000. 5000. NIL)))) + (COND (DUMP (NOUUO NIL) T) ((NOUUO T))) + (MAPC '(LAMBDA (FASL-FILE) + (MAPC 'PRINC + (LIST '/ +FASLOADING/ FASL-FILE + '/ FASL)) + (APPLY 'FASLOAD + (CONS FASL-FILE + '(FASL DSK LLOGO)))) + (CDR (GET 'LLOGO 'FILES))))) + (AND DUMP (UWRITE DSK LLOGO) (IOC R) + (MAPC 'PRINC + (LIST '/ +CREATING/ DUMP + '/ ON/ + (DATE) + '/ AT/ + (DAYTIME) + (ASCII 13.))) + (MAPC '(LAMBDA (X) (PRINC X) + (TYO 32.) + (PRINC (GET X 'VERSION)) + (TERPRI)) + (CONS 'LOADER (REVERSE (GET 'LLOGO 'FILES)))))) + (COND ((STATUS FEATURE BIBOP) + (SETQ BASE 10.) + (PRINC '/ +GC-STATISTICS/ +) (PRINC '/ +BPS:/ ) (PRINC (- BPORG (CAR INITIAL-SIZE) + (COND ((NUMBERP PURE) (* PURE 2048.)) (0.)))) + (PRINC '/ WORDS/ +UUO:/ ) (PRINC (COND ((NUMBERP PURE) (* PURE 2048.)) (0.))) + (PRINC '/ WORDS/ +) ((LAMBDA (FREE) + ((LAMBDA (GC-DAEMON) (GCTWA) (GC)) + '(LAMBDA (GC-STATISTICS) (SETQ FREE GC-STATISTICS))) + (MAPC + '(LAMBDA (SPACE OLD-SIZE) + (PRINC SPACE) + (PRINC ':/ ) + (PRINC (- (- (STATUS SPCSIZE SPACE) + (CDDR (ASSOC SPACE FREE))) + (CAR OLD-SIZE))) + (PRINC '/ IMPURE/ WORDS/ USED/ +) (AND (CDR OLD-SIZE) + (PRINC '/ ) + (PRINC (- (STATUS PURSIZE SPACE) + (CADR OLD-SIZE))) + (PRINC '/ PURE/ WORDS/ USED/ +))) (STATUS SPCNAMES) + (CDR INITIAL-SIZE))) + NIL))) + ;;UNSNAP ALL LINKS. (SSTATUS UUOLINKS) + (MAKUNBOUND 'INITIAL-SIZE) + (SETQ PURE NIL ^W NIL) + (LOGO) +(defun dprinc (x) (princ x)) +(defun dterpri () (terpri)) + (SETQ BASE 10. + IBASE 10. + *NOPOINT T + *PURE NIL + HOMCHECK NIL + FASLOAD NIL) + (TERPRI) + (SSTATUS TOPLEVEL '(START-UP)) + (COND ((AND DUMP (STATUS FEATURE ITS)) + (ERRSET (UFILE LLOGO > DSK LLOGO) NIL) + (IOG NIL (PRINC 'VERSION/ NUMBER?/ ) + (PUTPROP 'LLOGO (LIST DUMP (READ)) 'VERSION)) + (UCLOSE) + (PURIFY 0. 0. 'BPORG) + (SUSPEND (ATOMIZE ':SYMLOD EOL ':PDUMP/ LLOGO/;TS/ DUMP EOL ':KILL/ ))) + (DUMP (IOG NIL (PRINC 'VERSION/ NUMBER?/ ) + (PUTPROP 'LLOGO (LIST DUMP (READ)) 'VERSION)) + (COND ((STATUS FEATURE DEC10) (SUSPEND)) + ((APPLY 'SAVE (LIST DUMP))))) + ((DEFPROP LLOGO (EXPERIMENTAL LLOGO) VERSION)))) + (AND (PRINC 'DO/ YOU/ WANT/ TO/ DUMP/ ON/ DSK?/ ) + (MEMQ (IOG NIL (READ)) '(Y YES OK SURE T YA OUI)) + (PRINC 'NAME/ /[LLOGO/,/ NLLOGO/]?/ ) + (IOG NIL (READ))))) + +(DECLARE (COUTPUT (READ))) + +(DEFUN START-UP NIL + (REMPROP 'START-UP 'EXPR) + (LOGO) + (AND (STATUS FEATURE ITS) (OR (ZEROP TTY) (CURSORPOS 'C))) + ;;CLEAR SCREEN IF AT A DISPLAY TERMINAL. + (MAPC '(LAMBDA (X Y) (MAPC 'DPRINC (LIST X '/ Y EOL))) + (LIST 'LISP + (CAR (GET 'LLOGO 'VERSION))) + (LIST (STATUS LISPVERSION) + (CADR (GET 'LLOGO 'VERSION)))) + (AND (STATUS FEATURE ITS) (ERRSET (ALLOCATOR) NIL)) + ;; ALLOCATOR LOADS IN AUXILIARY PACKAGES IF THE USER WANTS THEM. + (APPLY 'CRUNIT (LIST 'DSK (STATUS UDIR))) + (SETQ SAIL (NOT (ZEROP (BOOLE 1. 536870912. (CADDR (STATUS TTY)))))) + ;;SET FLAG WHETHER TERMINAL IS IN SAIL MODE. + ((LAMBDA (^W) + (COND ((STATUS FEATURE ITS) + (OR (ERRSET (READFILE LLOGO /(INIT/)) NIL) + (ERRSET (AND (APPLY 'READFILE + (LIST (STATUS UDIR) + '/.LLOGO/. + '/(INIT/))) + (APPLY 'CRUNIT + (LIST 'DSK (STATUS UDIR)))) + NIL))) + ((STATUS FEATURE DEC10) (ERRSET (READFILE INIT LGO) NIL)) + ((ERRSET (READFILE START_UP LOGO) NIL)))) + T) + (PRINC 'LLOGO/ LISTENING) + '?) + + +(DEFPROP LLOGO (DEFINE SETUP READER PARSER UNEDIT PRINT PRIMIT ERROR) FILES) + +(AND (STATUS FEATURE BIBOP) (SETQ INITIAL-SIZE (HOW-BIG))) + +(SSTATUS TOPLEVEL '(CREATE)) + diff --git a/src/llogo/primit.2 b/src/llogo/primit.2 new file mode 100644 index 00000000..b4b54d05 --- /dev/null +++ b/src/llogo/primit.2 @@ -0,0 +1,1089 @@ + +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; PRIMIT > ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; THIS FILE CONTAINS MOST OF THE LLOGO PRIMITIVES. +;;; + +(DECLARE (OR (STATUS FEATURE DEFINE) + (COND ((STATUS FEATURE ITS) + ;;MULTICS? + (FASLOAD DEFINE FASL DSK LLOGO))))) + +(SAVE-VERSION-NUMBER PRIMIT) + +(DECLARE (GENPREFIX PRIMIT)) + +(DEFINE USE FEXPR (X) + ;;DEFAULT USER NAME SET TO ARG. + (APPLY 'CRUNIT + [(OR ITS DEC10) (CONS 'DSK X)] + [MULTICS (LIST 'DSK (APPLY 'ATOMIZE X))]) + NO-VALUE) + +(DEFINE DIRNAME NIL (STATUS UDIR)) + +(DEFINE LOGNAME NIL (STATUS UNAME)) + +[(OR ITS MULTICS) (DEFINE LOGOUT (ABB BYE GOODBYE) NIL + (TYPE '"AND A PLEASANT DAY TO YOU! +") [ITS (VALRET '/U)] + [DEC10 (VALRET '"KJOB +")] [MULTICS (CLINE "LOGOUT")])] + +;;*PAGE + + +(DEFUN FILECHECK (X) + ;;CHECK IF FILE X EXISTS ON DSK. IF SO ASKS QUESTION. + (COND + [ITS ((MEMQ (CADR X) '(< >)))] + ((NOT (APPLY 'UPROBE X))) + ((AND + (TYPE + (LIST + '";YOU HAVE" + X + '"ALREADY. WOULD YOU LIKE TO WRITE OVER IT? ")) + (ASK))) + ((TYPE '";OK, YOUR OLD FILE IS SAFE." EOL) + NIL))) + +(DEFUN FILENUM (X) (APPLY 'UREAD X) (STATUS UREAD)) + +;;SAVE IS A HOMONYM IN THE MULTICS IMPLEMENTATION ONLY. + +[MULTICS (DEFINE SAVE (PARSE (PARSE-SUBSTITUTE 'LOGO-SAVE)))] + +([(OR ITS DEC10) DEFINE + SAVE] + [MULTICS DEFINE + LOGO-SAVE + (UNPARSE (UNPARSE-SUBSTITUTE 'SAVE))] + FEXPR + (X) + (COND ((OR (DELEET :CONTENTS :BURIED) :NAMES) + (AND (SETQ X (FILESPEC X)) + ;;EXPAND X TO FULL FILE NAME. + (FILECHECK X) + ;;CHECK IF THE FILE X IS ALREADY ON THE DSK. + (APPLY 'UWRITE (CDDR X)) + (LET ((^W T) (^R T) (FN FN) (PROG PROG) (TITLE TITLE)) + (PRINTOUTNAMES) + (PRINTOUTPROCEDURES) + (APPLY 'UFILE X)) + (TYPE '/; (LIST (FILENUM X) 'SAVED)) + (DTERPRI)) + NO-VALUE) + ('";:CONTENTS EMPTY"))) + +;;*PAGE + +;;;THIS WRITE FUNCTION IS OF GENERAL LISP USE. IT PRINTS DEFPROPS +;;FOR ALL BUT THE PNAME AND TRACE PROPERTIES FOR EVERY ATOM ON THE LIST :CONTENTS +;;; +;;WRITE OPTIMIZES SPEED WITH WHICH LOGO USER INTERPRETIVE FUNCTIONS CAN BE REREAD. +;;THEY ARE STORED AS DEFPROP S-EXPRESSIONS. NEITHER THE LOGO READER NOR PARSER ARE +;;NECESSARY UPON REREADING. /AS STANDARD LISP FORMAT, THE FILES CAN BE COMPILED AS +;;WELL. + +(DEFINE WRITE FEXPR (FILE) + ;;PRINTS DEFPROPS FOR PROPERTIES OF ATOMS ON :CONTENTS. + (SETQ FILE (FILESPEC FILE)) + ;;EXPAND FILE NAME. + (AND (FILECHECK FILE) + (PROG (READTABLE ^W CONTENTS FN PLIST TRACE IND PROP) + (SETQ READTABLE LISP-READTABLE) + ;;SLASH MUST WORK TO PRESERVE TRANSPARENCY OF (READ (PRIN1 X)). + (SETQ ^R T ^W T) + (APPLY 'UWRITE (CDDR FILE)) + (TYO 35.) + (PRINC '(READOB LOGO-OBARRAY LISPREADTABLE)) + (TERPRI) + (SETQ CONTENTS :CONTENTS) + (WRITENAMES :NAMES) + A (OR CONTENTS (TERPRI) (RETURN (APPLY 'UFILE FILE))) + (SETQ FN (CAR CONTENTS) CONTENTS (CDR CONTENTS)) + (AND (MEMQ FN :BURIED) (GO A)) + (TERPRI) + (WRITELIST 'UNITE + '/' + FN + '/' + ':CONTENTS) + ;;FN ADDED TO CONTENTS IF NOT ALREADY THERE. + (TERPRI) + (SETQ PLIST (CDR FN)) + ;;PROPERTY LIST TO BE STORED. + (SETQ TRACE (TRACE? FN)) + ;;FLAG TO AVOID TRACE PROP. + B (OR PLIST (GO A)) + ;;DONE WITH THIS ATOM + (SETQ IND (CAR PLIST) PROP (CADR PLIST) PLIST (CDDR PLIST)) + (COND ((AND TRACE (MEMQ IND '(EXPR FEXPR MACRO))) + ;;IGNORE TRACE PROP + (SETQ TRACE NIL)) + ((MEMQ IND '(SUBR FSUBR LSUBR ARGS PNAME))) + ;;IGNORE PNAME SUBR LSUBR AND FSUBR PROP + ((WRITELIST 'DEFPROP FN PROP IND))) + (TERPRI) + (GO B))) + (TYPE '/; (FILENUM FILE) '" WRITTEN" EOL) + NO-VALUE) + +(DEFUN WRITENAMES (NAMELIST) + (MAPC '(LAMBDA (NAM) + (AND (BOUNDP NAM) + (WRITELIST 'UNITE + ;;UNBOUND ON EXIT + '/' + NAM + '/' + ':NAMES) + (WRITELIST 'SETQ + NAM + (COND ((EQ (SETQ NAM (SYMEVAL NAM)) :EMPTYW) + ':EMPTYW) + ((LIST 'QUOTE NAM)))))) + NAMELIST)) + +;;*PAGE + +;; THIS DEFINES FUNCTIONS WHICH WILL ENABLE THE LOGO USER TO COMPILE HIS OWN +;;PROCEDURES. +;;; ?COMPILE +;; WILL COMPILE ALL THE FUNCTIONS IN A USER'S WORKSPACE AS FASL ON HIS +;;DIRECTORY. THE COMPILE FUNCTION WRITES OUT A FILE .LOGO. OUTPUT CONTAINING +;;DECLARATIONS AND DEFINITIONS OF ALL THE FUNCTIONS ON :CONTENTS. IT IS NECESSARY +;;THAT ALL PARSEMACROS BE ELIMINATED BEFORE COMPILING SINCE IT IS IMPOSSIBLE TO +;;INSERT A RUN-TIME PARSED LINE INTO A COMPILED FUNCTION. THEREFORE, IT IS AN ERROR +;;TO ATTEMPT TO COMPILE A FUNCTION WHICH REFERENCES A FUNCTION WHICH IS NOT DEFINED +;;IN THE USER'S WORKSPACE. THE FILE LLOGO;DECLARE > CONTAINS DECLARATIONS FOR LLOGO +;;PRIMITIVES. +;;; +;; NOTE THAT COMPILATION OF LOGO PROCEDURES, LIKE THOSE OF LISP, IS NOT FOOLPROOF- +;;ONE IS NOT GUARANTEED THAT A PROCEUDRE THAT RUNS INTERPRETIVELY WILL BE +;;COMPILABLE, AND WILL RUN CORRECTLY WHEN COMPILED. CAUTION MUST BE EXERCISED WITH +;;PROCEDURES THAT DEPEND HEAVILY ON MAINTAINING A DYNAMIC ENVIRONMENT- PROCEDURE +;;MODIFYING PROCEDURES, EXTENSIVE P-LIST HACKING, GLOBAL VARIABLES, WEIRD CONTROL +;;STRUCTURES, ETC. + +[(OR ITS MULTICS) (PUTPROP 'COMPILE-PARSEMACRO + (GET 'PARSEMACRO 'MACRO) + 'FEXPR)] + +[(OR ITS MULTICS) (DEFUN COMPILE-DEFINITION-PRINT (USER-FUNCTION) + (IOG NIL (PRINT USER-FUNCTION)) + (MAPC '(LAMBDA (FORM) + (AND (NOT (ATOM FORM)) + (EQ (CAR FORM) 'PARSEMACRO) + (LET ((READTABLE LOGO-READTABLE)) + (APPLY 'COMPILE-PARSEMACRO + FORM)))) + (LET + ((DEFINITION + (CDDR + (OR + (GET USER-FUNCTION 'EXPR) + (ERRBREAK + 'COMPILE + (LIST + USER-FUNCTION + '"DOES NOT HAVE A DEFINITION")))))) + (COND ((EQ (CAAR DEFINITION) 'PROG) + (CAR DEFINITION)) + ((CADR DEFINITION))))) + (PRINT (LIST 'COMPILED-FUNCTION-SETUP USER-FUNCTION)) + (PRINT (LIST 'DEFPROP + USER-FUNCTION + (GET USER-FUNCTION 'EXPR) + 'EXPR)))] + +;;FEXPR VERSION OF PARSEMACRO TO REPLACE PARSED LINE ONLY. MACRO WOULD CAUSE +;;EVALUATION OF PARSED LINE. + +[(OR ITS MULTICS) (DEFINE COMPILE FEXPR (ARGLIST ENV) + (LET + ((FILENAME (CCONS (COND ((SYMBOLP (CAR ARGLIST))) + ((CAR (STATUS CRFILE)))) + 'FASL + (CRUNIT)))) + (AND (APPLY 'UPROBE FILENAME) + (APPLY 'UKILL FILENAME)) + (UWRITE) + (TYPE '";FUNCTIONS BEING COMPILED ARE:") + (LET + ((^W T) + (^R T) + (READTABLE LISP-READTABLE) + (*NOPOINT NIL) + (CONTENTS (DELEET :CONTENTS :BURIED))) + (PRINT (LIST 'DECLARE (CONS '*EXPR CONTENTS))) + ;;DECLARATIONS. + (AND (EQ (CAR (SETQ ARGLIST (EVAL (CADR ARGLIST) ENV))) + 'DECLARE) + (PRINT ARGLIST)) + [MULTICS (PRINT + '(DECLARE + (INPUSH + (OPENI + ">UDD>AP>LIB>LOGO_DECLARE.LISP")) + (SETQ NFUNVARS T)))] + (MAPC 'COMPILE-DEFINITION-PRINT CONTENTS) + (WRITENAMES :NAMES) + [ITS (PRINT '(DECLARE (UKILL ".LOGO." + OUTPUT))) + (PRINT (LIST 'DECLARE + (APPEND '(UKILL DECLARE UNFASL) + (CRUNIT))))]) + [ITS (UFILE ".LOGO." OUTPUT) + (TERPRI) + (VALRET + (ATOMIZE + '":NCOMPLR " + (CADR (CRUNIT)) + '/; + (CAR FILENAME) + '" FASL_LLOGO;DECLARE >," + (CADR (CRUNIT)) + '";.LOGO. OUTPUT (FKDWVSU) +" (STATUS JNAME) + '"JP"))] + [MULTICS (LET + ((DIRECTORY (GET_PNAME (CAR (NAMES (CAR OUTFILES)))))) + (APPLY 'UFILE + (LIST (CAR FILENAME) 'LISP)) + (TERPRI) + (CLINE + (CATENATE + ">UDD>AP>LIB>LISP_COMPILER " + DIRECTORY + ">" + (GET_PNAME (CAR FILENAME)) + " -ALL_SPECIAL ; DELETE " + DIRECTORY + ">" + (CAR FILENAME) + ".LISP ")))] + (COMPILATION-ALARM FILENAME)) + NO-VALUE)] + +[(OR ITS MULTICS) (DEFUN COMPILATION-ALARM (FILENAME) + (TYPE + '";YOUR WORKSPACE WILL BE COMPILED AS " + FILENAME + EOL + '";I WILL LET YOU KNOW WHEN IT'S READY." + EOL) + (SETQ ALARMCLOCK + (SUBST FILENAME + 'FILENAME + '(LAMBDA (USELESS) + (WAIT-FOR-FILE . FILENAME)))) + (ALARMCLOCK 'TIME 60.)) + (DEFUN WAIT-FOR-FILE FEXPR (FILENAME) + (COND + ((APPLY 'UPROBE FILENAME) + (TYO 7.) + (TYPE + '";YOUR COMPILATION IS FINISHED." + EOL) + (SETQ ALARMCLOCK NIL)) + ((ALARMCLOCK 'TIME 60.)))) + (DEFINE COMPILED-FUNCTION-SETUP FEXPR (COMPILED-FUNCTION) + (TO-:COMPILED (CAR COMPILED-FUNCTION))) + (DEFUN TO-:COMPILED (COMPILED-FUNCTION) + (SETQ :CONTENTS (DELQ COMPILED-FUNCTION :CONTENTS) + :BURIED (DELQ COMPILED-FUNCTION :BURIED)) + (AND (EQ FN COMPILED-FUNCTION) + (SETQ FN NIL PROMPTER NO-VALUE)) + (UNITE COMPILED-FUNCTION ':COMPILED)) + (DEFUN TO-:CONTENTS (INTERPRETED-FUNCTION) + (SETQ :COMPILED (DELQ INTERPRETED-FUNCTION :COMPILED)) + (UNITE INTERPRETED-FUNCTION ':CONTENTS))] + +;;FLUSHCOMPILED AND FLUSHINTERPRETED ARE USEFUL IN SWITCHING BACK AND FORTH BETWEEN +;;COMPILED AND INTERPRETED VERSIONS OF THE SAME FUNCTIONS. + +[(OR ITS MULTICS) (DEFINE FLUSHCOMPILED (ABB FLC) NIL + (MAPC '(LAMBDA (SUBR) + (LET ((EXPR-PROP (CAR (REMPROP SUBR + 'EXPR)))) + (AND EXPR-PROP + (TO-:CONTENTS SUBR) + (PUTPROP SUBR + EXPR-PROP + 'EXPR)))) + :COMPILED)) + (DEFINE FLUSHINTERPRETED (ABB FLI) NIL + (MAPC '(LAMBDA (EXPR) + (LET ((SUBR-PROP (CAR (REMPROP EXPR + 'SUBR)))) + (AND SUBR-PROP + (TO-:COMPILED EXPR) + (PUTPROP EXPR + SUBR-PROP + 'SUBR)))) + (DELEET :CONTENTS :BURIED)))] + +;;*PAGE + +;;EVALUATION + +(DEFUN EVALS EXPR (X) + ;;MAPS EVAL ONTO A LIST RETURNING THE VALUE OF THE LAST ELEMENT. + (COND ((ATOM X) X) + ((NULL (CDR X)) (EVAL (CAR X))) + (T (EVAL (CAR X)) (EVALS (CDR X))))) + +;;SPECIAL SYNONYM FOR EVALS WITHIN PARSEMACRO. USED BY ERROR HANDLER TO DETECT +;;ERRORS WITHIN PARSEMACROS. + +(DEFINE PARSEMACRO-EVAL (SYN EVALS)) + +(DEFINE RUN (PARSE 1.) (X) + ;;LOGO EQUIVALENT OF EVAL. IF INPUTS TO RUN FAIL TO PARSE, WILL CAUSE (ERR + ;;'REREAD). + (LET + ((RESULT (ERRSET (PARSELINE (COND ((ATOM X) (LIST X)) (X)) T)))) + (COND + ((EQ RESULT 'REREAD) + (SETQ X + (ERRBREAK 'RUN + (LIST '" UNABLE TO PARSE INPUTS TO RUN" + '" INPUT WAS " + X))) + (RUN X)) + ((EVALS (CAR RESULT)))))) + +[CLOGO (DEFINE DO (PARSE (PARSE-CLOGO-HOMONYM RUN L)))] + +;;*PAGE + +;;CLOCKS AND TIME +;;; +;;;LOGO PRIMITIVES +;;; +;;;CLOCK = TIME SINCE LOGIN OR LAST RESET +;;;RESET = RESETS CLOCK +;;;DATE = DAY/MONTH/YEAR (AS A WORD) +;;;TIME = HOUR/MINUTE/SECOND +;;;COMPUTE = COMPUTATION TIME USED BY JOB +;;;WAIT = PUTS LOGO TO SLEEP +;;; +;;;LISP PRIMITIVES +;;; +;;;TIME = ACCESSES SYSTEM REAL-TIME CLOCK. OUTPUT IN SECONDS. +;;; (LOGO CLOCK WITHOUT RESETTING CAPABILITY). +;;;SETTIME = LOGO RESET (NO LONGER EXISTS IN LISP) +;;;DATE = LOGO DATE (STATUS CALL) RETURNS (YEAR MONTH DAY) +;;;DAYTIME = LOGO TIME (STATUS CALL) +;;;RUNTIME = LOGO COMPUTE (STATUS CALL) +;;;SLEEP = LOGO WAIT (INPUT IN SECONDS) +;;; +;;;ALARMCLOCK TWO TYPES OF ALARMCLOCKS ARE AVAILABLE NOW - REAL ELAPSED +;;; TIME, AND CPU RUNTIME USED BY JOB IN QUESTION. FIRST ARG +;;; SPECIFIES WHICH TIMER TO USE, AND SECOND ARG SPECIFIES INTERVAL +;;; TO WAIT, EXCEPT THAT A NEGATIVE SECOND ARG MEAN SHUT OFF THAT +;;; TIMER. FIRST ARG = "RUNTIME" => WAIT FOR ELAPSED RUNTIME +;;; IN UNITS OF MICROSECONDS; FIRST ARG = "TIME" => WAIT FOR ELAPSED +;;; REALTIME IN UNITS OF SECONDS. SECOND ARG MAY BE EITHER FIXED OR +;;; FLOATING POINT. VALUE RETURNED IS T IF A TIMER WAS JUST SET, +;;; AND NIL IF IT WAS TURNED OFF. + +(SETQ CLOCK 0.0) + +;;TIME OF LAST RESET. + +(DEFINE SLEEP (ABB WAIT)) + +;;PUTS LLOGO TO SLEEP FOR ARG SECONDS. + +(DEFINE RUNTIME (ABB COMPUTE)) + +;;COMPUTATION TIME IN MICROSECONDS OF LLOGO. + +(DEFINE DAYTIME NIL + ;;RETURNS LIST = (HOUR MIN SEC) + (STATUS DAYTIME)) + +(DEFINE TIME (PARSE (PARSE-SUBSTITUTE 'DAYTIME))) + +(DEFINE DATE NIL (STATUS DATE)) + +;;DATE AS (YEAR MONTH DAY). + +(DEFINE RESETCLOCK NIL (SETQ CLOCK (TIME)) NO-VALUE) + +;;RESETS CLOCK TO 0. + +(DEFINE CLOCK NIL (DIFFERENCE (TIME) CLOCK)) + +;;TIME SINCE LOGIN OR LAST RESET IN THIRTIETHS OF A SECOND. +;;*PAGE + +;;; ASSIGNMENT +;;; +;;LOGO INPUTS ARE PREFIXED BY : FOR CLARITY IN LLOGO ALTHOUGH LISP'S LIST STRUCTURE +;;DOES NOT REQUIRE THIS.MAKE DETECTS ATTEMPTS TO SET SYSTEM VARIABLES [SUCH ATTEMPTS +;;PRINT WARNING MESSAGE]. ALSO, VARIABLES DECLARED READ ONLY CANNOT BE SET BY MAKE. +;;A SYSTEM-VARIABLE PROPERTY FLAGS VARIABLES USED BY THE SYSTEM. SOMEDAY, THE +;;DEFINITION OF : SHOULD BE CHANGED SO THAT THE VALUE OF :FOO IS KEPT ON THE LISP +;;ATOM FOO, NOT :FOO, SO THAT MAKE WILL NOT HAVE TO DO EXPENSIVE EXPLODE/IMPLODE. + +(DEFINE MAKE (ABB M) (NAME THING) + (COND + ((WORDP NAME) + (SETQ NAME (IMPLODE (CONS ': (EXPLODEC NAME)))) + (LET + ((SYSTEM-VARIABLE-PROP (GET NAME 'SYSTEM-VARIABLE))) + (COND + ((NULL SYSTEM-VARIABLE-PROP)) + ((EQ SYSTEM-VARIABLE-PROP 'READ-ONLY) + (ERRBREAK + 'MAKE + '"YOU CAN'T CHANGE THE VALUE OF A SYSTEM VARIABLE")) + ((EQ SYSTEM-VARIABLE-PROP 'READ-WRITE) + (TYPE '";CHANGING A SYSTEM NAME" EOL)) + ((LISPBREAK + '"SYSTEM BUG -- BAD SYSTEM VARIABLE PROPERTY IN MAKE"))) + (COND (:CAREFUL (UNITE NAME ':NAMES))) + (SET NAME THING))) + ((SETQ NAME + (ERRBREAK 'MAKE + (LIST '" - FIRST INPUT TO MAKE " + NAME + '" IS NOT A WORD"))) + (MAKE NAME THING)))) + +(DEFINE MAKEQ (ABB MQ) (PARSE (PARSE-SETQ)) FEXPR (ARGLIST ENV) + (DO ((THING)) + ((NULL ARGLIST) THING) + (MAKE (CAR ARGLIST) (SETQ THING (EVAL (CADR ARGLIST) ENV))) + (SETQ ARGLIST (CDDR ARGLIST)))) + +(DEFINE INFIX-MAKE (SYN MAKE)) + +(DEFINE SETQ (PARSE (PARSE-SETQ))) + +(DEFUN SYSTEM-VARIABLE FEXPR (SYSTEM-VARIABLES) + (MAPC '(LAMBDA (SYSTEM-VARIABLE) (OBTERN SYSTEM-VARIABLE LOGO-OBARRAY) + (PUTPROP SYSTEM-VARIABLE + 'READ-WRITE + 'SYSTEM-VARIABLE)) + SYSTEM-VARIABLES)) + +(SYSTEM-VARIABLE :PARENBALANCE :CAREFUL :EDITMODE :ERRBREAK :LISPBREAK :REDEFINE) + +;;LLOGO SYSTEM VARIABLES WHICH CAN BE EXAMINED, BUT IF SET DIRECTLY BY USER WOULD +;;LEAVE STATE INCONSISTENT [I.E. SOME ADDITIONAL ACTION MUST BE PERFORMED WHEN THEY +;;ARE CHANGED] ARE DECLARED READ-ONLY. MAKE WILL REFUSE TO CHANGE THEM. ANY +;;ATTEMPT TO DO SO WILL RESULT IN ERROR. + +(DEFUN READ-ONLY FEXPR (HANDS-OFF) + (MAPC '(LAMBDA (READ-ONLY-VARIABLE) (OBTERN READ-ONLY-VARIABLE LOGO-OBARRAY) + (PUTPROP READ-ONLY-VARIABLE + 'READ-ONLY + 'SYSTEM-VARIABLE)) + HANDS-OFF)) + +(READ-ONLY :BURIED + :COMPILED + :CONTENTS + :ECHOLINES + :EMPTY + :EMPTYS + :EMPTYW + :INFIX + :NAMES + :PI + :SNAPS + :SCREENSIZE + :WINDOWS) + +(DEFINE THINGP (NAME) (BOUNDP (MAKLOGONAM NAME))) + +(DEFINE THING (ABB :) (X) + (COND ((WORDP X) (SYMEVAL (IMPLODE (CONS ': (EXPLODEC X))))) + ((SETQ X + (ERRBREAK 'THING + (LIST '" - INPUT " + X + '" TO THING IS NOT A WORD"))) + (THING X)))) + +(DEFINE STORE (PARSE (PARSE-STORE))) + +(FILLARRAY (ARRAY DEFINEARRAY-TYPE T 3.) '(FIXNUM FLONUM T)) + +(DEFINE DEFINEARRAY (ABB DEFAR) (PARSE 3. L) ARG-COUNT + ;;11LOGO'S ARRAY CONSTRUCTION COMMAND. + (APPLY '*ARRAY + (CCONS (ARG 1.) + (DEFINEARRAY-TYPE (ARG ARG-COUNT)) + (CDR (LISTIFY (1- ARG-COUNT)))))) + +;;*PAGE + +;;FIRST, BUTFIRST, LAST, BUTLAST, COUNT, SENTENCE AND WORD. +;;;MAKNAM VERSUS READLIST +;;; +;;;READLIST IS REQUIRED FOR GENERATING NUMBERS FROM STRING OF CHARACTERS. +;;;READLIST, HOWEVER, FAILS IF SINGLE CHARACTER OBJECTS ARE INCLUDED. +;;;(WORD '* 1) WILL LOSE. TWO SOLUTIONS ARE: +;;; +;;;1. TAILOR MAKE A READTABLE FOR THESE FUNCTIONS. ALMOST ALL +;;;CHARACTERS WOULD BE ORDINARY LETTERS EXCEPT THE DIGITS AND -. +;;; +;;;2. MAKNAM IGNORES CHARACTER SYNTAX. IT PRODUCES A PNAME TYPE ATOM +;;;REGARDLESS OF THE CHARACTER SYNTAX. HENCE, A READLIST COULD BE +;;;ATTEMPTED INSIDE AN ERRSET. IF IT LOSES, THEN INTERN OF MAKNAM +;;;COULD BE USED. THIS TAKES MORE TIME AND LESS SPACE THAN 1. +;;;(NOTE THIS STILL LOSES ON MAKING NEGATIVE NUMBERS. THE SYNTAX +;;;OF - IS THAT OF A SCO AND NOT THE - SIGN) +;;; +;;;EXPLODEC RATHER THAN EXPLODE IS NEEDED. MAKNAM WOULD INSERT +;;;SLASHES PRODUCED BY EXPLODE. +;;; +;;;ON THIS OBARRAY WHEN USED FROM LISP. ALTERNATIVELY, IT COULD SIMPLY +;;;INTERN ON THE CURRENT OBARRAY. PROBABLY WITHOUT ANY LOSSAGE. +;;; + +(DEFUN LOGOREADLIST (CHARLIST) + ;;LOGOREADLIST USES READLIST TO SEE IF STUFF TURNS OUT TO BE A NUMBER, IF SO + ;;USE NUMBER. ELSE IGNORE CHAR SYNTAX AND RETURN INTERN OF MAKNAM. + (LET ((READWORD (CAR (ERRSET (READLIST CHARLIST) NIL)))) + (COND ((NUMBERP READWORD) READWORD) ((IMPLODE CHARLIST))))) + +(DEFINE FIRST (ABB F) (X) + (COND ((EMPTYP X) + ;;;(SETQ X ...) (FIRST X) RATHER THAN (FIRST ...) SO THAT + ;;;FROM INSIDE THE ERRBREAK, STACK HACKER WILL FIND THE + ;;;OFFENDING CALL TO FIRST. + (SETQ X + (ERRBREAK 'FIRST + '"FIRST OF AN EMPTY THING")) + (FIRST X)) + ((NUMBERP X) (LOGOREADLIST (LIST (CAR (EXPLODEC X))))) + ((WORDP X) (LOGOREADLIST (LIST (GETCHAR X 1.)))) + ((CAR X)))) + +(DEFINE BUTFIRST (ABB BF) (X) + (COND ((EMPTYP X) + (SETQ X + (ERRBREAK 'BUTFIRST + '"BUTFIRST OF AN EMPTY THING")) + (BUTFIRST X)) + ((ATOM X) (LOGOREADLIST (CDR (EXPLODEC X)))) + ((CDR X)))) + +(DEFINE LAST (PARSE (PARSE-SUBSTITUTE 'LOGO-LAST))) + +;(DEFINE NTH (POSITION LIST) +; ;;THE CLASSIC NTH FUNCTION. FINDS THE NTH ELEMENT IN A LIST. INSERT ERROR +; ;;CHECKING -- BAD POSITION NUMBER, TOO SHORT LIST, ETC. +; (DO NIL ((= POSITION 1.) (CAR LIST)) (POP LIST) (DECREMENT POSITION))) + +(DEFINE LOGO-LAST (ABB LA) (UNPARSE (UNPARSE-SUBSTITUTE 'LAST)) (X) + (COND ((EMPTYP X) + (SETQ X + (ERRBREAK 'LOGO-LAST + '" LAST OF AN EMPTY THING")) + (LOGO-LAST X)) + ((NUMBERP X) (LOGOREADLIST (LAST (EXPLODEC X)))) + ;;GETCHAR LOSES ON NUMBERS. + ((WORDP X) (GETCHAR X (FLATC X))) + ((CAR (LAST X))))) + +(DEFINE BUTLAST (ABB BL) (X) + (COND ((EMPTYP X) + (SETQ X + (ERRBREAK 'BUTLAST + '" BUTLAST OF AN EMPTY THING")) + (BUTLAST X)) + ((ATOM X) + ;;SPLICE OUT LAST ELEMENT FROM LIST OF CHARACTERS, THEN ATOMIZE. + (LET ((EXPLODED-ATOM (EXPLODEC X))) + (RPLACA (LAST EXPLODED-ATOM) :EMPTYW) + (LOGOREADLIST EXPLODED-ATOM))) + ;;ALL BUT THE LAST ELEMENT OF A LIST. + ((MAPCON '(LAMBDA (LIST-ELEMENTS) (COND ((NULL (CDR LIST-ELEMENTS)) NIL) + ((LIST (CAR LIST-ELEMENTS))))) + X)))) + +(DEFINE COUNT (X) (COND ((WORDP X) (FLATC X)) ((LENGTH X)))) + +(DEFINE JOIN (SYN LIST) (PARSE 2. L)) + +[/11LOGO (DEFINE LIST (PARSE 2. L))] + +(DEFINE FPUT (PARSE 2. L) ARGS + (COND ((NOT (LISTP (ARG ARGS))) + (SETARG ARGS + (ERRBREAK 'FPUT + (LIST '"THE LAST INPUT " + (ARG ARGS) + '" IS NOT A LIST"))) + (APPLY 'FPUT (LISTIFY ARGS))) + ((DO ((I (1- ARGS) (1- I))) + ((= 0. I) (ARG ARGS)) + (SETARG ARGS (CONS (ARG I) (ARG ARGS))))))) + +[(OR ITS DEC10) (ARGS 'FPUT '(2. . 77.))] + +(DEFINE LPUT (PARSE 2. L) ARGS + (COND ((NOT (LISTP (ARG ARGS))) + (SETARG ARGS + (ERRBREAK 'LPUT + (LIST '"THE LAST INPUT " + (ARG ARGS) + '" IS NOT A LIST"))) + (APPLY 'LPUT (LISTIFY ARGS))) + ((APPEND (ARG ARGS) (LISTIFY (1- ARGS)))))) + +[(OR ITS DEC10) (ARGS 'LPUT '(2. . 77.))] + +(DEFINE SENTENCE (ABB S SE) (PARSE 2. L) ARGS + (DO ((I ARGS (1- I)) (FRAGMENT)) + ((= I 0.) FRAGMENT) + (SETQ FRAGMENT (APPEND (COND ((WORDP (ARG I)) (LIST (ARG I))) ((ARG I))) + FRAGMENT)))) + +[(OR ITS DEC10) (ARGS 'SENTENCE '(1. . 77.))] + +(DEFUN WORD-EXPLODE (WORD) + (COND + ((WORDP WORD) (EXPLODEC WORD)) + ((SETQ WORD + (ERRBREAK 'WORD + (LIST '"THE INPUT " + WORD + '" TO WORD WAS NOT A WORD"))) + (WORD-EXPLODE WORD)))) + +(DEFINE WORD (ABB WD &) (PARSE 2. L) ARGS + (LOGOREADLIST (DO ((I ARGS (1- I)) (FRAGMENT)) + ((= I 0.) FRAGMENT) + (SETQ FRAGMENT (NCONC (WORD-EXPLODE (ARG I)) FRAGMENT))))) + +[(OR ITS DEC10) (ARGS 'WORD '(2. . 77.))] + +(DEFINE CHAR (SYN ASCII)) + +(DEFINE BELL NIL (TYO 7.) NO-VALUE) + +;;*PAGE + +;;ERASING PROCEDURES + +(DEFUN ERASE-PROCEDURE (ERASE-IT) + (SETQ :CONTENTS (DELQ ERASE-IT :CONTENTS) :BURIED (DELQ ERASE-IT :BURIED)) + (AND (EQ FN ERASE-IT) (SETQ FN NIL PROMPTER NO-VALUE)) + (UNTRACE1 ERASE-IT) + (REMPROP ERASE-IT 'EXPR)) + +(DEFINE ERASE (ABB ER) FEXPR (X) + (COND + ((NULL X) NO-VALUE) + ((MEMQ (CAR X) '(PRIM PRIMITIVE)) (ERASEPRIM (CADR X))) + ((MEMQ (CAR X) '(ABB ABBREVIATION)) (ERASEABB (CADR X))) + ((EQ (CAR X) 'LINE) (ERASELINE (CADR X))) + ((EQ (CAR X) 'NAMES) (ERASENAMES)) + ((EQ (CAR X) 'NAME) (APPLY 'ERASENAME (MAKLOGONAM (CADR X)))) + ((EQ (CAR X) 'PROCEDURES) (ERASEPROCEDURES)) + ((EQ (CAR X) 'ALL) (ERASEALL)) + ((EQ (CAR X) 'TRACE) (APPLY 'ERASETRACE (CDR X))) + ((EQ (CAR X) 'BURY) (APPLY 'ERASEBURY (CDR X))) + ((EQ (CAR X) 'FILE) (APPLY 'ERASEFILE (CDR X))) + ((EQ (CAR X) 'COMPILED) (APPLY 'ERASE :COMPILED)) + [ITS ((EQ (CAR X) 'WINDOWS) (APPLY 'ERASEWINDOWS NIL)) + ((EQ (CAR X) 'WINDOW) (APPLY 'ERASEWINDOW (CDR X)))] + ((MAPC + '(LAMBDA (ERASE-IT) + (COND ((MEMQ ERASE-IT :CONTENTS) + (ERASE-PROCEDURE ERASE-IT) + (TYPE '/; + ERASE-IT + '" ERASED" + EOL)) + ((MEMQ ERASE-IT :COMPILED) + (SETQ :COMPILED (DELQ ERASE-IT :COMPILED)) + [(OR ITS DEC10) (ARGS ERASE-IT NIL)] + (TYPE '/; + ERASE-IT + '" ERASED" + EOL) + (UNTRACE1 ERASE-IT) + (REMPROP ERASE-IT (CAR (GETL ERASE-IT '(SUBR LSUBR))))) + ((MEMQ ERASE-IT :NAMES) (ERASENAME ERASE-IT)) + [ITS ((MEMQ ERASE-IT :SNAPS) + (REMSNAP (SYMEVAL ERASE-IT)) + (TYPE '/; + ERASE-IT + '" ERASED" + EOL))] + ((TYPE '/; + ERASE-IT + '" NOT FOUND" + EOL)))) + X) + NO-VALUE))) + +(SETQ :SNAPS NIL :WINDOWS NIL) + +(DEFUN EXPUNGE (ATOM) + (REMPROP ATOM + (CAR (GETL ATOM + '(EXPR FEXPR MACRO SUBR LSUBR FSUBR ARRAY AUTOLOAD)))) + (MAPC '(LAMBDA (PROP) (REMPROP ATOM PROP)) + '(PARSE UNPARSE PARSE-INFIX UNPARSE-INFIX INFIX-PRECEDENCE READ-ONLY)) + (UNTRACE1 ATOM)) + +(DEFINE ERASEPROCEDURES (ABB ERP ERPR) NIL + (LET ((TO-BE-ERASED (APPEND :COMPILED (DELEET :CONTENTS :BURIED)))) + (OR TO-BE-ERASED + (TYPE '";ALL PROCEDURES ERASED" EOL)) + (APPLY 'ERASE TO-BE-ERASED)) + NO-VALUE) + +(DEFUN ERASENAME (VARIABLE-NAME) + (COND ((GET VARIABLE-NAME 'SYSTEM-VARIABLE)) + (T (SETQ :NAMES (DELQ VARIABLE-NAME :NAMES)) + (TYPE '/; + VARIABLE-NAME + '" ERASED" + EOL) + (MAKUNBOUND VARIABLE-NAME)))) + +(DEFINE ERASENAMES (ABB ERN) NIL + ;;MAKUNBOUND SETS THE VALUE PROPERTY TO THE + ;;SYSTEM'S UNBOUND MARKER. REMPROP OF VALUE + ;;PROPERTY WOULD SCREW COMPILED CODE. ERASE ALL + ;;NAMES + (MAPC 'ERASENAME :NAMES) + NO-VALUE) + +(DEFINE ERASEFILE (ABB ERF) (PARSE F) FEXPR (X) + (OR X + (ERRBREAK 'ERASEFILE + '"NO INPUT TO ERASEFILE? ")) + [ITS (APPLY 'UREAD (COND ((CDR X) (FILESPEC X)) ((APPEND X '(<))))) + (SETQ X (STATUS UREAD)) + (APPLY 'UREAD (LIST (CAR X) '>)) + (COND + ((AND + (EQUAL X (STATUS UREAD)) + (TYPE + '/; + X + '" IS YOUR LAST COPY. WOULD YOU LIKE TO ERASE IT? ") + (NOT (ASK))) + (TYPE '";NOT ERASED")) + ((APPLY 'UKILL X) + (TYPE '/; X '" ERASED")))] + [(OR DEC10 MULTICS) (APPLY 'UKILL (SETQ X (FILESPEC X))) + (TYPE '/; X '" ERASED" EOL)] + ?) + +(DEFINE ERASEALL (ABB ERA) NIL (ERASENAMES) (ERASEPROCEDURES) ?) + +(DEFINE ERASEABB (Z) + (COND ((ABBREVIATIONP Z) + (REMPROP Z + [(OR ITS DEC10) (CAR (GETL Z '(EXPR FEXPR)))] + [MULTICS 'EXPR]) + (LIST '/; Z '" ERASED")) + ((SETQ Z + (ERRBREAK 'ERASEABB + (LIST Z + '" IS NOT AN ABBREVIATION"))) + (ERASEABB Z)))) + +(DEFINE ERASEPRIM (X) + (COND ((PRIMITIVEP X) + (EXPUNGE X) + [ITS (ARGS X NIL)] + (LIST '/; X 'ERASED)) + ((SETQ X + (ERRBREAK 'ERASEPRIM + (LIST X + '" IS NOT A PRIMITIVE"))) + (ERASEPRIM X)))) + +(DEFINE ERASETRACE (ABB ERTR) FEXPR (Y) + (COND ((NULL Y) (SETQ Y (DEFAULT-FUNCTION 'ERASETRACE NIL))) + (T (SETQ Y (CAR Y)))) + (UNTRACE1 Y) + (TYPE '";TRACE ON " + Y + '" ERASED" + EOL) + ?) + +;;*PAGE + +;;CONTROL + +(DEFINE GO (ABB GTL) (PARSE (PARSE-GO)) (SYN GO)) + +(DEFINE OUTPUT (SYN RETURN) (ABB OP)) + +;;OUTPUT IS USED IN THE FOLLOWING DEFINITION INSTEAD OF RETURN TO PLEASE THE +;;COMPILER. + +(DEFINE STOP NIL (OUTPUT NO-VALUE)) + +;;IN CLOGO, TESTFLAG IS LOCAL TO THE PROCEDURE. THUS TEST'S IN SUBS DO NOT EFFECT +;;VALUE OF TESTFLAG IN CALLING PROCEDURE. IN LLOGO, TESTFLAG IS GLOBAL AND SUBS DO +;;EFFECT SUPERPROCEDURE. + +(DEFINE TEST (X) (SETQ TESTFLAG X)) + +(DEFINE IFTRUE (ABB IFT) (PARSE L) FEXPR (X) + (AND TESTFLAG (NOT (EQ TESTFLAG 'FALSE)) (EVALS X))) + +(DEFINE IFFALSE (ABB IFF) (PARSE L) FEXPR (X) + (AND (OR (NOT TESTFLAG) (EQ TESTFLAG 'FALSE)) (EVALS X))) + +(DEFINE IF (PARSE (PARSEIF))) + +;;REPRESENTED AS COND +;;; +;;; Iteration +;;; +;;;(DECLARE (FIXNUM ITERATIONS)) +;;REPEAT forms in body a finite number of times. First arg number of iterations. +;;Loops return the last form evaluated. + +(DEFINE REPEAT (ABB RP) (PARSE L) FEXPR (ARG-LIST ENV) + (LET ((ITERATIONS (EVAL (CAR ARG-LIST) ENV)) (REPEAT-BODY (CDR ARG-LIST))) + (DO ((REPEAT-COUNT 1. (1+ REPEAT-COUNT)) (REPEAT-VALUE NO-VALUE)) + ((> REPEAT-COUNT ITERATIONS) REPEAT-VALUE) + (SETQ REPEAT-VALUE (EVALUATE-BODY REPEAT-BODY ENV))))) + +(DEFUN EVALUATE-BODY (REPEAT-FORMS ENV) + ;;Does body evaluation for iterations. + (DO ((REPEAT-VALUE (EVAL (CAR REPEAT-FORMS) ENV) + (EVAL (CAR REPEAT-FORMS) ENV))) + ((NULL (POP REPEAT-FORMS)) REPEAT-VALUE))) + +;;WHILE repeats its body while the first form evaluates to non-nil. + +(DEFINE WHILE (PARSE L) FEXPR (ARG-LIST ENV) + (DO ((REPEAT-BODY (CDR ARG-LIST)) + (STOP-CONDITION (CAR ARG-LIST)) + (REPEAT-VALUE NO-VALUE)) + ((NULL (EVAL STOP-CONDITION ENV)) REPEAT-VALUE) + (SETQ REPEAT-VALUE (EVALUATE-BODY REPEAT-BODY ENV)))) + +;;UNTIL ... is like WHILE NOT ... + +(DEFINE UNTIL (PARSE L) FEXPR (ARG-LIST ENV) + (DO ((REPEAT-BODY (CDR ARG-LIST)) + (STOP-CONDITION (CAR ARG-LIST)) + (REPEAT-VALUE NO-VALUE)) + ((EVAL STOP-CONDITION ENV) REPEAT-VALUE) + (SETQ REPEAT-VALUE (EVALUATE-BODY REPEAT-BODY ENV)))) + +;;Repeat forever in infinite loop. + +(DEFINE FOREVER (PARSE L) FEXPR (ARG-LIST ENV) + (DO NIL (NIL) (MAPC '(LAMBDA (FORM) (EVAL FORM ENV)) ARG-LIST))) + +(DEFINE DO (PARSE (PARSE-DO)) (UNPARSE (UNPARSE-DO))) + +;;Loops have zero precedence since all their args are forms to be evaluated. + +(DEFPROP DO 0. INFIX-PRECEDENCE) + +(DEFPROP REPEAT 0. INFIX-PRECEDENCE) + +(DEFPROP WHILE 0. INFIX-PRECEDENCE) + +(DEFPROP UNTIL 0. INFIX-PRECEDENCE) + +(DEFPROP FOREVER 0. INFIX-PRECEDENCE) + +;;*PAGE + +;;ARITHMETIC + +(DEFINE ROUNDOFF (PARSE 1. L) ARGS + ;;THE SECOND ARGUMENT IS OPTIONAL. WHEN GIVEN IT ROUNDS OFF TO ARG2 DIGITS + ;;AFTER A DECIMAL POINT + (COND ((FIXP (ARG 1.)) (ARG 1.)) + ((LET ((UNROUNDED (FLOAT (ARG 1.)))) + (COND ((= ARGS 1.) (ROUND UNROUNDED)) + ((LET ((TEN-TO-PLACES (^$ 10.0 (FIX (ARG 2.))))) + (//$ (FLOAT (ROUND (*$ UNROUNDED TEN-TO-PLACES))) + TEN-TO-PLACES)))))))) + +[(OR ITS DEC10) (ARGS 'ROUNDOFF '(1. . 2.))] + +(DEFINE RANDOM (PARSE (PARSE-SUBSTITUTE 'LOGO-RANDOM))) + +(DEFINE LOTS NIL 9999999999.) + +(DEFINE LOGO-RANDOM (PARSE 0. L) (UNPARSE (UNPARSE-SUBSTITUTE 'RANDOM)) ARGS + ;;(RANDOM) RETURNS A RANDOM NUMBER BETWEEN 0 AND 1. (RANDOM LOWER UPPER) + ;;RETURNS A RANDOM NUMBER INCLUSIVE BETWEEN LOWER AND UPPER. IF BOTH ARE + ;;FIXED POINT, THEN SO IS THE RANDOM NUMBER RETURNED. THUS (RANDOM 0 9) + ;;RETURNS A RANDOM DIGIT, WHILE (RANDOM 0.0 9) RETURNS A FLOATING POINT + ;;NUMBER BETWEEN 0.0 AND 9.0. THE LSH GUARANTEES + CHECK FOR FIXED POINT + ;;BOUNDS + (LET ((RANDOM (//$ (FLOAT (LSH (RANDOM) -1.)) 3.4359737E+10))) + (COND ((= ARGS 0.) RANDOM) + ((AND (FIXP (ARG 1.)) + (FIXP (ARG 2.)) + (FIX (PLUS (ARG 1.) + (TIMES (DIFFERENCE (ARG 2.) -1. (ARG 1.)) + RANDOM))))) + ((PLUS (ARG 1.) (TIMES (DIFFERENCE (ARG 2.) (ARG 1.)) RANDOM)))))) + +[(OR ITS DEC10) (ARGS 'RANDOM '(0. . 2.))] + +(DEFINE DIFFERENCE (ABB DIFF) (PARSE 2. L)) + +(DEFINE INFIX-DIFFERENCE (SYN DIFFERENCE) (PARSE 2. L)) + +(DEFINE - (PARSE (PARSE-SUBSTITUTE 'PREFIX-MINUS))) + +(DEFINE PREFIX-MINUS (SYN MINUS) (PARSE 1.) (UNPARSE (UNPARSE-SUBSTITUTE '-))) + +(DEFINE + (PARSE (PARSE-SUBSTITUTE 'PREFIX-PLUS))) + +(DEFINE PREFIX-PLUS (SYN USER-PAREN) (UNPARSE (UNPARSE-SUBSTITUTE '+))) + +(DEFINE QUOTIENT (ABB QUO) (PARSE 2.)) + +(DEFINE INFIX-QUOTIENT (SYN QUOTIENT) (PARSE 2. L)) + +(DEFINE PLUS (ABB SUM) (PARSE 2. L)) + +(DEFINE INFIX-PLUS (SYN PLUS) (PARSE 2. L)) + +(DEFINE TIMES (ABB PRODUCT PROD) (PARSE 2. L)) + +(DEFINE INFIX-TIMES (SYN TIMES) (PARSE 2. L)) + +(DEFINE INFIX-EXPT (SYN EXPT)) + +(DEFINE MAX (ABB MAXIMUM) (PARSE 2. L)) + +(DEFINE MIN (ABB MINIMUM) (PARSE 2. L)) + +(DEFINE REMAINDER (ABB MOD)) + +(DEFINE INFIX-REMAINDER (SYN REMAINDER) (PARSE 2.)) + +;;FLONUM REMAINDER. + +(DEFUN \$ (MODULAND MODULUS) + (-$ MODULAND (*$ MODULUS (FLOAT (FIX (//$ MODULAND MODULUS)))))) + +;;LISP'S TRIG FUNCTIONS OPERATE IN TERMS OF RADIANS, THESE USE DEGREES. + +(SETQ :PI 3.1415926 PI-OVER-180 (//$ :PI 180.0)) + +(DEFINE SINE (X) (SIN (TIMES X PI-OVER-180))) + +(DEFINE COSINE (X) (COS (TIMES X PI-OVER-180))) + +(DEFINE ARCTAN (ABB ATANGENT) (X Y) (//$ (ATAN (FLOAT X) (FLOAT Y)) PI-OVER-180)) + +;;*PAGE + +;;PREDICATE OPERATIONS + +(DEFINE CONTENTSP (X) (MEMQ X :CONTENTS)) + +(DEFINE PRIMITIVEP (X) + ;;(PRIMITIVEP X)=T IF X IS USED BY SYSTEM. + (AND (NOT (MEMQ X :CONTENTS)) + (NOT (MEMQ X :COMPILED)) + [/11LOGO (GETL X '(EXPR FEXPR MACRO SUBR LSUBR FSUBR))] + [CLOGO (OR (GETL X '(EXPR FEXPR MACRO SUBR LSUBR FSUBR)) + (LET ((PARSE-PROP (GET X 'PARSE))) + (AND PARSE-PROP + (NOT (ATOM (CAR PARSE-PROP))) + (EQ (CAAR PARSE-PROP) + 'PARSE-CLOGO-HOMONYM))))])) + +(DEFINE ABBREVIATIONP (ATOM) + (OR (LET ((EXPR-PROP (GET ATOM 'EXPR))) + (AND (ATOM EXPR-PROP) EXPR-PROP)) + [(OR ITS DEC10) (LET ((FEXPR-PROP (GET ATOM 'FEXPR))) + (AND (ATOM FEXPR-PROP) FEXPR-PROP))])) + +(DEFINE GREATERP (ABB GP GREATER GR) (PARSE 2. L)) + +(DEFINE INFIX-GREATERP (SYN GREATERP) (PARSE 2. L)) + +(DEFINE LESSP (ABB LP LESS LE) (PARSE 2. L)) + +(DEFINE INFIX-LESSP (SYN LESSP) (PARSE 2. L)) + +(DEFINE ZEROP (ABB ZP)) + +(DEFINE NUMBERP (ABB NP)) + +(DEFINE INTEGER (ABB INT) (SYN FIX)) + +(SETQ TOL 0.01) + +(DEFINE ISABOUT (X Y) (LESSP (ABS (DIFFERENCE X Y)) TOL)) + +;;USEFUL FOR TESTING APPROXIMATE EQUALITY OF FLOATING POINT + +(DEFINE EQUAL (ABB IS) (PARSE 2.)) + +(DEFINE INFIX-EQUAL (SYN EQUAL) (PARSE 2.)) + +(DEFINE WORDP (ABB WP) (X) (AND X (ATOM X))) + +;;A WORD IS A NON-NIL ATOM. + +(DEFINE MEMBER (ABB MEMBERP MP)) + +;;MEMBER IS A LISP PRIMITIVE. + +(DEFINE BOTH (SYN AND) (ABB B) (PARSE 2. L)) + +(DEFINE AND (PARSE 2. L)) + +(DEFINE EITHER (SYN OR) (ABB EI) (PARSE 2. L)) + +(DEFINE OR (PARSE 2. L)) + +;;EMPTY WORD AND EMPTY SENTENCE + +(SETQ :EMPTYS NIL :EMPTY NIL :EMPTYW (OBTERN (ASCII 0.) LOGO-OBARRAY)) + +(DEFINE EMPTYWP (ABB EWP) (X) (EQ X :EMPTYW)) + +(DEFINE NULL (ABB EMPTYSP ESP)) + +(DEFINE EMPTYP (ABB EP) (X) (OR (NULL X) (EQ X :EMPTYW))) + +(DEFINE SENTENCEP (ABB SP) (Y) + (PROG NIL + (AND (NULL Y) (RETURN T)) + (AND (ATOM Y) (RETURN NIL)) + LOOP (COND ((NULL Y) (RETURN T)) + ((WORDP (CAR Y)) (SETQ Y (CDR Y)) (GO LOOP)) + ((RETURN NIL))))) + +(DEFINE LISTP (X) (OR (NULL X) (EQ 'LIST (TYPEP X)))) + +;; (TYPEP NIL) = SYMBOL. + +[(AND ITS CLOGO) (DEFINE DISPLAY (ABB D) (PARSE (PARSE-CLOGO-HOMONYM STARTDISPLAY + 2.)))] + +(DEFINE LOGO-COMMENT FEXPR (COMMENT) NO-VALUE) + +;;*PAGE + +