PDP-10.its/src/llogo/setup.306

;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;				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 DSK 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 DSK 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"))]