mirror of
https://github.com/PDP-10/its.git
synced 2026-01-30 13:36:42 +00:00
136 lines
6.0 KiB
Plaintext
136 lines
6.0 KiB
Plaintext
|
||
;;THIS FILE CONTAINS DECLARATIONS FOR ALL THE LISP LOGO PRIMITIVES.
|
||
;;GERMLAND, MUSIC BOX, TURTLE, AND TVRTLE PRIMITIVES ARE
|
||
;;INCLUDED.
|
||
|
||
(DECLARE (SETQ NFUNVARS T MUZZLED T CLOSED T MAPEX T IBASE 10.)
|
||
(ARRAY* (NOTYPE WHERE 1. LOOKLIKE 1. FOODSUPPLY 1.))
|
||
(FIXNUM REPEAT-COUNT)
|
||
(ARGS 'DISPLAY NIL)
|
||
;;PREVENT ARG CHECK ON LLOGO'S DISPLAY WHICH MIGHT BE DIFFERENT THAN LISP'S.
|
||
(*FEXPR BOTH CHORUS CHORUS2 CHORUS3 CHORUS4 COMPILE
|
||
DUMP EDITTITLE EITHER ENTERSNAP ERASE
|
||
ERASEFILE ERASETRACE GETSNAPS GETWINDOWS IFFALSE IFTRUE
|
||
INSERTLINE LINEPRINT LISPBREAK LISTFILE LISTINDEX
|
||
LOGIN LOGO-EDIT LOGOBREAK MAKTURTLE MAKETURTLE
|
||
PHOTO PICTURE PLOTTER PRINTOUT READFILE READLISP REPEAT RUNGERM
|
||
RESNAP SAVE
|
||
SAVESNAPS SAVEWINDOWS TITLE TO USE WRITE)
|
||
(*LEXPR BEARING BLINK BRIGHT DSCALE DISPLAYWINDOW EXIT ERRBREAK
|
||
FILLWINDOW FPRINT FPUT HIDEWINDOW INFIX JOIN
|
||
LOGO-PRINT LOGO-RANDOM LPUT MAKEWINDOW MBUFPUT MCLEAR MOTION
|
||
PENSTATE POINT POINTSTATE PRECEDENCE RANGE ROUNDOFF SCALE SENTENCE
|
||
SETHOME SHADE SHOWWINDOW STARTDISPLAY TOWARDS
|
||
TURTLESIZE TVSIZE TYPE UNBLINK
|
||
XORWINDOW WINDOWFRAME WINDOWHOME WIPE WORD)
|
||
(*EXPR :MAX ABBREVIATE ALLOCATOR ARC ASK ATANGENT BACK
|
||
BELL BLANK BOOM BRUSH BUTFIRST BUTLAST
|
||
CARRIAGERETURN CLEARSCREEN CLOCK CONTENTS CONTENTSP
|
||
CONTINUE COSINE COUNT DATE DAYTIME DELX DELXY DELY
|
||
DIALS DIRNAME DISPAGE DRUM EDITLINE EMPTYP EMPTYWP
|
||
ENDSNAP ERASEABB ERASEALL ERASELINE ERASENAMES
|
||
ERASEPRIM ERASEPROCEDURES FIRST FORWARD
|
||
FRAMEUP GRITCH HEADING HERE HIDE HIDESNAP HIDETEXT
|
||
HIDETURTLE HOMCHECK HOME HOMESTATE INITMUSIC INTEGER ISABOUT LEFT LINE
|
||
LINEFEED LISP LISTABBREVIATIONS LISTALL
|
||
LISTCONTENTS LISTLINE LISTNAMES LISTP
|
||
LISTPRIMITIVES LISTPROCEDURES LISTTITLE LOGNAME
|
||
LOGO-LAST LOGOUT MAKETUNE MARK MBUFCLEAR
|
||
MBUFCOUNT MBUFINIT MBUFNEXT MBUFOUT MLEN MODMUSIC
|
||
NEWMUSIC NODISPLAY NOMUSIC NOPLOT NOTE NOWRAP
|
||
NVOICES OLDMUSIC OLDTURTLE PARSE PARSER
|
||
PENDOWN PENP PENUP PERFORM PLAYTUNE PM
|
||
PRETTY PRIMITIVEP PUSHCONTENTS READOB REMSNAP
|
||
REMTEXT REQUEST RESET REST RESTARTMUSIC RIGHT RUN
|
||
SENTENCEP SETHEAD SETTURTLE SETX SETXY SETY SHOW
|
||
SHOWCLOCK SHOWSNAP SHOWTEXT SHOWTURTLE SINE SING
|
||
SONG STARTMUSIC TEST THING THINGP
|
||
TURTLESTATE UNITE VERSION VLEN VOICE VOICES WIPE
|
||
WIPECLEAN WORDP WRAP XCOR XHOME YCOR YHOME)
|
||
|
||
;; SOME LLOGO PRIMITIVES MUST BE HANDLED SPECIALLY, SINCE JUST
|
||
;;COMPILING CALLS TO THEM WILL NOT WORK. IN PARTICULAR, ANYTHING
|
||
;;WHICH DOES A RETURN MUST BE REPLACED, AS THE PROG WILL BE GONE
|
||
;;WHEN THE FUNCTION IS COMPILED. NOTE THE LACK OF
|
||
;;*EXPR DECLARATION FOR GO. GO'S AND RETURN'S OUT OF
|
||
;;IFTRUE'S AND IFFALSE'S WILL NOT WORK UNLESS REPLACED BY AND'S
|
||
;;AND OR'S WHICH COMPILER UNDERSTANDS. CALLS TO LOCAL, USER-PAREN,
|
||
;;AND LOGO-COMMENT ARE USELESS, AND ARE DISPOSED OF.
|
||
|
||
(DEFUN END MACRO (CALL) '(RETURN '?))
|
||
(DEFUN STOP MACRO (CALL) '(RETURN '?))
|
||
(DEFUN IFTRUE MACRO (CALL)
|
||
(RPLACA CALL 'COND)
|
||
(RPLACD CALL (NCONS (CONS 'TESTFLAG (CDR CALL)))))
|
||
(DEFUN IFFALSE MACRO (CALL)
|
||
(RPLACA CALL 'COND)
|
||
(RPLACD CALL (LIST '(TESTFLAG) (CONS T (CDR CALL)))))
|
||
(DEFUN BOTH MACRO (CALL) (RPLACA CALL 'AND))
|
||
(DEFUN EITHER MACRO (CALL) (RPLACA CALL 'OR))
|
||
(DEFUN OUTPUT MACRO (CALL)
|
||
(RPLACA CALL 'RETURN))
|
||
(DEFUN LOCAL MACRO (CALL) NIL)
|
||
(DEFUN LOGO-COMMENT MACRO (CALL) NIL)
|
||
(DEFUN USER-PAREN MACRO (CALL) (CADR CALL))
|
||
(DEFUN DOUBLE-QUOTE MACRO (CALL) (RPLACA CALL 'QUOTE))
|
||
(DEFUN SQUARE-BRACKETS MACRO (CALL) (RPLACA CALL 'QUOTE))
|
||
(DEFUN INFIX-PLUS MACRO (CALL) (RPLACA CALL 'PLUS))
|
||
(DEFUN INFIX-DIFFERENCE MACRO (CALL) (RPLACA CALL 'DIFFERENCE))
|
||
(DEFUN INFIX-TIMES MACRO (CALL) (RPLACA CALL 'TIMES))
|
||
(DEFUN INFIX-QUOTIENT MACRO (CALL) (RPLACA CALL 'QUOTIENT))
|
||
(DEFUN INFIX-REMAINDER MACRO (CALL) (RPLACA CALL 'REMAINDER))
|
||
(DEFUN INFIX-EQUAL MACRO (CALL) (RPLACA CALL 'EQUAL))
|
||
(DEFUN INFIX-LESSP MACRO (CALL) (RPLACA CALL 'LESSP))
|
||
(DEFUN INFIX-GREATERP MACRO (CALL) (RPLACA CALL 'GREATERP))
|
||
(DEFUN INFIX-EXPT MACRO (CALL) (RPLACA CALL 'EXPT))
|
||
(DEFUN PREFIX-PLUS MACRO (CALL) (CADR CALL))
|
||
(DEFUN PREFIX-MINUS MACRO (CALL) (RPLACA CALL 'MINUS))
|
||
(DEFUN INFIX-MAKE MACRO (CALL) (RPLACA CALL 'MAKE))
|
||
(DEFUN MAKEQ MACRO (CALL) (RPLACA CALL 'SETQ)
|
||
(RPLACD CALL
|
||
(CONS (IMPLODE (CONS ': (EXPLODEC (CADR CALL))))
|
||
(CDDR CALL))))
|
||
;;ELIMINATE THE EXPLODE THAT MAKE HAS TO DO.
|
||
(DEFUN MAKE MACRO (CALL)
|
||
(COND ((OR (ATOM (CADR CALL)) (NOT (MEMQ (CAADR CALL) '(QUOTE DOUBLE-QUOTE))))
|
||
(RPLACA CALL 'SET)
|
||
(RPLACD CALL
|
||
(CONS (SUBST (CADR CALL)
|
||
'NAME
|
||
'(IMPLODE (CONS ': (EXPLODEC NAME))))
|
||
(CDDR CALL))))
|
||
(T (RPLACA (CDR CALL) (IMPLODE (CONS ': (EXPLODEC (CADADR CALL)))))
|
||
(RPLACA CALL 'SETQ))))
|
||
|
||
|
||
;; Compilation macros for open coding iteration loops.
|
||
|
||
(DEFUN REPEAT MACRO (CALL)
|
||
(SUBLIS (LIST (CONS 'REPEAT-ITERATIONS (CADR CALL))
|
||
(CONS 'REPEAT-BODY (NEW-BODY (CDDR CALL))))
|
||
'(DO ((REPEAT-COUNT 1. (1+ REPEAT-COUNT))
|
||
(LOOP-VALUE '?))
|
||
((> REPEAT-COUNT REPEAT-ITERATIONS) LOOP-VALUE)
|
||
. REPEAT-BODY)))
|
||
|
||
(DEFUN NEW-BODY (OLD-BODY)
|
||
(DO ((NEW-BODY))
|
||
((NULL (CDR OLD-BODY))
|
||
(NREVERSE (CONS (LIST 'SETQ 'LOOP-VALUE (CAR OLD-BODY)) NEW-BODY)))
|
||
(SETQ NEW-BODY (CONS (CAR OLD-BODY) NEW-BODY) OLD-BODY (CDR OLD-BODY))))
|
||
|
||
(DEFUN WHILE MACRO (CALL)
|
||
(SUBLIS (LIST (CONS 'WHILE-CONTINUE-CONDITION (CADR CALL))
|
||
(CONS 'WHILE-BODY (NEW-BODY (CDDR CALL))))
|
||
'(DO ((LOOP-VALUE '?)) ((NOT WHILE-CONTINUE-CONDITION) LOOP-VALUE) . WHILE-BODY)))
|
||
|
||
(DEFUN UNTIL MACRO (CALL)
|
||
(SUBLIS (LIST (CONS 'UNTIL-STOP-CONDITION (CADR CALL))
|
||
(CONS 'UNTIL-BODY (NEW-BODY (CDDR CALL))))
|
||
'(DO ((LOOP-VALUE '?)) (UNTIL-STOP-CONDITION LOOP-VALUE) . UNTIL-BODY)))
|
||
|
||
(DEFUN FOREVER MACRO (CALL)
|
||
(SUBST (CDR CALL) 'FOREVER-BODY '(DO NIL (NIL) . FOREVER-BODY)))
|
||
|
||
)
|
||
|