;; -*- Fonts: CPTFONT;  Mode:Lisp;  Package: BOXER -*-

;;; (C) Copyright 1985 Massachusetts Institute of Technology
;;;
;;; Permission to use, copy, modify, distribute, and sell this software
;;; and its documentation for any purpose is hereby granted without fee,
;;; provided that the above copyright notice appear in all copies and that
;;; both that copyright notice and this permission notice appear in
;;; supporting documentation, and that the name of M.I.T. not be used in
;;; advertising or publicity pertaining to distribution of the software
;;; without specific, written prior permission.  M.I.T. makes no
;;; representations about the suitability of this software for any
;;; purpose.  It is provided "as is" without express or implied warranty.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;								         ;;;
;;; A "Pratt Parser" for BOXER, by Leigh Klotz. (KLOTZ@MIT-MC)   	 ;;;
;;; Modeled after the VAX NIL parser, by George Carrette (GJC@MIT-MC)    ;;;
;;;                                                                      ;;;
;;;	Based on a theory of parsing presented in:                       ;;;
;;;                                                                      ;;;
;;;	    Pratt, Vaughan R., ``Top Down Operator Precedence,''         ;;;
;;;	    ACM Symposium on Principles of Programming Languages         ;;;
;;;	    Boston, MA; October, 1973.                                   ;;;
;;;                                                                      ;;;
;;; The PARSE function takes a list describing BOXER code, and returns   ;;;
;;; a list suitable for EVAL.                                            ;;;
;;; Two optional arguments specify symbols that should be considered     ;;;
;;; variables or procedures, but are not currently bound to the proper   ;;;
;;; object.                                                              ;;;
;;;                                                                      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;Special variables for the token stuff.
;Has to be a symbol so we can put a rbp property on it.
;It has to be in the boxer package to keep from confusing it
;with something in the bu package.
(DEFCONST *END-OF-LINE* '*END-OF-LINE*)

(DEFVAR *CURRENT-TOKEN*)
(DEFVAR *PRATT-PEEK-TOKEN?*)
(DEFVAR *PRATT-READ-LIST*)
(DEFVAR *TOKEN-TYPE*)

(DEFVAR *OP*)
(DEFVAR *SYMBOLS-TO-BE-CONSIDERED-VARIABLES-IN-PARSING*)
(DEFVAR *SYMBOLS-TO-BE-CONSIDERED-PROCEDURES-IN-PARSING*)
(DEFVAR *SYMBOLS-IN-ARGLIST*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Low-Level and setup stuff.
;;;

(DEFSUBST COERCE-NUMBER-TO-BOX (NUMBER)
  (MAKE-INSTANCE 'DATA-BOX ':FIRST-INFERIOR-ROW (MAKE-ROW (NCONS NUMBER))))

;The functions for getting the tokens from the input list, one-at-a-time.
(DEFUN READ-TOKEN ()
  (IF *PRATT-READ-LIST*
      (SETQ *CURRENT-TOKEN* (POP *PRATT-READ-LIST*))
      (SETQ *CURRENT-TOKEN* *END-OF-LINE*))
  ;; get rid of number here for now (probably the wrong place to do it)
  (WHEN (NUMBERP *CURRENT-TOKEN*)
    (SETQ *CURRENT-TOKEN* (COERCE-NUMBER-TO-BOX *CURRENT-TOKEN*)))

  *CURRENT-TOKEN*)


(DEFUN PRATT-READ-REST-OF-LINE ()
  (IF *PRATT-PEEK-TOKEN?*
      (CONS *CURRENT-TOKEN*
	    (PROG1 *PRATT-READ-LIST*
		   (SETQ *PRATT-READ-LIST* NIL
			 *PRATT-PEEK-TOKEN?* NIL)))
      (PROG1 *PRATT-READ-LIST*
	     (SETQ *PRATT-READ-LIST* NIL))))

(DEFUN PRATT-PEEK-TOKEN ()
  (IF *PRATT-PEEK-TOKEN?*
      *CURRENT-TOKEN*
      (SETQ *PRATT-PEEK-TOKEN?* T)
      (READ-TOKEN)))

(DEFUN PRATT-READ-TOKEN ()
  (COND (*PRATT-PEEK-TOKEN?*
	 (SETQ *PRATT-PEEK-TOKEN?* NIL)
	 *CURRENT-TOKEN*)
	(T (READ-TOKEN))))

(DEFUN PRATT-READ-TOKEN-NO-EOL ()
  (LET ((RESULT (PRATT-READ-TOKEN)))
    (IF (EQ RESULT *END-OF-LINE*)
	(PARSER-BARF "Not enough stuff on line.")
	RESULT)))


;;; Code generators.

;This reminds me of writing APPLY in Logo.
(defun ENSHROUD-BOX-OR-VARIABLE (it)
  (cond ((box? it) (list 'quote it))
	((symbolp it) (boxer-variable-reference it))
	(t it)))

(defun boxer-variable-reference (symbol)
  `(boxer-symeval ',symbol))

(defun extract-entry (thing)
  (if (label-pair? thing) (label-pair-element thing) thing))

(defun parser-token-type (lex)
  (cond ((label-pair? lex) 'LABEL-PAIR)
	((numberp lex) 'NUMBER)
	((access-pair? lex) 'ACCESS-PAIR)
	(t (or (cdr (assq (typep lex)
			  '((:symbol . symbol)
			    (:string . string)
			    (data-box . data-box)
			    (port-box . port-box)
			    (doit-box . doit-box)
			    (sprite-box . sprite-box)
			    (GRAPHICS-BOX . GRAPHICS-BOX)
			    (GRAPHICS-data-BOX . GRAPHICS-data-BOX))))
	       (ferror nil "~S -- Unknown type in parser." lex)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The top-level parsing function.  Given a list describing a boxer expression,
;;; it returns a list suitable for EVAL.  The caller should take this list
;;; and do one of several things, like eval it, wrap a lambda around it,
;;; or glom it together with some other ones in a PROGN.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun parse (exp &optional (variables nil) (procedures nil) (inputs nil))
  (if (null exp) nil
      (let ((*pratt-read-list* (SUBSET-NOT #'NAMED-BOX-P exp))
	    (*current-token*)
	    (*PRATT-PEEK-TOKEN?*)
	    (*OP* "Something")		  ;crock for now...
	    (*SYMBOLS-TO-BE-CONSIDERED-VARIABLES-IN-PARSING* variables)
	    (*SYMBOLS-TO-BE-CONSIDERED-PROCEDURES-IN-PARSING* procedures)
	    (*SYMBOLS-IN-ARGLIST* inputs))
	(pratt-parse 0))))

;;; NUD -- NUll left Denotation (op has nothing to its left (prefix))
;;; LED -- LEft Denotation	(op has something to left (postfix or infix))
;;;
;;; LBP -- Left Binding Power  (the stickiness to the left)
;;; RBP -- Right Binding Power (the stickiness to the right)

;;; (PRATT-PARSE <rbp>)
;;;
;;;  This will parse an expression containing operators which have a higher
;;;  left binding power than <rbp>, returning as soon as an operator of
;;;  lesser or equal binding power is seen.

;note that the error reporting depends on the special variable *OP*...
(DEFUN PRATT-PARSE (RBP)
  (LET ((RESULT (PRATT-PARSE-ALLOW-EOL RBP)))
    (IF (EQ RESULT *END-OF-LINE*) (PARSER-BARF "~A needs more inputs." *OP*)
	RESULT)))

(DEFUN PRATT-PARSE-ALLOW-EOL (RBP)
  (DO ((EXPRESSION (PRATT-NUD-CALL (PRATT-READ-TOKEN) (parser-token-type *current-token*))
		   (PRATT-LED-CALL (PRATT-READ-TOKEN) (parser-token-type *current-token*)
				   EXPRESSION)))
      ((>= RBP (PRATT-LBP (PRATT-PEEK-TOKEN) (parser-token-type (pratt-peek-token))))
       EXPRESSION)))

(DEFUN PRATT-NUD-CALL (LEX TYP)
  (funcall (OR (get typ 'NUD-TYPE-HANDLER)
	       #'(LAMBDA (U) (FERROR "~S unknown datatype in parsing." U)))
	   LEX))

(DEFUN PRATT-LED-CALL (LEX TYP EXP)
  (LET ((F (AND (EQ TYP 'SYMBOL) (GET LEX 'LED))))
    (IF F (FUNCALL F LEX EXP)
	(if (eq (car exp) 'boxer-symeval)
	    (PARSER-BARF "/~A/ is not a defined procedure."
			 (cadr (cadr exp)))	;extracts variable reference. crock.
	    (parser-barf "Too many commands on one line, just before ~A" lex)
;;	      (parser-barf "/"~A/" is not an infix operator." lex)
	    ))))


;If a function has no precedence, then it's assumed to be less than
;the lowest infix function.
(DEFUN PRATT-BP (LEX TYP P)
  (or (and (eq typ 'symbol)
	   (get lex p))
      50))
  
(DEFUN PRATT-LBP (LEX &OPTIONAL (TYP 'SYMBOL))
    (PRATT-BP LEX TYP 'LBP))
  
(DEFUN PRATT-RBP (LEX &OPTIONAL (TYP 'SYMBOL))
    (PRATT-BP LEX TYP 'RBP))
  
(defun end-of-line-fun (*op*)
  *op*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Things for dealing with different funny datatypes in the prefix position.
;;; Funcalled by PRATT-NUD-CALL.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  
;;;This function is nonstandard, in that it understands what to
;;;do with special boxer datatypes.  If the symbol is on the
;;;lambda-list of the currently-being-parsed box, then it is not
;;;special and is a variable.
;;;
;;;Otherwise, If the token is a sumbol and it has a NUD
;;;property, then this NUD property is funcalled with the
;;;current-token as input.  That's for parsing infix and special
;;;forms.
(DEFUN (:PROPERTY SYMBOL NUD-TYPE-HANDLER) (LEX)
  (LET ((PARSING-FUN (GET LEX 'NUD))	;Special form property.
	(NARGS (PARSER-PROCEDURE-SYMBOL-DESCRIPTOR-NUMBER-OF-ARGS
		 (ASSQ LEX *SYMBOLS-TO-BE-CONSIDERED-PROCEDURES-IN-PARSING*))))
    (COND ((OR (MEMQ LEX *SYMBOLS-IN-ARGLIST*)
	       (ASSQ LEX *SYMBOLS-TO-BE-CONSIDERED-VARIABLES-IN-PARSING*))
	   (BOXER-VARIABLE-REFERENCE LEX))	 ;It's definitely a varible.
	  ((NUMBERP NARGS) (PRATT-PARSE-MULTIPREFIX LEX NARGS))	;It's certainly a function.
	  (parsing-fun (FUNCALL parsing-fun LEX))	;Special form
	  ((BOXER-FDEFINED? LEX)	     ;It's a currently-defined function
	   (PRATT-PARSE-MULTIPREFIX LEX (PARSER-NUMBER-OF-ARGS LEX)))
	  ((sprite-box? (boxer-symeval lex))
	   (list 'quote (port-to-internal (boxer-symeval lex))))
	  (T (BOXER-VARIABLE-REFERENCE LEX)))))  ;Must be a variable or undefined function

;;;If it's a data-box, then it parses into 'BOX.  Self-evaling
;;;things (numbers, strings) parse into themseves.  Other things
;;;are probably broken anyway.
;;;
;;;Things which are currently-defined functions are parsed as
;;;multiple-input prefix functions according to the number of
;;;inputs they have.

(DEFUN (:PROPERTY NUMBER NUD-TYPE-HANDLER) (LEX)
  LEX)

(DEFUN (:PROPERTY STRING NUD-TYPE-HANDLER) (LEX)
  LEX)

(DEFUN (:PROPERTY GRAPHICS-BOX NUD-TYPE-HANDLER) (LEX)
  (LIST 'QUOTE LEX))

(DEFUN (:PROPERTY DATA-BOX NUD-TYPE-HANDLER) (LEX)
 (LIST 'QUOTE LEX))

(DEFUN (:PROPERTY graphics-DATA-BOX NUD-TYPE-HANDLER) (LEX)
 (LIST 'QUOTE LEX))

(defun (:property sprite-box nud-type-handler) (lex)
  (list 'quote (port-to-internal lex)))

(DEFUN (:PROPERTY DOIT-BOX NUD-TYPE-HANDLER) (LEX)
  (PRATT-PARSE-MULTIPREFIX LEX (PARSER-NUMBER-OF-ARGS LEX)))

(defun (:property port-box nud-type-handler) (lex)
  (let ((obj (tell lex :ports)))
    (cond ((data-box? obj) (list 'quote lex))
	  ((doit-box? obj) (pratt-parse-multiprefix lex (parser-number-of-args obj)))
	  ((GRAPHICS-BOX? OBJ) (list 'quote lex))
	  ((sprite-box? obj) (list 'quote obj))
	  ((graphics-data-box? obj) (list 'quote lex))
	  (t (ferror "Tried to parse a reference to a port which wasn't a port to a doit
or data box: ~S" lex)))))

(DEFUN (:PROPERTY LABEL-PAIR NUD-TYPE-HANDLER) (LEX)
 (PRATT-NUD-CALL (LABEL-PAIR-ELEMENT LEX)
		 (PARSER-TOKEN-TYPE (LABEL-PAIR-ELEMENT LEX))))

;This is a crock.  These things shouldn't be put in procedure lambdas,
;but should be parsed when doit'd explcitly.  There's no way to tell,
;though.  We really need some other way of doing initial variable assignment.
;(defun (:property NAME-PAIR NUD-TYPE-HANDLER) (lex)
;  (let ((name (name-pair-name lex))
;	(val (name-pair-element lex)))
;    (if (box? val) (tell val :set-name name))
;    `(PROGN
;       (BOXER-MAKE ',name
;		   ',val)
;       ':NOPRINT)))



;;And if you think THAT was a crock...

;(defun (:property ACCESS-PAIR NUD-TYPE-HANDLER)(lex)
;  (let* ((superbox (access-pair-superbox lex))
;	 (subbox (access-pair-subbox lex)))
;    `(progn 
;       (boxer-tell (boxer-eval ',superbox)
;		   (let ((eval-subbox (caar (get-pre-box-rows (boxer-eval ',subbox)))))
;		     `(,eval-subbox))))))



;;; Parsing functions for various pieces of syntax.


;;; (PRATT-PARSE-MULTIPREFIX <*OP*> <nargs>)
;;; Parses prefix forms with multiple args -- e.g, REMAINDER 2 3
;;;
;;; This is the default parsing property for symbols.  It fires after any
;;; symbol currently defined as a function has been seen.  It parses
;;; forward looking for NARGS more expressions according to its right binding
;;; power, returning a proper boxer-funcall expression.

(defun pratt-parse-multiprefix (*OP* nargs)
  (LIST* 'BOXER-FUNCALL
	 (ENSHROUD-BOX-OR-VARIABLE *OP*)
	;; Get nargs args.
	(let ((rbp (PRATT-RBP *OP*)))
	  (do ((args nil (cons (LET ((IT (PRATT-PARSE rbp)))
				 (IF (EQ *END-OF-LINE* IT)
				     (PARSER-BARF "~A needs more inputs." *OP*)
				     (ENSHROUD-BOX-OR-VARIABLE it)))
			       args))
	       (nargs nargs (1- nargs)))
	      ((zerop nargs) (nreverse args))))))


;;; (PRATT-PARSE-PREFIX <*OP*>)
;;;
;;;  Parses prefix forms -- eg, - X or + X.
;;;
;;;  This should be the NUD property on an operator. It fires after <op>
;;;  has been seen. It parses forward looking for one more expression
;;;  according to its right binding power, returning (<*OP*> <arg1>).

(DEFUN PRATT-PARSE-PREFIX (*OP*)
  (LIST 'BOXER-FUNCALL
	(ENSHROUD-BOX-OR-VARIABLE *OP*)
	;; Convert single argument for use
	(ENSHROUD-BOX-OR-VARIABLE (PRATT-PARSE (PRATT-RBP *OP*)))))


;;; (PRATT-PARSE-POSTFIX <*OP*> <left>)
;;;
;;;  Parses postfix forms. eg, X !.
;;;
;;;  This should be the LED property of an operator. It fires after <left>
;;;  has been accumulated and <op> has been seen and gobbled up. It returns
;;;  (<*OP*> <arg1>).

(DEFUN PRATT-PARSE-POSTFIX (*OP* left)
  (LIST
    'BOXER-FUNCALL
    (ENSHROUD-BOX-OR-VARIABLE *OP*)
    left))

;;; (PRATT-PARSE-INFIX <*OP*> <left>)
;;;
;;;  Parses infix (non-nary) forms. eg, 5 mod 3.
;;;  For things like +, see PRATT-PARSE-NARY.
;;;
;;;  This should be the led property of an operator. It fires after <left>
;;;  has been accumulated and <*OP*> has been seen and gobbled up.

(DEFUN PRATT-PARSE-INFIX (*OP* arg1)
  (LIST
   'BOXER-FUNCALL
    *OP*
    ARG1
    ;; Look for an arg2 
    (ENSHROUD-BOX-OR-VARIABLE (PRATT-PARSE (PRATT-RBP *OP*)))))

;;; (PRATT-PARSE-NARY <*OP*> <left>)
;;;
;;;  Parses nary forms. Eg, form1*form2*... or form1+form2+...
;;;  This should be the LED property on an operator. It fires after <op>
;;;  has been seen, accumulating and returning
;;;  (<*OP*> <arg1> <arg2> ...).
;;;
;;;  <*OP*>   is the being parsed.
;;;  <left> is the stuff that has been seen to the left of <*OP*> which 
;;;         rightly belongs to <*OP*> on the basis of parse precedence rules.

(DEFUN PRATT-PARSE-NARY (*OP* L)
  (LIST* 'BOXER-FUNCALL
	 *OP*
	 (ENSHROUD-BOX-OR-VARIABLE L)
	 ;; Search for other args
	 (PRATT-PARSE-NARY-SUB *OP* (PRATT-LBP *OP*))))

;;; (PRATT-PARSE-NARY-SUB <*OP*> <rbp>)
;;;
;;;  Parses an nary operator tail E.G., ...form2+form3+... or ...form2*form3*..
;;;
;;;  Expects to be entered after the leading form and the first call to an 
;;;  nary operator has been seen and popped. Returns a list of parsed forms
;;;  which belong to that operator. Eg, for X+Y+Z; this should be called 
;;;  after the first + is popped. Returns (Y Z).
;;;
;;;  <*OP*>   is the nary operator in question.
;;;  <rbp>  is (LBP <*OP*>) and is provided for efficiency. It is for use in
;;;	     recursive parses as a binding power to parse for.

(DEFUN PRATT-PARSE-NARY-SUB (*OP* RBP)
  (DO ((NL (LIST (PRATT-PARSE RBP))	   ;Get at least one form
	   (CONS (PRATT-PARSE RBP) NL)))   ;and keep getting forms
      ((NOT (EQ *OP* (PRATT-PEEK-TOKEN)))  ;until a parse pops on a new op
       (NREVERSE NL))			   ;at which time return forms
      (PRATT-READ-TOKEN)))          	   ;otherwise pop *OP*


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Boxer Special Form parser
;;; It's like DEFUN, but the special arg declarations are in lists instead
;;; of being flattened out -- for example:
;;; (defboxer-macro set ((&quote variable) value)
;;;   `(progn
;;;      (boxer-set ',variable ,value)
;;;      ':NOPRINT))
;;; There are subtlties about &quote and also about whether you put a quote before
;;; a comma.

(defmacro defboxer-special (name arglist &body body)
  (let* ((argnames (mapcar #'(lambda (entry)
			       (if (symbolp entry)
				   entry
				   (cadr entry)))
			   arglist))
	 (bu-name (intern-in-bu-package name))
	 (values (mapcar #'(lambda (entry)
			   (if (symbolp entry)
			       '(pratt-parse (pratt-rbp *OP*))
			       (selectq (car entry)
				 (&quote  '(extract-entry (pratt-read-token-no-eol)))
				 (&rest '(pratt-read-rest-of-line))
				 (otherwise (ferror
					      "Bad arglist element in DEFBOXER-SPECIAL ~S"
					      entry)))))
		       arglist)))
    `(progn 'compile
	    (putprop ',bu-name ',argnames 'arglist)
	    (defun (:property ,bu-name nud) (*op*)
	      (let ,(mapcar #'list argnames values)
		.,body)))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers for special forms.
;;; These functions are on the Null Left Denotation property of the function
;;; name.  They get one argument, which is the name of the function (for
;;; functions that want to handle multiple ones.)  They should return some
;;; eval-able lisp code.
;;;
;;; This stuff should be replaced with a macro that takes a function name
;;; and an arglist and does the right thing.


;;;REPEAT 3 <box or form>

(defboxer-special repeat (times stuff)
  `(catch 'iteration-tag
     (dotimes (repeat-times (NUMBERIZE ,TIMES))
       ,stuff)))


;;;IF BOX BOX
;;;IF BOX BOX BOX

(defprop bu:if (PREDICATE CONSEQUENT ALTERNATIVE) ARGLIST)
(defun (:property BU:IF nud) (*OP*)
  (let ((predicate (pratt-parse (pratt-rbp *OP*)))
	(consequent (pratt-parse (pratt-rbp *OP*))))
    (if (eq (pratt-peek-token) *end-of-line*)
	`(COND ((TRUE? ,predicate) ,consequent))
	`(COND ((TRUE? ,predicate) ,consequent)
	       (t ,(pratt-parse (pratt-rbp *OP*)))))))


;;;TELL BOX DOITBOX
;;;=> (boxer-tell 'box '(list of elements on rest of line))
;;;or (boxer-tell-rowlist 'box '(list of rows))
;this parsing isn't quite right
(defboxer-special tell (who (&rest what))
    (if (and (null (cdr what))
	     (doit-box? (car what)))
	`(boxer-tell-rowlist ,who
			 ',(tell (car what) :rows))
	`(boxer-tell ,who ',what)))

;;;; A real quick one here 

(defboxer-special tell-all (whos (&rest what))
  (if (and (null (cdr what))
	   (doit-box? (car what)))
      `(loop for box in (subset #'box? (tell ,whos :elements))
	     do (boxer-tell-rowlist box ',(tell (car what) :rows)))
      `(loop for box in (subset #'box? (tell ,whos :elements))
	     do (boxer-tell box ',what))))

;;;DEFINE-INSIDE-BOX
;; Actually, TELL should take care of this special form, but for reasons that
;; are momentarily unclear, it doesn't. This procedure allows you to create
;; a binding inside another box, as in 
;; DEFINE-INSIDE-BOX FOO NEW-FOO-PROC <doit-box>.
;; Perhaps the result of such a call should be that the new binding is actually
;; displayed somewhere inside FOO (as in, at least, the local library of FOO).
;; Right now, this doesn't happen -- so use this at your own risk.
(defboxer-special define-inside-box (box (&quote name)(&quote value))
  `(tell ,box :add-static-variable-pair ',name ',value))

;;;SET x 3
;;;SET does searching.
(defboxer-special set ((&quote variable) value)
  `(progn
     (boxer-set ',variable ,value)
     ':NOPRINT))


;;;MAKE X box
;;;Make always affects the current box environment.  If there's no variable
;;;named X, it adds one.  If there's nothing running (i.e. toplevel inside
;;;a box) it adds it permanently, otherwise it adds it to the copy.
(defboxer-special make ((&quote variable) value)
  `(progn
     (boxer-make ',variable
		 ,value)
     ':noprint))

;;;FILE is like MAKE, but doesn't eval the second arg.
;;;FILE X box
(defboxer-special file ((&quote variable) (&quote value))
  `(PROGN 
     (boxer-make ',variable
		 ',value)
     ':noprint))

;;;TEXT name-or-box
(defboxer-special text ((&quote box-or-name))
  `(datafy ,(cond ((box? box-or-name)
		   (LIST 'QUOTE box-or-name))
		 ((symbolp box-or-name)
		  (LIST 'QUOTE (BOXER-SYMEVAL box-or-name)))
		 (t (parser-barf "TEXT doesn't like ~A as input.  It expects a doit-box or the name of a doit-box." box-or-name)))))

;;; STOP
;;; This isn't quite worked out yet.

(defboxer-special stop ()
  `(throw 'iteration-tag ':NOPRINT))

(defboxer-special return (value)
  `(throw 'iteration-tag ,value))

;;;The Local Library might have an INPUT/INPUTS line in it, and it doesn't go through
;;;;parse-code-into-lambda which excises the inputs line before parsing the
;;;;whole thing (as a speed hack).

(defboxer-special input ((&rest ignore))
  '':NOPRINT)

(defboxer-special inputs ((&rest ignore))
  '':NOPRINT)

;;Exporting variables
(DEFBOXER-FUNCTION BU:SHOW-EXPORTS (BOX)
  (LET ((EXPORTING-VARS (TELL BOX :GET-EXPORTS)))
    (IF (NULL EXPORTING-VARS)
	(MAKE-BOX ())
	(MAKE-BOX (MAPCAR #'NCONS EXPORTING-VARS)))))

(DEFBOXER-FUNCTION BU:EXPORT-ALL (BOX)
  (TELL BOX :EXPORT-ALL-VARIABLES))

(DEFBOXER-SPECIAL BU:EXPORT ((&QUOTE VARIABLE) BOX)
  `(PROGN (TELL ,BOX :EXPORT-VARIABLE ',VARIABLE) ':NOPRINT))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Setup stuff.  This function should be made readable.
;;;

(DEFUN ENTER-PRATT-OP (OP &REST P)
  (LET (LBP RBP)
    (do ((list p (cddr list)))
	((null list))
	(LET ((K (car list))
	      (v (cadr list)))
	  (COND ((EQ K 'LBP)
		 (SETQ LBP V))
		((EQ K 'RBP)
		 (SETQ RBP V))
		('ELSE
		 (PUTPROP OP
			  (IF (AND (MEMQ K '(NUL LED))
				   (SYMBOLP V))
			      (FSYMEVAL V)
			      V)
			  K)))))
      (LET ((EXISTING-LBP (GET OP 'LBP))
	    (EXISTING-RBP (GET OP 'RBP)))
	   (COND ((NOT LBP)
		  (COMMENT IGNORE OMITTED ARG))
		 ((NOT EXISTING-LBP)
		  (SETF (GET OP 'LBP) LBP))
		 ((NOT (EQUAL EXISTING-LBP LBP))
		  (FERROR "Incompatible LBP's defined for ~S operator" OP)))
	   (COND ((NOT RBP)
		  (COMMENT IGNORE OMITTED ARG))
		 ((NOT EXISTING-RBP)
		  (SETF (GET OP 'RBP) RBP))
		 ((NOT (EQUAL EXISTING-RBP RBP))
		  (FERROR "Incompatible RBP's defined for ~S operator"
			 OP))))))

(EVAL-WHEN (LOAD EVAL)
(MAPC #'(LAMBDA (L)
	  (APPLY #'ENTER-PRATT-OP L))
      '((BU:|^| LED PRATT-PARSE-INFIX
	     LBP 140.
	     RBP 139.)
	(BU:|*| LED PRATT-PARSE-NARY
	     LBP 120.)
	(BU:|//| LED PRATT-PARSE-INFIX
	      LBP 120.
	      RBP 120.)
	(BU:|+| NUD PRATT-PARSE-PREFIX
	     LBP 100.
	     RBP 100.
	     LED PRATT-PARSE-NARY)
	(BU:|-| NUD PRATT-PARSE-PREFIX
	     LBP 100.
	     RBP 134.
	     LED PRATT-PARSE-NARY)
	(BU:|=| LED PRATT-PARSE-INFIX
	     LBP 80.
	     RBP 80.)
	(BU:|>| LED PRATT-PARSE-INFIX
	     LBP 80.
	     RBP 80.)
	(BU:|>=| LED PRATT-PARSE-INFIX
	      LBP 80.
	      RBP 80.)
	(BU:|| LED PRATT-PARSE-INFIX
		LBP 80
		RBP 80)
	(BU:|<| LED PRATT-PARSE-INFIX
	     LBP 80.
	     RBP 80.)
	(BU:|<=| LED PRATT-PARSE-INFIX
	      LBP 80.
	      RBP 80.)
	(BU:|| LED PRATT-PARSE-INFIX
	      LBP 80.
	      RBP 80.)
	(bu:|| LED PRATT-PARSE-INFIX
	      LBP 80.
	      RBP 80.)
	(*END-OF-LINE* NUD end-of-line-fun
	      LBP -1)))
); End of Eval-when.