github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-20 16:38:16 +00:00
Code Issues Releases Wiki Activity

Fixed llogo.

Browse Source
This commit is contained in:
Eric Swenson
2018-09-25 22:38:42 -07:00
parent 2769e25f06
commit ddbf4d79db
3 changed files with 2066 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

776
src/llogo/error.2 Normal file
View File

@@ -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 <NUMBER>) GO UP <NUMBER> FRAMES.
;;;(UP <ATOM>) GO SEARCHING UP THE STACK FOR AN INVOCATION OF <ATOM>
;;;(UP <ATOM> <NUMBER>) FIND THE <NUMBER>TH INVOCATION OF <ATOM> UP THE STACK.
;;;DOWN IS SIMILAR, EXCEPT PROCEEDS DOWN THE STACK.
;;;DOWN IS EQUIVALENT TO (UP ... - <NUMBER>)
;;THE FUNCTIONS WORK BY THROWING A LIST BACK TO A CATCH IN FRAMEUP.
;;;FORMAT OF LIST IS:
;;; (<FUNCTION> <FUNCTION TO FIND> <NUMBER OF FRAMES> <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
;;; (<EVAL OR APPLY> <STACK-POINTER> <FORM> <ENV>)
;;;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.")]

201
src/llogo/loader.2 Normal file
View File

@@ -0,0 +1,201 @@
(COMMENT NO ALLOCATION)
(PUTPROP (CAR (STATUS UREAD)) (CADR (STATUS UREAD)) 'VERSION)
;;;LOADER > READS IN THE FN "CREATE". (CREATE <LLOGO OR NLLOGO>) 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))

1089
src/llogo/primit.2 Normal file
View File

File diff suppressed because it is too large Load Diff