More LLOGO files.

src/llogo/declar.67

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