github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-02-26 08:53:29 +00:00
Code Issues Releases Wiki Activity

Make LLOGO use DSK device rather than AI.

Browse Source 
Rename file versions to one more than the last known version.
This commit is contained in:
Lars Brinkhoff
2018-09-25 07:44:48 +02:00
parent 5113220de5
commit df17cabaf6
13 changed files with 20 additions and 20 deletions
Download Patch File Download Diff File Expand all files Collapse all files

611
src/llogo/reader.201 Normal file
View File

@@ -0,0 +1,611 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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