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

Split llogo.lisp into individual files.

Browse Source 
It's a concatenation of, in order: DEFINE, SETUP, READER, PARSER,
UNEDIT, PRINT, PRIMIT, ERROR, LOADER, TURTLE, GERM, MUSIC, TVRTLE, and
HANG.  Version numbers are unknown except TURTLE.
This commit is contained in:
Lars Brinkhoff
2018-09-24 12:52:17 +02:00
parent 8c2a037d23
commit 5113220de5
15 changed files with 12484 additions and 12480 deletions
Download Patch File Download Diff File Expand all files Collapse all files

445
src/llogo/define.1 Normal file
View File

@@ -0,0 +1,445 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DEFINE > ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;THIS FILE IS INTENDED FOR:
;;; DEFINING LLOGO PRIMITIVES
;;; READING IN DECLARATIONS AND MACROS FOR COMPILING PIECES OF LLOGO.
;;;
;; IT CONTAINS DEFINITIONS OF READMACROS, COMPILER-EXPANDED MACROS, DEFINITION OF
;;DEFINE FUNCTION. NOTE THAT THIS FILE ITSELF MUST BE READ INTO COMPILER TO COMPILE
;;IT. NOTHING IN THIS FILE WILL BE PRESENT IN COMPILED LLOGO, EXCEPT THAT DEFINE
;;FUNCTION WILL BE AUTOLOADED.
(DECLARE (SPECIAL SYNSTAX TTYNOTES DEFINE-MACRO-INDEX)
(MACROS T)
(GENPREFIX DEFINE-)
(COND ((STATUS FEATURE DEFINE))
((AND (OR (STATUS FEATURE ITS) (STATUS FEATURE DEC10))
(ERRSET (FASLOAD DEFINE FASL AI LLOGO))))
((AND (STATUS FEATURE MULTICS)
(ERRSET (LOAD "DEFINE.LISP"))))
((IOG NIL (PRINT '(DEFINE MUST BE READ INTO COMPILER))))))
(DECLARE (READ))
(AND (STATUS FEATURE ITS)
(OR (STATUS FEATURE NCOMPLR) (STATUS FEATURE COMPLR))
;;READING IN TO COMPILER INTERPRETIVELY TO COMPILE ITSELF, MUST CHANGE OBARRAY
;;AND READTABLE SO DEFINITIONS OF READMACROS, ETC. WILL WIND UP ON CORRECT
;;ONES.
(SETQ OBARRAY COBARRAY READTABLE CREADTABLE))
(SSTATUS FEATURE DEFINE)
(*RSET T)
(SETQ CAR T CDR T NO-VALUE '?)
;;TO SET CONDITIONAL READ IN SWITCHES WHILE COMPILING, TYPE CONTROL-G AT COMPLR,
;;(SETQ <SWITCH> <VALUE>) THEN (MAKLAP) TO RETURN TO COMPILER COMMAND LEVEL. IN
;;COMPILERS >= VERSION 489, A "&" IS REQUIRED BEFORE THE SETQ TO SET THE VARIABLES
;;ON THE RIGHT OBARRAY.
(COND ((BOUNDP 'THIS-SYSTEM)
(SETQ ITS (EQ THIS-SYSTEM 'ITS) DEC10 (EQ THIS-SYSTEM 'DEC10)))
((SETQ ITS (STATUS FEATURE ITS) DEC10 (STATUS FEATURE DEC10))))
;;THIS-SYSTEM IS A VARIABLE DENOTING THE CURRENT IMPLEMENTATION. IF NOT PREVIOUSLY
;;SET, DEDUCED FROM (STATUS FEATURES). ATOM "MULTICS" HAS CAPITAL "M", SO REPLACE
;;WITH SMALL.
(SETQ MULTICS (AND (NOT ITS) (NOT DEC10)))
;;CLOGO VS. 11LOGO COMPATIBILITY SWITCH. [11LOGO DEFAULT]
(COND ((BOUNDP 'CLOGO) (SETQ /11LOGO (NOT CLOGO)))
((BOUNDP '/11LOGO) (SETQ CLOGO (NOT /11LOGO)))
((SETQ /11LOGO T CLOGO NIL)))
(OR (BOUNDP ':CAREFUL) (SETQ :CAREFUL T))
(OR (BOUNDP 'BIBOP) (SETQ BIBOP ITS))
(SETQ COMPILING (OR (STATUS FEATURE COMPLR)
;;VARIOUS INCARNATIONS OF THE LISP COMPILER ARE NAMED
;;DIFFERENTLY.
(STATUS FEATURE NCOMPLR)
(STATUS FEATURE COMPILER)))
;;READ-TIME SWITCH FOR IMPLEMENTATION-DEPENDENT CODE. OPEN BRACKET IS DEFINED TO BE
;;A READMACRO [ON LISP READTABLE ONLY] WHICH PICKS UP THE NEXT OBJECT, AND EVALUATES
;;IT. IF IT EVALUATES TO NON-NIL, BRACKETS DISAPPEAR. IF IN THE WRONG SYSTEM,
;;EVERYTHING IS DISCARDED UP TO THE NEXT CLOSE BRACKET. EXAMPLE:
;;; [MULTICS <CODE GOOD ONLY IN MULTICS>]
;;; [(OR ITS DEC10) <CODE GOOD IN EITHER ITS OR DEC10, NOT MULTICS>]
(SETQ SYNSTAX NIL GENSYM (GENSYM))
;;TO ALLOW NESTING OF SQUARE-BRACKET MACROS, A STACK OF SYNTAX PROPERTIES FOR
;;CLOSE-BRACKET IS KEPT, CHANGED WHEN AN OPEN BRACKET IS ENCOUNTERED, RESTORED WHEN
;;A CLOSE-BRACKET IS MET.
(DEFUN OPEN-BRACKET-MACRO NIL
(SETQ SYNSTAX (CONS (STATUS MACRO 93.) SYNSTAX))
(COND ((EVAL (READ))
(SETSYNTAX 93. 'SPLICING 'RESTORE-CLOSE-BRACKET-SYNTAX))
((SETSYNTAX 93. 'MACRO 'CLOSE-BRACKET-MACRO)
;;IN THE WRONG SYSTEM, GOBBLE AND DISCARD EVERYTHING TILL THE NEXT
;;CLOSE BRACKET. SYNTAX OF CLOSE-BRACKET MUST BE CHANGED TO MAKE IT
;;REAPPEAR.
(DO ((STUFF (READ) (READ)))
((EQ STUFF GENSYM) (RESTORE-CLOSE-BRACKET-SYNTAX)))))
NIL)
(SETSYNTAX 91. 'SPLICING 'OPEN-BRACKET-MACRO)
(DEFUN RESTORE-CLOSE-BRACKET-SYNTAX NIL
(SETSYNTAX 93. (OR (CADAR SYNSTAX) 'MACRO) (CAAR SYNSTAX))
(SETQ SYNSTAX (CDR SYNSTAX))
NIL)
(DEFUN CLOSE-BRACKET-MACRO NIL GENSYM)
(SETSYNTAX 93. 'MACRO 'CLOSE-BRACKET-MACRO)
;;DOUBLE-QUOTE IS DEFINED ON THE LISP READTABLE TO BE A PL/1-TYPE STRING-QUOTING
;;MACRO. IN THE MULTICS IMPLEMENTATION, STRINGS ARE IMPLEMENTED DIRECTLY.
[(OR ITS DEC10) (DEFUN DOUBLE-QUOTE-MACRO NIL
(DO ((CHARLIST) (CHARNUM (TYI) (TYI)))
((AND (= CHARNUM 34.) (NOT (= (TYIPEEK) 34.)))
(MAKNAM (NREVERSE CHARLIST)))
(AND (= CHARNUM 34.) (TYI))
(SETQ CHARLIST (CONS CHARNUM CHARLIST))))
(SETSYNTAX 34. 'MACRO 'DOUBLE-QUOTE-MACRO)]
;;NOTE THAT THE DOUBLE-QUOTE MACRO DOES NOT INTERN THE ATOM CREATED. END OF
;;READMACRO CHARACTER DEFINITIONS.
;;*PAGE
;; COMPILER DECLARATIONS AND MACROS.
(AND COMPILING
;;OPEN CODE MAP'S, FLUSH KLUDGY EXPR-HASH FEATURE, NO FUNCTIONAL VARIABLES.
(SETQ MAPEX T EXPR-HASH NIL NFUNVARS T)
(*FEXPR DEFINE DUMP ERASE IF IFFALSE IFTRUE LISPBREAK LOGOBREAK LOGO-EDIT
LOAD-IF-WANTED LOGIN PRINTOUTFILE PRINTOUTINDEX PRINTOUTTITLE PRINTOUT
READFILE REMGRIND REMTRACE SAVE TO TRACE UNTRACE USE WRITE)
(*LEXPR DPRINTL EXIT ERRBREAK LOCATE-ERROR LOGOREAD LOGO-PRINT LOGO-RANDOM
ATOMIZE PARSELINE ROUNDOFF SENTENCE TYPE WORD WRITELIST)
(*EXPR ABB1 ADDLINE ABBREVIATIONP ASK ALLOCATOR BIND-ACTIVATE-LISP
BIND-ACTIVATE-LOGO CONTROL-N CONTROL-P CONTROL-R CONTROL-S DATE DAYTIME
DEFAULT-FUNCTION DELEET DPRINC DPRINT DTERPRI EDITINIT1 EDIT-LINE
ERASELINE ERRORFRAME EVALS EXPUNGE ERASEPRIM FILESPEC FUNCTION-PROP
GETLINE HOW-TO-PARSE-INPUTS HOMCHECK INIT LINE LISP LOGO LOGOPRINC MAKE
MAKLOGONAM NUMBER? OBTERN OUTPUT PARSE PASS2 PASS2-ERROR PRINTOUTLINES
PRINTOUTNAMES PRINTOUTPROCEDURES PRINTOUTTITLES PRIMITIVEP PROCEDUREP
REPAIR-LINE REQUEST REMSNAP REREAD-ERROR SCREENSIZE SET- SYNONYMIZE
SYMBOLP TOP-LEVEL TRACE? TRACED? UNITE UNPARSE-FORM
UNPARSE-FUNCTION-NAME UNTRACE1 UNPARSE-LOGO-LINE VARIABLEP VERSION)
(SPECIAL :BURIED :CAREFUL :COMPILED :CONTENTS :EDITMODE :EMPTYW :ERRBREAK
:HISTORY :INFIX :LISPBREAK :NAMES :PARENBALANCE :PI :REDEFINE
:SCREENSIZE :SHOW :SNAPS :TEXT :TEXTXHOME :TEXTYHOME :WRAP ? ABB
ATOM-GOBBLER BAD-FORM CAR-FORM CDR-FORM CLOCK CLOGO CTRL-E CONTROL-K
CONTROL-L CTRL-P CTRL-R CTRL-S DEFAULT-PRECEDENCE DEFAULT-TURTLE
DEFINE-DEFPROP DEFINE-HOMCHECK DEFINE-OBTERN DEFINE-SYNONYMIZE
DEF-IND-RPLACA DEF-PROP-RPLACA DEF-SYM-RPLACA DPRINC DTERPRI
EDIT? EDITED EDITTITLE
EDL EDT EOF EOL EOL* ERRBREAK ERRLIST ERRS EXIT FIRST FLAG FN FNNAME
FULL GENSYM HOM HOMCHECK HOMCHECK-RPLACA INFIX INPUT-LIST INPUTS
INSERTLINE-NUMBER LAST-LINE LINE LISP LISP-OBARRAY LISP-OBDIM
LISPPRINT LISP-READTABLE LISPREADTABLE LOGO-OBARRAY LOGOREAD
LOGO-READTABLE LOGOREADTABLE MERGESTATUS NEXT-TAG NOUUO NO-VALUE
NULL-LINE NUMBER OBARRAY OBTERN-RPLACA OLD-LINE OLDPARSE PARSE
PARSED-FORM /11LOGO PASS2-LINE PI-OVER-180 PROG PROMPTER PROP
READTABLE REQUEST? REREAD-ERROR? RIGHT-ASSOCIATIVE SAIL STACK-TYPE SYN
SYN-NEW-RPLACA SYN-OLD-RPLACA TESTFLAG THIS-FORM THIS-FORM-INDEX
THIS-LINE THIS-LINE-INDEX THIS-VALUE-INDEX TITLE TOP-LINE TOKENLINE
TOL TOPARSE TTY TYPE UNPARSE UNPARSED-LINE UNARY-MINUS UP? WORD ^Q *
+ -)
(FIXNUM ABOVE ARGINDEX ARGS ARG-COUNT CHARNUM CHRCT DEFAULT-PRECEDENCE
DIRECTION ENV FORM-INDEX FRAME-NUMBER HOWMANY HOW-MANY-ARGS I J
LINE-INDEX LINEL LISP-OBDIM NEWLINEL POSITION (PRECEDENCE)
ROUND-FIXNUM-VARIABLE ROUND-PLACES STACK-POINTER
THIS-FORM-INDEX THIS-LINE-INDEX
THIS-VALUE-INDEX TYIPEEKED TTY VALUE-INDEX)
(ARRAY* (NOTYPE VALUE-HISTORY 1.)
(NOTYPE FORM-HISTORY 1.)
(NOTYPE LINE-HISTORY 1.)
(NOTYPE DEFINEARRAY-TYPE 1.))
(FLONUM (\$ FLONUM FLONUM) :PI PI-OVER-180 UNROUNDED TEN-TO-PLACES)
(NOTYPE (PARSE-EXPR-ARGS FIXNUM)))
;;*PAGE
;;; DEFINING LLOGO PRIMITIVES
;;;FORMAT - (DEFINE FN (11LOGO ...) (ABB ...) (SYN ...) (PARSE ...) (UNPARSE ...)
;; (FASLOAD ...) DEFINITION)
;;;
;;;(ABB ABB1 ABB2....) THIS CLAUSE SPECIFIES ABBREVIATIONS FOR THE FUNCTION BEING
;;DEFINED.
;;;(SYN GOLDEN-OLDIE) SAYS THAT THE FUNCTION IS TO BE DEFINED TO BE A SYNONYM OF
;;GOLDEN-OLDIE.
;;;(PARSE PARSE-PROPERTY) (UNPARSE UNPARSE-PROPERTY)
;;; ARE DECLARATIONS TO THE PARSER/UNPARSER TO SPECIFY HOW THE
;;; CALLS TO THE FUNCTION BEING DEFINED ARE TO BE PARSED/UNPARSED.
;;;(FASLOAD <FILE NAME>) -- FN IS DEFINED TO BE A MACRO WHICH WILL
;;; FASLOAD IN THE SPECIFIED FILE WHICH SHOULD DEFINE THE FN.
;;;; DEFINITION CONSISTS OF INPUTS AND BODY AS FOR A "DEFUN".
(DEFUN ACCEPT-ADVICE (ADVICE)
;;SLICE OFF ADVICE CLAUSES.
(DO NIL
((OR (NULL ADVICE)
(ATOM (CADR ADVICE))
(NOT (MEMQ (CAADR ADVICE) '(ABB SYN PARSE UNPARSE FASLOAD)))))
(SET (CAADR ADVICE) (CDADR ADVICE))
(RPLACD ADVICE (CDDR ADVICE))))
;;INITIALIZATION OF FORMS NEEDED BY DEFINE FUNCTION. THESE VARIABLES ARE KEPT
;;AROUND SO THAT DEFINE FUNCTION NEEDN'T DO CONSING.
(DEFUN DEFINE-PROPERTY (SYMBOL PROPERTY INDICATOR)
(DEFINE-HAPPEN (LIST 'DEFPROP SYMBOL PROPERTY INDICATOR)))
[(OR ITS DEC10) (DEFPROP DEFINE DEFINE-MACRO MACRO)]
[MULTICS (DEFPROP COUTPUT PUT-IN-TREE EXPR)]
(DEFUN [(OR ITS DEC10) DEFINE-MACRO
FEXPR] [MULTICS DEFINE
MACRO]
(X)
(PROG (FN SYN ABB UNPARSE PARSE FASLOAD)
(ACCEPT-ADVICE (SETQ X (CDR X)))
(SETQ FN (CAR X))
(COND ((OR FASLOAD (CDR X))
(DEFINE-HAPPEN (LIST 'HOMCHECK (LIST 'QUOTE FN))))
((DEFINE-HAPPEN (LIST 'OBTERN
(LIST 'QUOTE FN)
'LOGO-OBARRAY))))
(AND PARSE (DEFINE-PROPERTY FN PARSE 'PARSE))
(AND UNPARSE (DEFINE-PROPERTY FN (CAR UNPARSE) 'UNPARSE))
(AND FASLOAD (DEFINE-PROPERTY FN FASLOAD 'AUTOLOAD))
(MAPC
'(LAMBDA (Y)
(DEFINE-HAPPEN (LIST 'HOMCHECK (LIST 'QUOTE Y)))
(DEFINE-PROPERTY Y
FN
[MULTICS 'EXPR]
[(OR ITS DEC10) (COND ((MEMQ (CADR X)
'(FEXPR MACRO))
'FEXPR)
('EXPR))]))
ABB)
(RETURN
(COND
(SYN (DEFINE-HAPPEN (LIST 'SYNONYMIZE
(LIST 'QUOTE FN)
(LIST 'QUOTE (CAR SYN))))
(LIST 'QUOTE (CAR SYN)))
((CDR X)
(SETQ X (CDR X))
(COND
((EQ (CAR X) 'MACRO)
((LAMBDA (COMPILED-MACRO)
(DEFINE-PROPERTY FN COMPILED-MACRO 'MACRO)
(LIST 'DEFPROP
COMPILED-MACRO
(CONS 'LAMBDA (CDR X))
'FEXPR))
(MAKNAM
(APPEND
'(D E F I N E - M A C R O -)
(EXPLODEC (SETQ DEFINE-MACRO-INDEX (1+ DEFINE-MACRO-INDEX)))))))
((CONS 'DEFUN (CONS FN X)))))))))
(SETQ DEFINE-MACRO-INDEX (FIX (TIME)))
;;*PAGE
(COND
((STATUS FEATURE LLOGO))
;;IF NOT READ INTO LLOGO, SUPPLY MISSING FUNCTIONS.
((DEFUN HOMCHECK (USELESS) USELESS)
(DEFUN OBTERN (USE LESS) USE)
(SETQ LOGO-OBARRAY NIL)
(DEFPROP ABB1 SYNONYMIZE EXPR)
(DEFUN SYNONYMIZE (NEW OLD)
(PUTPROP NEW
OLD
[MULTICS 'EXPR]
[(OR ITS DEC10) (COND ((GETL OLD '(EXPR SUBR LSUBR ARRAY))
'EXPR)
((GETL OLD '(FEXPR FSUBR))
'FEXPR)
((ERRBREAK 'DEFINE
'SYNONYM/ NOT/ FOUND)))]))
(DEFUN ERRBREAK ARGS
(PRINC (ARG 2.))
(TERPRI)
(APPLY 'BREAK (LIST (ARG 1.) T)))))
;;*PAGE
;;;IT'S MACRO TIME!
;;CAREFUL ABOUT USING THESE MACROS IN RANDOM FORMS, AS DEFINITIONS MAY NOT BE AROUND
;;AT RUN TIME.
(DECLARE (DEFPROP DEFINE-HAPPEN COUTPUT EXPR))
(DEFPROP DEFINE-HAPPEN EVAL EXPR)
(DEFINE SAVE-VERSION-NUMBER MACRO (CALL)
[(OR ITS DEC10) (LIST 'DEFPROP
(CADR CALL)
(CADR (STATUS UREAD))
'VERSION)]
[MULTICS (LIST 'DEFPROP
(CADR CALL)
(CADDAR (ALLFILES (LIST (CADR CALL) '*)))
'VERSION)])
(SAVE-VERSION-NUMBER DEFINE)
(DEFINE INCREMENT MACRO (CALL)
(RPLACA CALL 'SETQ)
(RPLACD CALL
(LIST (CADR CALL)
(CONS (COND ((NULL (CDDR CALL)) '1+) ('+))
(CDR CALL)))))
(DEFINE DECREMENT MACRO (CALL)
(RPLACA CALL 'SETQ)
(RPLACD CALL
(LIST (CADR CALL)
(CONS (COND ((NULL (CDDR CALL)) '1-) ('-))
(CDR CALL)))))
(DEFINE LET MACRO (CALL)
;;SYNTACTIC SUGAR FOR LOCAL LAMBDA BINDINGS. KEEPS BOUND VARIABLE AND BOUND
;;VALUE LEXICALLY NEAR EACH OTHER.
((LAMBDA (BOUND-VARIABLES BOUND-VALUES)
(MAPC '(LAMBDA (VARIABLE-SPEC)
(COND ((ATOM VARIABLE-SPEC)
(PUSH VARIABLE-SPEC BOUND-VARIABLES)
(PUSH NIL BOUND-VALUES))
((PUSH (CAR VARIABLE-SPEC) BOUND-VARIABLES)
(PUSH (CADR VARIABLE-SPEC) BOUND-VALUES))))
(CADR CALL))
(RPLACA CALL
(CONS 'LAMBDA
(CONS (NREVERSE BOUND-VARIABLES) (CDDR CALL))))
(RPLACD CALL (NREVERSE BOUND-VALUES)))
;;NOTICE HOW FAR AWAY VARIABLES ARE FROM VALUES!
NIL
NIL))
;;MACROS TO EXPAND BIT-TWIDDLING FUNCTIONS IN TERMS OF THE BOOLE FUNCTION.
;;PRIMARILY OF USE IN CONSTRUCTING MASKS FOR SETTING BITS IN THE TV BUFFER ARRAY.
(DEFINE BITWISE-AND MACRO (CALL) (RPLACA CALL 'BOOLE)
(RPLACD CALL (CONS 1. (CDR CALL))))
(DEFINE BITWISE-OR MACRO (CALL) (RPLACA CALL 'BOOLE)
(RPLACD CALL (CONS 7. (CDR CALL))))
(DEFINE BITWISE-NOT MACRO (CALL)
(RPLACA CALL 'BOOLE)
(RPLACD CALL (CONS 6. (CONS -1. (CDR CALL)))))
(DEFINE BITWISE-XOR MACRO (CALL) (RPLACA CALL 'BOOLE) (RPLACD CALL (CONS 6. (CDR CALL))))
(DEFINE BITWISE-ANDC MACRO (CALL) (RPLACA CALL 'BOOLE) (RPLACD CALL (CONS 2. (CDR CALL))))
(DEFINE PROG1 MACRO (CALL)
;;USEFUL FOR KEEPING A VALUE AROUND MOMENTARILY AFTER
;;IT'S DESTROYED BY A SIDE EFFECT, WITHOUT CREATING
;;ANOTHER VARIABLE TO HOLD IT.
(RPLACA CALL 'PROG2)
(RPLACD CALL (CONS T (CDR CALL))))
(DEFINE ROUND MACRO (CALL)
(SUBST (CADR CALL)
'ROUND-ME
;;The ROUND-FIXNUM-VARIABLE crock is just an attempt to get the
;;compiler to open code the FIX. In general, FIX of a flonum may
;;return a BIGNUM.
'((LAMBDA (ROUND-FIXNUM-VARIABLE) ROUND-FIXNUM-VARIABLE)
(FIX (+$ ROUND-ME 0.5)))))
;;(CCONS 1 2 3) = (CONS 1 (CONS 2 3))
(DEFINE CCONS MACRO (X)
(RPLACA X 'CONS)
(AND (CDDDR X) (RPLACD X (LIST (CADR X) (CONS 'CCONS (CDDR X)))))
X)
;;REPLACES (PUSH X Y) BY (SETQ Y (CONS X Y))
(DEFINE PUSH MACRO (X)
(RPLACA X 'SETQ)
(RPLACD X (LIST (CADDR X) (LIST 'CONS (CADR X) (CADDR X)))))
;;REPLACES (POP X) BY (SETQ X (CDR X))
(DEFINE POP MACRO (X) (RPLACA X 'SETQ)
(RPLACD X (LIST (CADR X) (LIST 'CDR (CADR X)))))
;;END OF MACRO DEFINITIONS AND COMPILER DECLARATIONS. CHOOSE BETWEEN INTERPRETED
;;AND COMPILED DEFINITIONS OF DEFINE.
(DEFUN COMPILED-EXPR-FUNCTION FEXPR (CALL)
(RPLACA CALL 'GET)
(RPLACD CALL (LIST (LIST 'FUNCTION (CADR CALL)) ''SUBR)))
;;EXPR-FUNCTION & EXPR-CALL EXPAND INTO SUBRCALLS OF SUBR POINTERS FOR
;;EFFICIENCY, BUT INTERPRETIVELY ARE FUNCTION & FUNCALL.
(DEFUN COMPILED-EXPR-CALL FEXPR (CALL)
(RPLACA CALL 'SUBRCALL)
(RPLACD CALL (CONS NIL (CDR CALL))))
(DEFUN COMPILED-EXPR-CALL-FIXNUM FEXPR (CALL)
(RPLACA CALL 'SUBRCALL)
(RPLACD CALL (CONS 'FIXNUM (CDR CALL))))
(DEFUN INTERPRETIVE-EXPR-FUNCTION FEXPR (CALL)
(LET ((EXPR-FUNCTION-PROP (GETL (CADR CALL) '(SUBR EXPR-CALL-SUBR))))
;;A DUMMY SUBR MAY BE PUT UNDER THE PROPERTY EXPR-CALL-SUBR FOR
;;THE PURPOSE OF DEBUGGING INTERPRETIVELY.
(COND ((NULL EXPR-FUNCTION-PROP) (LIST 'FUNCTION (CADR CALL)))
((LIST 'QUOTE (CADR EXPR-FUNCTION-PROP))))))
(DEFUN INTERPRETIVE-EXPR-CALL FEXPR (CALL)
(LET ((EXPR-FUNCTION (EVAL (CADR CALL))))
(LET ((TYPE-EXPR-FUNCTION (TYPEP EXPR-FUNCTION)))
(COND ((EQ TYPE-EXPR-FUNCTION 'SYMBOL)
(CONS 'FUNCALL (CDR CALL)))
((CONS 'SUBRCALL (CONS NIL (CDR CALL))))))))
(DEFUN INTERPRETIVE-EXPR-CALL-FIXNUM FEXPR (CALL)
(LET ((EXPR-FUNCTION (EVAL (CADR CALL))))
(LET ((TYPE-EXPR-FUNCTION (TYPEP EXPR-FUNCTION)))
(COND ((EQ TYPE-EXPR-FUNCTION 'SYMBOL)
(CONS 'FUNCALL (CDR CALL)))
((CONS 'SUBRCALL (CONS 'FIXNUM (CDR CALL))))))))
(COND (COMPILING (DEFPROP EXPR-FUNCTION COMPILED-EXPR-FUNCTION MACRO)
(DEFPROP EXPR-CALL COMPILED-EXPR-CALL MACRO)
(DEFPROP EXPR-CALL-FIXNUM COMPILED-EXPR-CALL-FIXNUM MACRO))
((DEFPROP EXPR-FUNCTION INTERPRETIVE-EXPR-FUNCTION MACRO)
(DEFPROP EXPR-CALL INTERPRETIVE-EXPR-CALL MACRO)
(DEFPROP EXPR-CALL-FIXNUM INTERPRETIVE-EXPR-CALL-FIXNUM MACRO)))
(COND (COMPILING (DEFPROP DEFINE-HAPPEN COUTPUT EXPR))
;;FOR EXTRA FORMS TO BE MADE HAPPEN BY DEFINE FUNCTION, IF COMPILING, OUTPUT
;;THEM TO BE DONE AT RUN TIME, IF NOT COMPILING, JUST DO THEM.
((DEFPROP DEFINE-HAPPEN EVAL EXPR)))

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

@@ -0,0 +1,776 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ERROR > -- DEBUGGING PRIMITIVES ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(DECLARE (OR (STATUS FEATURE DEFINE)
(COND ((STATUS FEATURE ITS)
;;MULTICS?
(FASLOAD DEFINE FASL AI 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 INTERRUPT 16. '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 INTERR 1. '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 INTERRUPT 2. '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")))
(SSTATUS INTERRUPT 5. '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"))))))
(SSTATUS INTERRUPT 7. '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")))))
(SSTATUS INTERRUPT 8. '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))))))
(SSTATUS INTERRUPT 9. '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))))
(SSTATUS INTERRUPT 19. 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 AI /.TECO/.) AUTOLOAD)
(DEFPROP START-TECO (LISPT FASL AI /.TECO/.) AUTOLOAD)
(DEFPROP MEV (STEPMM FASL AI 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.")]

815
src/llogo/germ.1 Normal file
View File

@@ -0,0 +1,815 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GERMLAND ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(DECLARE (*FEXPR REPEAT RUNGERM)
(ARRAY* (NOTYPE WHERE 1. LOOKLIKE 1. GERMARRAY 1. HEADING 1. FOODSUPPLY 1.))
(*EXPR GRID GRIDP HERE XCOR YCOR NORTH SOUTH EAST WEST HOME MOVE EAT WHAT FOOD
FOODP GETSQUARE PUTSQUARE REMSQUARE PRINTSQUARE STEP OBSTRUCT DESTRUCT
KILL GERM PRINTGRID CLEARSCREEN FILLFOOD NORTHP SOUTHP EASTP WESTP
ACCESSIBLE RIGHT RT LEFT LT FORWARD FD BACK BK NEXT FSIDE RSIDE BSIDE
LSIDE FRONT RIGHTSIDE REAR LEFTSIDE CORNERP EDGEP GERMDEMOS REQUEST
OBTERN STOP END XTERPRI UNGRID WRAP NOWRAP CHECK-EDGE WRAP-CHECK-EDGE
NO-WRAP-CHECK-EDGE TOUCH ERRBREAK )
;;GLOBAL VARIABLES AND ATOMS TO BE TYPED FROM CONSOLE DECLARED SPECIAL
(SPECIAL :GERM :HUNGRY :GRIDSIZE OBARRAY ^Q LISPREADTABLE HORIZSCALE VERTSCALE
TOPLINE RESET-CURSOR PROGRAMS REPEAT-INTRO :WRAPAROUND OLD-POS)
(SETQ FIXSW T MAPEX T))
(SSTATUS FEATURE GERMLAND)
;;IF WE ARE IN LOGO WORLD, MAKE LISP FUCNTIONS USUABLE FROM LOGO
(COND ((STATUS FEATURE LLOGO)
(READ-ONLY :GERM :GRIDSIZE)
(SYSTEM-VARIABLE :HUNGRY :WRAPAROUND)
(MAPC '(LAMBDA (X) (OBTERN X LOGO-OBARRAY))
'(WHERE GERM GRID GRIDP HERE XCOR YCOR NORTH SOUTH
EAST WEST HOME MOVE WHAT FOOD FOODP EAT GETSQUARE PUTSQUARE REMSQUARE
PRINTSQUARE STEP OBSTRUCT KILL DESTRUCT REPEAT PRINTGRID REPEAT-INTRO
FILLFOOD NORTHP SOUTHP EASTP WESTP RIGHT RT LEFT LT FORWARD FD BACK BK
NEXT FSIDE BSIDE RSIDE LSIDE FRONT RIGHTSIDE REAR LEFTSIDE ACCESSIBLE
EDGEP CORNERP RUNGERM GERMDEMOS Q CLEARSCREEN FOODSUPPLY HEADING TOPGERM
UNGRID WRAP NOWRAP BORDER OBSTACLE TOUCH NOGRID STARTGRID
SG NG NOGERM))
(DEFPROP REPEAT (L) PARSE)
(DEFPROP RUNGERM (L) PARSE))
((DEFUN TYPEIN NIL (READ))
(DEFUN REQUEST NIL (READ))
(DEFUN UNITE (X LIST) (OR (MEMQ X (EVAL LIST)) (SET LIST (CONS X (EVAL LIST)))) '?)
(SETQ LISPREADTABLE READTABLE :CONTENTS NIL)
(DEFUN ASK NIL (MEMQ (IOG NIL (READ)) '(Y YES T OK SURE YA TRUE OUI DA YUP)))
(DEFUN STOP NIL (RETURN NIL))
(DEFUN END NIL (RETURN NIL))
(DEFUN ERRBREAK (X Y) (PRINC Y) (APPLY 'BREAK (LIST X T)))))
(SETQ BASE 10. IBASE 10. *NOPOINT T)
;;*USER-PAGING NIL
;;; DEFINITION OF DOUBLE-QUOTE MACRO
;;; THIS MACRO MUST BE RUNNING AT COMPILER READ TIME.
;;; IT CONVERTS A DOUBLE QUOTED STRING TO
;;; A NON-INTERNED ATOM SUITABLE FOR PRINC'ING MESAGES
(DECLARE (EVAL (READ)))
(SETSYNTAX 34.
'MACRO
(FUNCTION (LAMBDA NIL
(DO ((L) (C (TYI) (TYI)))
((AND
(= C 34.)
(NOT
(=
(TYIPEEK)
34.)))
(MAKNAM
(NREVERSE L)))
(AND (= C 34.) (TYI))
(AND (= C 13.) (= (TYIPEEK) 10.) (READCH))
(SETQ L (CONS C L))))))
(DECLARE (SPECIAL :GERM :HUNGRY :GRIDECHOLINES :SCREENSIZE))
(SETQ :GERM 1. :HUNGRY NIL RESET-CURSOR T :GRIDECHOLINES 10.
:SCREENSIZE (CAR (STATUS TTYSIZE)))
;;*PAGE
(SSTATUS PAGEPAUSE NIL)
(DECLARE (*EXPR CREATE-ECHO-AREA) (SPECIAL :ECHOLINES))
(LAP CREATE-ECHO-AREA SUBR)
(ARGS CREATE-ECHO-AREA (NIL . 1.))
(DEFSYM TYIC 1.)
(DEFSYM TYOC 2.)
(DEFSYM IMMEDIATE 512.)
(HLLOS 0. NOQUIT)
(MOVEM A (SPECIAL :ECHOLINES))
(PUSH FXP TT)
(SKIPE TT A)
(MOVE TT 0. A)
(*CALL 0. SET-UP-ECHO-AREA)
;;THIS CALL ESTABLISHES AREA FOR ECHO OF TYPEIN.
(*VALUE)
(POP FXP TT)
(HLLZS 0 NOQUIT)
(PUSHJ P CHECKI)
(MOVE A (SPECIAL :ECHOLINES))
(POPJ P)
SET-UP-ECHO-AREA
(SETZ)
(SIXBIT SCML/ / )
;;IMMEDIATE ARG IS INPUT CHANNEL.
(0. 0. TYIC IMMEDIATE)
;;NUMBER OF LINES IS IN A.
(SETZ 0. TT)
NIL
(LAP OUTPUT-TO-ECHO-AREA SUBR)
(ARGS OUTPUT-TO-ECHO-AREA (NIL . 0))
(DEFSYM TYOC 2.)
(DEFSYM IMMEDIATE 512.)
(HLLOS 0 NOQUIT)
(*OPEN TYOC REOPEN-OUTPUT)
;;OUTPUT CHANNEL MUST BE REOPENED TO ASSURE OUTPUT GOES TO BOTTOM OF SCREEN.
(*VALUE)
(MOVEI A 'OUTPUT-NOW-IN-ECHO-AREA)
(HLLZS 0 NOQUIT)
(PUSHJ P CHECKI)
(POPJ P)
REOPEN-OUTPUT
(0. 0. (SIXBIT / / / TTY) 25.)
;;25. IS THE MAGIC NUMBER THAT SAYS:
;;; 1. = OUTPUT CHANNEL &
;;; 8. = OUTPUT TO ECHO AREA, IF IT EXISTS &
;;; 16. = DISPLAY MODE [LOOKS FOR CONTROL-P CODES]
(SIXBIT /.LISP/.)
(SIXBIT OUTPUT)
NIL
(LAP OUTPUT-TO-MAIN-SCREEN SUBR)
(ARGS OUTPUT-TO-MAIN-SCREEN (NIL . 0))
(DEFSYM TYOC 2.)
(DEFSYM IMMEDIATE 512.)
(HLLOS 0 NOQUIT)
(*OPEN TYOC REOPEN-OUTPUT)
(*VALUE)
(MOVEI A 'OUTPUT-NOW-IN-MAIN-SCREEN)
(HLLZS 0 NOQUIT)
(PUSHJ P CHECKI)
(POPJ P)
REOPEN-OUTPUT
(0. 0. (SIXBIT / / / TTY) 17.)
(SIXBIT /.LISP/.)
(SIXBIT OUTPUT)
NIL
(DEFUN ECHOLINES (BOTTOM-LINES)
(CREATE-ECHO-AREA BOTTOM-LINES)
(OUTPUT-TO-ECHO-AREA)
(CURSORPOS 'C)
'?)
;;THE STANDARD LISP CURSORPOS FUNCTION WON'T DO
;;FOR SPLIT-SCREEN HACKERY. THE SYSTEM MAINTAINS TWO
;;CURSORS, AND LISP IGNORES THE ECHO OUTPUT CURSOR.
(LAP ECHO-CURSORPOS SUBR)
(ARGS ECHO-CURSORPOS (NIL . 0))
(DEFSYM TYIC 1)
(DEFSYM IMMEDIATE 512.)
(DEFSYM RESULT 1024.)
(*CALL 0 READ-CURSOR-POSITION)
(*VALUE)
(HLLOS 0 NOQUIT)
(PUSH FXP TT)
(PUSH FXP D)
(PUSH FXP F)
(HRRZ TT F)
(JSP T FXCONS)
(MOVE B A)
(HLRZ TT F)
(JSP T FXCONS)
(CALL 2 (FUNCTION CONS))
(POP FXP F)
(POP FXP D)
(POP FXP TT)
(HLLZS 0 NOQUIT)
(PUSHJ P CHECKI)
(POPJ P)
READ-CURSOR-POSITION
(SETZ)
(SIXBIT RCPOS/ )
(0 0 1. IMMEDIATE)
(0 0 D RESULT)
(SETZ 0 F RESULT)
NIL
;;; TOPGERM ATTEMPTS TO SET UP A CONVENIENT ENVIRONMENT FOR
;;; DEBUGGING GERM PROGRAMS. IT ALLOWS THE USER TO INTERRACT
;;; WITH LLOGO IN A MORE OR LESS NORMAL WAY, BUT
;;; ATTEMPTS TO INSURE THAT THE DISPLAY OF THE GERMLAND
;;; GRID WILL NOT BE INTERFERED WITH.
(DEFUN STARTGRID NIL
(ECHOLINES :GRIDECHOLINES)
(PRINTGRID)
'?)
(DEFPROP TOPGERM STARTGRID EXPR)
(DEFPROP SG STARTGRID EXPR)
(DEFUN UNGRID NIL (ECHOLINES NIL) '?)
(DEFPROP NOGRID UNGRID EXPR)
(DEFPROP NOGERM UNGRID EXPR)
(DEFPROP NG UNGRID EXPR)
(DEFUN LEGALPOS (F X)
;;ERROR IN FN F IF X NOT LEGALPOS.
(OR
(AND (NUMBERP (CAR X)) (NUMBERP (CADR X)) (GRIDP X) X)
(ERRBREAK
F
'"POSITION MUST BE WITHIN BOUNDARIES OF GRID")))
(ARRAY WHERE T 10.)
;;THIS HOLDS POSITION OF EACH GERM
(ARRAY LOOKLIKE T 10.)
;;THIS HOLDS WHAT THEY LOOK LIKE ON THE SCREEN.
(FILLARRAY 'LOOKLIKE '(* @ & % ? + $ = /! :))
(ARRAY FOODSUPPLY T 10.)
;;THIS HOLDS THE FOOD SUPPLY FOR EACH GERM
(ARRAY HEADING T 10.)
;; HOLDS THE CURRENT HEADING OF EACH GERM.
(DEFUN GRID (N)
;;INITIALIZE GERMLAND GRID TO N BY N
(OR (FIXP N)
(ERRBREAK 'GRID
'"INPUT MUST BE AN INTEGER"))
(COND ((> N (- :SCREENSIZE 5.))
(ERRBREAK 'GRID '"GRID SIZE TOO BIG"))
((< N 1.)
(ERRBREAK 'GRID
'"GRID SIZE MUST BE AT LEAST 1."))
;;MUST FIT ON SCREEN
((ARRAY GERMARRAY T N N)
(COND ((< N (LSH (- :SCREENSIZE 5.) -2.))
(SETQ HORIZSCALE 8. VERTSCALE 4.))
((< N (LSH (- :SCREENSIZE 5.) -1.))
(SETQ HORIZSCALE 4. VERTSCALE 2.))
((SETQ HORIZSCALE 2. VERTSCALE 1.)))
(SETQ :GRIDSIZE N
:GRIDECHOLINES (- :SCREENSIZE (+ (* VERTSCALE N) 2.)))
;;ELEMENTS OF GERMARRAY WILL BE RPLACA/D INTO, SO MUST BE SET TO SEPERATE
;;CONSINGS.
(CREATE-ECHO-AREA :GRIDECHOLINES)
(DO I
0.
(1+ I)
(= I N)
(DO J 0. (1+ J) (= J N) (STORE (GERMARRAY I J) (LIST NIL))))
(FILLARRAY 'FOODSUPPLY '(0.))
(FILLARRAY 'HEADING '(0.))
N)))
;;GLOBAL VARIABLE CONTAINING GRID SIZE
(DEFUN GRIDP (POSITION)
;;RETURNS T IFF <POSITION> WITHIN GRID BOUNDS
(AND (> (CAR POSITION) -1.)
(< (CAR POSITION) :GRIDSIZE)
(> (CADR POSITION) -1.)
(< (CADR POSITION) :GRIDSIZE)))
;;*PAGE
;;; ROUTINES FOR DIRECTION REMEMBERING GERM COMMANDS
;;; RIGHT---CHANGE HEADING
(DEFUN RIGHT (N)
(OR (NUMBERP N)
(ERRBREAK 'RIGHT
'"INPUT TO RIGHT MUST BE A NUMBER"))
(OR (ZEROP (\ N 90.))
(ERRBREAK 'RIGHT
'"INPUT MUST BE MULTIPLE OF 90"))
(SETQ N (\ (+ N (HEADING :GERM)) 360.))
(AND (MINUSP N) (SETQ N (+ N 360.)))
(STORE (HEADING :GERM) N))
(PUTPROP 'RT 'RIGHT 'EXPR)
(DEFUN LEFT (N) (RIGHT (MINUS N)))
(PUTPROP 'LT 'LEFT 'EXPR)
;;; FORWARD---MOVE
(DEFUN FORWARD (N)
(OR (NUMBERP N)
(ERRBREAK 'FORWARD
'"INPUT TO FORWARD MUST BE A NUMBER"))
(DO ((I 1. (1+ I))
(HEAD (COND ((> N 0.) (HEADING :GERM))
((SETQ N (- N)) (+ (HEADING :GERM) 180.)))))
((> I N) '?)
(MOVE (NEXT HEAD))))
(PUTPROP 'FD 'FORWARD 'EXPR)
(DEFUN BACK (N) (FORWARD (- N)))
(PUTPROP 'BK 'BACK 'EXPR)
;;; NEXT---NEXT SQUARE IN A GIVEN HEADING
(DEFUN NEXT (HEADING)
(OR (FIXP HEADING)
(ERRBREAK 'NEXT
'"INPUT MUST BE A NUMBER"))
(SETQ HEADING (\ HEADING 360.))
(AND (MINUSP HEADING) (SETQ HEADING (+ HEADING 360.)))
(COND ((ZEROP HEADING) (NORTH))
((= HEADING 90.) (EAST))
((= HEADING 180.) (SOUTH))
((= HEADING 270.) (WEST))))
(DEFUN FRONT NIL (NEXT (HEADING :GERM)))
;;RETURN SQUARE FACING ANY SIDE
(DEFUN RIGHTSIDE NIL (NEXT (+ (HEADING :GERM) 90.)))
(DEFUN REAR NIL (NEXT (+ (HEADING :GERM) 180.)))
(DEFUN LEFTSIDE NIL (NEXT (+ (HEADING :GERM) 270.)))
(PUTPROP 'FSIDE 'FRONT 'EXPR)
(PUTPROP 'RSIDE 'RIGHTSIDE 'EXPR)
(PUTPROP 'BSIDE 'REAR 'EXPR)
(PUTPROP 'LSIDE 'LEFTSIDE 'EXPR)
(DEFUN HERE NIL (WHERE :GERM))
;;POSITION OF CURRENT GERM
(DEFUN XCOR NIL (CAR (HERE)))
;;X-COORDINATE LEFT TO RIGHT
(DEFUN YCOR NIL (CADR (HERE)))
;;Y-COORDINATE BOTTOM TO TOP
(DEFUN WRAP NIL (DEFPROP CHECK-EDGE WRAP-CHECK-EDGE EXPR) (SETQ :WRAPAROUND T))
(DEFUN NOWRAP NIL (DEFPROP CHECK-EDGE NO-WRAP-CHECK-EDGE EXPR) (SETQ :WRAPAROUND NIL))
(NOWRAP)
;;*PAGE
;;; RETURN THE SQUARE IN THE SPECIFIED DIRECTION FROM
;;; (HERE). IF THIS GOES BEYOND BOARD EDGE, RETURN 'CROSSBORDER IN NORMAL
;;; MODE, OR WRAPAROUND IN WRAPAROUND MODE.
(DEFUN NORTH NIL (CHECK-EDGE (LIST (XCOR) (1+ (YCOR)))))
(DEFUN SOUTH NIL (CHECK-EDGE (LIST (XCOR) (1- (YCOR)))))
(DEFUN EAST NIL (CHECK-EDGE (LIST (1+ (XCOR)) (YCOR))))
(DEFUN WEST NIL (CHECK-EDGE (LIST (1- (XCOR)) (YCOR))))
(DEFUN NO-WRAP-CHECK-EDGE (POS) (COND ((GRIDP POS) POS) ('BORDER)))
(DEFUN WRAP-CHECK-EDGE (POS)
(MAPCAR '(LAMBDA (X) (COND ((< X 0.) (+ :GRIDSIZE X))
((> X (1- :GRIDSIZE)) (- X :GRIDSIZE))
(X)))
POS))
(DEFUN HOME NIL (MOVE '(0. 0.)))
;;*PAGE
(DEFUN LISTP MACRO (CALL)
(RPLACA CALL 'NOT)
(RPLACD CALL (LIST (CONS 'ATOM (CDR CALL))))
CALL)
;;; MOVE CURRENT GERM TO <PLACE>.
;;; GENERATES ERROR MESSAGE IF ILLEGAL
(DEFUN MOVE (PLACE)
(AND PLACE (LEGALPOS 'MOVE PLACE))
(COND ((OR (ATOM PLACE) (NOT (GRIDP PLACE)) (GETSQUARE PLACE 'OBSTACLE))
(ERRBREAK 'MOVE
'"ATTEMPT TO MOVE TO ILLEGAL POSITION"))
((OUTPUT-TO-MAIN-SCREEN)
(NOINTERRUPT T)
(REMSQUARE (HERE) 'INHABITANT)
(PRINTSQUARE (HERE))
;;OUT WITH THE OLD GERM
(STORE (WHERE :GERM) PLACE)
(COND ((GETSQUARE PLACE 'INHABITANT)
(KILL (GETSQUARE PLACE 'INHABITANT))
(OUTPUT-TO-MAIN-SCREEN)
(NOINTERRUPT T)))
(PUTSQUARE (HERE) :GERM 'INHABITANT)
(PRINTSQUARE PLACE)
(OUTPUT-TO-ECHO-AREA)
(NOINTERRUPT NIL)))
'?)
;;IN WITH THE NEW
(DEFUN TOUCH (POS)
(OR (AND (ATOM POS) POS)
(AND (NOT (GRIDP POS)) 'BORDER)
(GETSQUARE POS 'OBSTACLE)))
(DEFUN STEP (HEADING)
;;ACCEPTS NUMERICAL ARG FOR MOVING GERM
(MOVE (NEXT HEADING)))
(DEFUN WHAT (PLACE)
;;ALL INFO AT <PLACE>
(LEGALPOS 'WHAT PLACE)
(CDR (GERMARRAY (CAR PLACE) (CADR PLACE))))
(DEFUN FOOD (PLACE) (OR (ONUMBERP (GETSQUARE PLACE 'FOOD)) 0.))
;;NUMBER OF FOOD PARTICLES AT <PLACE>
(DEFUN ONUMBERP (N) (AND (NUMBERP N) N))
(DEFUN EAT (MORSELS)
;;REMOVE <MORSELS> FROM FOOD SUPPLY AT (HERE)
(OR (NUMBERP MORSELS)
(ERRBREAK 'EAT
'"INPUT MUST BE AN INTEGER"))
(COND ((> MORSELS (FOOD (HERE)))
(ERRBREAK 'EAT
'"YOU TRIED TO EAT TOO MUCH"))
((PUTSQUARE (HERE) (- (FOOD (HERE)) MORSELS) 'FOOD)))
;;INCREASE THE GERM'S FOOD SUPPLY BY WHAT HE JUST ATE.
(STORE (FOODSUPPLY :GERM) (+ MORSELS (FOODSUPPLY :GERM))))
(DEFUN FOODP (PLACE)
(AND (GETSQUARE PLACE 'FOOD) (> (GETSQUARE PLACE 'FOOD) 0.)))
(DEFUN GETSQUARE (PLACE IND)
;;PROPERTY STORAGE AND RETRIEVAL FUNCTIONS
(AND (LISTP PLACE)
(LEGALPOS 'GETSQUARE PLACE)
(GET (APPLY 'GERMARRAY PLACE) IND)))
(DEFUN PUTSQUARE (PLACE THING IND)
(AND (LISTP PLACE)
(LEGALPOS 'PUTSQUARE PLACE)
(PUTPROP (APPLY 'GERMARRAY PLACE) THING IND)))
(DEFUN REMSQUARE (PLACE IND)
(AND (LISTP PLACE)
(LEGALPOS 'REMSQUARE PLACE)
(REMPROP (APPLY 'GERMARRAY PLACE) IND)))
;;(CURSORPOS <X> <Y> ) MOVES THE CURSOR TO XTH LINE [FROM TOP], YTH COLUMN GERMLAND
;;COORDINATES ARE LEFT-TO-RIGHT, BOTTOM-TO-TOP.
(DEFUN PRINTSQUARE (PLACE)
;;PRINTS ONE SQUARE OF THE GRID.
(CURSORPOS (TIMES (- :GRIDSIZE (CADR PLACE)) VERTSCALE)
(TIMES HORIZSCALE (CAR PLACE)))
(CURSORPOS 'K)
;;OBSTRUCTED SQUARES ARE X'S, FOOD IS NUMBERS, EMPTY SQUARE IS A POINT
(COND ((GETSQUARE PLACE 'INHABITANT)
(PRINC (LOOKLIKE (GETSQUARE PLACE 'INHABITANT))))
((GETSQUARE PLACE 'OBSTACLE) (PRINC 'X))
((FOODP PLACE) (PRINC (FOOD PLACE)))
((PRINC '/.))))
(DEFUN OBSTRUCT (POSITION) (PUTSQUARE POSITION 'OBSTACLE 'OBSTACLE))
;;PLACE AN OBSTACLE AT <POSITION>. NOTHING CAN BE MOVED THERE.
(DEFUN DESTRUCT (POSITION) (REMSQUARE POSITION 'OBSTACLE))
;;REMOVE OBSTACLE AT POSITION
(DEFUN KILL (GERM)
(NOINTERRUPT T)
(OUTPUT-TO-MAIN-SCREEN)
(CURSORPOS 0. 0.)
(PRINC '" GERM ")
(PRINC GERM)
(PRINC '" IS DEAD- R. I. P.")
(REMSQUARE (WHERE GERM) 'INHABITANT)
(PRINTSQUARE (WHERE GERM))
(OUTPUT-TO-ECHO-AREA)
(NOINTERRUPT NIL)
GERM)
(DEFUN REPEAT FEXPR (LPROGRAMS)
;;PROGRAM CONTROL FUNCTION ATTACHES NTH ARG TO NTH GERM, EXECUTES EACH PROGRAM
;;ONCE PER CYCLE AND REPEATS. IF USER TYPES A SPACE, DOES 1 GENERATION. IF HE
;;TYPES A NUMBER, DOES THAT MANY GENERATIONS. Q STOPS REPEAT.
(PROG (TYPED)
(OR (AND LPROGRAMS (SETQ PROGRAMS LPROGRAMS))
PROGRAMS
(ERRBREAK 'REPEAT
'"NO PROGRAMS TO REPEAT"))
(CURSORPOS 'C)
AGAIN(DO ((CYCLES (COND ((AND (PRINC 'REPEAT>/ )
(= (TYIPEEK) 32.))
(READCH)
(TERPRI)
1.)
((MEMQ (TYIPEEK) '(1. 8. 13. 28.)) (READCH) 0.)
((MEMQ (TYIPEEK) '(81. 113.))
(READCH) (AND (= (TYIPEEK) 13.) (READCH))
(RETURN (ASCII 0.)))
((AND (SETQ TYPED (TYPEIN))
(ONUMBERP TYPED)))
((ERRBREAK
'REPEAT
'"REPEAT ACCEPTS ONLY SPACE, NUMBER, OR Q AS INPUT")))
(SUB1 CYCLES)))
((ZEROP CYCLES))
(DO ((:GERM 1. (1+ :GERM))
(CONTROL (OR LPROGRAMS PROGRAMS) (CDR CONTROL)))
((NULL CONTROL))
(EVAL (CAR CONTROL))
(AND :HUNGRY
(COND ((ZEROP (FOODSUPPLY :GERM)) (KILL :GERM))
((STORE (FOODSUPPLY :GERM) (1- (FOODSUPPLY :GERM))))))))
(GO AGAIN)))
(DEFUN GERM (NUMBER PLACE)
;;INITIALIZE GERM <NUMBER> AT <PLACE> TO LOOK LIKE <APPEARANCE> [ONE CHARACTER]
(REMSQUARE (WHERE NUMBER) 'INHABITANT)
(PUTSQUARE PLACE NUMBER 'INHABITANT)
(STORE (WHERE NUMBER) PLACE)
(SETQ :GERM NUMBER))
(DEFUN PRINTGRID NIL
;;DISPLAY GRID
(NOINTERRUPT T)
(OUTPUT-TO-MAIN-SCREEN)
(CLEARSCREEN)
(DO ((J (SUB1 :GRIDSIZE) (SUB1 J)) (RESET-CURSOR NIL))
((MINUSP J))
(DO I 0. (ADD1 I) (> I (SUB1 :GRIDSIZE)) (PRINTSQUARE (LIST I J))))
(OUTPUT-TO-ECHO-AREA)
(NOINTERRUPT NIL)
(ASCII 0.))
(DEFUN CLEARSCREEN NIL (CURSORPOS 'C))
;;BLANK DISPLAY SCREEN
(SSTATUS INTERRUPT 14. '(LAMBDA (USELESS) (PRINTGRID) '?))
;;CONTROL-\ TYPED BY USER WILL REDISPLAY THE GRID USEFUL FOR RECOVERING FROM DATAPOINT
;;MALFUNCTION
(DEFUN FILLFOOD (N)
;;FILL WORLD WITH N PARTICLES OF FOOD PER SQUARE
(OR (NUMBERP N)
(ERRBREAK 'FILLFOOD
'"INPUT MUST BE NUMBER OF FOOD PARTICLES"))
(DO J
(SUB1 :GRIDSIZE)
(SUB1 J)
(MINUSP J)
(DO I
0.
(ADD1 I)
(> I (SUB1 :GRIDSIZE))
(PUTSQUARE (LIST I J) N 'FOOD)))
N)
(DEFUN NORTHP (G) (> (CADR (WHERE G)) (CADR (WHERE :GERM))))
(DEFUN SOUTHP (G) (< (CADR (WHERE G)) (CADR (WHERE :GERM))))
(DEFUN EASTP (G) (> (CAR (WHERE G)) (CAR (WHERE :GERM))))
(DEFUN WESTP (G) (< (CAR (WHERE G)) (CAR (WHERE :GERM))))
;;THESE RETURN T IF <G> IS NORTH/SOUTH/EAST/WEST/ OF :GERM
(DEFUN ACCESSIBLE (SQUARE WHO)
(LEGALPOS 'ACCESSIBLE SQUARE)
(AND (MEMBER (MAPCAR '- (WHERE WHO) SQUARE)
'((1. 0.) (0. 1.) (-1. 0.) (0. -1.)))
T))
(DEFUN EDGEP (PLACE)
(LEGALPOS 'EDGEP PLACE)
(NOT (APPLY 'AND
(MAPCAR 'GRIDP
(LIST (LIST (CAR PLACE) (ADD1 (CADR PLACE)))
(LIST (ADD1 (CAR PLACE)) (CADR PLACE))
(LIST (CAR PLACE) (SUB1 (CADR PLACE)))
(LIST (SUB1 (CAR PLACE)) (CADR PLACE)))))))
(DEFUN CORNERP (PLACE)
(LEGALPOS 'CORNERP PLACE)
(< 1.
(APPLY '+
(MAPCAR '(LAMBDA (X) (COND ((GRIDP X) 0.) (1.)))
(LIST (LIST (CAR PLACE) (ADD1 (CADR PLACE)))
(LIST (ADD1 (CAR PLACE)) (CADR PLACE))
(LIST (CAR PLACE) (SUB1 (CADR PLACE)))
(LIST (SUB1 (CAR PLACE)) (CADR PLACE)))))))
;;* PAGE
(DEFUN RUNGERM FEXPR (LPROGRAMS)
(PROG (HELP :GERM TYPED)
(AND LPROGRAMS
(PRINTGRID)
(APPLY 'REPEAT LPROGRAMS)
(RETURN (ASCII 0.)))
(SETQ :GERM 1. PROGRAMS NIL)
(CLEARSCREEN)
(PRINC
'"WELCOME TO GERMLAND!!!
DO YOU NEED HELP? ")
(SETQ HELP (ASK))
(PRINC
'"
WHAT SIZE GRID WOULD YOU LIKE? (TYPE A NUMBER) ")
(GRID (TYPEIN))
(PRINC
'"
NOW, LET'S PUT SOME GERMS IN GERMLAND. ")
BIRTH(GERM
:GERM
(AND
(PRINC
'"
WHAT SQUARE SHOULD THE GERM START OUT ON? ")
(OR
(NOT HELP)
(PRINC
'"
(A SQUARE IS A SENTENCE (<X> <Y>) WHERE <X> IS THE NUMBER
OF SQUARES FROM THE LEFT AND <Y> IS THE NUMBER OF
SQUARES FROM THE BOTTOM) "))
(LEGALPOS 'RUNGERM (REQUEST))))
(PRINC '" THIS GERM WILL LOOK LIKE: ")
(PRINC (LOOKLIKE :GERM))
(PRINC '"
WHAT SHOULD THIS GERM'S PROGRAM BE? ")
(SETQ TYPED
(REQUEST)
PROGRAMS
(CONS (COND ((ATOM TYPED) (LIST TYPED)) (TYPED)) PROGRAMS))
(OR (GETL (CAAR PROGRAMS) '(EXPR FEXPR SUBR FSUBR MACRO LSUBR))
(ERRBREAK 'RUNGERM
(LIST (CAAR PROGRAMS)
'" IS NOT DEFINED")))
(AND (< :GERM 8.)
(PRINC '"
SHALL WE ADD ANOTHER GERM? ")
(ASK)
(SETQ :GERM (ADD1 :GERM))
(GO BIRTH))
(PRINC '"
SHOULD THE GERMS BE HUNGRY? ")
(AND
HELP
(PRINC
'"
(HUNGRY GERMS MUST EAT 1 MORSEL OF FOOD FOR EACH TURN OR THEY DIE)"))
(SETQ :HUNGRY (ASK))
(AND
:HUNGRY
(PROG NIL
(PRINC
'"
THEN YOU MUST FILL SOME SQUARES WITH FOOD.")
(COND
(HELP
(PRINC
'"
TYPE A NUMBER TO FILL ALL THE SQUARES OF GERMLAND
WITH THAT MANY MORSELS OF FOOD. (TYPE 0 IF
YOU DON'T WANT THIS TO HAPPEN) ? "))
((PRINC '"
HOW MANY PARTICLES OF FOOD DO YOU WANT ON EACH SQUARE? (TYPE A NUMBER) ")))
(FILLFOOD (TYPEIN))
(PRINC
'"DO YOU WANT TO ADD MORE FOOD TO SPECIFIC SQUARES?")
(OR (ASK) (GO FED))
FEED (PRINC
'"TYPE THE AMOUNT OF FOOD TO ADD (OR 0 IF YOU ARE DONE): ")
(SETQ TYPED (TYPEIN))
(AND (ZEROP TYPED) (GO FED))
(PRINC
'"TYPE A LIST OF SQUARES TO ADD THIS FOOD TO: ")
(MAPC '(LAMBDA (X) (PUTSQUARE X TYPED 'FOOD)) (REQUEST))
(GO FEED)
FED (RETURN NIL)))
(COND
(HELP
(PRINC
'"
TYPE A LIST OF SQUARES WHICH YOU WANT TO BE OBSTRUCTED? "))
((PRINC '"
OBSTRUCTIONS? ")))
(MAPC 'OBSTRUCT (REQUEST))
RUNNIT
(PRINC
'"
OKAY, WE'RE READY TO START. SHALL WE BEGIN? ")
(SETQ PROGRAMS (REVERSE PROGRAMS))
(AND (ASK) (STARTGRID) (REPEAT))
(RETURN (ASCII 0.))))
;;* PAGE
;;; GERMDEMOS IMPLEMENTS THE STANDARDIZED FORMAT FOR GERM DEMOS
;;; THE DEMOS ARE IN THE FILE AI:LLOGO;DEMOS >
;;; THE FORMAT FOR A DEMO IS:
;;; NAME OF DEMO, STRING TERMINATED BY ALT-MODE,
;;; SERIES OF THINGS TO BE READ-EVAL-PRINTED, NIL.
;;; TWO NILS END THE FILE. NOTE THAT THE FILE IS TO BE READ WITH
;;; THE LISP READTABLE, BUT THE LOGO OBARRAY, SINCE THE FILE IS IN
;;; LISP FORMAT, BUT THE DEMO NAMES MUST BE ACCESSIBLE FROM LOGO.
(DEFUN GERMDEMOS NIL
(PROG (^Q READTABLE REPEAT-INTRO)
(UREAD DEMOS GERM AI LLOGO)
(CLEARSCREEN)
(SETQ
^Q
T
READTABLE
LISPREADTABLE
REPEAT-INTRO
'"
TYPE A SPACE TO DO ONE GENERATION, OR A NUMBER TO DO THAT
MANY GENERATIONS.
IF THE BOARD GETS MESSED UP, HIT CONTROL-\.
TYPE Q TO STOP.
(TYPE SPACE TO START)")
(NOGRID)
(SSTATUS PAGEPAUSE T)
(PRINC
'"
GERMLAND IS A GRID OF SQUARES ON WHICH MAY LIVE UP
TO 10 GERMS. SQUARES MAY ALSO CONTAIN FOOD FOR THEM TO
EAT OR OBSTACLES WHICH PREVENT THEM FROM MOVING.
WITH EACH GERM YOU ASSOCIATE A FIXED PROGRAM, WHICH IT REPEATS
ONCE EACH GENERATION UNTIL IT DIES.
SEE THE LLOGO MANUAL (AI MEMO 307) FOR PRIMITIVES TO USE IN WRITING
GERM PROGRAMS, AND LOGO WORKING PAPER 7 FOR MORE INFO.")
(DO ((NAME (READ) (READ)) (EVAL?))
((EQ NAME NIL))
(TERPRI)
(PRINC '"DO YOU WANT TO SEE THE ")
(PRINC NAME)
(PRINC '" DEMO? ")
(SETQ EVAL? (ASK))
(AND EVAL? (CLEARSCREEN))
(DO ((C (TYI) (TYI))) ((= C 27.)) (AND EVAL? (NOT (= C 10.)) (TYO C)))
(DO ((FORM (READ) (READ)))
((NULL FORM))
(AND EVAL? ((LAMBDA (^Q) (EVAL FORM)) NIL)))
(NOGRID)
(SSTATUS PAGEPAUSE T)))
(SSTATUS PAGEPAUSE NIL)
(PRINC
'"
OKAY, NOW IT'S YOUR TURN. WHEN YOU FINISH WRITING YOUR GERM,
SET UP A GRID USING RUNGERM, AND TRY IT OUT.
HAVE FUN!
") '?)
(PROG NIL
(GRID 3.)
(GERM 1. '(0. 0.))
(STARTGRID)
(PRINC
'"
WELCOME TO GERMLAND.
CALL GERMDEMOS TO SEE DEMOSTRATION PROGRAMS,
CALL RUNGERM TO REINITIALIZE GRID.
") (RETURN '?))

167
src/llogo/hang.1 Normal file
View File

@@ -0,0 +1,167 @@
TO HANGMAN
110 MAKE "WRONG." 1 MAKE "GUESSED" :EMPTY
120 MAKE "WRONG" (WORD :BLANK :BLANK :BLANK :BLANK :BLANK)
130 MAKE "NUM" (RANDOM 0 :WORDMAX)
190 MAKE "WORD" THING WORD "WORD" :NUM
200 MAKE "UNDER" SETT "-" COUNT :WORD
210 MAKE "OVER" SETT :BLANK COUNT :WORD
220 PRINT WORD :SKIP :SKIP
230 TYPE :BLANK PRINT .EXPAND :UNDER
240 TEST :WRONG.>6
250 IFTRUE GO 410
260 TYPE WORD :BLANK :BLANK TYPE "YOUR GUESS?"
270 MAKE "GUESS" TYPEIN
280 TEST GREATERP COUNT :GUESS 1
290 IFTRUE GO 550
291 IF NOT ALPHP :GUESS PRINT SENTENCE :GUESS "IS NOT A LETTER. TRY AGAIN." GO 260
293 TEST CONTAINS :GUESS :GUESSED
294 IFFALSE GO 297
295 PRINT SENTENCE SENTENCE "YOU ALREADY GUESSED" WORD :GUESS " . " "TRY AGAIN."
297 MAKE "GUESSED" SENTENCE :GUESSED :GUESS
300 TEST CONTAINS :GUESS :WORD
310 IFFALSE MAKE "WRONG" WORD :WRONG :GUESS
320 IFFALSE PRINT SENTENCE SENTENCE SENTENCE :SKIP .EXPAND :OVER :WRONG SENTENCE :SKIP .EXPAND :UNDER
330 TEST CONTAINS :GUESS :WORD
340 IFFALSE MAKE "WRONG." :WRONG.+1
350 IFFALSE GO 240
360 MAKE "OVER" .RESET :WORD :GUESS :OVER
370 PRINT SENTENCE SENTENCE SENTENCE :SKIP .EXPAND :OVER :WRONG SENTENCE :SKIP .EXPAND :UNDER
380 TEST :OVER=:WORD
390 IFTRUE GO 560
400 GO 240
410 BELLS 6 PRINT SENTENCE :SKIP "YOU GOT MORE THAN 6 WRONG GUESSES. HA I WIN."
420 PRINT SENTENCE "MY WORD WAS" WORD :WORD " . "
430 STOP
550 TEST :GUESS=:WORD
560 IFTRUE TYPE "YOU BEAT ME " BELLS 4 PRINT "THAT MAKES ME SO MAD (I AM A SORE LOSER) YOU MAKE MY DIODES STEAM"
570 IFTRUE STOP
620 PRINT "WRONG GUESS, TRY AGAIN."
630 GO 260
END
TO BELLS :NUM
10 IF :NUM=0 STOP ELSE TYPE :BELL BELLS :NUM-1
END
TO SETT :K :L
10 MAKE "M" 1
20 MAKE "N" :EMPTYW
30 IF :L=:M OUTPUT WORD :N :K
40 MAKE "N" WORD :N :K
50 MAKE "M" SUM :M 1
60 GO 30
END
TO .EXPAND :.WORD.
10 MAKE "EX" :EMPTY
20 MAKE "EX" SENTENCE :EX FIRST :.WORD.
30 MAKE ".WORD." BUTFIRST :.WORD.
40 TEST EQUAL COUNT :.WORD. 1
50 IFTRUE OUTPUT SENTENCE :EX :.WORD.
60 GO 20
END
TO ALPHP :QWERT
10 OUTPUT CONTAINS :QWERT "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
END
TO CONTAINS :OPP :POO
10 IF EMPTYP :POO OUTPUT NIL ELSE IF :OPP=FIRST :POO OUTPUT T ELSE OUTPUT CONTAINS :OPP BUTFIRST :POO
END
TO .RESET :A :B :C
10 MAKE "OP" :EMPTYW
20 TEST EMPTYP :A
30 IFTRUE OUTPUT :OP
40 TEST EQUAL FIRST :A :B
50 IFTRUE MAKE "OP" WORD :OP :B
60 IFFALSE MAKE "OP" WORD :OP FIRST :C
65 MAKE "C" BUTFIRST :C
70 MAKE "A" BUTFIRST :A
80 GO 20
END
TO ADDWORDS
10 IF NOT NUMBERP :WORDMAX PRINT "SOMETHING WRONG" STOP
20 MAKE "D" :WORDMAX+1
30 TYPE WORD WORD "WORD" :D ":"
40 MAKE WORD "WORD" :D TYPEIN
50 IF EMPTYP THING WORD "WORD" :D MAKE "WORDMAX" DIFFERENCE :D 1 STOP ELSE MAKE "D" SUM :D 1 GO 30
END
MAKE "NUM" "12"
MAKE "WORDMAX" "16"
MAKE "WORD" "DRAWING"
MAKE "UNDER" "-------"
MAKE "WRONG." "2"
MAKE "GUESS" "W"
MAKE "GUESSED" " E R A I D N G W"
MAKE "WRONG" "E "
MAKE "OVER" "DRAWING"
MAKE "M" "7"
MAKE "N" " "
MAKE "EX" " - - - - - -"
MAKE "OP" "DRAWING"
MAKE "D" "17"
MAKE "X" "HI"
MAKE "WORD0" "TRANSCENDENTAL"
MAKE "WORD1" "OPERATOR"
MAKE "WORD2" "MANUAL"
MAKE "WORD3" "BUTTON"
MAKE "WORD4" "RIBBON"
MAKE "WORD5" "SERVICE "
MAKE "WORD6" "CRASH"
MAKE "WORD7" "EQUIPMENT"
MAKE "WORD8" "EXPLOSION"
MAKE "WORD9" "HYPERACTIVE "
MAKE "WORD10" "ELECTRICAL"
MAKE "WORD11" "GENERATOR"
MAKE "WORD12" "DRAWING"
MAKE "WORD13" "INTELLIGENCE "
MAKE "WORD14" "ARTIFICIAL"
MAKE "WORD15" "COMPUTER"
MAKE "WORD16" "ATOMIZER"
MAKE "WORD17" "IRIDESCENT"
MAKE "BLANK" ASCII 32.
MAKE "BELL" ASCII 7
MAKE "SKIP" ASCII 13.
MAKE "A" "0"
MAKE "B" "4"
MAKE "Z" "5"
MAKE "N" "10"
MAKE "C" "6"
TO DEC
10 TYPE "ENTER NUMERATOR :"
20 MAKE "A" TYPEIN
30 TYPE "ENTER DENOMINATOR :"
40 MAKE "B" TYPEIN
50 TERPRI
110 MAKE "Z" 5
120 IF :B < :A THEN GO 140 ELSE IF :B = :A THEN GO 130
122 TYPE '$ 0.$
127 GO 210
130 TERPRI
132 PRINT 1
136 TERPRI
138 STOP
140 PRINT "THIS PROGRAM ONLY EVALUATES FRACTIONS < 1"
150 STOP
210 MAKE "N" 10
220 IF :N * :A > :B THEN GO 410
230 MAKE "N" 10 * :N
240 TYPE 0
250 GO 220
410 MAKE "C" 1
420 IF :N * :A < :C * :B THEN GO 510
430 MAKE "C" :C + 1
440 GO 420
510 TYPE :C - 1
520 MAKE "A" :N * :A - (:C - 1) * :B
530 IF - :A < 0 THEN GO 550
540 TERPRI
545 STOP
550 IF :A < :B THEN GO 210 ELSE IF :A = :B THEN GO 130 ELSE GO 140
END

12480
src/llogo/llogo.lisp
View File

File diff suppressed because it is too large Load Diff

197
src/llogo/loader.1 Normal file
View File

@@ -0,0 +1,197 @@
(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)))
(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 '(> AI 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 AI LLOGO))))
(CDR (GET 'LLOGO 'FILES)))))
(AND DUMP (UWRITE AI 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)
(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 > AI 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))

342
src/llogo/music.1 Normal file
View File

@@ -0,0 +1,342 @@
;;; LLOGO MUSIC BOX PRIMITIVES
;;; ; SEE HARDWARE
;;MEMOS 8 AND 9.
;;*SLASHIFY #
(DECLARE (OR (STATUS FEATURE DEFINE) (FASLOAD DEFINE FASL AI LLOGO)))
(DECLARE (GENPREFIX MUSIC)
(SPECIAL :INSTRUMENT :NVOICES :SCALEBASE :VOICE :SAVBUF BUFFERS NEWMUSIC
MODMUSIC DEFAULTSCALEBASE CBUF1 CBUF2 CBUF3 CBUF4 WBUF1 WBUF2 WBUF3
WBUF4 CBUF WBUF ERRLIST)
(*FEXPR QUERY NOTIMP CHORUS4 CHORUS3 CHORUS2 CHORUS)
(*LEXPR ERRBREAK)
(*EXPR NEWMUSIC MODMUSIC))
;; THIS FILE WILL USE BASE 10 NUMBERS (FOLLOWED BY ".")
(SSTATUS FEATURE MUSIC)
(COND ((STATUS FEATURE LLOGO)
(MAPC '(LAMBDA (BOTH-OBARRAY-ATOM) (OBTERN BOTH-OBARRAY-ATOM LOGO-OBARRAY))
'(N O :INSTRUMENT :MAX :NVOICES :VOICE :SCALEBASE :SAVBUF LEGATO)))
((DEFPROP MAKE SET EXPR)
(DEFUN HOMCHECK (USELESS) USELESS)
(DEFUN OBTERN (IGNORE THIS) IGNORE)
(DEFUN ERRBREAK ARGS (PRINT (ARG ARGS)) (APPLY (FUNCTION BREAK) (LIST (ARG 1.) T)))
(DEFUN REQUEST NIL (TERPRI) (PRINC '<) (READ))))
[MULTICS (DECLARE (*FEXPR TURN_RAWO_ON TURN_RAWO_OFF))
(CLINE
"INITIATE >UDD>AP>LIB>TURN_RAWO_ON TURN_RAWO_ON TURN_RAWO_OFF")
(PUTPROP 'TURN_RAWO_ON
(DEFSUBR "TURN_RAWO_ON"
"TURN_RAWO_ON"
0.)
'FSUBR)
(PUTPROP 'TURN_RAWO_OFF
(DEFSUBR "TURN_RAWO_OFF"
"TURN_RAWO_OFF"
0.)
'FSUBR)]
;;SUBROUTINES FOR TURNING ON AND OFF "RAW" OR IMAGE MODE OUTPUT. THIS OUTPUTS CHARACTERS
;;LIKE CONTROL CHARACTERS DIRECTLY, RATHER THAN AS ORDINARY CHARACTERS PRECEDED BY
;;UPARROW [ITS] OR BACKSLASH [MULTICS]. QUITTING MUST BE DISABLED FROM INSIDE THE SYSTEM
;;CALL.
;;THE FOLLOWING LAP FUNCTIONS WILL PROBABLY NEED CHANGING
;;WHEN NEW I/O SYSTEM EXISTS ON ITS LISP.
[ITS (DECLARE (*EXPR TURN_RAWO_ON TURN_RAWO_OFF))
(LAP TURN_RAWO_ON SUBR)
(ARGS TURN_RAWO_ON (NIL . 0.))
(HLLOS 0. NOQUIT)
(*OPEN 2. (% SIXBIT / / %TTY))
(*VALUE)
(HLLZS 0. NOQUIT)
(POPJ P)
NIL
(LAP TURN_RAWO_OFF SUBR)
(ARGS TURN_RAWO_OFF (NIL . 0.))
(HLLOS 0. NOQUIT)
(*OPEN 2. (% SIXBIT / / 1TTY/.LISP/./ OUTPUT))
(*VALUE)
(HLLZS 0. NOQUIT)
(POPJ P)
NIL
NIL]
(DEFINE INITMUSIC NIL
;; INITIALIZE . DONT WANT SPURIOUS CR/LF ON PRINC.
(SSTATUS TERPRI T)
(SETQ BUFFERS '(WBUF1 WBUF2 WBUF3 WBUF4 CBUF1 CBUF2 CBUF3 CBUF4))
(TERPRI)
(PRINC 'YOU/ ARE/ NOW/ USING/ THE/ LLOGO/ MINIMUSIC/ SYSTEM/.)
(COND ((EQ (QUERY / / / WHICH MUSIC BOX? (N OR O)) 'N) (NEWMUSIC))
((OLDMUSIC)))
(SETQ :SAVBUF NIL :INSTRUMENT 'LEGATO DEFAULTSCALEBASE 0.)
(MODMUSIC NIL)
(NVOICES 4.))
(DEFINE STARTMUSIC (ABB SM) NIL (QUERY TURN ON MUSIC BOX/, THEN TYPE /"OK/"/.) (PERFORM))
(DEFINE RESTARTMUSIC NIL (INITMUSIC) (STARTMUSIC))
(DEFUN WBUFS MACRO (X) '(LIST WBUF1 WBUF2 WBUF3 WBUF4))
(DEFUN CBUFS MACRO (X) '(LIST CBUF1 CBUF2 CBUF3 CBUF4))
(DEFUN VNEXT MACRO (X)
;; THE NEXT THREE DEFS ALLOW SING TO TAKE PERCUSSION NOTES BY NAME; USING DRUM AND
;;BRUSH IS MORE EFFICIENT.
(LIST '1+ (LIST 'REMAINDER (CADR X) ':NVOICES)))
(DEFINE REST NIL (- -25. :SCALEBASE))
(DEFINE BOOM NIL (- -24. :SCALEBASE))
(DEFINE GRITCH NIL (- -23. :SCALEBASE))
(DEFINE DRUM (DLIST)
(MAPC (FUNCTION (LAMBDA (D) (PLAY1 '/!) (PLAY '/ (SUB1 D)))) DLIST)
'?)
(DEFINE BRUSH (DLIST)
(MAPC (FUNCTION (LAMBDA (D) (PLAY1 '/") (PLAY '/ (SUB1 D)))) DLIST)
'?)
(DEFUN BCNT (A B) (+ (* 25. (CAAR A)) (CAAR B)))
(DEFINE CHORUS2 (PARSE 2.) FEXPR (X) (APPLY (FUNCTION CHORUS4) X))
(DEFINE CHORUS3 (PARSE 3.) FEXPR (X) (APPLY (FUNCTION CHORUS4) X))
(DEFINE CHORUS4 (PARSE 4.) FEXPR (X)
(TERPRI)
(PRINC '/(TRY/ USING/ CHORUS/ NEXT/ TIME/ YOU/'LL/ LIKE/ IT/))
(APPLY (FUNCTION CHORUS) X))
(DEFINE MBUFINIT NIL (NOTIMP MBUFINIT MBUFCLEAR))
(DEFINE MBUFPUT X (NOTIMP MBUFPUT PLAY))
(DEFINE MBUFNEXT (N) (NOTIMP MBUFNEXT ?))
(DEFINE MLEN (ABB :MAX) NIL (APPLY (FUNCTION MAX)
;; NUMBER OF NOTES IN LARGEST BUFFER.
(MAPCAR (FUNCTION BCNT) (WBUFS) (CBUFS))))
(DEFINE VLEN (ABB MBUFCOUNT) NIL (BCNT WBUF CBUF))
;; NUMBER NOTES IN CURRENT BUFFER.
(DEFINE NOMUSIC NIL (NOTIMP NOMUSIC ?))
(DEFINE PERFORM (ABB PM) NIL (MBUFOUT) (MBUFCLEAR))
(DEFINE NEWMUSIC NIL
;; ASK WHICH PORT (4 IS TTY).
(SETQ NEWMUSIC
(QUERY / / / WHICH PORT IS MUSIC BOX? (1/, 2. OR 3.))
NEWMUSIC
(COND ((= NEWMUSIC 1.) 79.)
;; LETTER O
((= NEWMUSIC 3.) 69.)
;;LETTER E
(74.))
;; LETTER J
ERRLIST
'((TURN_RAWO_ON) (TYO 17.) (TYO 32.) (TURN_RAWO_OFF)))
;;CNTRL-Q SPACE (RESTORE TTY)
(AND (BOUNDP ':NVOICES) (= :NVOICES 3.) (NVOICES 4.))
'?)
(DEFINE OLDMUSIC NIL (SETQ NEWMUSIC NIL
ERRLIST '((TURN_RAWO_ON)
(MAPC 'TYO
'(99. 103. 32. 32. 32. 32. 32. 71. 32. 65.
32. 32. 32. 32. 32. 32. 32. 66.))
(TURN_RAWO_OFF)))
'?)
(DEFINE MBUFCLEAR (ABB MCLEAR) NIL (MAPC (FUNCTION STARTATTACH) BUFFERS) (VOICE 1.))
(DEFINE MODMUSIC (TORNIL) (COND ((SETQ MODMUSIC TORNIL) (SETQ :SCALEBASE -25.))
((SETQ :SCALEBASE DEFAULTSCALEBASE))))
(DEFINE VOICES (N) (NOTIMP VOICES NVOICES))
(DEFUN NOTIMP FEXPR (X)
(ERRBREAK (CAR X)
(LIST '"NOT IMPLEMENTED IN LLOGO: USE"
(CADR X))))
(DEFINE VOICE (N)
(SETQ :VOICE N)
(COND ((AND NEWMUSIC (= N 3.) (< :NVOICES 4.)) (NVOICES 4.))
((< :NVOICES N) (NVOICES N)))
(COND ((= N 1.) (SETQ CBUF CBUF1 WBUF WBUF1))
((= N 2.) (SETQ CBUF CBUF2 WBUF WBUF2))
((= N 3.) (SETQ CBUF CBUF3 WBUF WBUF3))
((= N 4.) (SETQ CBUF CBUF4 WBUF WBUF4))
(MODMUSIC (VOICE (VNEXT (SUB1 N))))
((ERRBREAK 'VOICE '"NO SUCH VOICE")))
'?)
(DEFINE NVOICES (N)
(COND ((AND NEWMUSIC (= N 3.))
(ERRBREAK 'NVOICES
'"3. VOICES ILLEGAL ON NEW BOX USE 4."))
((AND (> N 0.) (< N 5.)) (SETQ :NVOICES N))
(MODMUSIC (NVOICES (1+ (REMAINDER (SUB1 N) 4.))))
((ERRBREAK 'NVOICES '"NO SUCH VOICE")))
(MBUFCLEAR))
(DEFUN CRUNCH (CBUF WBUF)
(COND ((CDDR CBUF) (ATTACH1 WBUF (MAKNAM (CDDR CBUF))) (STARTATTACH (CADR CBUF)))
(CBUF)))
(DEFUN PLAY1 (NOTE)
;; CRUNCHES A CHARACTER LIST INTO A PNAME ATOM AND PUTS IT ON A WORD LIST WHICH IS
;;ASSOCIATED WITH IT. NOTE THAT (CADR LST) IS THE NAME OF THE LIST, AND (CAR LST)
;;HAS INTERNAL INFO (COUNT, PTR), SINCE THESE ARE "ATTACH LISTS". NORMALLY ONE
;;WANTS TO SAY (SETQ CBUF (CRUNCH CBUF WBUF))! JUST THE CHAR PART REINITIALIZE
;;PUTS NOTE IN THE CURRENT CHAR BUF EVERY 25 CHARS, WE CRUNCH TO CONSERVE FREE
;;SPACE. (ATTACH1 RETURNS THE NUMBER OF CHARS SO FAR).
(AND (> (ATTACH1 CBUF NOTE) 24.) (SETQ CBUF (CRUNCH CBUF WBUF))))
(DEFUN PLAY (NOTE TIMS) (DO I 1. (1+ I) (> I TIMS) (PLAY1 NOTE)))
(DEFINE SING (PITCH DUR)
(PLAY1 (SETQ PITCH (NOTECH PITCH)))
;; PUTS THE NOTE CORRESPONDING TO THIS PITCH NUMBER INTO THE CURRENT BUFFER (SEE
;;PLAY). FILLS THE DURATION WITH NOTES OR BLANKS DEPENDING ON WHETHER LEGATO OR
;;NOT. IF DURATION AT LEAST 2 WILL LEAVE AT LEAST ONE UNIT REST BETWEEN NOTES.
(PLAY (COND ((EQ :INSTRUMENT 'LEGATO) PITCH) ('/ )) (- DUR 2.))
(AND (> DUR 1.) (PLAY1 '/ ))
'?)
(DEFINE SONG (A B) (MAPC (FUNCTION SING) A B) '?)
(DEFINE CHORUS (PARSE L) FEXPR (COMS)
;;CHECK FOR WRONG NUMBER? FOR RECURSION
(MAPC (FUNCTION (LAMBDA (X) (EVAL X) (VOICE (VNEXT :VOICE)))) COMS)
'?)
(DEFINE NOTE (P D)
;; NOT QUITE SYNONYM, 11LOGO VARIANT OF SING.
(COND ((= P -28.) (PLAY '/ D))
((= P -27.) (DRUM (LIST D)))
((= P -26.) (BRUSH (LIST D)))
((= P -25.)
(ERRBREAK 'NOTE '"NOT A VALID PITCH"))
((SING (+ P 3.) D))))
(DEFUN NOTECH (P)
;; A MUSIC BOX NOTE IS AN ASCII CHAR IN OCTAL [40, 137] A STD LOGO PITCH IS A
;;NUMBER IN DECIMAL [-25.,38.] (0 = MIDDLE C) :SCALEBASE SPECIFIES OFFSETS FROM
;;STD, RELATIVE TO MIDDLEC 0. MODMUSIC NUMBERS FROM 0. TO DECIMAL 63. (IE
;;:SCALEBASE = -25.) MODMUSIC FEATURES "WRAPAROUND" , IE PITCH 64 = PITCH 0.
;;"NOTECH" RETURNS ASCII CHARS FOR PITCHS. 140 OCTAL 37 OCTAL OCT 37 IS A NULL
;;CHAR. IGNORED BY BOX.
(COND (MODMUSIC (ASCII (+ 32. (REMAINDER P 64.))))
((AND (< (SETQ P (+ P :SCALEBASE 57.)) 96.) (> P 31.)) (ASCII P))
((PRINT '"NOTE OUT OF MUSIC BOX RANGE")
(ASCII 31.))))
(DEFUN STARTATTACH (LNAM)
;; STARTS AN ATTACH LIST OF FORM ((CNT . PTR) LNAM) FOR USE WITH ATTACH, ATTACH1
;;COUNT IS THE NUMBER OF ELEMENTS IN (CDDR LST) PTR IS A PTR TO THE END OF THE
;;LST.
(RPLACA (SET LNAM (LIST NIL LNAM)) (CONS 0. (CDR (EVAL LNAM)))))
(DEFUN ATTACH1 (LST EL)
;; ATTACHES ATOM EL TO LIST LST LIST MUST BE AT LEAST TWO ELEMENTS LONG. THE
;;FIRST ELEMENT IS ASSUMED TO BE A DOTTED PAIR -- A COUNT OF THE ELEMENTS IN (CDDR
;;LST) AND A PTR TO THE END. THE SECOND ELEMENT IS THE NAME OF THE LIST ITSELF.
;;THIS INTERNAL INFO IS UPDATED BY ATTACH. VALUE RETURNED IS THE NEW COUNT. NEW
;;LISTS SHOULD BE INITIALIZED USING STARTATTACH. (NCONS IS DEFINED AS (CONS EL
;;NIL)).
(CAR (RPLACA (RPLACD (CAR LST) (CDR (RPLACD (CDAR LST) (NCONS EL))))
(1+ (CAAR LST)))))
(DEFUN MLTPLX (T1 T2 T3 T4 N)
;; MLTPLX 1 TO 4 ARGS (N), IGNORE REST .
(PROG (CBUF WBUF)
;;; REBIND .
(COND ((< N 2.) (RETURN T1))
((< N 3.) (SETQ T3 (SETQ T4 NIL)))
((< N 4.) (SETQ T4 NIL)))
(STARTATTACH 'CBUF)
(STARTATTACH 'WBUF)
TOP (OR T1 T2 T3 T4 (PROG2 (CRUNCH CBUF WBUF) (RETURN (CDDR WBUF))))
(SETQ T1 (ZAP T1) T2 (ZAP T2))
(AND (< N 3.) (GO TOP))
(SETQ T3 (ZAP T3))
(AND (> N 3.) (SETQ T4 (ZAP T4)))
(GO TOP)))
(DEFUN ZAP (TB)
(COND (TB (AND (GETCHAR (CAR TB) 2.)
(SETQ TB (NCONC (EXPLODEC (CAR TB)) (CDR TB))))
(PLAY1 (CAR TB))
(CDR TB))
((PLAY1 '/ ) NIL)))
(DEFINE MBUFOUT NIL (PLYTUN (MAKTUN)))
(DEFINE MAKETUNE (TUN) (MAKE TUN (CONS :NVOICES (MAKTUN))) TUN)
;; NEED TO KNOW # VOICES.
(DEFINE PLAYTUNE (TUN) ((LAMBDA (OLDV) (NVOICES (CAR TUN))
;;ELSE GARBAGE
(PLYTUN (CDR TUN))
;;WINS EVEN IF DIFFERENT M.BOX
(NVOICES OLDV))
:NVOICES)
'?)
;; RESTORE PREVIOUS STATE
(DEFUN MAKTUN NIL
(MAPC (FUNCTION CRUNCH) (CBUFS) (WBUFS))
(MLTPLX (CDDR WBUF1) (CDDR WBUF2) (CDDR WBUF3) (CDDR WBUF4) :NVOICES))
(DEFUN PLYTUN (TUN)
;; TUN IS PRE-MLTPLXED CHAR LIST
(TURN_RAWO_ON)
(COND (NEWMUSIC (TYO 17.)
;; CNTRL-Q (REAL)
(TYO NEWMUSIC)
;; PORT SELECTOR
(PRINC '/#0/ / / / /#)
(TYO (COND ((= :NVOICES 1.) 83.)
;; LETTER S
((= :NVOICES 2.) 34.)
;; DOUBLE QUOTE
(48.))))
;; NUMERAL 0
((PRINC '/c/g/ / / / / )
(TYO (+ 99. :NVOICES))
(PRINC '/ /a/ / / / / / / )))
(MAPC (FUNCTION PRINC) TUN)
(COND (NEWMUSIC (TYO 17.) (TYO 32.))
;; ^Q-SPACE RESTORE PORT 4 (TTY)
((TYO 98.)))
(TURN_RAWO_OFF)
;; LOWER B, RESTORE EXECUPORT PRINTER
'?)
(DEFUN QUERY FEXPR (X)
(TERPRI)
(MAPC (FUNCTION (LAMBDA (Y) (PRINC Y) (TYO 32.))) X)
;;; 32. A SPACE
(REQUEST))
(INITMUSIC)

579
src/llogo/parser.1 Normal file
View File

@@ -0,0 +1,579 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; LOGO PARSER ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;THE FUNCTION OF THE PARSER IS TO CONVERT A LINE OF LOGO CODE TO
;;;LISP. THE TOPLEVEL FUNCTION "PARSELINE" EXPECTS AS INPUT A LIST OF
;;;LOGO ATOMS AS, FOR EXAMPLE, ARE PRODUCED BY "LINE". PARSELINE
;;;RETURNS THE EQUIVALENT LIST OF LISP S-EXPRESSIONS WHICH CAN THEN
;;;BE RUN BY "EVALS..
;;;
;;;THE GENERAL ATTACK IS FOR THE SPECIALISTS OF PARSE TO EXAMINE
;;;TOPARSE FOR THEIR SPECIALTY. IF FOUND, THEY GENERATE AN
;;;S-EXPRESSION WHICH IS PUSHED ONTO "PARSED" AND "TOPARSE" IS
;;;APPROPRIATELY PRUNED. AN EXCEPTION TO THIS IS THAT PARSE-LOGOFN
;;;REPLACES THE PARSED EXPRESSION ONTO FIRST AND THEN TRIES
;;;PARSE-INFIX. THIS ALLOWS INFIX TO HAVE PRECEDENCE IN SITUATIONS
;;;OF THE FORM: "A"=B AND HEADING=360.
;;;
;;;
;;;F = COLLECT INPUTS TO END OF LINE WITHOUT PARSING
;;;L = COLLECT INPUTS TO END OF LINE PARSING
;;;NO. = FIXED NUMBER OF INPUTS
;;;(FNCALL) = SPECIAL PARSING FN TO BE EXECUTED.
;;;
;;;
;;FOR PROCEDURAL PARSING PROPERTIES, (GET ATOM 'PARSE) = ((PARSE-FN)), THE ENTRY
;;STATE IS THAT FIRST = FN, TOPARSE = REMAINDER OF LINE. THE OUTPUT OF THE PARSE-FN
;;IS TO BE THE PARSED EXPR. TOPARSE SHOULD BE POPPED IN THE PROCESS.
(DECLARE (OR (STATUS FEATURE DEFINE)
(COND ((STATUS FEATURE ITS)
;;MULTICS?
(FASLOAD DEFINE FASL AI LLOGO)))))
(SAVE-VERSION-NUMBER PARSER)
(DECLARE (SETQ MACROS T) (GENPREFIX PARSER))
;;THE CATCH WILL TRAP THE RESULT OF A PARSING ERROR. THE FUNCTION REREAD-ERROR WILL
;;TRY TO GET USER TO CORRECT THE LINE, AND WILL THROW BACK A CORRECTLY PARSED LINE.
;;IF PARSELINE IS GIVEN A NON-NIL SECOND ARGUMENT, THEN A PARSING ERROR WILL SIMPLY
;;(ERR 'REREAD) OUT OF PARSELINE, INSTEAD OF ATTEMPTING TO RECOVER.
(DEFUN PARSELINE ARGS
(COND ((EQ (ARG 1.) EOF) EOF)
((CATCH (DO ((PARSED NIL (CONS (PARSE NIL) PARSED))
(REREAD-ERROR? (AND (> ARGS 1.) (ARG 2.)))
(TOPARSE (APPEND (AND (NUMBERP (CAR (ARG 1.)))
(OR (NOT :EDITMODE)
(EQ PROMPTER '>))
'(INSERT-LINE))
(ARG 1.))))
((NULL TOPARSE)
(COND (PARSED (NREVERSE PARSED)) (NULL-LINE))))
PARSELINE))))
[(OR ITS DEC10) (ARGS 'PARSELINE '(1. . 2.))]
(SETQ FLAG NIL :EDITMODE T)
[CLOGO (DEFINE PARSE-CLOGO-HOMONYM FEXPR (X)
(COND (:CAREFUL (AND (CDDR X)
(IOG NIL
(TYPE '"HOMONYM: REPLACING "
FIRST
'" BY "
(CAR X))))
(SETQ TOPARSE (CONS (CAR X) TOPARSE))
(PARSE FLAG))
((PARSE1 (CADR X)))))]
;;THE PARSE FUNCTION IS SUB-STRUCTURED. PARSE1 PARSES WITH A GIVEN PARSE PROPERTY.
;;PROP SHOULD BE LAMBDA VARIABLE AS IT IS MODIFIED BY PARSE-PROP.
(DEFUN PARSE (FLAG)
(COND ((ATOM TOPARSE) (SETQ TOPARSE NIL))
((LET ((FIRST (CAR TOPARSE)) (PROP))
(POP TOPARSE)
(PARSE1 (PARSE-PROP FIRST))))))
;;FIRST IS THE THING CURRENTLY BEING WORKED ON [I.E. FUNCTION NAME] , TOPARSE IS
;;NOW THE REST OF THE LINE.
(DEFUN PARSE1 (PROP)
(SETQ FIRST (COND ((NULL PROP) (PARSE-?))
((ATOM PROP) (PARSE-LOGOFN PROP))
((AND (CDR PROP) (ATOM (CDR PROP)))
(CONS FIRST (PARSE-LEXPR-ARGS (CAR PROP) (CDR PROP))))
((EVAL PROP))))
(PARSE-INFIX))
;; TO ELIMINATE HOMONYMS [WORDS THAT MEAN ONE THING IN LISP, ANOTHER IN LOGO], THE
;;PARSER WILL TRANSFORM THEM INTO ALTERNATE WORDS, UNPARSER, PRINTER WILL CHANGE
;;THEM BACK. PITFALL IN CURRENT METHOD OF HANDLING HOMONYMS: WHEN PASSING
;;FUNCTIONAL ARUGUMENTS IN CERTAIN CASES, THE PARSER DOES NOT GET A CHANCE TO DO ITS
;;THING, SO USER MAY FIND UNEXPECTED FUNCTION CALLED. EXAMPLE: APPLY 'PRINT .....
;;CALLS LISP'S PRINT FN, NOT LOGO'S.
(DEFUN PARSE-SUBSTITUTE (REAL) (PARSE1 (PARSE-PROP (SETQ FIRST REAL))))
;;FINDS PARSE PROPERTY FOR X. X MUST BE A PNAME TYPE ATOM. IF PARSE-PROP GETS A
;;LIST, RETURNS NIL. EXPLICIT PARSE PROPERTY IF INSIDE USER-PARENS USE SECOND
;;ELEMENT OF PARSE PROPERTY, IF THERE IS ONE. ARRAY IS HANDLED AS AN EXPR OF NUMBER
;;OF DIMENSIONS ARGS. TREAT X AS A VARIABLE IF IT'S BOUND OR FIRST LETTER IS COLON.
(DEFUN PARSE-PROP (X)
(COND
((NOT (SYMBOLP X)) NIL)
((SETQ PROP (ABBREVIATIONP X)) (PARSE-PROP (SETQ FIRST PROP)))
((SETQ PROP (GET X 'PARSE))
(COND ((AND (EQ FLAG 'USER-PAREN) (CDR PROP)) (CADR PROP))
((CAR PROP))))
((HOW-TO-PARSE-INPUTS X))
((BOUNDP X) NIL)
((EQ (GETCHAR X 1.) ':) NIL)
(INSERTLINE-NUMBER (THROW (NCONS (LIST 'INSERT-LINE
INSERTLINE-NUMBER
(CCONS 'PARSEMACRO
FIRST
(LIST FN INSERTLINE-NUMBER)
OLD-LINE)))
PARSELINE))
;;X IS AN UNKNOWN FUNCTION. IF EDITING, THROW.
((REREAD-ERROR
(LIST FIRST
'" IS AN UNDEFINED FUNCTION ")))))
(DEFUN HOW-TO-PARSE-INPUTS (FUNCTION)
;;FIND FIRST FUNCTION PROPERTY ON PLIST OF X.
(LET ((GETL (FUNCTION-PROP FUNCTION)))
(COND ((MEMQ (CAR GETL) '(FEXPR FSUBR MACRO)) 'F)
((EQ (CAR GETL) 'EXPR)
;;PARSE PROPERTY OF AN EXPR IS THE NUMBER OF INPUTS.
(LET ((ARGLIST (CADADR GETL)))
(COND ((AND ARGLIST (ATOM ARGLIST))
(PARSE-ARGS-PROP FUNCTION))
((LENGTH ARGLIST)))))
((MEMQ (CAR GETL) '(LSUBR SUBR)) (PARSE-ARGS-PROP FUNCTION))
((EQ (CAR GETL) 'ARRAY)
(1- (LENGTH (ARRAYDIMS FUNCTION)))))))
(DEFUN PARSE-ARGS-PROP (FUNCTION)
(LET ((ARGS-PROP (ARGS FUNCTION)))
(COND ((NULL ARGS-PROP) 'L)
((NULL (CAR ARGS-PROP)) (CDR ARGS-PROP))
(ARGS-PROP))))
(DEFUN EOP NIL
(OR (NULL TOPARSE)
(AND (EQ (TYPEP (CAR TOPARSE)) 'LIST)
(EQ (CAAR TOPARSE) 'LOGO-COMMENT))))
;;FIRST IS SET TO PARSED FN AND TOPARSE IS APPROPRIATELY POPPED. PROP IS THE NUMBER
;;OF INPUTS.
(DEFUN PARSE-LOGOFN (PROP)
(CONS
FIRST
(COND ((EQ PROP 'F) (PARSE-FEXPR-ARGS))
((EQ PROP 'L) (PARSE-LEXPR-ARGS 0. 999.))
((NUMBERP PROP) (PARSE-EXPR-ARGS PROP))
((REREAD-ERROR '"SYSTEM BUG - PARSE-LOGOFN")))))
(DEFUN PARSE-FEXPR-ARGS NIL
(COND ((EOP) NIL)
((CONS (CAR TOPARSE) (PROG2 (POP TOPARSE) (PARSE-FEXPR-ARGS))))))
;;PICK UP INPUTS TO FUNCTIONS EXPECTING AN INDEFINITE NUMBER OF EVALUATED ARGUMENTS.
;;PARSING OF ARGUMENTS MUST HALT AT INFIX OPERATOR, BECAUSE FIRST OPERAND IS MEANT
;;TO BE THE WHOLE FORM, AND INFIX OPERATOR DOES NOT BEGIN ANOTHER ARGUMENT TO THE
;;LEXPR. EXAMPLE:
;;; 10 TEST YOUR.FAVORITE.LEXPR :ARG1 ... :ARGN = :RANDOM
(DEFUN PARSE-LEXPR-ARGS (AT-LEAST AT-MOST)
(COND ((OR (EOP) (GET (CAR TOPARSE) 'PARSE-INFIX))
(AND (PLUSP AT-LEAST)
(REREAD-ERROR (LIST '"TO FEW INPUTS TO "
(UNPARSE-FUNCTION-NAME FIRST)))))
((ZEROP AT-MOST) NIL)
((CONS (PARSE FIRST) (PARSE-LEXPR-ARGS (1- AT-LEAST) (1- AT-MOST))))))
(DEFUN PARSE-EXPR-ARGS (HOWMANY)
(COND ((= HOWMANY 0.) NIL)
((EOP)
(REREAD-ERROR (LIST '"TOO FEW INPUTS TO "
(UNPARSE-FUNCTION-NAME FIRST))))
((CONS (PARSE FIRST) (PARSE-EXPR-ARGS (1- HOWMANY))))))
(DEFUN PARSE-FORM-LIST NIL
(COND ((EOP) NIL) ((CONS (PARSE FIRST) (PARSE-FORM-LIST)))))
;;*PAGE
;;PRECEDENCE FUNCTION ALLOWS USER TO CHANGE PRECEDENCE AS HE WISHES. (PRECEDENCE
;;<OP>) RETURNS PRECEDENCE NUMBER OF <OP>. (PRECEDENCE <OP> <LEVEL>) SETS
;;PRECEDENCE OF <OP> TO <LEVEL>, EITHER A NUMBER OR OPERATOR, WHICH MAKES IT SAME
;;PRECEDENCE AS THAT OPERATOR. <LEVEL>= NIL MEANS LOWEST PRECEDENCE.
;;(PRECEDENCE NIL <NUMBER>) SETS THE DEFAULT PRECEDENCE FOR IDENTIFIERS TO <NUMBER>.
(DEFINE PRECEDENCE ARGS
(COND ((= ARGS 1.)
(COND ((NULL (ARG 1.)) 0.)
((GET (ARG 1.) 'INFIX-PRECEDENCE))
(DEFAULT-PRECEDENCE)))
((ARG 1.)
(PUTPROP (ARG 1.)
(COND ((NUMBERP (ARG 2.)) (ARG 2.)) ((PRECEDENCE (ARG 2.))))
'INFIX-PRECEDENCE))
((SETQ DEFAULT-PRECEDENCE (NUMBER? 'PRECEDENCE (ARG 2.))))))
[(OR ITS DEC10) (ARGS 'PRECEDENCE '(1. . 2.))]
;; (ASSOCIATE <LEVEL> <WHICH-WAY>) CAUSES ALL OPERATORS OF PRECEDENCE <LEVEL> TO
;;ASSOCIATE TO RIGHT, OR LEFT, AS SPECIFIED. DEFAULT IS LEFT ASSOCIATIVE.
;;RIGHT-ASSOCIATIVE IS LIST OF LEVELS WHICH ARE NOT.
(DEFINE ASSOCIATE (LEVEL WHICH-WAY)
(SETQ LEVEL (NUMBER? 'ASSOCIATE LEVEL))
(COND ((EQ WHICH-WAY 'RIGHT) (PUSH LEVEL RIGHT-ASSOCIATIVE))
((EQ WHICH-WAY 'LEFT)
(SETQ RIGHT-ASSOCIATIVE (DELETE LEVEL RIGHT-ASSOCIATIVE)))
((ERRBREAK 'ASSOCIATE
'"INPUT MUST BE RIGHT OR LEFT")))
WHICH-WAY)
;; (INFIX <OP> <PRECEDENCE> ) CREATES <OP> TO BE A NEW INFIX OPERATOR, OPTIONALLY
;;SPECIFYING A PRECEDENCE LEVEL.
(DEFINE INFIX ARGS
(PUTPROP (ARG 1.) (ARG 1.) 'PARSE-INFIX)
(PUTPROP (ARG 1.) (ARG 1.) 'UNPARSE-INFIX)
(PUSH (ARG 1.) :INFIX)
(AND (= ARGS 2.)
(PUTPROP (ARG 1.)
(COND ((NUMBERP (ARG 2.)) (ARG 2.)) ((PRECEDENCE (ARG 2.))))
'INFIX-PRECEDENCE))
(ARG 1.))
[(OR ITS DEC10) (ARGS 'INFIX '(1. . 2.))]
;;NOPRECEDENCE MAKES EVERY INFIX OPERATOR HAVE THE SAME PRECEDENCE, AS CLOGO DOES.
;;LOGICAL FUNCTIONS HAVE PRECEDENCE LOWER THAN DEFAULT FUNCTIONS, INFIX HIGHER.
(DEFINE NOPRECEDENCE NIL
(SETQ DEFAULT-PRECEDENCE 300.)
(MAPC
'(LAMBDA (OP) (PUTPROP OP (1+ DEFAULT-PRECEDENCE) 'INFIX-PRECEDENCE))
:INFIX)
(MAPC '(LAMBDA (OP) (REMPROP OP 'INFIX-PRECEDENCE))
'(IF NOT BOTH EITHER TEST AND OR))
NO-VALUE)
;;THIS FUNCTION PARSES INFIX EXPRESSIONS. ON ENTRY, FIRST IS THE FORM THAT WAS JUST
;;PARSED, TOPARSE REMAINDER OF LINE. IF THE EXPRESSION IS INFIX, NEXT WILL BE AN
;;INFIX OPERATOR. FLAG, THE INPUT TO PARSE, MAY BE NIL, USER-PAREN, OR A FUNCTION
;;NAME. IF PRECEDENCE OF FLAG, IS GREATER THAN PRECEDENCE OF NEXT, INFIX EXPRESSION
;;IS OVER, RETURN FIRST. ELSE CONTINUE PARSING SECOND INPUT TO INFIX OPERATOR.
;;ASSOCIATIVITY IS DECIDED BY PARSING DECISION MADE WHEN PRECEDENCES ARE EQUAL. A
;;SPECIAL KLUDGE IS NECESSARY FOR HANDLING MINUS SIGN- PASS2 CONVERTS ALL MINUS
;;SIGNS FOLLOWED BY NUMBERS TO NEGATIVE NUMBERS; RECONVERSION MAY BE NECESSARY.
(DEFUN PARSE-INFIX NIL
(DO ((NEXT (CAR TOPARSE) (CAR TOPARSE))
(INFIX-OP (GET (CAR TOPARSE) 'PARSE-INFIX)
(GET (CAR TOPARSE) 'PARSE-INFIX))
(NEXT-LEVEL (PRECEDENCE (CAR TOPARSE)) (PRECEDENCE (CAR TOPARSE)))
(FLAG-LEVEL (PRECEDENCE FLAG))
(DASH))
(NIL)
(COND (INFIX-OP)
((AND (NUMBERP NEXT)
(MINUSP NEXT)
(SETQ DASH (GET '- 'PARSE-INFIX)))
(SETQ INFIX-OP DASH
NEXT-LEVEL (PRECEDENCE '-)
NEXT '-)
(RPLACA TOPARSE (MINUS (CAR TOPARSE)))
(PUSH '- TOPARSE))
((RETURN FIRST)))
(COND ((AND (NUMBERP FIRST)
(MINUSP FIRST)
(GREATERP NEXT-LEVEL (PRECEDENCE 'PREFIX-MINUS)))
(PUSH (MINUS FIRST) TOPARSE)
(SETQ FIRST (LIST 'PREFIX-MINUS
(PARSE 'PREFIX-MINUS))))
((GREATERP NEXT-LEVEL FLAG-LEVEL) (PARSE-INFIX-LEVEL NEXT INFIX-OP))
((EQUAL NEXT-LEVEL FLAG-LEVEL)
(COND ((MEMBER NEXT-LEVEL RIGHT-ASSOCIATIVE)
(PARSE-INFIX-LEVEL NEXT INFIX-OP))
((RETURN FIRST))))
((RETURN FIRST)))))
(DEFUN PARSE-INFIX-LEVEL (NEXT INFIX-OP)
(POP TOPARSE)
(AND (EOP)
(REREAD-ERROR (LIST '"TOO FEW INPUTS TO"
(UNPARSE-FUNCTION-NAME NEXT))))
(SETQ FIRST (LIST INFIX-OP FIRST (PARSE NEXT))))
;;INITIAL DEFAULT PRECEDENCES. NIL & USER-PAREN HAVE PRECEDENCE 0, (PARSE NIL)
;;,(PARSE 'USER-PAREN) PICKS UP A FORM- MAXIMAL INFIX EXPRESSION. BOOLEAN FUNCTIONS
;;ARE GIVEN LOWER PRECEDENCE THAN COMPARISON OPERATORS. DEFAULT PRECEDENCE IS 300.
;;INITIALLY, ONLY EXPONENTIATION AND ASSIGNMENT ARE RIGHT ASSOCIATIVE. THESE ARE
;;THE PRECEDENCE LEVELS USED BY 11LOGO.
(MAPC '(LAMBDA (INFIX PREFIX) (PUTPROP INFIX PREFIX 'PARSE-INFIX)
(PUTPROP PREFIX INFIX 'UNPARSE-INFIX))
'(+ - * // \ < > = ^ _)
'(INFIX-PLUS INFIX-DIFFERENCE INFIX-TIMES INFIX-QUOTIENT INFIX-REMAINDER
INFIX-LESSP INFIX-GREATERP INFIX-EQUAL INFIX-EXPT INFIX-MAKE))
;;THEN AND ELSE ARE CONSIDERED AS "INFIX" SO THAT THEY WILL TERMINATE PARSING OF
;;INPUTS TO LEXPR-TYPE FUNCTIONS, WHERE THE EXTENT OF A FORM ISN'T REALLY CLEARLY
;;DELINEATED. SINCE THEY HAVE LOWER PRECEDENCE THAN ANYTHING ELSE, THEY WILL NEVER
;;REALLY BE PARSED AS INFIX.
(DEFPROP THEN THEN PARSE-INFIX)
(DEFPROP ELSE ELSE PARSE-INFIX)
(DEFPROP THEN 0. INFIX-PRECEDENCE)
(DEFPROP ELSE 0. INFIX-PRECEDENCE)
(SETQ :INFIX '(_ < > = + - * // \ PREFIX-MINUS PREFIX-PLUS ^))
(MAPC '(LAMBDA (OP LEVEL) (PUTPROP OP LEVEL 'INFIX-PRECEDENCE))
:INFIX
'(50. 200. 200. 200. 400. 400. 500. 500. 500. 600. 600. 700.))
(MAPC '(LAMBDA (OP LEVEL) (PUTPROP OP LEVEL 'INFIX-PRECEDENCE))
'(NIL USER-PAREN IF BOTH NOT EITHER TEST AND OR)
'(0. 0. 100. 100. 100. 100. 100. 100. 100.))
(SETQ DEFAULT-PRECEDENCE 300.)
(SETQ RIGHT-ASSOCIATIVE '(50. 700.))
;;INFIX-MAKE SHOULD PROBABLY HAVE DIFFERENT PRECEDENCES FROM RIGHT AND LEFT SIDES:
;;; :A + :B _ 17 ==> (PLUS :A (MAKE :B 17))
;;; :A _ :B + 17 ==> (MAKE :A (PLUS :B 17))
;;;
;;USER PARENTHESIS MARKER.
(DEFINE USER-PAREN (X) X)
(DEFUN PARSE-? NIL
(COND
((AND (EQ (TYPEP FIRST) 'LIST)
(NOT (MEMQ (CAR FIRST)
'(LOGO-COMMENT QUOTE DOUBLE-QUOTE SQUARE-BRACKETS))))
(LIST
'USER-PAREN
(LET
((TOPARSE FIRST))
(PROG2
NIL
(PARSE 'USER-PAREN)
;;MORE THAN ONE FORM INSIDE PARENTHESES.
(AND
TOPARSE
(REREAD-ERROR
(LIST '"TOO MUCH INSIDE PARENTHESES."
TOPARSE
'"IS EXTRA")))))))
((AND (NUMBERP FIRST) (NULL FLAG))
(REREAD-ERROR (LIST '"A NUMBER ISN'T A FUNCTION"
FIRST)))
(FIRST)))
;;CONVERTS IF TO LISP "COND"
(DEFUN PARSEIF NIL
(PROG (TRUES FALSES)
(COND ((EQ (CAR TOPARSE) 'TRUE)
(SETQ TOPARSE (CONS 'IFTRUE (CDR TOPARSE)))
(RETURN (PARSE NIL)))
((EQ (CAR TOPARSE) 'FALSE)
(SETQ TOPARSE (CONS 'IFFALSE (CDR TOPARSE)))
(RETURN (PARSE NIL))))
(SETQ TRUES (LIST (PARSE 'IF)))
(AND (EQ (CAR TOPARSE) 'THEN) (POP TOPARSE))
LOOP1(COND ((EOP) (GO DONE))
((EQ (CAR TOPARSE) 'ELSE) (POP TOPARSE) (GO LOOP2)))
(PUSH (PARSE NIL) TRUES)
(GO LOOP1)
LOOP2(COND ((EOP) (GO DONE))
;;ANOTHER ELSE WILL TERMINATE PARSING OF ELSE CLAUSES.
((EQ (CAR TOPARSE) 'ELSE) (GO DONE)))
(PUSH (PARSE NIL) FALSES)
(GO LOOP2)
DONE (SETQ TRUES (NREVERSE TRUES))
(SETQ FALSES (NREVERSE FALSES))
(RETURN (COND (FALSES (LIST 'COND TRUES (CONS T FALSES)))
((LIST 'COND TRUES))))))
(DEFUN PARSE-SETQ NIL
(PROG (PARSED)
(AND (EOP)
(REREAD-ERROR '" - NO INPUTS TO SETQ"))
(SETQ PARSED (LIST FIRST))
A (AND (EOP) (RETURN (NREVERSE PARSED)))
(OR
(SYMBOLP (CAR TOPARSE))
(REREAD-ERROR
(LIST '"THE INPUT "
(CAR TOPARSE)
'" TO "
FIRST
'" WAS NOT A VALID VARIABLE NAME")))
(PUSH (CAR TOPARSE) PARSED)
;;VARIABLE NAME
(POP TOPARSE)
(AND
(EOP)
(REREAD-ERROR
(LIST '" - WRONG NUMBER INPUTS TO"
FIRST)))
;;VALUE
(PUSH (PARSE FIRST) PARSED)
(GO A)))
(DEFUN PARSE-STORE NIL
;;SPECIAL PARSING FUNCTION FOR STORE. LISP STORE MANAGES TO GET CONFUSED BY
;;USER-PAREN FUNCTION TACKED ONTO ARRAY CALL ARGUMENT, EVEN THO USER-PAREN
;;DOES NOTHING [DON'T ASK ME WHY]. ALSO, MAKE A HALF-HEARTED ATTEMPT AT
;;MAKING 11LOGO-STYLE STORE WORK.
(CONS FIRST
(LET ((ARRAY-CALL (PARSE 'STORE)))
(COND ((OR (ATOM ARRAY-CALL) (EQ (CAR ARRAY-CALL) 'QUOTE))
;;11LOGO STYLE STORE. STORE <ARRAY> <DIM1>..<DIM N>
;;<VALUE>.
(LIST (COND ((EQ FLAG 'USER-PAREN)
;;IF PARENTHESIZED, ALL BUT LAST ARGS ARE
;;DIMS.
(DO ((DIMENSIONS NIL
(CONS (PARSE 'STORE)
DIMENSIONS)))
((NULL (CDR TOPARSE))
(CONS ARRAY-CALL (NREVERSE DIMENSIONS)))))
;;DEFAULT UNPARENTHESIZED PARSING IS 1 DIM.
;;ARRAY
((LIST ARRAY-CALL (PARSE 'STORE))))
(PARSE 'STORE)))
((EQ (CAR ARRAY-CALL) 'USER-PAREN)
;;UNFORTUNATELY LOSES PAREN INFO HERE. PERHAPS HAVE
;;ADDITIONAL FUNCTION STORE-PAREN WHICH UNPARSES WITH
;;PARENS?
(LIST (CADR ARRAY-CALL) (PARSE 'STORE)))
((LIST ARRAY-CALL (PARSE 'STORE)))))))
(DEFUN PARSE-BREAK NIL
(CONS FIRST
(AND TOPARSE
(CONS (CAR TOPARSE)
(AND (POP TOPARSE)
(CONS (PARSE NIL) (AND TOPARSE (LIST (PARSE NIL)))))))))
(DEFUN PARSE-DO NIL
(CONS FIRST
(LET ((VAR-SPECS (CAR TOPARSE)) (STOP-RULE (CADR TOPARSE)))
(COND ((AND VAR-SPECS (ATOM VAR-SPECS))
(PARSE-LEXPR-ARGS 4. 99999.))
;;Old or new style DO?
((CCONS (PARSE-VARIABLE-SPEC VAR-SPECS)
;;Variable specs, stop rule...
(LET ((TOPARSE STOP-RULE))
(PARSE-LEXPR-ARGS 0. 99999.))
;;..and the body.
(AND (SETQ TOPARSE (CDDR TOPARSE))
(PARSE-LEXPR-ARGS 0. 99999.))))))))
(DEFUN PARSE-VARIABLE-SPEC (VAR-SPECS)
(MAPCAR
'(LAMBDA (TOPARSE)
(PROG1
(PARSE-LEXPR-ARGS 1. 3.)
(AND
TOPARSE
(REREAD-ERROR '"TOO MUCH IN DO VARIABLE LIST"))))
VAR-SPECS))
;;IGNORE CARRIAGE RETURN WHICH MIGHT FIND ITS WAY INTO A FORM DUE TO MULTI-LINE
;;PARENTHESIZED FORM FEATURE.
(PUTPROP EOL '((PARSE NIL)) 'PARSE)
(DEFUN PARSE-GO NIL
(AND (EQ (CAR TOPARSE) 'TO) (POP TOPARSE))
(AND (EQ (CAR TOPARSE) 'LINE) (POP TOPARSE))
(AND (EOP)
(REREAD-ERROR (LIST '"TOO FEW INPUTS TO GO")))
(LIST FIRST (PARSE 'GO)))
;; INSERTLINE-NUMBER IS A GLOBAL VARIABLE CHECKED BY PARSE-PROP. IT IS SET TO LINE
;;NUMBER TO BE INSERTED. IF AN UNDEFINED FUNCTION IS ENCOUNTERED, THROW A
;;PARSEMACRO BACK TO PARSELINE.
(SETQ INSERTLINE-NUMBER NIL)
;;FOR LINES INSERTED BY USER CALLS TO INSERTLINE, THE FIRST THING IN THE LINE MUST
;;BE A NUMBER. COMMENTS NOT INCLUDED BY INSERTLINE.
(DEFUN PARSE-INSERTLINE NIL
(LET
((LINE-NUMBER (CAR TOPARSE)))
(SETQ TOPARSE (CDR TOPARSE) FIRST NIL)
(OR
(NUMBERP LINE-NUMBER)
(REREAD-ERROR
'"INSERTED LINE MUST BEGIN WITH NUMBER"))
(AND
(BIGP LINE-NUMBER)
(REREAD-ERROR
(LIST LINE-NUMBER
'"IS TOO BIG TO BE A LINE NUMBER")))
(AND (EOP)
(REREAD-ERROR '"INSERTING EMPTY LINE? "))
(CCONS 'INSERTLINE LINE-NUMBER (PARSE-FORM-LIST))))
(DEFUN PARSE-INSERT-LINE NIL
(LET
((INSERTLINE-NUMBER (CAR TOPARSE)))
(SETQ TOPARSE (CDR TOPARSE) FIRST NIL)
(OR TOPARSE
(REREAD-ERROR '"NO CODE FOLLOWING LINE NUMBER?"))
(AND
(BIGP INSERTLINE-NUMBER)
(REREAD-ERROR
(LIST INSERTLINE-NUMBER
'"IS TO BIG TO BE A LINE NUMBER")))
(NCONC (CCONS 'INSERT-LINE INSERTLINE-NUMBER (PARSE-FORM-LIST))
(AND TOPARSE
;;(CAAR NIL) IS A NO-NO.
(EQ (CAAR TOPARSE) 'LOGO-COMMENT)
TOPARSE))))
;;;LINE CONTAINED A FUNCTION NAME WHICH DID NOT HAVE A DEFINITION AT COMPILE TIME.
(DEFINE PARSEMACRO MACRO (X)
(LET
((OLD-LINE (CDDDR X))
(PARSEMACRO-FN (CAR (CADDR X)))
(NUMBER (CADR (CADDR X)))
(OLD-FN FN)
(PROMPTER '>))
(DEFAULT-FUNCTION 'PARSEMACRO PARSEMACRO-FN)
(LIST
'PARSEMACRO-EVAL
(LIST 'QUOTE
(COND
;;DOES FUNCTION HAVE A DEFINITION AT EXECUTION TIME? YES, REPARSE IT.
((FUNCTION-PROP (CADR X))
(EVALS (PARSELINE (PASS2 OLD-LINE)))
((LAMBDA (THIS-LINE NEXT-TAG LAST-LINE)
(GETLINE PROG NUMBER)
(DEFAULT-FUNCTION 'PARSEMACRO OLD-FN)
THIS-LINE)
NIL
NIL
NIL))
;;NO, CAUSE ERROR.
((IOG NIL
(TYPE '";ERROR IN LINE "
NUMBER
'" OF "
PARSEMACRO-FN
'" - "
(CADR X)
'" IS AN UNDEFINED FUNCTION"
EOL)
((LAMBDA (NEW-LINE)
(DEFAULT-FUNCTION 'PARSEMACRO OLD-FN)
(TYPE '";CONTINUING EVALUATION"
EOL)
NEW-LINE)
(EDIT-LINE NUMBER)))))))))


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

File diff suppressed because it is too large Load Diff

332
src/llogo/print.1 Normal file
View File

@@ -0,0 +1,332 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; LLOGO PRINTING FUNCTIONS. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(DECLARE (OR (STATUS FEATURE DEFINE)
(COND ((STATUS FEATURE ITS)
;;MULTICS?
(FASLOAD DEFINE FASL AI LLOGO)))))
(SAVE-VERSION-NUMBER PRINT)
(DECLARE (GENPREFIX PRINT))
[(OR MULTICS DEC10) (DEFINE DPRINC (SYN PRINC))
(DEFINE DTERPRI (SYN TERPRI))]
[ITS (DEFUN DPRINC (X) (SUBRCALL NIL DPRINC X))
(DEFUN DTERPRI NIL (SUBRCALL NIL DTERPRI))
;;WATCH IT, THESE ARE LSUBRS IN NEWIO!
(SETQ DPRINC (GET 'PRINC 'SUBR) DTERPRI (GET 'TERPRI 'SUBR))]
(DEFUN DPRINT (X) (DTERPRI) (DPRIN1 X) (DPRINC '/ ))
(DEFUN DPRIN1 (X)
(COND ((NUMBERP X) (DPRINC X))
((ATOM X)
(COND ((= (FLATC X) (FLATSIZE X)) (DPRINC X))
((MAPC 'DPRINC (LIST '$ X '$)))))
((DPRINC '/()
(DO ((REST-LIST X (CDR REST-LIST)))
((COND ((NULL REST-LIST) (DPRINC '/)))
((ATOM REST-LIST)
(DPRINC '" . ") (DPRIN1 REST-LIST) (DPRINC '/)))))
(DPRIN1 (CAR REST-LIST))
(AND (CDR REST-LIST) (DPRINC '/ ))))))
(DEFUN DPRINTL ARGS
(DO ARG-INDEX 1. (1+ ARG-INDEX) (> ARG-INDEX ARGS)
(DPRINC (ARG ARG-INDEX)) (DPRINC '/ ))
(DTERPRI))
(DEFUN DPRINCSP (X) (DPRINC X) (DPRINC '/ ))
(DEFINE PRINT (PARSE (PARSE-SUBSTITUTE 'LOGO-PRINT)))
(DEFINE LOGO-PRINT (UNPARSE (UNPARSE-SUBSTITUTE 'PRINT)) (ABB P PR) (PARSE 1. L) ARGS
(DO I 1. (1+ I) (> I ARGS) (TYPE (ARG I)) (DTERPRI))
NO-VALUE)
(DEFINE FPRINT (ABB FP) (PARSE 1. L) ARGS
(DO I 1. (1+ I) (> I ARGS) (DPRIN1 (ARG I)))
?)
(DEFINE TYPE (PARSE 1. L) ARGS (DO ((I 1. (1+ I)))
((> I ARGS) NO-VALUE)
(COND ((ATOM (ARG I)) (DPRINC (ARG I)))
((DO ((TYPE-ARG (ARG I) (CDR TYPE-ARG)))
((ATOM (CDR TYPE-ARG))
(DPRINC (CAR TYPE-ARG))
(AND (CDR TYPE-ARG)
(DPRINC '/ /./ )
(DPRINC (CDR TYPE-ARG))))
(DPRINCSP (CAR TYPE-ARG)))))))
(DEFINE BLANK NIL (DPRINC '/ ) NO-VALUE)
(DEFINE CARRIAGERETURN (ABB CR) NIL (DPRINC EOL) NO-VALUE)
(DEFINE LINEFEED NIL NIL (DPRINC (ASCII 10.)) NO-VALUE)
[MULTICS (DEFINE PRETTY (NEWLINEL)
;;UPDATES CHRCT AND LINEL. IDENTICAL TO "NEWLINEL" IN GRIND.
(CHRCT NIL (+ (CHRCT NIL) (- NEWLINEL (LINEL NIL))))
(LINEL NIL NEWLINEL))]
[(OR ITS DEC10) (DEFINE PRETTY (NEWLINEL) (SETQ CHRCT (+ CHRCT (- NEWLINEL LINEL)))
(SETQ LINEL NEWLINEL))]
;;THE DPRIN FNS PRINT ON DISPLAY AS WELL AS AT TTY IF :SHOW = T. IF TRUE, THE
;;DPRINT FNS OUTPUT TO 6.
(SETQ :SHOW NIL)
;;LISTING
(DEFINE PRINTOUT (ABB PO) FEXPR (X)
(COND ((NULL X) (LIST-PROCEDURE FN))
((MEMQ (CAR X) '(ABBREVIATIONS ABBS)) (PRINTOUTABBREVIATIONS))
((MEMQ (CAR X) '(NAMES :NAMES)) (PRINTOUTNAMES))
((EQ (CAR X) 'PROCEDURES) (PRINTOUTPROCEDURES))
((EQ (CAR X) 'ALL)
(PRINTOUTPROCEDURES)
(DTERPRI)
(PRINTOUTNAMES))
((MEMQ (CAR X) '(CONTENTS :CONTENTS TITLES)) (PRINTOUTCONTENTS))
((EQ (CAR X) 'TITLE) (APPLY 'PRINTOUTTITLE (CDR X)))
((EQ (CAR X) 'LINE) (PRINTOUTLINE (CADR X)))
((MEMQ (CAR X) '(PRIMITIVES :PRIMITIVES)) (PRINTOUTPRIMITIVES))
((EQ (CAR X) 'FILE) (APPLY 'PRINTOUTFILES (CDR X)))
[(OR ITS MULTICS) ((MEMQ (CAR X) '(INDEX FILES))
(APPLY 'PRINTOUTINDEX (CDR X)))]
[ITS ((MEMQ (CAR X) '(SNAPS :SNAPS)) (PRINTOUTSNAPS))]
((MAPC 'LIST-PROCEDURE X)))
?)
(DEFINE CONTENTS NIL (DELEET :CONTENTS :BURIED))
[CLOGO (DEFINE LIST (PARSE (PARSE-CLOGO-HOMONYM PRINTOUT L)))]
(DEFINE PRINTOUTCONTENTS (ABB LC LISTCONTENTS POC POTS) NIL
(MAPC '(LAMBDA (USER-PROCEDURE)
(OR (MEMQ USER-PROCEDURE :BURIED)
(LOGOPRINT (CAR (EDITINIT1 USER-PROCEDURE)))))
:CONTENTS)
NO-VALUE)
(DEFINE PRINTOUTSNAPS (ABB LISTSNAPS) NIL (AND :SNAPS (TYPE :SNAPS EOL)) NO-VALUE)
(DEFINE PRINTOUTPROCEDURES (ABB LISTPROCEDURES LPR POPR) NIL
(MAPC '(LAMBDA (USER-PROCEDURE) (OR (MEMQ USER-PROCEDURE :BURIED)
(LIST-PROCEDURE USER-PROCEDURE)
(DTERPRI)))
:CONTENTS)
?)
(DEFINE PRINTOUTTITLE (ABB LISTTITLE POT) FEXPR (OPTFUNCTION)
(DEFAULT-FUNCTION 'PRINTOUTTITLE (AND OPTFUNCTION (CAR OPTFUNCTION)))
(LOGOPRINT TITLE)
NO-VALUE)
(DEFINE PRINTOUTALL (ABB POA LISTALL) NIL (PRINTOUTPROCEDURES) (PRINTOUTNAMES) ?)
(DEFINE PRINTOUTFILE (ABB POF LISTFILE) FEXPR (FILENAME)
;;TAKES A FILE NAME AS INPUT AND PRINTS THE FILE.
(APPLY 'UREAD (FILESPEC FILENAME))
(SETQ ^Q T)
(DO ((CHARNUM (TYI -1.) (TYI -1.)))
((OR (NULL ^Q) (MINUSP CHARNUM)) (SETQ ^Q NIL) (TERPRI))
(OR (= CHARNUM 12.) (= CHARNUM 10.) (TYO CHARNUM)))
NO-VALUE)
[(OR ITS MULTICS) (DEFINE PRINTOUTINDEX (ABB POI LISTINDEX LISTFILES) FEXPR (WHOSE)
;;PRINTS OUT LISTING OF FILES.
[ITS (APPLY 'PRINTOUTFILE
(APPEND '(".FILE."
"(DIR)")
WHOSE))]
[MULTICS (CLINE (GET_PNAME (APPLY 'ATOMIZE
(CONS 'LIST/
(AND WHOSE
(CONS '/ -P/
WHOSE))))))]
[DEC10 (VALRET (APPLY 'ATOMIZE
(APPEND '("DIR ")
(AND WHOSE (CONS '/[ WHOSE))
(AND WHOSE '(/]))
'(/
))))] NO-VALUE)]
(DEFINE PRINTOUTLINE (ABB LISTLINE LL POL) (NUMBER)
(DEFAULT-FUNCTION 'PRINTOUTLINE NIL)
(COND ((GETLINE PROG (SETQ NUMBER (NUMBER? 'PRINTOUTLINE NUMBER)))
(TYPE '";PRINTING LINE "
NUMBER
'" OF "
FN
EOL)
(LOGOPRINT (CONS NUMBER THIS-LINE))
NO-VALUE)
((SETQ NUMBER
(ERRBREAK 'PRINTOUTLINE
(LIST '"NO LINE NUMBERED "
NUMBER
'" IN "
FN)))
(PRINTOUTLINE NUMBER))))
;;;FOR EACH NAME ON :NAMES, PRINTOUTNAMES WRITES OUT
;;; MAKE "<NAME>" "<THING>"
;;;WHICH CAN BE REREAD TO RESTORE VALUES OF VARIABLES.
(DEFINE PRINTOUTNAMES (ABB LISTNAMES LN PON) NIL
(COND
(:CAREFUL
(COND (:NAMES (DTERPRI)
(MAPC
'(LAMBDA (NAME)
(AND (BOUNDP NAME)
(DPRINC '"MAKE '")
(DO ((CHARNUM 3. (1+ CHARNUM))
(CHAR (GETCHAR NAME 2.) (GETCHAR NAME CHARNUM)))
((NULL CHAR) T)
(DPRINC CHAR))
;;SPECIAL CASE CHECK FOR :EMPTYW IS REQUIRED, SINCE
;;ITS PRINTED REPRESENTATION IS NOT REREADABLE.
(COND ((EQ (SETQ NAME (SYMEVAL NAME)) :EMPTYW)
(TYPE '" :EMPTYW" EOL))
((DPRINC '" '") (DPRIN1 NAME) (DTERPRI)))))
:NAMES))
((IOG NIL (TYPE '";NO NAMES DEFINED" EOL)))))
((IOG
NIL
(TYPE
'";YOU ARE NOT IN CAREFUL MODE. NO NAMES ARE SAVED."
EOL))))
NO-VALUE)
;;LISTING ABBREVIATIONS AND PRIMITIVES IS ACCOMPLISHED BY EXAMINING THE OBLIST.
;;THIS TAKES NO SPACE BUT RESULTS IN AN UNORDERED AND THEREFORE UNINFORMATIVE
;;PRINTOUT. AN IMPROVEMENT WOULD BE TO HAVE THESE INQUIRES BE ANSWERED BY ACCESSING
;;A DSK FILE OF COMMENTARY. THE FILE COULD BE CREATED AT COMPILE TIME.
(DEFINE PRINTOUTABBREVIATIONS (ABB LISTABBREVIATIONS) NIL
(TYPE '";ABBREVIATIONS:" EOL)
;;FILTER FOR ABBREVIATIONS.
(OBFILTER (EXPR-FUNCTION ABBREVIATIONP)
(EXPR-FUNCTION (LAMBDA (AB)
(TYPE AB
'" ABBREVIATION FOR "
(ABBREVIATIONP AB)
EOL)))))
(DEFINE PRINTOUTPRIMITIVES (ABB LISTPRIMITIVES) NIL
(TYPE 'PRIMITIVES: EOL)
(OBFILTER (EXPR-FUNCTION (LAMBDA (X) (AND (PRIMITIVEP X)
(NOT (ABBREVIATIONP X)))))
(EXPR-FUNCTION DPRINT)))
(DEFUN OBFILTER (*FILTER* *MESSAGE*)
;;PRINTS (MESSAGE ATOM) FOR EACH ATOM ON
(DO ((J 0. (1+ J)))
((= J (CADR (ARRAYDIMS 'OBARRAY))))
(MAPC '(LAMBDA (ATOM)
(AND (EXPR-CALL *FILTER* ATOM) (EXPR-CALL *MESSAGE* ATOM)))
(ARRAYCALL NIL OBARRAY J)))
?)
(DEFUN LIST-PROCEDURE (FNNAME)
;;PRINTS LISPIFIED USER FN AS LOGO.
(DEFAULT-FUNCTION 'LIST-PROCEDURE FNNAME)
(DTERPRI)
(LOGOPRINC TITLE)
(DO ((PROC (CDDDR PROG) (CDR PROC)) (THIS-FORM (CADDR PROG) (CAR PROC)))
((NULL PROC) (TYPE EOL 'END EOL))
(COND ((NUMBERP THIS-FORM)
;;TAG PRINTED
(DTERPRI)
(DPRINC THIS-FORM))
((DPRINC '/ )
(UNPARSE-FORM (EXPR-FUNCTION DPRINC) THIS-FORM)))))
;;*PAGE
(DEFUN LOGOPRINT (X) (LOGOPRINC X) (DTERPRI))
(DEFUN LOGOPRINSP (X) (LOGOPRINC X) (DPRINC '/ ))
;;; THE FOLLOWING CODE INSERTS CARRAIGE RETURNS IN LONG COMMENTS
;;; LIKE THE PRETTY-PRINTER DOES. THIS CODE IS NOW UNUSUABLE DUE
;;; TO MODIFICATIONS IN THE PRINTER, BUT SIMILAR STUFF SHOULD BE
;;; WRITTEN AT SOME POINT.
;;;
;;;
;;; (DEFUN PRINT-COMMENT (FN ARGS)
;;; (DINDENT-TO (DIFFERENCE LINEL 20.))
;;; (DPRINC '!)
;;; (DSEGTEXT (CAR ARGS))
;;; (DPRINC '!))
;;;
;;;
;;;
;;;
;;; (DEFUN DINDENT-TO (X)
;;;SIMILAR
;;TO INDENT-TO BUT DOES NOT USE TABS
;;; (AND (LESSP CHRCT X) (DTERPRI))
;;;WHICH
;;DISPLAY DOES NOT UNDERSTAND.
;;; (PROG NIL
;;; LOOP (COND ((= CHRCT X)) ((DPRINC '/ ) (GO LOOP)))))
;;;
;;; (DEFUN DSEGTEXT (L)
;;; (PROG (N)
;;; (AND (ATOM L) (RETURN (TYPE L))) ;GRINDS THE
;;SEGMENT L AS TEXT INTO REMAINING
;;; (SETQ N CHRCT) ;SPACE ON
;;LINE. SERVES TO INSERT CR'S IN
;;; A (TYPE (CAR L)) ;EXCESSIVELY
;;LONG COMMENTS.
;;; (POP L)
;;; (OR L (RETURN NIL))
;;; (COND ((LESSP (FLATSIZE (CAR L)) (DIFFERENCE CHRCT 2.))
;;; (DPRINC '/ ))
;;; ((DINDENT-TO N)))
;;; (GO A)))
;;;
(DEFINE LINEPRINT FEXPR (X)
[ITS (UWRITE TPL)]
[MULTICS (UWRITE)]
(IOG
RW
(PROG (CRUNIT :SHOW LINEL)
[(OR ITS DEC10) (SETQ LINEL 120.)]
[MULTICS (SETQ LINEL (LINEL NIL))
(LINEL NIL 120.)]
;;SAVE CURRENT DEVICE, DIRNAME.
(SETQ CRUNIT (CRUNIT))
(TYPE '";************* "
(STATUS UNAME)
'/
(OR X :EMPTYW)
'" *************"
EOL)
(DPRINTL '/; (DAYTIME))
(DPRINTL '/; (DATE))
(DTERPRI)
(PRINTOUTALL)
[ITS (UFILE)]
[MULTICS (LET ((DIRECTORY (GET_PNAME (CAR (NAMES (CAR OUTFILES))))))
(UFILE LINE_PRINT LOGO)
(CLINE (CATENATE "DPRINT -DELETE "
DIRECTORY
">LINE_PRINT.LOGO ")))
(LINEL NIL LINEL)]
;;RESTORE ORIGINAL DEVICE.
(APPLY 'CRUNIT CRUNIT)))
NO-VALUE)


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

@@ -0,0 +1,611 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; LISP LOGO READER ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(DECLARE (OR (STATUS FEATURE DEFINE)
(COND ((STATUS FEATURE ITS)
;;MULTICS?
(FASLOAD DEFINE FASL AI 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


386
src/llogo/setup.1 Normal file
View File

@@ -0,0 +1,386 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SETUP > ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;THIS FILE CONTAINS LLOGO INITIALIZATIONS, CREATION OF OBARRAY & READTABLE, SOME
;;UTILITY FUNCTIONS.
;;;
(SSTATUS FEATURE LLOGO)
(DECLARE (SETQ MACROS NIL)
;;MACROS = T FROM DEFINE FILE.
(OR (STATUS FEATURE DEFINE)
(COND ((STATUS FEATURE ITS)
;;MULTICS?
(FASLOAD DEFINE FASL AI LLOGO)))))
;;FOR DEFINING NEW LLOGO PRIMITIVES, DEFINE IS DEFINED TO AUTOLOAD IN FILE
;;LLOGO;DEFINE FASL, CONTAINING A FEXPR DEFININTION OF DEFINE, PUSH, POP AND OTHER
;;ASSORTED MACROS, ALONG WITH SQUARE BRACKET AND DOUBLE QUOTE READMACROS.
;;;
;;NOTE: DEFINE MAY ONLY BE CALLED FROM LISP, NOT LOGO!
;;;
[ITS (OR (STATUS FEATURE DEFINE) (DEFPROP DEFINE (DEFINE FASL AI LLOGO) AUTOLOAD))]
(SETQ GENSYM (GENSYM)
LISP-READTABLE READTABLE
LISPREADTABLE LISP-READTABLE
LOGO-READTABLE (GET [(OR ITS DEC10) (*ARRAY 'LOGO-READTABLE
'READTABLE)]
;;MULTICS INCOMPATABILITY.
[MULTICS (MAKREADTABLE 'LOGO-READTABLE)]
'ARRAY)
LOGOREADTABLE LOGO-READTABLE
CAR T
CDR T
NO-VALUE '?)
;;THIS PAGE SHOULD APPEAR BEFORE THE LOGO OBARRAY IS CREATED TO AVOID UNEXPECTED
;;ATOMS BEING INTERNED ON THE LISP OBARRAY BEFORE THE LOGO OBARRAY IS CREATED FROM
;;IT. THE FOLLOWING IS A LIST OF ATOMS THAT ARE TO BE PUT ON BOTH OBARRAYS FOR
;;CONVENIENCE. THE DUMMY MEMQ IS AN ATTEMPT TO FOOL FASLAP TO NOT THROW AWAY THE
;;LIST BEFORE READING IT.
(MEMQ NIL
'(! /" $ /
/ /' /( /) /; / : :PARENBALANCE :BURIED :CAREFUL :COMPILED :CONTENTS :DSCALE
:ECHOLINES :EDITMODE :EMPTY :EMPTY :EMPTYS :EMPTYW :ERRBREAK :HEADING
:INFIX :LISPBREAK :NAMES :NAMES :PAGE :PI :PICTURE :POLYGON :REDEFINE
:SCREENSIZE :SHOW :SNAPS :SNAPS :TEXT :TEXTXHOME :TEXTYHOME :TSIZE :TURTLE
:WINDOWS :WRAP :XCOR :YCOR ABB ABBREVIATION ABBREVIATIONS ABBS ALL ARG
ARGPDL BOTH BYE COMPILED CONTENTS DOWN EDITTITLE ELSE ENTRY ENTRYCOND
ERRBREAK EXITCOND F FALSE FASL FASL FILE GT40 HOMCHECK INDEX LEFT LINE
LISPBREAK N NAMES NO PI-OVER-180 PARSE PARSEMACRO PRIM PRIMITIVE
PRIMITIVES PROCEDURES READOB REMGRIND REMTRACE RIGHT SNAPS SQUARE-BRACKETS
T34 TESTFLAG THEN TITLE TITLES TRUE UNITE UNTRACE USER-PAREN VALUE WHEREIN
WINDOW WINDOWS WRONG Y YES /[ /] _))
;;SHARP-SIGN ["#"] IS MADE AN IMMEDIATE READ MACRO WHICH DOES THE NEXT READ ON THE
;;LISP OBARRAY IF PERFORMED FROM LOGO, OR LOGO OBARRAY IF DONE FROM LISP. LISP
;;READTABLE IS ALWAYS USED.
(DEFUN OBSWITCH NIL
(COND ((EQ OBARRAY LOGO-OBARRAY)
((LAMBDA (OBARRAY READTABLE) (READ)) LISP-OBARRAY LISP-READTABLE))
(((LAMBDA (OBARRAY READTABLE) (READ)) LOGO-OBARRAY LISP-READTABLE))))
(COND ((GET 'LOGO-OBARRAY 'ARRAY)
'"OBARRAYS ALREADY ESTABLISHED")
((PUTPROP 'LISP-OBARRAY (SETQ LISP-OBARRAY OBARRAY) 'ARRAY)
(SET [(OR ITS DEC10) (*ARRAY 'LOGO-OBARRAY 'OBARRAY)]
;;MULTICS IS BEHIND THE TIMES.
[MULTICS (MAKOBLIST 'LOGO-OBARRAY)]
(GET 'LOGO-OBARRAY 'ARRAY))
(SETSYNTAX 35. 'MACRO 'OBSWITCH)
[(OR ITS DEC10) (SETSYNTAX 35. 198656. NIL)]
((LAMBDA (READTABLE)
(SETSYNTAX 35. 'MACRO 'OBSWITCH)
[(OR ITS DEC10) (SETSYNTAX 35. 198656. NIL)])
LOGO-READTABLE)))
;;198656. = OCTAL 604000, STANDARD MACRO SYNTAX IS 404500; 600000 BIT MAKES A
;;SINGLE CHARACTER OBJECT.
[ITS (SETQ LISP-OBDIM (CADR (ARRAYDIMS 'OBARRAY))
LISP-OBDIM (COND ((ODDP LISP-OBDIM) LISP-OBDIM) ((- LISP-OBDIM 129.))))]
;;;DIMENSION OF LISP OBARRAY, USED BY KNOWNP.
;;A KLUDGE HERE IS THAT IN SOME VERSIONS OF LISP, THE DIMENSION OF THE OBARRAY IS
;;THE RIGHT NUMBER TO USE, IN OTHERS IT IS THAT NUMBER LESS 129.
;;*PAGE
(SAVE-VERSION-NUMBER SETUP)
;;*PAGE
;;; UTILITY FUNCTIONS
;;;
;;FIRST ARG IS MESSAGE TO BE PRINTED OUT, FOLLOWED BY FILE NAMES TO BE FASLOADED IN
;;IF USER GIVES ASSENT.
(DEFUN LOAD-IF-WANTED FEXPR (MESSAGE-FILES)
(PRINC (CAR MESSAGE-FILES))
(AND (ASK)
(LET ((OBARRAY LISP-OBARRAY))
(MAPC '(LAMBDA (FILE)
[(OR ITS DEC10) (APPLY 'FASLOAD FILE)]
[MULTICS (LOAD FILE)])
(CDR MESSAGE-FILES)))))
;;ARGS ARE PUT TOGETHER AND MAKE ONE ATOM. USED BY COMPILE FUNCTION.
(DEFUN ATOMIZE ARGS (MAKNAM (MAPCAN 'EXPLODEC (LISTIFY ARGS))))
;;FILLS IN DEFAULTS FOR FILE COMMANDS.
(DEFUN FILESPEC (X)
(OR (APPLY 'AND (MAPCAR 'ATOM X))
(SETQ X
(ERRBREAK 'FILESPEC
(LIST X
'"IS NOT A FILE NAME"))))
(COND ((NULL X) (APPEND (STATUS CRFILE) (CRUNIT)))
((NOT (CDR X))
(APPEND X
'([ITS >]
[DEC10 LGO]
[MULTICS LOGO])
(CRUNIT)))
((NOT (CDDR X)) (APPEND X (CRUNIT)))
[(OR ITS DEC10) ((NOT (CDDDR X))
(APPEND (LIST (CAR X) (CADR X))
'(DSK)
(CDDR X)))
(X)]
[MULTICS ((LIST (CAR X)
(CADR X)
'DSK
(APPLY 'ATOMIZE
(COND ((EQ (CADDR X) 'DSK) (CDDDR X))
((CDDR X))))))]))
;;RETURNS LAMBDA DEF OF FN. IGNORES TRACE.
(DEFUN TRACED? (FNNAME)
(PROG (TRACED DEF)
(SETQ DEF (GETL FNNAME '(EXPR)))
(RETURN (COND ((SETQ TRACED (GETL (CDR DEF) '(EXPR)))
(DPRINC '";TRACED")
(DTERPRI)
(SETQ DEF (CADR TRACED)))
((SETQ DEF (CADR DEF)))))))
;;PREDICATE FOR WHETHER FN X IS CURRENTLY TRACED. DOES NOT ERR IF TRACE PACKAGE IS
;;NOT PRESENT.
(DEFUN TRACE? (X) (AND (STATUS FEATURE TRACE) (MEMQ X (TRACE))))
;;UNTRACES X. DOES NOT ERR IF TRACE PACKAGE NOT PRESENT.
(DEFUN UNTRACE1 (X) (AND (TRACE? X) (APPLY 'UNTRACE (LIST X))))
;;*PAGE
(DEFUN FUNCTION-PROP (ATOM)
(GETL ATOM '(EXPR FEXPR MACRO SUBR LSUBR FSUBR ARRAY)))
;;THE SUBSET SUB IS SUBTRACED FROM SET.
(DEFUN SET- (SET SUB)
(DO ((REMOVE-ELEMENTS SUB (CDR REMOVE-ELEMENTS)))
((NULL REMOVE-ELEMENTS) SET)
(SETQ SET (DELQ (CAR REMOVE-ELEMENTS) SET))))
;;NON-DESTRUCTIVE VERSION OF SET-.
(DEFUN DELEET (SET OTHER-SET)
(COND ((NULL SET) NIL)
((MEMBER (CAR SET) OTHER-SET) (DELEET (CDR SET) OTHER-SET))
((CONS (CAR SET) (DELEET (CDR SET) OTHER-SET)))))
;;PRINTS LIST WITHOUT CONSING. EG (WRITELIST 'SETQ 'X '/( 'CONS '/' A '/)). NOTE
;;THAT EMBEDDED PARENS MUST BE QUOTED. PRIN1 IS USED EXCEPT ON /(, /) AND /'.
(DEFUN WRITELIST ARGS
(PRINC '/()
(DO ((I 1. (1+ I)) (P 0.))
((> I ARGS)
(COND ((= P 0.) (PRINC '/)))
((ERRBREAK 'WRITELIST
'" - UNBALANCED PARENTHESES"))))
(COND ((EQ (ARG I) '/') (PRINC '/'))
((EQ (ARG I) '/() (INCREMENT P) (PRINC '/())
((EQ (ARG I) '/)) (DECREMENT P) (PRINC '/)))
((PRIN1 (ARG I)) (TYO 32.)))))
;;PUSHS X ONTO LIST IF X NOT ALREADY PRESENT
(DEFUN UNITE (X LIST)
(LET ((UNITE-WITH (SYMEVAL LIST)))
(OR (MEMQ X UNITE-WITH) (SET LIST (CONS X UNITE-WITH))))
NO-VALUE)
;;*PAGE
(SETQ :CAREFUL T
;;LIST OF COMPILED USER FUNCTIONS.
:COMPILED NIL
;;LIST OF INTERPRETIVE USER FUNCTIONS.
:CONTENTS NIL
;;LIST OF BURIED USER FUNCTIONS.
:BURIED NIL
;;LIST OF USER VARIABLES.
:NAMES NIL
;;SWITCH TO REGULATE CHECKING FOR LISP/LOGO HOMONYMS.
HOMCHECK T)
;;CHECKS FOR LISP/LOGO HOMONYMS. PREVENTS OBSCURE SCREWS WHEN DEFINING NEW LOGO
;;PRIMITIVES.
(DEFUN HOMCHECK (ATOM)
(AND HOMCHECK
(IOG NIL
(COND ((FUNCTION-PROP ATOM)
(PRINC (LIST '"
WARNING.." ATOM
'" HAS PROPERTY LIST "
(CDR ATOM)))))))
(OBTERN ATOM LOGO-OBARRAY))
;;FOR LOGO FUNCTIONS WITH DIFFERENT NAMES THAN LISP FUNCTIONS WHICH PERFORM
;;IDENTICAL TASKS.
(DEFUN SYNONYMIZE (SYNONYM GOLDEN-OLDIE)
(LET
((SYNPROP (FUNCTION-PROP GOLDEN-OLDIE)))
(COND
(SYNPROP (PUTPROP SYNONYM (CADR SYNPROP) (CAR SYNPROP))
[(OR ITS DEC10) (AND (SETQ SYNPROP (ARGS GOLDEN-OLDIE))
(ARGS SYNONYM SYNPROP))]
(AND (SETQ SYNPROP (GET GOLDEN-OLDIE 'PARSE))
[CLOGO (OR (ATOM (CAR SYNPROP))
;;;JOIN SHOULD NOT GET PARSE-CLOGO-HOMONYM
;;PROPERTY OF LIST.
(NOT (EQ (CAAR SYNPROP)
'PARSE-CLOGO-HOMONYM)))]
(PUTPROP SYNONYM SYNPROP 'PARSE)))
((ERRBREAK 'DEFINE
(LIST GOLDEN-OLDIE
'" -SYNONYM OF "
SYNONYM
'" NOT FOUND"))))))
;;*PAGE
;;IF ATOM IS NOT ALREADY PRESENT ON THE OBARRAY OB, IT IS INTERNED. ELSE USER IS
;;ASKED IF HE WANTS TO SUBSTITUTE IT.
(DEFUN OBTERN (ATOM OB)
(PROG (OBATOM)
(LET
((OBARRAY OB))
(COND
((EQ ATOM (SETQ OBATOM (INTERN ATOM))) (RETURN ATOM))
([(OR ITS MULTICS) (CDR OBATOM)]
[DEC10 (AND (> (LENGTH OBATOM) 2.)
(OR (BOUNDP OBATOM)
(NOT (EQ (CADR OBATOM) 'VALUE))))]
(IOG
NIL
(PRINT OBATOM)
(PRINC '" HAS PROPERTY LIST ")
(PRINT (CDR OBATOM))
(PRINC
'"
DO YOU WANT TO GET RID OF IT? ")
(AND (MEMQ (READ) '(NO N NIL F FALSE WRONG NOPE))
(RETURN NIL)))))
(REMOB OBATOM)
(RETURN (INTERN ATOM)))))
;;EXPR-FUNCTION AND EXPR-CALL ARE FUNCTION AND FUNCALL, EXCEPT THAT WHEN COMPILING
;;THEY ARE REPLACED BY SPEEDIER SUBRCALL FOR EFFICIENCY.
(DEFINE EXPR-FUNCTION (SYN FUNCTION))
(DEFINE EXPR-CALL (SYN FUNCALL))
(DEFINE EXPR-CALL-FIXNUM (SYN FUNCALL))
;;*PAGE
;;;
;;;
;;; ABBREVIATIONS
;;;
;; ABBREVIATIONS ARE ACCOMPLISHED BY PUTTING THE NAME OF THE FUNCTION TO BE
;;ABBREVIATED ON THE ABBREVIATION'S PROPERTY LIST UNDER EXPR OR FEXPR INDICATORS AS
;;APPROPRIATE. IF CALLED DIRECTLY AS A FUNCTION, THE ABBREVIATION WILL HAVE THE
;;SAME AFFECT AS THE ABBREVIATED FUNCTION.
;;;
;; CURRENTLY ON MULTICS, ALL ABBREVIATIONS MUST BE DONE WITH EXPR PROPERTIES AND NOT
;;FEXPR PROPERTIES. CONDITIONAL CODE WHICH HANDLES THIS INCOMPATIBILITY SHOULD
;;SOMEDAY BE REMOVED WHEN IT IS FIXED. THERE IS ALSO CONDITIONAL CODE IN DEFINE FOR
;;THIS PURPOSE.
;;;
;;ABBREVIATES EVEN IF NEW HAS A FN PROP.
(DEFUN ABB1 (NEW OLD)
(PUTPROP
NEW
OLD
[MULTICS 'EXPR]
[(OR ITS DEC10) (LET
((FPROP (CAR (FUNCTION-PROP OLD))))
(COND
((MEMQ FPROP '(EXPR SUBR LSUBR)) 'EXPR)
((MEMQ FPROP '(FEXPR FSUBR MACRO)) 'FEXPR)
((ERRBREAK
'ABBREVIATE
(LIST
OLD
'"CAN'T BE ABBREVIATED BECAUSE IT DOESN'T HAVE A DEFINITION")))))])
[(OR ITS DEC10) (AND (ARGS OLD) (ARGS NEW (ARGS OLD)))]
(AND (GET OLD 'PARSE)
(PUTPROP NEW (GET OLD 'PARSE) 'PARSE))
(LIST '/; OLD '" ABBREVIATED BY " NEW))
(DEFINE ABBREVIATE (ABB AB) (NEW OLD)
(AND (PRIMITIVEP NEW)
(SETQ NEW (ERRBREAK 'ABBREVIATE
(LIST NEW
'"IS USED BY LOGO"))))
(OR
(SYMBOLP NEW)
(SETQ
NEW
(ERRBREAK 'ABBREVIATE
(LIST NEW
'" IS NOT A VALID PROCEDURE NAME"))))
(AND
(EQ (GETCHAR NEW 1.) ':)
(SETQ
NEW
(ERRBREAK
'ABBREVIATE
(LIST
NEW
'" LOOKS LIKE A VARIABLE NAME- NOT A VALID PROCEDURE NAME"))))
(AND (OR (MEMQ NEW :CONTENTS) (MEMQ NEW :COMPILED))
(SETQ NEW (ERRBREAK 'ABBREVIATE
(LIST NEW
'"IS ALREADY DEFINED."))))
(OR (PRIMITIVEP OLD) (SETQ OLD (PROCEDUREP 'ABBREVIATE OLD)))
(ABB1 NEW OLD)
(LIST '/; OLD '"ABBREVIATED BY" NEW))
;;OLD MUST BE A LISP LOGO PRIMITIVE OR A USER FUNCTION.
[ITS (DEFINE ALLOCATOR NIL
(OR
(COND
((= TTY 5.)
;;TTY=5 IFF USER IS AT A TV TERMINAL.
(LOAD-IF-WANTED
"DO YOU WANT TO USE THE TV TURTLE? "
(TVRTLE FASL DSK LLOGO)))
((LOAD-IF-WANTED
"DO YOU WANT TO USE THE DISPLAY TURTLE? "
(TURTLE FASL DSK LLOGO))
(TYPE
'"DO YOU WANT TO USE THE GT40 RATHER THAN THE 340?")
(SETQ DEFAULT-TURTLE (COND ((ASK) 'GT40) (340.)))))
(LOAD-IF-WANTED GERMLAND? (GERM FASL DSK LLOGO))
(LOAD-IF-WANTED "MUSIC BOX? " (MUSIC FASL DSK LLOGO))))]
[MULTICS (DEFINE ALLOCATOR NIL
(LOAD-IF-WANTED
"DO YOU WANT TO USE THE MUSIC BOX? "
">UDD>AP>LIB>LOGO_MUSIC"))]


698
src/llogo/turtle.465 Normal file
View File

@@ -0,0 +1,698 @@
;;; LOGO TURTLE FUNCTIONS
(DECLARE (OR (STATUS FEATURE DEFINE) (FASLOAD DEFINE FASL AI LLOGO)))
(SSTATUS FEATURE TURTLE)
(DECLARE (GENPREFIX TURTLE)
(*FEXPR PHOTO SNAP PICTURE RESNAP)
(*LEXPR ERRBREAK POINT DSCALE SETHOME DISPLAY BLINK UNBLINK MOTION BRIGHT
SCALE RANGE BEARING TOWARDS PENSTATE)
(*EXPR HOME)
(SPECIAL :WRAP :POLYGON FLOAT-DIS :SNAP :TEXTXHOME :TEXTYHOME NEWTURTLE
WORLD :SNAPS :DSCALE :RAD3 :PI :TURTLE HOME :HEADING :XCOR :YCOR
:PICTURE :PAGE :SHOW :TSIZE :TEXT :SCREENSIZE PI-OVER-180 PLOTS))
(COND ((STATUS FEATURE LLOGO)
(READ-ONLY :WRAP :XCOR :YCOR :SNAP :SNAPS :DSCALE :TURTLE :PI :HEADING
:PICTURE :PAGE :SHOW :TEXT :SCREENSIZE :TSIZE :RAD3)
(SYSTEM-VARIABLE :POLYGON))
((DEFUN ERRBREAK ARGS (PRINC (ARG 1.)) (APPLY 'BREAK (LIST (ARG 2.) T)))
(DEFUN HOMCHECK (USELESS) USELESS)
(DEFUN OBTERN (IGNORE THIS) IGNORE)
(DEFUN TYPE ARGS
(DO ((I 1. (1+ I))) ((> I ARGS) (ARG (1- I))) (PRINC (ARG I))))
(DEFUN ASK NIL (MEMQ (READ) '(Y YES OK YUP SURE OUI DA)))
(DEFUN FILESPEC (X)
(OR (APPLY 'AND (MAPCAR 'ATOM X))
(SETQ X (ERRBREAK 'FILESPEC
(LIST X 'IS/ NOT/ A/ FILE/ NAME))))
(COND ((NULL X) (APPEND (STATUS CRFILE) (CRUNIT)))
((NOT (CDR X)) (APPEND X '(>) (CRUNIT)))
((NOT (CDDR X)) (APPEND X (CRUNIT)))
((NOT (CDDDR X))
(APPEND (LIST (CAR X) (CADR X)) '(DSK) (CDDR X)))
(X)))))
;;THE TURTLE PACKAGE IS GOING TO EAT LOTS OF FLONUM SPACE, SO IN BIBOP LISP, ASSURE
;;THAT ENOUGH WILL BE AVAILABLE.
(AND (MEMQ 'BIBOP (STATUS FEATURES))
(ALLOC '(FLONUM (2000. 4000. NIL) FLPDL 2000.)))
(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))
(DEFUN DISPLAY-PRINC (X)
(AND :SHOW (DISCUSS :TEXT :TEXTXHOME :TEXTYHOME X))
(PRINC X))
(DEFUN DISPLAY-TERPRI NIL
(AND :SHOW (DISCUSS :TEXT :TEXTXHOME :TEXTYHOME EOL))
(TERPRI))
(DECLARE (READ))
(READ)
;;COMPILED BUT NOT INTERPRETIVELY.
(SETQ DPRINC (GET 'DISPLAY-PRINC 'SUBR) DTERPRI (GET 'DISPLAY-TERPRI 'SUBR))
(DECLARE (READ) (READ))
;;INTERPRETIVELY BUT NOT COMPILED. [NOUUO=T]
(DEFPROP DPRINC DISPLAY-PRINC EXPR)
(DEFPROP DTERPRI DISPLAY-TERPRI EXPR)
;;THE FREE VARIABLES ":XCOR, :YCOR" ARE NECESSARY FOR FLOATING POINT ACCURACY.
;;;
;;*PAGE
(DEFINE STARTDISPLAY (ABB SD) ARGS
(REMPROP ':PICTURE 'SNAP)
(REMPROP ':PICTURE 'ORIGINAL)
(MAPC '(LAMBDA (SNAP) (MAKUNBOUND SNAP) (REMPROP SNAP 'SNAP))
:SNAPS)
(IOC Y)
(SETQ :SNAPS NIL
NEWTURTLE NIL
WORLD ':PICTURE
:TURTLE 0.
:SNAPS NIL
:HEADING 0.0
:XCOR 0.0
:YCOR 0.0
:SHOW NIL
:TEXT NIL)
(OR (ZEROP ARGS) (SETQ DEFAULT-TURTLE (ARG 1.)))
(COND ((ERRSET (DISSTART1) NIL))
;;IF ERROR, FLUSH SLAVE AND TRY AGAIN.
(T (DISFLUSH)
(TYPE '/;TRYING/ TO/ REGRAB/ DISPLAY/ SLAVE EOL)
(SETQ :TURTLE 0.)
(DISSTART1))))
(ARGS 'STARTDISPLAY '(0. . 1.))
(DEFUN DISSTART1 NIL
;;SUBROUTINE OF DISSTART. NO GLOBAL PURPOSE. OPENS SLAVE OR FLUSHES CURRENT
;;ARRAYS, GUARANTEES ASTATE=0. ONE DISINI TO START SLAVE, ONE TO SET
;;"ASTATE" MODE
(COND ((EQ DEFAULT-TURTLE 'GT40) (DISINI 0. 'T34)) ((DISINI)))
(DISINI 0.)
(SETQ :PICTURE (DISCREATE (CAR HOME) (CADR HOME)))
(SHOWTURTLE)
(IOC F))
(DEFINE WIPE NIL (OR (= :TURTLE 0.) (SETQ :TURTLE (DISCOPY :TURTLE)))
((LAMBDA (D) (DISFLUSH :PICTURE)
(SETQ :PICTURE (DISCREATE (CAR D) (CADR D)))
(DISALINE :PICTURE (CADDR D) (CADDDR D) 1.)
(DISMARK :PICTURE :TURTLE)
(DISET :PICTURE (CADDDR (CDDDR D))))
(DISCRIBE :PICTURE))
'?)
(DEFINE WIPECLEAN (ABB WC) NIL
;;IN ADDITION TO WIPE HIDES ALL SNAPS
(WIPE)
(MAPC 'HIDE (MAPCAR 'EVAL :SNAPS))
'?)
(DEFINE CLEARSCREEN (ABB CS) NIL (WIPECLEAN) (HOME))
(DEFINE NODISPLAY (ABB ND) NIL (SETQ :SHOW NIL) (DISFLUSH) '?)
;;THE TURTLE
(DEFINE HIDETURTLE (ABB HT) NIL (COND ((NOT (= :TURTLE 0.))
(DISMARK :PICTURE 0.)
(DISFLUSH :TURTLE)
(SETQ :TURTLE 0.)))
'?)
(DEFINE SHOWTURTLE (ABB ST) NIL
;;:TURTLE IS 0 IF TURTLE IS NOT DISPLAYED. ELSE IT'S THE NUMBER OF THE
;;DISPLAY ITEM WHICH IS THE TURTLE. :PICTURE IS THE ITEM WHICH THE TURTLE
;;AFFECTS. DOES NOT INCLUDE SNAPS SHOWN VIA SHOWSNAP.
(COND ((= :TURTLE 0.)
(SETQ :TURTLE (DISCREATE (+ (XHOME) (XCOORD)) (+ (YHOME) (YCOORD))))
(DISPLAY :TURTLE NIL)
(COND (NEWTURTLE ((LAMBDA (:PICTURE :TURTLE :XCOR :YCOR :HEADING
:DSCALE :SCREENSIZE)
(MAPC 'EVAL NEWTURTLE))
:TURTLE
0.
0.0
0.0
:HEADING
NIL
512.))
((TURTLE)))
(DISMARK :PICTURE :TURTLE)))
'?)
(DEFUN TURTLE NIL
(PROG (H)
(DISINI 3.)
(SETQ H (MINUS (DIFFERENCE :HEADING 90.0)))
(DISALINE :TURTLE (//$ :TSIZE :RAD3) H -1.)
(DISALINE :TURTLE :TSIZE (SETQ H (+$ H 150.0)))
(DISALINE :TURTLE :TSIZE (SETQ H (+$ H 120.0)))
(DISALINE :TURTLE :TSIZE (SETQ H (+$ H 120.0)))
(DISINI 0.)))
(DEFINE HOME (ABB H) NIL (OR (= :TURTLE 0.) (DISPLAY :TURTLE NIL))
(DISALINE :PICTURE 0. 0. 1.)
(SETQ :XCOR 0.0 :YCOR 0.0)
(SETHEAD 0.)
'?)
;;;MOVING THE TURTLE. THE BASIC INTERFACE WITH THE DISPLAY IS "SETXY".
(DEFINE FORWARD (ABB FD) (R) (SETXY (PLUS :XCOR (TIMES R (SINE :HEADING)))
(PLUS :YCOR (TIMES R (COSINE :HEADING)))))
(DEFINE BACK (ABB BK) (R) (FORWARD (MINUS R)))
(DEFINE SETTURTLE (ABB SETT) (P)
;;(SETTURTLE '(100 100 90)) SETS THE STATE OF THE
;;TURTLE TO THE POSITION '(100 100) AND HEADING 90.
;;THE HEADING IS OPTIONAL. (SETTURTLE (HERE)) IS A
;;NO-OP.
(SETXY (CAR P) (CADR P))
(AND (CDDR P) (SETHEAD (CADDR P))))
(DEFINE SETX (X) (SETXY X :YCOR))
(DEFINE SETY (Y) (SETXY :XCOR Y))
(DEFINE SETXY (X Y)
(AND (NOT :WRAP)
(OR (GREATERP (ABS X) :SCREENSIZE) (GREATERP (ABS Y) :SCREENSIZE))
(ERRBREAK 'SETXY 'TURTLE/ MOVING/ OFF/ SCREEN!))
(SETQ :XCOR X :YCOR Y)
(COND (:DSCALE (DISALINE :PICTURE
(ROUND (TIMES X :DSCALE))
(ROUND (TIMES Y :DSCALE))))
((DISALINE :PICTURE (ROUND X) (ROUND Y))))
'?)
;;;TURNING THE TURTLE
(DEFINE RIGHT (ABB RT) (ANGLE) (SETHEAD (PLUS :HEADING ANGLE)))
(DEFINE LEFT (ABB LT) (ANGLE) (SETHEAD (DIFFERENCE :HEADING ANGLE)))
(DEFINE SETHEAD (ABB SH SETHEADING) (ANGLE)
;;UPDATES :HEADING AND ROTATES TURTLE.
(SETQ :HEADING ANGLE)
(COND ((= :TURTLE 0.)) ((HIDETURTLE) (SHOWTURTLE)))
'?)
(DEFINE WRAP NIL (SETQ :WRAP T) '?)
(DEFINE NOWRAP NIL (SETQ :WRAP NIL) '?)
;;EXAMINING THE TURTLE'S STATE
(DEFINE XHOME NIL (CAR (DISCRIBE :PICTURE)))
;;RETURNS ABSOLUTE X SCOPE COORDINATE OF HOME
(DEFINE YHOME NIL (CADR (DISCRIBE :PICTURE)))
(DEFINE HOMESTATE NIL (LIST (XHOME) (YHOME)))
(DEFUN XCOORD NIL (CADDR (DISCRIBE :PICTURE)))
;;ABSOLUTE X COORD
(DEFINE XCOR NIL (ROUND :XCOR))
;;SCALED X COORD
(DEFUN YCOORD NIL (CADDDR (DISCRIBE :PICTURE)))
;;ABSOLUTE Y COORD
(DEFINE YCOR NIL (ROUND :YCOR))
;;SCALED Y COORD
(DEFINE HERE NIL (LIST (XCOR) (YCOR) (HEADING)))
(DEFINE HEADING NIL
((LAMBDA (X) (OR (AND (MINUSP X) (+ 360. X)) X)) (\ (ROUND :HEADING) 360.)))
;;THE PEN
(DEFINE PENDOWN (ABB PD) NIL (DISET :PICTURE -1.) '?)
(DEFINE PENUP (ABB PU) NIL (DISET :PICTURE 1.) '?)
(DEFINE PENSTATE ARGS (COND ((= ARGS 0.)
;;(PENSTATE) = STATE OF PEN (PENSTATE <1, -1>) SETS PEN
;;UP OR DOWN (PENSTATE (PENSTATE)) IS A NO-OP
(CADDDR (CDDDR (DISCRIBE :PICTURE))))
((= ARGS 1.) (DISET :PICTURE (ARG 1.)))))
(DEFINE PENP NIL (= (PENSTATE) -1.))
;;PENDOWN <=> PENSTATE = -1. TRIG FNS
;;;
;;GLOBAL VARIABLES - FOLLOWS ANY POSSIBLE REMOBS
(SETQ :WRAP NIL
:DSCALE NIL
NEWTURTLE NIL
:TSIZE 30.0
:RAD3 1.7320508
:PI 3.1415926
PI-OVER-180 (//$ :PI 180.0)
:TURTLE 0.
;;TURTLE = DEFAULT CROSS
HOME '(512. 512.)
:SCREENSIZE 512.)
;;MAX SCALED X,Y COORDINATE
;;*PAGE
;;THE TURTLE
(DEFINE MAKTURTLE (PARSE L) FEXPR (X) (SETQ NEWTURTLE X)
;;MAKTURTLE SHOULD BE FOLLOWED BY A LOGO LINE.
;;QUOTES ARE NOT NECESSARY. SHOWTURTLE
;;INSPECTS NEWTURTLE VARIABLE TO DECIDE WHICH
;;TURTLE TO SHOW.
(HIDETURTLE)
(SHOWTURTLE))
(DEFINE OLDTURTLE NIL (SETQ NEWTURTLE NIL) (HIDETURTLE) (SHOWTURTLE))
;;MOVING THE TURTLE. THE BASIC INTERFACE WITH THE DISPLAY IS "SETXY".
(DEFINE DELX (X) (SETXY (PLUS X :XCOR) :YCOR))
(DEFINE DELY (Y) (SETXY :XCOR (PLUS :YCOR Y)))
(DEFINE DELXY (X Y) (SETXY (PLUS :XCOR X) (PLUS :YCOR Y)))
;;POINTS
(DEFINE POINT ARGS
(COND ((= ARGS 0.) (DISAPOINT :PICTURE (XCOORD) (YCOORD) -1.))
((= ARGS 1.)
(DISAPOINT :PICTURE (ROUND (CAR (ARG 1.))) (ROUND (CADR (ARG 1.)))))
((= ARGS 2.)
(DISAPOINT (ARG 1.) (ROUND (CAR (ARG 2.))) (ROUND (CADR (ARG 2.)))))
((= ARGS 3.) (DISAPOINT (ARG 1.) (ROUND (ARG 2.)) (ROUND (ARG 3.))))))
;;EXAMINING THE TURTLE'S STATE
(DEFINE TURTLESTATE NIL (CADDDR (CDDDR (CDR (DISCRIBE :PICTURE)))))
;;DISPLAYING TEXT
(DEFINE SHOWTEXT NIL
;;CLEARS TEXT AND DISPLAYS SUBSEQUENT PRINTING.
(SETQ :SHOW T)
(OR :TEXT (SETQ :TEXT (DISCREATE :TEXTXHOME :TEXTYHOME)))
'?)
(DEFINE HIDETEXT NIL (SETQ :SHOW NIL) '?)
(DEFINE REMTEXT NIL (ERRSET (DISFLUSH :TEXT) NIL)
;;CLEARS TEXT AND TURNS OFF DISPLAY OF SUBSEQUENT TEXT OFF.
(SETQ :SHOW NIL :TEXT NIL)
'?)
(DEFINE MARK (X)
;;PUTS TEXT AT CURRENT TURTLE POSITION.
((LAMBDA (^W :SHOW :TEXT :TEXTXHOME :TEXTYHOME) (TYPE X EOL))
T
T
:PICTURE
(XCOORD)
(YCOORD)))
;;POTS
;;;JOYSTICK = POTS 66 (HORIZ) AND 67 (VERTICAL). MUST BE CALIBRATED.
;;;ORDINARY POTS 0 - 3777
(DEFINE DIALS (X) (QUOTIENT (PROG2 (MPX 1. NIL)
;;RETURNS VALUE OF POT X AS DECIMAL BETWEEN 0 AND
;;1. LSH USED TO ELIMINATE BAD BIT FROM IMPX.
(LSH (LSH (IMPX X) 1.) -1.)
(MPX 0. NIL))
2047.0))
;;PLOTTER FUNCTIONS.
(DEFINE NOPLOT NIL (PLOT 0.) '?)
;;CLOSES PLOTTER
(SETQ PLOTS NIL)
;;PROTECTION AGAINST GC.
(DEFINE PLOTTER FEXPR (A)
;;WITH NO ARG, THE CURRENT DISPLAY IS PLOTTED ON A FRESH PAGE; ELSE IT IS PLOTTED
;;OVER THE CURRENT PAGE. ERROR IF PLOTTER UNAVAILABLE, OTHERWISE OPENS PLOTTER.
;;NEW PAGE IF NO ARG.
(OR (ERRSET (PLOT 63.) NIL) (ERRBREAK 'PLOTTER 'PLOTTER/ UNAVAILABLE))
(OR A (NEXTPLOT))
(AND
PLOTS
(IOG
NIL
;;ANSWER Y IF PLOTTER IS DONE WITH OLD PLOTS.
(TYPE '";IS PLOTTER DONE WITH YOUR PREVIOUS PLOTTING? "
EOL)
(AND (ASK) (SETQ PLOTS NIL))))
(PLOTLIST (SETQ A (MAPCAR '(LAMBDA (X) (GET (DISGORGE X) 'ARRAY))
(DISLIST)))
'/.)
;;POINTS ARE PLOTTED AS "."
(SETQ PLOTS (APPEND PLOTS A))
;;SAVE POINTER TO LIST OF ARRAYS WHICH THE IPL JOB IS PLOTTING TO AVOID ARRAYS
;;BEING GC'ED.
'?)
;;ANY TTY CHARACTER CAN BE USED.
(DEFINE DISPAGE NIL
;;DISPLAYS 7X11 PAGE OUTLINE.
((LAMBDA (OASTATE)
(SETQ :PAGE (DISCREATE) :SNAPS (PUSH ':PAGE :SNAPS))
(DISALINE :PAGE 0. 1023.)
(DISALINE :PAGE 791. 1023.)
(DISALINE :PAGE 791. 0.)
(DISALINE :PAGE 0. 0.)
(DISINI OASTATE))
(DISINI 1.))
'?)
;;GLOBAL STATE
;;;
;;ALL OF THE FOLLOWING COMMANDS CAN TAKE AN OPTIONAL FIRST ARGUMENT EVALUATING TO
;;SOME DISPLAY ITEM. OTHERWISE, THEY REFER TO THE :PICTURE.
(DEFINE BLINK ARGS (COND ((= ARGS 0.) (DISBLINK :PICTURE T)) ((DISBLINK (ARG 1.) T)))
'?)
(DEFINE UNBLINK ARGS
(COND ((= ARGS 0.) (DISBLINK :PICTURE NIL)) ((DISBLINK (ARG 1.) NIL)))
'?)
(DEFINE MOTION ARGS (COND ((= ARGS 0.) (DISMOTION :PICTURE -1. -1. 100.))
((DISMOTION (ARG 1.) -1. -1. 100.))))
(DEFINE SETHOME ARGS
(COND ((= ARGS 0.)
(DISLOCATE :PICTURE (+ (XHOME) (XCOORD)) (+ (YHOME) (YCOORD)))
(HOME))
((= ARGS 1.) ((LAMBDA (:PICTURE) (SETHOME)) (ARG 1.)))
((= ARGS 2.) (DISLOCATE :PICTURE (ROUND (ARG 1.)) (ROUND (ARG 2.))))
((DISLOCATE (ARG 1.) (ARG 2.) (ARG 3.))))
'?)
(DEFINE BRIGHT ARGS
;;;1 < BRIGHTNESS < 8
;;;(BRIGHT) = BRIGHTNESS OF :PICTURE
;;;(BRIGHT :SCENE) = BRIGHTNESS OF :SCENE
;;;(BRIGHT :SCENE #) SETS BRIGHTNESS OF
;;;:SCENE TO #.
(COND ((= ARGS 0.) (CADDR (CDDR (DISCRIBE :PICTURE))))
((= 1. ARGS) (CADDR (CDDR (DISCRIBE (ARG 1.)))))
((BSL (ARG 1.) (ARG 2.) (SCALE (ARG 1.))))))
(DEFINE SCALE ARGS
;;;1 < SCALE < 4
;;;(SCALE) = SCALE OF :PICTURE
;;;(SCALE :SCENE) = SCALE OF :SCENE
;;(SCALE :SCENE #) SETS SCALE OF :SCENE TO #.
(COND ((= ARGS 0.) (CADDR (CDDDR (DISCRIBE :PICTURE))))
((= 1. ARGS) (CADDR (CDDDR (DISCRIBE (ARG 1.)))))
((BSL (ARG 1.) (BRIGHT (ARG 1.)) (ARG 2.)))))
(DEFUN BSL (ITEM BR SCALE)
(DISCHANGE ITEM (DIFFERENCE BR (BRIGHT ITEM)) (DIFFERENCE SCALE (SCALE ITEM)))
(DISET ITEM 0. (LIST BR SCALE)))
(DEFINE DSCALE ARGS (COND ((= ARGS 0.) :DSCALE)
((= 1. ARGS)
(OR :DSCALE (SETQ :DSCALE 1.0))
(SETQ :XCOR (TIMES (QUOTIENT :XCOR (ARG 1.)) :DSCALE))
(SETQ :YCOR (TIMES (QUOTIENT :YCOR (ARG 1.)) :DSCALE))
(SETQ :DSCALE (FLOAT (ARG 1.))))))
;;MANIPULATING SCENES
(DEFINE PHOTO (ABB SNAP) (PARSE L)
;;CREATES A NEW COPY OF :PICTURE ON TOP OF THE CURRENT ONE. THE SNAP HAS A COPY OF
;;THE CURRENT TURTLE, WHICH EG (PHOTO "SCENE" SQUARE 100) WILL BE MOVED AROUND AS
;;THE PEN POSITION OF THE SNAP MOVES.
FEXPR (X)
(PROG (:SNAP NAME)
(SETQ NAME (READLIST (CONS ': (EXPLODE (EVAL (CAR X))))))
(COND ((MEMQ NAME :SNAPS) (ERRSET (DISFLUSH (SYMEVAL NAME)) NIL))
((PUSH NAME :SNAPS)))
(COND ((CDR X)
;;IF GIVEN A LINE OF CODE, WILL PRODUCE A SNAP WITH THAT NAME
;;CONTAINING RESULT OF CODE
(APPLY 'PICTURE (CDR X))
(PUTPROP NAME (GET ':SNAP 'SNAP) 'SNAP))
((DISPLAY (SETQ :SNAP (DISCOPY :PICTURE)) T)
(OR (= :TURTLE 0.) (DISMARK :SNAP (DISCOPY :TURTLE)))
(PUTPROP NAME (LIST :XCOR :YCOR :HEADING) 'SNAP)))
(RETURN (SET NAME :SNAP))))
(DEFINE ENTERSNAP (PARSE 1.) FEXPR (X)
;;EG (SNAP "SCENE") REBINDS WORLD TO NEW SNAP.
(APPLY 'PHOTO (LIST (CAR X) '(HIDETURTLE)))
(SETQ X (READLIST (CONS ': (EXPLODE (EVAL (CAR X))))))
;;X=NAME OF SNAP.
(CHANGEWORLD X))
(DEFINE ENDSNAP NIL (CHANGEWORLD ':PICTURE))
;;RETURNS WORLD TO ORIGINAL :PICTURE
(DEFINE PICTURE (PARSE L) FEXPR (X)
;;:SNAP BOUND TO PICTURE
(SETQ :SNAP (DISCREATE (XHOME) (YHOME)))
(DISALINE :SNAP (XCOORD) (YCOORD) 1.)
(DISET :SNAP (PENSTATE))
((LAMBDA (:PICTURE :TURTLE :XCOR :YCOR :HEADING)
;;BIND PROTECTS STATE AGAINST ^G.
(OR (= :TURTLE 0.) (SETQ :TURTLE (DISCOPY :TURTLE)))
(DISMARK :PICTURE :TURTLE)
(ERRSET (MAPC 'EVAL X))
(SETQ :SNAP :PICTURE)
(PUTPROP ':SNAP (LIST :XCOR :YCOR :HEADING) 'SNAP))
:SNAP
:TURTLE
:XCOR
:YCOR
:HEADING)
:SNAP)
;;CREATE A NEW DISPLAY ITEM, BIND :SNAP TO IT, EXECUTE COMMAND LINE, SAVE (HERE) AS
;;SNAP PROPERTY OF :SNAP. COMMANDS ONLY AFFECT :SNAP, WHICH IS A GLOBAL VARIABLE.
(DEFINE REMSNAP (:SNAP)
(DISFLUSH :SNAP)
(PROG (SNAPS SNAPNAME)
(SETQ SNAPS :SNAPS)
LOOP (COND ((NULL SNAPS) (RETURN :SNAP))
((EQUAL :SNAP (SYMEVAL (SETQ SNAPNAME (CAR :SNAPS))))
(REMPROP SNAPNAME 'SNAP)
(MAKUNBOUND SNAPNAME)
(SETQ :SNAPS (DELETE SNAPNAME :SNAPS))
(RETURN :SNAP)))
(POP SNAPS)
(GO LOOP)))
(DEFUN CHANGEWORLD (SNAPNAME)
;;EG SNAPNAME = :FOO
(PROG (STATE)
(SETQ :SNAP (COND ((AND (EQ SNAPNAME ':PICTURE)
(GET SNAPNAME 'ORIGINAL)))
((SYMEVAL SNAPNAME))))
(OR (ERRSET (DISCRIBE :SNAP) NIL)
(ERRBREAK 'CHANGEWORLD
(LIST SNAPNAME 'IS/ NOT/ A/ SNAP)))
(AND WORLD
;;REMEMBER OLD WORLD IF NAMED.
(NOT (NUMBERP WORLD))
(COND ((EQ WORLD ':PICTURE)
(PUTPROP ':PICTURE :PICTURE 'ORIGINAL))
((SET WORLD :PICTURE)))
(PUTPROP WORLD (LIST :XCOR :YCOR :HEADING) 'SNAP))
(SETQ WORLD SNAPNAME
:PICTURE :SNAP
;;:PICTURE NOW BECOMES :SNAP.
STATE (COND ((GET SNAPNAME 'SNAP))
;;STATE OF :SNAP IS FOUND
((LIST (COND (:DSCALE (QUOTIENT (XCOORD) :DSCALE))
((XCOORD)))
(COND (:DSCALE (QUOTIENT (YCOORD) :DSCALE))
((YCOORD)))
0.0)))
:XCOR (CAR STATE)
:YCOR (CADR STATE)
:HEADING (CADDR STATE)
:TURTLE (TURTLESTATE))
;;TURTLE COMMANDS NOW REFER TO THE TURTLE WHICH RESIDES IN :SNAP.
(RETURN :SNAP)))
(DEFINE RESNAP (PARSE L) FEXPR (X)
;;E.G. RESNAP :P1 FD 100 EXECUTES CODE WITH COPY OF TURTLE IN THAT SNAP.
(COND ((CDR X)
(PROG (WORLD SNAPNAME :PICTURE :TURTLE :XCOR :YCOR :HEADING)
(CHANGEWORLD (SETQ SNAPNAME (CAR X)))
;;REBINDS STATE TO SNAP.
(ERRSET (MAPC 'EVAL (CDR X)))
(PUTPROP SNAPNAME (LIST :XCOR :YCOR :HEADING) 'SNAP)
(RETURN (SET SNAPNAME (SETQ :SNAP :PICTURE)))))
((CHANGEWORLD (CAR X)))))
(DEFINE SHOW (DNAME)
;;SHOW TRANSLATES THE SNAP TO CURRENT TURTLE POSITION AND
;;DISPLAYS IT.
(DISLOCATE DNAME (+ (XHOME) (XCOORD)) (+ (YHOME) (YCOORD)))
(DISPLAY DNAME T))
(DEFINE HIDE (DNAME) (DISPLAY DNAME NIL))
(DEFINE SHOWSNAP (X)
;;SHOWSNAP MAKES A COPY OF ITS INPUT, AND ITS INFERIORS, AND DISPLAYS IT AT
;;THE CURRENT POSITION OF THE TURTLE. COPY IS LINKED.
(PROG (C)
(SETQ C (DISCOPY (COND ((DISLIST X) (CAR (DISLIST X))) (X))))
(DISLOCATE C (+ (XHOME) (XCOORD)) (+ (YHOME) (YCOORD)))
(DISLINK X C T)
(DISPLAY C T)
(RETURN C)))
(DEFINE HIDESNAP (X) (COND ((DISLIST X) (MAPC 'DISFLUSH (DISLIST X))))
(DISPLAY X NIL))
;;GLOBAL NAVIGATION
(DEFINE TOWARDS ARGS
;;DIRECTION OF A POINT RELATIVE TO TURTLE HEADING. +0-360 DEGREES. POINT =
;;(X Y).
(PROG (X Y TEMP)
(COND ((= ARGS 1.) (SETQ X (CAR (ARG 1.))) (SETQ Y (CADR (ARG 1.))))
((SETQ X (ARG 1.)) (SETQ Y (ARG 2.))))
(COND ((MINUSP (SETQ TEMP (DIFFERENCE (BEARING X Y) (HEADING))))
(RETURN (PLUS 360. TEMP)))
((RETURN TEMP)))))
(DEFINE BEARING ARGS
(PROG (X Y TEMP X1 Y1)
(COND ((= ARGS 1.) (SETQ X (CAR (ARG 1.))) (SETQ Y (CADR (ARG 1.))))
((SETQ X (ARG 1.)) (SETQ Y (ARG 2.))))
(SETQ X1 (DIFFERENCE X :XCOR) Y1 (DIFFERENCE Y :YCOR))
;;;+0-360 DEGREES. POINT = (X Y)
;;MADE NECESSARY SINCE (ATAN 0 0) = 45 DEGREES.
(AND (LESSP (ABS X1) 0.01) (LESSP (ABS Y1) 0.01) (RETURN 0.))
(SETQ TEMP (*$ 180.0
(//$ (ATAN (DIFFERENCE (FLOAT X) :XCOR)
(DIFFERENCE (FLOAT Y) :YCOR))
:PI)))
(AND (MINUSP TEMP) (SETQ TEMP (DIFFERENCE 360. TEMP)))
(RETURN (OR (AND (FIXP X) (FIXP Y) (ROUND TEMP)) TEMP))))
(DEFINE RANGE ARGS
(PROG (X Y TEMP)
(COND ((= ARGS 1.) (SETQ X (CAR (ARG 1.))) (SETQ Y (CADR (ARG 1.))))
((SETQ X (ARG 1.)) (SETQ Y (ARG 2.))))
(SETQ TEMP (SQRT (PLUS (EXPT (DIFFERENCE X :XCOR) 2.)
(EXPT (DIFFERENCE Y :YCOR) 2.))))
(RETURN (OR (AND (FIXP X) (FIXP Y) (ROUND TEMP)) TEMP))))
;;GLOBAL VARIABLES - FOLLOWS ANY POSSIBLE REMOBS
(SETQ :SNAPS NIL)
(SETQ :TEXTXHOME 0.)
;;TEXT ARRAY X COORDINATE
(SETQ :TEXTYHOME 1000.)
;;TEXT ARRAY Y COORDINATE
;;;A TURTLE SCENE CONSISTS OF ANY SUBSET OF FOLLOWING ARRAYS:
;;; :TURTLE
;;; :PICTURE
;;; :TEXT
;;; AND ANY SNAPS THAT HAVE BEEN CREATED.
;;;
;;;TO SAVE A TURTLE SCENE,
;;:SNAPS IS A LIST OF ARRAY NAMES BUG IN SLAVE - DISGOBBLE CAUSES SLAVE TO DIE.
(DEFINE SAVESNAPS FEXPR (X)
(MAPC '(LAMBDA (X) (PUTPROP X
(GET (DISGORGE (SYMEVAL X)) 'ARRAY)
'ARRAY))
:SNAPS)
(APPLY 'DUMPARRAYS
(LIST :SNAPS
(FILESPEC (COND ((CDR X) X) ((LIST (CAR X) 'SNAPS))))))
(MAPC '(LAMBDA (X) (REMPROP X 'ARRAY)) :SNAPS))
(DEFINE GETSNAPS FEXPR (X)
(MAPC '(LAMBDA (Y) ((LAMBDA (:PICTURE SNAPNAM)
(SETQ :PICTURE (DISGOBBLE :PICTURE))
(SET SNAPNAM :PICTURE)
(PUTPROP SNAPNAM
(LIST (XCOORD) (YCOORD) 0.0)
'SNAP)
(COND ((MEMQ SNAPNAM :SNAPS)
(TYPE '/;
SNAPNAM
'" CONFLICTS"
EOL))
((PUSH SNAPNAM :SNAPS))))
(CAR Y)
(CADR Y)))
(LOADARRAYS (FILESPEC X))))
;;;ARC PROCEDURES
(SETQ :POLYGON 30.)
(DEFINE ARC (RADIUS DEGREES)
(PROG (HT SIDE TURN SIDES CENTER)
(COND ((= :TURTLE 0.)) ((SETQ HT T) (HIDETURTLE)))
(SETQ SIDE (TIMES 2. RADIUS (SIN (QUOTIENT :PI :POLYGON)))
TURN (QUOTIENT 360.0 :POLYGON)
SIDES (QUOTIENT DEGREES TURN)
CENTER (HERE))
(PENUP)
(FORWARD RADIUS)
(RIGHT 90.)
(PENDOWN)
LOOP (COND ((LESSP SIDES 1.)
(RIGHT (QUOTIENT TURN 2.))
(FORWARD (TIMES SIDES SIDE)))
(T (RIGHT (QUOTIENT TURN 2.))
(FORWARD SIDE)
(RIGHT (QUOTIENT TURN 2.))
(SETQ SIDES (DIFFERENCE SIDES 1.))
(GO LOOP)))
(PENUP)
(SETXY (CAR CENTER) (CADR CENTER))
(SETHEAD (PLUS (CADDR CENTER) DEGREES))
(PENDOWN)
(AND HT (SHOWTURTLE))
(RETURN '?)))


5249
src/llogo/tvrtle.1 Normal file
View File

File diff suppressed because it is too large Load Diff

798
src/llogo/unedit.1 Normal file
View File

@@ -0,0 +1,798 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; LOGO UNPARSER ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(DECLARE (OR (STATUS FEATURE DEFINE)
(COND ((STATUS FEATURE ITS)
;;MULTICS?
(FASLOAD DEFINE FASL AI LLOGO)))))
(SAVE-VERSION-NUMBER UNEDIT)
(DECLARE (GENPREFIX UNEDIT))
;; ATOM-GOBBLER IS A FUNCTIONAL ARGUMENT TO THE UNPARSER WHICH GETS HANDED
;;SUCCESSIVE ATOMIC TOKENS OF THE UNPARSED LINE. THE PRINTER USES AN ATOM-GOBBLER
;;WHICH PRINTS OUT EACH TOKEN. FOR EDITING LINES, A LIST OF THE UNPARSED TOKENS IS
;;CONSTRUCTED.
(DEFUN UNPARSE-LIST-OF-FORMS (ATOM-GOBBLER FORM-LIST)
(MAP '(LAMBDA (FORMS) (UNPARSE-FORM ATOM-GOBBLER (CAR FORMS))
;;SPACES IN BETWEEN SUCCESSIVE FORMS.
(AND (CDR FORMS) (EXPR-CALL ATOM-GOBBLER '/ )))
FORM-LIST))
;;PRINTS OUT A LINE OF LOGO SOUCE CODE.
(DEFUN LOGOPRINC (TO-BE-PRINTED)
(UNPARSE-LIST-OF-FORMS (EXPR-FUNCTION DPRINC) TO-BE-PRINTED))
;;CALLED BY EDITOR TO RECONSTRUCT SOURCE CODE.
(DEFUN UNPARSE-LOGO-LINE (PARSED-LINE)
(LET ((UNPARSED-LINE))
(UNPARSE-LIST-OF-FORMS (EXPR-FUNCTION (LAMBDA (TOKEN)
(PUSH TOKEN
UNPARSED-LINE)))
PARSED-LINE)
(NREVERSE UNPARSED-LINE)))
(DEFUN UNPARSE-PRINT-FORM (FORM) (UNPARSE-FORM (EXPR-FUNCTION DPRINC) FORM))
(DEFUN UNPARSE-EXPR-FORM NIL (UNPARSE-LIST-OF-FORMS ATOM-GOBBLER PARSED-FORM))
(DEFUN UNPARSE-ATOM (ATOM)
(COND ((= (FLATC ATOM) (FLATSIZE ATOM)) (EXPR-CALL ATOM-GOBBLER ATOM))
((EXPR-CALL ATOM-GOBBLER '$)
(DO ((CHARNUM 1. (1+ CHARNUM)) (CHAR))
((> CHARNUM (FLATC ATOM)))
(SETQ CHAR (GETCHAR ATOM CHARNUM))
(COND ((EQ CHAR '$)
(EXPR-CALL ATOM-GOBBLER '$)
(EXPR-CALL ATOM-GOBBLER '$))
((EXPR-CALL ATOM-GOBBLER CHAR))))
(EXPR-CALL ATOM-GOBBLER '$))))
;;*PAGE
;;FIGURE OUT HOW TO UNPARSE BY FIGURING OUT HOW THE PARSER HANDLED IT.
(DEFUN UNPARSE-FORM (ATOM-GOBBLER PARSED-FORM)
(COND ((ATOM PARSED-FORM) (UNPARSE-ATOM PARSED-FORM))
((LET ((CAR-FORM (CAR PARSED-FORM))
(CDR-FORM (CDR PARSED-FORM))
(UNPARSE-PROP))
(COND ((NOT (ATOM CAR-FORM))
(UNPARSE-LIST-OF-CONSTANTS ATOM-GOBBLER PARSED-FORM))
((SETQ UNPARSE-PROP (GET CAR-FORM 'UNPARSE))
(EVAL UNPARSE-PROP))
((SETQ UNPARSE-PROP (GET CAR-FORM 'UNPARSE-INFIX))
(UNPARSE-INFIX UNPARSE-PROP CDR-FORM))
((AND (SETQ UNPARSE-PROP (GET CAR-FORM 'PARSE))
(COND ((CDR UNPARSE-PROP)
(UNPARSE-PARSE-PROP (CADR UNPARSE-PROP)))
((UNPARSE-PARSE-PROP (CAR UNPARSE-PROP))))))
((SETQ UNPARSE-PROP (HOW-TO-PARSE-INPUTS CAR-FORM))
(UNPARSE-PARSE-PROP UNPARSE-PROP))
((UNPARSE-LIST-OF-CONSTANTS ATOM-GOBBLER PARSED-FORM)))))))
;;WHAT CAN BE DONE ABOUT FUNCTIONS OF WHICH NOTHING IS KNOWN AT UNPARSE TIME? FOR
;;INSTANCE, THE FUNCTION MAY HAVE BEEN KNOWN AT PARSE TIME, BUT USER HAS SINCE
;;ERASED IT, READ A FILE CONTAINING CALL BUT NOT DEFINITION, ETC. HE MAY THEN ASK
;;TO PRINT OUT OR EDIT IT, REQUIRING A DECISION ON UNPARSING. PROBABLY THE BEST
;;THAT CAN BE DONE IS TO TREAT AS FEXPR- NOT DO FULL UNPARSING OF INPUTS. USER MAY
;;GET FREAKED OUT, BUT UNPARSED REPRESENTATION WILL BE RE-PARSABLE.
(DEFUN UNPARSE-PARSE-PROP (PARSE-PROP)
(COND ((OR (NUMBERP PARSE-PROP) (EQ PARSE-PROP 'L))
(UNPARSE-EXPR-FORM))
((EQ PARSE-PROP 'F)
(UNPARSE-LIST-OF-CONSTANTS ATOM-GOBBLER PARSED-FORM))
((ATOM PARSE-PROP)
(ERRBREAK 'UNPARSE-PARSE-PROP
(LIST '"SYSTEM BUG: "
CAR-FORM
'" HAS PARSE PROP "
PARSE-PROP
'" NEEDS UNPARSE PROP")))
((AND (CDR PARSE-PROP) (ATOM (CDR PARSE-PROP))) (UNPARSE-EXPR-FORM))
[CLOGO ((EQ (CAR PARSE-PROP) 'PARSE-CLOGO-HOMONYM)
(UNPARSE-PARSE-PROP (CADDR PARSE-PROP)))]
((EQ (CAR PARSE-PROP) 'PARSE-SUBSTITUTE) NIL)
((ERRBREAK 'UNPARSE-PARSE-PROP
(LIST '"SYSTEM BUG: "
CAR-FORM
'" HAS PARSE PROP "
PARSE-PROP
'" NEEDS UNPARSE PROP")))))
(DEFUN UNPARSE-SUBSTITUTE (FAKE-OUT)
(UNPARSE-FORM ATOM-GOBBLER (CONS FAKE-OUT CDR-FORM)))
;;*PAGE
;;UNPARSING OF "CONSTANTS" [QUOTED THINGS, INPUTS TO FEXPRS] CONSISTS OF DOING:
;;; (QUOTE <SEXP>) --> '<SEXP>
;;; (SQUARE-BRACKETS (<S1> ... <SN>)) --> [<S1> ... <SN>]
;;; (DOUBLE-QUOTE <SEXP>) --> "<SEXP>"
;;; (DOUBLE-QUOTE (<S1>...<SN>)) --> "<S1> ... <SN>"
;;;AND PRINTING PARENS AROUND LISTS.
(DEFUN UNPARSE-LIST-OF-CONSTANTS (ATOM-GOBBLER PARSED-FORM)
(MAP '(LAMBDA (CONSTANTS)
(UNPARSE-CONSTANT ATOM-GOBBLER (CAR CONSTANTS))
(AND (CDR CONSTANTS) (EXPR-CALL ATOM-GOBBLER '/ )))
PARSED-FORM))
(DEFUN UNPARSE-CONSTANT (ATOM-GOBBLER CONSTANT)
(COND ((ATOM CONSTANT) (UNPARSE-ATOM CONSTANT))
((EQ (CAR CONSTANT) 'QUOTE)
(EXPR-CALL ATOM-GOBBLER '/')
(UNPARSE-CONSTANT ATOM-GOBBLER (CADR CONSTANT)))
((EQ (CAR CONSTANT) 'DOUBLE-QUOTE)
(EXPR-CALL ATOM-GOBBLER '/")
(LET ((QUOTED (CADR CONSTANT)))
(COND ((ATOM QUOTED) (UNPARSE-ATOM QUOTED))
((CDR QUOTED)
(UNPARSE-LIST-OF-CONSTANTS ATOM-GOBBLER QUOTED))
((UNPARSE-CONSTANT ATOM-GOBBLER QUOTED))))
(EXPR-CALL ATOM-GOBBLER '/"))
((EQ (CAR CONSTANT) 'SQUARE-BRACKETS)
(EXPR-CALL ATOM-GOBBLER '/[)
(UNPARSE-LIST-OF-CONSTANTS ATOM-GOBBLER (CADR CONSTANT))
(EXPR-CALL ATOM-GOBBLER '/]))
((EXPR-CALL ATOM-GOBBLER '/()
(UNPARSE-LIST-OF-CONSTANTS ATOM-GOBBLER CONSTANT)
(EXPR-CALL ATOM-GOBBLER '/)))))
(MAPC '(LAMBDA (QUOTER) (PUTPROP QUOTER '(UNPARSE-QUOTER) 'UNPARSE))
'(QUOTE DOUBLE-QUOTE SQUARE-BRACKETS))
(DEFUN UNPARSE-QUOTER NIL (UNPARSE-CONSTANT ATOM-GOBBLER PARSED-FORM))
(DEFPROP LOGO-COMMENT (UNPARSE-COMMENT) UNPARSE)
(DEFUN UNPARSE-COMMENT NIL
(DO NIL
((NULL CDR-FORM))
(EXPR-CALL ATOM-GOBBLER (CAR CDR-FORM))
(POP CDR-FORM)))
(DEFPROP USER-PAREN (UNPARSE-PAREN) UNPARSE)
(DEFUN UNPARSE-PAREN NIL
(PROGN (EXPR-CALL ATOM-GOBBLER '/()
(UNPARSE-FORM ATOM-GOBBLER (CAR CDR-FORM))
(EXPR-CALL ATOM-GOBBLER '/))))
;;*PAGE
;;FOR ERROR MESSAGE PRINTOUTS, ETC. CHANGE INTERNAL FUNCTION NAMES TO EXTERNAL
;;FORM. HOMONYMS, INFIX.
(DEFUN UNPARSE-FUNCTION-NAME (PARSED-FUNCTION-NAME)
(COND ((GET PARSED-FUNCTION-NAME 'UNPARSE-INFIX))
((LET ((UNPARSE-PROP (GET PARSED-FUNCTION-NAME 'UNPARSE)))
(COND ((EQ (CAR UNPARSE-PROP) 'UNPARSE-SUBSTITUTE)
(CADADR UNPARSE-PROP)))))
(PARSED-FUNCTION-NAME)))
(DEFUN UNPARSE-INFIX (INFIX-OP ARGLIST)
(UNPARSE-FORM ATOM-GOBBLER (CAR ARGLIST))
(COND ((CDR ARGLIST)
(EXPR-CALL ATOM-GOBBLER '/ )
(EXPR-CALL ATOM-GOBBLER INFIX-OP)
(EXPR-CALL ATOM-GOBBLER '/ )
(UNPARSE-INFIX INFIX-OP (CDR ARGLIST)))))
(DEFPROP PARSEMACRO (UNPARSE-PARSEMACRO CDR-FORM) UNPARSE)
(DEFUN UNPARSE-PARSEMACRO (OLD-LINE)
;;POP OFF OLD-LINE UNTIL YOU HIT LINE NUMBER.
(DO NIL
((NUMBERP (CAR OLD-LINE))
(POP OLD-LINE)
(AND (EQ (CAR OLD-LINE) '/ ) (POP OLD-LINE))
(DO NIL
((NULL OLD-LINE))
(EXPR-CALL ATOM-GOBBLER (CAR OLD-LINE))
(POP OLD-LINE)))
(POP OLD-LINE)))
(DEFPROP COND (UNPARSE-COND CDR-FORM) UNPARSE)
(DEFUN UNPARSE-COND (CLAUSES)
(EXPR-CALL ATOM-GOBBLER 'IF)
(EXPR-CALL ATOM-GOBBLER '/ )
(UNPARSE-FORM ATOM-GOBBLER (CAAR CLAUSES))
(COND ((CDAR CLAUSES)
(EXPR-CALL ATOM-GOBBLER '/ )
(EXPR-CALL ATOM-GOBBLER 'THEN)
(EXPR-CALL ATOM-GOBBLER '/ )
(UNPARSE-LIST-OF-FORMS ATOM-GOBBLER (CDAR CLAUSES))))
(COND ((CDR CLAUSES)
(EXPR-CALL ATOM-GOBBLER '/ )
(EXPR-CALL ATOM-GOBBLER 'ELSE)
(EXPR-CALL ATOM-GOBBLER '/ )
(UNPARSE-LIST-OF-FORMS ATOM-GOBBLER (CDADR CLAUSES)))))
(DEFUN UNPARSE-DO NIL
(COND ((ATOM (CAR CDR-FORM)) (UNPARSE-EXPR-FORM))
((MAPC '(LAMBDA (ATOM) (EXPR-CALL ATOM-GOBBLER ATOM))
'(DO / /())
(MAP '(LAMBDA (VAR-SPEC)
(EXPR-CALL ATOM-GOBBLER '/()
(UNPARSE-LIST-OF-FORMS ATOM-GOBBLER (CAR VAR-SPEC))
(EXPR-CALL ATOM-GOBBLER '/))
(AND (CDR VAR-SPEC) (EXPR-CALL ATOM-GOBBLER '/ )))
(CAR CDR-FORM))
(MAPC '(LAMBDA (ATOM) (EXPR-CALL ATOM-GOBBLER ATOM))
'(/) / /())
(UNPARSE-LIST-OF-FORMS ATOM-GOBBLER (CADR CDR-FORM))
(EXPR-CALL ATOM-GOBBLER '/))
(EXPR-CALL ATOM-GOBBLER '/ )
(UNPARSE-LIST-OF-FORMS ATOM-GOBBLER (CDDR CDR-FORM)))))
;; THESE ARE ONLY NECESSARY SINCE FUNCTIONS HAVE SPECIAL PARSE PROPS.
(MAPC '(LAMBDA (F) (PUTPROP F '(UNPARSE-EXPR-FORM) 'UNPARSE))
'(INSERTLINE INSERT-LINE SETQ MAKEQ GO STORE))
;;*PAGE
;; DEFINING LOGO PROCEDURES.
(SETQ :REDEFINE NIL)
;;INITIALLY, USER IS ASKED ABOUT ANY REDEFINITION.
(DEFINE TO FEXPR (X)
(AND (NOT EDT)
:EDITMODE
(EQ PROMPTER '>)
(ERRBREAK 'TO
(LIST '"YOU ARE ALREADY EDITING " FN)))
(PROG (INPUTS COM NEW-FN)
(OR X
(AND (DEFAULT-FUNCTION 'TO NIL)
(SETQ COM (AND (CDR TITLE) (CADR TITLE)) X (CDAR TITLE))
(TYPE '";DEFINING " FN EOL)))
;;TYPE CHECK TO'S INPUTS.
(LET ((:CONTENTS (CONS (CAR X) :CONTENTS)))
(SETQ NEW-FN (PROCEDUREP 'TO (CAR X))
;;PROCEDUREP EXPECTS NEW-FN ON :CONTENTS.
INPUTS (CDR X)))
;;TO ALSO GETS CALLED WHILE EDITING TITLES. EDT IS SET TO OLD PROCEDURE
;;NAME, GIVEN AS INPUT TO EDTITITLE. CHECKED TO SEE WHAT'S APPROPRIATE FOR
;;EDITING TITLES.
(AND
(NOT :REDEFINE)
;;:REDEFINE=T MEANS REDEFINITION WILL BE ALLOWED WITHOUT ASKING USER.
(NOT (EQ EDT NEW-FN))
(OR (MEMQ NEW-FN :CONTENTS) (MEMQ NEW-FN :COMPILED))
(IOG
NIL
(TYPE
EOL
'/;
NEW-FN
'" IS ALREADY DEFINED. WOULD YOU LIKE TO REDEFINE IT?"))
(COND ((ASK))
;;ASK IF USER WANTS TO REDEFINE THE FUNCTION. IF NOT, FROM CONSOLE,
;;MERELY RETURN FROM TO. FROM FILE, CHANGE TO DUMMY FUNCTION NAME TO
;;SLURP UP LINES OF DEFINITION REMAINING. A KLUDGE, ADMITTEDLY.
(^Q (LET ((DUMMY-HACK (ATOMIZE NEW-FN
'" NOT RE")))
(APPLY 'TO (LIST DUMMY-HACK))
(SETQ :CONTENTS (DELQ DUMMY-HACK :CONTENTS))
(RETURN NO-VALUE)))
((RETURN (LIST '/; NEW-FN 'NOT 'REDEFINED))))
(TYPE '";REDEFINING " NEW-FN EOL))
(AND (CDR LOGOREAD)
;;TITLE LINE COMMENT PROCESSED.
(EQ (CAADR LOGOREAD) 'LOGO-COMMENT)
(SETQ COM (CADR LOGOREAD))
(POP LOGOREAD))
(COND
((PRIMITIVEP NEW-FN)
(COND
(:REDEFINE (ERASEPRIM NEW-FN))
(T
(IOG
NIL
(TYPE
'/;
NEW-FN
'" IS USED BY LOGO. WOULD YOU LIKE TO REDEFINE IT?"))
(COND ((ASK))
;;ASK IF USER WANTS TO REDEFINE THE FUNCTION. IF NOT, FROM
;;CONSOLE, MERELY RETURN FROM TO. FROM FILE, CHANGE TO DUMMY
;;FUNCTION NAME TO SLURP UP LINES OF DEFINITION REMAINING. A
;;KLUDGE, ADMITTEDLY.
(^Q (LET ((DUMMY-HACK (ATOMIZE NEW-FN
'" NOT RE")))
(APPLY 'TO (LIST DUMMY-HACK))
(SETQ :CONTENTS (DELQ DUMMY-HACK :CONTENTS))
(RETURN NO-VALUE)))
((RETURN (LIST '/; NEW-FN 'NOT 'REDEFINED))))
(TYPE '";REDEFINING " NEW-FN EOL)
(ERASEPRIM NEW-FN)))))
;;ARE ALL THE INPUTS TO FUNCTION BEING DEFINED KOSHER?
(MAP '(LAMBDA (VARL) (RPLACA VARL (VARIABLEP 'TO (CAR VARL))))
INPUTS)
(UNTRACE1 FN)
(SETQ FN NEW-FN
PROG (COND (EDT (EDITINIT EDT)) ((LIST 'PROG NIL '(END))))
TITLE (CONS (CCONS 'TO FN INPUTS) (AND COM (NCONS COM)))
:BURIED (DELETE FN :BURIED))
(UNITE FN ':CONTENTS)
;;FN ADDED TO :CONTENTS.
(PUTPROP FN
(COND (COM (LIST 'LAMBDA INPUTS COM PROG))
((LIST 'LAMBDA INPUTS PROG)))
'EXPR)
(OR EDT (NOT :EDITMODE) (SETQ PROMPTER '>))
(RETURN NO-VALUE)))
;;; END DOES NOT HAVE TO BE TYPED TO TERMINATE EDITING OF A PROCEDURE.
;;; IF USER TYPES IT, IT JUST TYPES BACK COMFORTING MESSAGE AND CHANGES PROMPTER TO
;;? SO AS
;;; NOT TO FREAK OUT 11 LOGO & CLOGO USERS. INSIDE A PROCEDURE, RETURNS ?.
(DEFINE END (PARSE (PARSE-END)) NIL (OUTPUT NO-VALUE))
(DEFUN PARSE-END NIL
(SETQ PROMPTER NO-VALUE)
(TYPE '/; FN '" DEFINED" EOL))
(DEFINE LOCAL (SYN COMMENT))
;;*PAGE
;; LOGO EDITOR
(SETQ LAST-LINE NIL NEXT-TAG NIL THIS-LINE NIL FN NIL PROG NIL TITLE NIL)
;;; FIRST INPUT TO DEFAULT-FUNCTION IS NAME OF CALLER TO BE USED IN ERROR MESSAGES
;;; IF NECESSARY.
;;; 2ND ARG = NIL -> CHECK IF DEFAULT FUNCTION EXITS.
;;; 2ND ARG = FUNCTION NAME -> RESET DEFAULT FUNCTION TO
;;; 2ND ARG, IF IT IS NOT ALREADY.
;;; SETS GLOBAL VARIABLES:
;;; FN <- CURRENT DEFAULT FUNCTION.
;;; PROG <- POINTER TO FN'S PROG.
;;; TITLE <- POINTER TO FN'S TITLE [AND TITLE LINE COMMENTS]
(DEFUN DEFAULT-FUNCTION (CALLER FUNCTION)
(COND
(FUNCTION (OR (EQ FN FUNCTION)
(SETQ FN (PROCEDUREP CALLER FUNCTION)
PROG (EDITINIT1 FN)
TITLE (CAR PROG)
PROG (CADR PROG)))
FN)
(FN)
((DEFAULT-FUNCTION
CALLER
(ERRBREAK
CALLER
'"YOU HAVEN'T SPECIFIED A PROCEDURE NAME")))))
;;; NOTE THAT LOGO-EDIT DOES NOTHING EXCEPT CHANGE DEFAULT FUNCTION IF
;;; GIVEN INPUT. PROMPTER CHANGED AS CONCESSION TO CLOGO & 11 LOGO USERS.
(DEFINE EDIT (PARSE (PARSE-SUBSTITUTE 'LOGO-EDIT)))
;;EDIT OF NO ARGS USES THE DEFAULT FN.
(DEFINE LOGO-EDIT (ABB ED) (UNPARSE (UNPARSE-SUBSTITUTE 'EDIT)) FEXPR (WHAT-FUNCTION)
(AND :EDITMODE
(EQ PROMPTER '>)
(ERRBREAK 'LOGO-EDIT
(LIST '"YOU ARE ALREADY EDITING"
FN)))
(DEFAULT-FUNCTION 'LOGO-EDIT (AND WHAT-FUNCTION (CAR WHAT-FUNCTION)))
(AND :EDITMODE (SETQ PROMPTER '>))
(LIST '/; 'EDITING FN))
;;RETURNS FIRST PROG OF FN
(DEFUN EDITINIT (FN) (CADR (EDITINIT1 FN)))
(DEFUN EDITINIT1 (FN)
;;CAR OF OUTPUT IS TITLE LINE + COMMENTS. CADR OF OUTPUT IS PROG.
(OR (MEMQ FN :CONTENTS)
(SETQ FN (ERRBREAK 'EDITINIT1
(LIST FN
'"NOT IN WORKSPACE"))))
(PROG (DEF INPUTS TITLE)
(SETQ DEF (TRACED? FN))
(SETQ INPUTS (CADR DEF) DEF (CDDR DEF))
(SETQ TITLE (LIST (APPEND (LIST 'TO FN) INPUTS)))
COM (COND ((EQ 'PROG (CAAR DEF))
(RETURN (CONS (NREVERSE TITLE) DEF)))
((PUSH (CAR DEF) TITLE) (SETQ DEF (CDR DEF)) (GO COM)))))
(DEFINE ERASELINE (ABB ERL) (ERASE-LINE-NUMBER)
(DEFAULT-FUNCTION 'ERASELINE NIL)
(TYPE '";ERASING LINE "
ERASE-LINE-NUMBER
'" OF "
FN
EOL)
(LET
((THIS-LINE) (NEXT-TAG) (LAST-LINE))
(GETLINE PROG
(SETQ ERASE-LINE-NUMBER (NUMBER? 'ERASELINE ERASE-LINE-NUMBER)))
(ERASE-LOCALS PROG THIS-LINE)
(COND
(THIS-LINE (RPLACD LAST-LINE NEXT-TAG) NO-VALUE)
((SETQ ERASE-LINE-NUMBER
(ERRBREAK 'ERASELINE
(LIST '"NO LINE NUMBERED"
ERASE-LINE-NUMBER
'" IN "
FN)))
(ERASELINE ERASE-LINE-NUMBER)))))
;;FLAG USED BY "TO".
(SETQ EDT NIL INPUT-LIST GENSYM)
(DEFINE EDITTITLE (ABB EDT) FEXPR (OPTIONAL-FUNCTION)
(DEFAULT-FUNCTION 'EDITTITLE
(AND OPTIONAL-FUNCTION (CAR OPTIONAL-FUNCTION)))
(EDT1 (REPAIR-LINE (UNPARSE-LOGO-LINE TITLE))))
(DEFINE TITLE (PARSE L) FEXPR (X) (EDT1 X))
(DEFUN EDT1 (LOGOREAD)
(LET
((EDT FN) (INPUT-LIST (CDDAR TITLE)))
(OR
(EQ (CAAR LOGOREAD) 'TO)
(SETQ
LOGOREAD
(ERRBREAK
'EDITTITLE
'"EDIT TITLE - TITLE LINE MUST BEGIN WITH TO")))
(EVAL (CAR LOGOREAD))
(COND ((NOT (EQ EDT FN))
(REMPROP EDT 'EXPR)
(SETQ :CONTENTS (DELETE EDT :CONTENTS) :BURIED (DELETE EDT :BURIED))
;;CHANGE FUNCTION NAMES IN PARSEMACROS INSIDE DEFINITION.
(MAPC '(LAMBDA (FORM) (COND ((ATOM FORM))
((EQ (CAR FORM) 'PARSEMACRO)
(RPLACA (CADDR FORM) FN))))
PROG)
(TYPE '";PROCEDURE NAME CHANGED FROM "
EDT
'" TO "
FN
EOL))
((NOT (EQUAL INPUT-LIST (CADR (GET FN 'EXPR))))
(TYPE '";INPUTS CHANGED TO "
(CADR (GET FN 'EXPR))
EOL))
((TYPE '";TITLE NOT CHANGED" EOL)))))
;;; SYNTAX: INSERTLINE <NUMBER> <FORM> <FORM> ....<FORM> <RETURN>
;;; INSERTS IN DEFAULT FUNCTION. MUST BE ONLY FORM ON LINE.
;;; NO REASON TO BE CALLED BY USER, SINCE LINE BEGINNING WITH NUMBER
;;; GETS PARSED AS INSERTLINE.
;;THE ONLY DIFFERENCE BETWEEN THESE TWO LINE INSERTING FUNCTIONS IS THAT FOR USE IN
;;USER PROCEDURES, THE LINE MUST BE COPIED. THIS IS NOT NECESSARY FOR AUTOMATICALLY
;;INSERTED LINES.
(DEFINE INSERTLINE (ABB INL) (PARSE (PARSE-INSERTLINE)) FEXPR (NEW-LINE)
(APPLY 'INSERT-LINE (SUBST NIL NIL NEW-LINE))
(LIST '";INSERTING LINE"
(CAR NEW-LINE)
'INTO
FN))
(DEFINE INSERT-LINE (PARSE (PARSE-INSERT-LINE)) FEXPR (NEW-LINE)
(DEFAULT-FUNCTION 'INSERT-LINE NIL)
(LET ((THIS-LINE) (NEXT-TAG) (LAST-LINE))
(GETLINE PROG (CAR NEW-LINE))
(ADDLINE PROG NEW-LINE))
NO-VALUE)
;;; GETLINE SETS THINGS UP TO MODIFY PROCEDURE LINES.
;;; LAST-LINE <- PIECE OF PROG WHOSE CADR IS <TAG>, WHOSE
;;; CAR IS LAST FORM BEFORE <TAG>.
;;; THIS-LINE <- LIST OF FORMS ON LINE NUMBER <TAG>.
;;; NEXT-TAG <- REMAINDER OF PROG STARTING WITH LINE FOLLOWING
;;; LINE NUMBER <TAG>.
;;;
;;; EXAMPLE: IF (GET '#FOO 'EXPR) IS
;;; (LAMBDA (:N) (PROG NIL 10 (TYPE 'F) 20 (TYPE'O) 30
;;; (TYPE 'OBAR) (END)))
;;; THEN (GETLINE (EDITINIT '#FOO) 20) MAKES
;;; THIS-LINE <- ((TYPE 'O))
;;; NEXT-TAG <- (30 (TYPE 'OBAR) (END))
;;; LAST-LINE <- ((TYPE 'F) 20 (TYPE 'O) 30 (TYPE 'OBAR) (END))
;;IF NO PROG DEFINITION, NEXT-TAG <- PROG <- THIS-LINE <- NIL. IF LINE NUMBER >
;;THAN <TAG> IS FOUND, THIS-LINE <- NIL, NEXT-TAG <- REMAINDER OF PROG STARTING WITH
;;FIRST HIGHER LINE NUMBER. LAST-LINE IS REMAINDER OF PROG WHOSE CAR IS FORM BEFORE
;;(CAR NEXT-TAG).
(DEFUN GETLINE (PROG TAG)
(PROG (LINE-NO)
LOOP (SETQ PROG (CDR PROG) LAST-LINE PROG THIS-LINE NIL LINE-NO (CADR PROG))
(COND ((EQUAL LINE-NO '(END)) (POP PROG) (GO NO-LINE))
((NOT (NUMBERP LINE-NO)) (GO LOOP)))
(POP PROG)
(COND ((EQUAL LINE-NO TAG)
(RETURN (SETQ PROG
(CDR PROG)
THIS-LINE
(CONS (CAR PROG) THIS-LINE)
PROG
(CDR PROG)
NEXT-TAG
(DO NIL
((OR (NUMBERP (CAR PROG))
(EQUAL (CAR PROG) '(END)))
PROG)
(SETQ THIS-LINE (CONS (CAR PROG) THIS-LINE)
PROG (CDR PROG)))
THIS-LINE
(NREVERSE THIS-LINE))))
((LESSP LINE-NO TAG) (GO LOOP)))
NO-LINE
(RETURN (SETQ NEXT-TAG PROG THIS-LINE NIL))))
;;ADDLINE REQUIRES THE GLOBAL VARIABLES THIS-LINE, NEXT-TAG, AND LAST-LINE, AS SET
;;BY GETLINE.
(DEFUN ADDLINE (PROG EDITED)
;;EDITED = (NUMBER (CALL) (CALL) ...).
(COND ((CDR EDITED)
(ERASE-LOCALS PROG THIS-LINE)
;;IF THE LINE CONTAINED LOCAL VARIABLE DECLARATIONS, THE PROG MUST BE
;;MODIFIED.
(MAPC
'(LAMBDA (FORM)
(COND ((EQ (CAR FORM) 'LOCAL)
(MAPC 'EDIT-LOCAL (CDR FORM)))
;;MAKE TESTFLAG LOCAL TO ANY PROCEDURE HARBORING A
;;TEST.
((EQ (CAR FORM) 'TEST)
(OR (MEMQ 'TESTFLAG (CADR PROG))
(RPLACA (CDR PROG)
(CONS 'TESTFLAG (CADR PROG)))))))
(CDR EDITED))
(RPLACD LAST-LINE EDITED)
(NCONC EDITED NEXT-TAG))))
(DEFUN MAKLOGONAM (VAR)
;;MAKES A LOGO VARIABLE NAME OUT OF VAR.
(LET
((OBARRAY LOGO-OBARRAY))
(COND
((SYMBOLP VAR)
(COND ((EQ (GETCHAR VAR 1.) ':) VAR)
((IMPLODE (CONS ': (EXPLODEC VAR))))))
((MEMQ (CAR VAR) '(DOUBLE-QUOTE QUOTE))
(IMPLODE (CONS ': (EXPLODEC (CADR VAR)))))
((ERRBREAK
'MAKLOGONAM
(LIST VAR
'" IS NOT A VALID VARIABLE NAME"))))))
;;THE VAR IS ADDED TO THE LOCAL VARS OF PROG. IF ALREADY PRESENT, A WARNING IS
;;ISSUED.
(DEFUN EDIT-LOCAL (VAR)
(SETQ VAR (MAKLOGONAM VAR))
(COND
((MEMQ VAR (CADR PROG))
(TYPE '";WARNING- "
VAR
'" IS ALREADY A LOCAL VARIABLE"
EOL))
((EQ (GET VAR 'SYSTEM-VARIABLE) 'READ-ONLY)
(ERRBREAK
'LOCAL
(LIST
VAR
'"CAN'T BE LOCAL BECAUSE IT'S USED BY LOGO")))
((RPLACA (CDR PROG) (CONS VAR (CADR PROG))))))
;;THE LOCAL VARS IF ANY OF THE OLD LINE ARE DELETED FROM THE PROG.
(DEFUN ERASE-LOCALS (PROG LINES)
(MAPC '(LAMBDA (X) (AND (EQ (CAR X) 'LOCAL)
(RPLACA (CDR PROG)
(SET- (CADR PROG)
(MAPCAR 'MAKLOGONAM (CDR X))))))
LINES))
;;*PAGE
;;BURYING A PROCEDURE MAKES IT INVISIBLE TO PRINTOUT PROCEDURES, PRINTOUT ALL, ERASE
;;PROCEDURES, ERASE ALL, PRINTOUT TITLES, COMPILE, SAVE, AND WRITE. INTENDED FOR A
;;PACKAGE OF FUNCTIONS WHICH YOU WANT TO BE "THERE" BUT NOT CONSIDERED AS PART OF
;;YOUR WORKSPACE WHEN USING THE ABOVE FUNCTIONS. ERASE BURY UNDOES THE EFFECT OF
;;BURY. A LIST OF BURIED PROCEDURES IS KEPT AS :BURIED.
(DEFINE BURY FEXPR (TO-BE-BURIED)
(OR TO-BE-BURIED
(SETQ TO-BE-BURIED
(LIST (ERRBREAK 'BURY
'"BURY WHAT??"))))
(AND (EQ (CAR TO-BE-BURIED) 'ALL) (SETQ TO-BE-BURIED :CONTENTS))
(MAPC 'INTERNAL-BURY TO-BE-BURIED)
(CONS '/; (APPEND TO-BE-BURIED '(BURIED))))
(DEFUN INTERNAL-BURY (BURY-IT)
(COND ((MEMQ BURY-IT :BURIED))
((MEMQ BURY-IT :CONTENTS) (PUSH BURY-IT :BURIED))
(T (SETQ BURY-IT
(ERRBREAK 'BURY
(LIST BURY-IT
'"NOT FOUND")))
(INTERNAL-BURY BURY-IT))))
(DEFINE ERASEBURY (ABB ERB) FEXPR (UNCOVER)
(OR UNCOVER
(SETQ UNCOVER
(LIST (ERRBREAK 'ERASEBURY
'"ERASE BURY WHAT??? "))))
(AND (EQUAL UNCOVER '(ALL)) (SETQ UNCOVER :BURIED))
(MAPC 'INTERNAL-ERASE-BURY UNCOVER)
(CONS '/; (APPEND UNCOVER '(NO LONGER BURIED))))
(DEFUN INTERNAL-ERASE-BURY (UNBURY)
(OR (MEMQ UNBURY :BURIED)
(SETQ UNBURY (ERRBREAK 'ERASEBURY
(LIST UNBURY
'"NOT BURIED"))))
(SETQ :BURIED (DELETE UNBURY :BURIED)))
;;*PAGE
;;THE ONLY DIFFERENCE BETWEEN THESE TWO VERSIONS OF EDITLINE IS THAT FOR INTERNAL
;;USE, EDIT-LINE RETURNS PARSED LINE, FOR LOGO USER, EDITLINE DOES NOT.
(DEFINE EDITLINE (ABB EDL) (NUMBER) (EDIT-LINE NUMBER) NO-VALUE)
;; THIS VERSION OF EDIT-LINE PROVIDES TYPE CHECKING, PRINT OUT OF OLD LINE, ETC.
;;NOTE THAT FOR EDITING LINES, ALL THAT IS NECESSARY IS (SETQ OLD-LINE <UNPARSED
;;VERSION OF OLD LINE NUMBER>)
(DEFUN EDIT-LINE (NUMBER)
(DEFAULT-FUNCTION 'EDIT-LINE NIL)
(LET
((NUMBER (NUMBER? 'EDIT-LINE NUMBER))
(LAST-LINE)
(THIS-LINE)
(NEXT-TAG)
(PROMPTER '>))
(GETLINE PROG NUMBER)
(OR
THIS-LINE
(GETLINE
PROG
(SETQ NUMBER
(ERRBREAK 'EDIT-LINE
(LIST '"NO LINE NUMBERED "
NUMBER
'" IN "
FN)))))
(TYPE '";EDITING LINE "
NUMBER
'" OF "
FN)
(LET ((^W)
(^R)
(NEW-PARSE (REPAIR-LINE (UNPARSE-LOGO-LINE (CONS NUMBER THIS-LINE))))
(COPY))
(COND ((EQ (CAAR NEW-PARSE) 'INSERT-LINE)
(SETQ COPY (APPEND (CDDAR NEW-PARSE) NIL))
(EVALS NEW-PARSE)
COPY)
((TYPE '";LINE MUST BEGIN WITH A NUMBER"
EOL)
(EDIT-LINE NUMBER))))))
;;WHAT IS THE USER'S INTENTION IN TYPING A LINE STARTING WITH A NUMBER OTHER THAN HE
;;HANDED TO EDITLINE? DOES HE EXPECT OLD LINE NUMBER TO REMAIN? CLOGO & 11LOGO
;;RETAIN OLD NUMBERED LINE.
;;;
;;;
;;REPAIR-LINE TAKES AS INPUT A LINE OF TOKENS, FOR INSTANCE, AS WOULD BE SAVED IN
;;OLD-LINE. IT RETURNS A CORRECTLY PARSED LINE.
(DEFUN REPAIR-LINE (OLD-LINE)
(LET ((PROMPTER '>))
(DTERPRI)
(MAPC 'DPRINC OLD-LINE)
(DTERPRI)
(DPRINC PROMPTER)
(LOGOREAD)))
;;*PAGE
;;; LOGO EDITING CHARACTERS.
;;MAYBE A BETTER IMPLEMENTATION WOULD BE FOR THESE CHARS TO BE LINE-READMACROS WHICH
;;HAPPEN INSIDE THE LINE FUNCTION. THIS WILL ALLOW PROPER HANDLING OF INFIX MINUS
;;AS WELL AS RUBOUT. THE IMPLEMENTATION COULD BE THAT LINE CHECKS FOR A "LINEMACRO"
;;PROPERTY. IF IT FINDS ONE, THEN THE APPROPRIATE ACTION HAPPENS.
[ITS (DEFUN COVER-UP NIL
;;ON DISPLAY TERMINALS, MAKE CONTROL CHARACTERS DISAPPEAR.
(COND ((ZEROP TTY))
;;PRINTING TERMINALS OR ARDS'S LOSE.
((= TTY 4.))
(T (CURSORPOS 'X) (COND (SAIL) ((CURSORPOS 'X))))))]
[(OR ITS DEC10) (DEFUN CONTROL-P NIL
;;CONTROL-P DELETES LAST WORD -- POPS END OF NEW LINE.
[ITS (COVER-UP)]
(AND
LINE
(PROG (^W)
A (COND
((EQ (CAR LINE) '/ )
(COND [ITS ((MEMBER TTY '(1. 2. 3. 5.))
(CURSORPOS 'X))]
((DPRINC '/ )))
(POP LINE)
(GO A))
(T
(MAPC
(COND
[ITS ((MEMBER TTY '(1. 2. 3. 5.))
'(LAMBDA (X) (CURSORPOS 'X)))]
('DPRINC))
(NREVERSE (EXPLODEC (CAR LINE))))
(POP LINE))))))
(DEFUN CONTROL-N NIL
;; MOVE NEXT WORD FROM THE FRONT OF THE OLD LINE TO THE END
;;OF THE NEW LINE.
[ITS (COVER-UP)]
(DO NIL
((NOT (EQ (CAR OLD-LINE) '/ )) NIL)
(DPRINC '/ )
(PUSH '/ LINE)
(POP OLD-LINE))
(COND (OLD-LINE (DPRINC (CAR OLD-LINE))
(PUSH (CAR OLD-LINE) LINE)
(POP OLD-LINE)
(COND ((NULL OLD-LINE)
(DPRINC '/ )
(PUSH '/ LINE))
((EQ (CAR OLD-LINE) '/ )
(POP OLD-LINE)
(DPRINC '/ )
(PUSH '/ LINE))))))
(DEFUN CONTROL-R NIL
;;MOVE THE REST OF THE OLD LINE ON TO THE END OF THE NEW
;;LINE.
(IOC T)
[ITS (COVER-UP)]
(DO NIL
((NULL OLD-LINE)
(COND ((EQ (CAR LINE) '/ ))
((DPRINC '/ ) (PUSH '/ LINE)))
NIL)
(DPRINC (CAR OLD-LINE))
(PUSH (CAR OLD-LINE) LINE)
(POP OLD-LINE)))
(DEFUN CONTROL-S NIL
;;POP FRONT OF THE OLD LINE.
[ITS (COVER-UP)]
(DO NIL
((NOT (EQ (CAR OLD-LINE) '/ ))
(AND OLD-LINE (POP OLD-LINE))
NIL)
(POP OLD-LINE)))]
;;*PAGE