;;; -*- Mode:Lisp; Syntax:Common-Lisp; Package:(POSTSCRIPT nicknames (PS)); Vsp:0; Fonts:(CPTFONT HL12 TR12I COURIER ADOBE-COURIER14B HL12B CPTFONTBI) -*-

;1;; File "3PS-INTERPRETER*".*
;1;; A PostScript interpreter.  Incomplete (big surprise).*
;1;;*
;1;; 5ChangeLog:**
;1;;*
;1;;   24 Jul 88*	1Rick Busdiecker*	1Created.*
;1;;    6 Apr 90*	1Jamie Zawinski*	1Overhauled.*
;1;;   10 Apr 90*	1Jamie Zawinski*	1Added run-time type checking and access-protection.*
;1;;*  113 Apr 90*	1Jamie Zawinski *	1Implemented the PostScript error handler.*
;1;;*  118 Apr 90*	1Jamie Zawinski *	1Implemented 5save* and 5restore.**
;1;;* 1 * 13 May 90*	1Jamie Zawinski *	1Added some memory areas to better track resource usage; it will also help the garbage collector.*
;1;;*				1Implemented the matrix operations; started working on device-independant rendering.*
;1;;*

#| to do

Haven't implemented the 'null' type - what's that used for?

execution stack is readonly; maintain it in parallel with Lisp's exe stack.
3What about *tail recursion elimination - maybe I should do the execution stack myself 
instead of using Lisp's execution stack.  Pop from exe stack when on elt 
remaining.

Doing a restore always reclaims storage.  I could implement save and 
restore in terms of areas, and free the whole area afterwards.  Hmmm... can
you delete an area after creating it, or only shrink it to zero?

stop halts PS.  stopped is like CATCH for 'stop'.
so what are start and quit.

%statementedit and %lineedit are streams that make the user edit.
%statementedit reads a complete form; %lineedit does one line.

fontdict:
FontName	name
PaintType	integer
		0:sets up paths to be filled, 1: sets up paths to be stroked, 
		2: sets up paths to be filled (but are outlined), or
		3: chars do drawing themselves.
Metrics		dict  width and side bearing info; optional.
StrokeWidth	number  in units of char coord sys for PaintType 2.
FontInfo	dict
UniqueID	int
CharStrings	dict  assoc names (keys) with shape descriptions in proprietary
		format
Private		dict  other stuff

FontInfo dict:
Notice		string 	trademark
FullName	string
FamilyName	string
Weight		string (bold, light, etc)
version		number
ItalicAngle	number	degrees counterclock of dominant strokes
isFixedPitch	bool	fixedwidth p
UnderlinePosition	number
UnderlineThickness	number
  

5STACK MANIPULATORS*

	2any*		5pop*		2-*
	2any2 any1 *	5exch*		2any1 any2*
	2any*		5dup*		2any any*
	2any1..anyn n*	5copy*		2any1..anyn any1..anyn*
	2anyN..any0 n*	5index*		2anyN..any0 anyN*
	2a(n-1)..a0 n j*	5roll*		2a(j-1)nodN..a0 a(n-1)..a(j mod n)*		1roll n elements up j times*
	2|- any1..anyn*	5clear*		2|-*
	2|- any1..anyn*	5count*		2|- any1..anyn n*
	2-*		5mark*		2mark*
	2mark obj1..objn*	5cleartomark*	2-*
	2mark obj1..objn*	5counttomark*	2mark obj1..objn

5ARITHMETIC**

	5add, div, idiv, mod, mul, sub, abs, neg, ceiling, floor, round, truncate*
	5sqrt -> real*
	5atan, cos, sin -> degrees*
	5exp -> real*
	2num*	2 *	5ln*		2real*	1base 5e**
	2num*		5log*		2real*	5base 10*
	2-*		5rand*		2int*
	2int*		5srand*		2-*	1seed it*
	2-*		5rrand*		2int*	1return seed

5ARRAY OPERATORS**

	2int*			5array*		2array*
	2-*			5[*		2mark*
	2mark obj0,,objn*		5]*		2array*
	2array*			5length*		2int*

	2array index*		5get*		2any*
	2array index any*		5put*		2-*

	2array index count*		5getinterval*	2subarray*
	2array index array2*		5putinterval*	2-*
	2array*			5aload*		2a0..a(n-1) array*		1push all elements of array on stack*
	2any0..any(n-1) array*	5astore*		2array*			1pop elements from stack into array*
	2array1 array2*		5copy*		2subarray2*
	2array proc*		5forall*		2-

5DICTIONARY OPS**

	2int*			5dict*		2dict*
	2dict*			5length*		2int*			1number of elements*
	2dict*			5maxlength*	2int*			1capacity*
	2dict*			5begin*		2-*			1push to dictstack*
	2-*			5end*		2-*
	2key value*			5def*		2-*
	2key*			5load*		2value*			1search dict stack*
	2key value*			5store*		2-*
	2dict key*			5get*		2any*
	2dict key *			5value*	2put*	2-*
	2dict key*			5known*		2bool*			1whether its there*
	2key*			5where*		2dict true1 -or- *false*	1which dict is it in*
	2dict1 dict2*		5copy*		2dict2*
	2dict proc*			5forall*		2-*
	2-*			5errordict*		2dict*
	2-*			5systemdict*	2dict*
	2-*			5userdict*		2dict*
	2-*			5countdictstack*	2int*
	2array*			5dictstack*		2subarray*			1copy dictstack into ar*r1ay

5STRING**

	2int *			5string*		2string*
	2string*			5length*		2int*
	2string index*		5get*		2int*
	2string index int*		5put*		2-*
	2string index count*		5getinterval*	2substring*
	2string1 index string2*	5putinterval*	2-*
	2string1 string2*		5copy*		2substring2*
	2string proc*		5forall*		2-*
	2string seek*		5anchorsearch*	2post match true 1-or-* string false*	1determine if seek is initial substring of string.*
	2string seek*		5search*		2post match pre true 1-or-* string false*
	2string*			5token*		2post token true 1-or-* false*		1read token from start of string (p 232)

5RELATIONAL, BOOLEAN, BITWISE**

	5eq, ne, ge, gt, le, lt1 -> *bool*
	5and, not, or, xor1 -> *bool1 or *int*
	5true, false*
	2int shift*			5bitshift*		2int*				1pos is left

5CONTROL OPERATORS**

	2any*			5exec*		2-*
	2bool proc*			5if*		2-*
	2bool proc proc*		5ifelse*		2-*
	2init incr limit proc*		5for*				1exec proc with vals from init step by incr to limit*
	2int proc*			5repeat*		2-*		1n times*
	2proc*			5loop*		2-*		1forever*
	2-*			5exit*		2-*		1out of innermost loop*
	2-*			5stop*		2-*		1terminate "stopped" context
2##**	2-*			5countexecstack*	2int
##*	2array*			5execstack*	2subarray
##*	2-*			5quit*		2-*		1terminate interpreter
2##**	2-*			5start*		2-*		1start interpreter

5TYPE, ATTR, and CONVERSION**

	2any*			5type*		2name*
	2any*			5cvlit*		2any*		1make it be literal*
	2any*			5cvx*		2any*		1make it executable*
	2any*			5xcheck*		2any*		1exe-p*
	2array,file,string*		5executeonly*	2array,file,string*
	2array,dict,file,string*	5noaccess*		2array,dict,file,string*
	2array,dict,file,string*	5readonly*		2array,dict,file,string*
	2array,dict,file,string*	5rcheck*		2bool*
	2array,dict,file,string*	5wcheck*		2bool*
	2num,string*		5cvi*		2int*
	2string*			5cvn*		2name*
	2num,string*		5cvr*		2real*
	2num radix string*		5cvrs*		2substring*
	2any string*		5cvs*		2substring

5FILE OPERATORS**

	2string1 string2*		5file*		2file*			1open file string1 with access string2*
	2file*			5closefile*		2-*
	2file*			5read*		2in true 1-or-* false*		1read one char*
	2file int*			5write*		2-*
##	2file string*		5readhexstring*	2substring bool*
##	2file string*		5writehexstring*	2-*
##	2file string*		5readstring*	2substring bool*
##	2file string*		5writestring*	2-*
##	2file string*		5readline*		2substring bool*
	2file *			5token*		2token true 1-or-* false  (p 232)*
	2file*			5bytesavailable*	2int*
	2-*			5flush*		2-*			1flush stdout*
	2file*			5flushfile*		2-*			1flush output, or read-til-eof*
	2file*			5resetfile*		2-*			1discard buffered chars*
	2file*			5status*		2bool*
	2string*			5run*		2-*			1exec named file*
	2-*			5currentfile*	2file*			1current file being exec'd*
	2string*			5print*		2-*
	2any*			5=*		2-*			1write text rep of any to stdout*
	2|- ...*			5stack*		2|- ...*			1write stack nondestructively (=)*
	2any*			5==*		2-*			1write syntactic rep*
	2|- ...*			5pstack*		2|- ...*			1like stack but with ==*
	2-*			5prompt*		2-*			1exec'd when ready for* 1interactive input*
##	2bool*			5echo*		2-

5VMEM OPERATORS**

	2-*			5save*		2save*
	2save*			5restore*		2-*
	2-*			5vmstatus*		2level used max (p 238)

5MISC OPS**

	2proc*			5bind*		2proc*			1replace all operator-names in proc by operators.*
##	2-*			5null*		2null*
	2-*			5usertime*		2int*			1time in miliseconds*
	2-*			5version*		2string

5GRAPHICS STATE OPS

gsave, grestore, grestoreall, initgraphics**
	2num*		5setlinewidth*	2-*
	2-*		5currentlinewidth*	2-*
	2int*		5setlinecap*	2-*
	2-*		5currentlinewidth*	2num*
	2int*		5setlinecap*	2-*
	2-*		5currentlinejoin*	2int*
	2num*		5setmiterlimit*	2-*
	2-*		5currentmiterlimit*	2num*
##	2array offset*	5setdash*		2-*
##	2-*		5currentdash*	2array offset*
	2num*		5setflat*		2-*
	2-*		5currentflat*	2num*
##	2num*		5setgray*		2-*
##	2-*		5currentgray*	2num*
##	2hue sat bri*	5sethsbcolor*	2-*
##	2-*		5currenthsbcolor*	2h s b*
##	2r g b*		5setrgbcolor*	2-*
##	2-*		5currentrgbcolor*	2r g b*
##	2freq angle proc*	5setscreen*	2-*
##	2-*		5currentscreen*	2f a p*
	2proc*		5settransfer*	2-*
	2-*		5currenttransfer*	2proc

5COORD AND MATRIX**

	2-*		5matrix*		2matrix*		1identity*
	2-*		5initmatrix*		2-*		1set CTM to device default*
	2matrix*		5identmatrix*	2matrix*		1fill with identity*
	2matrix*		5defaultmatrix*	2matrix*
	2matrix*		5currentmatrix*	2matrix*
	2matrix*		5setmatrix*		2-*		1make it CTM*
	2tx ty*		5translate*		2-*
	2tx ty matrix*	5translate*		2matrix*		1stomp*
	2sx sy*		5scale*		2-*
	2sx sy matrix*	5scale*		2matrix*		1stomp*
	2angle*		5rotate*		2-*
	2angle matrix*	5rotate*		2-*
	2matrix*		5concat*		2-*		1ctm = matrix x ctm*
	2m1 m2 m3*	5concatmatrix*	2m3*		1m3 = m1 x m2*
	2x y*		5transform*	2x' y'*
	2x y matrix*	5transform*	2x' y'*
	2dx dy *		5dtransform*	2dx' dy'*		1distances*
	2dx dy matrix*	5dtransform*	2dx' dy'*		1distances*
	2x y *		5itransform*	2dx' dy'*		1inverse*
	2x y *		5idtransform*	2dx' dy'*		1inverse distance*
	2m1 m2*		5invertmatrix*	2m2*		1m2 = ~m1

5PATH CONTRUCTION**

	2-*			5newpath*		2-*
	2-*			5currentpoint*	2x y*
	2x y*			5moveto*		2-*
	2dx dy*			5rmoveto*		2-*
	2x y *			5lineto*		2-*
	2dx dy *			5rlineto*		2-*
##	2x y r ang1 ang2*		5arc*		-			1append cclock arc*
##	2x y r ang1 ang2*		5arcn*		-			1append clock arc*
##	2x1 y1 x2 y2 r*		5arcto*		2xt1 yt1 xt2 yt2*		1append tangent arc*
##	2x1 y1 x2 y2 x3 y3*	5curveto*		2-*			1spline*
##	2dx1 dy1 dx2 dy2 dx3 dy3*	5rcurveto*		-
	2-*			5closepath*	-			1back to start*
##	2-*			5flattenpath*	-			1convert curves to straight lines*
	-			5reversepath*	-			1flip direction*
##	-			5strokepath*	-
##	2string bool*		5charpath*		-			1append char outline*
##	-			5clippath*		-			1set path to be clippath*
##	2-*			5pathbox*		2llx lly urx ury*		1compute bbox*
##	2move line curve close*	5pathforall*	-			1enumerate current path*
##	-			5initclip*		-			1to default*
##	-			5clip*		-			1new from path*
##	-			5eoclip*		-			1clip using even-odd-inside rule

5PAINTING

erasepage, fill, eofill, stroke**
##	2w h bps matrix proc *	5image*		2-*
##	2w h invert matrix proc*	5imagemask*	2-

5DEVICE SETUP AND OUTPUT

showpage, copypage**
##	2mat w h proc*		5banddevice*	2-*		1install band buffer device*
##	2mat w h proc*		5framedevice*	2-*		1install framebuffer device*
##	-			5nulldevice*	-		1install no-output device*
##	2proc*			5renderbands*	2-*		1enum bands for output dev

5CHAR AND FONT OPS**

##	2key font*	2definefont*	5font*		-		1register as a font dict*
##	2key*			5findfont*		2font*
##	2font scale*		5scalefont*		2font'*
##	2font matrix*		5makefont*		2font'*
##	2font*			5setfont*		-
##	-			5currentfont*	2font*
##	2string*			5show*		-
##	2ax ay string*		5ashow*		2-*		1add ax ay to pos of each char*
##	2cx cy chr str*		5widthshow*	2-*		1ad cx cy to w of chr while showing*
##	2cx cy chr ax ay str*	5awidthshow*	2-*
##	2proc string*		5kshow*		2-*		1exec proc between chars*
##	2string*			5stringwidth*	2wx wy*
##	2-*			5FontDirectory*	2dict*		1dict of font dicts*
##	2-*			5StandardEncoding*	2array*		1std encod vector

5FONT CACHE**

##	2-*			5cachestatus*	2bsize bmax msize csize cmax blimit*
##	2wx wy llx lly urx ury*	5setcachedevice*
##	2wx wy*			5setcharwidth*
##	2num*			5setcachelimit*

"executeonly affects the access attribute only of the object that it returns;l; iof there exist other objects that
3 *share the same value, their access attributes are unaffected."

StandardEncoding maps numbers to char names.

LaserWriter Limits:
	int 2^31-1
	real +-10^(+-)38  8 sig digits
	array, dict, string - 65k long
	name - 128 chars
	file - 6 open
	userdict - 200
	operand stack 500
	dict stack 20
	exec stack 250			for, repeat, stopped use this stack as well

	interpreter level - 10		pathforall, show, image invoke interpreter (?)
	save level - 15
	gsave level - 31
	path - 1500 points
        dash - 11 elements VM - 240000 bytes

	array or proc occupy 8 bytes per element.
	dict occupies 20 bytes per pair.
	dicts do not grow.
	each distinct name occupies 40 bytes plus namestring.
	save/restore consume proportionally.

