mirror of
https://github.com/PDP-10/its.git
synced 2026-01-18 01:02:15 +00:00
611 lines
20 KiB
Plaintext
611 lines
20 KiB
Plaintext
;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;; LISP LOGO READER ;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
(DECLARE (OR (STATUS FEATURE DEFINE)
|
||
(COND ((STATUS FEATURE ITS)
|
||
;;MULTICS?
|
||
(FASLOAD DEFINE FASL DSK LLOGO)))))
|
||
|
||
;;;
|
||
;;READ SYNTAX FOR LOGO, LOGO READER, EVALUATION FUNCTIONS
|
||
|
||
(SAVE-VERSION-NUMBER READER)
|
||
|
||
(DECLARE (GENPREFIX READER))
|
||
|
||
;;NEITHER IN LISP NOR LOGO MODE ARE CR'S INSERTED.
|
||
|
||
(SSTATUS TERPRI T)
|
||
|
||
;;; LOGO READTABLE
|
||
;;;
|
||
|
||
((LAMBDA (READTABLE) (SETSYNTAX 39. 'MACRO NIL)
|
||
(SETSYNTAX 59. 'MACRO NIL)
|
||
;;TURN OFF LISP'S SINGLE QUOTE, EXCL, AND SEMICOLON MACROS.
|
||
;;SINGLE-QUOTE HANDLED BY PASS2, SEMICOLON BY PARSER.
|
||
(SETSYNTAX 33. 'MACRO NIL)
|
||
(SETSYNTAX 34. 'MACRO NIL)
|
||
(SETSYNTAX 91. 'MACRO NIL)
|
||
(SETSYNTAX 93. 'MACRO NIL)
|
||
;;TURN OFF LLOGO'S DOUBLE-QUOTE, SQUARE-BRACKET MACROS.
|
||
[CLOGO (SETSYNTAX 20. 'SINGLE 34.)]
|
||
;;CONTROL-T CHANGED TO DOUBLE-QUOTE ON READ-IN FOR COMPATIBLITY
|
||
;;WITH CLOGO.
|
||
(SETSYNTAX 44. 2. NIL)
|
||
;;COMMA IS EXTENDED ALPHABETIC.
|
||
(SETSYNTAX 46. 128. NIL)
|
||
;;PERIOD IS DECIMAL POINT ONLY, NOT CONS DOT. LOGO EDITING
|
||
;;CHARACTERS: MADE SINGLE CHARACTER OBJECTS, BUT ALSO MUST BE
|
||
;;"TTY FORCE FEED" CHARACTERS TO TAKE IMMEDIATE EFFECT.
|
||
;;; 197472. = OCTAL 601540 [600000 = S.C.O., 1040 = T.F.F.,
|
||
;;; 500 = SLASHIFY.]
|
||
;;;
|
||
;;EDITING CHARACTERS -- CONTROL-E, CONTROL-P, CONTROL-R,
|
||
;;CONTROL-S.
|
||
[(OR ITS DEC10) (SETSYNTAX 5. 197472. NIL)
|
||
(SETSYNTAX 16. 197472. NIL)
|
||
(SETSYNTAX 18. 197472. NIL)
|
||
(SETSYNTAX 19. 197472. NIL)]
|
||
;;;
|
||
(MAPC '(LAMBDA (CHARACTER) (SETSYNTAX CHARACTER 'SINGLE NIL))
|
||
;;MULTICS "NEWLINE" IS CONTROL-J [ASCII 10.]
|
||
'([MULTICS 10.]
|
||
[(OR ITS DEC10) 11.
|
||
12.
|
||
13.] [CLOGO 20.] 32. 33. 34. 36. 38.
|
||
39. 40. 41. 42. 43. 45. 47. 59. 60. 61. 62. 91. 92.
|
||
93. 94. 95. 127.))
|
||
;;;DON'T PRINT EXTRA CARRAIGE RETURNS ON LINE OVERFLOW.
|
||
(SSTATUS TERPRI T))
|
||
LOGO-READTABLE)
|
||
|
||
;;; SINGLE CHARACTER OBJECTS IN LOGO ARE:
|
||
;;; CONTROL-J <LINEFEED, IN MULTICS ONLY>, CONTROL-K <NOT IN MULTICS>,
|
||
;;; CONTROL-L <NOT IN MULTICS>, CONTROL-M <CARRAIGE RETURN, NOT IN MULTICS>,
|
||
;;; CONTROL-T, SPACE, DOUBLE-QUOTE, DOLLAR, AMPERSAND, QUOTE, LEFT-PAREN,
|
||
;;; RIGHT-PAREN, STAR, PLUS, MINUS, SLASH, SEMICOLON, LESS, EQUAL, GREATER,
|
||
;;; LEFT-BRACKET, BACKSLASH, RIGHT-BRACKET, UP-ARROW, UNDERSCORE, RUBOUT.
|
||
;;; TTY ACTIVATION CHARACTERS
|
||
;;;
|
||
;;ON ITS, YOUR PROCESS ONLY WAKES UP WHEN ONE OF A GROUP OF "ACTIVATION CHARACTERS"
|
||
;;IS READ. THESE CHARACTERS ARE DIFFERENT FOR LOGO THAN FOR LISP.
|
||
|
||
[ITS (DEFUN ACTIVATE-LISP NIL
|
||
;;LISP WAKES ON SPACE, BACKSPACE, PARENS, BRACKETS, BRACES, LF, TAB
|
||
;;INTERRUPTS ON CONTROL CHARS.
|
||
(SSTATUS TTY 20673790994. 20707344539.))
|
||
(DEFUN ACTIVATE-LOGO NIL
|
||
;;LOGO ACTIVATES ON RUBOUT, CR, SPACE, BACKSPACE, INTERRUPTS ON CONTROL
|
||
;;CHARS. SPACE NEEDED FOR GERMLAND REPEAT.
|
||
(SSTATUS TTY 20673790992. 20673798299.))
|
||
(DEFUN RESTORE-TTY-AND-POP-ERRLIST (TTYST1 TTYST2)
|
||
(APPLY 'SSTATUS (LIST 'TTY TTYST1 TTYST2))
|
||
(POP ERRLIST))
|
||
(DEFUN BIND-ACTIVATE-LOGO NIL
|
||
(LET ((OLD-TTY (STATUS TTY)))
|
||
(PUSH (LIST 'RESTORE-TTY-AND-POP-ERRLIST
|
||
(CAR OLD-TTY)
|
||
(CADR OLD-TTY))
|
||
ERRLIST))
|
||
(ACTIVATE-LOGO))
|
||
(DEFUN BIND-ACTIVATE-LISP NIL
|
||
(LET ((OLD-TTY (STATUS TTY)))
|
||
(PUSH (LIST 'RESTORE-TTY-AND-POP-ERRLIST
|
||
(CAR OLD-TTY)
|
||
(CADR OLD-TTY))
|
||
ERRLIST))
|
||
(ACTIVATE-LISP))
|
||
(DEFUN UNBIND-ACTIVATE NIL (EVAL (CAR ERRLIST)))]
|
||
|
||
(DEFINE LISP NIL
|
||
;;SWITCHES TO LISP MODE OF LISP-LOGO.
|
||
[ITS (ACTIVATE-LISP)]
|
||
(SSTATUS TOPLEVEL NIL)
|
||
(THROW '* EXIT-LOGO-TOPLEVEL))
|
||
|
||
;;;OBARRAY AND READTABLE UNBOUND BY EXITING TOPLEVEL.
|
||
;;;
|
||
|
||
(DEFUN LOGO NIL
|
||
[ITS (ACTIVATE-LOGO)]
|
||
(SSTATUS TOPLEVEL '(TOP-LEVEL)))
|
||
|
||
;;*PAGE
|
||
|
||
;;EVALUATION
|
||
|
||
(SETQ PROMPTER NO-VALUE LOGOREAD NIL)
|
||
|
||
(DEFINE HISTORY (N)
|
||
(SETQ :HISTORY N THIS-FORM-INDEX 0. THIS-VALUE-INDEX 0. THIS-LINE-INDEX 0.)
|
||
(ARRAY FORM-HISTORY T :HISTORY)
|
||
(ARRAY LINE-HISTORY T :HISTORY)
|
||
(ARRAY VALUE-HISTORY T :HISTORY))
|
||
|
||
(HISTORY 5.)
|
||
|
||
(DEFINE LASTLINE (ABB ILINE) ARGS
|
||
(LET ((LINE-INDEX (COND ((ZEROP ARGS) 1.) ((ARG 1.)))))
|
||
(AND (MINUSP (SETQ LINE-INDEX (- THIS-LINE-INDEX LINE-INDEX)))
|
||
(INCREMENT LINE-INDEX :HISTORY))
|
||
(LINE-HISTORY LINE-INDEX)))
|
||
|
||
[(OR ITS DEC10) (ARGS 'LASTLINE '(0. . 1.))]
|
||
|
||
(DEFINE LASTFORM ARGS
|
||
(LET ((FORM-INDEX (COND ((ZEROP ARGS) 1.) ((ARG 1.)))))
|
||
(AND (MINUSP (SETQ FORM-INDEX (- THIS-FORM-INDEX FORM-INDEX)))
|
||
(INCREMENT FORM-INDEX :HISTORY))
|
||
(FORM-HISTORY FORM-INDEX)))
|
||
|
||
[(OR ITS DEC10) (ARGS 'LASTFORM '(0. . 1.))]
|
||
|
||
(DEFINE LASTVALUE ARGS
|
||
(LET ((VALUE-INDEX (COND ((ZEROP ARGS) 1.) ((ARG 1.)))))
|
||
(AND (MINUSP (SETQ VALUE-INDEX (- THIS-VALUE-INDEX VALUE-INDEX)))
|
||
(INCREMENT VALUE-INDEX :HISTORY))
|
||
(VALUE-HISTORY VALUE-INDEX)))
|
||
|
||
[(OR ITS DEC10) (ARGS 'LASTVALUE '(0. . 1.))]
|
||
|
||
(DEFINE THISFORM NIL (LASTFORM 0.))
|
||
|
||
(DEFINE THISLINE NIL (LASTLINE 0.))
|
||
|
||
(DEFUN TOP-LEVEL NIL
|
||
(TERPRI)
|
||
(DPRINC PROMPTER)
|
||
(CATCH (LET ((OBARRAY LOGO-OBARRAY) (READTABLE LOGO-READTABLE) (LOGOVALUE))
|
||
(DO ((LOGOREAD (LOGOREAD) (AND (DPRINC PROMPTER) (LOGOREAD))))
|
||
(NIL)
|
||
(AND (= (INCREMENT THIS-LINE-INDEX) :HISTORY)
|
||
(SETQ THIS-LINE-INDEX 0.))
|
||
(STORE (LINE-HISTORY THIS-LINE-INDEX) PASS2-LINE)
|
||
(MAPC
|
||
'(LAMBDA (LOGO-FORM)
|
||
(AND (= (INCREMENT THIS-FORM-INDEX) :HISTORY)
|
||
(SETQ THIS-FORM-INDEX 0.))
|
||
(STORE (FORM-HISTORY THIS-FORM-INDEX) LOGO-FORM)
|
||
(AND (= (INCREMENT THIS-VALUE-INDEX) :HISTORY)
|
||
(SETQ THIS-VALUE-INDEX 0.))
|
||
(STORE (VALUE-HISTORY THIS-VALUE-INDEX)
|
||
(SETQ LOGOVALUE (EVAL LOGO-FORM))))
|
||
LOGOREAD)
|
||
(COND (LISPPRINT (DPRINT LOGOVALUE) (DTERPRI))
|
||
((EQ LOGOVALUE NO-VALUE))
|
||
((TYPE LOGOVALUE EOL)))))
|
||
EXIT-LOGO-TOPLEVEL))
|
||
|
||
;;TO SIMULATE LOGO FUNCTIONS WHICH DO NOT RETURN A VALUE [SINCE IN LISP EVERY FORM
|
||
;;RETURNS A VALUE] FORMS WHICH RETURN NO-VALUE DO NOT HAVE THEIR VALUES PRINTED BY
|
||
;;THE TOP LEVEL FUNCTION. NOTE THAT LLOGO CANNOT CATCH THE ERROR OF SUCH A FORM
|
||
;;OCCURING INSIDE PARENTHESES. FUNCTIONS RETURNING ? CAUSES TOPLEVEL TO PRINT
|
||
;;SINGLE CR BEFOR PROMPTER. FNS RETURNING CR CAUSES TOPLEVEL TO PRINT DOUBLE CR
|
||
;;BEFORE PROPTER. FNS RETURNING NO-VALUE CAUSE TOPLEVEL TO PRINT NO CR'S BEFORE
|
||
;;PROMPTER.
|
||
|
||
(SETQ ? (ASCII 0.))
|
||
|
||
;;*PAGE
|
||
|
||
;; LOGO READER
|
||
|
||
(SETQ EOF (LIST NIL))
|
||
|
||
(SETQ CONTROL-K (OBTERN (ASCII 11.) LOGO-OBARRAY)
|
||
CONTROL-L (OBTERN (ASCII 12.) LOGO-OBARRAY)
|
||
CTRL-E (OBTERN (ASCII 5.) LOGO-OBARRAY)
|
||
CTRL-P (OBTERN (ASCII 16.) LOGO-OBARRAY)
|
||
CTRL-R (OBTERN (ASCII 18.) LOGO-OBARRAY)
|
||
CTRL-S (OBTERN (ASCII 19.) LOGO-OBARRAY))
|
||
|
||
[(OR DEC10 ITS) (SETQ EOL (ASCII 13.))]
|
||
|
||
[MULTICS (SETQ EOL (ASCII 10.))]
|
||
|
||
;;LOGO READ FUNCTION. RETURNS A LIST OF STUFF READ BETWEEN CARRIAGE RETURNS.
|
||
;;EVENTUALLY, MUCH OF THIS KLUDGY CODE SHOULD BE FLUSHED, IN FAVOR OF UTILIZING
|
||
;;LISP'S (SSTATUS LINMODE T) FEATURE. HOWEVER, THERE IS A PROBLEM WITH GETTING THE
|
||
;;EDITING CONTROL CHARACTERS TO WORK CORRECTLY IN THIS MODE.
|
||
;;;
|
||
;;LOOKS AHEAD TO SEE IF FIRST CHARACTER OF LINE IS #. IF SO, RETURNS LISP-STYLE
|
||
;;READ WITHOUT ANY PROCESSING. WILL NOT DO SO IF FIRST CHARACTER IS SPACE, ETC.
|
||
|
||
(SETQ NULL-LINE (LIST (LIST 'QUOTE NO-VALUE)))
|
||
|
||
(DEFUN LOGOREAD ARGS
|
||
(COND ((= ARGS 0.)
|
||
(LET ((TYIPEEKED (TYIPEEK T)))
|
||
(COND ((= TYIPEEKED 35.)
|
||
(SETQ LISPPRINT T)
|
||
(OR (ERRSET (READ EOF)) NULL-LINE))
|
||
((= TYIPEEKED 3.) (SETQ ^Q NIL) EOF)
|
||
(T (SETQ LISPPRINT NIL) (PARSELINE (LINE NIL))))))
|
||
(T (SETQ LISPPRINT NIL) (PARSELINE (LINE (ARG 1.))))))
|
||
|
||
[(OR ITS DEC10) (ARGS 'LOGOREAD '(0. . 1.))]
|
||
|
||
;;SYNTAX CATEGORIES TO DECIDE WHEN TO MERGE CHARACTERS INTO AN ATOM NAME AFTER
|
||
;;RUBOUT IS TYPED (SEE LINE).
|
||
|
||
(SETQ MERGESTATUS '(1. 2. 128. 260.))
|
||
|
||
;;RETURNS LIST OF SYMBOLS READ UP TO CR.
|
||
|
||
(DEFUN LINE (LINE)
|
||
(PROG (WORD C)
|
||
[(OR ITS DEC10) (AND LINE
|
||
(SETQ C (NREVERSE (EXPLODEC (CAR LINE))))
|
||
;;INITIALIZE RUBOUT VARIABLE.
|
||
(POP LINE))]
|
||
READ (SETQ WORD (READ EOF))
|
||
[(OR ITS DEC10) (COND
|
||
((OR (EQ WORD CONTROL-L) (EQ WORD CONTROL-K))
|
||
(AND ^Q (GO READ))
|
||
[ITS (AND
|
||
;;PROCESS ^L CLEAR SCREEN IF TYPING AT
|
||
;;DATAPOINT.
|
||
(EQ WORD CONTROL-L)
|
||
(MEMBER TTY '(1. 2. 3. 5.))
|
||
(CURSORPOS 'C))]
|
||
(AND (EQ WORD CONTROL-K)
|
||
;;^K => RETYPE LINE
|
||
(TERPRI))
|
||
(DPRINC PROMPTER)
|
||
(MAPC 'DPRINC (REVERSE LINE))
|
||
(MAPC 'DPRINC (REVERSE C))
|
||
(OR C
|
||
(AND LINE
|
||
(SETQ C (NREVERSE (EXPLODEC (CAR LINE))))
|
||
;;SET C SO THAT ^L,^K ARE NOT ATOM BREAKS
|
||
(POP LINE)))
|
||
(DECREMENT CHRCT)
|
||
(GO READ))
|
||
((EQ WORD CTRL-E) (CONTROL-N) (GO READ))
|
||
;;CHECK FOR EDITING CHARS
|
||
((EQ WORD CTRL-P) (CONTROL-P) (GO READ))
|
||
((EQ WORD CTRL-R) (CONTROL-R) (GO READ))
|
||
((EQ WORD CTRL-S) (CONTROL-S) (GO READ)))
|
||
R
|
||
(COND
|
||
((EQ WORD '/)
|
||
;;RUBOUT
|
||
(COND (C)
|
||
((AND LINE (EQ (CAR LINE) '$))
|
||
;;RUBBING OUT STRING?
|
||
(COND [ITS ((MEMBER TTY '(1. 2. 3. 5.))
|
||
(CURSORPOS 'X)
|
||
(INCREMENT CHRCT 3.))]
|
||
((DPRINC '$)))
|
||
(POP LINE)
|
||
(INSTRING)
|
||
(GO READ))
|
||
(LINE
|
||
;;GET CHARS TO BE RUBBED
|
||
(SETQ C (NREVERSE (EXPLODEC (CAR LINE))))
|
||
(POP LINE))
|
||
;;RUBOUT PAST THE BEGINNING OF LINE.
|
||
(T (TERPRI) (PRINC PROMPTER) (GO READ)))
|
||
;;EMPTY, FORGET IT
|
||
(COND
|
||
;;ON DISPLAY COMSOLES, BACKSPACE AND CLEAR TO
|
||
;;END OF LINE. LOSES ON IMLACS. THIS HACK
|
||
;;DOES NOT WORK FOR RUBOUT PAST BEGINNING OF
|
||
;;LINE.
|
||
[ITS ((MEMBER TTY '(1. 2. 3. 5.))
|
||
(CURSORPOS 'X)
|
||
(INCREMENT CHRCT 3.))]
|
||
((DPRINC (CAR C))))
|
||
(COND ((POP C))
|
||
(LINE (SETQ C (NREVERSE (EXPLODEC (CAR LINE))))
|
||
(POP LINE)))
|
||
(GO READ)))
|
||
(COND
|
||
(C
|
||
;;MERGE AFTER RUBOUT
|
||
(COND ((AND (OR (NUMBERP WORD)
|
||
(MEMBER
|
||
(STATUS SYNTAX (GETCHARN WORD 1.))
|
||
MERGESTATUS))
|
||
(OR (NUMBERP (CAR C))
|
||
(MEMBER
|
||
(STATUS SYNTAX (GETCHARN (CAR C) 1.))
|
||
MERGESTATUS)))
|
||
(SETQ WORD
|
||
(READLIST (NCONC (NREVERSE C)
|
||
(EXPLODEC WORD)))))
|
||
((PUSH (READLIST (NREVERSE C)) LINE)))
|
||
(SETQ C NIL)))]
|
||
(COND ((EQ EOL WORD)
|
||
;;IF LINE IS COMING IN FROM A FILE, PRINT SOURCE WHEN IN CAREFUL
|
||
;;MODE.
|
||
(SETQ OLD-LINE (NREVERSE LINE))
|
||
(SETQ PASS2-LINE (PASS2 OLD-LINE))
|
||
(AND ^Q :CAREFUL (MAPC 'DPRINC OLD-LINE) (DTERPRI))
|
||
;;COPY OF ORIGINAL LINE SAVED FOR RECOVERY OF PIECES BY EDITING
|
||
;;CHARACTERS, PARSEMACROS [SEE PARSER].
|
||
(RETURN PASS2-LINE))
|
||
((EQ WORD EOF) (RETURN EOF)))
|
||
(AND (EQ WORD '$) (PUSH '$ LINE) (INSTRING) (GO READ))
|
||
(PUSH WORD LINE)
|
||
(GO READ)))
|
||
|
||
;; READ IN A QUOTED STRING.
|
||
|
||
(DEFUN INSTRING NIL
|
||
(PROG (CH)
|
||
LOOP (SETQ CH (READCH))
|
||
;;;GOBBLE A CHARACTER
|
||
(COND ((EQ CH '$)
|
||
;;;IF $, DONE
|
||
(PUSH CH LINE)
|
||
(RETURN T))
|
||
((AND ^Q (EQ CH EOL) (= (TYIPEEK) 10.)) (READCH) (PUSH CH LINE))
|
||
((EQ CH '/)
|
||
;;;RUBOUT?
|
||
(COND [ITS ((MEMBER TTY '(1. 2. 3. 5.))
|
||
(CURSORPOS 'X)
|
||
(INCREMENT CHRCT 3.))]
|
||
;;;IF DISPLAY TTY, ERASE
|
||
((DPRINC (CAR LINE))))
|
||
;;;ELSE REECHO
|
||
(COND ((EQ (CAR LINE) '$) (POP LINE) (RETURN T)))
|
||
;;;IF $ RUBBED OUT, DONE
|
||
(POP LINE)
|
||
;;;REMOVE RUBBED OUT CHAR
|
||
(GO LOOP)))
|
||
(PUSH CH LINE)
|
||
;;;SAVE CHAR
|
||
(GO LOOP)))
|
||
|
||
;;*PAGE
|
||
|
||
;; PASS2 IS RESPONSIBLE FOR REMOVING SPACES, HANDLING QUOTING CONVENTIONS, CREATING
|
||
;;LIST STRUCTURE, PACKAGING COMMENTS AND MAKING NEGATIVE NUMBERS FROM MINUS SIGNS.
|
||
;;; '<SEXP> --> (QUOTE <SEXP>)
|
||
;;; "<SEXP>" --> (DOUBLE-QUOTE <SEXP>)
|
||
;;; "<S1> ... <SN>" --> (DOUBLE-QUOTE (<S1> ... <SN>))
|
||
;;; "" --> NIL
|
||
;;; [] --> NIL
|
||
;;; [ <SEXP1> ... <SEXPN>] --> (SQUARE-BRACKETS (<SEXP1> ... <SEXPN>)) EXCEPT THAT
|
||
;;; SQUARE BRACKETS INSIDE LIST STRUCTURE DO NOT HAVE SQUARE-BRACKETS
|
||
;;; PUT AROUND THEM. SQUARE-BRACKETS, DOUBLE-QUOTE ARE LIKE QUOTE, EXCEPT
|
||
;;; PRINTER KNOWS DIFFERENCE.
|
||
;;; ! <COMMENTARY> ! --> (LOGO-COMMENT ! <COMMENTARY> !)
|
||
;;; ; <COMMENTARY> --> (LOGO-COMMENT /; <COMMENTARY>)
|
||
;;; - <NUMBER> --> <-NUMBER>
|
||
|
||
(DEFUN PASS2 (TOKENLINE) (CATCH (UNSQUISH-LIST NIL) PASS2))
|
||
|
||
(SETQ :PARENBALANCE T)
|
||
|
||
(DEFUN UNSQUISH-LIST (LOOKING-FOR)
|
||
(COND
|
||
((NULL TOKENLINE)
|
||
(COND
|
||
((EQ LOOKING-FOR '/))
|
||
;;THE FLAG :PARENBALANCE TELLS WHETHER OR NOT TO CHECK FOR PARENTHESIS
|
||
;;BALANCE WHEN A LINE ENDS. TURNING IT OFF ALLOWS USER TO HAVE A
|
||
;;MULTI-LINE PARENTHESIZED FORM, FOR EASIER READING [VERTICAL ALIGNMENT
|
||
;;OF CONDITIONAL CLAUSES].
|
||
(COND (:PARENBALANCE (PASS2-ERROR '"UNMATCHED ("))
|
||
((LET ((:CAREFUL (COND ((AND ^Q :CAREFUL) NIL) (:CAREFUL))))
|
||
;;PREVENT RETYPEOUT OF LINE COMING IN FROM FILE.
|
||
(THROW (LINE (CONS '/ (NREVERSE OLD-LINE))) PASS2)))))
|
||
((EQ LOOKING-FOR '/])
|
||
;;A SQUARE BRACKETED LIST MAY CONTAIN A CARRIAGE RETURN. LINE MUST BE
|
||
;;CALLED AGAIN TO PICK UP REMAINDER OF LINE. BEWARE OF CALLING PASS2
|
||
;;WHEN NOT INSIDE LINE.
|
||
(LET ((:CAREFUL (COND ((AND ^Q :CAREFUL) NIL) (:CAREFUL))))
|
||
(THROW (LINE (CONS EOL (NREVERSE OLD-LINE))) PASS2)))
|
||
((EQ LOOKING-FOR '/")
|
||
(LET ((:CAREFUL (COND ((AND ^Q :CAREFUL) NIL) (:CAREFUL))))
|
||
(THROW (LINE (CONS EOL (NREVERSE OLD-LINE))) PASS2)))
|
||
((NULL LOOKING-FOR) NIL)
|
||
((PASS2-ERROR '"SYSTEM BUG - UNSQUISH-LIST"))))
|
||
((EQ (CAR TOKENLINE) '/ ) (POP TOKENLINE) (UNSQUISH-LIST LOOKING-FOR))
|
||
((AND LOOKING-FOR (EQ (CAR TOKENLINE) LOOKING-FOR)) (POP TOKENLINE) NIL)
|
||
((CONS (UNSQUISH LOOKING-FOR) (UNSQUISH-LIST LOOKING-FOR)))))
|
||
|
||
(DEFUN UNSQUISH (LOOKING-FOR)
|
||
(LET
|
||
((WORD (CAR TOKENLINE)))
|
||
(OR TOKENLINE
|
||
(PASS2-ERROR (COND ((EQ LOOKING-FOR '/')
|
||
'"QUOTE WHAT?")
|
||
('"SYSTEM BUG - UNSQUISH"))))
|
||
(POP TOKENLINE)
|
||
(COND
|
||
((EQ WORD '$)
|
||
(DO ((CH (CAR TOKENLINE) (CAR TOKENLINE)) (L))
|
||
((AND (EQ CH '$)
|
||
(NOT (AND TOKENLINE
|
||
(CDR TOKENLINE)
|
||
(EQ (CADR TOKENLINE) '$)
|
||
(POP TOKENLINE))))
|
||
(SETQ CH (INTERN (MAKNAM (NREVERSE L))))
|
||
(POP TOKENLINE)
|
||
CH)
|
||
(POP TOKENLINE)
|
||
(PUSH CH L)))
|
||
((EQ WORD '/ ) (UNSQUISH LOOKING-FOR))
|
||
((MEMQ WORD '(/; !))
|
||
(AND (EQ WORD '!)
|
||
(NOT (MEMQ '! TOKENLINE))
|
||
(LET ((:CAREFUL (COND ((AND ^Q :CAREFUL) NIL) (:CAREFUL))))
|
||
(THROW (LINE (CONS EOL (NREVERSE OLD-LINE))) PASS2)))
|
||
;;IF WE WERE EXPECTING ANYTHING WHEN COMMENT COMMENCED, THERE'S SOMETHING
|
||
;;WRONG.
|
||
(PROG2 (COND ((EQ LOOKING-FOR '/')
|
||
(PASS2-ERROR '"QUOTE WHAT?"))
|
||
((EQ LOOKING-FOR '/))
|
||
(PASS2-ERROR '"UNMATCHED ("))
|
||
((EQ LOOKING-FOR '/])
|
||
(PASS2-ERROR '"UNMATCHED ["))
|
||
((EQ LOOKING-FOR '/")
|
||
(PASS2-ERROR '"UNMATCHED """"")))
|
||
(CCONS 'LOGO-COMMENT WORD TOKENLINE)
|
||
(SETQ TOKENLINE NIL)))
|
||
((EQ WORD '/') (LIST 'QUOTE (UNSQUISH '/')))
|
||
((EQ WORD '/")
|
||
(COND ((NULL (SETQ WORD (UNSQUISH-LIST WORD))) NIL)
|
||
(REQUEST? WORD)
|
||
((CDR WORD) (LIST 'DOUBLE-QUOTE WORD))
|
||
((LIST 'DOUBLE-QUOTE (CAR WORD)))))
|
||
((EQ WORD '/() (UNSQUISH-LIST '/)))
|
||
((EQ WORD '/))
|
||
(PASS2-ERROR
|
||
(COND
|
||
((EQ LOOKING-FOR '/])
|
||
'"UNMATCHED RIGHT PAREN INSIDE SQUARE BRACKETS")
|
||
((EQ LOOKING-FOR '/")
|
||
'"UNMATCHED RIGHT PAREN INSIDE DOUBLE QUOTES")
|
||
('"UNMATCHED RIGHT PAREN"))))
|
||
((EQ WORD '/[)
|
||
(COND ((NULL (SETQ WORD (UNSQUISH-LIST '/]))) NIL)
|
||
((MEMQ LOOKING-FOR '(/] /' /")) WORD)
|
||
(REQUEST? WORD)
|
||
;;SPECIAL CASE CHECK. INSIDE REQUEST, SQUARE BRACKETS ARE NOT TO
|
||
;;HAVE OUTER LEVEL QUOTED.
|
||
((LIST 'SQUARE-BRACKETS WORD))))
|
||
((EQ WORD '/])
|
||
(PASS2-ERROR
|
||
(COND
|
||
((EQ LOOKING-FOR '/))
|
||
'"UNMATCHED RIGHT BRACKET INSIDE PARENTHESES")
|
||
((EQ LOOKING-FOR '/")
|
||
'"UNMATCHED RIGHT BRACKET INSIDE DOUBLE QUOTES")
|
||
('"UNMATCHED RIGHT BRACKET"))))
|
||
((EQ WORD '-)
|
||
(COND ((NUMBERP (SETQ WORD (CAR TOKENLINE))) (POP TOKENLINE) (MINUS WORD))
|
||
('-)))
|
||
(WORD))))
|
||
|
||
(SETQ REQUEST? NIL)
|
||
|
||
(DEFINE SQUARE-BRACKETS (SYN QUOTE))
|
||
|
||
(DEFINE DOUBLE-QUOTE (SYN QUOTE))
|
||
|
||
;;; READING FILES
|
||
|
||
(DEFINE READFILE (ABB RF) FEXPR (FILENAME)
|
||
(LET ((^W ^W)
|
||
(OBARRAY LOGO-OBARRAY)
|
||
(READTABLE LOGO-READTABLE)
|
||
(LISPPRINT NIL)
|
||
(SECOND-FILE-NAME)
|
||
;;TURN OFF FASLOAD REDEFINITION MESSAGES IF REDEFINITION ALLOWED.
|
||
(FASLOAD (NOT :REDEFINE)))
|
||
(SETQ SECOND-FILE-NAME (CADR (SETQ FILENAME (FILESPEC FILENAME))))
|
||
(COND [(OR DEC10 ITS) ((EQ SECOND-FILE-NAME 'FASL)
|
||
(TYPE '";FASLOADING "
|
||
FILENAME
|
||
EOL)
|
||
(APPLY 'FASLOAD FILENAME))]
|
||
[MULTICS ((EQ SECOND-FILE-NAME 'FASL)
|
||
(TYPE '";READING " FILENAME EOL)
|
||
(LOAD (CATENATE (GET_PNAME (CADDDR FILENAME))
|
||
">"
|
||
(GET_PNAME (CAR FILENAME)))))]
|
||
((EQ SECOND-FILE-NAME 'WINDOW) (APPLY 'GETWINDOWS FILENAME))
|
||
((EQ SECOND-FILE-NAME 'SNAPS) (APPLY 'GETSNAPS FILENAME))
|
||
((APPLY 'UREAD FILENAME)
|
||
(TYPE '";READING " FILENAME EOL)
|
||
(SETQ ^Q T ^W (OR ^W (NOT :CAREFUL)))
|
||
(DO ((LOGOREAD (LOGOREAD) (LOGOREAD))
|
||
(LOGOVALUE)
|
||
(PROMPTER NO-VALUE)
|
||
(OLD-LINE))
|
||
((OR (EQ LOGOREAD EOF) (NULL ^Q)) (SETQ ^Q NIL) NO-VALUE)
|
||
(SETQ LOGOVALUE (EVALS LOGOREAD))
|
||
(OR (EQ LOGOVALUE NO-VALUE) (LOGO-PRINT LOGOVALUE))
|
||
(OR ^Q (RETURN NIL)))))
|
||
NO-VALUE))
|
||
|
||
[CLOGO (DEFINE READ (PARSE (PARSE-CLOGO-HOMONYM READFILE L T)))]
|
||
|
||
[CLOGO (DEFINE GET (PARSE (PARSE-CLOGO-HOMONYM READFILE 2. T)))]
|
||
|
||
;;READ LOOP.
|
||
|
||
(DEFINE READLISP FEXPR (FILENAME)
|
||
(COND ((EQ (CADR (SETQ FILENAME (FILESPEC FILENAME))) 'FASL)
|
||
(LET ((OBARRAY LISP-OBARRAY) (READTABLE LISP-READTABLE))
|
||
(APPLY 'FASLOAD FILENAME)))
|
||
((APPLY 'UREAD FILENAME) (READOB LOGO-OBARRAY LISP-READTABLE))))
|
||
|
||
(DEFUN READOB (OBARRAY READTABLE)
|
||
(DO ((R) (^Q T))
|
||
((OR (NULL ^Q) (EQ (SETQ R (READ GENSYM)) GENSYM)) (TERPRI))
|
||
(SETQ R (EVAL R))
|
||
(OR (EQ R NO-VALUE) (PRINT R)))
|
||
(SETQ ^Q NIL)
|
||
NO-VALUE)
|
||
|
||
;;INPUT
|
||
;;;
|
||
;;READS NEXT CHARACTER AND RETURNS ITS ASCII VALUE.
|
||
|
||
(DEFINE TYI (PARSE 0.))
|
||
|
||
(DEFINE TTYP NIL (ZEROP (LISTEN)))
|
||
|
||
;;ARG PROP OF TYI = (0 . 1), WHERE AN ARG TREATED AS EOF CHAR ALLA READ. THUS
|
||
;;PARSE PROPERTY IS NECESSARY. THE AMBIGUITY BETWEEN ONE WORD SENTENCES AND WORDS
|
||
;;IS RESOLVED IN FAVOR OF WORDS IN THE CLOGO VERSION.
|
||
|
||
(DEFINE REQUEST (ABB RQ) NIL
|
||
(AND (OR (= [(OR ITS DEC10) LINEL]
|
||
[MULTICS (LINEL NIL)]
|
||
[(OR ITS DEC10) CHRCT]
|
||
[MULTICS (CHRCT NIL)])
|
||
(= (SUB1 [(OR ITS DEC10) LINEL]
|
||
[MULTICS (LINEL NIL)])
|
||
[(OR ITS DEC10) CHRCT]
|
||
[MULTICS (CHRCT NIL)]))
|
||
(DPRINC '<))
|
||
(LET ((OBARRAY LOGO-OBARRAY)
|
||
(READTABLE LOGO-READTABLE)
|
||
(LINE)
|
||
(REQUEST? T)
|
||
(PROMPTER '<)
|
||
(OLD-LINE))
|
||
[ITS (BIND-ACTIVATE-LOGO)]
|
||
(SETQ LINE (LINE NIL))
|
||
(PROG1 (COND ((CDR LINE) LINE)
|
||
;;ONE ELEMENT TYPED. IN 11LOGO, IF ATOM RETURN LIST OF
|
||
;;ATOM. ELSE RETURN LIST TYPED.
|
||
[/11LOGO ((ATOM (CAR LINE)) LINE)]
|
||
((CAR LINE)))
|
||
[/11LOGO LINE]
|
||
[ITS (UNBIND-ACTIVATE)])))
|
||
|
||
;;NO PARSING IS DONE ON THE STUFF GOBBLED BY REQUEST. PASS2 IS DONE, SO PARENS ARE
|
||
;;CHANGED TO LIST STRUCTURE, SPACES REMOVED, UNARY-BINARY MINUS DISTINCTION IS MADE.
|
||
;;USER CAN GET FAKED OUT BY MINUS SIGN, SINGLE-QUOTE, SQUARE BRACKETS.
|
||
;;;
|
||
|
||
(DEFUN ASK NIL
|
||
;;USER IS ASKED YES-NO QUESTION. IT RETURNS T OR NIL.
|
||
(IOG
|
||
NIL
|
||
(PROG (ANS)
|
||
A (DTERPRI)
|
||
(SETQ ANS (REQUEST))
|
||
(OR (ATOM ANS) (SETQ ANS (CAR ANS)))
|
||
(COND ((MEMQ ANS '(YES Y T TRUE RIGHT)) (RETURN T))
|
||
((MEMQ ANS '(NO N NIL F FALSE WRONG)) (RETURN NIL))
|
||
((DPRINC '";PLEASE TYPE YES OR NO. ")
|
||
(GO A))))))
|
||
|
||
(DEFINE TYPEIN NIL [/11LOGO (CAR (REQUEST))]
|
||
[CLOGO (LET ((RESPONSE (REQUEST)))
|
||
(COND ((ATOM RESPONSE) RESPONSE) ((CAR RESPONSE))))])
|
||
|
||
;;*PAGE
|
||
|
||
|