serverdict contains exitserver proc and other secrets
statusdict operators change nonvolatile parms

 |#


(in-package "2POSTSCRIPT*" :nicknames '("2PS*"))

(defvar 4*verbose* *nil)

3#+LISPM*   ;1 Set up some memory areas for easier resource tracking and better GC performance.*
(progn
  (defvar 4POSTSCRIPT-SYSTEM-AREA *:unbound "2The memory area for PostScript builtins.*")
  (defvar 4POSTSCRIPT-USER-AREA *:unbound "2The memory area for user-defined PostScript objects.*")
  (defvar 4POSTSCRIPT-SAVE-AREA *:unbound "2The memory area for PostScript save and other vmem-status-related objects.*")

  (unless (boundp 'POSTSCRIPT-SYSTEM-AREA)
    (make-area :name 'POSTSCRIPT-SYSTEM-AREA :representation :structure))

  (unless (boundp 'POSTSCRIPT-USER-AREA)
    (make-area :name 'POSTSCRIPT-USER-AREA :representation :structure))

  (unless (boundp 'POSTSCRIPT-SAVE-AREA)
    (make-area :name 'POSTSCRIPT-SAVE-AREA :representation :list))
  
  (defmacro consing-in-system-area (&body body)
    `(let ((DEFAULT-CONS-AREA POSTSCRIPT-SYSTEM-AREA)) ,@body))

  (defmacro consing-in-user-area (&body body)
    `(let ((DEFAULT-CONS-AREA POSTSCRIPT-USER-AREA)) ,@body))

  (defmacro consing-in-save-area (&body body)
    `(let ((DEFAULT-CONS-AREA POSTSCRIPT-SAVE-AREA)) ,@body))

  (defmacro consing-in-parser-area (&body body)
    `(consing-in-user-area ,@body))
  )

#-LISPM
(progn
  (defmacro consing-in-system-area (&body body) `(progn ,@body))
  (defmacro consing-in-user-area (&body body) `(progn ,@body))
  (defmacro consing-in-save-area (&body body) `(progn ,@body))
  (defmacro consing-in-parser-area (&body body) `(progn ,@body))
  )


3#-LISPM*
(defmacro 4deff *(name synonym)
  `(defmacro ,name (&rest args) (,synonym ,@args)))

3#-LISPM*
(defmacro 4defsubst *(name arglist &body body)
  `(progn
     (proclaim '(inline ,name))
     (defun ,name ,arglist ,@body)))


;1;;; 5Stacks.**

(defstruct 4(stack *(:print-function %print-stack)
		   (:constructor %make-stack (&optional (max 20))))
  "2We use this structure instead of simply a list so that we can easilly enforce a max-stack-depth.*"
  (max 20 :type integer)
  (length 0 :type integer)
  (list () :type list)    ;1 any win to using a vector instead of a list?  I don't think so.*
  )

(defsubst 4make-stack *(&optional (max 20))
  ;1; ## should be able to do this with a defstruct option...*
  (consing-in-save-area (%make-stack max)))

(defun 4%print-stack* (self stream ignore)
  (if *print-escape*
      (if (stack-list self)
	  (format stream "3#<stack ~D ~S>*" (stack-length self) (reverse (stack-list self)))
	  (format stream "3#<empty-stack>*"))
      (let* ((list (reverse (stack-list self))))
	(princ #+TI "3( *" #-TI "3-( *" stream)
	(dolist (elt list)
	  (if (stringp elt)
	      (prin1 elt)
	      (princ elt))
	  (write-char #\Space stream))
	(princ #+TI "3)*" #-TI "3)-*" stream))))


(defun 4stack-push *(obj stack)
  "2Add an element to the stack, signalling an error if the stack's max-depth is exceeded.*"
;  (unless (= (stack-length stack) (length (stack-list stack)))
;    (error "2internal: stack out of synch.  ~D vs ~D.*" (stack-length stack) (length (stack-list stack))))
  (locally (declare (special *within-eh*))
    (unless (and (boundp '*within-eh*) *within-eh*)
      (when (> (1+ (stack-length stack)) (stack-max stack))
	(ps-error "3stackoverflow*"))
      (when (and (integerp obj) (typep obj 'bignum))
	(ps-error "3rangecheck*" "3~D is a BIGNUM (~D bits).*" obj (integer-length obj)))))
  (consing-in-save-area
    (push obj (stack-list stack)))
  (incf (stack-length stack))
  obj)

(defun 4stack-pop *(stack &optional desired-type)
  "2Remove and return and element from the stack, signalling an error if the stack is empty.
  If a type-specifier is supplied, and the popped object is not of that type, an error is signalled.*"
;  (unless (= (stack-length stack) (length (stack-list stack)))
;    (error "2internal: stack out of synch.  ~D vs ~D.*" (stack-length stack) (length (stack-list stack))))
  (when (minusp (1- (stack-length stack)))
    (ps-error "3stackunderflow*"))
  (when (and desired-type (not (typep (car (stack-list stack)) desired-type)))
    (ps-error "3typecheck*" "3not of type ~A*" desired-type))
  (decf (stack-length stack))
  (pop (stack-list stack)))

(defun 4stack-top *(stack &optional no-error)
  "2Return (without removing) the top element of the stack.
 Signals an error if the stack is empty, unless NO-ERROR is true.*"
  (unless (or no-error (stack-list stack)) (ps-error "3stackunderflow*"))
  (car (stack-list stack)))

(defun 4clear-stack *(stack)
  (setf (stack-length stack) 0
	(stack-list stack) '()))


(defvar 4*dict-stack* *(make-stack 20)
  "2The stack of currently active dictionaries; user-dict and system-dict are always implicitly here.*")

(defvar 4*graphics-state-stack* *(make-stack)
  "2A stack of the graphics-state objects currently being held by gsave/grestore.*")

(defvar 4*operand-stack* *(make-stack 500) "2The stack of objects; this is THE stack.*")
(defvar 4*execution-stack* *(make-stack 250) "2unused.*")


;1;;; 5Objects.**

(defstruct 4object*
  (%status 0 :type (unsigned-byte 3))
  )

(defun 4object-status* (object)
  (aref '#(:unlimited :read-only :exec-only :none) (ldb (byte 2 0) (object-%status object))))

(defun 4set-object-status* (object newval)
  (setf (object-%status object)
	(dpb (or (position newval '#(:unlimited :read-only :exec-only :none) :test #'eq)
		 (error "3Invalid status, ~S*" newval))
	     (byte 2 0)
	     (object-%status object))))

(defsetf 4object-status* set-object-status)

(defsubst 4object-executable* (object) (logbitp 2 (object-%status object)))

(defsetf  4object-executable* (object) (newval)
  `(setf (object-%status ,object)
	 (dpb (if ,newval 1 0) (byte 1 2) (object-%status ,object))))

(defsubst 4object-writable* (object) (zerop (ldb (byte 2 0) (object-%status object))))
(defsubst 4object-readable* (object) (< (ldb (byte 2 0) (object-%status object)) 2))
(defsubst 4object-execable* (object) (/= 3 (ldb (byte 2 0) (object-%status object))))

(defmacro 4check-status* (function object desc)
  (let ((o (gensym)))
    `(let ((,o ,object))
       (when (object-p ,o)
	 (unless (,function ,o)
	   (ps-error "3invalidaccess*" ,(format nil "3cannot ~a*" desc)))))))

(defmacro 4check-writable* (object) `(check-status object-writable ,object "3write*"))
(defmacro 4check-readable* (object) `(check-status object-readable ,object "3read*"))
(defmacro 4check-execable* (object) `(check-status object-execable ,object "3execute*"))


;1;; 5Arrays, Strings, Names, Operators, Files, and FontIDs.**

(defstruct 4(array-object* (:print-function %print-array)
			   (:include object))
  (contents #() :type vector)
  )

(defsubst 4executable-array-p *(x) (and (array-object-p x) (not (string-object-p x)) (object-executable x)))
(deftype 4executable-array *() '(and array-object (not string-object) (satisfies executable-array-p)))

(defun 4%print-array* (self stream ignore)
  (let* ((exe-p (object-executable self)))
    (if *print-escape*
	(format stream "3#<~A ~A>*" (type-of self) self)
	(let* ((a (array-object-contents self)))
	  (princ (if exe-p "3{*" "3[*") stream)
	  (dotimes (i (length a))
	    (unless (zerop i) (write-char #\Space stream))
	    (if (stringp (aref a i))
		(prin1 (aref a i) stream)
		(princ (aref a i) stream)))
	  (princ (if exe-p "3}*" "3]*") stream)))))

;1;; Strings and Arrays are sometimes interchangable, since they are both sequences to PostScript.*
;1;;*
(defstruct 4(string-object* (:print-function %print-string)
			    (:include array-object
				      (contents #() :type string)))
  )

;1;; Names and Strings are sometimes interchangable, since they are both "text" to PostScript.*
;1;; Names, however, are never treated as sequences, as Strings sometimes are.*
;1;;*
(defstruct 4(name* (:print-function %print-name)
		 (:include string-object))
  )

(deff 4name-string *'name-contents)

(defun 4%print-string* (self stream ignore)
  (if *print-escape*
      (format stream "3#<~S~:[~; (exe)~] ~A>*" (type-of self) (object-executable self) (string-object-contents self))
      (format stream "3(~A)*" (string-object-contents self))))

(defun 4%print-name* (self stream ignore)
  (if *print-escape*
      (format stream "3#<~S~:[~; (exe)~] ~A>*" (type-of self) (object-executable self) (name-string self))
      (format stream "3~:[/~;~]~A*" (object-executable self) (name-string self))))


(defstruct 4(file-object *(:include object))
  stream)

(defstruct 4(font-ID *(:include object))
  )

(defstruct 4(save *(:include object))
  (level -1 :type fixnum)
  (dead-p nil :type (member t nil))
  )


;1;; Matrices, and operations on them.*

(defmacro 4log10 *(x) `(log ,x 10))

(defmacro 4deg-atan *(x) `(atan (* #.(/ pi 180) ,x)))
(defmacro 4deg-cos * (x) `(cos  (* #.(/ pi 180) ,x)))
(defmacro 4deg-sin * (x) `(sin  (* #.(/ pi 180) ,x)))
(defmacro 4deg-tan * (x) `(tan  (* #.(/ pi 180) ,x)))


(defstruct 4(matrix *(:type (vector real))
		    (:constructor make-matrix (a b c d x y)))
  "2A 3x3 transformation matrix - but the third column is assumed to be 0,0,1.*"
  a  b ;0
  c  d ;0
  x  y ;1
  )

(deftype 4matrix *() '(array real (6)))
(deftype 4matrix-object *() '(and array-object (satisfies matrix-object-p)))

(defun 4matrix-object-p *(x)
  (and (array-object-p x) (typep (array-object-contents x) 'matrix)))


(defun 4mat-translate *(mat x y)
  "2Modify the given matrix to perform X,Y more translation.*"
  (incf (matrix-x mat) x)
  (incf (matrix-y mat) y)
  mat)

(defun 4mat-scale *(mat x y)
  "2Scale the given matrix destructively.*"
  (setf (matrix-a mat) (* (matrix-a mat) x)
	(matrix-d mat) (* (matrix-d mat) y))
  mat)

;(defun 4mat-rotate *(mat theta)
;  (let ((cos (deg-cos theta))
;	(sin (deg-sin theta)))
;    (let ((mat2 (make-matrix cos sin (- sin) cos 0 0)))
;      (mat-multiply mat2 mat mat))))


(defun 4mat-rotate *(mat theta)
  "2Rotate the given matrix destructively by theta degrees counterclockwise.*"
  (let ((cos (deg-cos theta))
	(sin (deg-sin theta)))
;    (let ((a (+ (* cos (matrix-a mat))
;		(* (- sin) (matrix-c mat))))
;	  (b (+ (* cos (matrix-b mat))
;		(* sin (matrix-d mat))))
;	  (c (+ (* (- sin) (matrix-a mat))
;		(* cos (matrix-c mat))))
;	  (d (+ (* (- sin) (matrix-b mat))
;		(* cos (matrix-d mat)))))
;      (setf (matrix-a mat) a (matrix-b mat) b
;	    (matrix-c mat) c (matrix-d mat) d)))
    (let ((a (+ (* (matrix-a mat) cos)
		(* (matrix-b mat) (- sin))))
	  (b (+ (* (matrix-a mat) sin)
		(* (matrix-b mat) cos)))
	  (c (+ (* (matrix-c mat) cos)
		(* (matrix-d mat) (- sin))))
	  (d (+ (* (matrix-c mat) sin)
		(* (matrix-d mat) cos))))
      (setf (matrix-a mat) a (matrix-b mat) b
	    (matrix-c mat) c (matrix-d mat) d)))
  mat)

(defun 4mat-multiply *(mat1 mat2 &optional (mat3 mat1))
  "2Destrucively modify MAT3 to be MAT1 multiplied by MAT2.  MAT3 may be MAT1 - we are careful.*"
  (let ((a (+ (* (matrix-a mat1) (matrix-a mat2))
	      (* (matrix-b mat1) (matrix-c mat2))))
	(b (+ (* (matrix-a mat1) (matrix-b mat2))
	      (* (matrix-b mat1) (matrix-d mat2))))
	(c (+ (* (matrix-c mat1) (matrix-a mat2))
	      (* (matrix-d mat1) (matrix-c mat2))))
	(d (+ (* (matrix-c mat1) (matrix-b mat2))
	      (* (matrix-d mat1) (matrix-d mat2))))
	(x (+ (* (matrix-x mat1) (matrix-a mat2))
	      (* (matrix-y mat1) (matrix-c mat2))
	      (matrix-x mat2)))
	(y (+ (* (matrix-x mat1) (matrix-b mat2))
	      (* (matrix-y mat1) (matrix-d mat2))
	      (matrix-y mat2))))
    (setf (matrix-a mat3) a (matrix-b mat3) b
	  (matrix-c mat3) c (matrix-d mat3) d
	  (matrix-x mat3) x (matrix-y mat3) y))
  mat3)


(defun 4transform-point *(x y mat)
  "2Pump the point through the matrix.
 X' = aX + cY + tx;
 Y' = bX + dY + ty.*"
  (declare (values x1 y1))
  (values (+ (* x (matrix-a mat)) (* y (matrix-c mat)) (matrix-x mat))
	  (+ (* x (matrix-b mat)) (* y (matrix-d mat)) (matrix-y mat))))


(defun 4itransform-point *(x y mat)
  "2Pump the point through the matrix backwards; that is,
  invert the matrix and transform the point through it.*"
  (declare (values x1 y1))
  (let ((determinant (float (- (* (matrix-a mat) (matrix-d mat))
			       (* (matrix-b mat) (matrix-c mat))))))
    (declare (float determinant))
    (let ((m1.1 (float (/ (matrix-d mat) determinant)))
	  (m1.2 (float (/ (- (matrix-b mat)) determinant)))
	  (m2.1 (float (/ (- (matrix-c mat)) determinant)))
	  (m2.2 (float (/ (matrix-a mat) determinant)))
	  (m3.1 (float (/ (- (* (matrix-c mat) (matrix-y mat))
		      (* (matrix-d mat) (matrix-x mat)))
		   determinant)))
	  (m3.2 (float (/ (- (* (matrix-b mat) (matrix-x mat))
		      (* (matrix-a mat) (matrix-y mat)))
		   determinant))))
      (declare (float m1.1 m1.2 m2.1 m2.2 m3.1 m3.2))
      (values (+ (* x m1.1) (* y m2.1) m3.1)
	      (+ (* x m1.2) (* y m2.2) m3.2)))))


(defun 4dtransform-point *(x y mat)
  "2Pump the point through the matrix, disregarding the translation components.
 X' = aX + cY;
 Y' = bX + dY.*"
  (declare (values x1 y1))
  (values (+ (* x (matrix-a mat)) (* y (matrix-c mat)))
	  (+ (* x (matrix-b mat)) (* y (matrix-d mat)))))


(defun 4idtransform-point *(x y mat)
  "2This is to dtransform what itransform is to transform;
 pump a point through a matrix backwards, disregarding distance.*"
  (declare (values x1 y1))
  (let ((determinant (float (- (* (matrix-a mat) (matrix-d mat))
			       (* (matrix-b mat) (matrix-c mat))))))
    (declare (float determinant))
    (let ((m1.1 (float (/ (matrix-d mat) determinant)))
	  (m1.2 (float (/ (- (matrix-b mat)) determinant)))
	  (m2.1 (float (/ (- (matrix-c mat)) determinant)))
	  (m2.2 (float (/ (matrix-a mat) determinant))))
      (declare (float m1.1 m1.2 m2.1 m2.2))
      (values (+ (* x m1.1) (* y m2.1))
	      (+ (* x m1.2) (* y m2.2))))))


(defun 4invert-matrix *(mat1 &optional (mat2 mat1))
  "2Create a matrix which will have the opposite effect of MAT1, and write it into MAT2.
 MAT1 and MAT2 may be the same object.*"
  (declare (values mat2))
  (let ((determinant (float (- (* (matrix-a mat1) (matrix-d mat1))
			       (* (matrix-b mat1) (matrix-c mat1))))))
    (declare (float determinant))
    (let ((m1.1 (float (/ (matrix-d mat1) determinant)))
	  (m1.2 (float (/ (- (matrix-b mat1)) determinant)))
	  (m2.1 (float (/ (- (matrix-c mat1)) determinant)))
	  (m2.2 (float (/ (matrix-a mat1) determinant)))
	  (m3.1 (float (/ (- (* (matrix-c mat1) (matrix-y mat1))
			     (* (matrix-d mat1) (matrix-x mat1)))
			  determinant)))
	  (m3.2 (float (/ (- (* (matrix-b mat1) (matrix-x mat1))
			     (* (matrix-a mat1) (matrix-y mat1)))
			  determinant))))
      (declare (float m1.1 m1.2 m2.1 m2.2 m3.1 m3.2))
      (setf (matrix-a mat2) m1.1 (matrix-b mat2) m1.2
	    (matrix-c mat2) m2.1 (matrix-d mat2) m2.2
	    (matrix-x mat2) m3.1 (matrix-y mat2) m3.2)
      mat2)))



;1;; 5Graphics State* and 5Devices.**

(deftype 4linecap* () '(mod 6))
(deftype 4linejoin* () '(mod 6))

(defstruct 4device*
  matrix
  draw-line
  draw-curve
  draw-string
  page
  )

(defvar 4*identity-ctm* *#(1 0 0 1 0 0))

(defvar 4*null-device* *(make-device :matrix *identity-ctm*
				     :draw-line #'values
				     :draw-curve #'values
				     :draw-string #'values
				     ))


(defstruct 4(graphics-state* (:print-function %print-graphics-state)
			     (:constructor %make-graphics-state (&optional device CTM))
			     (:copier %copy-graphics-state))
  (CTM		*identity-ctm*	:type matrix)	;1 default: points->device coords*
  (color	0		:type number)			;1 (internal) depends on model*
  (position-x	nil		:type (or null number))
  (position-y	nil		:type (or null number))
  (path		nil		:type list)			;1 default empty*
  (clippath	nil		:type list)			;1 default whole page*
  (font		nil		:type (or null dictionary))
  (linewidth	1		:type number)
  (linecap	0		:type linecap)
  (linejoin	0		:type linejoin)
  (halftonescreen nil		)
  (transfer	nil		:type (or null array))
  (flatness	0		:type number)			;1 smoothness of curves.  *
  (miterlimit	10		:type number)
  (dashpattern	nil		:type (or null array))
  (device	*null-device*	:type device)
  (from-save-p  nil		:type (member t nil))		;1 whether this is from 5save* rather than 5gsave*.*
  )

(defun 4%print-graphics-state *(self stream ignore)
  (format stream "3#<~S~:[~; via save~]>*" (type-of self) (graphics-state-from-save-p self)))

(defun 4make-graphics-state *(&optional (device *null-device*))
  (let ((state (consing-in-save-area (%make-graphics-state))))
    (setf (graphics-state-device state) device
	  (graphics-state-CTM state) (device-matrix device))
    state))

(defun 4copy-graphics-state *(gstate)
  (let ((copy (consing-in-save-area (%copy-graphics-state gstate))))
    (setf (graphics-state-CTM copy) (consing-in-save-area (copy-matrix (graphics-state-CTM copy))))
    copy))

(defvar 4*default-graphics-state* *(consing-in-system-area
				       (%make-graphics-state *null-device*))
  )

(defmacro 4top-graphics-state *()
  '(or (stack-top *graphics-state-stack* t) *default-graphics-state*))


;1;; Other useful typedefs.*

(deftype 4boolean* () '(member t nil))

(defconstant 4MARK* 'MARK)
(deftype 4mark* () '(member mark))


;1;; We use this because it's not legal to aref a /name, even though in many other respects it's a string.*
;1;;*
(deftype 4arefable* () '(and array-object (not name) (not operator)))

;1;; An abstraction potentially useful someday...*
(deftype 4stringable* () 'string-object)

;1;; Just an array, dammit, not a subclass.*
;(deftype 4basic-array* () '(and array-object (not executable-array) (not string-object)))
(deftype 4basic-array* () '(and array-object (not string-object)))

;1;; Just a string, dammit, not a subclass.*
(deftype 4basic-string* () '(and string-object (not name)))


;1;; Dictionaries.*

(defvar 4*all-dictionaries** '() "2Every dictionary created - used internally by save/restore.*")

(defstruct 4(dictionary* (:print-function %print-dictionary)
			 (:include object)
			 (:constructor %make-dictionary (max-entries table)))
  (max-entries 200 :type fixnum)
  (table nil :type (or null hash-table))
  )

(defun 4%print-dictionary *(self stream ignore)
  (format stream "3#<~s ~D entr~@:p of ~D>*" (type-of self)
	  (hash-table-count (dictionary-table self))
	  ; (dictionary-n-entries self)
	  (dictionary-max-entries self)))

(defun 4make-dictionary* (&optional (max-entries 200))
  (let* ((d (%make-dictionary max-entries (make-hash-table :test #'equal :size max-entries))))
    (push d *all-dictionaries*)
    d))

(defun 4dict-count *(dictionary) (hash-table-count (dictionary-table dictionary)))


;1;; Dictionary Hash Table format...*
;1;;*
;1;; Dictionaries can be indexed with 5names* or 5strings*, but the actual key must be preserved.*
;1;; So we hash on a lisp string, and store a cons of the PostScript-object key and value.*
;1;;*
;1;; To implement save and restore, we store lists of the above - the one towards the front of*
;1;; the list is the current value, and ones farther back are shadowed.  When we do a 5restore*,*
;1;; we pop from this list.*
;1;;*
;1;; To avoid having to push one cons cell to every dict element each time we do a 5save*, we*
;1;; store the save-level in the table as well, and only push a new value when we need to (that*
;1;; is, when a change is made within an environment enclosed by 5save/restore.**
;1;;*
;1;; So the contents of a dictionary's hash table might look something like this:*
;1;;*
;1;;*	5HT-Key*		5HT-Value*
;1;;*
;1;;*	3"string"*	3( ( 5/string* 5 <2value1*> ) ( 5/string* 1 <2value2*> ) ( 5/string* 0 <2value3*> ) )*
;1;;*
;1;; where 3"string"* is a Lisp string, 5/string* is a PostScript string object, and 3<2value1*>* is the current value of*
;1;; the object.  This object has been modified at three diferent save-levels; first it was given a value at level*
;1;; zero (2value3*), then a 5save* was done and it was given the value 2value2*.  Then four more saves were done;*
;1;; the next time a value was written was at save-level 5, where it was assigned 2value1*.*
;1;;*
;1;; When a table is written to, we examine the topmost value.  If it was made at the current save-level, then*
;1;; we simply modify it.  If it was written at a saved level, then we push a new value descriptor on the front.*
;1;;*
;1;; When a restore happens, we iterate over every dictionary and delete all value descriptors which have been*
;1;; made obsolete.  If there are no descriptors left for an item, we remove it from the table.*
;1;;*
;1;; One additional hack is done - the hash table contents are not really 3( <2value-desc*> <2value-desc*> ... )*,*
;1;; they are 3(* 3NIL <2value-desc*> <2value-desc*> ... )*.  This lets us sometimes get away with not having to call*
;1;; both 5gethash* and 5sethash*, because we can just destructively modify the list instead of storing into the table.*
;1;;*


(defvar 4*current-save-level** -1)
(defvar 4*currently-active-saves* *'() "2A list of those save objects which are not dead.*")


(defstruct 4(save-binding *(:type list) (:constructor nil))
  key level value)

(defsubst 4make-save-binding* (key level value)
  (consing-in-save-area (list key level value)))

(defun 4dict-hash *(key dictionary &optional default-value)
  (let ((hashcode (if (string-object-p key)
		      (string-object-contents key)
		      key)))
    (check-readable dictionary)
    (let ((bindings (cdr (gethash hashcode (dictionary-table dictionary)))))
      ;1; bindings are 3( <2key*> <2savelevel*> <2value*> )**
      (dolist (binding bindings default-value)
	(when (> (save-binding-level binding) *current-save-level*) (error "3internal error: save-level skewed.*"))
	(when (<= (save-binding-level binding) *current-save-level*)
	  (return (save-binding-value binding)
		  (save-binding-key binding)))))
    ))


(defun 4set-dict-hash *(key dictionary newval)
  (when (>= (dict-count dictionary)
	    (dictionary-max-entries dictionary))
    (ps-error "3dictfull*"))
  (check-writable dictionary)
  (let* ((hashcode (if (string-object-p key)
		       (string-object-contents key)
		       key))
	 (bindings (gethash hashcode (dictionary-table dictionary)))
	 (top-binding (second bindings)))
    (cond ((null bindings)
	   ;1; nothing has been bound here yet.*
	   (setf (gethash hashcode (dictionary-table dictionary))
		 (consing-in-save-area
		   (list NIL (make-save-binding key *current-save-level* newval)))))
	  
	  ((= (save-binding-level top-binding) *current-save-level*)
	   ;1; there is a binding at this save-level - stomp it.*
	   (setf (save-binding-value top-binding) newval))
	  
	  ((> (save-binding-level top-binding) *current-save-level*)
	   (error "3internal: current-save-level skewed.*"))
	  
	  (t
	   ;1; Otherwise, all bindings are at prior save-levels - add a new (shadowing) binding.*
	   (push (make-save-binding key *current-save-level* newval)
		 (cdr bindings))))
    newval))

(defsetf 4dict-hash* set-dict-hash)


(defun 4map-dictionary* (function dictionary)
  "2Just like MAPHASH.*"
  (maphash #'(lambda (hashcode cons)
	       (declare (ignore hashcode))
	       (let ((top-binding (second cons)))
		 (unless top-binding (error "3hey, bogus dict entry.*"))
		 (funcall function (save-binding-key top-binding) (save-binding-value top-binding))))
	   (dictionary-table dictionary))
  nil)

(defun 4pop-save-state* (&optional to-core-state)
  "2Pop the save state down to the *CURRENT-SAVE-LEVEL*.  Error if it's already below that.*"
  (if to-core-state
      (assert (= *current-save-level* -1) () "3popping to system, but *current-save-level* isn't -1.*")
      (when (minusp *current-save-level*) (error "3trying to pop the core!*")))
  (dolist (dict *all-dictionaries*)
    (maphash #'(lambda (key val)
		 ;(declare (ignore key))
		 (unless (cdr val) (error "3blah, bad entry.*"))
		 (do ()
		     ((or (null (cdr val))
			  (<= (save-binding-level (second val)) *current-save-level*))
		      (when (null (cdr val)) ;1 we've popped it all the way.*
			(remhash key (dictionary-table dict)))
		      )
		   (when *verbose* (format t "3~&## target: ~d; popping ~A's save-~D value ~A*"
					   *current-save-level*
					   key (save-binding-level (second val)) (save-binding-value (second val))))
		   (pop (cdr val))))
	     (dictionary-table dict)))
  )


(defvar 4*system-dict* *(make-dictionary 300) "2The dictionary of builtin commands.*")
(defvar 4*user-dict* *(make-dictionary 200) "2The default dictionary for user commands.*")
(defvar 4*error-dict* *(make-dictionary 200) "2The dictionary for error handlers.*")


(defun 4dict-stack-hash *(key dict-stack)
  "2Look up the key in the first dictionary on the given dict-stack that holds it.*"
  (declare (values value found-p))
  (let* ((-noval- '(())))
    (block DONE
      (dolist (dict (stack-list dict-stack))
	(let* ((val (dict-hash key dict -noval-)))
	  (unless (eq val -noval-) (return-from DONE (values val t)))))
      (let* ((val (dict-hash key *user-dict* -noval-)))
	(unless (eq val -noval-) (return-from DONE (values val t))))
      (let* ((val (dict-hash key *system-dict* -noval-)))
	(unless (eq val -noval-) (return-from DONE (values val t))))
      (values nil nil))))

(defun 4dict-stack-set *(key val dict-stack)
  "2Store the value in the topmost dictionary on the stack (or userdict).*"
  (setf (dict-hash key (or (stack-top dict-stack t) *user-dict*)) val))

(defsetf 4dict-stack-hash *(key dict-stack) (val)
  `(dict-stack-set ,key ,val ,dict-stack))



;1;; 5Operators.**


(defstruct 4(operator* (:print-function %print-operator)
		       (:include object
				 (%status #b110)))
  (name "" :type string)
  (function #'false :type function)
  )


(defun 4%print-operator* (self stream ignore)
  (if *print-escape*
      (format stream "3#<~S ~A>*" (type-of self) (operator-name self))
      (format stream "3<<~A>>*" (operator-name self))))



(defmacro 4define-operator* (name &body body)
  "2 Define a builtin postscript procedure called NAME.  this is placed in SystemDict.
 NAME may be a symbol or a string; if it is a symbol, it is downcased.*"
  (let ((name (if (stringp name) name (string-downcase (symbol-name name)))))
;    (setq body `(consing-in-user-area ,@body))
    `(let* ((fn #-TI #'(lambda () ,@body)
		#+TI #'(named-lambda ,(intern (string-append "3%ps-internal-*" name)) () ,@body))
	    (op (consing-in-system-area
		  (make-operator :name ',name :function fn))))
       (setf (object-executable op) t)
       (assert (= -1 *current-save-level*) () "3Defining an operator at save-level ~D.*" *current-save-level*)
       (let ((old (dict-hash ',name *system-dict*)))
	 (when (and old (not (eq old :undefined)))
	   (warn "3Redefining operator ~S*" ',name)))
       (consing-in-system-area
	 (setf (dict-hash ',name *system-dict*) op))
       ',name)))


(defmacro 4define-simple-operator *(name nargs function)
  "2 Define a builtin postscript procedure called NAME, which is the same
 as calling FUNCTION with N arguments and pushing the (single) result
 onto the stack.
 NARGS may be a number, meaning that many arguments should be popped, or a 
 list of type-specifiers, meaning arguments of those types should be popped.*"
  (let* ((rest '()))
    (if (numberp nargs)
	(dotimes (i nargs) (push '(stack-pop *operand-stack*) rest))
	(setq rest (mapcar #'(lambda (x)
			       (if (member x '(t nil))
				   '(stack-pop *operand-stack*)
				   `(stack-pop *operand-stack* ',x)))
			   nargs)))
    `(define-operator ,name
       (stack-push (,function ,@rest) *operand-stack*))))


(defmacro 4define-binary-operator *(name function &optional type1 type2)
  "2 Define a builtin postscript procedure called NAME, which is the same
 as calling FUNCTION with two arguments, in the reverse order that they
 appear on the stack.  The result of the function is pushed onto the stack.
 If type specifiers are provided, the arguments are insured to be of those types.
 Syntax:*
	3(define-binary-operator op op-function)*
	3(define-binary-operator op op-function type-1 type-2)*
	3(define-binary-operator op op-function (type-1 type-2))*
	3(define-binary-operator op (type-1 type-2) op-function)
2 **"
  (declare (arglist name &rest args))
  (cond ((and (consp type1) (null type2))
	 (assert (= 2 (length type1)) () "2If type1 is a list of typespecs, it must contain 2 elements.*")
	 (setq type2 (second type1) type1 (first type1)))
	((consp function)
	 (rotatef function type1)
	 (assert (null type2) () "2If the typespecs come first, there must be exactly three arguments.*")
	 (assert (= 2 (length type1)) () "2If type1 is a list of typespecs, it must contain 2 elements.*")
	 (setq type2 (second type1) type1 (first type1))))
  `(define-operator ,name
     (let* ((y (stack-pop *operand-stack* ,@(when type1 `(',type1))))
	    (x (stack-pop *operand-stack* ,@(when type2 `(',type2)))))
       (stack-push (,function x y) *operand-stack*))))


(defmacro 4define-boolean-operator *(name nargs function)
  "2 Define a builtin postscript procedure called NAME, which is the same
 as calling FUNCTION with N arguments and pushing the (single) result
 onto the stack as a boolean value.
 NARGS may be a number, meaning that many arguments should be popped, or a 
 list of type-specifiers, meaning arguments of those types should be popped.*"
  (let* ((rest '()))
    (if (numberp nargs)
	(dotimes (i nargs) (push '(stack-pop *operand-stack*) rest))
	(setq rest (mapcar #'(lambda (x)
			       (if (member x '(t nil))
				   '(stack-pop *operand-stack*)
				   `(stack-pop *operand-stack* ',x)))
			   nargs)))
    `(define-operator ,name
       (stack-push (if (,function ,@rest) T NIL) *operand-stack*))))


;1;; 5The Scanner.**


(defsubst 4whitespace-p* (char)
  (member (the string-char char) '(#\Space #\Tab #\Newline) :test #'char=))

(defsubst 4special-p* (char)
  (member (the string-char char) '(#\( #\) #\< #\> #\[ #\] #\{ #\} #\% #\Space #\Tab #\Newline #\/)
	  :test #'char=))

(defun 4scan-top *(&optional (stream *standard-input*) (eval-p t))
  (clrhash (dictionary-table *user-dict*))
  (clrhash (dictionary-table *error-report-dict*))
  (clear-stack *operand-stack*)
  (clear-stack *dict-stack*)
  (clear-stack *graphics-state-stack*)
  (setq *error-cached-opstack* '()
	*error-cached-dictstack* '()
	*error-cached-message* '())
  (setf (graphics-state-device *default-graphics-state*) *null-device*
	(graphics-state-CTM *default-graphics-state*) (device-matrix (graphics-state-device *default-graphics-state*)))
  (let* ((*current-save-level* 0))
    (unwind-protect
	(scan-all stream eval-p)
      (setq *current-save-level* -1)
      (pop-save-state t)))
  nil)

(defun 4scan-all *(&optional (stream *standard-input*) (eval-p t))
  (catch 'STOPPED
    (let* ((*in-stopped* :scan-all))
      (declare (special *in-stopped*))
      (loop
	(let* ((c (scan stream nil eval-p)))
	  (unless c (return *operand-stack*))))))
  (execute (dict-hash "3handleerror*" *error-dict*) t))


(defvar 4*scanning-from-string-p* *nil)
(defvar 4*scanning-file-object-p* *nil)

(defun 4scan* (&optional (stream *standard-input*) recursive-p (eval-p t))
  "2Parsed the next PostScript object from stream, and places it on the *operand-stack*.
  Returns NIL if EOF, non-NIL otherwise.
  If EVAL-P is true, then executable objects (except literal procedures) will be executed
  after being read.*"
  (let* ((character (peek-char t stream nil nil))
	 (object
	   (consing-in-parser-area
	     (case character
	       ((nil) nil)
	       (#\/ (scan-literal-name stream))
	       (#\( (scan-literal-string stream))
	       (#\{ (consing-in-user-area
		      (make-array-object :contents (scan-array stream '--\{-- '--\}-- nil) :%status #b100)))
	       (#\[ (read-char stream) MARK)
	       (#\< (scan-literal-hex-string stream))
	       
	       (#\) (read-char stream) (ps-error "3syntaxerror*" "3too many )'s*"))
	       (#\] (read-char stream) (consing-in-user-area (make-name :contents "]" :%status #b100)))
	       (#\} (read-char stream) (if (eq recursive-p '--\}--) '--\}-- (ps-error "3syntaxerror*" "3too many }'s*")))
	       
	       (#\% (read-line stream nil nil)
		    (setq character (scan stream recursive-p eval-p))
		    nil)
	       (t (scan-name-or-number stream))))))
    (when object
      (check-type object (or number string object dictionary mark (member --\}--)))
      (cond ((and eval-p (object-p object) (object-executable object)
		  (not (executable-array-p object))
		  )
	     ;1; Execute this one.*
	     (execute object nil)
	     ;1; If executing it left an executable object on the top of the stack, then execute that.  And so on.*
;	     (do* ()
;		  ((not (and (stack-list *operand-stack*)
;			     (object-p (stack-top *operand-stack* t))
;			     (object-executable (stack-top *operand-stack* t))
;			     (not (executable-array-p (stack-top *operand-stack* t)))
;			     )))
;	       (execute (stack-pop *operand-stack*) nil))
	     )
	    (t
	     (when *verbose* (format t "3~&push ~A to ~:A *" object *operand-stack*))
	     (stack-push object *operand-stack*))))
    character))


(defun 4scan-array *(stream start-tag end-tag eval-p)
  "2Put down a start-of-array marker, and parse until an end-of-array marker is read.
  Then rip up the part of the stack between the markers, and return an array.
  EVAL-P should be true if we are reading [] arrays, and false if reading {} arrays.*"
  (stack-push start-tag *operand-stack*)	;1 start-of-array marker.*
  (read-char stream)				;1 take off [ or {*
  (loop
    (unless (scan stream end-tag eval-p)
      ;(error "3Premature EOF reading ~:[executable ~;~]array.*" eval-p)
      (ps-error "3syntaxerror*" "3Premature EOF reading ~:[executable ~;~]array.*" eval-p)
      )
    (let* ((obj (stack-top *operand-stack*)))
      (when (eq obj end-tag)
	(stack-pop *operand-stack*)
	(let* ((result '()))
	  (loop
	    (let* ((elt (stack-pop *operand-stack*)))
	      (when (eq elt start-tag) (return))
	      (push elt result)))
	  (return (coerce result 'vector)))))))


(defun 4scan-literal-string* (&optional (stream *standard-input*))
  "2Read and return a PostScript-syntax string.*"
  (unless (char= #\( (read-char stream)) (error "2Expected ( to start parsing a literal string.*"))
  (let* ((do-backslashes (not *scanning-from-string-p*))
	 (string #+TI (sys:get-readstring)
		 #-TI (make-array 20 :element-type 'string-char :fill-pointer t :adjustable t)))
    #+TI (setf (fill-pointer string) 0)
    (do ((level 1))
	(())
      (let ((char (read-char stream nil nil)))
	(case char
	  ((nil) (return string))
	  (#\\ (if do-backslashes
		   (let ((c (scan-character-literal stream)))
		     (when c (vector-push-extend c string)))
		   (vector-push-extend char string)))
	  (t
	   (case char
	     (#\( (incf level))
	     (#\) (when (zerop (decf level)) (return))))
	   (vector-push-extend char string)))))
    (consing-in-user-area
      (make-string-object :contents
			  #+TI (prog1 (copy-seq string) (sys:return-readstring string))
			  #-TI string))))


(defun 4scan-character-literal* (&optional (stream *standard-input*))
  "2Read and return one element of a PostScript-syntax string.*"
  (let ((char (read-char stream nil nil)))
    (cond ((digit-char-p char 8)
	   (let* ((number (digit-char-p char 8))
		  (next (peek-char t stream nil nil)))
	     (when (and next (setq next (digit-char-p next 8)))
	       (read-char stream)
	       (setq number (+ (* number 8) next))
	       
	       (when (and (setq next (peek-char t stream nil nil))
			  (setq next (digit-char-p next 8)))
		 (read-char stream)
		 (setq number (+ (* number 8) next))))
	     
	     (int-char number)))
	  
	  ((char= #\Newline char) nil)
	  (t (case char
	       (#\n #\Newline)
	       (#\r #\Return)
	       (#\t #\Tab)
	       (#\b #\Backspace)
	       (#\f #\Page)
	       (#\\ #\\)
	       (#\( #\()
	       (#\) #\))
	       (t (unread-char char stream)
		  nil))))))

;1;; ## should implement sys:get-readstring for non-Lispms.  Not hard.*

(defun 4scan-literal-name* (&optional (stream *standard-input*))
  "2Read a quoted name.*"
  (unless (char= #\/ (read-char stream)) (error "2Expected / to begin parsing a literal (quoted) name.*"))
  (do ((name #+TI (sys:get-readstring)
	     #-TI (make-array 10 :element-type 'string-char :fill-pointer t :adjustable t)))
      ((special-p (peek-char nil stream nil #\Space))
       (consing-in-user-area
	 #+TI (make-name :contents (prog1 (copy-seq name) (sys:return-readstring name)))
	 #-TI (make-name :contents name)))
    (vector-push-extend (read-char stream) name)))

(defun 4numberify* (string)
  "2If the string can be parsed as a PostScript-syntax number, return the number.  Else NIL.*"
  (case (length string)
    (0 nil)
    (1 (digit-char-p (char string 0) 10))
    (t
     (let (minusp)
       (when (or (setq minusp (char= #\- (char string 0)))
		 (char= #\+ (char string 0))
		 (char= #\. (char string 0))
		 (digit-char-p (char string 0) 10))
	 (multiple-value-bind (n end) (parse-integer string :junk-allowed t :radix 10)
	   ;1; For the 5.5, -.5* cases.*
	   (when (and (null n) (char= #\. (char string end))) (setq n 0))
	   (cond ((null n) nil)
		 ;1; Simple integer.*
		 ((= end (length string))
		  n)
		 ;1; Floating point, or exponential.*
		 ((char= #\. (char string end))
		  (setq n (abs n))
		  ;1; For the 5"123."* case.*
		  (when (= end (1- (length string))) (return-from 4numberify* (if minusp (- n) n)))
		  (multiple-value-bind (n2 end2) (parse-integer string :junk-allowed t :start (1+ end) :radix 10)
		    (when n2
		      (if  (= end2 (length string))
			   ;1; 51.23, -0.5**
			   (if minusp
			       (- (+ n (float (/ n2 (expt 10 (- end2 end 1))))))
			       (+ n (float (/ n2 (expt 10 (- end2 end 1))))))
			   ;1; 51.23e7, -0.1e5**
			   (when (char-equal #\e (char string end2))
			     (multiple-value-bind (n3 end3) (parse-integer string :junk-allowed t :start (1+ end2) :radix 10)
			       (when (and n3 (= end3 (length string)))
				 (* (+ n (float (/ n2 (expt 10 (- end2 end 1)))))
				    (if minusp
					(- (expt 10 n3))
					(expt 10 n3))))))
			   ))))
		 
		 ((char-equal #\e (char string end))
		  ;1; 513e7**
		  (multiple-value-bind (n2 end2) (parse-integer string :junk-allowed t :start (1+ end) :radix 10)
		    (when (and n2 (= end2 (length string)))
		      (* (float n) (expt 10 n2)))))
		 
		 ((char= #\# (char string end))
		  ;1; 516#FFFE**
		  (when (<= 2 (abs n) 36)
		    (multiple-value-bind (n2 end2) (parse-integer string :junk-allowed t :start (1+ end) :radix (abs n))
		      (when (and n2 (= end2 (length string)))
			;1; 5-16#FFFE**
			(when (minusp n) (setq n (- n) n2 (- n2)))
			n2))))
		 (t nil))))))))


(defun 4scan-name-or-number* (&optional (stream *standard-input*))
  "2Read a number or non-quoted name.  Returns a VARIABLE object or a number.*"
  (do ((string #-TI (make-array 10 :element-type 'string-char :fill-pointer t :adjustable t)
	       #+TI (sys:get-readstring))
       (done-once nil t))
      ((special-p (peek-char nil stream (not done-once) #\Space))
       (when (zerop (length string))
	 (ps-error "3syntaxerror*" "3Invalid null name.*"))
       (or (numberify string)
	   (let ((name (consing-in-user-area
			 #+TI (make-name :contents (prog1 (copy-seq string) (sys:return-readstring string)))
			 #-TI (make-name :contents string))))
	     (setf (object-executable name) t)
	     name)))
    (vector-push-extend (read-char stream) string)))


(defun 4scan-literal-hex-string* (&optional (stream *standard-input*))
  "2Reads a PostScript-syntax hex-string.*"
  (unless (char= #\< (read-char stream)) (error "2Expected < to begin reading a literal hex string.*"))
  (do ((string (make-array 0 :element-type 'string-char :fill-pointer t :adjustable t))
       (char (read-char stream) (read-char stream)))
      ((char= char #\>)
       string)
    (let* ((number (digit-char-p char 16)))
      (when number
	(let* ((next (peek-char t stream nil nil)))
	  (cond ((and next (setq next (digit-char-p next 16)))
		 (read-char stream)
		 (setq number (+ (* number 16) next)))
		(t (setq number (* number 16)))))
	(vector-push-extend (int-char number) string)))))


;1;; 5The Evaluator.**

(defvar 4*error-cached-opstack* *'() "2EXECUTE stores a pointer to the operand stack here before execution for use by the error handler.*")
(defvar 4*error-cached-dictstack* *'() "2EXECUTE stores a pointer to the dict stack here before execution for use by the error handler.*")
(defvar 4*error-cached-message* *'() "2PS-ERROR stores an error message here for use by the error reporter.*")

(defun 4execute *(object &optional execute-procs-p)
  "2Execute the given object.
 If it is a variable, look it up and execute the result.
 If it is an executable array (or builtin function), execute each element in turn.
 Otherwise, simply return it.*"
  (let* ((*current-object* object))
    (declare (special *current-object*))
    
    (locally (declare (special *within-eh*))
      (unless (and (boundp '*within-eh*) *within-eh*)
	(setq *error-cached-opstack* (stack-list *operand-stack*)
	      *error-cached-dictstack* (stack-list *dict-stack*)
	      )))
;    (format t "3~&STORING opstack ~s*" *error-cached-opstack*)
    
    (cond ((and (object-p object)
		(or (eq execute-procs-p :force)
		    (object-executable object)))
	   (check-execable object)
	   (typecase object
	     (NAME
	      (let* ((val (dict-stack-hash (name-string object) *dict-stack*)))
		(unless val (ps-error "3undefined*"))
		(when (eq val :undefined)
		  (ps-error "3unregistered*" "3builtin procedure '~A' has not been implemented.*" object))
		(execute val t)))
	     
	     (OPERATOR
	      (when *verbose*
		(format t "3~&invoke op: ~A ~A *" object *operand-stack*))
	      (if (eq (operator-function object) :undefined)
		  (ps-error "3unregistered*" "3builtin procedure '~A' has not been implemented.*" object)
		  (funcall (operator-function object)))
	      (when *verbose* (format t "3~&stack:     ~A *" *operand-stack*))
	      nil)
	     
	     (STRING-OBJECT
	      (when *verbose* (format t "3~&invoke string: ~A*" object))
	      (with-input-from-string (stream (string-object-contents object))
		(let* ((*scanning-from-string-p* object))
		  (scan-all stream)))
	      nil)
	     
	     (ARRAY-OBJECT			;1 *EXECUTABLE-ARRAY
	      (cond (execute-procs-p
		     (when *verbose*
		       (format t "3~&execute: ~A ~A *" object *operand-stack*))
		     (let* ((array (array-object-contents object)))
		       (dotimes (i (length array))
			 (let ((obj (aref array i)))
			   ;(if (executable-array-p obj)
			    ;   (stack-push obj *operand-stack*)
			       (execute obj nil)
			     ;  )
			   ))
		       (when *verbose* (format t "3~&stack:  ~A *" *operand-stack*))))
		    (t (stack-push object *operand-stack*)))
	      nil)
	     
	     (FILE-OBJECT
	      (let* ((*scanning-file-object-p* object))
		(scan-all (file-object-stream object) t))
	      nil)
	     
	     (t (stack-push object *operand-stack*))))
	  (t (stack-push object *operand-stack*)))))


;1;; The Error Handler.*

(defvar 4*error-report-dict* *(make-dictionary 20) "2The5 $error* dictionary, used internally for reporting errors.*")

(defun 4store-error-info *(errorname command ostack estack dstack &optional error-message)
  "2Store the given info into the 5$error* dict.*"
  (setf (dict-hash "3newerror*" *error-report-dict*) t
	(dict-hash "3errorname*" *error-report-dict*) errorname
	(dict-hash "3command*" *error-report-dict*) command
	(dict-hash "3ostack*" *error-report-dict*) ostack
	(dict-hash "3estack*" *error-report-dict*) estack
	(dict-hash "3dstack*" *error-report-dict*) dstack
	(dict-hash "3emessage*" *error-report-dict*) error-message	;1 ## This is my own nonstandard extension.*
	))


(defvar 4*signal-ps-errors* *nil "2If this is T, then PS Errors call #'ERROR; otherwise, they just print and abort.*")

(defun 4handleerror *()
  "2The default action of the handleerror operator.*"
  (when (dict-hash "3newerror*" *error-report-dict*)
    (let* ((errorname (dict-hash "3errorname*" *error-report-dict*))
	   (message (dict-hash "3emessage*" *error-report-dict*))
	   (command (dict-hash "3command*" *error-report-dict*))
	   (opstack (dict-hash "3ostack*" *error-report-dict*))
	   (evalstack (dict-hash "3estack*" *error-report-dict*))
	   (dictstack (dict-hash "3dstack*" *error-report-dict*))
	   (reporter (if *signal-ps-errors*
			 #'error
			 #'(lambda (&rest args)
			     (fresh-line)
			     (apply #'format *debug-io* args)))))
      (funcall reporter "3%%[ Error: ~A; OffendingCommand: ~A ]%%~%~*
			3 ~:[~;%%~11t~:*~A~%~]~*
			3 %% OStack: ~A~%~*
			3 %% EStack: ~A~%~*
			3 %% DStack: [--systemdict-- --userdict--~A*"
	       (if (string-object-p errorname) (string-object-contents errorname) errorname)
	       (if (string-object-p command) (string-object-contents command)
		   (if (operator-p command) (operator-name command) command))
	       (if (string-object-p message) (string-object-contents message) message)
	       (if opstack   (with-output-to-string (*standard-output*) (ps-== opstack))   "3[]*")
	       (if evalstack (with-output-to-string (*standard-output*) (ps-== evalstack)) "3[]*")
	       (if (and dictstack (plusp (length (array-object-contents dictstack))))
		   (let* ((s (with-output-to-string (*standard-output*) (ps-== dictstack))))
		     (setf (char s 0) #\Space)
		     s)
		   "3]*")
	       ))))

(defun 4default-errorhandler *(errorname)
  "2Invoked by the operators in errordict - do not call this directly.*"
  (declare (special *within-eh*))
  (if (and (boundp '*within-eh*)
	   (and *within-eh* (not (eq *within-eh* :from-lisp))))
      (error "3PostScript error inside the Error Handler.  Error ~S; OpStack: ~A*" errorname *operand-stack*)
      (let* ((*within-eh* t))
	(declare (special *within-eh*))
	(let* ((error-object (stack-pop *operand-stack*))
	       (opstack   (consing-in-user-area
			    (make-array-object :contents (coerce (the list *error-cached-opstack*)   'vector))))
	       (dictstack (consing-in-user-area
			    (make-array-object :contents (coerce (the list *error-cached-dictstack*) 'vector))))
	       (error-message *error-cached-message*)
	       )
	  (setf (array-object-contents opstack)   (nreverse (the vector (array-object-contents opstack))))
	  (setf (array-object-contents dictstack) (nreverse (the vector (array-object-contents dictstack))))
	  (store-error-info errorname error-object opstack nil dictstack error-message)
	  (locally (declare (special *in-stopped*))
		   (unless (and (boundp '*in-stopped*) *in-stopped*) (ps-error "3invalidexit*")))
	  (throw 'STOPPED nil)))))


; %%[ Error: error; OffendingCommand: operator ]%%
; %%[ PrinterError: reason ]%%
; see printererror proc in statusdict
; %%[ Flushing: rest of job (to end-of-file) will be ignored ]%%
; %%[ exitserver: permanent state may be changed ]%%

(eval-when (load eval compile)
(defvar 4*all-ps-errors**
	'("3dictfull*"
	  "3dictstackoverflow*"		;1 too many begins*
	  "3dictstackunderflow*"	;1 too many ends*
	  "3execstackoverflow*"
	  "3interrupt*"			;1 control-C typed*
	  "3invalidaccess*"		;1 read-permission, etc*
	  "3invalidexit*"		;1 exit not in loop*
	  "3invalidfileaccess*"		;1 bad file-access string*
	  "3invalidfont*"		;1 bad font name or dict*
	  "3invalidrestore*"
	  "3ioerror*"
	  "3limitcheck*"			;1 implementation limit exceeded*
	  "3nocurrentpoint*"
	  "3rangecheck*"
	  "3stackoverflow*"
	  "3stackunderflow*"
	  "3syntaxerror*"
	  "3timeout*"
	  "3typecheck*"
	  "3undefined*"			;1 name unknown*
	  "3undefinedfilename*"		;1 file not found*
	  "3undefinedresult*"		;1 math NaN or overflow*
	  "3unmatchedmark*"		;1 no mark on stack*
	  "3unregistered*"		;1 internal*
	  "3VMerror*"			;1 out of memory*
	  ))
 ) ;1closes eval-when*

(defmacro 4define-errorhandler *(name)
  (let ((name (if (stringp name) name (string-downcase (symbol-name name)))))
    `(let* ((fn #-TI #'(lambda () (default-errorhandler ',name))
		#+TI #'(named-lambda ,(intern (string-append "3%ps-error-*" name)) ()
				     (default-errorhandler ',name)))
	    (op (consing-in-system-area (make-operator :name ',name :function fn))))
       (setf (object-executable op) t)
       (setf (dict-hash ',name *error-dict*) op)
       ',name)))


(macrolet ((define-errorhandlers ()
	     `(progn
		,@(mapcar #'(lambda (x) `(define-errorhandler ,x))
			  *all-ps-errors*))))
  (define-errorhandlers))

(let ((op (consing-in-system-area
	    (make-operator :name "3handleerror*" :function #'(lambda () (handleerror))))))
  (setf (object-executable op) t)
  (setf (dict-hash "3handleerror*" *error-dict*) op)
  )

(defun 4ps-error *(errorname &optional error-message &rest format-args)
  "2Call this to signal a PostScript error from Lisp code.*"
  (declare (special *within-eh*))
  (when (symbolp errorname) (setq errorname (string-downcase (string errorname))))
  (if (and (boundp '*within-eh*)
	   (and *within-eh* (not (eq *within-eh* :from-lisp))))
      (error "3PostScript error inside the Error Handler.  Error ~S; OpStack: ~A*" errorname *operand-stack*)
      (let* ((op (dict-hash errorname *error-dict*)))
	(assert op () "3No error handler for ~S*" errorname)
	(assert (and (object-executable op) (object-execable op)) () "3Error handler ~S is not executable!*" op)
	(locally (declare (special *current-object*))
		 (assert (and (boundp '*current-object*) *current-object*) ()
			 "3PS-ERROR called not within the scope of EXECUTE.*")
		 (stack-push *current-object* *operand-stack*))
	(setq *error-cached-message* (if error-message
					 (apply #'format nil error-message format-args)
					 *error-cached-message*))
	(execute op t))))



;1;;; 5The Operator Definitions.**

;1;; 5Stack operators**

(define-operator 4pop* (stack-pop *operand-stack*))

(define-operator 4exch*
  (let* ((a (stack-pop *operand-stack*))
	 (b (stack-pop *operand-stack*)))
    (stack-push a *operand-stack*)
    (stack-push b *operand-stack*)))

(define-operator 4dup* (stack-push (stack-top *operand-stack*) *operand-stack*))

(define-operator 4index*
  (let* ((n (stack-pop *operand-stack* 'integer))
	 (obj (nth n (stack-list *operand-stack*))))
    (when (< (stack-length *operand-stack*) n) (ps-error "3stackunderflow*"))
    (stack-push obj *operand-stack*)))

(defun 4roll *(list length shift)
  (cond ((or (zerop shift) (zerop length)) nil)
	(t
	 (let* ((tmp (make-array length)))
	   (do* ((i 0 (1+ i))
		 (list list (cdr list)))
		((= i length))
	     (setf (aref tmp (mod (+ i shift) length)) (car list)))
	   (setf (car list) (aref tmp 0))
	   (do* ((i 1 (1+ i))
		 (list list (cdr list)))
		((= i length))
	     (setf (cadr list) (aref tmp i))))))
  list)


(define-operator 4roll*
  (let* ((shift (stack-pop *operand-stack* 'integer))
	 (length (stack-pop *operand-stack* 'integer)))
    (setf (stack-list *operand-stack*) (roll (stack-list *operand-stack*) length shift))))

(define-operator 4clear* (clear-stack *operand-stack*))
(define-operator 4count* (stack-push (stack-length *operand-stack*) *operand-stack*))
(define-operator 4mark* (stack-push MARK *operand-stack*))

(define-operator 4cleartomark* (do () ((eq MARK (stack-pop *operand-stack*)))))
(define-operator 4counttomark* (stack-push (or (position MARK (stack-list *operand-stack*) :test #'eq)
					       (ps-error "3unmatchedmark*"))
					   *operand-stack*))

;1;; 5Arithmetic operators**

(defun 4div *(x y)
  (if (and (integerp x) (integerp y))
      (let* ((x (/ x y)))
	(if (= 1 (denominator x)) x (float x)))
      (float (/ x y))))

(define-simple-operator 4add* (number number) +)
(define-binary-operator 4div* (number number)4 *div)
(define-binary-operator 4idiv* (number number)4 *floor)
(define-binary-operator 4mod* (number number) mod)
(define-simple-operator 4mul* (number number) *)
(define-binary-operator 4sub* (number number) -)
(define-simple-operator 4abs* (number) abs)
(define-simple-operator 4neg* (number) -)
(define-simple-operator 4ceiling* (number) ceiling)
(define-simple-operator 4round* (number) round)
(define-simple-operator 4truncate* (number) truncate)
(define-simple-operator 4sqrt* (number) sqrt)
(define-simple-operator 4atan* (number) deg-atan)
(define-simple-operator 4cos* (number) deg-cos)
(define-simple-operator 4tan* (number) deg-tan)
(define-binary-operator 4exp* (number number) expt)
(define-simple-operator 4ln* (number) log)		;1 <---- log base e*
(define-simple-operator 4log* (number) log10)		;1 <---- log base 10*


(defvar 4*rand-seed** (random most-positive-fixnum))

(define-operator 4rand* (stack-push (random most-positive-fixnum) *operand-stack*))

;1; ## These don't work.*
(define-operator 4srand* (setq *rand-seed* (stack-pop *operand-stack* 'integer)))
(define-operator 4rrand* (stack-push *rand-seed* *operand-stack*))


;1;; 5Array operators**

(define-operator 4array*
  (stack-push (consing-in-user-area
		(make-array-object :contents (make-array (stack-pop *operand-stack* 'integer) :initial-element 0)))
	      *operand-stack*))

(define-operator 4"\["* (stack-push MARK *operand-stack*))	;1 This is redundant - happens in scanner too.*

(define-operator 4"\]"*
  (let* ((n (or (position MARK (stack-list *operand-stack*) :test #'eq)
		(ps-error "3unmatchedmark*")))
	 (a  (consing-in-user-area (make-array n)))
	 (aa (consing-in-user-area (make-array-object :contents a))))
    (dotimes (i n) (setf (aref a (- n i 1)) (stack-pop *operand-stack*)))
    (stack-pop *operand-stack*) ;1 pop the mark*
    (stack-push aa *operand-stack*)))

(define-operator 4length*
  (let* ((obj (stack-pop *operand-stack* '(or arefable dictionary))))
    (stack-push (if (dictionary-p obj)
		    (dict-count obj)
		    (length (array-object-contents obj)))
		*operand-stack*)))

(define-operator 4getinterval*
  (let* ((length (stack-pop *operand-stack* 'integer))
	 (index (stack-pop *operand-stack* 'integer))
	 (array (stack-pop *operand-stack* 'arefable))
	 (contents (array-object-contents array))
	 (subarray (consing-in-user-area
		     (make-array length :element-type (array-element-type contents)
				 :displaced-to contents :displaced-index-offset index))))
    (check-readable array)
    (stack-push (consing-in-user-area
		  (if (string-object-p array)
		      (make-string-object :%status (string-object-%status array) :contents subarray)
		      (make-array-object :%status (array-object-%status array) :contents subarray)))
		*operand-stack*)))

(define-operator 4putinterval*
  (let* ((array2 (stack-pop *operand-stack* 'arefable))
	 (index  (stack-pop *operand-stack* 'integer))
	 (array1 (stack-pop *operand-stack* (type-of array2)))
	 (contents1 (array-object-contents array1))
	 (contents2 (array-object-contents array2)))
    (check-readable array2)
    (check-writable array1)
    (dotimes (i (length contents2))
	     (setf (aref contents1 (+ i index)) (aref contents2 i)))))

(define-operator 4aload*
  (let* ((array (stack-pop *operand-stack* 'arefable))
	 (contents (array-object-contents array)))
    (check-readable array)
    (dotimes (i (length contents)) (stack-push (aref contents i) *operand-stack*))))

(define-operator 4astore*
  (let* ((array (stack-pop *operand-stack* 'arefable))
	 (contents (array-object-contents array))
	 (l (length contents)))
    (check-writable array)
    (dotimes (i l) (setf (aref contents (- l i 1)) (stack-pop *operand-stack*)))
    (stack-push array *operand-stack*)))

;1;; 5Dictionary operators**

(define-operator 4dict*
  (stack-push (consing-in-user-area (make-dictionary (stack-pop *operand-stack* 'integer))) *operand-stack*))

(define-operator 4maxlength* (stack-push (dictionary-max-entries (stack-pop *operand-stack* 'dictionary)) *operand-stack*))
(define-operator 4begin* (stack-push (stack-pop *operand-stack* 'dictionary) *dict-stack*))
(define-operator 4end* (stack-pop *dict-stack*))

(define-operator 4def*
  (let* ((val (stack-pop *operand-stack*))
	 (key (stack-pop *operand-stack* 'name)))
    (setf (dict-stack-hash key *dict-stack*) val)))

(define-operator 4load*
  (stack-push (or (dict-stack-hash (stack-pop *operand-stack* 'stringable) *dict-stack*)
		  (ps-error "3undefined*"))
	      *operand-stack*))

(define-operator 4store*
  (let* ((value (stack-pop *operand-stack*))
	 (key (stack-pop *operand-stack* 'stringable)))
    (setf (dict-stack-hash key *dict-stack*) value)))


(define-operator 4known*
  (stack-push (if (dict-hash (stack-pop *operand-stack* 'stringable) (stack-pop *operand-stack* 'dictionary))
		  T NIL)
	      *operand-stack*))

(define-operator 4where*
  (let* ((key (stack-pop *operand-stack* 'stringable))
	 (-noval- '(()))
	 (dict (block DONE
		 (dolist (dict (stack-list *dict-stack*))
		   (unless (eq (dict-hash key dict -noval-) -noval-) (return-from DONE dict)))
		 (unless (eq (dict-hash key *user-dict* -noval-) -noval-) (return-from DONE *user-dict*))
		 (unless (eq (dict-hash key *system-dict* -noval-) -noval-) (return-from DONE *system-dict*))
		 nil)))
    (when dict (stack-push dict *operand-stack*))
    (stack-push (and dict t) *operand-stack*)))

(define-operator 4countdictstack*
  (stack-push (+ 2 (stack-length *dict-stack*)) *operand-stack*))

(define-operator 4dictstack*
  (let* ((array (stack-pop *operand-stack* 'basic-array))
	 (contents (array-object-contents array))
	 (list (stack-list *dict-stack*))
	 (i (+ 2 (length list)))
	 (subcontents (consing-in-user-area (make-array i :displaced-to contents)))
	 (subarray (consing-in-user-area (make-array-object :%status (array-object-%status array) :contents subcontents))))
    (check-writable array)
    (dolist (dict list)
      (setf (aref contents (decf i)) dict))
    (setf (aref contents 1) *user-dict*
	  (aref contents 0) *system-dict*)
    (stack-push subarray *operand-stack*)))


;1;; 5String Operators**

(define-operator 4string*
  (stack-push (consing-in-user-area
		(make-string-object :contents (make-string (stack-pop *operand-stack* 'integer))))
	      *operand-stack*))

(define-operator 4anchorsearch*
  (let* ((seek (string-object-contents (stack-pop *operand-stack* 'basic-string)))
	 (string (string-object-contents (stack-pop *operand-stack* 'basic-string))))
    (check-readable seek)
    (check-readable string)
    (cond ((string= seek string :end2 (length seek))
	   (let* ((match (consing-in-user-area
			   (make-string-object
			     :contents (make-array (length seek) :element-type 'string-char :displaced-to string))))
		  (post (consing-in-user-area
			  (make-string-object
			    :contents (make-array (- (length string) (length seek)) :element-type 'string-char
						  :displaced-to string
						  :displaced-index-offset (length seek))))))
	     (stack-push post *operand-stack*)
	     (stack-push match *operand-stack*)
	     (stack-push T *operand-stack*)))
	  (t
	   (stack-push string *operand-stack*)
	   (stack-push NIL *operand-stack*)))))


;(defun 4junk *(x y)
;  (compiler:dont-optimize
;    (search (the simple-string x) (the simple-string y) :test #'char=)))


(define-operator 4search*
  (let* ((seek (stack-pop *operand-stack* 'basic-string))
	 (string (stack-pop *operand-stack* 'basic-string))
	 (pos #+TI (compiler:dont-optimize  ;1 COMPILER BUG!*
		     (search (string-object-contents seek) (string-object-contents string) :test #'char=))
	      #-TI (pos (search (string-object-contents seek) (string-object-contents string) :test #'char=))))
    (check-readable seek)
    (check-readable string)
    (cond (pos
	   (let* ((match (consing-in-user-area
			   (make-string-object
			     :contents (make-array (length (string-object-contents seek))
						   :element-type 'string-char :displaced-to (string-object-contents string)
						   :displaced-index-offset pos))))
		  (post (consing-in-user-area
			  (make-string-object
			    :contents (make-array (- (length (string-object-contents string))
						     (length (string-object-contents seek))
						     pos)
						  :element-type 'string-char :displaced-to (string-object-contents string)
						  :displaced-index-offset (+ pos (length (string-object-contents seek)))))))
		  (pre  (consing-in-user-area
			  (make-string-object
			    :contents (make-array pos :element-type 'string-char
						  :displaced-to (string-object-contents string))))))
	     (stack-push post *operand-stack*)
	     (stack-push match *operand-stack*)
	     (stack-push pre *operand-stack*)
	     (stack-push T *operand-stack*)))
	  (t
	   (stack-push string *operand-stack*)
	   (stack-push NIL *operand-stack*)))))


;1;; 5Relational, Boolean, and Bitwise operators.**

(define-operator 4eq*
  (let* ((arg1 (stack-pop *operand-stack*))
	 (arg2 (stack-pop *operand-stack*)))
    (check-readable arg1)
    (check-readable arg2)
    (stack-push (and (or (eql arg1 arg2)
			 (and (numberp arg1) (numberp arg2) (= arg1 arg2))
			 (and (string-object-p arg1) (string-object-p arg2)
			      (string= (string-object-contents arg1) (string-object-contents arg2))))
		     t)
		*operand-stack*)))

(define-operator 4ne*
  (let* ((arg1 (stack-pop *operand-stack*))
	 (arg2 (stack-pop *operand-stack*)))
    (check-readable arg1)
    (check-readable arg2)
    (stack-push (and (and (not (eql arg1 arg2))
			  (or (not (numberp arg1)) (not (numberp arg2)) (/= arg1 arg2))
			  (or (not (string-object-p arg1))
			      (not (string-object-p arg2))
			      (string-not-equal (string-object-contents arg1) (string-object-contents arg2))))
		     t)
		*operand-stack*)))

(define-operator 4gt*
  (let* ((x (stack-pop *operand-stack* '(or number stringable)))
	 (y (stack-pop *operand-stack* (if (numberp x) 'number 'stringable))))
    (stack-push (and (if (numberp x) (> x y) (string> (string-object-contents x) (string-object-contents y)))
		     t)
		*operand-stack*)))

(define-operator 4ge*
  (let* ((x (stack-pop *operand-stack* '(or number stringable)))
	 (y (stack-pop *operand-stack* (if (numberp x) 'number 'stringable))))
    (stack-push (and (if (numberp x) (>= x y) (string>= (string-object-contents x) (string-object-contents y)))
		     T)
		*operand-stack*)))

(define-operator 4lt*
  (let* ((x (stack-pop *operand-stack* '(or number stringable)))
	 (y (stack-pop *operand-stack* (if (numberp x) 'number 'stringable))))
    (stack-push (and (if (numberp x) (< x y) (string< (string-object-contents x) (string-object-contents y)))
		     T)
		*operand-stack*)))

(define-operator 4le*
  (let* ((x (stack-pop *operand-stack* '(or number stringable)))
	 (y (stack-pop *operand-stack* (if (numberp x) 'number 'stringable))))
    (stack-push (and (if (numberp x) (<= x y) (string>= (string-object-contents x) (string-object-contents y)))
		     T)
		*operand-stack*)))


(define-operator 4and*
  (let* ((x (stack-pop *operand-stack* '(or integer boolean))))
    (stack-push (if (numberp x)
		    (logand x (stack-pop *operand-stack* 'integer))
		    (and x (stack-pop *operand-stack* 'boolean) t))
		*operand-stack*)))

(define-operator 4not*
  (let* ((x (stack-pop *operand-stack* '(or integer boolean))))
    (stack-push (if (numberp x) (lognot x) (not x))
		*operand-stack*)))

(define-operator 4or*
  (let* ((x (stack-pop *operand-stack* '(or integer boolean))))
    (stack-push (if (numberp x)
		    (logior x (stack-pop *operand-stack* 'integer))
		    (and (or x (stack-pop *operand-stack* 'boolean)) t))
		*operand-stack*)))

(define-operator 4xor*
  (let* ((x (stack-pop *operand-stack* '(or integer boolean)))
	 (y (stack-pop *operand-stack* (if (numberp x) 'integer 'boolean))))
    (stack-push (if (numberp x)
		    (logxor x y)
		    (and (or x y) (not (and x y)) t))
		*operand-stack*)))

(define-operator 4true* (stack-push 'T *operand-stack*))
(define-operator 4false* (stack-push 'NIL *operand-stack*))

(define-binary-operator 4bitshift* (integer integer)4 *ash)


;1;; 5Control Operators**

(define-operator 4exec* (execute (stack-pop *operand-stack*) :force))

(define-operator 4if*
  (let* ((then (stack-pop *operand-stack* 'executable-array))
	 (cond (stack-pop *operand-stack* 'boolean)))
    (when cond (execute then t))))

(define-operator 4ifelse*
  (let* ((else (stack-pop *operand-stack* 'executable-array))
	 (then (stack-pop *operand-stack* 'executable-array))
	 (cond (stack-pop *operand-stack* 'boolean)))
    (if cond
	(execute then t)
	(execute else t))))


(define-operator 4for*
  (let* ((proc (stack-pop *operand-stack* 'executable-array))
	 (limit (stack-pop *operand-stack* 'number))
	 (incr (stack-pop *operand-stack* 'number))
	 (init (stack-pop *operand-stack* 'number))
	 (backwards (> init limit)))
    (catch 'LOOP
      (do* ((n init (+ n incr)))
	   ((if backwards (< n limit) (> n limit)))
	(stack-push n *operand-stack*)
	(execute proc t)))))


(define-operator 4repeat*
  (let* ((proc (stack-pop *operand-stack* 'executable-array)))
    (catch 'LOOP
      (let* ((*in-loop* :repeat))
	(declare (special *in-loop*))
	(dotimes (i (stack-pop *operand-stack* 'integer)) (execute proc t))))))

(define-operator 4loop*
  (let* ((proc (stack-pop *operand-stack* 'executable-array)))
    (check-execable proc)
    (catch 'LOOP
      (let* ((*in-loop* :loop))
	(declare (special *in-loop*))
	(loop (execute proc t))))))

(define-operator 4exit*
  (locally (declare (special *in-loop*))
    (unless (and (boundp '*in-loop*) *in-loop*)
      (ps-error "3invalidexit*")))
  (throw 'LOOP nil))

(define-operator 4stop*
  (locally (declare (special *in-stopped*))
    (unless (and (boundp '*in-stopped*) *in-stopped*) (ps-error "3invalidexit*")))
  (throw 'STOPPED nil))


;1;; 5Type, Attribute, and Conversion operators.**

(define-operator 4type*
  (let* ((thing (stack-pop *operand-stack*)))
    (stack-push (consing-in-user-area
		  (make-name :contents
		    (typecase thing
		      (stack "3stacktype*")
		      (dictionary "3dicttype*")
		      (operator "3operatortype*")
		      (name "3nametype*")
		      (string-object "3stringtype*")
		      ;(executable-array "3arraytype*")
		      (array-object "3arraytype*")
		      (file-object "3filetype*")
		      (font-ID "3fonttype*")
		      (save "3savetype*")
		      (integer "3integertype*")
		      (real "3realtype*")
		      (mark "3marktype*")
		      (boolean "3booleantype*")
		      ;1 *(ps-null "3nulltype*")
		      (t "3-invalidtype-*"))
		    :%status #b100))
		*operand-stack*)))

(defun 4copy-any-object *(x)
  (typecase x
    (stack (copy-stack x))
    (dictionary (copy-dictionary x))
    (operator (copy-operator x))
    (name (copy-name x))
    (string-object (copy-string-object x))
    ;(executable-array (copy-executable-array x))
    (array-object (copy-array-object x))
    (file-object (copy-file-object x))
    (font-ID "3fonttype*")
    (save (copy-save x))
    ;1 *(ps-null "3nulltype*")
    (t x)))

(define-operator 4cvlit*
  (let* ((copy (consing-in-user-area (copy-any-object (stack-pop *operand-stack*)))))
    (setf (object-executable copy) nil)
    (stack-push copy *operand-stack*)))

(define-operator 4cvx*
  (let* ((copy (consing-in-user-area (copy-any-object (stack-pop *operand-stack*)))))
    (check-execable copy)
    (setf (object-executable copy) t)
    (stack-push copy *operand-stack*)))

(define-operator 4xcheck*
  (stack-push (object-executable (stack-pop *operand-stack*)) *operand-stack*))

(define-operator 4executeonly*
  (let* ((copy (consing-in-user-area (copy-any-object (stack-pop *operand-stack* 'arefable)))))
    (check-execable copy)
    (setf (object-status copy) :execute-only)
    (stack-push copy *operand-stack*)))

(define-operator 4noaccess*
  (let* ((obj (stack-pop *operand-stack* '(or arefable dictionary)))
	 (copy (if (dictionary-p obj) obj (consing-in-user-area (copy-any-object obj)))))
    (check-execable obj)
    (setf (object-status copy) :none)
    (stack-push copy *operand-stack*)))

(define-operator 4readonly*
  (let* ((obj (stack-pop *operand-stack* '(or arefable dictionary)))
	 (copy (if (dictionary-p obj) obj (consing-in-user-area (copy-any-object obj)))))
    (check-readable obj)
    (setf (object-status copy) :read-only)
    (stack-push copy *operand-stack*)))

(define-operator 4rcheck*
  (let* ((status (object-status (stack-pop *operand-stack*)))
	 (readable (not (member status '(:exec-only :none) :test #'eq))))
    (stack-push readable *operand-stack*)))

(define-operator 4wcheck*
  (let* ((status (object-status (stack-pop *operand-stack*)))
	 (writable (eq status :unlimited)))
    (stack-push writable *operand-stack*)))

(define-operator 4cvi*
  (let* ((obj (stack-pop *operand-stack* '(or number stringable))))
    (check-readable obj)
    (stack-push (truncate (cond ((numberp obj) obj)
				(t (or (numberify obj) (ps-error "3typecheck*")))))
		*operand-stack*)))

(define-operator 4cvn*
  (stack-push (consing-in-user-area
		(make-name :contents (string-object-contents (stack-pop *operand-stack* 'basic-string))))
	      *operand-stack*))

(define-operator 4cvr*
  (let* ((obj (stack-pop *operand-stack* '(or number basic-string))))
    (check-readable obj)
    (stack-push (float (cond ((numberp obj) obj)
			     (t (or (numberify obj) (ps-error "3typecheck*")))))
		*operand-stack*)))

(define-operator 4cvrs*
  (let* ((string (stack-pop *operand-stack* 'basic-string))
	 (radix (stack-pop *operand-stack* 'integer))
	 (num (stack-pop *operand-stack* 'integer))
	 (tmpstring (write-to-string num :base radix))
	 (substring (consing-in-user-area
		      (make-array (length tmpstring) :element-type 'string-char
				  :displaced-to (string-object-contents string)))))
    (check-writable string)
    (replace substring tmpstring)
    (stack-push (consing-in-user-area (make-string-object :contents substring))
		*operand-stack*)))

(define-operator 4cvs*
  (let* ((thing (stack-pop *operand-stack*))
	 (string (stack-pop *operand-stack* 'basic-string))
	 (tmpstring (consing-in-user-area
		      (typecase thing
			(string-object
			 (copy-seq (string-object-contents thing)))
			(number
			 (princ-to-string thing))
			((member t) (copy-seq "3true*"))
			(null (copy-seq "3false*"))
			(operator (copy-seq (operator-name thing)))
			(t (copy-seq "3--nostringval--*")))))
	 (substring (consing-in-user-area
		      (make-array (length tmpstring) :element-type 'string-char
				  :displaced-to (string-object-contents string)))))
    (and (object-p thing) (check-readable thing))
    (check-writable string)
    (when (< (length (string-object-contents string)) (length tmpstring)) (ps-error "3rangecheck*"))
    (replace substring tmpstring)
    (stack-push (consing-in-user-area (make-string-object :contents substring)) *operand-stack*)))


;1;; 5File Operators**

(define-operator 4flush* (force-output *debug-io*))
(define-operator 4print* (write-string (string-object-contents (stack-pop *operand-stack* 'basic-string)) *debug-io*))

(define-operator 4file*
  (let* ((access (string-object-contents (stack-pop *operand-stack* 'string-object)))
	 (filename (stack-pop *operand-stack* 'string-object))
	 (direction (cond ((string-equal access "3r*") :input)
			  ((string-equal access "3w*") :output)
			  (t (ps-error "3invalidfileaccess*"
				       "3Invalid open mode ~S - should be \"r\" or \"w\".*" access))))
	 (stream (open filename :direction direction :version :newest)))
    (stack-push (consing-in-user-area (make-file-object :stream stream))
		*operand-stack*)))

(define-operator 4closefile*
  (let* ((file (stack-pop *operand-stack* 'file-object)))
    (close (file-object-stream file))
    (setf (file-object-stream file) nil)))

(define-operator 4read*
  (let* ((file (stack-pop *operand-stack* 'file-object))
	 (stream (file-object-stream file))
	 char)
    (check-readable file)
    (setq char (and stream (read-char stream nil nil)))
    (cond (char
	   (stack-push (char-int char) *operand-stack*)
	   (stack-push T *operand-stack*))
	  (t
	   (when stream
	     (close stream)
	     (setf (file-object-stream file) nil))
	   (stack-push NIL *operand-stack*)))))

(define-operator 4write*
  (let* ((file (file-object-stream (stack-pop *operand-stack* 'file-object)))
	 char)
    (check-writable file)
    (setq char (stack-pop *operand-stack* 'integer))
    (write-char (int-char char) file)))

(define-operator 4token*
  (let* ((thing (stack-pop *operand-stack* '(or string-object file-object))))
    (if (string-object-p thing)
	(with-input-from-string (stream (string-object-contents thing))
	  (let* ((*scanning-from-string-p* thing))
	    ;1; SCAN will push an object on the opstack if it's there, and return non-NIL if something was pushed.*
	    ;1; After that, we push true or false.*
	    (stack-push (and (scan stream nil nil) t) *operand-stack*)))
	(let* ((stream (file-object-stream thing))
	       (eof-p (not (and stream (scan stream nil nil)))))
	  (when (and eof-p stream)
	    (close stream)
	    (setf (file-object-stream thing) nil))
	  (stack-push (not eof-p) *operand-stack*)))))
	

(define-operator 4bytesavailable*
  (let* ((file (file-object-stream (stack-pop *operand-stack* 'file-object))))
    (stack-push (or (and file (file-length file)) -1) *operand-stack*)))

(define-operator 4flushfile*
  (let* ((file (stack-pop *operand-stack* 'file-object))
	 (stream (file-object-stream file)))
    (check-readable file)
    (when stream
      (if (input-stream-p stream) (clear-input stream) (force-output stream)))))

(define-operator 4resetfile*
  (let* ((file (stack-pop *operand-stack* 'file-object))
	 (stream (file-object-stream file)))
    (check-readable file)
    (when file
      (if (input-stream-p stream) (clear-input stream) (clear-output stream)))))

(define-operator 4status*
  (let* ((file (stack-pop *operand-stack* 'file-object))
	 (stream (file-object-stream file)))
    (check-readable file)
    (stack-push (and stream t) *operand-stack*)))

(define-operator 4run*
  (let* ((file (stack-pop *operand-stack* 'file-object)))
    (check-execable file)
    (execute file t)))

(define-operator 4currentfile*
  (stack-push (or *scanning-file-object-p* (dict-hash "3%stdin*" *system-dict*)
		  (error "3No %stdin?*"))
	      *operand-stack*))

(defun 4write-ps-string *(string)
  "2Write a string in PostScript syntax - map tab characters to '\\t', etc.*"
  (let* ((l (length string)))
    (dotimes (i l)
      (case (char string i)
	(#\Newline (write-string "3\\n*"))
	(#\Return  (write-string "3\\r*"))
	(#\Tab     (write-string "3\\t*"))
	(#\Backspace (write-string "3\\b*"))
	(#\Page    (write-string "3\\f*"))
	(#\\       (write-string "3\\\\*"))
	(#\(       (write-string "3\\(*"))
	(#\)       (write-string "3\\)*"))
	(t (write-char (char string i)))))))


(defun 4ps-== *(thing &optional (recursive t))
  "2The guts of the == and = operators - write the object in PostScript syntax on standard output.
  If RECURSIVE, then the object will be written readably.  Otherwise, strings will be written as
  their contents, and arrays will be written as --nostringval--.*"
  (typecase thing
    (NUMBER (princ thing))
    (OPERATOR (if recursive
		  (format t "3--~A--*" (operator-name thing))
		  (write-string "3$--nostringval--*")))
    (NAME (when (and recursive (not (object-executable thing))) (write-char #\/))
	  (write-string (name-string thing)))
    (STRING-OBJECT (when recursive (write-char #\())
		   (if recursive
		       (write-ps-string (string-object-contents thing))
		       (write-string (string-object-contents thing)))
		   (when recursive (write-char #\))))
    ((MEMBER T) (write-string "3true*"))
    (NULL (write-string "3false*"))
    (t
     (cond ((and recursive (array-object-p thing))
	    (write-char (if (executable-array-p thing) #\{ #\[))
	    (let* ((a (array-object-contents thing)))
	      (dotimes (i (length a))
		(unless (zerop i) (write-char #\Space))
		(ps-== (aref a i) t)))
	    (write-char (if (executable-array-p thing) #\} #\])))
	   (t (write-string
		(if recursive
		    (typecase thing
		      (STACK "3--stacktype--*")
		      (DICTIONARY (cond ((eq thing *system-dict*) "3--systemdict--*")	;1 ## This is nonstandard, but useful.*
					((eq thing *user-dict*) "3--userdict--*")
					((eq thing *error-dict*) "3--errordict--*")
					((eq thing *error-report-dict*) "3--$errordict--*")
					(t "3--dicttype--*")))
		      (FILE-OBJECT "3--filetype--*")
		      (FONT-ID "3--fonttype--*")
		      ;1 *(??? "1--3nulltype*--*")
		      (SAVE "1--3savetype*--*")
		      (MARK "3--marktype--*")
		      ((member :undefined) "3--undefinedOperatorType--*")
		      (t "3--nostringval--*"))
		    "3--nostringval--*")))))))

(define-operator 4=*
  (ps-== (stack-pop *operand-stack*) nil))

(define-operator 4==*
  (ps-== (stack-pop *operand-stack*) t))

(define-operator 4stack*
  (fresh-line)
  (dolist (x (reverse (stack-list *operand-stack*)))
    (ps-== x nil)
    (terpri)))

(define-operator 4pstack*
  (fresh-line)
  (dolist (x (stack-list *operand-stack*))
    (ps-== x t)
    (terpri)))


;1;; 5Vmem Operators**

(define-operator 4save*
  (let* ((gs (top-graphics-state))
	 (gstate (consing-in-save-area (copy-graphics-state gs)))
	 (save (consing-in-save-area (make-save :level *current-save-level* :dead-p nil))))
    (setf (graphics-state-from-save-p gstate) t)
    (push save *currently-active-saves*)
    (stack-push save *operand-stack*)
    (stack-push gstate *graphics-state-stack*))
  (incf *current-save-level*))

(define-operator 4restore*
  (let* ((save (stack-pop *operand-stack* 'save)))
    (when (save-dead-p save) (ps-error "3invalidrestore*" "3restore object is dead.*"))
    (assert (member save *currently-active-saves* :test #'eq) () "3internal: save not on savestack.*")
    (setq *currently-active-saves* (delete save *currently-active-saves* :test #'eq))
    (when (< *current-save-level* (save-level save)) (error "3internal: save skewed.*"))
    (setf *current-save-level* (save-level save))
    (grestoreall)
    (let ((gstate (stack-top *graphics-state-stack* t)))
      (assert (and gstate (graphics-state-from-save-p gstate)) () "3restore and grestore out of synch.*")
      (stack-pop *graphics-state-stack* 'graphics-state))
    (pop-save-state)))

(define-operator 4vmstatus*
  (stack-push (max 0 *current-save-level*) *operand-stack*)	;1 save nesting*
  (stack-push 999999 *operand-stack*)				;1 memory consumed...*
  (stack-push 999999 *operand-stack*)				;1 memory remaining...*
  )


;1;;5 Misc Operators**

(defun 4ps-bind *(object)
  "2The guts of the 'bind' operator.  Stomps the object to have nested procedures tightly-bound.*"
  (when (and (executable-array-p object)
	     (object-readable object))
    (let* ((a (array-object-contents object)))
      (dotimes (i (length a))
	(let* ((obj2 (aref a i)))
	  (when (object-writable object)
	    (when (and (name-p obj2) (object-executable obj2))
	      (multiple-value-bind (binding foundp) (dict-stack-hash obj2 *dict-stack*)
		(when (and foundp (operator-p binding))
		  (setf (aref a i) binding)))))
	  (when (executable-array-p obj2) (ps-bind obj2))))))
  object)

(define-simple-operator 4bind *1 ps-bind)

(define-operator 4usertime*
  (stack-push #+TI (sys:%microsecond-time) #-TI (get-internal-real-time)
	      *operand-stack*))

(define-operator 4version*
  (stack-push (consing-in-user-area (make-string-object :contents (copy-seq "3CLPS-1.0*")))
	      *operand-stack*))


;1;; 5Graphics State Ops**


(defvar 4*default-graphics-state* *(consing-in-save-area (make-graphics-state)))

(define-operator 4gsave*
  (let* ((gs (top-graphics-state))
	 (copy (consing-in-save-area (copy-graphics-state gs))))
    (setf (graphics-state-from-save-p copy) nil)
    (stack-push copy *graphics-state-stack*)))

(define-operator 4grestore*
  (let ((to-pop (stack-top *graphics-state-stack* t)))
    (unless (or (null to-pop) (graphics-state-from-save-p to-pop))
      (stack-pop *graphics-state-stack*))))

(defun 4grestoreall *()
  (do ((top (stack-top *graphics-state-stack* t)
	    (stack-top *graphics-state-stack* t)))
      ((or (null top) (graphics-state-from-save-p top)))
    (stack-pop *graphics-state-stack*)))

(define-operator 4grestoreall* (grestoreall))

;1; ## 5initgraphics* is the same as "initmatrix newpath initclip 1 setlinewidth 0 setlinecap 0 setlinejoin [] 0 setdash 0 setgray 10 setmiterlimit"*

(defmacro 4define-gstate-reader *(name accessor)
  `(define-operator ,name
     (stack-push (,accessor (top-graphics-state)) *operand-stack*)))

(defmacro 4define-gstate-writer *(name accessor type)
  `(define-operator ,name
     (setf (,accessor (top-graphics-state)) (stack-pop *operand-stack* ',type))))

(define-gstate-writer 4setlinewidth*	4 *graphics-state-linewidth number)
(define-gstate-reader 4currentlinewidth *graphics-state-linewidth)

(define-gstate-writer 4setlinecap*	4 *graphics-state-linecap linecap)

(define-gstate-reader 4currentlinejoin *graphics-state-linejoin)

(define-gstate-writer 4setmiterlimit*	4 *graphics-state-miterlimit number)
(define-gstate-reader 4currentmiterlimit *graphics-state-miterlimit)

;1 *##	2array offset*	5setdash*		2-*
;1 *##	2-*		5currentdash*	2array offset*

(define-gstate-writer 4setflat*		graphics-state-flatness number)
(define-gstate-reader 4currentflat*	graphics-state-flatness)

;1 *##	2num*		5setgray*		2-*
;1 *##	2-*		5currentgray*	2num*
;1 *##	2hue sat bri*	5sethsbcolor*	2-*
;1 *##	2-*		5currenthsbcolor*	2h s b*
;1 *##	2r g b*		5setrgbcolor*	2-*
;1 *##	2-*		5currentrgbcolor*	2r g b*
;1 *##	2freq angle proc*	5setscreen*	2-*
;1 *##	2-*		5currentscreen*	2f a p*

(define-gstate-writer 4settransfer*	graphics-state-transfer4 *executable-array)
(define-gstate-reader 4currenttransfer*	graphics-state-transfer)



;1;; 5Matrix Operators**

(define-operator 4matrix*
  (stack-push (consing-in-user-area (make-array-object :contents (make-matrix 1 0 0 1 0 0)))
	      *operand-stack*))

(define-operator 4initmatrix*
  (let* ((gs (top-graphics-state))
	 (dev (graphics-state-device gs)))
    (setf (graphics-state-CTM gs) (device-matrix dev))
    ))

(define-operator 4identmatrix*
  (let* ((mat (stack-pop *operand-stack* 'matrix-object))
	 (a (array-object-contents mat)))
    (check-writable mat)
    (replace a '#(1 0 0 1 0 0))
    (stack-push mat *operand-stack*)))

(define-operator 4defaultmatrix*
  (let* ((mat (stack-pop *operand-stack* 'matrix-object))
	 (a (array-object-contents mat))
	 (gs (top-graphics-state)))
    (check-writable mat)
    (replace a (device-matrix (graphics-state-device gs)))
    (stack-push mat *operand-stack*)))

(define-operator 4currentmatrix*
  (let* ((mat (stack-pop *operand-stack* 'matrix-object))
	 (gs (top-graphics-state))
	 (a (array-object-contents mat)))
    (check-writable mat)
    (replace a (graphics-state-CTM gs))
    (stack-push mat *operand-stack*)))

(define-operator 4setmatrix*
  (let* ((mat (stack-pop *operand-stack* 'matrix-object))
	 (gs (top-graphics-state))
	 (a (array-object-contents mat)))
    (check-readable mat)
    (replace (graphics-state-CTM gs) a)))

(define-operator 4translate*
  (let* ((m (stack-pop *operand-stack* '(or matrix-object number)))
	 (y (if (matrix-object-p m)
		(stack-pop *operand-stack* 'number)
		(prog1 m (setq m nil))))
	 (x (stack-pop *operand-stack* 'number))
	 (a (if m
		(array-object-contents m)
		(graphics-state-CTM (top-graphics-state)))))
    (mat-translate a x y)
    (when m (stack-push m *operand-stack*))))

(define-operator 4scale*
  (let* ((m (stack-pop *operand-stack* '(or matrix-object number)))
	 (y (if (matrix-object-p m)
		(stack-pop *operand-stack* 'number)
		(prog1 m (setq m nil))))
	 (x (stack-pop *operand-stack* 'number))
	 (a (if m
		(array-object-contents m)
		(graphics-state-CTM (top-graphics-state)))))
    (mat-scale a x y)
    (when m (stack-push m *operand-stack*))))

(define-operator 4rotate*
  (let* ((m (stack-pop *operand-stack* '(or matrix-object number)))
	 (d (if (matrix-object-p m)
		(stack-pop *operand-stack* 'number)
		(prog1 m (setq m nil))))
	 (a (if m
		(array-object-contents m)
		(graphics-state-CTM (top-graphics-state)))))
    (mat-rotate a d)
    (when m (stack-push m *operand-stack*))))

(define-operator 4concat*
  (let ((ctm (graphics-state-CTM (top-graphics-state))))
    (mat-multiply (array-object-contents (stack-pop *operand-stack* 'matrix-object))
		  ctm ctm)))

(define-operator 4concatmatrix*
  (let ((m3 (stack-pop *operand-stack* 'matrix-object))
	(m2 (stack-pop *operand-stack* 'matrix-object))
	(m1 (stack-pop *operand-stack* 'matrix-object)))
    (mat-multiply (array-object-contents m1) (array-object-contents m2) (array-object-contents m3))
    (stack-push m3 *operand-stack*)))

(define-operator 4transform*
  (let* ((m (stack-pop *operand-stack* '(or matrix-object number)))
	 (y (if (matrix-object-p m)
		(stack-pop *operand-stack* 'number)
		(prog1 m (setq m nil))))
	 (x (stack-pop *operand-stack* 'number)))
    (multiple-value-bind (x1 y1)
			 (transform-point x y (if m
						  (array-object-contents m)
						  (graphics-state-CTM (top-graphics-state))))
      (stack-push x1 *operand-stack*)
      (stack-push y1 *operand-stack*))))

(define-operator 4dtransform*
  (let* ((m (stack-pop *operand-stack* '(or matrix-object number)))
	 (y (if (matrix-object-p m)
		(stack-pop *operand-stack* 'number)
		(prog1 m (setq m nil))))
	 (x (stack-pop *operand-stack* 'number)))
    (multiple-value-bind (x1 y1)
			 (dtransform-point x y (if m
						   (array-object-contents m)
						   (graphics-state-CTM (top-graphics-state))))
      (stack-push x1 *operand-stack*)
      (stack-push y1 *operand-stack*))))

(define-operator 4itransform*
  (let* ((m (stack-pop *operand-stack* '(or matrix-object number)))
	 (y (if (matrix-object-p m)
		(stack-pop *operand-stack* 'number)
		(prog1 m (setq m nil))))
	 (x (stack-pop *operand-stack* 'number)))
    (multiple-value-bind (x1 y1)
			 (itransform-point x y (if m
						   (array-object-contents m)
						   (graphics-state-CTM (top-graphics-state))))
      (stack-push x1 *operand-stack*)
      (stack-push y1 *operand-stack*))))

(define-operator 4idtransform*
  (let* ((m (stack-pop *operand-stack* '(or matrix-object number)))
	 (y (if (matrix-object-p m)
		(stack-pop *operand-stack* 'number)
		(prog1 m (setq m nil))))
	 (x (stack-pop *operand-stack* 'number)))
    (multiple-value-bind (x1 y1)
			 (idtransform-point x y (if m
						    (array-object-contents m)
						    (graphics-state-CTM (top-graphics-state))))
      (stack-push x1 *operand-stack*)
      (stack-push y1 *operand-stack*))))


(define-operator 4invertmatrix*
  (let* ((m2 (stack-pop *operand-stack* 'matrix-object))
	 (m1 (stack-pop *operand-stack* 'matrix-object)))
    (invert-matrix (array-object-contents m1) (array-object-contents m2))
    (stack-push m2 *operand-stack*)))



;1;; 5Path Operators**


(define-operator 4newpath*
  (setf (graphics-state-path (top-graphics-state)) nil))

(define-operator 4currentpoint*
  (let* ((g (top-graphics-state))
	 (x (graphics-state-position-x g))
	 (y (graphics-state-position-y g)))
    (unless (and x y) (ps-error "3nocurrentpoint*"))
    (stack-push x *operand-stack*)
    (stack-push y *operand-stack*)))

(define-operator 4moveto*
  (let* ((g (top-graphics-state))
	 (x (stack-pop *operand-stack* 'number))
	 (y (stack-pop *operand-stack* 'number)))
    (multiple-value-setq (x y) (transform-point x y (graphics-state-CTM g)))
    (setf (graphics-state-position-x g) x
	  (graphics-state-position-y g) y)))

(define-operator 4rmoveto*
  (let* ((g (top-graphics-state))
	 (dx (stack-pop *operand-stack* 'number))
	 (dy (stack-pop *operand-stack* 'number))
	 (x (graphics-state-position-x g))
	 (y (graphics-state-position-x g)))
    (unless (and x y) (ps-error "3nocurrentpoint*"))
    (multiple-value-setq (x y) (itransform-point x y (graphics-state-CTM g))) ;1 move them back to user space ####*
    (incf x dx)
    (incf y dy)
    (multiple-value-setq (x y) (transform-point x y (graphics-state-CTM g))) ;1 move them back to device space*
    (setf (graphics-state-position-x g) x
	  (graphics-state-position-y g) y)))

(define-operator 4lineto*
  (let* ((g (top-graphics-state))
	 (x2 (stack-pop *operand-stack* 'number))
	 (y2 (stack-pop *operand-stack* 'number))
	 (x (graphics-state-position-x g))
	 (y (graphics-state-position-x g)))
    (unless (and x y) (ps-error "3nocurrentpoint*"))
    (multiple-value-setq (x2 y2) (transform-point x2 y2 (graphics-state-CTM g)))
    (push `(:line ,x ,y ,x2 ,y2) (graphics-state-path g))
    (setf (graphics-state-position-x g) x2
	  (graphics-state-position-y g) y2)))

(define-operator 4rlineto*
  (let* ((g (top-graphics-state))
	 (dx (stack-pop *operand-stack* 'number))
	 (dy (stack-pop *operand-stack* 'number))
	 (x (graphics-state-position-x g))
	 (y (graphics-state-position-x g)))
    (unless (and x y) (ps-error "3nocurrentpoint*"))
    (multiple-value-bind (ux uy) (itransform-point x y (graphics-state-CTM g)) ;1 in user space*
      (let ((x2 (+ ux dx))
	    (y2 (+ uy dy)))
	(multiple-value-setq (x2 y2) (transform-point x y (graphics-state-CTM g))) ;1 in device space*
	(push `(:line ,x ,y ,x2 ,y2) (graphics-state-path g))
	(setf (graphics-state-position-x g) x2
	      (graphics-state-position-y g) y2)))))

(define-operator 4arc*
  (let* ((g (top-graphics-state))
	 (ang2 (stack-pop *operand-stack* 'number))
	 (ang1 (stack-pop *operand-stack* 'number))
	 (r (stack-pop *operand-stack* 'number))
	 (y (stack-pop *operand-stack* 'number))
	 (x (stack-pop *operand-stack* 'number))
	 (cx (graphics-state-position-x g))
	 (cy (graphics-state-position-x g)))
    (when (and cx cy)
      (let (x1 y1) ;1 ## these should be beginning of arc*
	(push `(:line ,cx ,cy ,x1 ,y1) (graphics-state-path g))))
    (push `(:arc ,x ,y ,r ,ang1 ,ang2 :counter-clockwise) (graphics-state-path g))
    (error "3##barf##*")
    (let (x2 y2) ;1 ## these should be end of arc.*
    (setf (graphics-state-position-x g) x2
	  (graphics-state-position-y g) y2))))

(define-operator 4arcn*
  (let* ((g (top-graphics-state))
	 (ang2 (stack-pop *operand-stack* 'number))
	 (ang1 (stack-pop *operand-stack* 'number))
	 (r (stack-pop *operand-stack* 'number))
	 (y (stack-pop *operand-stack* 'number))
	 (x (stack-pop *operand-stack* 'number))
	 (cx (graphics-state-position-x g))
	 (cy (graphics-state-position-x g)))
    (when (and cx cy)
      (let (x1 y1) ;1 ## these should be beginning of arc*
	(push `(:line ,cx ,cy ,x1 ,y1) (graphics-state-path g))))
    (push `(:arc ,x ,y ,r ,ang1 ,ang2 :clockwise) (graphics-state-path g))
    (error "3##barf##*")
    (let (x2 y2) ;1 ## these should be end of arc.*
    (setf (graphics-state-position-x g) x2
	  (graphics-state-position-y g) y2))))

;##	2x1 y1 x2 y2 r*		5arcto*		2xt1 yt1 xt2 yt2*		1append tangent arc*
;##	2x1 y1 x2 y2 x3 y3*	5curveto*		2-*			1spline*
;##	2dx1 dy1 dx2 dy2 dx3 dy3*	5rcurveto*		-

(define-operator 4closepath*
  (let* ((g (top-graphics-state))
	 (x1 (graphics-state-position-x g))
	 (y1 (graphics-state-position-x g))
	 (x2 (second (last (graphics-state-path g))))
	 (y2 (third  (last (graphics-state-path g)))))
    (when (and x1 y1 x2 y2 (or (/= x1 x2) (/= y1 y2)))
      (push `(:line ,x1 ,y1 ,x2 ,y2) (graphics-state-path g))
      (setf (graphics-state-position-x g) x2
	    (graphics-state-position-y g) y2))))

;##	2-*			5flattenpath*	-			1convert curves to straight lines*

(define-operator 4reversepath*
  (let* ((g (top-graphics-state)))
    ;1; Warning: don't use nreverse - we can't stomp this list because of save/restore.*
    ;1; ## This isn't complete - we need to reverse the directions of the lines, arcs, etc as well (or do we?)*
    (setf (graphics-state-path g) (reverse (graphics-state-path g)))))

;##	-			5strokepath*	-
;##	2string bool*		5charpath*		-			1append char outline*
;##	-			5clippath*		-			1set path to be clippath*
;##	2-*			5pathbox*		2llx lly urx ury*		1compute bbox*
;##	2move line curve close*	5pathforall*	-			1enumerate current path*
;##	-			5initclip*		-			1to default*
;##	-			5clip*		-			1new from path*
;##	-			5eoclip*		-			1clip using even-odd-inside rule*


;1;; 5Painting Operators**

(define-operator 4erasepage*
  (setf (device-page (graphics-state-device (top-graphics-state))) nil))

(define-operator 4fill*
  (push `(:fill ,(graphics-state-path (top-graphics-state)))
	(device-page (graphics-state-device (top-graphics-state))))
  (setf (graphics-state-path (top-graphics-state)) nil))

(define-operator 4eofill*
  (push `(:eofill ,(graphics-state-path (top-graphics-state)))
	(device-page (graphics-state-device (top-graphics-state))))
  (setf (graphics-state-path (top-graphics-state)) nil))

(define-operator 4stroke*
  (push `(:stroke ,(graphics-state-path (top-graphics-state))) ;1 ## need to deal with linewidth, etc.  Blaah.*
	(device-page (graphics-state-device (top-graphics-state))))
  (setf (graphics-state-path (top-graphics-state)) nil))


;1;; 5Overloaded Operators**

(define-operator 4get*
  (let* ((index (stack-pop *operand-stack* '(or stringable integer)))
	 (thing (stack-pop *operand-stack* '(or arefable dictionary))))
    (check-readable thing)
    (stack-push
      (typecase thing
	(string-object (char-int (aref (string-object-contents thing) index)))
	(array-object (aref (array-object-contents thing) index))
	(dictionary (let* ((-noval- '(()))
			   (val (dict-hash index thing -noval-)))
		      (if (eq val -noval-)
			  (ps-error "3undefined*" "3~A not found in ~S*" index thing)
			  val)))
	(t (ps-error "3typecheck*")))
      *operand-stack*)))

(define-operator 4put*
  (let* ((newval (stack-pop *operand-stack*))
	 (index (stack-pop *operand-stack* '(or integer stringable)))
	 (thing (stack-pop *operand-stack* '(or arefable dictionary))))
    (check-writable thing)
    (typecase thing
      (string-object
       (unless (numberp thing) (ps-error "3typecheck*"))
       (setf (aref (string-object-contents thing) index) (int-char newval)))
      (array-object (setf (aref (array-object-contents thing) index) newval))
      (dictionary (setf (dict-hash index thing) newval))
      (t (ps-error "3typecheck*")))))
      
(define-operator 4copy*
  (let* ((from (stack-pop *operand-stack* '(or integer dictionary arefable))))
    (check-readable from)
    (cond ((numberp from)
	   (let* ((s (subseq (stack-list *operand-stack*) 0 from)))
	     (dolist (x (nreverse s)) (stack-push x *operand-stack*))))
	  (t (let* ((to (stack-pop *operand-stack* (type-of from))))
	       (check-writable to)
	       (typecase from
		 (DICTIONARY 
		  (assert (zerop (dict-count to)) () "3to-table is not empty.*")
		  (assert (>= (dictionary-max-entries to) (dict-count from))
			  () "3to-table is too small to hold from-table.*")
		  (map-dictionary #'(lambda (key value) (setf (dict-hash key to) value))
				  from)
		  (stack-push to *operand-stack*))
		 (t
		  (let* ((from-array (array-object-contents from))
			 (to-array (array-object-contents to)))
		    (assert (<= (length from-array) (length to-array)) () "3dest too small*")
		    (let* ((subarray (consing-in-user-area
				       (make-array (length from-array) :element-type (array-element-type from-array)
						   :displaced-to to-array)))
			   (new-obj (consing-in-user-area (copy-any-object to))))
		      (setf (array-object-contents new-obj) subarray)
		      (replace to-array from-array)
		      (stack-push new-obj *operand-stack*))))))))))

(define-operator 4forall*
  (let* ((proc (stack-pop *operand-stack* 'executable-array))
	 (thing (stack-pop *operand-stack* '(or arefable dictionary))))
    (check-execable proc)
    (check-readable thing)
    (catch 'LOOP
      (let* ((*in-loop* :forall))
	(declare (special *in-loop*))
	(typecase thing
	  (DICTIONARY
	   (map-dictionary #'(lambda (key val)
			       (stack-push key *operand-stack*)
			       (stack-push val *operand-stack*)
			       (execute proc t))
			   thing))
	  (t
	   (let* ((array (array-object-contents thing))
		  (stringp (stringp array)))
	     (dotimes (i (length array))
	       (stack-push (if stringp (char-int (aref array i)) (aref array i)) *operand-stack*)
	       (execute proc t)))))))))


;1;; 5Variables**

(consing-in-system-area
  (setf (dict-hash "3%stdin*" *system-dict*)  (make-file-object :stream (make-synonym-stream '*standard-input*))
	(dict-hash "3%stdout*" *system-dict*) (make-file-object :stream (make-synonym-stream '*standard-ouput*))
	(dict-hash "3%stderr*" *system-dict*) (make-file-object :stream (make-synonym-stream '*debug-io*))
	
	(dict-hash "3systemdict*" *system-dict*) *system-dict*
	(dict-hash "3userdict*" *system-dict*) *user-dict*
	(dict-hash "3errordict*" *system-dict*) *error-dict*
	(dict-hash "3$error*" *system-dict*) *error-report-dict*
	))

(setf (dict-hash "3handleerror*" *system-dict*) (dict-hash "3handleerror*" *error-dict*))