Google
 

Trailing-Edge - PDP-10 Archives - clisp - clisp/upsala/boot.mid
There are no other files named boot.mid in the archive.
;;-*-midas-*-

	title KERNEL for Common Lisp

	.symtab 16001.,8191.

	.decrel

	loc 140

.qmtch=1			;use "X" for characters instead of "X

;Tops-20 Common Lisp is copyright (C) 1985 by Charles L. Hedrick.  At
;the moment I plan to distribute it to anyone who asks.  However a future
;version may become a product.  Thus all rights are reserved.  No one
;outside of Rutgers is authorized to give a copy to another installation.
;Refer all requests for copies to Charles Hedrick, Rutgers University, 
;CCIS, P.O. Box 879, Piscataway, NJ 08854.

;This kernel is based loosely on ELISP, but by now it has diverged
;quite significantly.

;[Victor]
; This kernel now contains many bug fixes and improvements, mostly from
;Lisp hackers at Uppsala University (Computer Science students and CS depts),
;and also some hacks and improvements from Peter Samson at Systems Concepts,
;San Fransisco, CA.  Some hacks (notably bignum arithmetics) are not quite
;working, so they are commented out with "IFN 0" constructs.
; Most Uppsala hacks have a comment saying [Victor] or [PEM] or [LG]
;or something like that.  Keep them so.
;
; Regarding the status of TOPS-20 Common Lisp, it is not quite straight.
;I can only refer to the following piece of electronic mail:
;
;    Date: Wed, 19 Aug 87 12:46:48 EDT
;    From: josh@klaatu.rutgers.edu (J Storrs Hall)
;    Message-Id: <8708191646.AA17242@klaatu.rutgers.edu>
;    To: AIDA.UU.SE@Victor@enea.se
;    Subject: Re:  TOPS-20 Common Lisp
;
;    Hi, I'm afraid you're on your own as far as common lisp is concerned.
;    We quit supporting it a year ago as we were getting rid of our -20's.
;    I believe that what you have is the last version we did.  
;
;    Good luck with it...
;    --JoSH
;
;So I guess we really are.  For more info, please contact
; Bjorn Victor <Victor@CARMEN.UU.SE> or <Victor%CARMEN.UU.SE@uunet.UU.NET>
; Dept. of Computer Systems
; Uppsala University
; PO Box 520
; S-751 20  UPPSALA
; SWEDEN
;
;End [Victor] comment

smap%=jsys 767
xsir%=jsys 602
meter%=jsys 766
rsmap%=jsys 610
swtrp%=jsys 573
hptim%=jsys 501			;[Victor] 
ifiw==400000,,0
rarg==400400,,0
iarg==400100,,0
define disp (x)
	200000+codsec,,x
	termin

define xblt(ac,foo)
	extend ac,[020_27.] termin
define cmpsle(ac,foo)
	extend ac,[003_27. ? 0 ? 0] termin
define cmpse(ac,foo)
	extend ac,[002_27. ? 0 ? 0] termin
;IND generates a global indirect reference
define gindex(index,addr)
	.byte 6,30. ? index ? addr termin


;****WARNING****
;Before looking at this code, read the appendix ("Notes for hackers")
;in the Elisp reference manual.  The comments assume that you 
;understand what is documented there.  You will also want to read
;SLGUTS, the internals documentation for Spice Lisp, since this
;impelementation is based on Spice Lisp.
;****GNINRAW****

;Memory structure.  this is more complex than it should be because
;of the way the KL's pager works.  The original structure caused
;thrashing.  There are two constraints:
;  the page table is organized in 4-page groups.  All 4 pages
;	must be from the same section.  so if you have code in
;	page 1000 trying to refer to data in page 3000, there will
;	be thrashing, since these are page 0 from two different
;	sections.  Special tricks are used in the hardware to
;	protect from interference between user programs and the
;	monitor, and between odd and even section numbers.  to
;	make the protection against the monitor work, one should
;	avoid pages 300-377 and 700-777 in any even section.
;  in extended code, the PDL is not protected against overflow.
;	This means that there should be non-existent pages or
;	(better) sections around the stack, so that overflow is
;	caught.

;here are the sections.  However the stacks do not begin at the start
;of the section, but are staggered, to prevent interference.  The
;stack that grows the slowest is started first, so as to avoid the
;possibility of having two stacks cross each other and thus 
;interfere.  The offsets are shown below, where QSEC, etc., are
;defined.
;	1 - code
;       2 - EMACS
;       3 - LINK
;	4 - Q pdl (data, including temporary lists produced by EVAL)
;		3 sections
;       7 - I/O buffers
;	10 - P pdl (control)
;	11 - compiled code, if section 1 is full
;	12 - evalstack
;	13 - multiple value stack
;	14 up - data space, 2 spaces of equal size used alternately

;The first data space starts with an area of "constant" objects.
;These are lisp objects that will probably never be GC'ed away, so
;they don't move.  This speeds up GC, and also allows kernel code
;to refer to special cells at fixed locations.  Following this is
;an area of constant strings.  We assume nobody is going to destructively
;change characters in the middle of atom names, etc., so these pages
;can be shared.  The GC doesn't even have to scan them, since strings
;don't contain any Lisp pointers.  This area is not set up in the
;boot code herein.  Rather we wait until all the Lisp code is loaded
;and then call PURIFY

;Everything in Q is a legal Lisp "object".  The structure of objects
;will be described in a minute.  Basically, they are things with
;type codes, so that the GC can tell how to handle them.  The GC
;will look at Q, SP, and AC's O1 to O6.  So all Lisp
;objects should go in one of these places.  We sometimes put
;a Lisp object in another AC.  But this should be done only 
;temporarily, in a situation where we know a GC can't happen.
;Sometimes it is necessary to put a non-Lisp object in O1 to O6.
;If you do so, you must put a legal object there when you are done,
;or a GC could get confused.  Typically we just do SETZ, which
;makes it NIL.

;Lisp objects take up a full word.  We intend to be able to use the
;full 30-bit address space of the DEC-20.  Thus an object consists
;of:
;  1 bit - zero, to indicate that this object (if it is an address)
;	is to be treated as global by the hardware (i.e. that it
;	is a 30-bit address, not an 18-bit one)
;  5 bits - a type code, types defined below
;  30 bits - the object itself.  Nobody is supposed to depend upon
;	the structure of a type of object without declaring it.
;	Every attempt is made to confine such knowlege to a few
;	pages.  The GC will, however, know at least whether something
;	is a pointer into list space or not.

;CHKQUO should be put after any JSYS that can cause quota exceeded.
; Note that it does not handle first-part-done properly, and should
; not be used (at least without fixing) after ILDB's, etc.  (If you
; need to fix it, the code is at MAPERR - however you might just
; as well use MAPERR itself in that case.  MAPERR differs by handling
; a few more cases, such as missing pages from read-only files.)
define chkquo
	ercal quochk	termin

addbts==7777777777	;address bits

define object(type,val)
  <.byte 6,30. ? type ? val> termin

define gettyp (x)
	ldb w2,[.bp 37_30.,x] termin

define getypa (ac,x)
	ldb ac,[.bp 37_30.,x] termin

define getsiz(to,ob)
	ldb to,[.bp 007777777777,(ob)] termin

;;TY%NUM
;Numtyp is for differentiating types when we already know 
; something is a number.
define nmtype (x)
	ldb w2,[.bp 17_30.,x] termin

; check ob for number, then determine numerical type
define xnmtyp (x)
	tlnn x,200000
	 jrst [move o1,x ? jrst notnum]
	ldb w2,[.bp 16_30.,x] termin

; determine numerical type
define nmtypx (x)
	ldb w2,[.bp 16_30.,x] termin

define skpnum (x)
	tlnn x,200000 termin

;integer of any type
define skpint (x)
	camge x,[object ty%big,0] termin

define skpnnt (x)
	caml x,[object ty%big,0] termin

;sorry about this terminology.  SATOM is true for any symbol.
;This includes NIL.  SSYMB is explicitly excludes NIL.  This was
;done during a time when I thought NIL was not a symbol.  However
;it is a useful macro anyway.  In many cases, NIL can't be used
;the same way a symbol can, so we might as well keep this macro.
;;TY%ATM
define satom (x)
	tlne x,360000	;skip if atom or constant atom
	termin

define snatom (x)
	tlnn x,360000	;skip if not atom or constant atom
	termin

define ssymb (x)
	skipe x
	tlne x,360000	;skip if symbol
	termin

define snsymb (x)
	skipe x
	tlne x,360000
	jrst .+2
	termin

define scons (x)
	tlnn x,340000	;non-skip if higher than CONS
	tlnn x,020000	;skip if exactly CONS
	termin

define smcons (x)	;skip if a movable (i.e. not constant) CONS
	tlnn x,350000	;non-skip if higher than CONS, or constant
	tlnn x,020000	;skip if exactly CONS
	termin

define sncons(x)
	xtype x
	cain w2,ty%xcn	;skip if not cons or constant cons
	termin

define chcons(x)
	tlnn x,340000	;non-skip if higher than CONS
	tlnn x,020000	;skip if exactly CONS
	jrst [move o1,x ? jrst notcns]
	termin

define xtype (x)
	ldb w2,[.bp 36_30.,x] termin

;xtype is like gettyp but ignores the low order bit.

define xtypea (a,x)
	ldb a,[.bp 36_30.,x] termin

;;TY%ATM
define getgval(dest,atom)
	move dest,at%val(atom)
	termin

;; These macros all have balanced dummies, which means that they
;; must be called WITHOUT parens around the args, ie.
;; fncall [%FOO],3   *not*   fncall ([%FOO],3).

define fncall(ob,k)
ifn o6-ob,move o6,ob
	tlnn o6,760000
	 skipn w2,at%dsp(o6)
	  call ufo
	call @k(w2)
termin

define fjcaln(ob)
ifn o6-ob,move o6,ob
	tlnn o6,760000
	 skipn w2,at%dsp(o6)
	  jrst ufon
	add w2,w3
	call @(w2)
	iret
termin

;here are the currently defined types.  Representations are described
;here.  This information is, however, classified.  Any code that
;depends upon it must contain a comment indicating that fact.  This
;allows us to change representations if necessary.  E.g. any code
;that knows about representations of vectors should have ;TY%VEC
;It is possible that some code written after 3am in the morning does
;not following this convention, but we use it as carefully as possible.

;Note that the atom has to be 0 so that NIL is taken as an atom
;any table that lists all type should by commented ;;TYPES

;Note that the types with constant equivalents should be defined so 
;that they form even/odd pairs.  This lets us ignore the low order
;bit to see if we have an atom when we don't care whether it is
;constant or not.

;;TYPES - note that code in several places depends upon the fact
;   that ty%atm and ty%xat are 0.  There are several dependencies 
;   on the typecode values of immediate numbers also.
;Warning:  compiled code uses the fact that atoms and constant
; atoms are 0 and 1, and that ac 1 always has 0 in it.  Thus we can
; do things like @[object ty%cat,foo].  Also, in compiled code
; when you want an indirect reference to an absolute address, you
; use @[object ty%iadr,addr], where TY%IADR is defined as the same
; as TY%CAT.  Only the GC will ever look at these references, and
; as far as the GC is concerned, TY%CAT and TY%LPI are the same, i.e.
; constants.  It would be better from a type point of view to use
; TY%LPI, but an indirect reference to such an object would end
; up being indexed by the AC whose number is the same as the code
; for TY%LPI.  TY%IADR is better because its code is 1, and AC 1
; always has a zero in it.
;The numeric types are the latter half of the table for easy
;manipulation of immediate numbers.  In particular, immediate
;integers are the last four types
ty%atm==0	;atom
ty%cat==1	;constant atom
  ty%xat==0	;some kind of atom
ty%iadr==1	;internal address, for use by LAP. You better not print this!
ty%con==2	;cons cell (two words)
ty%ccn==3	;constant cons cell
  ty%xcn==1	;some kind of cons
ty%str==4	;string (see below)
ty%cst==5	;constant cstring  
  ty%xst==2	;some kind of string
  ;starts with ty%sp5, which gives the count in char's.
  ;the pointer is to this object.
ty%chn==6	;I/O channel
ty%cch==7	;constant I/O channel
  ty%xch==3	;some kind of channel
ty%eht==10	;EQ hash table  (GC causes rehash)
ty%oht==11	;other kinds of hash table
  ty%xht==4	;a hash table
ty%vec==12	;vector (starts with size as INUM)
  ;subtype, #data words, data ...
  ;the pointer is to the first word of data
  ;here are the subtypes:
	st%vec==0	;normal vector
	st%str==1	;DEFSTRUCT
;;;NB: there is no such thing as a constant vector.  However there
;;; is a special hack in the GC to that vectors that appear in the
;;; oblist will stay put.  Note that vectors must have only this
;;; one type code, because of the way they are accesssed.
;;; When we implement compiled code, we may find that the dispatch
;;; vectors in the oblist really don't have to be of this type, and
;;; this problem will go away.
ty%chr==13	;character
ty%arh==14	;array header
  ;#data words,  ^data, #elts, fillptr, displacement, upper-bound ....
  ;the pointer it to ^DATA.  #data words is inum.  all entries are objects
ty%spc==15	;beginning of a non-GC'ed block
  ty%xar==6	;an array, under the assumption that a TY%SPC will
		;never happen
ty%ivc==16	;integer vector
  ;skip pointer, access type [small integer], #entries, data ...
  ;the pointer is to the first word of data
ty%bvc==17	;bit vector
  ;starts with ty%s36, which gives the count in bits.
  ;the pointer is to this object
ty%num==20	;the upper half is all the numbers
;the types are in reverse coercion precedence order, except
; for complex, which I don't really expect to implement.
; (I would have put them right too, but iflons must
; begin on a boundary = 2 mod 4).
  ty%xfl==10	;this is the offset into an "xtype" table for numbers
ty%flo==20	;long float
ty%cfl==21	;constant long float (ie, stack allocated)
;;ty%ifl	incant when you hack iflons
  ty%xif==11
ty%lnf==22	;low negative float (immediate 32 bit float)
ty%hnf==23	;high negative float
ty%lpf==24	;low positive float
ty%hpf==25	;high positive float
ty%crt==26	;constant ratios (stack allocated)
	;; type 26 is also the jsp in atom blocks
  ty%xrt==13
ty%rat==27	;ratios
;The following are really the complex type codes.  If complex are
;implemented, you have to figure out what to do with these.
ty%s36==30	;skip pointer with objects packed 36 per word
ty%sp5==31	;skip pointer with objects packed 5 per word
  ty%xbg==15
ty%big==32	;bignum (arbitrary precision integer)
ty%cbg==33	;constant bignum (ie, stack allocated)
;;ty%int	incant when hacking inums
  ty%xni==16
ty%lni==34	;low negative integer (32 bit integer)
ty%hni==35	;high negative integer
  ty%xpi==17
ty%lpi==36	;low positive integer
ty%hpi==37	;high positive integer


;Here is the structure of an atom:
;	value cell
;	ptr to property list (=cdr)
;	pname, a string pointer
;	function defn - lambda if expr or addr if subr
;	function evaluator for interpreter
;	address of function address block, or function address


;Here is an explanation of how compiled function call redefinition works:

;We want to be able to redefine functions.  Thus we can't do PUSHJ P,FOO.
;Instead we do PUSHJ P,@XXX, where XXX contains the current definition
;of FOO.  If FOO is compiled, this is just the address of FOO, else it is
;the address of a routine in the interpreter to interpret FOO.  In fact
;there is a block, called a "function address block" associated
;with each function that is called from compiled code.  This block is
;constructed by %FUNCTION-ADDRESS-BLOCK.  Its most important fields are
;the entry addresses of the function.  Calls to a compiled function are
;indirect off these words.  SETDEF makes sure to update them whenever you
;redefine a function.  In order to allow this, the atom contains a pointer to
;the function address block.  If no compiled code calls this function,
;there is no function address block, and the at%dsp word in the atom
;contains NIL.  The function address block must be in the
;same section as the code, which is why we can't just use a field in the
;atom itself.  Also, the function address block contains a pointer to
;the atom, which is used when an interpreter routine need to know what
;function it is calling.  Calls from compiled code are 
;  PUSHJ P,@function address block+n
;whre N is an offset that depends upon how many arguments are supplied.
;These allow the interpreter to find the function address block, and
;hence the atom itself.  For a PUSHJ, we look at the top of P.  This gives
;the address of the PUSHJ.  Then we look at the PUSHJ instruction.  Its
;address field is the address of the function address block.  Then we just
;look forward in the block until we find an atom (type 0 or 1).  

;The function address block must be in the same section as the caller.
;So if a function is called from two different sections, we have separate
;function address blocks in each section.  The function address blocks
;for a given function are linked in a list using the fa%nxt word
;in the block.


;Here is an explanation of how compiled function calls with varying numbers
;of arguments work:

;Common Lisp functions may be called with a varying number of arguments
;(optional args).  In order to speed up the general cases we 6 entry points in
;the function address block, corresponding to calling the function with zero to
;five arguments.  There is also a seventh entry address which handles calls
;with more than five args.  In the latter case register n must be loaded with
;the actual number of args.  Note that this last entry may ONLY be used if the
;number of args is greater than five; it is NOT a general "load n and call the
;function" entry point.

at%val==0
at%pro==1
at%pna==2
at%fun==3
at%pkg==4
at%dsp==5	;fadrblk location (or undefined function error routine)
at%siz==6	;size of block

;Constant atoms also have the following

at%fev==6

;function address block:
fa%ds0==0	;dispatch addresses for indirect pushj's with 0 args
fa%ds1==1	;	...1 arg,
fa%ds2==2	;	...etc.
fa%ds3==3
fa%ds4==4
fa%ds5==5
fa%dse==6	;addr for number of args > 5 and register n loaded
fa%atm==7	;the atom
fa%nxt==10	;link to next address block (presumably for a different
		;section)
fa%siz==11

;note that some of the property list code depends upon at%pro being 1
;the variables declared by DECLFU depend upon the fact that AT%VAL is
;0, but this can be changed by changing DECLFU.

;package.  This is a structure, so -1 is the length

pk%hdr==0	;the atom PACKAGE
pk%nam==1	;a string, the package name
pk%nic==2	;a list of strings, nicknames
pk%use==3	;a list of packages, use
pk%usd==4	;a list of packages, used by
pk%int==5	;a hash table, internal symbols
pk%ext==6	;a hash table, external symbols
pk%sdw==7	;a list, shadowing symbols
pk%siz==10	;number of components

;here is the structure of a string.  This is what is pointed to
; by a string pointer.
;object(ty%sp5,number of chars following)
;ascii string

;Here is the structure of an array header:

ah%hsz==-1	;size of header.  from this you can deduce dimensionality
ah%dat==0	;data vector
ah%siz==1	;number of data elements
ah%fil==2	;fill pointer
ah%dsp==3	;displacement
ah%ub1==4	;upper bound for dimension 1
;upper bounds for other dimensions follow

;AC usage is (unfortunately) known by everybody

p=17		;control stack
q=16		;data stack.
sp=15
n=14		;will be used for number of args passed
free=13		;start of free space

nil=0		;must always contain 0
nil1=1		;must always contain 0 except during jsys's

;The working AC's are separated into those that contain GC'able
;objects and those that don't.  This lets us know which to
;GC when we have to do that.  It also allows interrupt handling,
;since we know what is in each AC.

;AC's w2 to w4 must not contain legal Lisp objects, i.e. things
;that need not be GC'ed.  If they must be saved, they should be
;pushed onto P.  These must be first in order to allow jsys's
;to be called, since clearly the AC's used by jsys's can't in
;general be assumed to contain lisp objects.

;Wn may be assumed to be ACn.  These must include at least AC2,3,
;and 4, since these AC's are used for JSYS's.  

;There is no W1 because W1 is part of NIL.  To emphasize that fact,
;we call this NIL1.  This should remind you to zero it if you
;put anything in it.

w2=2
w3=3
w4=4

;AC's o1 to o6 must contain legal Lisp objects, i.e. things that
;GC can collect.  If they must be saved, they should be pushed
;onto Q

o1=5
o2=6
o3=7
o4=10
o5=11
o6=12		;used as a temp in macros - avoid using it yourself

;to call a routine, load the args into O1 to O6.  They must be legal
;Lisp objects, or the GC will get you.  Don't try to economize by
;passing a bare number - set the type code, please. there are macros to
;go from numbers to objects and visa versa, just so you don't have to
;know the numerical representation.  We will, however, tell you
;that the representation for integers is efficient enough that these
;macros are not expensive.  values are returned in O1.

;In general you should assume that calling a routine garbages all
;the working AC's, i.e. Ox and Wx.  The exceptions are the macros
;for CAR, CDR, RPLACA, RPLACD, and CONS, which touch only those
;AC's that they are defined as touching.

call=pushj p,
retn=popj p,			;used to return to lisp w/ n set
iret=popj p,			;used for internal rtns w/ n ignored

irp d,,[1,2,3,4,5]
define ret!d
	movei n,d
	retn
	termin
termin

;When we return no values, we want O1 to be NIL, so RET0 is special
define ret0
	setzb n,o1
	retn
	termin

;;TY%STR
define makstr &str&
	ty%cst_30.+<codsec,,[ty%sp5_30.+.length str
			     ascii str]>
termin	

define err(*str)
	move o1,[makstr /str/]
	setzb nil1,nil		;clean up
	jrst d.fer0
	termin

define err1(ac,*str)
ifn ac-o2,[move o2,ac]
	move o1,[makstr /str/]
	setzb nil1,nil		;clean up
	jrst d.fer1
	termin

define cerr(*cstr,str)
	move o1,[makstr /cstr/]
	move o2,[makstr /str/]
	setzb nil1,nil		;clean up
	call d.cer0
	termin

define cerr1(ac,*cstr,str)
ifn ac-o3,[move o3,ac]
	move o1,[makstr /cstr/]
	move o2,[makstr /str/]
	setzb nil1,nil		;clean up
	call d.cer1
	termin
;save/restart - produce pseudo-.EXE file and bootstrap the system from one

;This code is needed because GET and SSAVE don't work on rel. 4.  We have
;a simulation of SSAVE, which we always use, and a simulation of GET which
;we use for all pages outside of section 0 on rel. 4.

;Here is the format of the .EXE file:

;page 0 is a directory for the program, in the format of an .EXE
;file.  Note that only pages in section 0 will be loaded on rel. 4

;1776,,page count
;300000,,file page
;nnn000,,process page
;  etc. for all pages
;1775,,3
;3            [# words in entry vector]
;bootst
;1777,,1


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;   SECTION creation code
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;common routine for creating all the sections.  See the following
;page for documentation of the program structure.

sects:	movei w4,nqsec		;loop over number of Q sections
	movei w2,qsec
secql:	call maksec
	 jrst secfai
	aoj w2,
	sojg w4,secql
	movei w2,bufsec		;just one section for buffers
	call maksec
	 jrst secfai
	movei w2,psec
	call maksec
	 jrst secfai
	movei w2,codsc2
	call maksec
	 jrst secfai
	movei w2,spsec
	call maksec
	 jrst secfai
	movei w2,mvsec
	call maksec
	 jrst secfai
	movei w4,datsiz		;loop on data sections
	movei o1,datsec		;first such section
datlop:	move w2,o1
	call maksec
	 jrst secfai		;ran out of sections
	addi o1,1
	sojg w4,datlop
	movei w4,datsiz		;now same for second set of sections
	movei o1,datsc2
datlp2:	move w2,o1
	call maksec
	 jrst secfai
	addi o1,1
	sojg w4,datlp2
	movei w2,codsec		;now the code
	call maksec
	 jrst secfai
	iret

;maksec - create a section.
;  w2 - section number to make.  
; skip return if it works
maksec:	hrli w2,.fhslf		;in our work
	push p,w2		;save arg
	move nil1,w2
	rsmap%
	 erjmp maksc1		;no jsys - probably need section
	camn nil1,[-1]
	 jrst maksc1		;nonexistent section
	adjsp p,-1		;already there - nothing to do
	aos (p)
	iret

  ;create the section
maksc1:	setz nil1,		;private
	pop p,w2		;get back arg
	move w3,[pm%cnt\pm%rwx\1]
	smap%
	 erjmp cpopj
	aos (p)
cpopj:	iret

secfai:	hrroi nil1,[asciz / Can't create section
/]
	esout
	haltf
	jrst .-1

tmpsts==10
	.vector tmpstk(tmpsts)

exeerr:	hrroi nil1,[asciz / Bad .EXE file
/]
	esout
	haltf
	jrst .-1

badfil:	hrroi nil1,[asciz / Problems reading .EXE file - This failure happens about 1% of
the time.  If you try running this program again, it will probably work.
/]
	esout
	haltf
	jrst .-1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;   BOOT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;This code is all that is loaded into memory when you first run a saved
;core image.  Its responsibility is to load the rest of the file.
;One of the trickier things is to find out what file it is.  We do
;this by doing RMAP, which gives you the JFN that is mapped into page
;0.  That should be the file.  Note that the JSYS manual specifically
;prohibits this code.  However it should work if we are running from
;disk.

;O2 is global to this section, and contains the JFN of the file.

;entry vector
bootev:	jrst bootst
	jrst bootst
	1,,0
	jrst sboost

;sboost is special entry if we are running a sharable file
sboost:	movem o2,shrfil'
bootst:	reset

;See whether we need to load the rest of the .EXE file

	move nil1,[.fhslf,,codsec]	;see if section 1 is there
	rsmap%
	 erjmp needbt			;if no jsys, rel. 4
	camn nil1,[-1]			;if nonexistent
	jrst needbt			;also rel. 4
;here if rel. 5 - skip most of the following.  Here is all we need
	move p,[-tmpsts,,tmpstk-1]	;section 0 temp stack
	call sects			;create sections
	jrst bootok			;no boot needed, rel. 5 GET works

;Here if we don't have section 1;  presumably rel. 4

needbt:	move nil1,[.fhslf,,0]		;see who we are mapped to
	rmap				;nil1 - jfn,,file page
	hlrz o2,nil1			;save in o2
	caige o2,100			;see if valid jfn
	caig o2,0
	jrst badfil
	move p,[-tmpsts,,tmpstk-1]
;create sections
	call sects

;now read the rest of the code from our EXE file.  We do
;this in sections.  Each section corresponds to a 2-word entry
;in the directory, and describes a set of contiguous pages.
;We first read the 2-word entry and then pmap in the pages
;that it describes.
  ;get to the directory and validate it.
	hrrz nil1,o2			;get to directory page
	movei w2,0			;start of page
	sfptr
	 erjmp badfil
	bin				;should be 1776,,n
	hrrz w4,w2			;isolate count
	hlrz w2,w2			;make sure it is kosher
	caie w2,1776
	jrst exeerr			;illegal structure
	subi w4,1			;w4 - number of entries
	lsh w4,-1
  ;pmap in the data, one piece at a time
    ;get data for one chunk from directory
bootlp:	hrrz nil1,o2			;jfn
	bin
	push p,w2			;(p) - 300000,,file page
	bin				;w2 - rpt000,,process page
    ;pmap it in
	pop p,nil1			;jfn,,file page
	hrl nil1,o2
	ldb w3,[.bp 777000000000,w2]	;bits,,count
	addi w3,1			;.EXE file has odd defn of count
	hrli w3,(pm%cnt\pm%rd\pm%ex\pm%cpy)
	hrli w2,.fhslf			;.fhslf,,process page
	pmap
	sojg w4,bootlp			;again if there are more
  ;end loop when get to end of directory

;rel. 5 rejoins us here, with the entire core image in memory.

;finally, ddt.  We map the pages that contain ddt from section 0 to
;section 1, so if the user does the DDT command it shows up in
;section 1, which is after all where it is most useful.
bootok:	move nil1,[.fhslf,,ddtpag] ;and the upper 1/4 to codsec (for DDT)
	move w2,[.fhslf,,codsec*1000+ddtpag]
	move w3,[pm%cnt\pm%rd\pm%cpy\ddtsiz]
	pmap
;reset so restart gets us to new context
	movei nil1,.fhslf
	move w2,[4,,evec]
	sevec
;and go to permanent Lisp context
	move q,[baseq-1]
	move p,[basep-1]
	xjrstf [0
		codsec,,.+1]
	move w2,[jfcl]
	movem w2,evhook
	move free,freesv'
	move w2,@[shrfil]			;copy funny init var
	movem w2,shrfil				;to section 1
;At the moment, section zero contains just one page, the bootstrap.
;We would like the whole thing, since it contains DDT symbols (which
;DDT stubbornly refuses to take from section 1.  Also the entry
;vectors, DDTST, and other randomness.  In order to save swap space,
;we make this an indirect mapping to section 1.  Note that we
;don't bother to map BPS HIGH into section 0
	move nil1,[.fhslf,,1000]		;get ident for section 1
	move w2,[.fhslf,,0]
	move w3,[pm%cnt\pm%rd\pm%cpy]
	hrrz w4,bpscod+bps%le			;first address beyond end
	subi w4,1				;last used
	lsh w4,-9.				;last page
	addi w4,1				;number of pages
	hrr w3,w4
  ;The obvious thing is to just do the pmap we just set up.  Alas,
  ;the destination page is 0.  when you do this in section 1, page 0
  ;is interpreted as page 0 in the current section.  we have to go
  ;back to section 0 in order to get this page number interpreted right.
        xjrstf [0
	        0,,.+1]
	pmap
	xjrstf [0
	        codsec,,.+1]
  ;and finish init
	setzb nil,nil1
	setzb o1,o2
	setzb o3,o4
	setzm edfork		;may have had ed fork when saved, but don't now
	setzm edpc
	call limstk		;set up stack limits
	call ioinit		;set up I/O system
	move sp,bootsp		;unbind from here
	move w2,[basesp-1]	;down to here
	call cunbn1
;	skipe o1,@[.botmsg]	;if greeting message
;	call princ		;put it out
	getnm			;[Victor] Get private name
	move w2,nil1		;[Victor] Put in place for SETSN
	move nil1,[sixbit /CLISP/]	;[Victor] System name is CLISP
	setsn			;[Victor] Set both
	 nop			;[Victor] and be happy
	setz nil1,		;[Victor]
	skipe o1,@[.botfrm]	;[Victor] If boot initialization form
	 call ueval		;[Victor] then eval it
	jrst tstshr		;start top (after testing share file thing)

;make sure everything needed above is on this page

	.scalar bpslst,bootsp

;bpslst points to a list that describes BPS in each section:
;The following record is in each section that has BPS in it.
;Except in CODSEC, it is at the very beginning of the section,
;i.e. below address 20.  In CODSEC, it is at BPSCOD.

bps%nx==0	;address of next section, 0 if none
bps%ls==1	;start of low (impure) section
bps%le==2	;end of low (impure) section + 1
bps%hs==3	;start of high (pure) section
bps%he==4	;end of high (pure) section + 1

;The normal start of BPS low in any section is one beyond this
;descriptor.  Normally this is an area structured for GCTRAN to
;look at.  However in CODSEC, some of it is compiled code, so
;at CODSEC,,BPS%ST there will be a skip pointer to skip that part
;of it.

bps%st==21	;start of BPS low in each section


bpscod:	0	;BPS descriptor for CODSEC
	codsec,,bps%st
	0
	codsec,,<ddtpag*1000>
	codsec,,<ddtpag*1000>

lstcsc:	1	;section number of last code section
	
	consta

	variab


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  SAVE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;Here is the save code
;the following AC's are global to this whole section.  The rest are temps.
;  O1 - channel object for file
;  W4 - last disk page written

;(save "filename" "greeting") - save the core image
;o1 - string or atom for file name
;o2 - greeting
xsave:	move o2,nil		;default is no greeting
	movem o2,@[.botmsg]
	push q,o1		;[Victor] Make smaller EXE
	call edkill		;[Victor] delete editor if any
	call gc			;[Victor] clean up free stg
	pop q,o1		;[Victor] 
;open and set up file
	move o2,[$OUTPUT]
	move o3,[$NEWVER]
	move o4,[$CREATE]
	move o5,[%STRCHR]
	call xopenf		;o1 - channel object for file
  ;the only AC that will be needed for booting is FREE.  Note that this
  ;is being saved in section 1, not section 0.
	movem free,freesv	;save free for BOOT
	movem sp,bootsp		;and SP for unbinding after BOOT
	hrrz nil1,ch%jfn(o1)	;xoutpu openned for 7 bits, change to 36
	movei w2,36.
	sfbsz
	 erjmp [setz nil1,
		err /Can't set byte size to 36/]
	movei w4,0		;page 0 is directory - last used
;write out actual data directory and data
  ;header
	call dirhd6		;type 6 header
  ;BOOT page
	movei w2,0		;process page
	movei w3,1		;page count
	call diren6		;type 6 entry for constant data
  ;BPS spaces
	xmovei o2,bpscod	;start with descriptor for CODSEC
xsave1:	
;first we check some special cases: no data at all or data 
;is contiguous with high section.
	move w2,bps%ls(o2)	;start of low segment in this section
	camn w2,bps%le(o2)	;first see if they are the same
	 jrst xsave2		;the same, forget low section
	move w3,bps%le(o2)	;end of low area
	subi w3,1
	xor w3,bps%hs(o2)	;compare with start of high area
	trnn w3,777000		;same page?
	 jrst xsave3		;yes - just one group
;now we are committed to saving the low section
	lsh w2,-9.		;go to page number
	move w3,bps%le(o2)	;compute size of area
	subi w3,1
	lsh w3,-9.		;in pages
	sub w3,w2
	addi w3,1
	call diren6		;type 6 entry for code
xsave2:	move w2,bps%hs(o2)	;same for high segment
	camn w2,bps%le(o2)	;first see if they are the same
	 jrst xsave4		;the same, no high section
xsave3:	lsh w2,-9.
	move w3,bps%he(o2)
	subi w3,1
	lsh w3,-9.
	sub w3,w2
	addi w3,1
	call diren6
xsave4:	move o2,bps%nx(o2)	;any more sections?
	jumpn o2,xsave1		;if so, do them
  ;note that at the end of this loop O2 has 0, which is NIL, so it
  ;is back to being a legal Lisp object

  ;constant data area.  This is the start of the first free space,
  ;and contains the initial OBLIST and its friends.
	movei w2,datsec*1000+datoff ;process page
	move w3,datpgs'		;number of pages
	call diren6		;type 6 entry for constant data
  ;the currently active free space.  Only the part with data in
  ;it is saved.  We are not allowed to cross section boundaries.
  ;This can overlap what was done above, so fix that
	move w2,stthis		;start of this section, if not overlapping
	camge w2,encnpg		;if overlaps already saved
	move w2,encnpg		;start at end of that
	move w3,free		;then use real end address
  ;now we have the limits in W2 and W3, save this section
	lsh w2,-9.		;convert to page - first page
	lsh w3,-9.		;convert to page - last page
	sub w3,w2
	addi w3,1		;page count
	call diren6		;type 6 entry for free space
  ;currently active SP
	move w2,[basesp/1000]	;first page of SP
	move w3,sp		;last addr
	lsh w3,-9.		;convert to page - last page
	sub w3,w2
	addi w3,1		;page count
	call diren6		;type 6 entry for SP
	call dirtr6		;type 6 trailer
  ;currently active mv stack
	move w2,[basemv/1000]	;first page of SP
	move w3,mvp		;last addr
	lsh w3,-9.		;convert to page - last page
	sub w3,w2
	addi w3,1		;page count
	call diren6		;type 6 entry for SP
	call dirtr6		;type 6 trailer
  ;close things off
	movei w2,4		;vector length 3
	movei w3,bootev		;vector location
	call dir5		;type 5 (entry vector)
	call dir7		;type 7 (end block)
	move w2,[444440,,0]
	movem w2,ch%bpt(o1)	;say 36 bit bytes
	addi w4,1		;go to base 1 count
	imuli w4,512.		;convert pages to bytes
	movem w4,ch%lby(o1)	;and say we have this many pages
;because we are doing pmapped I/O on a file open in byte mode
;the close resets the byte count, and gets it wrong.  So save
;the info we need to put it back
	push p,w4
	push p,ch%jfn(o1)
	move o2,[inum0\(co%nrj)] ;flag to say don't release jfn
;do a Pascal close, but leave the JFN for the chfdb
	call closef+1		;close file
;set the byte count and get rid of the JFN
	pop p,nil1		;jfn
	hrli nil1,.fbsiz	;set byte count
	pop p,w3		;here it is
	seto w2,		;all bits
	chfdb
	 erjmp .+1
	tlz nil1,777777
	rljfn
	 erjmp .+1
	jrst retnil

;routines for writing .EXE files - w4 is an implict arg to all these
;routines.  It is the last file page that has been written.

;type 6 - the actual data.  The structure of this is
;  1776,,length
;  pairs of data
;To do this, first call DIRHD6 once to leave space for the header
;DIREN6 once for each entry, to make the pairs  (actually if the count
;	is .GT. 1000, one call may make more than one pair)
;DIRTR6 once at the end to go back and fill in the count in the header
	
;dirhd6 - header for directory entry
dirhd6:	hrlzi w2,1776		;make 1776,,length - length filled in later
	hrrz nil1,ch%jfn(o1)	;to output
	bout
	rfptr			;find out where we are
	 jrst poserr
	subi w2,1
	movem w2,dirst6'	;save as start of directory
	iret

poserr:	err /Can't use random access on file/

;diren6 - entry for directory entry - process page in w2, count in w3
;This routine will call dirdo6 once for each section in the region
diren6:	caig w3,0		;forget it if null region
	iret
	move nil1,w2		;compute last page saved
	add nil1,w3		; one beyond
	subi nil1,1		;actual last
	xor nil1,w2		;cross section?
	caig nil1,777		;yes
	jrst dir6do		;no, OK
;here if this thing will cross a section boundary
	move nil1,w2		;compute first pg of next section
	tro nil1,777		;last one of this
	addi nil1,1		;first of next
	push p,nil1		;save as start of next transfer
	sub nil1,w2		;number of pages in this transfer
	sub w3,nil1		;number left for next time
	push p,w3		;save it
	move w3,nil1		;count for this time must be in w3
	call dir6do		;do this one
	pop p,w3
	pop p,w2
	jrst diren6		;now try again

;dir6do - this routine does an actual type 6 entry - proc pag in w2, count w3
dir6do:	push p,w2		;-1(p) - process page
	push p,w3		;(p) - count of pages
;first put dir entry to dir area
	hrrz nil1,ch%jfn(o1)
	move w2,w4		;300000,,file page
	addi w2,1		;use first page after last used
	hrli w2,300000
	bout			;put to file
	move w2,(p)		;rpt000,,process page
	subi w2,1		;DEC's rpt count is count-1
	lsh w2,27.		;in bits xxx000,,000000
	hrr w2,-1(p)		;saved process page
	bout			;put to file
;now actual data pages - uses page BUFPAG as a buffer
dir6lp:	sosge (p)		;any more left?
	jrst dir6ex		;no - done
	addi w4,1		;next disk page
	hrl nil1,ch%jfn(o1)	;file jfn,,file page
	hrr nil1,w4
	move w2,[.fhslf,,bufpag]	;to buffer page
	move w3,[pm%rd\pm%wr]	;we want to write it (obviously)
	pmap			;now we have mapping to file
	 chkquo			;[Victor] Check for quota exceeded
	movei nil1,1000		;next we copy a page to the buffer - 1000 wds
	move w2,-1(p)		;this page
	lsh w2,9.		;but we want address
	move w3,[bufpag*1000]	;to buffer
	xblt nil1,
	 chkquo			;[Victor] Check for quota exceeded
	aos -1(p)		;advance process page
	jrst dir6lp		;and try again
dir6ex:	subi p,2		;get rid of saved args
	seto nil1,		;and unmap buffer page
	move w2,[.fhslf,,bufpag]
	setz w3,
	pmap
	 chkquo			;[Victor] Necessary?
	iret			;and return

;dirtr6 - trailer for directory entry.  Must fill in length part of header
dirtr6:	hrrz nil1,ch%jfn(o1)	;jfn of file
	rfptr			;current pos in w2
	 jrst poserr
	move w3,dirst6		;start of block
	movem w2,dirst6		;save current pos
	sub w2,w3		;subtract start, for length
	hrli w2,1776		;1776,,length
	rout			;put out the header at start pos
	move w2,dirst6		;get back end position
	sfptr			;and go back there
	 jrst poserr
	iret

;dir5 - entry vector - length in w2, address in w3
dir5:	push p,w2
	hrrz nil1,ch%jfn(o1)	;jfn of file
	move w2,[1775,,3]	;entry header
	bout
	pop p,w2		;length
	bout
	move w2,w3
	bout
	iret
	
;dir7 - end - no args
dir7:	hrrz nil1,ch%jfn(o1)	;jfn of file
	move w2,[1777,,1]
	bout
	iret
;startup - sets up memory structure.

;this routine knows about memory structure.
;anyone who wants initialization done should write a routine and
;	put a call to it here.

;memory structure is documented at the beginning of the program.
;anyone changing these declarations should change those comments.

;locals:

;section definitions.
codsec==1		;code
edsec==2		;EMACS subfork
lnksec==3		;LINK subfork
qsec==4			;section for Q stack
 nqsec==3		;number of sections for Q
 baseq=qsec,,40000	;start of Q pdl, used in GC
 endq=<qsec+nqsec-1>,,740000;leave a bit of space for debugger for PDL over
 endqs=<qsec+nqsec-1>,,777000	;illegal page at real end
bufsec==7		;I/O buffers
 bufst=bufsec,,400000	;first buffer
 bufend=bufsec+1,,0	;end of buffers
psec==10		;section for P stack
 basep=psec,,20		;ERCAL gets confused if this is between ,,0 and ,,17
			;also, until that bug is fixed, the stack can't cross
			;a section boundary.
 endp=psec,,740000
 endps=psec,,777000	;illegal page at real end
codsc2==11		;second code section
spsec==12		;section for SP stack
 basesp=spsec,,20000
 endsp=spsec,,740000
 endsps=spsec,,777000	;illegal page at real end
bufpag==12000		;page for use in SAVE command.  Any free page will do
mvsec==13		;multiple value stack section
 basemv=mvsec,,100000	;start of MV stack
 endmv=mvsec,,740000
 endmvs=mvsec,,777000
datsiz==5		;[Victor] Only five sections in Uppsala (SPTFL1)
;datsiz==11		;maximum number of sections in each data space
	;this number should be odd, in order that both data spaces start
	;in sections of the same parity.  This is important for performance
	;reasons.
datsec==14		;first section in first data space
datoff==200		;page within section where first data space starts
datsc2==datsec+datsiz+1	;first section in second data space
datof2==230		;page within section where secnd data space starts

ddtpag==760		;start of ddt
ddtsiz==20		;number of pages in ddt

winpgs==4		;size of I/O window in pages

endsec==777777			;end of a section (relative)

evec:	xjrstf [0
		codsec,,rstart]
	xjrstf [0
		codsec,,rstart]
	1,,0
	xjrstf [0
		codsec,,sstart]	;special start for sharable section

ddtst:	xjrstf [0
		codsec,,770000]

calddt:	skipe @770001
	jrst caldd1
;no DDT yet - get it
	move nil1,[gj%old+gj%sht]  ;look up the file
	hrroi w2,[asciz /sys:uddt.exe/]
	gtjfn
	 jrst [err /Can't find SYS:UDDT.EXE/]
	push p,nil1		;save jfn
	movei nil1,.fhslf
	gevec			;get entry vector, since GET will change it
	move nil1,(p)		;now get back JFN
	movem w2,(p)		;and save entry vector
	hrli nil1,.fhslf
	get
	 erjmp [err /Can't get SYS:UDDT.EXE/]
	movei nil1,.fhslf	;put back entry vector
	pop p,w2
	sevec
	setz nil1,
	move w2,@[116]		;get symbol pointer
	hrrz w3,770001		;get addr of symbol table in DDT, sec. 0
	movem w2,(w3)		;now put symbol pointer in symbol table
caldd1:	call 770000
	jrst retnil

start:	reset
	move p,[-tmpsts,,tmpstk-1]
;Most of the following code is used to get us into our final
;sections.  there is no way to get Midas or Link to load
;code directly into a non-zero section, but we must be there
;or global addressing won't work.  To get into a non-zero
;section, you must
;  1) use SMAP% to create the section
;  2) PMAP code there from an existing place
;  3) use XJRSTF to get there.  XJRSTF is the only instruction
;	that you can use to get from section zero to a non-zero
;	section.
  ;write out CLISP.REL, with symbols in it
;	call wrirel
  ;create sections
	call sects		;routine also used by BOOT code
;now we move things into these sections we just created.  Things go
;faster when a page is not mapped, so we first map them copy on
;write, and then do a MOVES on each page to make them private.
;this may be superstition.  You should see whether it seems to help.
;There is some evidence that the tests we used to evaluate this
;strategy were wrong.  If so, turn on PM%WR instead of PM%CPY, and
;omit the code that does MOVES on each page.

;low section - code. This is from 0 to then end of the symbol table.
	hrrz w4,116		;.jbsym - symbol table
	hlre o1,116		;negative length
	movn o1,o1		;positive length
	add w4,o1		;w4 is now first loc after sym tab
	subi w4,1		;need last used
  ;construct entry for list of symbol tables
	push w4,[0]		;end of list
	hrli w4,codsec		;put in section number
;	movem w4,symlst		;first entry in list of symbol tables
	push w4,116		;AOBJN word for this table
	hrli w4,codsec		;put in section number
	addi w4,1		;first beyond
	movem w4,bpscod+bps%le	;save as end of low segment
	tlz w4,777777		;get back to local addressing
	move w2,w4		;compute skip pointer to skip this junk
	subi w2,bps%st+1
	tlo w2,(<object ty%spc,0>)
	movem w2,bps%st		;and put at start of BPS in CODSEC
	subi w4,1		;w4 is now last loc used
	lsh w4,-9.		;w4 is now last page used
	addi w4,1		;w4 is now number of pages used
	move nil1,[.fhslf,,0]	;pmap lower half of our sec 0 to codsec
	move w2,[.fhslf,,codsec*1000]
	move w3,[pm%cnt\pm%rd\pm%cpy]
	ior w3,w4		;or in count
	pmap
;now high section (oblist) to data.  This is from DATOFF to ENDSTR
	movei w4,endstr		;now number of pages in initial const areas
	subi w4,datoff*1000	;starts here
	subi w4,1		;just like above
	lsh w4,-9.
	addi w4,1
	move nil1,[.fhslf,,datoff] ;the oblist to datsec
	move w2,[.fhslf,,datsec*1000+datoff]
	move w3,[pm%cnt\pm%rd\pm%cpy]
	ior w3,w4
	pmap
	movei w4,endobl		;compute size of constant atom area
	subi w4,datoff*1000
	subi w4,1
	lsh w4,-9
	addi w4,1
	movem w4,datpgs		;only this gets saved by SAVE command
;finally, ddt
	move nil1,[.fhslf,,ddtpag] ;and the upper 1/4 to codsec (for DDT)
	move w2,[.fhslf,,codsec*1000+ddtpag]
	move w3,[pm%cnt\pm%rd\pm%cpy\ddtsiz]
	pmap
  ;reset so restart gets us to new context
	movei nil1,.fhslf
	move w2,[4,,evec]
	sevec
  ;also so DDT gets the right DDT
	movei w2,ddtst
	skipe 770000			;if we have ddt
	movem w2,74			;make jbddt point to extended ddt
	xjrstf [0
		codsec,,.+1]
  ;and go to permanent Lisp context
	move q,[baseq-1]
	move p,[basep-1]
	move sp,[basesp-1]
	move w2,[jfcl]
	movem w2,evhook
  ;now make all the pages private
    ;code
	move w2,bpscod+bps%ls		;first in code pages
	move w3,bpscod+bps%le
	sub w3,bpscod+bps%ls		;number of words
	subi w3,1
	lsh w3,-9.			;number of pages, rounded up
	addi w3,1
	moves (w2)			;make private
	addi w2,1000			;next page
	sojg w3,.-2			;loop for all pages
   ;data
	move w2,[datsec,,datoff*1000+20] ;same for data
	move w3,datpgs
	moves (w2)
	addi w2,1000
	sojg w3,.-2
  ;if ddt is here, start it
	skipn 770000
	jrst noddt
	movei w2,ddtst
	movem w2,74
	hrroi nil1,[asciz /
Type DDTRET$G to return
/]
	psout
	xjrstf [0
		codsec,,770000]
ddtret:	xjrstf [0
		codsec,,noddt]
  ;now do initialization for various pieces of code that need it
noddt:	setzb nil,nil1
	setzb o1,o2
	setzb o3,o4
	call limstk		;set up stack limits
	call ioinit		;set up I/O system
	move w2,[basemv]
	movem w2,mvp
	push q,[datsec,,datoff*1000]
	push q,[datsec,,endobl]
	push q,[datsec,,endstr]
	push q,[datsec+datsiz,,0]
	push q,[datsc2,,datof2*1000]
	push q,[datsc2+datsiz,,0]
	call gcinit
	call makrdt		;initialize read tables
	movem o1,@[.crdtab]
	call makrdt
	movem o1,@[.srdtab]
	call oustrg		;get our default output string
	movem o1,@[.dfoust]
;create package obarray
	move o1,[%EQUAL]
	move o2,nil
	move o3,nil
	move o4,nil
	call makhsh
	movem o1,@[.PKGOBARRAY]
;create LISP and KEYWORD packages
	move o1,[makstr /LISP/]
	move o2,nil
	move w4,[%atmls]
	call makpkg
	movem o1,@[.LISPPACKAGE]
	movem o1,@[.PACKAGE]
	move o1,[makstr /KEYWORD/]
	move o2,[%KEYNIC]
	move w4,[%kyatl]
	call makpkg
	move o2,pk%int(o1)		;keyword uses external
	exch o2,pk%ext(o1)
	movem o2,pk%int(o1)
	movem o1,@[.KEYPACKAGE]
;set up NIL
	move o1,[makstr /NIL/]
	move o2,@[.PACKAGE]
	move o2,pk%int(o2)
	move o3,nil
	call puthsh
	jrst topst		;start top

;WRIREL - write out CLISP.REL, with all of our symbols in it, for use
;  by the LINK interface.
wrirel:	movsi nil1,(gj%fou+gj%sht) ;new version
	hrroi w2,[asciz /CLISP.REL/]
	gtjfn
	 erjmp wrirer
	movem nil1,n			;save JFN in N
	move w2,[<44_30.>\of%wr]	;open binary
	openf
	 erjmp wrirer
 ;NAME block
	move w2,[6,,1]
	bout
	movei w2,0
	bout
	move w2,[.rsqz 0,CLISP]
	bout
 ;SYMBOL block
	hlre w2,116		;get count, negative
	movn w2,w2		;make positive
	subi w2,2		;leave out the program name
	hrli w2,2		;block type 2
	bout
	move w3,116		;W3 - AOBJN word for symbols
	add w3,[2,,0]		;leave out the program name
	setz w4,		;W4 - counter for every 22 words
  ;main loop - here to output another symbol if there is one left
wrirl:	sojg w4,wrirn		;if W4 non-zero, normal case
  ;W4 exhausted, time for a relocation word
	movei w2,0		;none relocatable
	bout
	movei w4,11		;reinit W4 for 11 symbols (22 words)
  ;normal symbol output
wrirn:	move w2,(w3)		;get symbol
	hlrz o1,w2		;O1 - LH of symbol
	hlrz o2,1(w3)		;O2 - LH of value
	trz o1,740000		;clear flags in symbol
	caie o1,014772		;symbol = G00xxx
	cain o2,(object ty%ccn,<datsec,,0>) ;dummy symbol inside atom
	jrst wrirn1		;leave local
	tlne w2,040000		;already global or PNAME?
	jrst wrirn1		;yes - leave it alone
	tlne w2,100000		;local?
	tlc w2,140000		;yes - make global
wrirn1:	bout			;output it
	aobjp w3,wrire		;go to next
	move w2,(w3)		;get value
	bout			;put it out
	aobjn w3,wrirl
  ;done with symbols
wrire:		
 ;END block
	move w2,[5,,2]
	bout
	movei w2,0
	bout
	bout
	bout
 ;now finished
	closf
	 erjmp .+1
	setz nil1,
	setzb o1,o2
	ret1

wrirer:	hrroi nil1,[asciz /Can't open CLISP.REL/]
	esout
	setz nil1,
	setzb o1,o2
	ret1
;forward decls - these belong on the page with CAR and CDR
define docar(x,y)
	move x,(y)
	termin

define pushcar(x,y)
	push x,(y)
	termin
	
define docdr(x,y)
	move x,1(y)
	termin

define pushcdr(x,y)
	push x,1(y)
	termin

define doboth(x,y)
	dmove x,(y)
	termin

;;TY%CON
define dorpd(x,y)
	movem y,1(x)
	termin

;;TY%CON
define docons(x,y,z)		; x gets (y . z)
	caml free,lastl		;make sure there is space
	 call sgc		;special version of GC that saves AC's
	push free,y		;and set car and cdr
	push free,z
	xmovei x,-1(free)	;return pointer to this
	tlo x,(object(ty%con,0)) ;as cons cell
	termin

;;TY%ATM
define gbind(x,y)		;bind x to y using z as temp
;	came x,[%NIL]
	camn x,[%T]
	jrst illreb
	ssymb x			;and make sure it is an atom
	jrst illreb
	push sp,x		;save old value
	push sp,at%val(x)
	setgval x,y
	termin

;FASBIND is used where the thing to be bound need not be checked
;when the function was defined.
;;TY%ATM
define fasgbind(x,y)
	push sp,x
	push sp,at%val(x)
	setgval x,y
	termin

;BINDIT is used when we have a particular atom
;ATOM is an actual atom
;Y is an AC with the new value
;;TY%ATM
define bindit(atom,y)
	push sp,[atom]
	push sp,@[datsec,,atom+at%val]
	movem y,@[datsec,,atom+at%val]
	termin

;;TY%ATM
define setgval(atom,value)
	movem value,at%val(atom)
	termin

;;TY%ATM
define putval(atom,value)
	movem value,@[datsec,,atom+at%val]
	termin

;;TY%INT

inum0==object(ty%lpi,0)

define inum (n)
<n>+inum0 termin

define posnum(ac)
	tlz ac,760000 termin

define negnum(ac)
	tlo ac,760000 termin

define getnum(ac)
	sub ac,[inum0]
	termin

; skip if ac an inum
define skpin (ac)
	camge ac,[object ty%lni,0] termin
; -- not an inum
define skpnin (ac)
	caml ac,[object ty%lni,0] termin



;;TY%INT
; make a bare number into an inum
define maknum(ac)
	add ac,[inum0]
	termin

;canonical way of converting something that is known to be a positive
;INUM to a bare number in a working AC.
define ldint(dest,source)
	move dest,source
	posnum dest
	termin	

;;TY%IFL
; make a bare floating point number into an iflon
define makifl(ac)
	ash ac,-4
	tloe ac,240000
	 tlz ac,540000
	termin

define iflon(num)
	<num/20+<240000,,0>> termin
;I/O - TYI and TYO
;knows about representation of TY%CHN, and characters.  This should be the
;only page (except for the GC, to some extent) that knows about
;channels.  The string stuff will probably have to know about char's.
;Anyone else wanting to convert from char objects to char's should use
;the macros GETCHR and MAKCHR.

;locals to this page: 

;variables for terminal I/O:

	.vector trmbuf(winpgs*1000) ;terminal input buffer

eolchr==12			;this is the character used to represent eoln

;macros for people to convert between char objects and characters

;GETCHR(AC) - convert char object in AC to ASCII character
define getchr(ac)
	tlz ac,770000		;clear type code
  termin

;MAKCHR(AC) - convert ASCII char in AC to char object
define makchr(ac)
	tlo ac,(object(ty%chr,0)) ;and make char
  termin

;MAKDIG(AC) - convert numeric value in AC to ASCII char for the digit
define makdig(ac)
	caile ac,9.
	 addi ac,"A"-"9"-1
	add ac,[object ty%chr,"0"] ;and make char
  termin

;CHAR(ch) - a character object with this code
define char(ch)
	object(ty%chr,ch) termin

;Channels have the following form:
;	jfn
;	line length
;	char's left on the line
ch%spc==0	;code for gc - may be ch%666-1 or ch%666-2 depending upon
		;whether the data in ch%dat is GC'able or not
ch%jfn==1	;these are bare numbers.  ch%jfn should be used only for
		;numbers that JSYS's will accept as file designators.
		;0 is for a stream that doesn't have a JFN
		;-1 is for a stream that did but is now closed
		;if this is non-zero, i.e. a JFN or -1, then CH%DAT
		;is the filespec that was used to open the file
ch%len==2
ch%pos==3
ch%get==4	;routine for tyi
ch%put==5	;routine for physical put
;ch%get and ch%put are required to be contiguous
ch%dsp==6	;dispatch for less-used routines
 ch%ura==0		;unread
 ch%unr==ch%dsp		;we arrange for a direct dispatch here
 ch%cps==1		;curpos
 ch%sps==2		;setpos
 ch%clo==3		;close
 ch%lsn==4		;listen
 ch%cbi==5		;clear buffer
 ch%lps==6		;get line position
 ch%fin==7		;finish
 ch%frc==10		;force
 ch%cbo==11		;clear output buffer
 ch%siz==12		;file size
 ch%trp==13		;terpri
 ch%elt==14		;element type
 ch%dnm==15		;number of dispatch entries
;the following macro defines which entries have the channel
; in O2.  The rest are in O1
define use2m(addr)
	use2==<addr-ch%ura>*<addr-ch%sps>*<addr-ch%lps>*<addr-ch%trp>*<addr-ch%elt>
	termin
ch%lka==7	;lookahead character in case we backed up
ch%lst==10	;last char read for unread
ch%buf==11	;address of window
ch%pag==12	;file page mapped to window
ch%bpt==13	;byte pointer
 ;two-word byte pointer
ch%bct==15	;byte count
;the following words have different meanings in different modes
   ;for pmapped files and strings
ch%bfs==16	;bytes per window
ch%cby==17	;current byte in file
ch%lby==20	;last byte in file
ch%lts==21	;line number test word
   ;for terminals
ch%rbp==16	;^R buffer byte pointer, 2 words
ch%rbc==20	;^R buffer count
ch%tmd==21	;Lisp terminal modes
 tm%esc==1	;understand escape sequences as single terminators
		;  not yet implemented
 tm%eco==2	;echo
;end of different types
ch%typ==22	;data type
 ct%str==0	;7-bit character
 ct%chr==1	;full character
 ct%uns==2	;unsigned, LH is byte size
 ct%sgn==3	;signed, LH is byte size.  Note that 36-bit signed
		;  I/O is implemented using CT%UNS
 ct%bin==2	;this bit is on for binary modes
ch%pgs==23	;bytes per page
 ch%obl==23		;alternate defn for string output channels
ch%dat==24	;mode-dependent data
ch%666==24	;last entry

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; output
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;This section is organized in layers.
;;;;1) TYO and TYOUT, which just handle conversion from character
;;;;	to full-words in W2.
;;;;2) device-dependent routines that actually put out the characters.
;;;;	Because of the way streams are done, these have to do the
;;;;	accounting for current line position.

;oustrm ac is used to normalize a stream argument
define oustrm(ac)
	camn ac,[%T]
	move ac,@[.trmio]
	skipn ac
	move ac,@[.stdout]
	xtype ac
	caie w2,ty%xch
	jrst [err1 ac,/Not a stream: ~S/]
   termin

;;;;;;;;;;;;;;;LEVEL 1 --  TYO and TYOUT;;;;;;;;;;;;;;;;;


;tyout - prints an asciz string - string in w2
;this is an internal routine only, so it does not return a value
;assumes stream in O2
tyout:	push p,[440740,,0]	;make up byte pointer at -1(p)
	push p,w2
tyolp:	ildb w2,-1(p)		;next char
	jumpe w2,tyoend		;done
	cain w2,15		;ignore CR's, since LF alone is enough
	 jrst tyolp
	makchr w2
	move o1,w2
	call tyo
	jrst tyolp
tyoend:	subi p,2
	ret1

;;;WRITE-CHAR
writch:	move o2,@[.stdout]	;default
	oustrm o2
	push q,o1
	call tyo
	pop q,o1
	ret1

;;;WRITE-BYTE
wrtbyt:	oustrm o2
	hrrz w2,ch%typ(o2)	;see what type it is
	xct wrtbtb(w2)
	jrst @ch%put(o2)	;now put it out

wrtbtb:	call ch2int
	call ch2int
	call get1nt
	call get1nt

ch2int:	move w2,o1
	getchr w2
	ret1

;;TY%CHN
;TYO
; o1 - output char
; o2 - output stream
tyo:	move w2,o1
	getchr w2
	caie w2,eolchr		;if official end of line char
	 jrst @ch%put(o2)	;not, just do it
	move w2,ch%dsp(o2)	;yes - do terpri instead
	jrst @ch%trp(w2)

;;;;;;;;;;;;;;;;LEVEL 2 -- device-dependent routines;;;;;;;;;;;;;

;these routines always take an ASCII char in W2.
;o2 is assumed to contain the channel object

;this is the normal put routine, for physical devices
norput:	hrrz nil1,ch%jfn(o2)
	bout
	setz nil1,
;now account for this in ch%pos
;until we fix this for common Lisp, do the following special tests
;putact is assumed to leave w2 alone
putact:	aos ch%pos(o2)		;assume normal character
	cail w2,0
	 caile w2,15		;quickly separate cases that need work
	  iret
	xct .+2(w2)
	iret

	iret		;0 - nul
	iret		;1 - ^A
	iret		;2 - ^B
	iret		;3 - ^C
	iret		;4 - ^D
	iret		;5 - ^E
	iret		;6 - ^F
	iret		;7 - ^G
	iret		;10 - ^H
	jrst putatb	;11 - tab
	setzm ch%pos(o2) ;12 - lf
	iret		;13 - ^K
	setzm ch%pos(o2) ;14 - ^L
	setzm ch%pos(o2) ;15 - ^M

;account for tab
putatb:	sos w3,ch%pos(o2)	;w3 is now 0 if at start of line
	trz w3,7
	addi w3,10		;w3 is now next tab stop
	movem w3,ch%pos(o2)
	iret

;terpri
nortrp:	movei w2,15
	call @ch%put(o2)
	movei w2,12
	jrst @ch%put(o2)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  input
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;TYI is in three levels:
;;;;;; 1) TYI and its subroutine is device-independent.  Its only
;;;;;;		intelligence is skipping null and getting the channel
;;;;;; 2) device dependent routines do the actual I/O
;;;;;;	   These routines must handle UNREAD, because of the requirements
;;;;;;	   For implementing odd stream types.


;;;;;;;;;;;;;;;;;;;;;;;LEVEL 1 -- TYI;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Currently this level is reponsible for converting the output to
;a Lisp object.  It also implements the EOF action, depending
;upon which function is called.

;internal entry when we want to see EOF, channel in O2
;preserves O2, nothing else guaranteed
tyie:	call @ch%get(o2)	;read char
	 iret			;eof
	 jrst tyie		;skip CR in CRLF
	aos (p)			;normal return
	tlz w2,770000
	makchr w2		;make Lisp object
	move o1,w2		;return it
	iret

;internal entry when we want EOF to be an error, channel in O2
;preserves O2, nothing else guaranteed
tyi:	call @ch%get(o2)	;read char
	 jrst eoferr
	 jrst tyi		;skip CR in CRLF
	tlz w2,770000
	makchr w2		;make Lisp object
	move o1,w2		;return it
	iret

eoferr:	err1 o2,/Unexpected EOF on channel ~S/

;;;;;;;;;;;;;;;;;;;LEVEL 2 -- actual I/O routines;;;;;;;;;;;;;;;;;;;
;get a char into W2, preserve O2, which is the channel object.
;  other AC's free

;;TY%CHN
;norget is for everything except terminals
norget:	skipl w2,ch%lka(o2)	;lookahead?
	 jrst getlka		;yes, use it
	hrrz nil1,ch%jfn(o2)	;jfn
	bin			;do the input
	 erjmp getclr		;eof
	movem w2,ch%lst(o2)	;save for unread
	aos (p)			;assume not CR
	aos (p)
	cain w2,15
	 jrst norcr
	setz nil1,
	iret

;here if we have a CR.  Check for LF immediately following
norcr:	sibe			;fix due to Upsala
	 jrst norcry
	sos (p)
	movei w2,15
	setz nil1,
	iret

norcry:	bin			;do the input
	 erjmp norcrx		;if EOF, not LF
	caie w2,12		;well, is it?
	 jrst norcrx		;no
	sos (p)			;yes, so take skip 1
norcrx:	bkjfn			;now back over the peeked char
	 erjmp [ caie nil1,sfptx2	;[Victor] Illegal for this file?
		  jrst norcrz	;[Victor] No, other error
		 movem w2,ch%lst(o2)	;[Victor] ** This is a kludge!
		 call norunr	;[Victor] Unread the char softwarily
		 jrst norcxx ]	;[Victor] and proceed as normal
norcxx:	movei w2,15		;put back the CR
	setz nil1,
	iret

; [Victor] end of kludge
norcrz:	err /Can't unread in NORCR - contact a system programmer/

;here at EOF
;this is an entry from other drivers.
getclr:	setz nil1,
	setom ch%lst(o2)	;say no last char
	iret

;here if found a lookahead char
;this is an entry from other drivers
getlka:	setom ch%lka(o2)	;no more lookahead
	movem w2,ch%lst(o2)
	aos (p)
	aos (p)			;normal return
	iret

;unread - back up pointer
;internal entry- O2 is channel, preserved
norunr:	move w2,ch%lst(o2)	;get last char
	movem w2,ch%lka(o2)	;and use for lookahead
	iret

;get element type to w2
norelt:	move w2,ch%typ(o2)
	iret
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Terminal I/O
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;offsets into the buffer pages
bf%siz==winpgs*1000/2		;size of buffer or ^R buffer
bf%buf==0			;normal buffer
bf%ctr==winpgs*1000/2		;

;here from OPEN with channel in O1, open bits in W4
trmopn:	ldb w2,[.bp 77_30.,w4]	;look at byte size
	cain w2,10		;if binary open
	 iret			;then use bin/bout
	movei w2,winpgs		;number of pages in window
	call getbuf		;get the buffer
	movem w2,ch%buf(o1)	;save its address

;this is an entry from IOINIT to reinit TRMCHN
trmini:	setzm ch%bct(o1)
	movei w2,tm%eco		;say we are echoing
	movem w2,ch%tmd(o1)
;init ^R buffer
	move w3,ch%buf(o1)	;get main buffer
	addi w3,bf%ctr		; adjust to ^R buffer
	move w2,[440740,,0]	;make byte pointer
	dmovem w2,ch%rbp(o1)	;save as pointer to ^R buffer
	movei w2,5*bf%siz	;reinit ^R buffer count
	movem w2,ch%rbc(o1)
	dmove w2,[codsec,,trmget ? codsec,,trmput]
	dmovem w2,ch%get(o1)
	move w2,[disp trmdsp]
	movem w2,ch%dsp(o1)
	hrrz nil1,ch%jfn(o1)	;get the tty page width
	movei w2,.morlw
	mtopr
	skipe w3		;if it is set, get linelength from it
	movem w3,ch%len(o1)	;set linelength to tty width
	setz nil1,
	iret

;special read from terminal
trmget:	skipl w2,ch%lka(o2)	;lookahead?
	 jrst getlka		;yes, use it
	sosge ch%bct(o2)	;anything there?
	 jrst trmgbf		;no - get a buffer
	ildb w2,ch%bpt(o2)
	cain w2,32		;eof?
	 jrst trmgef		;probably
trmnor:	aos (p)			;assume no cr
	aos (p)
	movem w2,ch%lst(o2)	;save for unread
	cain w2,15		;cr?
	 jrst trmcr		;yes, check for lf
	iret

;here if CR.  See if LF following.  Because of the way TEXTI works,
; if there is an LF, it will always be in the same buffer.  (This
; assumes that the user doesn't have a line longer than 5000 
; characters.)
;this is also used for emacs buffers
trmcr:	skipg ch%bct(o2)	;anything more there?
	 iret			;for the moment just return.  This
				;  shouldn't be possible
	dmove w2,ch%bpt(o2)	;get byte pointer
	ildb w2,w2		;and the next char
	caie w2,12		;lf?
	 jrst trmcrx		;no, done
	sos (p)			;yes, skip 1 return
trmcrx:	movei w2,15		;put back the CR
	iret

;here if ^Z.  EOF, except if .priin, then don't let him do EOF
trmgef:	hrrz w3,ch%jfn(o2)
	caie w3,.priin
	 cain w3,.priin
	  jrst trmnor		;ignore it
trmeof:	xmovei w3,getclr	;make sure he can't continue reading
	movem w3,ch%get(o2)
	jrst getclr		;and go do it now

;Note that terminal input and output are linked.  Output goes into
;the ^R buffer and input increments CHRPOS.

;here if buffer empty
trmgbf:	dmove nil1,ch%rbp(o2)	;make asciz
	idpb nil,nil1
;set up normal TOPS-20 CCOC words.  We have made things transparent
;for writing.
	addi p,2		;save space for them in any case
	move w2,ch%tmd(o2)
	trnn w2,tm%esc		;if in escape mode
	jrst trmgb0		;not, leave CCOC alone
	hrrz nil1,ch%jfn(o2)
	rfcoc			;get current echoing, etc.
	dmovem w2,-1(p)		;save old
	trz w3,600000		;don't do anything for escape
	sfcoc
;make up texti argument block
trmgb0:	push p,[.rdrty]		;0: number of words
	move nil1,p		;addr of this block
	push p,[rd%top+rd%jfn]	;1: Tops-10 break chars, JFN's supplied
	move w2,ch%jfn(o2)
	hrl w2,w2
	push p,w2		;2: jfn,,jfn
	move w2,ch%buf(o2)	;   address of buffer
	tlo w2,610000		;   make byte pointer
	push p,w2		;3: destination buffer
	push p,[5*bf%siz]	;4: number of chars
	push p,w2		;5: destination buffer
	addi w2,bf%ctr		;   offset to ^R buffer
	push p,w2		;6: ^R buffer
	texti
	 jrst textir
;restore CCOC if we changed it
	move w2,ch%tmd(o2)
	trnn w2,tm%esc		;if in escape mode
	jrst trmgs1		;not, leave CCOC alone, and ignore escape
	hrrz nil1,ch%jfn(o2)
	dmove w2,-10(p)		;get back old CCOC
	sfcoc			;and restore it
	ldb w2,-3(p)		;look at last char
	cain w2,33		;if it is escape
	 jrst trmges		;it is special
trmgs1:	move w2,-2(p)		;get count
	subi w2,5*bf%siz
	subi p,11
	movnm w2,ch%bct(o2)	;save as read count
	move w3,ch%buf(o2)	;address of buffer
	move w2,[440740,,0]	;make byte pointer
	dmovem w2,ch%bpt(o2)	;save as read byte pointer
	hrrz nil1,ch%jfn(o2)	;get jfn again
	rfpos			;see where we are now
	tlz w2,777777		;clear vertical position
	setz nil1,
	movem w2,ch%pos(o2)	;set this as new line position
	jumpg w2,trmgb2		;continue if we are still on same line
;here if we are now on a new line - reinit ^R buffer, etc.	
	move w3,ch%buf(o2)	;address of buffer
	addi w3,bf%ctr		; adjust to ^R buffer
	move w2,[440740,,0]	;make byte pointer
	dmovem w2,ch%rbp(o2)	;save as pointer to ^R buffer
	movei w2,5*bf%siz	;reinit ^R buffer count
	movem w2,ch%rbc(o2)
	jrst trmget		;now go read char

;here for error after texti
textir:	move w2,ch%tmd(o2)
	trnn w2,tm%esc		;if in escape mode
	jrst txtir1		;not, leave CCOC alone, and ignore escape
	hrrz nil1,ch%jfn(o2)
	dmove w2,-10(p)		;get back old CCOC
	sfcoc			;and restore it
txtir1:	setz nil1,
	err /Error in terminal input/


;here if we are on the same line after an RDTTY.  copy new line
;to ^R buffer.
trmgb2:	push p,w4
	move w4,ch%tmd(o2)	;see if echoing
	trnn w4,tm%eco		;if not
	 jrst trmgb4		;  forget all this
	move w2,ch%bct(o2)	;number of chars
	dmove w3,ch%bpt(o2)	;byte pointer
	jumpe w2,trmgb4		;done if none
trmgb3:	ildb nil1,w3		;copy into ^R buffer
	sosl ch%rbc(o2)		;if room
	idpb nil1,ch%rbp(o2)	;copy the char
	sojg w2,trmgb3
trmgb4:	setz nil1,
	pop p,w4
	jrst trmget		;now process char

;here if TEXTI ends with escape.  Look for special escape sequences.
;This is so cursor-up activiates.
trmges:	hrrz nil1,ch%jfn(o2)
;we are parsing escape sequences.  What fun...
	sosge -2(p)		;any space left?
	 jrst [	aos -2(p)	;no, so don't worry
		jrst trmgs1]
;possible syntax:
;  esc 40-57  ....  60-176
;  esc 73  40-57 ... 60-176
;  esc 77  40-57 ... 60-176
;  esc 117 40-57 ... 100-176
;  esc 133 60-77 ... 40-57 ... 100-176
;in addition to those (which the VAX allows), we allow esc followed
;by anything else as a 2-char sequence.  This is for the VT52 and
;anything else

;turn echo off during this
	rfmod
	movem w2,(p)		;save for later restoration
	trz w2,tt%eco		;turn off echoing
	sfmod
;get the first char after it
	bin
	erjmp [	move w2,(p)
		sfmod
		setz nil1,
		err /Error reading from terminal/]
	idpb w2,-3(p)		;put it in
	movei w3,60		;assume this is the terminator
	caie w2,117		;but for these
	 cain w2,133
	  jrst [movei w3,100	;sequence stops with alphabetic
		jrst trmgsl]
	caie w2,73
	 cain w2,77		;these are also legal
	  jrst trmgsl
	cail w2,40		;so are these
	 caile w2,57
	  jrst trmgsx		;this isn't - stop here
;now look for end of sequence.  End char is in W3
trmgsl:	sosge -2(p)		;any space left?
	 jrst [	aos -2(p)	;no, so don't worry
		jrst trmgsx]
	bin
	erjmp [	move w2,(p)
		sfmod
		setz nil1,
		err /Error reading from terminal/]
	idpb w2,-3(p)		;put it in
	caml w2,w3		;terminator?
	 caile w2,176
	  jrst trmgsl		;no, try again
;here at end of sequence
trmgsx:	move w2,(p)		;restore echo
	sfmod
	jrst trmgs1		;yes, that's it


;this is a special put for the controlling terminal.  It interfaces
;with the ^R buffer, etc.
trmput:	hrrz nil1,ch%jfn(o2)
	bout
	call putact
	setz nil1,
	skipe ch%pos(o2)
	jrst trmpt2		;if still on same line, put in ^R buffer
;here if we are now on a new line - reinit ^R buffer, etc.	
	push p,w2
	move w3,ch%buf(o2)	;address of buffer
	addi w3,bf%ctr		; adjust to ^R buffer
	move w2,[440740,,0]	;make byte pointer
	dmovem w2,ch%rbp(o2)	;save as pointer to ^R buffer
	movei w2,5*bf%siz	;reinit ^R buffer count
	movem w2,ch%rbc(o2)
	pop p,w2
	iret

;here if on same line
trmpt2:	sosl ch%rbc(o2)		;if room, put it in ^R buffer
	idpb w2,ch%rbp(o2)
	iret

;pass-all get
trmpgt:	skipl w2,ch%lka(o2)	;lookahead?
	 jrst getlka		;yes, use it
	hrrz nil1,ch%jfn(o2)	;jfn
	bin			;do the input
	 erjmp [setz nil1,
		err /Error on terminal input/]
;note that we don't strip parity until after echoing
	caie w2,232		;might be wierd parity
	 cain w2,32		;^Z is EOF
	  jrst [caie nil1,.priin	;except not on primary I/O
		 cain nil1,.priou
		  jrst .+1
		jrst trmeof]
	move w3,ch%tmd(o2)	;see if we have to echo it
	trne w3,tm%eco
	bout			;yes
	setz nil1,
	andi w2,177		;strip parity
	movem w2,ch%lst(o2)	;save as last char
	aos (p)			;not that we see LF as a separate char here
	aos (p)			;take normal return
	jrst putact		;account for it on line

;listen for terminal
;
trmlsn:	skipg ch%bct(o1)	;if something in buffer
	skipl ch%lka(o1)	;or if lookahead
	jrst nlsnef		;then we have input
	jrst nlssib		;else try SIBE

;clrbfi for terminal
trmcbi:	setzm ch%bct(o1)
	jrst norcbi

;close for terminal
trmclo:	hrrz w2,ch%jfn(o1)
	caie w2,.priou
	 cain w2,.priin
	  jrst [err /You can't close the primary terminal channel/]
	move w2,ch%buf(o1)	;addr of buffer
	movei w3,winpgs		;its size
	call relbuf		;release it
	jrst norclo		;now finish the close

;(%SP-SET-TERMINAL-MODES term arg-list)

	.scalar orgtiw,trmcoc(2)

sstmod:	oustrm o1
	push q,o2		;save list of modes
	move w2,ch%dsp(o1)	;make sure this is really a terminal
	came w2,[disp trmdsp]
	 jrst [err1 o1,/SET-TERMINAL-MODES used for something not a terminal: ~S/]
	hrrz nil1,ch%jfn(o1)	;everybody needs the JFN
;loop over requested modes
stmodl:	move o2,(q)
	jumpe o2,stmodx		;done
	scons o2
	 jrst [	setz nil1,
		err /Impossible keyword list/]
	doboth o3,o2		;o3 - keyword, o4 -rest
	scons o4
	 jrst [	setz nil1,
		err /Impossible keyword list/]
	doboth o4,o4		;o4 - value, o5 - rest
	movem o5,(q)
;now have o3 - keyword, o4 - value
	camn o3,[$BROADCAST]
	 jrst stmbrd
	camn o3,[$ECHO]
	 jrst stmech
	camn o3,[$ESCAPE]
	 jrst stmesc
	camn o3,[$PASSALL]
	 jrst stmpas
	camn o3,[$PAUSE]
	 jrst stmpau
	camn o3,[$WRAP]
	 jrst stmrap
	camn o3,[$TRANSLATE]
	 jrst stmtrn
	jrst stmodl		;ignore others

;exit
stmodx:	subi q,1
	setzb o1,nil1
	retn

;broadcast [receive system]
stmbrd:	movei w3,1		;assume refuse
	skipe o4
	movei w3,0		;unless he requests allow
	movei w2,.mosnt
	mtopr
	jrst stmodl

;echo
stmech:	rfmod
	move w4,ch%tmd(o1)	;have to set flag here also
	skipn o4
	jrst [	trz w2,tt%eco
		trz w4,tm%eco
		jrst stmec1]
	tro w2,tt%eco
	tro w4,tm%eco
stmec1:	sfmod
	movem w4,ch%tmd(o1)
	jrst stmodl

;escape [this one is simulated by Lisp]
stmesc:	move w2,ch%tmd(o1)
	skipn o4
	trz w2,tm%esc
	skipe o4
	tro w2,tm%esc
	movem w2,ch%tmd(o1)
	jrst stmodl

;pass-all [binary mode - note: this is not real 8-bit]
stmpas:	rfmod
	jumpe o4,stmps0		;pass-all NIL
;T [i.e. anything else] - real binary mode
	trz w2,300		;passall means go to binary
	sfmod
	xmovei w3,trmpgt	;also special input routine
	movem w3,ch%get(o1)
	movei nil1,-5		;get old TIW
	rtiw
	skipe w2		;if interrupts now on
	 movem w2,orgtiw	; save them
	setzb w2,w3		;now turn off interrupts
	stiw
	 erjmp .+1		;forget it if we can't
	hrrz nil1,ch%jfn(o1)	;[PEM]: Was move but we don't want the flags.
	jrst stmodl

;here for normal mode
stmps0:	push p,w2		;save old
	trz w2,300		;not passall means ascii mode
	tro w2,100		;normal mode
	sfmod
	xmovei w3,trmget	;and normal input routine
	movem w3,ch%get(o1)
	movei nil1,-5		;now turn interrupts back on
	rtiw			;see if interrupts are now off
	jumpn w2,stmps1		;no, they're on, so don't do anything
	skipe w2,orgtiw		;if we have saved interrupts
	 stiw			;reset them
	  erjmp .+1
stmps1:	hrrz nil1,ch%jfn(o1)	;[PEM]: Was move but we don't want the flags.
;also, when leaving binary mode, all sorts of junk may be in
;the ^R buffer, so clear it.
	pop p,w3		;get back original modes
	trne w3,300		;if it was binary
	 jrst stmodl		;not
	move w4,ch%buf(o2)	;address of buffer
	addi w4,bf%ctr		; adjust to ^R buffer
	move w3,[440740,,0]	;make byte pointer
	dmovem w3,ch%rbp(o2)	;save as pointer to ^R buffer
	movei w3,5*bf%siz	;reinit ^R buffer count
	movem w3,ch%rbc(o2)
	jrst stmodl

;wrap means page width
stmrap:	skpin o4		;inum argument?
	jrst stmrpf		;no, just a flag
	move w3,o4		;yes, use it
	getnum w3
stmrps:	movei w2,.moslw	;set width
	mtopr
	jrst stmodl

stmrpf:	skipe w3,o4		;nil means use 0
	move w3,ch%len(o1)	;else use width
	jrst stmrps

;pause [at end of page]
stmpau:	skipe o4
	movei w3,1
	skipn o4
	movei w3,0
	movei w2,.moxof		;pause at end of  page
	mtopr
	jrst stmodl

;translate
stmtrn:	rfcoc
	move w4,w2		;save setting of tab
	andi w4,600000		;isolate tab setting
	dmove w2,trncoc		;assume normal Tops-20 translate table
	skipn o4
	dmove w2,ntrcoc		;but if turnning off, use special one
	ior w2,w4		;now add in tab
	sfcoc			;and set it
	caie nil1,.priin	;if primary I/O
	 cain nil1,.priou
	  jrst .+2
	   jrst stmodl
	dmovem w2,trmcoc	;save this for restart
	jrst stmodl

;table for no translate
ntrcoc:	525252,,125252		;send all but tab
	525252,,525252

;table for translate
trncoc:	52531,,153125
	252125,,652400

;(GET-TERMINAL-MODES terminal)
gtmod:	oustrm o1
	move w2,ch%dsp(o1)	;make sure this is really a terminal
	came w2,[disp trmdsp]
	 jrst [err1 o1,/GET-TERMINAL-MODES used for something not a terminal: ~S/]
	hrrz nil1,ch%jfn(o1)	;everybody needs the JFN
	move o2,o1
;wrap
	movei w2,.morlw
	mtopr
	skipe w3		;if 0, leave as NIL
	maknum w3		;else make number
	push q,w3		;conses moved, GC screws nil1 etc
;translate
	rfcoc
	trz w2,600000		;clear tab
	movei o4,nil		;assume not
	camn w2,ntrcoc		;any funny bits?
	 came w3,ntrcoc+1
	  move o4,[%T]		;yes, so assume translate
	push q,o4		;[Victor] O4, not 04 !!!
;pause
	movei w2,.morxo
	mtopr
	move o4,[%T]		;assume pause
	skipn w3
	movei o4,nil
	push q,o4
;passall
	rfmod
	move w4,w2		;save mode word in W4
	move o4,[%T]		;assume passall
	trne w4,300
	movei o4,nil		;unless not
	push q,o4
;escape
	move o4,[%T]		;assume escape
	move w2,ch%tmd(o2)	;get flag words
	trnn w2,tm%esc
	movei o4,nil
	push q,o4
;echo
	move o4,[%T]		;assume echo
	trnn w4,tt%eco		;except if not
	movei o4,nil
	push q,o4
;broadcast
	movei w2,.mornt		;receive system message
	mtopr
	move o4,[%T]		;assume broadcast
	skipe w3
	movei o4,nil		;except if refuse, then no broadcast
	setz nil1,

	docons o1,-5(q),nil
	docons o1,[$WRAP],o1
	docons o1,-4(q),o1
	docons o1,[$TRANSLATE],o1
	docons o1,-3(q),o1
	docons o1,[$PAUSE],o1
	docons o1,-2(q),o1
	docons o1,[$PASSALL],o1
	docons o1,-1(q),o1
	docons o1,[$ESCAPE],o1
	docons o1,(q),o1
	docons o1,[$ECHO],o1
	docons o1,o4,o1
	docons o1,[$BROADCAST],o1
	subi q,6
	ret1

;put for pmapped I/O
dskput:	aos w3,ch%cby(o2)	;advance current byte
	camle w3,ch%lby(o2)	;beyond end seen so far?
	movem w3,ch%lby(o2)	;yes - update it
	sosge ch%bct(o2)	;room in buffer?
	 call dskadv		;no - next
	idpb w2,ch%bpt(o2)
	 ercal maperr
	jrst putact		;account for space on line

;This routine is called when we get an error upon attempting access
; to a page.  It makes assumes that the caller uses the following
; sequence:
;	aos ch%cby(o2)
;	sos ch%bct(o2)
;	idpb/ildb w2,ch%bpt(o2)
;	 ercal maperr
; as it will undo the sideeffects of these operations if necessary.
;    When a hole is found (only possible on read), we just have to set w2
;    to zero after clearing the page.
; But on a real error, we have to back out all the operations shown
;	and abort the caller.

maperr:	
;for tops-20 the most likely thing here is that we tried to read a
;  hole in the file. Tops-20 gives an ill mem read in that case. 
;Also, it may be quota exceeded.
;So the code comes in these pieces:
;  diagnose it - hole in the file?
;  if a hole, then give a zero page
;  else, print an error message and back out of the I/O operation

	sfm w3			;save flags in W4
	tlo w3,020000		;set first part done, as ILDB was interrupted
	move w4,[440700,,w4]	;do an ILDB to clear first part done
	ildb w4,w4		;since ERCAL may leave it set
	push p,w2		;save the char
	movei nil1,400000	;see what error
	geter
	tlz w2,777777		;w2 _ error code
	cain w2,iox11		;if quota error
	jrst mapquo		;special handling
	pop p,w2		;put back stack (don't care about char now)
;here we check to see if the page is perhaps nonexistent in the file
;if so, we treat it as zeros.  
	move nil1,ch%bpt+1(o2)	;addr of core page
	lsh nil1,-11		;convert to page
	hrli nil1,.fhslf	;in our fork
	rpacs
	 erjmp maper3		;treat this as an I/O error
;The case we are looking for is read-only access and an indirect pointer
	tlnn w2,(pa%wt)		;if have write access, not this problem
	tlnn w2,(pa%ind)	;if indirect too, that is it
	jrst maper3		;write access or not indirect: normal error
  ;here if it is a hole.  clear the page
maper1: move w2,nil1		;b _ .fhslf,,core page no.
	seto nil1,		;clear page
	setz w3,		;no counts
	pmap
	 chkquo			;[27]
	 erjmp maper2		;can't clear page
	setzb nil1,w2		;return a zero byte
	iret			;and continue as if ILDB had worked

;here if is a quota error, to retry
mapquo:	hrroi nil1,[asciz / Quota exceeded or disk full for /]
	esout
	movei nil1,.priou
	hrrz w2,ch%jfn(o2)
	push p,w3
	setz w3,
	jfns
	hrroi nil1,[asciz /
[Find some space, then type CONTINUE]
/]
	psout
; Finally we are ready to restore to the user's context and continue,
; if user types CONTINUE
	pop p,w3
	pop p,w2		;restore thing to put out
	pop p,w4		;return address
	subi w4,2		;back to the IDPB
	setz nil1,		;get legal again
	haltf			;let him delete some files
	xjrstf w3		;flags (including first part done) are in W4

;here is the beginning of the true error code.
maper2:	
maper3:
	sos ch%cby(o2)		;move back
	aos ch%bct(o2)
;the following should use ADJBP with -1, but that doesn't work in extended
;addressing (at least in release 4)
	ldb w3,[.bp 77_24.,ch%bpt(o2)] ;byte size
	ldb w2,[.bp 77_30.,ch%bpt(o2)] ;offset - can't be 44, as we have just
					;done ildb
	add w2,w3		;move back a byte
	dpb w2,[.bp 77_30.,ch%bpt(o2)]	;and put it back in byte pointer
	setz nil1,
ioer:	jrst opfer2		;error with file in O2

;this is also used by other device drivers
dskeof:	sos ch%cby(o2)		;yes - don't do the advance
	setom ch%lst(o2)	;say no last char
	iret			;take error return

;get for pmapped I/O
dskget:	skipl w2,ch%lka(o2)	;lookahead?
	 jrst getlka		;yes, use it
	aos w3,ch%cby(o2)	;advance current byte
	camle w3,ch%lby(o2)	;beyond eof?
	 jrst dskeof		;yes - do it
	sosge ch%bct(o2)	;count bytes left in this buffer
	call dskadv		;none - get new buffer
	ildb w2,ch%bpt(o2)	;get character
	 ercal maperr
	move w3,ch%lts(o2)	;line no. test bit if 7 bit mode
	tdne w3,@ch%bpt+1(o2)	;was it a line no.?
	 jrst dsklnr		;yes, skip it
	movem w2,ch%lst(o2)	;save as last char read
	cain w2,15		;see if need eol handling
	 jrst dskcr
	aos (p)			;no, normal return
	aos (p)
	iret

;here if we found a CR.  See if it is followed by LF
dskcr:	aos (p)			;assume not CRLF
	aos (p)
	move w3,ch%cby(o2)	;get current byte
	caml w3,ch%lby(o2)	;is next one beyond eof?
	 jrst dskcrx		;yes, not CRLF
	sosge ch%bct(o2)	;count bytes left in this buffer
	call dskadv		;none - get new buffer
	ildb w2,ch%bpt(o2)	;get character
	 ercal maperr
;don't bother to check for line number.  No line number is going to
;begin in LF.
	caie w2,12		;LF?
	 jrst dskcrb		;no, back up over it
;here if we have CRLF.  Take skip 1 return
	sos (p)	
;here if we have advanced - back up
dskcrb:	aos ch%bct(o2)		;one more byte there
	movni w2,1		;move back pointer by one
	adjbp w2,ch%bpt(o2)
	dmovem w2,ch%bpt(o2)
;here if not a CRLF - return the CR to W2 and exit
dskcrx:	movei w2,15
	iret

;currently we aren't giving the user the line number
;	move w3,@ch%bpt(o2)	;line no. - get it
;	movem w3,...		;save it for user
dsklnr:	aos ch%bpt+1(o2)	;skip it
	movei w3,5		;update currentposition
	addm w3,ch%cby(o2)
	movni w3,5		;note getchb already skipped one char, so
	addb w3,ch%bct(o2)	; we only skip 5
	jumpge w3,dskget	;now get real character
;the context in which dskadv is valid is where we have just done sosge ch%bct,
;and are about to do ildb.  Usually this is right, as in the subtraction of
;5 above, 1 of the 5 is in the new block.   so that is the sosge.  we will
;still have to do an ibp afterwards, though.  If we are further into the
;word than the first char, we now back up, since filadv will leave us at
;the start of the buffer (and its error handling is predicated on the
;assumption that we are working on the first char)
	addi w3,1		;if more than one char into new buffer
	addm w3,ch%cby(o2)	;move back (T is negative)
	call dskadv		;go to new buffer
;this should be IBP, but IBP doesn't work in extended addressing
	ildb w3,ch%bpt(o2)	;pass over first char (tab)
	jrst dskget		;now go back for real char
;pmap I/O - buffer advance and go to new page

;dskadv - get to the next page when reading sequentially.  If
; the getpage succeeds, this gives new byte ptr, count, etc., for
; the new page.  Otherwise you are left exactly where you were before,
; with filcby adjusted, since the caller is assumed to have
; incremented it.
;    W2 must be preserved, since it has the character in it
dskadv:	move w3,ch%pag(o2)	;old page
	addi w3,winpgs		;new page
	call getfpg		;get page routine
	 jrst badadv		;can't get new page
	move w3,ch%bfs(o2)	;bytes in buffer
	subi w3,1		;caller has done sosge
	movem w3,ch%bct(o2)
	move w3,ch%buf(o2)	;pointer to start of buffer
	movem w3,ch%bpt+1(o2)
	movei w3,44
	dpb w3,[.bp 77_30.,ch%bpt(o2)]
	iret

badadv:	sos ch%cby(o2)		;user has done aos on this
	err /I-O error on disk file/

;getfpg - get specified page 
;	w3 - desired page - preserved
;	w2 - preserved
;  returns:  w3 - requested disk page, skip if works, non-skip if not
;    also resets 
;	ch%pag to indicate we are on a new file page
;    the user is assumed to adjust counts, pointers, etc., as he likes

getfpg:	push p,w2
	push p,w3
	hrr nil1,w3		;desired page
	hrl nil1,ch%jfn(o2)	;on this file
	move w2,ch%buf(o2)	;address of buffer
	lsh w2,-9.		;make page no.
	hrli w2,400000		;current process
	move w3,[pm%cnt\pm%rd\pm%wr\pm%pld\winpgs] ;use count, preload
	pmap
	 chkquo			;[27]
	 erjmp badpag
	setz nil1,
	pop p,w3
	pop p,w2
	movem w3,ch%pag(o2)	;only now can we say are on that page
	aos (p)			;skip return - success
	iret

;note that badpag is called with b&c saved on stack
badpag:	pop p,w3		;we don't change filpag, as haven't moved
	pop p,w2
	setz nil1,
	iret			;error return
;pmap I/O - device dependent openning

;Here after a file has been opened on disk.
;W4 - OPENF bits user asked for (if simulating append, may have used others)
;O1 - file, which must be preserved

;The first problem is to see whether we have enough access to the file to
;   PMAP it.  Write-only or append-only files can't be pmapped.
dskopn:	hrrz nil1,ch%jfn(o1)	;let's see whether we can use PMAP'ed I/O
	gtsts			;w2 - file status
	tlne w2,(gs%opn)	;if not open, nothing we can do
	tlnn w2,(gs%rdf)	;also if can't read, pmap is no use
	iret			;not open or no read
	tlnn w2,(gs%rnd)	;better not be opened append-only
	iret			;it is
	trnn w4,of%wr\of%app	;if he wanted write or append
	jrst dskop1		;no - read is enough
	tlnn w2,(gs%wrf)	;we had better be able to write
	iret			;can't - let monitor figure this out
;If here, we know we will be able to PMAP the file
dskop1:	push p,w4		;save open bits for later users
	skipe w2,ch%buf(o1)	;if there is already a buffer
	jrst dskop2		;we use it
	movei w2,winpgs		;get this many pages
	call getbuf		;returns address in W2
dskop2:	movem w2,ch%buf(o1)	;now set up all the fields
	movem w2,ch%bpt+1(o1)
	ldb w2,[.bp 77_30.,(p)] ;get byte size
	cain w2,0		;if not specified
	movei w2,7		;use ascii
	movei w3,36.		;now compute number of bytes per word
	idiv w3,w2		;w3 - number of bytes per word
	lsh w3,9.		;w3 - number of bytes per page
	movem w3,ch%pgs(o1)
	imuli w3,winpgs		;w3 - number of bytes per buffer
	movem w3,ch%bfs(o1)
	setzm ch%lts(o1)	;assume no line number test needed
	cain w2,7		;if 7-bit
	aos ch%lts(o1)		;then turn on the bit
	lsh w2,24.		;move into byte size field in byte ptr
	tlo w2,440040		;and make pointer to start of word, extended
	movem w2,ch%bpt(o1)	;now we have a full byte pointer (2-word)
	movni w2,winpgs		;set set DSKADV gives first page
	movem w2,ch%pag(o1)
	setom ch%bct(o1)	;no space left
	setzm ch%cby(o1)	;and no char's read
	move w2,[codsec,,dskget] ;set up dispatches
	movem w2,ch%get(o1)
	move w2,[codsec,,dskput]
	movem w2,ch%put(o1)
	move w2,[disp dskdsp]
	movem w2,ch%dsp(o1)

;here we have to split according to the sort of open being done
	pop p,w2		;get back openf bits
	trne w2,of%app		;special code to simulate append
	jrst dskapp
	trnn w2,of%rd		;special code if write-only
	jrst dskwrt
;read or update
	trne w2,of%wr		;if only read
	jrst sizefi		;and finally, use size of existing file

  ;read only
	move w2,[codsec,,errwrt] ;disable writing
	movem w2,ch%put(o1)
	move w2,[disp dskrds] ;use special dispatch because of close
	movem w2,ch%dsp(o1)
	jrst sizefi		;and finally, use size of existing file

;write only
dskwrt:	setzm ch%lby(o1)		;file is now zero length
	iret			;that's it

;append simulation
dskapp:	pushj p,sizefi		;find end of file
	move w2,ch%lby(o1)	;go to end
	move w3,ch%dsp(o1)	;get dispatch vector
	move o2,o1		;low-level routines want arg in O2
	call dskmov		;setpos routine for disk
	move o1,o2		;put channel in O1
	iret

clsdio:	err /Attempt to do I-O on a channel that is closed/

errwrt:	err /Attempt to do output operation to read-only channel/

errrea:	err /Attempt to do input operation on write-only channel/

;These are common initializations that must not be done until
;we know the open succeeded

;Find the size of the file, and set up CH%LBY
sizefi:	hrrz nil1,ch%jfn(o1)
	move w2,[2,,.fbbyv]
	movei w3,w2		;put w2 _ byte size, w3 _ bytes in file
	gtfdb			;get from fdb
	 erjmp opfer
	ldb w4,[.bp 77_24.,ch%bpt(o1)]	;w4 _ our byte size
	ldb w2,[.bp 77_24.,w2]	;w2 _ file's byte size
	cain w2,0		;[2] if zero
	movei w2,36.		;[2] use 36 to prevent divide by 0
	camn w2,w4
	jrst sambsz		;if same, use exact calculation
;[44] new algorithm that gets exact sizes if at all possible
;different byte sizes.  First we figure the number of completely filled
;words.  Then if not an even number of words, we handle the last,
;partially filled word separately.  The object is to avoid rounding up
;if possible.
	movei o2,36.
	idiv o2,w2		;o2 - file bytes/wd
	move o3,w3		;o3 - number of full words, o4 - extra fil byt
	idiv o3,o2
	imul o4,w2		;o4 - extra bits in last word
	movei o5,36.		;o5 - our bytes per word
	idiv o5,w4
	imul o5,o3		;o5 - our bytes in full words
	move o6,o5		;o6 - our bytes in full words
	idiv o4,w4		;o4 - extra bytes of our size in last wd
				;o5 - extra bits beyond those bytes
	add o6,o4		;o6 - our bytes due to full words and extra
				;    bytes in last word
	skiple o5		;any bits not yet counted?
	addi o6,1		;yes - say one more byte
	move w3,o6		;c - final result - bytes in file
	setzb o2,o3		;make these things legal
	setzb o4,o5
	setz o6,
;[44] end of new algorithm
sambsz:	movem w3,ch%lby(o1)
	iret
;I/O buffer allocation

;At the moment all of our buffers are the same size, so we use a
;bit mask showing availability of buffers, not pages.  A bit
;turned on indicates something is there, as this is easier to find.

numbfs==64.	;number of buffers possible
winpgs==4
;fremap is initially an array of 64 bits

;GETBUF
;W2 - number of pages to get
;returns address in W2

getbuf:	caie w2,winpgs
	jrst [err /Bad request - GETBUF/]
	seto w2,	;assume nothing there
	skipe fremap+1	;anything in second word?
	movei w2,1	;yes - use it if not in first
	skipe fremap	;anything in first word?
	setz w2,	;yes - use it
	jumpl w2,[err /No space for I-O buffer/]
;w2 is now a word in FREMAP having an entry
	move w3,fremap(w2) ;get the word
	jffo w3,getbf1
	err /Impossible error in GETBUF/
getbf1:	movsi w3,400000	;make up mask
	movn w4,w4
	lsh w3,(w4)
	andcam w3,fremap(w2)
	movn w4,w4
	imuli w2,36.	;number of bits per word
	add w2,w4	;w2 now has a buffer number
	imuli w2,winpgs	;now we have a page number
	lsh w2,9.	;to address offset
	add w2,[bufst]	;and real address in section
	iret		;that's it

;RELBUF
;W2 - address
;W3 - number of pages
relbuf:	caie w3,winpgs	;better be this
	jrst [err /Bad request - RELBUF/]
	sub w2,[bufst]	;get to address offset
	lsh w2,-9.	;to page number
	idivi w2,winpgs	;to buffer number
	idivi w2,36.	;to word and bit
	movsi w4,400000	;mask
	movn w3,w3
	lsh w4,(w3)	;now have bit in right place
	iorm w4,fremap(w2) ;in right word
	iret
;pmap I/O - device-dependent routines

;break - force out the buffer - used by close routines
;O2 must be preserved
dskbrk:	skipge ch%pag(o1)	;anything there?
	iret			;no - nothing to do
	seto nil1,		;clear the pages
	move w2,ch%buf(o1)	;this core address
	lsh w2,-9.		;convert to page
	hrli w2,400000		;in this process
	move w3,[pm%cnt\winpgs]	;this many
	pmap
	 chkquo
	 erjmp opfer		;error with file in O1
	setz w2,
	exch w2,ch%buf(o1)	;address of buffer
	movei w3,winpgs		;size
	call relbuf		;release the space
	setz nil1,
	iret

;close for read/write modes
;O2 must be preserved
dskclo:	call dskbrk		;force the last buffer
	hrli nil1,400000\.fbbyv	;byte size, suppress updating disk copy
	hrr nil1,ch%jfn(o1)
	move w3,ch%bpt(o1)
	hrlzi w2,007700		;mask
	chfdb
	 erjmp .+1		;if not open for output, ignore
	hrli nil1,.fbsiz	;no. of bytes
	hrr nil1,ch%jfn(o1)
	move w3,ch%lby(o1)
	seto w2,		;all bits
	chfdb
	 erjmp .+1
	setz nil1,
	jrst norclo		;let common close routine finish

;close for read-only files
dskclr:	call dskbrk		;force the last buffer
	jrst norclo		;common close does most of the work

;listen - return number of char's until EOF
;  by clever design, this fits the definition of Listen, since
;  .GT. 0 means we will not hang, and 0 means EOF.  .LT. 0 is
;  not possible for a disk file.
;this routine is also used for other devices
dsklst:	skipl ch%lka(o1)	;if lookahead
	jrst nlsnef		;then we have input
	move w2,ch%lby(o1)	;eof
	sub w2,ch%cby(o1)	;any left?
	iret

;this routine is also used for other devices
dskcbi:	setom ch%lka(o1)
	iret

;finish output
dskfrc:	skipa w2,[400000,,777777] ;don't block
dskfin:	movei w2,777777		;lots of pages
	hrlz nil1,ch%jfn(o1)	;jfn,,first page=0
	ufpgs
	 jfcl
	setz nil1,
	iret
	subttl pmap I/O - random access

;setpos - file is O2, position is W2
;skips if works, error is non-skip

;dskmov - internal routine to move to new place
dskmov:	caige w2,0		;if less than zero
	move w2,ch%lby(o2)	;use end of file
	push p,w2		;save desired byte in W4
	idiv w2,ch%pgs(o2)	;w2 _ pages, w3 _ bytes off in page
	sub w2,ch%pag(o2)	;w2 _ pages from start of buffer
	cail w2,0		;is it in the window
	cail w2,winpgs
	jrst dskmv1		;no - need a new page
dskmv2:	pop p,ch%cby(o2)	;we are now at requested place
  ;compute byte count
	move w2,ch%pag(o2)	;compute bytes left in buffer - bytes to start
	imul w2,ch%pgs(o2)
	sub w2,ch%cby(o2)	;- (current - start of window)
	movn w4,w2		;for later: w4 = current - start of window
	add w2,ch%bfs(o2)	;bytes left in window
	movem w2,ch%bct(o2)
  ;compute byte pointer - this code is because ADJBP doesn't work for 2-word
	move w3,ch%bpt(o2)	;get the byte size from the current pointer
	tlz w3,770040		;00nn00,,0
	tlo w3,440000		;44nn00,,0
	adjbp w4,w3		;w4 - one-word bpt from zero
	tlo w4,000040		;LH is now LH of 2-word
	hllm w4,ch%bpt(o2)
	hrre w4,w4		;address portion only
	add w4,ch%buf(o2)	;add to start of buffer
	movem w4,ch%bpt+1(o2)	;this is second word of 2-word pointer
	aos (p)			;good (skip) return
	iret

dskmv1:	move w3,(p)		;get back target byte
	idiv w3,ch%pgs(o2)	;w3 _ pages
	call getfpg		;get file page
	 jrst .+1		;error
	jrst dskmv2		;it worked
	subi p,1		;fail return
	iret

dsksiz:	skipa w2,ch%lby(o1)
dskcpo:	move w2,ch%cby(o1)
	aos (p)
	iret
;error handling

;chkquo - special thing designed to be used with ERCAL after a
;jsys that may write to disk.  If quota is exceed, gives a
;message that looks just like the EXEC's, and retries the jsys
;if continued.
quochk:	push p,nil1
	push p,w2
	movei nil1,400000
	geter
	tlz w2,777777		;b _ error code
	caie w2,iox11		;is it quota problem?
	cain w2,pmapx6
	jrst isquot		;yes
;not a quota problem, do the next instruction, including erjmp/cal
;simulation.
	move nil1,-2(p)		;ret addr
	hlrz w2,(nil1)		;next inst
	cain w2,(erjmp)		;is erjmp?
	jrst dojmp
	cain w2,(ercal)		;is ercal?
	jrst docal
retba:	pop p,w2		;no, normal return
	pop p,nil1
	iret

;here are the erjmp/cal simulations
dojmp:	hrrz w2,(nil1)		;address to go to
	hrrm w2,-2(p)		;make us return there
	jrst retba

docal:	hrrz nil1,(nil1)	;address to call
	hll nil1,(p)		;left half should be callers section
	pop p,w2
	exch nil1,(p)
	subi p,1		;we now have goto addr 1(p)
	aos (p)			;return after the next ercal
	jrst @1(p)		;this is pjrst

;here if it is a quota problem
; print a message, and then prepare to retry the instruction
isquot:	hrroi nil1,[asciz / Quota exceeded or disk full
[Find some space, then type CONTINUE]
/]
	esout
; Finally we are ready to restore to the user's context and continue,
; is user types CONTINUE
	pop p,w2
	pop p,nil1
	sos (p)			;make return point to thing before QUOCHK
	sos (p)
	haltf			;let him delete some files
	iret
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Dispatch tables for I/O
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;In order to make it easier to add new functions, all dispatch vectors,
;whether for real files or odd sorts of I/O, should be put here.

;here is what the dispatch routines must do:
;	unread - file in O2.  For real files, moves ch%lst to ch%lka
;	curpos - file in O1, return position in W2.  Wn's are free
;		skip if successful
;	setpos - file in O2, position in W2 ; skips if it works. Wn's are free
;		skip if successful.  position of -1 means to eof
;	close - file in O1.  Wn's are free.  This is the device-specific
;		part of close only.  I.e. unmapping buffers and the like.
;		The CLOSF and other things are done by CLOSE.
;	listen - file in O1, return in W2, W's free
;		.GT. 0 if chars can be read immediately
;		=0 if EOF
;		.LT. 0 if would go into input wait
;	clrbfi - file in O1. W's free
;	linpos - file in O2. return position on line in W2. W's free
;	finish - file in O1. Force and wait for output W's free
;	force - file in O1.  Force output. W's free
;	clrbfo - file in O1. W's free
;	filsiz - file in O1. Return size in bytes in W2.  W's free
;		Skip if it works.
;	terpri - file in O2. Uses W2 and W3 only
;	elttyp - file in O2.  W's free.

;disk dispatch
;opendv calls dskopn when the device is a disk.  It sets up these
dskdsp:	codsec,,norunr		;unread
	codsec,,dskcpo		;curpos
	codsec,,dskmov		;setpos
	codsec,,dskclo		;close
	codsec,,dsklst		;listen
	codsec,,dskcbi		;clfbfi
	codsec,,norlps		;get line position
	codsec,,dskfin		;finish
	codsec,,dskfrc		;force
	codsec,,cpopj		;clrbfo
	codsec,,dsksiz		;filsiz
	codsec,,nortrp		;terpri
	codsec,,norelt		;element-type

;disk dispatch for read-only
dskrds:	codsec,,norunr		;unread
	codsec,,dskcpo		;curpos
	codsec,,dskmov		;setpos
	codsec,,dskclr		;close
	codsec,,dsklst		;listen
	codsec,,dskcbi		;clrbfi
	codsec,,norlps		;get line position
	codsec,,cpopj		;finish
	codsec,,cpopj		;force
	codsec,,cpopj		;clrbfo
	codsec,,dsksiz		;filsize
	codsec,,errwrt		;terpri	
	codsec,,norelt		;element type

;dispatch for vanilla monitor I/O
;set up by opendv when the device is not a disk
nordsp:	codsec,,norunr		;unread
	codsec,,norcpo
	codsec,,norspo
	codsec,,norclo		;close
	codsec,,norlst		;listen
	codsec,,norcbi		;clrbfi
	codsec,,norlps		;get line position
	codsec,,norfin		;finish
	codsec,,norfrc 		;force
	codsec,,norcbo		;clrbfo
	codsec,,cpopj		;filesize
	codsec,,nortrp		;terpri
	codsec,,norelt		;element type

;dispatch for terminal I/O
;currently this is used only for the file *TERMINAL-IO*.  There is
;  no open option to force this I/O mode, though maybe there should be.
trmdsp:	codsec,,norunr		;unread
	codsec,,setzw2		;curpos
	codsec,,cpopj		;setpos
	codsec,,trmclo		;close [an error]
	codsec,,trmlsn		;listen
	codsec,,trmcbi		;clrbfi
	codsec,,norlps		;get line position
	codsec,,norfin		;finish
	codsec,,cpopj		;force
	codsec,,norcbo		;clrbfo
	codsec,,cpopj		;filesize
	codsec,,nortrp		;terpri
	codsec,,norelt		;element type

;This is for channels that are not open
clsdsp:	codsec,,clsdio		;unread
	codsec,,clsdio
	codsec,,clsdio
	codsec,,cpopj		;the one thing we can do on non-ex channels
	codsec,,clsdio
	codsec,,clsdio
	codsec,,norlps		;get line position
	codsec,,clsdio
	codsec,,clsdio		;force
	codsec,,clsdio		;clrbfo
	codsec,,clsdio		;file size
	codsec,,clsdio		;terpri
	codsec,,clsdio		;element type

;dispatch for strget, routine for READ-FROM-STRING
strdsp:	codsec,,norunr		;unread
	codsec,,dskcpo		;curpos
	codsec,,strsps		;setpos
	codsec,,strcls		;close
	codsec,,dsklst		;listen
	codsec,,dskcbi		;clrbfi
	codsec,,norlps		;get line position
	codsec,,cpopj		;finish
	codsec,,cpopj		;force
	codsec,,cpopj		;clrbfo
	codsec,,dsksiz		;file size
	codsec,,strtrp		;terpri
	codsec,,norelt		;element type

;dispatch for flsput, routine for fill-pointer stream
flsdsp:	codsec,,errrea		;unread
	codsec,,setzw2		;curpos
	codsec,,cpopj		;setpos
	codsec,,strcls		;close
	codsec,,errrea		;listen
	codsec,,errrea		;clrbfi
	codsec,,norlps		;get line position
	codsec,,cpopj		;finish
	codsec,,cpopj		;force
	codsec,,cpopj		;clrbfo
	codsec,,cpopj		;file size
	codsec,,strtrp		;terpri
	codsec,,norelt		;element type

;dispatch for ostput, routine for PRINx-TO-STRING
ostdsp:	codsec,,errrea		;unread ??
	codsec,,ostcps		;curpos
	codsec,,cpopj		;setpos - not possible
	codsec,,ostclo		;close
	codsec,,errrea		;listen
	codsec,,errrea		;clrbfi
	codsec,,norlps		;get line position
	codsec,,cpopj		;finish
	codsec,,cpopj		;force
	codsec,,cpopj		;clrbfo
	codsec,,cpopj		;file size
	codsec,,strtrp		;terpri
	codsec,,norelt		;element type

;dispatch for edget/put, routines for EMACS buffer manipulation
eddsp:	codsec,,norunr		;unread
	codsec,,setzw2		;curpos
	codsec,,cpopj		;setpos
	codsec,,fakclo		;close
	codsec,,nlsnef		;listen - for now say always yes
	codsec,,dskcbi		;clrbfi
	codsec,,norlps		;get line position
	codsec,,cpopj		;finish
	codsec,,cpopj		;force
	codsec,,cpopj		;clrbfo
	codsec,,cpopj		;file size
	codsec,,nortrp		;terpri
	codsec,,norelt		;element type

;dispatch for bit bucket
nuldsp:	codsec,,cpopj		;unread
	codsec,,setzw2		;curpos
	codsec,,cpopj		;setpos
	codsec,,fakclo		;close
	codsec,,nlsnef		;listen - for now say always yes
	codsec,,cpopj		;clrbfi
	codsec,,setzw2		;get line position
	codsec,,cpopj		;finish
	codsec,,cpopj		;force
	codsec,,cpopj		;clrbfo
	codsec,,cpopj		;file size
	codsec,,cpopj		;terpri
	codsec,,setzw2		;element type

;This list continues on the next page, with composite streams
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  Streams
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; synonym macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; synonym representation:
;;;;   CH%DAT is the underlying channel.  I/O operations are simply
;;;;	  redirected there.

;synent creates a dispatch entry.
;  ADDR is the address is the dispatch table

define synent(addr)
	chnac==o1
	use2m(addr)
ife use2,[
chnac==o2]
	push q,chnac		;save indirect stream
	move chnac,ch%dat(chnac) ;this is the symbol
	move chnac,at%val(chnac) ;this is the stream
	unrp==addr-ch%ura	;0 if unread
ifn unrp,[
	move w3,ch%dsp(chnac)
	aos (p)
	call @addr(w3)
	sos (p)
]
ife unrp,[
	call @ch%unr(chnac)
]
	pop q,chnac
	closp==addr-ch%clo
ifn closp,[jrst retnil]
ife closp,[jrst fakclo]
	termin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; synonym dispatch
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

synget:	push q,o2		;save indirect stream
	move o2,ch%dat(o2)	;get underlying stream
	move o2,at%val(o2)
	aos (p)
	aos (p)
	call @ch%get(o2)
	sos (p)
	sos (p)
	pop q,o2
	iret

synput:	push q,o2		;save indirect stream
	move o2,ch%dat(o2)	;get underlying stream
	move o2,at%val(o2)
	call @ch%put(o2)
	pop q,o2
	iret

syndsp:	
repeat ch%dnm,[
	codsec,,[synent .rpcnt]]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; broadcast macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; broadcast representation:
;;;;   CH%OBL is a list of the output channels.  I/O operations go
;;;;	 go to all of them.
;;;;   CH%DAT is the current tail of this list
;;;; the list is always non-NIL.  If MAKE-BROADCAST is given no streams
;;;;   it manufactures a channel that uses NULDSP, etc.

define brdent(addr)
	chnac==o1
	use2m(addr)
ifn use2,[
	movei n,addr
	closp==addr-ch%clo	;0 if closing
ifn closp,[jrst brdo1]
ife closp,[call brdo1 ? jrst fakclo]
	]
ife use2,[
	movei n,addr
	jrst brdo2
	]
	termin


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; broadcast dispatch
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

brdput:	push q,o2		;save indirect stream
	move w3,ch%obl(o2)	;get stream list
	movem w3,ch%dat(o2)	;and save for loop
brdplp:	docar o2,w3		;get first stream
	call @ch%put(o2)
	move o2,(q)		;get back original stream
	move w3,ch%dat(o2)	;go to next stream
	docdr w3,w3
	movem w3,ch%dat(o2)
	jumpn w3,brdplp
	pop q,o2
	iret

;this routine executes the actual dispatch entries
; enter here with N having the table offset
;there are two versions: brdO1 and brdO2, using
;AC's O1 and O2
;N will be used internally to control the return

brdo1:	push q,o1		;save indirect stream
	push p,n
	push p,n
	move w3,ch%obl(o1)	;get stream list
	movem w3,ch%dat(o1)	;and save for loop
brdo1l:	docar o1,w3		;get first stream
	move w3,ch%dsp(o1)
	add w3,-1(p)		;add in offset
	setzm (p)		;clear return
	call @(w3)
	aos (p)			;indicate first return
	move o1,(q)		;get back original stream
	move w3,ch%dat(o1)	;go to next stream
	docdr w3,w3
	movem w3,ch%dat(o1)
	jumpn w3,brdo1l
	pop q,o1
	skipn (p)		;if skip return on last call
	aos -2(p)		;then do it
	subi p,2
	ret1

brdo2:	push q,o2		;save indirect stream
	push p,n
	push p,n
	move w3,ch%obl(o2)	;get stream list
	movem w3,ch%dat(o2)	;and save for loop
brdo2l:	docar o2,w3		;get first stream
	move w3,ch%dsp(o2)
	add w3,-1(p)		;add in offset
	setzm (p)		;clear return
	call @(w3)
	aos (p)			;indicate first return
	move o2,(q)		;get back original stream
	move w3,ch%dat(o2)	;go to next stream
	docdr w3,w3
	movem w3,ch%dat(o2)
	jumpn w3,brdo2l
	pop q,o2
	skipn (p)		;if skip return on last call
	aos -2(p)		;then do it
	subi p,2
	ret1

brddsp:	
repeat ch%dnm,[
	codsec,,[brdent .rpcnt]]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  Concatenated macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; representation:
;;;;   CH%OBL is the whole list of streams, for CLOSE
;;;;   CH%DAT is the current tail.  CAR of this is the current stream

;conent creates a dispatch entry.
;  ADDR is the address is the dispatch table

define conent(addr,offset)
	chnac==o1
	use2m(addr)
ife use2,[
chnac==o2]
	push q,chnac		;save indirect stream
	move chnac,ch%dat(chnac);get underlying stream
	docar chnac,chnac	;first in list
	unrp==addr-ch%ura	;0 if unread
ifn unrp,[
	move w3,ch%dsp(chnac)
	aos (p)
	call @addr(w3)
	sos (p)
]
ife unrp,[
	call @ch%unr(chnac)
]
	pop q,chnac
	iret
	termin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  Concatenated dispatch
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; representation:
;;;;   CH%OBL is the whole list of streams, for CLOSE
;;;;   CH%DAT is the current tail.  CAR of this is the current stream

conget:	push q,o2		;save indirect stream
congtn:	move o2,ch%dat(o2)	;get underlying stream
	docar o2,o2
	aos (p)
	aos (p)
	call @ch%get(o2)
	jrst congte		;here for EOF on one stream
	sos (p)
	pop q,o2
	iret

congte:	sos (p)			;take non-skip return
	sos (p)	
	move o2,(q)		;get concat stream
	move w3,ch%dat(o2)	;current list
	docdr w3,w3		;cdr it
	movem w3,ch%dat(o2)	;and save the cdr
	jumpn w3,congtn		;something there, use it
	iret	

;here to close - do all the member channels and then this one
conclo:	push q,o1		;save main channel
	push q,o2		;save save close arguments
concll:	move w3,ch%obl(o1)	;get channel list
	jumpe w3,conclx		;stop when done
	doboth w3,w3		;w3 - current channel, w4 - rest
	movem w4,ch%obl(o1)
	move o1,w3		;args for close
	move o2,(q)
	move w2,ch%dsp(o1)
	call @ch%clo(w2)
	move o1,-1(q)		;get back main channel
	jrst concll

conclx:	subi q,2		;here when all members are close 
	jrst fakclo		;close the main channel

condsp:
repeat ch%dnm,[
	closp==.rpcnt-ch%clo	;0 if close
ifn closp,<codsec,,[conent .rpcnt]>
ife closp,<codsec,,conclo>
]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  two-way macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;indent creates a dispatch entry.
;  ADDR is the address is the dispatch table
;  OFFSET is normally blank, but if non-block the channel in CH%DAT-OFFSET
;	will be used.

define indent(addr,offset)
	chnac==o1
	use2m(addr)
ife use2,[
chnac==o2]
	push q,chnac		;save indirect stream
ifnb [offset][move chnac,ch%dat-offset(chnac)] ;get underlying stream
ifb [offset][move chnac,ch%dat(chnac)] ;get underlying stream
	unrp==addr-ch%ura	;0 if unread
ifn unrp,[
	move w3,ch%dsp(chnac)
	aos (p)
	call @addr(w3)
	sos (p)
]
ife unrp,[
	call @ch%unr(chnac)
]
	pop q,chnac
	closp==addr-ch%clo
ifn closp,[jrst retnil]
ife closp,[jrst fakclo]
	termin


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  two-way entries
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; representation:
;;;;   CH%DAT-1 is the output channel
;;;;   CH%DAT is the input channel

towget:	push q,o2		;save indirect stream
	move o2,ch%dat(o2)	;get underlying stream
	aos (p)
	aos (p)
	call @ch%get(o2)
	sos (p)
	sos (p)
	pop q,o2
	iret

towput:	push q,o2		;save indirect stream
	move o2,ch%dat-1(o2)	;get underlying stream
	call @ch%put(o2)
	pop q,o2
	iret

towclo:	push q,o1		;save 2 way chan
	push q,o2		;save 2nd arg
	move o1,ch%dat(o1)	;close input
	move w2,ch%dsp(o1)
	call @ch%clo(w2)
	move o1,-1(q)		;get back 2 way chan
	move o1,ch%dat-1(o1)	;now close output
	move w2,ch%dsp(o1)
	pop q,o2		;get back 2nd arg
	call @ch%clo(w2)
	pop q,o1		;get back 2 way chan
	jrst fakclo		;and close it

towdsp:	codsec,,[indent(0)]	;unread
	codsec,,[indent(1)]	;curpos
	codsec,,[indent(2)]	;setpos
	codsec,,towclo		;close
	codsec,,[indent(4)]	;listen
	codsec,,[indent(5)]	;clfbfi
	codsec,,[indent(6,1)]	;get line position
	codsec,,[indent(7,1)]	;finish
	codsec,,[indent(10,1)]	;force
	codsec,,[indent(11,1)]	;clrbfo
	codsec,,[indent(12)]	;filsiz
	codsec,,[indent(13,1)]	;terpri
	codsec,,[indent(14,1)]	;element type

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; echo-stream entries
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; representation:
;;;;   CH%DAT-1 is the output channel
;;;;   CH%DAT is the input channel
;;;; NB: in order to avoid echoing twice, lookahead must be
;;;;   implemented at this level

;end of line handling here is rather messy.  Unforunately either
;of the streams involved could be strings, so we have to do all
;of this in normalized form.  Also, we want to avoid having
;dribble files have <lf> result <cr>, which simpler code gave.
;Note that it is possible to read from a text file with GETBYT,
;in which case you will see the CR and LF separately.  However I
;am taking the view that the echo should not be dependent upon
;that, just as we don't want to see characters twice just because
;we unread them.  So I do CRLF normalization on files not open
;in binary mode, and on files open in binary mode I echo the
;characters literally.  That means that the echo code here 
;essentially does the same end of line processing as TYI and TYO.
;Of course none of this affects what is returned to our caller,
;which is unnormalized.

echget:	skipl w2,ch%lka(o2)	;lookahead?
	 jrst getlka		;yes, use it
	push q,o2		;save indirect stream
	move o2,ch%dat(o2)	;get underlying stream
	aos (p)
	aos (p)
	call @ch%get(o2)
	jrst echeof
	jrst echcr
;now do the echo, except at EOF
echn:	move o2,(q)		;get back echo stream
	movem w2,ch%lst(o2)	;save for unread
	move o2,ch%dat-1(o2)	;the output stream
	cain w2,eolchr		;if EOLN, may have to do TERPRI
	 jrst echeol
eche:	call @ch%put(o2)
echx:	pop q,o2
	move w2,ch%lst(o2)	;put may garbage W2
	iret

;;;;;; handle end of lines in the output stream

;here if about to print LF.  See if it should be a TERPRI
echeol:	move w2,ch%dsp(o2)	;see if echo file is binary
	call @ch%elt(w2)	;now have type code in W2
	trne w2,ct%bin		;binary?
	 jrst echelb		;yes
	move w2,ch%dsp(o2)	;no, do terpri
	call @ch%trp(w2)
	jrst echx		;and exit

;here to echo LF if in binary mode - just do it
echelb:	movei w2,eolchr		;get back the LF
	jrst eche		;and do normal echo

;;;;;; handle end of lines in the input stream

;here if we read a CR with following LF.  Don't echo the CR
;unless the input channel is in binary mode.
echcr:	move w2,ch%dsp(o2)	;see if input file is binary
	call @ch%elt(w2)	;now have type code in W2
	trne w2,ct%bin		;binary?
	 jrst echcrb		;yes
	pop q,o2		;no, don't echo; get back echo stream
	movei w2,15		;CR was garbaged
	movem w2,ch%lst(o2)	;put may garbage W2
	sos (p)			;take skip 1 return
	iret

;here if CRLF was in binary mode
echcrb:	movei w2,15		;get back our cR
	sos (p)			;take CRLF return
	jrst echn		;and treat as normal char, i.e. echo it

;;;;; handle EOF

;here at EOF - just return the EOF
echeof:	sos (p)
	sos (p)
	pop q,o2
	setom ch%lst(o2)
	iret

echput==towput
echclo==towclo

echdsp:	codsec,,norunr		;unread
	codsec,,[indent(1)]	;curpos
	codsec,,[indent(2)]	;setpos
	codsec,,echclo		;close
	codsec,,[indent(4)]	;listen
	codsec,,[indent(5)]	;clfbfi
	codsec,,[indent(6,1)]	;get line position
	codsec,,[indent(7,1)]	;finish
	codsec,,[indent(10,1)]	;force
	codsec,,[indent(11,1)]	;clrbfo
	codsec,,[indent(12)]	;filsiz
	codsec,,[indent(13,1)]	;terpri
	codsec,,[indent(14)]	;element type

;;;;;;;;;;
;;; Here are routines for devices that no not implement the option
;;;;;;;;;

setzw2:	setz w2,
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  Routines to create streams
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;synonym

maksyn:	move o2,o1		;save original channel
	call makchn		;channel to O1
	dmove w2,[codsec,,synget ? codsec,,synput]
	dmovem w2,ch%get(o1)
	move w2,[disp syndsp]
	movem w2,ch%dsp(o1)
	sos (o1)		;one lisp object in this channel
	movem o2,ch%dat(o1)
	ret1

;broadcast

makbrd:	move o3,o1
	call makchn
	skipn o3		;any streams present?
	jrst maknul		;no - give us a null channel
	dmove w2,[codsec,,errrea ? codsec,,brdput]
	dmovem w2,ch%get(o1)
	move w2,[disp brddsp]
	movem w2,ch%dsp(o1)
	sos (o1)		;there are two lisp objects in this channel
	sos (o1)
	movem o3,ch%obl(o1)	;save stream list here
	ret1

;null - entry from broadcast

maknul:	dmove w2,[codsec,,cpopj ? codsec,,cpopj]
	dmovem w2,ch%get(o1)
	move w2,[disp nuldsp]
	movem w2,ch%dsp(o1)
	ret1

;concatenated

makcon:	move o2,o1		;save stream in O2
	call makchn
	skipn o2		;any streams present?
	jrst maknul		;no - give us a null channel
	dmove w2,[codsec,,conget ? codsec,,errwrt]
	dmovem w2,ch%get(o1)
	move w2,[disp condsp]
	movem w2,ch%dsp(o1)
	sos (o1)		;there are two lisp objects in this channel
	sos (o1)
	movem o2,ch%obl(o1)	;save stream list here
	movem o2,ch%dat(o1)
	ret1

;two-way

maktow:	dmove o2,o1		;O2 - input; O3 - output
	call makchn
	dmove w2,[codsec,,towget ? codsec,,towput]
	dmovem w2,ch%get(o1)
	move w2,[disp towdsp]
	movem w2,ch%dsp(o1)
	sos (o1)		;there are two lisp objects in this channel
	sos (o1)
	movem o3,ch%dat-1(o1)	;put streams here
	movem o2,ch%dat(o1)
	ret1

;echo

makech:	dmove o2,o1
	call makchn
	dmove w2,[codsec,,echget ? codsec,,echput]
	dmovem w2,ch%get(o1)
	move w2,[disp echdsp]
	movem w2,ch%dsp(o1)
	sos (o1)		;there are two lisp objects in this channel
	sos (o1)
	movem o3,ch%dat-1(o1)	;put streams here
	movem o2,ch%dat(o1)
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Now other misc. stream functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; input-stream-p
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

instrp:	xtype o1
	caie w2,ty%xch
	 jrst [err1 o1,/Not a stream: ~S/]
	move w2,ch%get(o1)	;look at get dispatch
	came w2,[codsec,,clsdio] ;only two values that can't
	 camn w2,[codsec,,errrea]
	  jrst retnil
	jrst rett

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; output-stream-p
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

oustrp:	xtype o1
	caie w2,ty%xch
	 jrst [err1 o1,/Not a stream: ~S/]
	move w2,ch%put(o1)	;look at get dispatch
	came w2,[codsec,,clsdio] ;only two values that can't
	 camn w2,[codsec,,errwrt]
	  jrst retnil
	jrst rett

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; stream-element-type
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

strelt:	xtype o1
	caie w2,ty%xch
	jrst [err1 o1,/Not a stream: ~S/]
	move w2,ch%dsp(o1)
	move o2,o1		;ch%elt expects file in O2
	call @ch%elt(w2)	;get element type
	hrrz w3,w2		;get type code
	xct strel1(w3)
	ret1

strel1:	move o1,[%STRCHR]
	move o1,[%CHARACTER]
	jrst strltu		;unsigned
	jrst strlts		;signed

strltu:	hlrz w3,w2		;get byte size
	cain w3,36.		;36 bit is actually signed
	jrst strlts
	skipa o2,[%UNSBYTE]
strlts:	move o2,[%SGNBYTE]
	hlrz w3,w2		;get byte size
	maknum w3
	docons o1,w3,nil	;(n)
	docons o1,o2,o1		;([UN]SIGNED n)
	ret1
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; I/O routines for normal files
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

norcpo:	hrrz nil1,ch%jfn(o1)
	rfptr
	 erjmp .+2
	aos (p)
	setz nil1,
	iret

norspo:	hrrz nil1,ch%jfn(o2)
	sfptr
	 erjmp .+2
	aos (p)
	setz nil1,
	iret

;listen for random devices: .GT. 0 if input available, 0 if EOF,
;  .LT. 0 if input will hang
;this is hairy because we can't predict EOF.  It only triggers
;  after trying to do the read.  But for interactive devices
;  such as terminals this can cause a hang.
norlst:	hrrz nil1,ch%jfn(o1)
	dvchr
	ldb w2,[.bp <7777,,0>,w2]
	caile w2,16
	movei w2,16
	xct .+1(w2)

	jrst nlstry		;0 disk
	jrst nlssib		;1 undef
	jrst nlstry		;2 tape
repeat 4,[jrst nlssib
		]		;3 - 6 undef
	jrst nlstry		;7 printer [???]
	jrst nlstry		;10 card reader
repeat 4,[jrst nlssib
		]		;11 - 14 fe, tty, pty, undef
	jrst nlseof		;15 nul, always at EOF
	jrst nlssib		;16 and above networks, etc.
	
;here for conventional I/O devices.  Can't hang, but can be at
;  EOF.  Just try the I/O and look for EOF
nlstry:	skipl ch%lka(o1)	;if lookahead
	jrst nlsnef		;there is definitely something ready
	hrrz nil1,ch%jfn(o1)	;jfn
	bin			;do the input
	 erjmp nlseof		;eof
	movem w2,ch%lka(o1)	;got something, so save it away
	jrst nlsnef		;say input available

;here for networks and terminals.  We can't easily predict EOF
;  without actually reading.  But it looks like SIBE is probably
;  the right thing to do.
nlssib:	hrrz nil1,ch%jfn(o1)	;jfn
	sibe
	 jrst nlsnef		;normal
	seto w2,		;input buffer empty
	setz nil1,
	iret

;here for device NUL:.  It is always at EOF
nlseof:	skipa w2,[0]		;eof
nlsnef:	movei w2,1		;not eof
	setz nil1,
	iret

;clrbfi
norcbi:	hrrz nil1,ch%jfn(o1)
	cfibf
	setz nil1,
	setom ch%lka(o1)	;also clear lookahead
	iret

;clrbfo
norcbo:	hrrz nil1,ch%jfn(o1)
	cfobf
	setz nil1,
	iret

;get line position
norlps:	move w2,ch%pos(o2)
	iret

;finish
norfin:	hrrz nil1,ch%jfn(o1)
	dobe
	setz nil1,
	iret

;force [Victor addition]
norfrc:	hrrz nil1,ch%jfn(o1)
	hrroi w2,[asciz //]	;I know this is ugly, but it works
	movei w3,0
	movei w4,0
	soutr
	setz nil1,
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOSE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;channel in O1 [validated]
;close bits in O2 [LH flags for closf]

norclo:	hrrz nil1,ch%jfn(o1)	;get jfn
	caie nil1,.priin	;if pri in or pri out, noop
	cain nil1,.priou
	jrst closz
	cain nil1,777777	;already closed
	 jrst closz
	jumpe nil1,closz	;also if nothing there any more, already done
	gtsts
	 erjmp closz		;trap all errors
	tlnn w2,(gs%nam)	;something wrong with JFN?
	jrst closz		;yes - forget it all
	tlnn w2,(gs%opn)	;is it open?
	jrst closno		;no - release it instead
	hrlz w2,o2		;set up any funny bits
	call doclos		;call common routine for actual close
	 jrst .+1
	tlnn w2,(cz%nrj)	;unless kept JFN
closz:	setzb nil1
	setom ch%jfn(o1)	;say nothing there now, but there was
;entry for closing fake channels
fakclo:	move w2,[codsec,,clsdio] ;error return saying file is closed
	movem w2,ch%get(o1)
	movem w2,ch%put(o1)
	move w2,[disp clsdsp]
	movem w2,ch%dsp(o1)
	setz o1,		;return NIL
	ret1

;here if JFN not open - release it instead
closno:	trne o2,(cz%nrj)	;if keeping JFN
	jrst closz		;nothing to do
	rljfn
	 erjmp .+1		;ignore errors
	jrst closz

;doclos - routine to close a file.  File in O1, close bits in W2
doclos:	move nil1,w2		;put bits into right AC
	hrr nil1,ch%jfn(o1)	;and add in JFN
	closf
	 erjmp .+2		;error return
	aos (p)			;normal return
	setz nil1,
	iret
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Routines for I/O on strings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;TY%STR
;;TY%CHN
;;;;;(INSTRING string begin end) create an input channel open on a string

;For byte numbers in CH%CBY and CH%LBY (as well as most of the
; variables inside this routine) we use the byte number within
; the base string.  So if BEGIN is set to 3, CH%CBY starts out
; at 3.  If the string is displaced, we do not add in the
; displacement, except when we have to compute the byte pointer,
; where obvious the displacement is needed.

instrg:	move o2,[inum 0]	;start defaults to beginning
	setz o3,		;use NIL to mark default end
	setz w4,		;assume not displaced array
;handle complex arrays
	gettyp o1
	caie w2,ty%str
	 cain w2,ty%cst
	  jrst instr1		;yes, it's really a string
	caie w2,ty%arh
	 jrst getste		;not a string
 ;here if array with header
	xtype ah%dat(o1)	;make sure it is really a string
	caie w2,ty%xst
	 jrst getste		;no error
	skipn o3		;specified end?
	move o3,ah%fil(o1)	;no, use fill pointer
	move w4,ah%dsp(o1)	;remember displacement
	getnum w4,
	move o1,ah%dat(o1)	;and use data
;now have a real string in O1
instr1:	move o6,o1		;save string
	call makchn
	sos (o1)		;CH%DAT is Lisp object
;set dispatches to point to string routines
	dmove w2,[codsec,,strget ? codsec,,strput]
	dmovem w2,ch%get(o1)
	move w2,[disp strdsp]
	movem w2,ch%dsp(o1)
;set internal state variables need by string routines
	move w2,o2		;compute starting offset
	getnum w2
	movem w2,ch%cby(o1)	;call that starting position
	add w2,w4		;add displacement
	adjbp w2,[440740,,0 ? 030000,,1] ;for byte pointer
	dmovem w2,ch%bpt(o1)
;NB: if we used the length of a displaced string, we would
;have to adjust it by the displacment.  However the code
;above already set up O3 if the string is displaced.
	skipn w2,o3		;if length spec, use it
	move w2,(o6)		;else length of string
	tlz w2,770000		;make bare number
	movem w2,ch%lby(o1)	;and call that end
	movem o6,ch%dat(o1)	;string itself goes in CH%DAT
	ret1

isterr:	err1 o1,/INSTRING needs a string/

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;now the I/O routines for string set up by INSTRING

;here is the read routine:
strget:	skipl w2,ch%lka(o2)	;lookahead?
	 jrst getlka		;yes, use it
	aos w3,ch%cby(o2)	;advance current byte
	camle w3,ch%lby(o2)	;beyond eof?
	 jrst dskeof		;yes - do it
	move w3,ch%dat(o2)	;need this for indexing the byte ptr
	ildb w2,ch%bpt(o2)
	aos (p)			;return normally
	aos (p)
	movem w2,ch%lst(o2)
;note that we don't check for CRLF, since strings are stored in
;internal format
	iret

;terpri
strtrp:	movei w2,eolchr		;for a string, use internal representation
	jrst @ch%put(o2)

;this is used for writing into an existing string (a truly unique
;  concept)
strput:	aos w3,ch%cby(o2)	;advance current byte
	camle w3,ch%lby(o2)	;beyond eof?
	 jrst streof		;yes, illegal
	move w3,ch%dat(o2)	;need this for indexing the byte ptr
	idpb w2,ch%bpt(o2)
	jrst putact

streof:	err /Attempt to write to existing string beyond its end/

;listen, clear input buffer, curpos use the disk routines, as the basic
; bookkeeping is similar for both

strsps:	caige w2,0		;-1 is eof
	 move w2,ch%lby(o2)
	camle w2,ch%lby(o2)
	 jrst [err /Attempt to SETPOS to existing string beyond its end/]
	move w3,w2
	sub w3,ch%cby(o2)
	adjbp w3,ch%bpt(o2)
	dmovem w3,ch%bpt(o2)
	movem w2,ch%cby(o2)
	aos (p)
	iret

strcls:	setzm ch%dat(o1)
	jrst fakclo

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This was the easy part.  Now we have the routines for strings that
;;;   we are creating.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;There are two kinds of output strings.  The first is the one 
;used by make-string-output-stream.  This is optimized for write-only
;access.  It uses a linked list of chunks.  This allows us to extend
;it indefinitely without having to recopy it each time.

;The second is used by the pretty-printer.  A uses a single contiguous
;string.  Indeed most of the code is the same as for input strings.
;However when a PUT operation gets to the end of the string, 
;more space is allocated, by copying the old one.  I refer to this
;as a "buffer string".

;Here is the code for the normal output strings.

;since we can create strings of arbitrary size, we use a representation
;  that is a linked list of hunks.  GET-OUTPUT-STREAM-STRING checks
;  to see if there is more than one hunk, and if so copies them all
;  into a single contiguous string.  CH%DAT is the current hunk,
;  which is set up to look like a normal string.  CH%OBL is the list
;  of hunks.

ostwds==10.   ;number of words in one hunk
ostchs==ostwds*5

;MAKE-STRING-OUTPUT-STREAM [try saying that ten times fast!]
; make a channel bound to a new string
oustrg:	call makchn
	movei w2,ch%666-2	;have 2 GC'ed things at the end
	hrrm w2,(o1)
	dmove w2,[codsec,,errrea ? codsec,, ostput]
	dmovem w2,ch%get(o1)
	move w2,[disp ostdsp]
	movem w2,ch%dsp(o1)
	dmove w2,[440740,,0 ? 030000,,1] ;start byt ptr at beginning
	dmovem w2,ch%bpt(o1)
	setom ch%pag(o1)	;say not on real buffer
	ret1

;routine to write into a new string
ostput:	sosge ch%bct(o2)
	 jrst ostpub
	move w3,ch%dat(o2)
	idpb w2,ch%bpt(o2)
	jrst putact

;here if a new buffer is needed
ostpub:	push p,w2
	push p,w4
	push q,o1
	move o1,o2
	call ostnbf
	dmove w3,[440740,,0 ? 030000,,1]
	dmovem w3,ch%bpt(o2)
	movei w3,ostchs
	movem w3,ch%bct(o2)
	aos ch%pag(o2)
	pop q,o1
	pop p,w4
	pop p,w2
	jrst ostput

;ostnbf is called by init and put to add a new hunk to the list
;  of hunks.  Also reinit the state variables as needed.
ostnbf:	
;create the new hunk, which is a string
	push free,[object ty%sp5,ostchs] ;create a new string
	move w2,free
	tlo w2,(<object ty%str>)
	movem w2,ch%dat(o1)		;put it in CH%DAT, as current one
	addi free,ostwds		;allocate space for the string
;link it into the list of hunks
	move w3,ch%obl(o1)
	push free,w2			;;ty%con  sneaking a cons in here
	move w2,free
	push free,w3
	tlo w2,(<object ty%con>)	;;ty%con  end of cons
	movem w2,ch%obl(o1)
;clear the new string
	movei w2,ostwds-1		;zero out the string
	move w3,ch%dat(o1)
	setzm 1(w3)
	xmovei w3,1(w3)
	xmovei w4,1(w3)
	xblt w2,
	camle free,lastl	;see if went beyond end of space
	 call sgc		;yes
	iret

;curpos
ostcps:	move w2,ch%pag(o1)
	imuli w2,ostchs
	addi w2,ostchs
	sub w2,ch%bct(o1)
	aos (p)
	iret

;ostclo - close
ostclo:	setzm ch%dat(o1)
	setzm ch%obl(o1)
	jrst fakclo

;;(get-output-stream-string <channel>) ==> string
; this also resets the channel for later use
getost:	
;do fairly paranoid type checking, since otherwise we could
; return something really off the wall
	xtype o1		;is it a channel?
	caie w2,ty%xch
	 jrst stcerr
	move w2,ch%dsp(o1)	;is it open on a string?
	came w2,[disp ostdsp]
	 jrst stcerr
	skipge ch%pag(o1)	;was a buffer allocated?
	 jrst gtstz		;no, return zero-length string
	skipe ch%pag(o1)	;is there just one string?
	 jrst gtstcp
	move o2,ch%dat(o1)	;yes, get it
	movei w2,ostchs
	sub w2,ch%bct(o1)
	tlo w2,(<object ty%sp5>)
	movem w2,(o2)
;reinit for later use
gtstrt:	setzm ch%obl(o1)
	setom ch%pag(o1)
	setzm ch%bct(o1)
	move o1,o2
	ret1

;here to return null string
gtstz:	push free,[object ty%sp5,0]
	move o2,free
	tlo o2,(<object ty%str,0>)
	jrst gtstrt

stcerr:	err1 o1,/not out string channel/

;here if we have a list of hunks
gtstcp:	
;computer total number of chars
	move w3,ch%pag(o1)	;number of buffers filled
	imuli w3,ostchs		;chars per
	movei w2,ostchs		;compute # chars in last
	sub w2,ch%bct(o1)
	add w3,w2		;total new string length, chars
;now make the new string
	tlo w3,(<object ty%sp5>)
	push free,w3		;strg header
	move o2,free		;will be strg pointer
	tlo o2,(<object ty%str>)
;now convert size to words and allocate it
	tlz w3,770000		;back to char count
	addi w3,4
	idivi w3,5
	add free,w3		;allocate the space
;now copy the data in
	addi w2,4		;number of wrds in last buffer
	idivi w2,5
	move w4,free		;pointer for filling in new strg
	sub w4,w2		;back by #wds in last buffer
	addi w4,1
	move w3,ch%dat(o1)	;buffer strg ptr
	xmovei w3,1(w3)		;get to data portion
	move o3,w4		;save
	xblt w2,
	move o4,ch%obl(o1)	;list of buffers
stcbbl:	docdr o4,o4		;bass ackwards down the list
	jumpe o4,[setz o3, ? jrst gtstrt]
	docar w3,o4		;get a buffer
	xmovei w3,1(w3)		;addr of its data
	subi o3,ostwds		;next block in output strg
	move w4,o3
	movei w2,ostwds		;count
	xblt w2,
	jrst stcbbl

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Here are the routines for "buffer strings".
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;(MAKE-BUFFER-STRING-STREAM)
bfstrg:	call makchn
	sos (o1)		;CH%DAT is Lisp object
;make the buffer string itself
	push free,[object ty%sp5,ostchs] ;create a moderate size string
	move w2,free		;make pointer to it
	tlo w2,(object(ty%str,0))
	movem w2,ch%dat(o1)	;put it in the object
	setzm 1(free)		;clear it
	movei w2,ostwds-1
	xmovei w3,1(free)
	xmovei w4,2(free)
	xblt w2,
	addi free,ostwds	;and move free list over it
;set dispatches to point to string routines
	dmove w2,[codsec,,strget ? codsec,,sbfput]
	dmovem w2,ch%get(o1)
	move w2,[disp strdsp]
	movem w2,ch%dsp(o1)
;set internal state variables need by string routines
	dmove w2,[440740,,0 ? 030000,,1] ;for byte pointer
	dmovem w2,ch%bpt(o1)
	movei w2,ostchs		;end of string
	movem w2,ch%lby(o1)
	ret1

;here is the special write routine, which extends the string if needed
sbfput:	aos w3,ch%cby(o2)	;advance current byte
	camle w3,ch%lby(o2)	;beyond eof?
	 jrst extsbf		;yes, extend it
sbfpt1:	move w3,ch%dat(o2)	;need this for indexing the byte ptr
	idpb w2,ch%bpt(o2)
	jrst putact

;here if run out of space: double the size of the buffer
extsbf:	push p,w4
	push p,w2
	move w2,ch%lby(o2)	;current size of string
	addi w2,4
	idivi w2,5		;in words
	push p,w2		;save for later
	move w3,ch%dat(o2)	;current string
	xmovei w3,1(w3)		;start of actual data
	xmovei w4,2(free)	;put it here
	xblt w2,		;copy old to new
	setzm 1(w4)		;clear next word
	xmovei w3,1(w4)		;and the rest
	xmovei w4,1(w3)
	pop p,w2
	subi w2,1
	xblt w2,
	move w2,ch%lby(o2)	;old size in chars
	lsh w2,1		;now is doubled
	movem w2,ch%lby(o2)	;put back as new size
	tlo w2,(object(ty%sp5,0))
	push free,w2		;that is the header
	move w2,free		;save string in W2
	tlo w2,(object(ty%str,0))
	move free,w4		;here is the last word used
	movem w2,ch%dat(o2)	;now have a new string
	pop p,w2
	pop p,w4
	caml free,lastl		;make sure there is space
	 call sgc		;special version of GC that saves AC's
	jrst sbfpt1		;now go put in the character

;get the string from a buffer stream
sbfstr:	move o1,ch%dat(o1)
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Here are the routines for "full pointer streams"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

ah%hsz==-1	;size of header.  from this you can deduce dimensionality
ah%dat==0	;data vector
ah%siz==1	;number of data elements
ah%fil==2	;fill pointer
ah%dsp==3	;displacement
ah%ub1==4	;upper bound for dimension 1

;;;;;(MAKE-FILL-POINTER-OUTPUT-STREAM)
flstrg:	gettyp o1		;make sure it is legal
	caie w2,ty%arh
	 jrst flilst
	move o2,ah%hsz(o1)	;make sure it is one-dimensional
	came o2,[inum 5]
	 jrst flilst
	move o2,ah%dat(o1)	;and make sure it is a string
	xtype o2
	caie w2,ty%xst
	 jrst flilst
;now we have validated the string.  Make a channel and put it there
	move o2,o1		;save the string in O2
	call makchn
	sos (o1)		;CH%DAT is Lisp object
	movem o2,ch%dat(o1)
;set dispatches to point to string routines
	dmove w2,[codsec,,errrea ? codsec,,flsput]
	dmovem w2,ch%get(o1)
	move w2,[disp flsdsp]
	movem w2,ch%dsp(o1)
;set internal state variables need by string routines
	move w2,ah%fil(o2)	;get current end of string
	getnum w2
	move w3,ah%dsp(o2)	;have to add in displacement
	getnum w3
	add w2,w3
	adjbp w2,[440740,,0 ? 030000,,1] ;for byte pointer
	dmovem w2,ch%bpt(o1)
	move w2,ah%siz(o2)	;logical size
	sub w2,ah%fil(o2)	;  - logical end = number of elts free
	movem w2,ch%bct(o1)
	ret1

flilst:	err1 o1,/Argument to MAKE-FILL-POINTER-OUTPUT-STREAM must be adjustable string: ~S/

;here is the special write routine, which extends the string if needed
flsput:	sosge w3,ch%bct(o2)	;advance current byte
	 jrst flsext		;ran out, extend it
	move w3,ch%dat(o2)	;need this for indexing the byte ptr
	aos ah%fil(w3)
	move w3,ah%dat(w3)
	idpb w2,ch%bpt(o2)
	jrst putact

flsinc==40.

;here if run out of space: add FLSINC spaces
flsext:	push p,w4
	push p,w2
	push q,o3
	push q,o4
	move w4,ch%dat(o2)	;w4 - the array header
	move w2,ah%siz(w4)	;get the effective size
	getnum w2
	addi w2,flsinc		;new size
	tlo w2,(object(ty%sp5,0))
	push free,w2		;make the string header for the new one
	move o3,[440740,,0]	;O3/O4 will be destination pointer
	xmovei o4,1(free)
	move nil1,ah%dsp(w4)	;nil1/w2 will be source pointer
	getnum nil1
	move w2,[440740,,0]	; w2/3 is start of old string
	move w3,ah%dat(w4)
	xmovei w3,1(w3)
	adjbp nil1,w2		;nil1/w2 is that offset by displacement
	move w3,ah%siz(w4)	;w3 is count
	getnum w3
;1/2 - source
;3 - count
;o3/4 - destination
	jumple w3,flsexx
flsexl:	ildb nil,nil1
	idpb nil,o3
	sojg w3,flsexl
flsexx:	movei w3,flsinc		;now extend it
	addm w3,ah%siz(w4)	;increment size by that in header also
	addm w3,ah%ub1(w4)
	movem w3,ch%bct(o2)	;this is also number of chars for next time
	setzb nil,nil1
	idpb nil,o3		;clear extra bytes
	sojg w3,.-1
	move w2,free		;W2 will be new string
	tlo w2,(object(ty%str,0))
	move free,o4		;update free counter
	movem w2,ah%dat(w4)	;save new string
	move w2,[inum 0]
	exch w2,ah%dsp(w4)	;new displacement
	getnum w2		;old displacement
	movn w2,w2		;adjust byte pointer by that, since now
	adjbp w2,ch%bpt(o2)	; have zero displacement
	dmovem w2,ch%bpt(o2)	;now have new byte pointer
	pop q,o4
	pop q,o3
	pop p,w2
	pop p,w4
	caml free,lastl		;make sure there is space
	 call sgc		;special version of GC that saves AC's
	jrst flsput		;now go put in the character

;;;;;;;;;;;;;;MISC INPUT-RELATED FUNCTIONS;;;;;;;;;;;;;;;;;;;;


;check stack limit and redo if needed.  If case debugger has released
;the limit.
chstlm:	skipe @[.%%STKLIM]		;only do this if not done
	iret
	hrroi nil1,[asciz /
[Reducing stacks to normal size]
/]
	psout
	seto nil1,			;kill the extra pages
	move w2,[.fhslf,,endq_-9.]	;start at top of normal
	move w3,[pm%cnt+<<endqs-endq>_-9.>] ;to end of section
	pmap				;clear them all
;limit stack usage, so we trap PDL overflows in time to call debugger
limstk:	move o1,[%T]
	movem o1,@[.%%STKLIM]		;say limit has been done
;put illegal pages in to limit memory usage
	moves @[endp]			;create the page
	move nil1,[.fhslf,,endp/1000]	;end of P, restricted
	setz w2,			;no access
	spacs
	moves @[endsp]			;create the page
	move nil1,[.fhslf,,endsp/1000]	;end of SP, restricted
	setz w2,			;no access
	spacs
	moves @[endmv]			;create the page
	move nil1,[.fhslf,,endmv/1000]	;end of MV, restricted
	setz w2,			;no access
	spacs
	moves @[endq]			;create the page
	move nil1,[.fhslf,,endq/1000]	;end of Q
	setz w2,			;no access
	spacs
	setz nil1,
	iret	

;EXPSTK - allow access to the whole section, to allow debugging after PDL ovrfl
expstk:	setzm @[.%%STKLIM]		;say need to reset them later
;put illegal pages in to limit memory usage
	move nil1,[.fhslf,,endp/1000]	;end of P
	movsi w2,(pa%rd\pa%wt\pa%ex)	;full access
	spacs
	move nil1,[.fhslf,,endsp/1000]	;end of SP
	movsi w2,(pa%rd\pa%wt\pa%ex)	;full access
	spacs
	move nil1,[.fhslf,,endmv/1000]	;end of MV
	movsi w2,(pa%rd\pa%wt\pa%ex)	;full access
	spacs
	move nil1,[.fhslf,,endq/1000]	;end of Q
	movsi w2,(pa%rd\pa%wt\pa%ex)	;full access
	spacs
	setz nil1,
	jrst (w3)

ioinit:	
;some memory initialization.  First set up the illegal pages at the end
;of each stack - these are the permanent ones.  the smaller reduced ones
;are done in LIMSTK.
	moves @[endqs]			;create the page
	move nil1,[.fhslf,,endqs/1000]	;illegal page in buf sec, to stop Q
	setz w2,			;no access
	spacs
	moves @[endps]			;create the page
	move nil1,[.fhslf,,endps/1000]	;illegal page in buf sec, to stop P
	setz w2,			;no access
	spacs
	moves @[endsps]			;create the page
	move nil1,[.fhslf,,endsps/1000]	;illegal page in buf sec, to stop SP
	setz w2,			;no access
	spacs
	moves @[endmvs]			;create the page
	move nil1,[.fhslf,,endmvs/1000]	;illegal page in buf sec, to stop MV
	setz w2,			;no access
	spacs
	dmove w2,[-1 ? 777777777400]	;say all I/O buffer pages free
	dmovem w2,fremap
;initialize I/O state stuff
ioin1:	move o1,[object ty%cch,<datsec,,trmchn>] ;init current channels
	call trmini		;reinit it
	movem o1,@[.stdin]
	movem o1,@[.stdout]
	movem o1,@[.trmio]
	setom ch%lka(o1)	;clear lookahead
	setzm ch%lst(o1)
	movei nil1,.fhslf
;turn on ^C interrupt
	rpcap
	tlo w3,(sc%ctc)		;enable control-C
	epcap
;enable char interrupts
	movei nil1,2
	movem nil1,cnccnt
	setzm crit		;not in critical section
;enable error channels
	movei nil1,.fhslf
	move w2,[codsec,,sirarg]
	xsir%
	eir
	move w2,[770547,,106000] ;channels that we need
	aic
;Now turn on arith trap if there is one
	movei nil1,.fhslf	;set up arith trap
	movei w2,.swart
	xmovei w3,trpblk	;trap block
	swtrp%
	 erjmp [hrroi nil1,[asciz /
% Can't set arithmetic trap - Fortran routines may not work right
/]
		psout
		jrst .+1]
ioin2:
	move nil1,["C"-100,,0]	;^C on channel 0
	ati
	 erjmp [hrroi nil1,[asciz /
% Can't trap ^C - Use (EXIT) to reset terminal modes
/]
		psout
		jrst .+1]
	move nil1,["G"-100,,3]	;^G on channel 3
	ati
	move nil1,["B"-100,,5]	;^B on channel 5
	ati
	move nil1,["Y"-100,,24.] ;^Y on channel 23 (24?)
	ati
	setz nil1,
	iret

sirarg:	3
	codsec,,levtab
	codsec,,chntab
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  Interrupt system - general routines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;We have to disable interrupts during the GC.  The way we will
;handle this is by using routines STCRIT and ENCRIT.  STCRIT
;will just set a flag CRIT.  ENCRIT will clear this flag and
;activate any delayed interrupt.  At the moment we will use
;only level 2.  The routine CHCRIT should be used to check if
;we are in a critical section and if so delay the interrupt.
;Note that only one interrupt at a time is delayed, the most
;recent.

	.vector lev1pc(2),lev2pc(2),lev3pc(2),crit,cnccnt

levtab:	codsec,,lev1pc
	codsec,,lev2pc
	codsec,,lev3pc


;start critical section
stcrit:	setom crit		;say in critical section
	iret

;end critical section - this is called as a normal routine, so the AC's
;are free.  But we do have to prevent race conditions.
;Do any deferred interrupts.
encrit:	setz w3,
	exch w3,crit		;no longer critcal, see if anywhere to go
	jumpe w3,[halt .]	;not in critical section???
	jumpl w3,cpopj		;no interrupt happened
;here when we have defered an interrupt.  The channel number will be in
;CRIT, now in W3.
	hrlzi w2,400000		;make bit from bit number
	tlz w3,770000		;this was an object, so clear ty%lpi
	movn w3,w3
	lsh w2,(w3)
	movei nil1,.fhslf
	iic
	setz nil1,
	iret

;this is called at interrupt level, so we are protected against
;further interrupts.  Thus we don't have to do anything fancy with
;EXCH, etc.
chcrit:	skipn crit		;in critical section?
	jrst chcrix		;no - exit
;we are in critical section - save the fact that int occured and debreak
	pop q,crit		;arg is interrupt channel
	subi p,1		;forget ret addr
	debrk

chcrix:	subi q,1		;forget arg
	iret

exit:	haltf
	ret0
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Character interrupt routines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;The following routines must always preserve all AC's, stack, etc,
;;;;;; since they may be called anywhere.  They may however garbage
;;;;;; AC's if they have determined that they are about to abort, etc.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ^C
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	.vector cncacs(20),cncsav

;^C - exit at next good time, unless he gets impatient
cncint:	
;if he has done 6 ^C's without an exit, don't check critical section, just exit
	sosge cnccnt		;if 6 ^C's,
	jrst cncdo		;just do it
;now do normal processing
	push q,[inum 0]
	call chcrit		;delay if in critical section
cncdo:	push p,nil1
	movei nil1,2		;rearm the count
	movem nil1,cnccnt
	movei nil1,.priin
	cfibf			;otherwise EXEC will see our typeahead
	hrroi nil1,[asciz /^C
/]
	psout
	call warncr
	pop p,nil1	
;save AC's in case the user does a SAVE
cncxit:	movem 17,cncacs+17
	move 17,[0,,cncacs]
	blt 17,cncacs+16
	move 17,cncacs+17
	setom cncsav		;say they are saved
	haltf
	setzm cncsav		;say they are no longer current
	debrk

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ^C
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

cnyint:	push p,nil1
	movei nil1,.priin
	cfibf			;otherwise EXEC will see our typeahead
	hrroi nil1,[asciz /^Y
/]
	psout
	call warncr
	pop p,nil1
	jrst cncxit		;common code to exit

;WARNCR - if in GC, warn the user
warncr:	hrroi nil1,[asciz /%% Beware - you are in the garbage collector.  CONTINUE is OK, but START 
   will result in an unusable core image.
/]
	skipe crit
	psout
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ^G
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;^G - to nearest break loop
cngint:	push q,[inum 3]
	call chcrit		;delay if in critical section
	movei nil1,7
	pbout
	setzb nil,nil1		;in case interrupting something odd
	setzb o2,o3
	setzb o4,o5
	setz o6,
	move w2,[codsec,,cngdo]
	dmovem nil1,lev2pc	;zero flags and new PC
	jsp w2,valsp
	debrk
cngdo:	move o1,[%T]		;(CLEAR-INPUT T)
	call clrinp+1
	move o1,[%BRLPC]	;BREAK-LOOP-CATCHER
	call cthrow
	movei o1,nil
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ^B
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;^B - break now
cnbint:	push q,[inum 5]
	call chcrit		;delay if in critical section
	movei nil1,7
	pbout
	setzb nil,nil1		;in case interrupting something odd
	setzb o2,o3
	setzb o4,o5
	setz o6,
	xmovei w2,cnbdo
	dmovem nil1,lev2pc	;zero flags and new PC
	jsp w2,valsp
	debrk

cnbdo:	move o1,[%T]		;(CLEAR-INPUT T)
	call clrinp+1
	err /Break requested by user/
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Error interrupts
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	.vector ilinia(5)	;[Victor] For saying what went wrong

;ILLMEM - interrupt handler for illegal mem reads and writes
illmem:	move nil,@lev2pc+1	;get the bad instruction
	ldb nil,[.bp <740,,0>,nil] ;the AC field
;check for PDL overflow
	cain nil,p
	 jrst regpdl		;P pdl
	cain nil,q
	 jrst datpdl		;Q pdl
	cain nil,sp
	 jrst spcpdl		;SP pdl
;check for data out of range
	move nil,@lev2pc+1	;the bad instruction
	tlz nil,777740		;change into XMOVEI NIL,
	tlo nil,(xmovei nil,)
	xct nil			;now have E.A. of instruction
	camg nil,[datsec+datsiz,,1000] ;see if just above data section 1
	 camge nil,[datsec+datsiz-1,,777777]
	  jrst .+2
	 jrst freovr		;yes - free space overflow
	camg nil,[datsc2+datsiz,,1000] ;see if just above data section 1
	 camge nil,[datsc2+datsiz-1,,777777]
	  jrst .+2
	 jrst freovr		;free space overflow in other space
	camg nil,[codsec+1,,1000] ;see if just above code section
	 camge nil,[codsec,,777777]
	  jrst .+2
	 jrst codovr		;code space overflow
	camg nil,[endmv] ;see if just MV section
	 camge nil,[endmv\777777]
	  jrst .+2
	 jrst mvovr		;mv stack space overflow
	dmovem w2,ilinia	;[Victor] save for manual pawing over
	dmove w2,lev2pc		;[Victor]
	dmovem w2,ilinia+2	;[Victor] ditto
	movem nil,ilinia+4	;[Victor] save bad address
	dmove w2,[0 ? codsec,,grbptr]
	dmovem w2,lev2pc
	debrk
grbptr:	hrroi nil1,[asciz /
Reference to illegal address #o/] ;[Victor] start
	psout
	movei nil1,.priou
	move w2,ilinia+4	;[Victor] bad address
	movei w3,10		;[Victor] in octal
	nout			;[Victor] print out
	 erjmp .+1
	hrroi nil1,[asciz / by instruction at #o/]
	psout
	movei nil1,.priou
	move w2,ilinia+3	;[Victor] loc of bad instruction
	movei w3,10		;[Victor] in octal
	nout
	 erjmp .+1
	err /(Probable garbage pointer)/	;[Victor] end addition
;	setzb nil,nil1
;	move 
;	err /Reference to illegal address - probable garbage pointer/

;various error processing routines
;PDL overflows - expand the stacks so we can use the debugger

regpdl:	hrroi nil1,[asciz / The control stack overflowed - probably too much recursion/]
	jrst dopdl

datpdl:	hrroi nil1,[asciz / The data stack overflowed - probably too much recursion/]
	jrst dopdl

spcpdl:	hrroi nil1,[asciz / The special stack overflowed - probably too much recursion/]
	jrst dopdl

mvovr:	hrroi nil1,[asciz / The multiple value stack overflowed - probably too much recursion/]
	jrst dopdl

dopdl:	esout
	skipn @[.%%STKLIM]		;already in bad shape?
	jrst badpdl
	dmove w2,[0 ? codsec,,dopdl1]
	dmovem w2,lev2pc
	debrk
dopdl1:	jsp w3,expstk			;no - expand it
	jsp w2,valsp			;make sure SP is valid
	setzb nil,nil1
	err /Expanding stacks temporarily to allow the debugger to run/

badpdl:	hrroi nil1,[asciz /
Your stack is already expanded, so we must return you to the top level of LISP
/]
	jrst fatal

freovr:	hrroi nil1,[asciz /You have run out of memory in Lisp free space.  Your program is probably 
too big.  We will return you to the top level of Lisp.  You should save any
data you can, because your core image is probably irretrievably garbaged.
/]
	jrst fatal

codovr:	hrroi nil1,[asciz /You have run out of memory in code space.  If you were not loading compiled
code, it is possible that what you really have is a garbage pointer.
/]
	jrst fatal

fatal:	esout
	setzb nil,nil1
kill:	movei nil1,7
	pbout
	setz nil1,
	move w2,[codsec,,restac]	;will clear the Lisp ac's
	dmovem nil1,lev2pc
	debrk

pdlovr:	dmove w2,[0 ? codsec,,pdlmsg]
	dmovem w2,lev2pc
	debrk
pdlmsg:	setzb nil,nil1
err /Pushdown list overflow.  This should be impossible.  Probably a bug in
the interpreter or compiled code./

sysres:	dmove w2,lev2pc		;[Victor] Get where we barfed
	dmovem w2,ilinia	;[Victor] save in ill-mem-ref save area
	dmove w2,[0 ? codsec,,syrmsg]
	dmovem w2,lev2pc
	debrk
syrmsg:	hrroi nil1,[asciz /
System resources exhausted at #o/]
	psout			;[Victor] print where
	move w2,ilinia+1
	movei nil1,.priou
	movei w3,10
	nout
	 erjmp .+1		;[Victor] and hint about quota problem
	hrroi nil1,[asciz /.  Probably you have run out of memory.
If so, your core image has probably been irretrievably lost.
Otherwise, you might have run out of disk.  If so, try to find some more.
Type "CONTINUE" to try to restart Lisp.
/]
	psout
	haltf	;make him type continue, to avoid infinite loop
	setzb nil,nil1
	jrst restac

maxerr==40
	.vector errmsg(maxerr)	;place to put monitor error msg

illins:	dmovem w2,ilinia	;[Victor] save for manual pawing over
	dmove w2,lev2pc		;[Victor]
	dmovem w2,ilinia+2	;[Victor] save for printout
	dmove w2,[0 ? codsec,,ilsmsg]
	dmovem w2,lev2pc
	debrk
ilsmsg:	hrroi nil1,errmsg	;put it here
	move w2,[.fhslf,,-1]	;most recent error for this process
	hrlzi w3,-maxerr*5	;this many char's
	erstr
	 jrst illinx
	 jrst illinx
	hrroi nil1,errmsg
	esout			;[Victor: esout] print the error message
	hrroi nil1,[asciz / at #o/]	;[Victor] start addition
	psout
	movei nil1,.priou
	move w2,ilinia+3
	subi w2,1
	movei w3,10		;[Victor] octal
	nout
	 erjmp .+1
	hrroi nil1,[asciz /
Instruction = #o/]
	psout
	move w2,ilinia+3
	move w2,-1(w2)		;[Victor] get bad instruction
	 erjmp .+1
	movei nil1,.priou
	move w3,[no%mag+10]	;[Victor] unsigned octal
	nout
	 erjmp .+1		;[Victor] end addition
	setzb nil,nil1
	err /Error signaled by operating system/

illinx:	setzb nil,nil1
	err /The operating system has issued an error that we can't figure out/
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  I/O channel stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;TY%STR
fnaml==100
	.scalar filnhe	;string header for filnam
	.vector filnam(fnaml),filnm2(fnaml)

;;TY%ATM
;one arg - put name as string in filnam
mflnam:	jumpe o1,mflnil		;nil is special
	call getstr		;get valid string into o1
mflnm1:	caile w4,<fnaml*5>-1	;if too long
	movei w4,<fnaml*5>-1	;use max
	tlo w4,(object(ty%sp5,0)) ;make valid header
	movem w4,filnhe
	tlz w4,770000		;back to pure number
mflnma:	move o1,[440700,,filnam] ;destination
	jumpe w4,mflnmx
mflnml:	ildb o2,w2		;now copy char's
	cain o2,":"		;look for host name
	 jrst mflnmc
mflnnh:	idpb o2,o1
	sojg w4,mflnml
mflnmx:	idpb nil,o1
	setzb o1,o2		;these got junk in them
	iret

;here if we find a :.  Look for host
mflnmc:	push p,w2
	push p,w3
	ildb o2,w2		;peek at next
	cain o2,":"
	 jrst mflnmh		;another :, have a host name
	movei o2,":"		;not, just go process this one
	pop p,w3		;not a host name, continue
	pop p,w2
	jrst mflnnh

;here if we have a host name.  Purge it
mflnmh:	subi p,2		;leave W2 incremented
	soja w4,mflnma		;reinit output spec

mflnil:	err /Null file name/

;GETSTR - Lisp object of unknown type in O1
;ends up with byte pointer in W2/W3
;count in W4
;base string in O1
;
;NB: If you are going to do I/O, you will want to or into
;W4 an indirect reference to the AC you will have the base
;string in
getstr:	gettyp o1
	caie w2,ty%str		;if simple string
	 cain w2,ty%cst
	  jrst getsts		;this is easy
	cain w2,ty%arh
	 jrst getsta		;if array header, it is harder
	caie w2,ty%atm		;if atom, use the PNAME
	 cain w2,ty%cat
	   jumpn o1,getstm
getste:	err1 o1,/Argument is not a string: ~S/

;here if a simple string - just set up the count and byte pointer
getsts:	move w4,(o1)
	tlz w4,770000
	move w2,[010740,,0]
	xmovei w3,(o1)
	iret

;here if an array that is a string (we hope)
getsta:	xtype ah%dat(o1)	;make sure it is really a string
	caie w2,ty%xst
	 jrst getste		;no error
	move w2,ah%dsp(o1)	;displacement
	move w3,[010740,,0]
	move w4,ah%dat(o1)
	tlz w4,770000
	adjbp w2,w3		;w2/w3 is now the byte pointer
	move w4,ah%fil(o1)	;w4 is size
	tlz w4,770000
	move o1,ah%dat(o1)	;O1 is data
	iret

;here if an atom
getstm:	skipn o1
	move o1,[%NIL]
	move o1,at%pna(o1)	;use pname recursively
	jrst getstr

;GETBVC - for bit vectors
;Lisp object of unknown type in O1
;ends up with byte pointer in W2/W3
;count in W4
;base string in O1
;
;NB: If you are going to do I/O, you will want to or into
;W4 an indirect reference to the AC you will have the base
;string in
getbvc:	gettyp o1
	cain w2,ty%bvc		;if simple string
	 jrst getbvs		;this is easy
	cain w2,ty%arh
	 jrst getbva		;if array header, it is harder
getbve:	err1 o1,/Argument is not a bit vector: ~S/

;here if a simple bit vector - just set up the count and byte pointer
getbvs:	move w4,(o1)
	tlz w4,770000
	move w2,[010140,,0]
	xmovei w3,(o1)
	iret

;here if an array that is a bit vector (we hope)
getbva:	gettyp ah%dat(o1)	;make sure it is really a string
	caie w2,ty%bvc
	 jrst getbve		;no error
	move w2,ah%dsp(o1)	;displacement
	move w3,[010140,,0]
	move w4,ah%dat(o1)
	tlz w4,770000
	adjbp w2,w3		;w2/w3 is now the byte pointer
	move w4,ah%fil(o1)	;w4 is size
	tlz w4,770000
	move o1,ah%dat(o1)	;O1 is data
	iret
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; File system operations
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;definition of the PATHNAME record

pt%hdr==0	;the atom PATHNAME
pt%hst==1	;host, currently unused
pt%dev==2	;device
pt%dir==3	;directory
pt%nam==4	;name
pt%typ==5	;type [extension]
pt%ver==6	;version [generation]
pt%len==7	;data words in record

;;;;;;;;;;;;
;;; OPEN
;;;;;;;;;;;;

;xopenf - this is %SP-OPEN
; o1 - filename
; o2 - direction
; o3 - if-exists
; o4 - if-does-not-exist
; o5 - object type

define gtjbts			;gtjfn bits
	0(p) termin
define opfbts			;openf bits
	-1(p) termin
define ifexst			;routine to go to if exists
	-2(p) termin
define ifnexs			;routien to go to if does not exist
	-3(p) termin
define bytesz			;code for byte size
	-4(p) termin
define iodir			;actual atom used for direction
	-5(p) termin

xopenf:	addi p,6		;place for bits to go
; o2 - direction.  Load W2 with openf bits
	seto w2,		;so we can tell if something found
	camn o2,@[$input]
	movei w2,of%rd
	camn o2,@[$output]
	movei w2,of%wr
	camn o2,@[$io]
	movei w2,of%rd\of%wr
	camn o2,@[$probe]
	movei w2,0
	jumpl w2,[err1 o2,/Illegal DIRECTION in OPEN: ~S/]
	movem w2,opfbts		;use as initial setting for openf bits
	movem o2,iodir
; o3 - if-exists.  Load W2 with GTJFN bits, W3 with addr for failure due
;   to "file already exists".
	seto w3,		;so we can tell if something found
	camn o3,[$default]
	dmove w2,[0 ? <codsec,,opnjer>]
	camn o3,[$error]
	dmove w2,[gj%new ? <codsec,,opnjer>]
	camn o3,[$newver]
	dmove w2,[gj%fou ? <codsec,,opnjer>]
	camn o3,[$rename]
	dmove w2,[gj%new ? <codsec,,opnren>]
	camn o3,[$rendel]
	dmove w2,[gj%new ? <codsec,,opndel>]
	camn o3,[$overwrite]
	 jrst [	dmove w2,[0 ? <codsec,,opnjer>]
		movei w4,of%wr\of%rd
		iorm w4,opfbts
		jrst .+1]
	camn o3,[$append]
	 jrst [	dmove w2,[0 ? <codsec,,opnjer>]
		move w4,opfbts
		trze w4,of%wr		;replace write
		tro w4,of%app		;with append
		movem w4,opfbts
		jrst .+1]
	camn o3,[$supersede]
	 jrst [	dmove w2,[0 ? <codsec,,opnjer>]
		movei w4,of%wr
		movem w4,opfbts
		jrst .+1]
	camn o3,nil
	dmove w2,[gj%new ? <codsec,,opnnil>]
	jumpl w3,[err1 o3,/Illegal IF-EXISTS in OPEN: ~S/]
	movem w2,gtjbts
	movem w3,ifexst
; o4 - if-does-not-exist.  Load W2 with gtjfn bits to be or'ed into
;  existing ones, W3 with address to go to if failure
	seto w3,
	camn o4,[$error]
	dmove w2,[gj%old ? <codsec,,opnjer>]
	camn o4,[$create]
	dmove w2,[0 ? <codsec,,opnjer>]
	camn o4,nil
	dmove w2,[gj%old ? <codsec,,opnnil>]
	jumpl w3,[err1 o4,/Illegal IF-DOES-NOT-EXIST in OPEN: ~S/]
	iorm w2,gtjbts
	movem w3,ifnexs
; o5 - element type
	scons o5		;see what it is
	jrst openta		;an atom
;here for data types of the form (thing N)
	docdr w3,o5		;first decode syntax
	scons w3
	jrst opniel		;make sure there is a second thing
	push q,o1
	docar o1,w3
	call get1nt		;get unsigned 36-bit number into W2
	pop q,o1
	docar w4,o5
  ;now have keyword in w4, number in w2
	camn w4,[%unsbyte]	;unsigned byte
	jrst opunsb
	camn w4,[%sgnbyte]	;signed byte
	jrst opsgnb
	came w4,[%mod]
opniel:	 jrst [err1 o5,/Illegal ELEMENT-TYPE in OPEN: ~S/]
  ;mod is slightly different because we have to compute the
  ;number of bits
	subi w2,1		;mod is numbers less than W2
	jffo w2,.+2		;number of leading zeros to O2
	 movei w3,36.		;if no 1 found, say all leading zeros
	movei w2,36.
	sub w2,w3
  ;w2 is now the number of bits
	;jrst opunsb		;call unsigned
;here for unsigned, number of bits in w2
opunsb:	movei w3,ct%uns
	cail w2,36.		;[Victor] check the right ac
	 jrst [err /UNSIGNED-BYTE byte size must be less then 36/]
	jrst opsgnc
;here for signed, number of bits in w2
opsgnb:	movei w3,ct%sgn
	caile w2,36.		;[Victor] check the right ac
	 jrst [err /SIGNED-BYTE byte size must be less than 37/]
	cain w2,36.		;if 36 bits
	movei w3,ct%uns		;treat as unsigned
opsgnc:	hrl w3,w2
	movem w3,bytesz
	lsh w2,30.		;move byte size into position for openf
	iorm w2,opfbts		;and put it there
	jrst openfj

;here for atomic types
openta:	seto w2,		;let us check whether we saw something
	camn o5,[%strchr]	;string-char
	move w2,[7.,,ct%str]
	camn o5,[%character]
	move w2,[36.,,ct%chr]
	camn o5,[%unsbyte]
	move w2,[0.,,ct%uns]	;[Victor] Determine sieze later
	camn o5,[%sgnbyte]
	move w2,[0.,,ct%sgn]	;[Victor] Ditto
	camn o5,[%bit]		;[Victor] Handle :BIT
	move w2,[1.,,ct%uns]	;[Victor] 
	camn o5,[$default]
	move w2,[7.,,ct%str]
	jumpl w2,opniel
	movem w2,bytesz
	hlrz w2,w2		;get just the byte size
	lsh w2,30.		;into position for openf
	iorm w2,opfbts
	;jrst openfj		;now ready to open

;now we have the bits set up in the stack - O1 is file 
;Make channel and do GTJFN
openfj:	call namstr		;convert other things into string
	xtype o1
	push q,o1		;save original file spec for later
	call mflnam		;put name in FILNAM
opengj:	setz o1,		;say no file yet
	move nil1,gtjbts	;find the gtjfn bits
	tlo nil1,(gj%sht+gj%flg) ;standard bits
	hrroi w2,filnam
	gtjfn
	 erjmp [caie nil1,gjfx27 ;error is file exists
		jrst @ifnexs	;no, just do normal code
		jrst @ifexst]	;yes, special if-exists
	call makchn		;make a channel with that JFN in it
;;;[Victor] The following code is a starting approximation for 
;;; the code we really want, getting the bytesize from the FDB.
;;; Should do something about new files (now get bsz 0) and non-disk files.
;;; Courtesy of Anders Andersson.
	hlrz w2,bytesz		;get the bytesize
	caie w2,0		;if zero, then we want to find out
	 jrst openg5
	hrrz nil1,ch%jfn(o1)
	dvchr			;Get device charax
	hlrzs nil1
	caie nil1,.dvdes+.dvdsk	;A disk device?
	 jrst [ movei w2,0 ? jrst openg4 ]	;No, go default it
	hrrz nil1,ch%jfn(o1)
	move w2,[1,,.fbctl]
	movei w3,w2
	gtfdb
	 erjmp [ movei w2,0 ? jrst openg4 ]
	tlne w2,(fb%nxf)	;Does the file exist yet?
	 jrst [ movei w2,0 ? jrst openg4 ]	;No, default size
	move w2,[1,,.fbbyv]
	movei w3,w2
	gtfdb			;want to find out real byte size
	ldb w2,[.bp 77_24.,w2]	;w2 _ file's byte size
openg4:	hrlm w2,bytesz		;save the bytesize
	lsh w2,30.		;into position for openf also
	iorm w2,opfbts
openg5:
;;;[Victor] End of new code
	move w2,bytesz
	movem w2,ch%typ(o1)
;Open the file if called for.
	move w2,opfbts		;does he want any open functions?
	trnn w2,of%rd\of%wr\of%app
	jrst openpr		;no - forget it - channel already in O1

	hrrz nil1,ch%jfn(o1)	;get back pure jfn
	dvchr			;see what we have
	ldb w4,[.bp 777_18.,w2]	;device type
	hrrz nil1,ch%jfn(o1)	;get back jfn again
	move w2,opfbts		;and openf bits
 ;this is code to let us try simulating append with normal read/write I/O
	cain w4,.dvdsk		;disk?
	trnn w2,of%app		;append?
	jrst openfn		;no or no - just go ahead
	trz w2,of%app		;first try to let us simulate - clear append
	tro w2,of%wr\of%rd	;first try to let us simulate using read/write
	openf
	 erjmp [hrrz nil1,ch%jfn(o1)	;failed, try again the normal way
		move w2,opfbts		;with real append
		jrst openfn]
	jrst openfy
 ;end of special append code
openfn:	openf
	 erjmp @ifnexs		;do error as user asked
;we now have a file open.  Do device depend initialization if needed
openfy:	move w4,opfbts
	call opendv
;done - restore things
	subi p,6
	sos (o1)		;about to use CH%DAT for Lisp object
	pop q,ch%dat(o1)	;put original name here
	setzb nil,nil1
	ret1

;here after gtjfn for probe.  Just close it
openpr:	subi p,6
	setzb nil,nil1
	jumpe o1,[call makchn	;if no channel, give him an empty one
		  seto ch%jfn(o1) ;say it is closed, but had a JFN
		  jrst openpx]
	push q,o1		;have to save O1 over close
	setz o2,		;make sure no funny close bits
	call norclo
	pop q,o1
openpx:	sos (o1)		;about to use CH%DAT for Lisp object
	pop q,ch%dat(o1)	;put original name here
	ret1

;;;;;;;;;various user-requested error routines.

;the first one is easy - return NIL
opnnil:	subi p,6
	setzb nil,nil1
	jumpe o1,ret1v		;if no channel, just return NIL
	hrrz nil1,ch%jfn(o1)	;if there is, first release it
	rljfn
	 erjmp .+1
	setzb nil1,o1
	ret1

;print canonical error message
opnjer:	jumpe o1,opfer0		;if no channel, just do the error
	hrrz nil1,ch%jfn(o1)	;if there is, first release it
	rljfn
	 erjmp .+1
	jrst opfer0		;then go do the error

;rename the offending file - can only happen on GTJFN
opnren:	call opnrnn		;rename it
	move nil1,w2		;get jfn of new copy
	rljfn			;release it
	 erjmp .+1
	jrst opengj		;now try again

;rename the offending file and then delete the renamed copy
opndel:	call opnrnn		;rename it
	move nil1,w2		;get jfn of new copy
	delf			;delete it
	 erjmp .+1
	jrst opengj		;now try again

;;;;;subroutine for rename and rename-and-delete
opnrnn:	move nil1,[gj%sht\gj%old\.gjleg] ;get rid of lowest version first
	hrroi w2,filnam
	gtjfn
	 erjmp [err /File exists and does not exist at the same time/]
	push p,nil1		;save the jfn
	move w2,nil1		;now make up new file name
	hrroi nil1,filnm2	;put it here
	move w3,[111000,,1]	;same place and name as old one
	jfns
	hrroi w2,[asciz /.LISP-BACKUP/] ;use this extension
	setz w3,
	sout
	movsi nil1,(gj%sht\gj%fou) ;now get new jfn
	hrroi w2,filnm2
	gtjfn
	 erjmp [err /Unable to rename old file to .LISP-BACKUP/]
	move w2,nil1		;use new one as destination
	pop p,nil1		;original as source
	rnamf
	 erjmp [err /Unable to rename old file to .LISP-BACKUP/]
	iret


;;TY%CHN
;makchn - make channel object for real I/O device, jfn in NIL1
;code in instrg relys on not using W4
makchn:	push free,[object ty%spc,ch%666] ;GC code
	move w2,free		;save addr to return
	push free,nil1		;jfn
	push free,[80.]		;len
	push free,[0]		;pos
	push free,[codsec,,clsdio] ;get
	push free,[codsec,,clsdio] ;put
	push free,[disp clsdsp] ;normal dispatch table
	push free,[-1]		;lka
	push free,[0]		;lst
	movei w3,ch%666-ch%lst	;number of extra entries needed
	push free,[0]
	sojg w3,.-1
	tlo w2,(object ty%chn,0)
	move o1,w2		;return new channel
	setz nil1,
	camle free,lastl	;see if went beyond end of space
	 call sgc		;yes
	ret1


;OPENDV is a general routine, usable by anyone who opens files and
;wants the right device-specific stuff.  We assume that the channel
;has already been set up except the DSK specific stuf.  W4 contains
;the OPENF bits, including byte size.
opendv:	move w2,[codsec,,norget] ;initialize for random device
	movem w2,ch%get(o1)
	move w2,[codsec,,norput]
	movem w2,ch%put(o1)
	move w2,[disp nordsp]
	movem w2,ch%dsp(o1)
	hrrz nil1,ch%jfn(o1)	;get back pure jfn
	dvchr			;see what we have
	ldb w2,[.bp 777_18.,w2]	;device type
	cain w2,.dvdsk		;disk?
	 jrst opddsk		;yes, set up for PMAP I/O
	cain w2,.dvtty		;terminal?
	 jrst opdtrm		;yes, set up for TEXTI
	setz nil1,
	iret

opdtrm:	call trmopn
	setz nil1,
	iret

opddsk:	call dskopn
	setz nil1,
	iret

;;TY%STR
;here for error from openf - file in O1
;actually the error message used is from the monitor, so this case
;be used for any error in which there is a file in O1
opfer2:	move o1,o2		;file is on O2
opfer:	hrrz w2,ch%jfn(o1)	;get name for this file
opferx:	hrroi nil1,filnam
	setz w3,		;default format
	jfns
	ldb w2,[.bp (770000),nil1]	;make string header for name
	idivi w2,7
	hrrzs nil1
	subi nil1,filnam
	imuli nil1,5
	sub nil1,w2
	hrrm nil1,filnhe
;entry when file name already in FILNAM
opfer0:	hrroi nil1,errmsg	;put it here
	move w2,[.fhslf,,-1]	;most recent error for this process
	hrlzi w3,-maxerr*5	;this many char's
	erstr
	 jrst operx
	 jrst operx
	hrroi nil1,errmsg
	psout				;print the message returned
;	move nil1,[codsec,,filnhe]
	hrroi nil1,[asciz /: /]	;[Victor] separate error from filename
	psout
	hrroi nil1,filnam	;[Victor] Why not use this????
	psout				;print the file name
	setzb nil,nil1
	err /Error in opening file/

operx:	err /Error in file operation/

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOSE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;TY%CHN
;This function should never give an error, unless it is given an object
;that couldn't be a legal channel.  I.e. it should be legal to close
;channels that are already closed, etc.
; O1 - channel
; O2 - close bits [INUM, representing LH of close bits - NIL=0]
closef:	setz o2,		;default to normal close
	xtype o1		;make sure legal channel number
	caie w2,ty%xch
	jrst illchn
	move w2,ch%dsp(o1)	;dispatch
	jrst @ch%clo(w2)	;do device-dependent code

illchn:	err1 o1,/Illegal I-O channel: ~S/

notopn:	err1 o1,/I-O channel not open: ~S/

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; PARSE-NAME-STRING
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1 - specification
;O2 - starting index, NIL = unspecified
;O3 - ending index, NIL = unspecified
;O4 - junk allowed after name
;  allows string, atom, pathname, or stream.  Only interesting
;	for string and atom.
;  returns a pathname and the index of the first char beyond the
;	filename.  If not a string or atom, returns START, which
;	defaults to 0
;  a null string results in all NIL's
;This routine violates one of my primary rules, namely that
;user code should not parse filenames.  This should be left
;to GTJFN.  Unfortunately, I don't see how to do so, since
;parse-only GTJFN still looks up the device and directory, and
;supplies defaults from the connected directory.

prsnam:	gettyp o1		;see what they gave us
	cain w2,ty%vec
	 jrst prsnmv		;better be a namestring already
	caie w2,ty%cch
	 cain w2,ty%chn
	  jrst prsnmc		;a channel, get its namestring
	call getstr		;count in W4, pointer in W2/3
	skipe nil1,o2		;offset by start, if NIL, use as 0
	jrst [	getnum nil1	;specified, use it
		jrst .+2]
	 move o2,[inum 0]	;unspec, have 0 in NIL1, put inum 0 in o2 also
	skipe o3		;if user specified an end
	jrst [	move w4,o3	;then use it instead
		getnum w4
		sub w4,nil1	;make it a count by subtracting start
		jrst .+1]
	adjbp nil1,w2
;now have byte pointer in NIL1/W2
;   count in W4
;   starting offset in O2

;create the structure, so we have somewhere to put the string
	push free,[inum st%str]
	push free,[inum pt%len]
	xmovei o1,1(free)	;O1 - the final namestring
	tlo o1,(object(ty%vec,0))
	push free,[%pathname]
	addi free,pt%len-1	;make space for components

;now parse things.
	call prsatm		;get the first atom
	 jrst prsdir		;immediate break. maybe directory
	caie w3,":"		;if not colon, then better be file name
	 jrst prsfnm
	jumpe w4,prsdev		;if no more chars left, must be a device
	push p,nil1		;else peek at next to see if a host
	push p,w2
	ildb w3,nil1		;peek at next
	caie w3,":"		;if also colon, we have a host name
	jrst [	pop p,w2	;not, just device
		pop p,nil1
		jrst prsdev]
	sos w4			;count the :
	aos o2
;here if host name seen
	subi p,2
	movem o3,pt%hst(o1)	;then save it
	call prsatm
	 jrst prsdir		;immediate break, maybe directory
	caie w3,":"		;if colon, is device
	 jrst prsfnm
;here after device name
prsdev:	movem o3,pt%dev(o1)
	call prsatm
	 jrst prsdir		;immediate break, maybe directory
	jrst prsfnm		;else a name
;here if immediate break.  probably directory
prsdir:	caie w3,74		;open broket?
	 jrst prsfnm		;no, maybe null file name?
	call prsdat		;atom with dot allowed
	 jfcl			;allow null directory, but call it unspecified
	caie w3,76
	 jrst prserr
	movem o3,pt%dir(o1)
	call prsatm
	 jfcl			;ok if empty
;here for file name (we hope)
prsfnm:	movem o3,pt%nam(o1)
	caie w3,"."		;if ends in dot, also have extension
	 jrst prsdon		;else done
;extension
	call prsatm
	 move o3,[makstr //]	;null extension is legal
	movem o3,pt%typ(o1)
	caie w3,"."		;if ends in dot, have version
	 jrst prsdon
;version
	setz o3,		;assume no version specified
	push p,[0]		;assume positive
	sojl w4,[seto w3,
		jrst prsvrw]	;if no more char's, that's it
	ildb w3,nil1		;get first char
	aos o2			;count chars
	cain w3,"*"
	 jrst [	move o3,[$wild]
		seto w3,	;no break char
		jrst prsvrw]
	cain w3,"-"		;remember if version is negative
	 jrst [	movem w3,(p)	;remember it
		sojl w4,prserr	;if no more char's it is illegal
		ildb w3,nil1
		aos o2		;count chars
		jrst .+1]
prsvrl:	cail w3,"0"
	 caile w3,"9"		;better be digit
	  jrst prsvrx
	imuli o3,10.		;add in new digit
	subi w3,"0"
	add o3,w3
	tlne o3,777777		;only 18 bits allowed in version
	 jrst prserr
	sojl w4,prsvre		;stop if no more chars
	ildb w3,nil1		;else get next
	aoja o2,prsvrl		;and count it

;here if get to end of string
prsvre:	seto w3,		;say got to end
;here if got terminator
prsvrx:	skipe (p)		;if negative
	movn o3,o3		;then negate it
	maknum o3		;make it a Lisp number
prsvrw:	subi p,1		;get rid of sign
	camn o3,[inum 0]	;zero is highest
	move o3,[$newest]
	camn o3,[inum -1]
	move o3,[$newver]
	camn o3,[inum -2]
	move o3,[$oldest]
	camn o3,[inum -3]
	move o3,[$wild]
	movem o3,pt%ver(o1)	;and put number in


;at this point we have in W3 either -1 if got to end of string or
;  the final terminator.
prsdon:	skipl w3		;if we read any junk at the end
	 sos o2			;don't count it
	setzb nil,nil1
	setzb o5,o6
	skipl w3		;if we read any junk at the end
	jumpe o4,[err /Junk at end of file name/] ;it is error
	ret2		;returning 2 args

prserr:	err /Syntax error in file name/

;;;;;;;; PRSATM

;here is the magic.  Parse an atom, leaving terminator in W3
; string in O3.  If immediate terminator, NIL in O3, and non-skip.
prsdat:	push p,[1]		;period is legal
	jrst .+2
prsatm:	push p,[0]		;period is illegal
	movsi o5,440740		;O5/O6 will be dest
	xmovei o6,2(free)	;string goes here
	setzm 2(free)		;clear it
	move nil,[object(ty%sp5,0)] ;count here
	setz o3,		;assume return NIL
prsatl:	sojl w4,prsate		;stop if no more chars
	ildb w3,nil1		;get next char
	aos o2			;count char's taken from input
	cain w3,26		;^V is special
	 jrst prsatv
	cain w3,"."		;period may be terminator or not
	 skipe (p)		;if terminator, then done
	  skipn prstrm(w3)	;if term
	   jrst prsatx		;then done
prsatc:	idpb w3,o5		;put in string
	aos nil			;count chars in this string
	setzm 1(o6)		;clear next word
	jrst prsatl		;and try again

;here for ^V
prsatv:	idpb w3,o5		;copy to string
	aos nil			;count it
	setzm 1(o6)		;clear next word
	sojl w4,[err /End of string after ^V/] ;must be something there
	ildb w3,nil1		;get it
	aos o2			;count it
	jrst prsatc		;and treat as normal char

;here if get to end of string
prsate:	seto w3,		;say got a null
;here if got terminator
prsatx:	subi p,1
	camn nil,[object(ty%sp5,0)] ;see if we got anything?
	 iret			;no, non-skip
;got something - make at atom of it
	camn nil,[object(ty%sp5,1)] ;see if simple *
	 jrst [	move o3,2(free)	;one char, see what it is
		came o3,[ascii /*/] ;if *
		jrst .+1	;not, continue
		move o3,[$wild]	;call it wild
		aos (p)
		iret]
	push free,nil		;start with count
	move o3,free		;return that as the string
	tlo o3,(object(ty%str,0))
	move free,o6		;advance free list to end of string
	aos (p)			;do skip return
	iret

prstrm:	
repeat 44,[0
	    ]
	1			;44 - $
	1			;45 - %
repeat 4,[0
	   ]
	1			;52 - *
	0
	0
	1			;55 - -
	1			;56 - .
	0
repeat 12,[1
	    ]			;60 - 71 - digits
repeat 7,[0
	   ]			;72 - 100
repeat 26.,[1
	     ]			;101 - 132 - upper case
repeat 4,[0
	   ]			;133 - 136
	1			;137 - _
	0			;140 - `
repeat 26.,[1
	     ]			;141 - 172 - lower case
repeat 5,[0
	   ]			;173 - 177

;;;;;;;;;;;;;;;;;;;;;

;here if we already have a namestring
prsnmv:	move o3,-2(o1)		;make sure it is really
	came o3,[inum st%str]	;must be structure
prsnme:	 jrst [err1 o1,/Attempt to get NAMESTRING from some bogus object: ~S/]
	move o3,(o1)
	came o3,[%PATHNAME]
	 jrst prsnme
	skipn o2
	move o2,[inum 0]	;default start to 0
	ret2			;return 2 values

;here if we have a channel
prsnmc:	skipn ch%jfn(o1)	;look at its JFN
	 jrst [err /Attempt to get NAMESTRING from stream that is not associated with a file/]
	move o1,ch%dat(o1)	;has one, so must have a string
	skipn o2
	move o2,[inum 0]	;default start to 0
	push q,o2		;save it to return
	call prsnam
	pop q,o2
	ret2			;return 2 values

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  NAMESTRING
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

namstr:	gettyp o1		;see what they gave us
	cain w2,ty%vec
	 jrst nmspth		;probably a pathname
	caie w2,ty%cch
	 cain w2,ty%chn
	  jrst nmschn		;a channel, get its namestring
	call isstr		;is it a string
	 jrst namst1
	ret1			;yes, just return it
namst1:	caie w2,ty%atm
	 cain w2,ty%cat
	  jrst symnam		;if a symbol, return its name
	err1 o1,/NAMESTRING argument is not a path: ~S/

;here for a channel
nmschn:	skipn ch%jfn(o1)	;look at its JFN
	 jrst [err /Attempt to get NAMESTRING from stream that is not associated with a file/]
	move o1,ch%dat(o1)	;has one, so must have a string
	ret1

;;;;;;;;;;;;;;;;;;;

;here for a structure
nmspth:	move o3,-2(o1)		;make sure it is really
	came o3,[inum st%str]	;must be structure
	 jrst prsnme
	move o3,(o1)
	came o3,[%PATHNAME]
	 jrst prsnme
	push q,o1		;save the original
	move o1,[makstr //]	;start with null string
;host
	move o3,(q)
	skipn o2,pt%hst(o3)
	jrst nmsdev		;none, look for device
	camn o2,[$wild]
	move o2,[makstr /*/]
	call stconc
	move o2,[makstr /::/]
	call stconc
;device
nmsdev:	move o3,(q)
	skipn o2,pt%dev(o3)
	jrst nmsdir		;none, look for directory
	camn o2,[$wild]
	move o2,[makstr /*/]
	call stconc
	move o2,[makstr /:/]
	call stconc
;directory
nmsdir:	move o3,(q)
	skipn pt%dir(o3)
	jrst nmsnam		;none, look for name
	move o2,[ty%cst_30.+<codsec,,[ty%sp5_30.+1
			     74_29.]>] ;open broket
	call stconc
	move o3,(q)
	move o2,pt%dir(o3)
	camn o2,[$wild]
	move o2,[makstr /*/]
	call stconc
	move o2,[ty%cst_30.+<codsec,,[ty%sp5_30.+1
			     76_29.]>] ;close broket
	call stconc
;name
nmsnam:	move o3,(q)
	skipn o2,pt%nam(o3)
	jrst nmstyp		;none, look for file type
	camn o2,[$wild]
	move o2,[makstr /*/]
	call stconc
;type
nmstyp:	move o3,(q)
	skipn pt%typ(o3)
	jrst nmsver		;none, look for version
	move o2,[makstr /./]
	call stconc
	move o3,(q)
	move o2,pt%typ(o3)
	camn o2,[$wild]
	move o2,[makstr /*/]
	call stconc
;version
	skipa o2,[makstr /./]	;entry for type done
nmsver:	move o2,[makstr /../]	;entry for no type
	move o3,(q)
	skipn pt%ver(o3)
	jrst nmsdon		;none, done
	call stconc
	move o3,(q)
	move o2,pt%ver(o3)
	skpin o2		;if version is numeric
	jrst nmsvrs		;no, better be a string
;version is a number
	hrroi nil1,filnam	;put it here
	move w2,o2
	getnum w2		;this number
	movei w3,10.		;decimal
	nout
	setz nil1,
	move w2,[object ty%sp5,0] ;start count at zero
	move w3,[440700,,filnam]
	ildb w4,w3
	caie w4,0
	aoja w2,.-2
	movem w2,filnhe		;now have correct count in header
	move o2,[object ty%cst,<codsec,,filnhe>]
	jrst nmsvrc		;go put this on the string

;version is a string
nmsvrs:	camn o2,[$wild]
	move o2,[makstr /*/]
	camn o2,[$newest]
	jrst nmsdon		;newest is TOPS-20 default: nothing needed
	camn o2,[$newver]
	move o2,[makstr /-1/]
	camn o2,[$oldest]
	move o2,[makstr /-2/]
nmsvrc:	call stconc
;done
nmsdon:	subi q,1
	ret1


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; USER-HOMEDIR-PATHNAME
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

homdir:	skipa			;with 0 args, we're OK
	 jrst [err /Can't find home directory on other machines/]
	seto nil1,		;current job
	hrroi w2,w4		;put 1 word into W4
	movei w3,.jilno		;logged in directory
	getji
	 erjmp retnil
	hrroi nil1,filnam	;put it here as string
	move w2,w4		;dir number
	dirst
	 erjmp retnil
	move w4,[object ty%sp5,<fnaml*5>] ;set maximum
	movem w4,filnhe
	move o1,[object ty%cst,<codsec,,filnhe>] ;make a string
	setzb o2,o3		;whole string
	move o4,[%T]		;stop at null, without predjudice
	call prsnam		;returns pathname in O1
	push q,o1
	call sphost		;get host
	pop q,o2		;get back pathname
	movem o1,pt%hst(o2)	;and put in host
	move o1,o2		;now return it
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  TRUENAME
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

trunam:	xtype o1		;see what they gave us
	cain w2,ty%xch		;if channel
	 jrst truchn		;just use it
;here if not a channel - convert to a string and then look up
;the file
trunm0:	call namstr		;return string in O1
	call mflnam		;put name in FILNAM
	movsi nil1,(gj%sht\gj%old) ;look it up
	hrroi w2,filnam
	gtjfn
	 erjmp opfer0		;if fails, give official error
	push p,nil1		;save JFN
	call trujfn		;create true name for JFN in NIL1
	pop p,nil1		;get back JFN to release it
	rljfn
	 erjmp .+1
	setz nil1,
	iret

;here if we have a channel
truchn:	skipg ch%jfn(o1)	;if we have a real JFN in the channel
	jrst trunm0		;no, get name it was opened with
	hrrz nil1,ch%jfn(o1)	;yes, get the JFN
	caie nil1,.priin	;can't use jfns on priin or priou
	 cain nil1,.priou
	  jrst trunm0
	jrst trujfn		;and get the name from it

;TRUJFN - common subroutine for creating a TRUENAME from a JFN in NIL1
trujfn:	hrrz w2,nil1
	hrroi nil1,filnam	;put full file name here
	move w3,[111110,,1]	;whole file spec
	jfns
;rather than count the string, we just say it takes up the whole
; buffer.  We then tell parse-namestring not to worry about junk at
; then end.
	move w4,[object ty%sp5,<fnaml*5>] ;assume string is full length
	movem w4,filnhe
	move o1,[object ty%cst,<codsec,,filnhe>] ;now have Lisp string
	setzb o2,o3		;use whole string
	move o4,[%T]		;allow junk at end
	setz nil1,
	call prsnam	;create pathname from that string
;;;[Victor] Return host as well (this is the best we can to until we hack nets)
	push q,o1
	call sphost		;get host
	pop q,o2		;get back pathname
	movem o1,pt%hst(o2)	;and put in host
	move o1,o2		;now return it
;;;[Victor] End addition
	ret1			;that's it, folks

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  PROBE-FILE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

profil:	xtype o1		;see what they gave us
	cain w2,ty%xch		;if channel
	 jrst truchn		;just use truname
;here if not a channel - convert to a string and then look up
;the file
	call namstr		;return string in O1
	call mflnam		;put name in FILNAM
	movsi nil1,(gj%sht\gj%old) ;look it up
	hrroi w2,filnam
	gtjfn
	 erjmp [move o1,nil	;if it isn't there, return NIL
		jrst proflx]
	push p,nil1		;save JFN
	call trujfn		;create true name for JFN in NIL1
	pop p,nil1		;get back JFN to release it
proflx:	rljfn
	 erjmp .+1
	setz nil1,
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  RENAME-FILE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

rnamef:	xtype o1
	caie w2,ty%xch		;special treatment for channels
	jrst rnamf1
	skipg w2,ch%jfn(o1)	;open on files
	jrst rnamf1
	caie w2,.priin
	 cain w2,.priout	;make sure it is a real JFN
	  jrst rnamf1
;here if we have a channel open on a file
	push q,o1		;save old file name
	push q,o2		;save new file name
	call trunam
	push q,o1		;save old true name
;-2: old file - a channel
;-1: new file name - eventually will be a pathname
; 0: original true name - a string
;derive the new name
	move o1,-1(q)		;use specified name
	move o2,-2(q)		;and old name as defaults
	fncall [%MRGNAM],2	;merge them
	movem o1,-1(q)		;this is the real new name
	call namstr		;have to make it a string
	call mflnam		;put name in FILNAM
	movsi nil1,(gj%sht+gj%fou) ;now look it up
	hrroi w2,filnam
	gtjfn
	 erjmp opfer0		;errors are fatal
	push p,nil1		;save JFN
	move o1,-2(q)		;get old file
	push p,ch%jfn(o1)	;save old JFN
	move o2,[inum 400000]	;say keep the jfn
	setz nil1,
	call closef+1		;close the file
	pop p,nil1		;old jfn
	tlz nil1,777777		;clear flags
	move w2,(p)		;new jfn
	rnamf
	 erjmp clser1		;close new jfn and print error
	move nil1,w2		;get new jfn into place for trunm1
	call trujfn		;now have new true name
	pop p,nil1		;get new jfn again
	rljfn			;release it
	 erjmp .+1
	move o3,o1		;get new truename as 3rd return
	pop q,o2		;original truename as 2nd return
	pop q,o1		;new file name as 1st return
	pop q,o4		;channel
	movem o1,ch%dat(o4)	;save as current file name for channel
	setz nil1,
	ret3			;3 returns

;this version of RENAME-FILE is when we are not working with an channel
rnamf1:	push q,o1		;save original name
	push q,o2		;save new file name
	call namstr		;return string in O1
	call mflnam		;put name in FILNAM
	movsi nil1,(gj%sht\gj%old) ;look it up
	hrroi w2,filnam
	gtjfn
	 erjmp opfer0		;if fails, give official error
	push p,nil1		;save old JFN
	call trujfn		;get true name, needed as return value
	push q,o1		;save it
;-2: original file name; will become new true name
;-1: new file name
; 0: original true name
;now derive the name name
	move o1,-1(q)		;new name
	move o2,-2(q)		;original name, for defaults
	fncall [%MRGNAM],2
	movem o1,-1(q)		;save as final new name
	call namstr		;return string in O1
	call mflnam		;put name in FILNAM
	movsi nil1,(gj%sht\gj%fou) ;look it up
	hrroi w2,filnam
	gtjfn
	 erjmp clser1		;close one file and do error
	push p,nil1		;save new JFN
	call trujfn		;get true name, needed as return value
	movem o1,-2(q)		;save as new true name
	pop p,w2		;new JFN
	pop p,nil1		;old JFN
	rnamf
	 erjmp clser2		;close both files and do error
	move nil1,w2
	rljfn			;don't need the new JFN any more
	 erjmp .+1
	pop q,o2		;original true name
	pop q,o1		;new file name
	pop q,o3		;new true name
	setz nil1,
	ret3			;returning 3 values

clser2:	pop p,nil1
	rljfn
	 erjmp .+1
clser1:	pop p,nil1
	rljfn
	 erjmp .+1
	jrst opfer0

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  DELETE-FILE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

deletf:	xtype o1
	caie w2,ty%xch		;special treatment for channels
	jrst dletf1
	skipg w2,ch%jfn(o1)	;open on files
	jrst dletf1
	caie w2,.priin
	 cain w2,.priout	;make sure it is a real JFN
	  jrst dletf1
;here if we have a channel open on a file
	push p,ch%jfn(o1)	;save old JFN
	move o2,[inum 400000]	;say keep the jfn
	setz nil1,
	call closef+1		;close the file
	pop p,nil1		;now actually delete it
	tlz nil1,777777		;clear flag bits
	delf
	 erjmp [err /Unable to delete file/]
	setz nil1,
	jrst rett

;here if we just have a file name
dletf1:	call namstr		;return string in O1
	call mflnam		;put name in FILNAM
	movsi nil1,(gj%sht\gj%old) ;look it up
	hrroi w2,filnam
	gtjfn
	 erjmp opfer0		;if fails, give official error
	delf
	 erjmp opfer0
	setz nil1,
	jrst rett

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; DIRECTORY
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

direct:	jrst [	move o1,[makstr /*.*.*/] ;default to wildcard
		jrst dirct0]
	move o2,[makstr /*.*.*/] ;default to wildcard
	move o3,[$WILD]
	fncall [%MRGNAM],3
	call namstr		;return string in O1
dirct0:	call mflnam		;put name in FILNAM
	movsi nil1,(gj%sht\gj%old\gj%ifg\gj%flg) ;look it up
	hrroi w2,filnam
	gtjfn
	 erjmp dircte		;[Victor,Fook]
				;if fails, check whether to give official error
;	 erjmp [setzb nil1,o1 ? ret1]	;no files, rtn nil
	push p,nil1		;save indexable file handle
	push q,nil		;list header
	push q,nil
	xmovei w2,-1(q)		;pointer to end
	tlo w2,(object(ty%ccn,0))
	push q,w2
;loop as long as there are files
dirctl:	hrrz nil1,(p)		;JFN
	call trujfn		;make pathname for it
	docons o1,o1,nil	;make new cell for list
	move o2,(q)		;current end
	dorpd o2,o1		;link this to it
	movem o1,(q)		;and save as new end
	move nil1,(p)		;indexable file handle
	gnjfn
	 jrst dirctx		;end of list
	jrst dirctl
;end of list
dirctx:	move o1,-1(q)		;head of list
	subi q,3		;clean up Q
	subi p,1
	setz nil1,
	ret1

;[Victor,Fook] check for "real" error 
dircte:	movei nil1,.fhslf
	geter			;Get last error
	hrrzs nil1
	cain nil1,GJFX3		;No more JFNs?
	 jrst opfer0		;OK to barf
	movem nil,o1		;Otherwise, just return NIL
	setz nil1,
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  FILJFN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;filjfn - object in O1.  Returns JFN in NIL1, T in O2 if we should
;  release the JFN afterwards
filjfn:	xtype o1
	caie w2,ty%xch		;special treatment for channels
	jrst filjf1
	skipg w2,ch%jfn(o1)	;open on files
	jrst filjf1
	caie w2,.priin
	 cain w2,.priout	;make sure it is a real JFN
	  jrst filjf1
;here if we have a channel
	hrrz nil1,ch%jfn(o1)	;JFN
	setz o2,		;don't release JFN
	iret

filjf1:	call namstr		;return string in O1
	call mflnam		;put name in FILNAM
	movsi nil1,(gj%sht\gj%old) ;look it up
	hrroi w2,filnam
	gtjfn
	 erjmp opfer0		;if fails, give official error
	move o2,[%T]		;should release at the end
	iret

;;;;;;;;;;; error routine appropriate for this

filje2:	hrrz nil1,w2
filjfe:	jumpn o2,filjec
;here if it was already open, just print error from JFN
	hrrz w2,nil1		;get jfn in right place
	hrroi nil1,filnam	;put full file name here
	move w3,[111110,,1]	;whole file spec
	jfns
	move w4,[object ty%sp5,<fnaml*5>] ;assume string is full length
	movem w4,filnhe
	jrst opfer0

;here if we opened it.  Close it, then do error
filjec:	rljfn
	jrst opfer0

;;;;;;;;;;; routine to return NIL

filrnl:	jumpe o2,retnil
;here if we need to close it first
	rljfn
	 erjmp .+1
	jrst retnil

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  FILE-WRITE-DATE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

wrtdat:	call filjfn
	move w2,[1,,.fbwrt]
	movei w3,w4
	gtfdb
	 erjmp filrnl		;return nil
	skipe o2		;if should release
	 rljfn			;do so
	  erjmp .+1
	setz nil1,
	move w2,w4
	jrst cltime

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  FILE-AUTHOR
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

wrtaut:	call filjfn
	hrroi w2,gjbuf
	gfust
	 erjmp filrnl
	idpb nil,nil1
	jrst buf2st

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  FILE-LENGTH
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

fillen:	xtype o1
	caie w2,ty%xch		;is it really a channel?
	 jrst [err1 o1,/FILE-LENGTH must take a stream open on a file: ~S/]
	move w2,ch%dsp(o1)	;get dispatch vector
	call @ch%siz(w2)
	 jrst retnil		;can't find it - return NIL
	jrst ret1nt		;return as integer

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  Various restart addresses
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;internal restart - here to restart clearing typeahead
restac:	call clrin
	jrst restar

;like RESTAC but leaves .UNWPRO alone
restc1:	call clrin
	jrst restr1

;special start for sharable section
sstart:	movem o2,shrfil		;save JFN of share file

;external restart, i.e. used by START command
rstart:	cis			;clear any interrupts, since this may
				;have been done from interrupt level if
				;he did ^C
	setzm crit		;not in critical section
;there is something really odd about the EXEC, such that sometimes
;our CCOC word gets reset when we ^C and start.  So put it back the
;way we last left it.
	movei nil1,.priin
	rfcoc
	move w4,w2		;save current tab setting
	dmove w2,trmcoc
	trz w2,600000		;use existing tab setting instead of saved
	andi w4,600000
	ior w2,w4
	skipe w3		;no zero coc words, please
	sfcoc
	setzb nil,nil1
	skipn cncsav		;AC's saved by ^C?
	jrst restar		;no
	move 17,[cncacs,,0]	;this may be after a SAVE/RUN - restore AC's
	blt 17,17
;internal restart - here to restart without clearing typeahead
restar:
;like RESTAR but leaves .UNWPRO alone
restr1:	setzb nil1,nil		;here to leave .unwpro alone
	setzb o1,o2		;make sure AC's are valid
	setzb o3,o4
	setzb o5,o6
	seto n,
	move p,savep
	move q,saveq
	move w2,[basemv]
	movem w2,mvp
	move w2,savesp		;get known valid SP
	xor w2,sp		;compare with current
	tlne w2,1		;if different parity
	subi sp,1		;then adjust to valid
	move w2,savesp
	call cunbn1		;unbind, closing files passed
	move sp,savesp
tstshr:	jrst toplev
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Basic List functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	; CAR, CDR, CONS and of course the garbage collector
	; code in this section knows about the format of cons cells
	; (a cons cell is two consecutive words containing values)
	; the garbage collector knows a little bit about everything,
	; so always check it when any format is changed.

;;TY%CON
CAR:	scons o1		;make sure it is cons cell
	jumpn o1,[cerr1 o1,/Give a real cons cell./,/CAR of non-CONS: ~S/
		  jrst car]
	move o1,(o1)		; car of a cell is the first word
	ret1

notcns:	err1 o1,/Attempt to take CAR or CDR of non-CONS: ~S/

;;TY%CON
CDR:	scons o1		;make sure it is a cons cell
	jumpn o1,[cerr1 o1,/Give a real cons cell./,/CDR of non-CONS: ~S/
		  jrst cdr]
	move o1,1(o1)		; cdr of a cell is the second word
	ret1

;;TY%CON
rplaca:	chcons o1		;better be a cons cell
	movem o2,(o1)
	ret1

;;TY%CON
define dorpa(x,y)
	movem y,(x)
	termin

;;TY%CON
rplacd:	chcons o1		;better be a cons cell
	movem o2,1(o1)		;put it in cdr
	ret1

;;ASSQ - search a list of pairs looking for one with a given CAR
;o2 - list, o1 - target
;O6 is assumed to be preserved 
  ;loop until list runs out
assq:	jumpe o2,retnil		;if list empty, return nil
	docar o4,o2		;o1 _ caar of list
	docar o5,o4
	camn o5,o1		;if EQ target
	jrst assqf		;found it, yes
	docdr o2,o2		;no, advance down list
	jrst assq
assqf:	move o1,o4		;return car
	ret1


;;IASSQ - search a list of pairs looking for one with a given CAR
;This is an internal function, which uses lots of AC's in a way
;convenient in parts of the interpreter.  It is meant to be used
;to search %VENV%, etc.

;o2 - list, o1 - target
;returns tail of list in O2 or NIL, last pair searched in O4
;O1, O3, O6 unchanged
;garbages O5
  ;loop until list runs out
iassq:	jumpe o2,cpopj		;if list empty, return nil
	docar o4,o2		;o1 _ caar of list
	docar o5,o4
	camn o5,o1		;if EQ target
	iret			;found it, done
	docdr o2,o2		;no, advance down list
	jrst iassq		;(you answer me?)

retnl1:	subi q,1
retnil: setzb o1,nil1
ident:	ret1

rett1:	subi q,1
rett:	move o1,[%t]
	ret1


;NOT
not:	jumpn o1,retnil
	move o1,[%T]
	ret1

;TY%CON
CONS:	caml free,lastl		; make sure we have space 
	 call sgc		; garbage collect if no new cells
	push free,o1		; set up car
	move o1,free		; make address into cons cell
	tlo o1,(object(ty%con,0))
	push free,o2		; and cdr
	ret1
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Type tests
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;atom
atomp:	scons o1
	skipa o1,[%T]		;if not cons, is atom
	move o1,nil
	ret1

;listp
listp:	jumpe o1,rett		;NIL is a list
consp:	scons o1
	jrst retnil
	jrst rett

;symbolp
symbp:	jumpe o1,rett
	satom o1
	jrst retnil
	jrst rett

;keywordp
keywp:	ssymb o1
	jrst retnil
	move o2,at%pkg(o1)	;get package
	came o2,@[.KEYPACKAGE]	;see if keyword
	jrst retnil		;not
	jrst rett		;yes

;isstr
; skip if O1 is a string
; changes only W2
isstr:	gettyp o1
	caie w2,ty%str		;if simple string
	 cain w2,ty%cst
	  jrst rskp		;it is, skip
	caie w2,ty%arh		;if array header
	 iret			;not, done
	xtype ah%dat(o1)	;yes, now look at data vector
	caie w2,ty%xst		;it is string?
	 iret			;no
rskp:	aos (p)			;yes, skip	
	iret

;stringp
strngp:	call isstr
	jrst retnil
	jrst rett

;characterp
chrp:	gettyp o1
	caie w2,ty%chr
	jrst retnil
	jrst rett

;fixnump
fxnump:	skpin o1
	jrst retnil
	jrst rett

;streamp
strmp:	xtype o1
	caie w2,ty%xch
	jrst retnil
	jrst rett

;structurep
strucp:	gettyp o1
	caie w2,ty%vec
	jrst retnil
	move w2,-2(o1)
	came w2,[inum st%str]
	jrst retnil
	jrst rett

;simple-string-p
simstr:	xtype o1
	caie w2,ty%xst
	jrst retnil
	jrst rett

;simple-bit-vector-p
simbvc:	gettyp o1
	caie w2,ty%bvc
	jrst retnil
	jrst rett

;simple-vector-p
simvec:	gettyp o1	;;TYPES
	move o1,simvcs(w2)
	ret1

simvcs:	nil ? nil ? nil ? nil ? %t  ? %t  ? nil ? nil ;0 - 7
	nil ? nil ? %t  ? nil ? nil ? nil ? %t  ? %t  ;10 - 17
repeat 20,[nil
	  ]

;vectorp
vectrp:	gettyp o1
	skipe simvcs(w2)
	jrst rett	;simple vector is vector
	caie w2,ty%arh	;else must be array
	jrst retnil
	move w2,-1(o1)	;length of header
	came w2,[inum 5] ;5 means one dimension
	jrst retnil
	jrst rett

;bit-vector-p
bitvcp:	gettyp o1
	cain w2,ty%bvc		;if simple bit vector
	jrst rett		;then succeed
	caie w2,ty%arh		;if array header
	 jrst retnil		;not, done
	gettyp ah%dat(o1)	;yes, now look at data vector
	caie w2,ty%bvc		;it is bit vector?
	 jrst retnil
	jrst rett

;integerp
intp:	skpint o1
	jrst retnil
	jrst rett

;rationalp
ratnlp:	skpnnt o1
	jrst rett		;if integer
	xtype o1
	caie w2,ty%xrt		;or ratio
	jrst retnil
	jrst rett

;floatp
floatp:	gettyp o1
	cail w2,ty%flo
	caile w2,ty%hpf
	jrst retnil
	jrst rett

;short-floatp
shtflp:	gettyp o1
	cail w2,ty%lnf
	caile w2,ty%hpf
	jrst retnil
	jrst rett

;long-floatp
lngflp:	xtype o1
	caie w2,ty%xfl
	jrst retnil
	jrst rett

;arrayp
arrayp:	gettyp o1
	skipe simvcs(w2)
	jrst rett	;simple vector is array
	caie w2,ty%arh	;else must be array
	jrst retnil
	jrst rett

;commonp
comonp:	call sptype	;sptype returns 0 for illegal types
	trnn o1,777777
	jrst retnil
	jrst rett

;functionp
;We read the manual as saying that this must work for APPLY,
;so macros and fexpr's do not apply.
functp:	snatom o1		;symbols are always OK
	 jrst rett		;though it seems odd to show NIL as OK
	scons o1		;else should be a function object
	 jrst retnil
	doboth o1,o1
	came o1,[%SUBR]
	 camn o1,[%LAMBDA]
	  jrst rett		;simple cases
	camn o1,[%LEXCLO]
	 jrst rett		;not simple, but legal
	jrst retnil

;compiled-function-p
;there is some ambiguity about compiled macros and special forms
; we read the manual as saying that this is any compiled object,
; which would include those cases.
comfnp:	scons o1
	 jrst retnil
	doboth o1,o1
	camn o1,[%SUBR]
	 jrst rett		;this is the simple one
	came o1,[%MACRO]	;=*=
	 camn o1,[%FEXPR]
	  jrst .+2
	   jrst retnil		;none of these, done
	docar o1,o2		;now had better be primitive kind
	camn o1,[%SUBR]
	 jrst rett		;not simple, but legal
	jrst retnil

;sequencep
seqp:	sncons			;list or vector
	jrst rett
	jrst vectrp

;bignump
bignmp:	xtype o1
	caie w2,ty%xbg
	jrst retnil
	jrst rett

;bitp
bitp:	came o1,[inum 0]
	 camn o1,[inum 1]
	  jrst rett
	jrst retnil

;ratiop
ratiop:	xtype o1
	caie w2,ty%xrt
	jrst retnil
	jrst rett


	

;%sp-type
;convert from ELISP to Spice Lisp type code.
sptype:	gettyp o1
	move o1,[inum 11.	;atom
		inum 11.	;constant atom
		inum 12.	;cons
		inum 12.	;constant cons
		inum 3.		;string
		inum 3.		;constant string
		inum 13.	;I/O channel
		inum 13.	;constant channel
		inum 14.	;hash table
		inum 14.	;other kind of hash table
		inum 8.		;vector
		inum 20.	;character
		inum 10.	;array header
		inum 0		;special
		inum 2		;integer vector
		inum 1		;bit vector
		inum 5		;long float
		inum 5		;long float
		inum 19.	;negative float
		inum 19.	;negative float
		inum 18.	;non-neg float
		inum 18.	;non-neg float
		inum 7.		;ratio
		inum 7.		;ratio
		inum 0		;skip
		inum 0		;skip
		inum 4		;bignum
		inum 4		;bignum
		inum 17.	;neg fixnum
		inum 17.	;neg fixnum
		inum 16.	;non-neg fixnum
		inum 16.](w2)	;non-neg fixnum
	ret1
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Equality predicates
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;EQ - fast compare
eq:	camn o1,o2
	jrst rett
	jrst retnil

; EQL - EQ, plus if numbers of same type and same value, if same char
;	note that char's are EQ, so we only need to test for numbers
eql:	camn o1,o2
	jrst rett		;if EQ then true
	xtypea w2,o1		;must be of same type
	xtypea w3,o2		;(xtype allows FOOs to be equalt
	camn w2,w3		; to constant FOOs)
eqln:	 caige w2,ty%xfl	;must be EQ if not numbers
	  jrst retnil		; enter eqln from inside equalt
	xct .+1-ty%xfl(w2)	;;TYPES
	jrst xeqflo		;long flons
	jrst retnil	;[Victor] jrst xeqifl		;iflons
	jrst retnil	;[Victor] jrst xeqifl		;iflons
	jrst xeqrat		;ratios
	jrst notnum		;complex
	jrst xeqbig		;bignums
	jrst retnil		;inums 
	jrst retnil		;inums

;EQUAL - 
;  number, char - as EQL
;  symbols - EQ
;  CONS: recursive
;  array - EQ, except strings and bit-vectors element by element
;     [with upper and lower case being different]
;  pathnames - components must be equivalent [we don't implement
;     that at the moment, except more or less by chance]

equal:	camn o1,o2
	jrst rett		;if EQ then true
;in general, types must match, but complex arrays can match simple
;arrays.  So we look for array headers and treat them as the type
;of their components, for purposes of matching.
	getypa w2,o1
	cain w2,ty%arh		;in case of array, use the base type
	 jrst [	move o3,ah%dat(o1)
		xtypea w2,o3
		jrst .+2]
	xtypea w2,o1
	getypa w3,o2
	cain w3,ty%arh
	 jrst [	move o3,ah%dat(o2)
		xtypea w3,o3
		jrst .+2]
	xtypea w3,o2
;now we are ready to dispatch on types
	came w2,w3		;types must match
	 jrst retnil
	xct .+1(w2)		;;TYPES
	jrst retnil		;atoms must be EQ
	jrst eqlcon		;check CONS recusively
	jrst eqlstr		;special string routine
	jrst retnil		;I/O channels must be EQ
	jrst retnil		;hash tables must be EQ
	jrst retnil		;vectors and chars must be EQ
	jrst retnil		;arrays and spc's must be EQ
	jrst eqlbvc		;integer and bit vector routine
	jrst xeqflo		;long flons
	jrst retnil	;[Victor] jrst xeqifl		;iflons
	jrst retnil	;[Victor] jrst xeqifl		;iflons
	jrst xeqrat		;ratios
	jrst retnil		;complex
	jrst xeqbig		;bignums
	jrst retnil		;inums 
	jrst retnil		;inums

;EQUAL for CONS
;recursively compare CAR's and CDR's
eqlcon:	pushcdr q,o1		;save cdr's for later
	pushcdr q,o2
	docar o1,o1		;compare car's
	docar o2,o2
	call equal		;recursively
	jumpe o1,eqfai		;if failed, prune stack and fail
	pop q,o2
	pop q,o1
	jrst equal		;else loop to compare cdr's
eqfai:	subi q,2
	move o1,nil
	ret1

;string - this is complicated by the fact that they may not be
;simple strings.  
eqlstr:	movei o5,1		;[Victor] bit to ignore in wd. comparison
;	move o4,[440740,,0]

;the rest of this code is shared with bit vectors

;first look at O1
eqlstc:	gettyp o1
	;; [Victor] Start patched area
	caie w2,ty%arh		;if array header, things get complex
	jrst eqlsf		;if not, possibility of speed
	move w2,ah%dsp(o1)
	move w3,ah%fil(o1)
	move o1,ah%dat(o1)  ;use data object from array
eqlst1:	tlz w2,770000
	tlz w3,770000

;now look at O2
	getypa w4,o2
	cain w4,ty%arh		;if array header, things get complex
	 jrst [	move w4,ah%dsp(o2)
		move o3,ah%fil(o2)
		move o2,ah%dat(o2)  ;use data object from array
		jrst eqlst2]
	movei w4,0		;start at beginning
	move o3,(o2)		;use whole thing
eqlst2:	tlz w4,770000
	tlz o3,770000
	move o4,[ 440140,,0	;[Victor] 
	          440740,,0](o5)	;[Victor] get bit/byte ptr
;w2 - start of 1
;w3 - count of 1
;w4 - start of 2
;o3 - count of 2
;o4 - 440740,,0 [or 440140,,0 for bit vector]
	came w3,o3		;count better be the same
	jrst eqlnil
	xmovei o5,1(o1)		;o4/o5 is now beginning of data obj
	adjbp w2,o4		;adjust be start
	xmovei o5,1(o2)		;same for second object
	adjbp w4,o4
	jumpe o3,eqlt		;if get to the end, match
eqlstl:	ildb o2,w2		;char from first string
	ildb o4,w4		;char from second string
	came o2,o4
	jrst eqlnil		;fail
	sojg o3,eqlstl		;if more char's loop

;here to return T
eqlt:	setzb o2,o3
	setzb o4,o5
	move o1,[%T]
	ret1

;;;[Victor] New routine
eqlsf:	move w3,(o1)		;count of 1st object
	getypa w4,o2
	cain w4,ty%arh		;if array header, things get complex
	 jrst [ movei w2,0
	        jrst eqlst1]
	move o3,(o2)		;else use fast (word-at-a-time) compare
	tlz o3,770000
	tlz w3,770000
	came o3,w3		;same length?
	 jrst eqlnil		;if not, lose
	move o4,[ 44
	           5](o5)	;entries per word
	xmovei w2,1(o1)		;beginning of 1st object
	xmovei w4,1(o2)		;beginning of 2nd object
eqlsfl:	jumpe o3,eqlt		;all match, win
	sub o3,o4		;deduct items in this wd
	move o2,(w2)		;word from 1st object
	xor o2,(w4)		;vs. word from 2nd object
	jumpl o3,eqlsfb		;if last word
	andcm o2,o5		;maybe mask off garbage bit
	jumpn o2,eqlnil		;if disagree, fail
	addi w2,1
	aoja w4,eqlsfl

eqlsfb:	add o3,o4		;how many items left
	skipe o5
	imuli o3,7		;make how many bits left
	movsi o5,400000
	movns o3
	ash o5,1(o3)		;form the mask
	and o2,o5		;mask off trash
	jumpe o2,eqlt		;if match, win

;here to return NIL
eqlnil:	setzb o3,o2		;o1 - o4 have junk, so clear all
	setzb o5,o4
	jrst retnil

;bit vector - this is quite similar to the string case
;we have to check the type codes, because the main body used
;XTYPE.  That would allow integer vectors also.
eqlbvc:	gettyp o1
	cain w2,ty%bvc
	 jrst retnil
	gettyp o2
	cain w2,ty%bvc
	 jrst retnil
	movei o5,0		;[Victor] No bits to ignore when comparing wds
;	move o4,[440140,,0]	;byte pointer for one bit
	jrst eqlstc		;join common code
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Functions on atoms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;TY%ATM
;GET - look up property on atom's property list
;o1 - the atom, o2 - the property, o3 - default value [&opt]
;O6 is assumed to be preserved 
xget:	move o3,nil		;entry for 2 args
	skipn o1
	move o1,[%NIL]		;use pseudo-symbol for NIL
	satom o1
	jrst [err1 o1,/Argument to GET must be a symbol: ~S/]
	move o1,at%pro(o1)	;the property list
	jumpe o1,xgetdf		;if nothing left, we failed
xgetl:	docar o4,o1
	camn o4,o2		;is CAR what we want?
	jrst xgets		;yes - success
	docdr o1,o1		;no - double cdr
	docdr o1,o1
	jumpn o1,xgetl
	jrst xgetdf		;nothing left, failed
  ;if we find it, what we found is a pair.  The CDR is the value part.
xgets:	docdr o1,o1		;get the value
	docar o1,o1
	ret1

xgetdf:	move o1,o3		;failed, return default
	ret1

;;TY%ATM
;%put - atom, prop, value
;o1 - atom, o2 - prop, o3 - value
putp:	skipn o1
	move o1,[%NIL]		;use pseudo-atom for NIL
	satom o1
	jrst [err1 o1,/Attempt to PUTPROP something that is not an atom: ~S/]
	move o4,at%pro(o1)	;o4 - property list tail
  ;now we search the plist to see if the prop is there already
putpl:	jumpe o4,putpno		;if run out, not there
	docar o5,o4		;o5 _ car of list
	camn o5,o2		;if EQ target
	jrst putpys		;found it, yes
	docdr o4,o4		;no, advance down list
	docdr o4,o4
	jumpn o4,putpl
;not found - add it at beginning
putpno:	move o4,at%pro(o1)	;old property list
	docons o5,o3,o4		;(value --orig--)
	docons o4,o2,o5		;(prop value --orig--)
	movem o4,at%pro(o1)	;new property list
	move o1,o3		;return the value
	ret1
;found - just change the value
putpys:	docdr o4,o4
	dorpa o4,o3
	move o1,o3		;return the value
	ret1

;;TY%ATM
;remprop - atom, prop
;o1 - atom, o2 - prop
remp:	skipn o1
	move o1,[%NIL]		;use pseudo-atom for NIL
	satom o1
	jrst [err1 o1,/Argument to REMPROP is not a symbol: ~S/]	
  ;cdr of the atom header is really a pointer to the plist
  ;we use this as a kludge to regard the atom header itself as
  ;the previous cell in the property list
  ;now we search the plist to see if the prop is there already
	;o1 - previous cell in plist
	;o3 - this cell
rempl:	docdr o3,o1		;get next cell
	jumpe o3,retnil		;if none, failed
	docar o4,o3		;o4 - the prop
	camn o4,o2		;if the same, we have it
	jrst rempys
	docdr o1,o3		;else advance
	jrst rempl
rempys:	docdr o3,o3		;get cdr to our cell
	docdr o3,o3
	dorpd o1,o3		;put it after previous
	jrst rett		;and return true

;;SYMBOL-NAME - return the pname of an atom
;o1 - symbol
symnam:	skipn o1
	move o1,[%NIL]		;use pseudo-symbol for NIL
	satom o1
	jrst [err1 o1,/SYMBOL-NAME called on non-symbol ~S/]
	move o1,at%pna(o1)
	ret1


;;SYMBOL-PACKAGE - return the package cell
;o1 - symbol
sympkg:	skipn o1
	move o1,[%NIL]		;use pseudo-symbol for NIL
	satom o1
	jrst [err1 o1,/SYMBOL-PACKAGE called on non-symbol ~S/]
	move o1,at%pkg(o1)
	ret1

;;SYMBOL-PLIST - return the plist of an atom
;o1 - symbol
symprp:	skipn o1
	move o1,[%NIL]		;use pseudo-symbol for NIL
	satom o1
	jrst [err1 o1,/SYMBOL-PLIST called on non-symbol ~S/]
	move o1,at%pro(o1)
	ret1

;;%SET-PLIST
;o1 - symbol, o2 - plist
ssympr:	skipn o1
	move o1,[%NIL]
	satom o1
	jrst [err1 o1,/%SET-PLIST called on non-symbol ~S/]
	movem o2,at%pro(o1)
	move o1,o2
	ret1

;SET
;o1 - symbol, O2 - value
set:	ssymb o1
	jrst [err1 o1,/SET called on non-symbol ~S/]
	movem o2,at%val(o1)
	move o1,o2
	ret1

;;SYMBOL-VALUE 
;this is defined as checking only global bindings
symval:	jumpe o1,retnil
	getgval o2,o1		;didn't, so try global value
	camn o2,[%.UNBOUND]
	jrst [err1 o1,/SYMBOL-VALUE called on unbound variable: ~S/]
	move o1,o2
	ret1
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Functions on arrays of various kinds
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Functions to allocate them
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;%sp-alloc-array (length)
;create array header
allarh:	addi o1,4
	push free,o1
	move w2,o1	
	getnum w2
	xmovei o1,1(free)
	tlo o1,(object ty%arh,0)
	add free,w2
	caml free,lastl
	 call sgc
	ret1

;%sp-alloc-u-vector (length access)
;create simple unboxed vector (elisp array)
;NB: not initialized to anything in particular
;skip pointer, access type [small integer], #entries, data ...
;the pointer is to the first word of data
;max	code	bits	/wd
;2	0	1	32
;4	1	2	16
;16	2	4	8
;512	3	8	4
;256K	4	16	2
;	5	32	1
allivc:	camn o2,[inum 0]		;access 0 is really
	jrst allbvc			;a bit vector
	push free,[object ty%spc,0]
	push free,o2
	push free,o1
	move w2,o1
	getnum w2
	getnum o2
	rot w2,-5(o2)		;full words to right end
	tlze w2,760000		;bits would be here
	addi w2,1		;round up - now have words needed
	xmovei o1,1(free)	;make pointer to return
	tlo o1,(object ty%ivc,0)
	add free,w2
	addi w2,2		;skip pointer must also skip header
	iorm w2,-3(o1)
	setz o2,		;make this legal
	caml free,lastl
	 call sgc
	ret1

allbvc:	push free,[object ty%s36,0]
	move w2,o1
	xmovei o1,0(free)
	tlo o1,(object ty%bvc,0)
	getnum w2
	iorm w2,(free)		;finish skip pointer
	idivi w2,36.		;how many words?
	skipe w3		;if no remainder
	addi w2,1		;round up - now have words needed
	add free,w2
	caml free,lastl
	 call sgc
	ret1

;%sp-alloc-string (length)
;create simple string
allstr:	push free,[object ty%sp5,0]
	move w2,o1
	xmovei o1,0(free)
	tlo o1,(object ty%str,0)
	getnum w2
	iorm w2,(free)
	idivi w2,5
	skipe w3
	addi w2,1
	add free,w2
	caml free,lastl
	 call sgc
	ret1

;%sp-alloc-b-vector (length  initial-value)
allvec:	push free,[inum st%vec]
	push free,o1
	move w2,o1
	xmovei o1,1(free)
	tlo o1,(object ty%vec,0)
	getnum w2
	add free,w2
	jumpe w2,allvcx		;if length = 0, no init possible
	movem o2,(o1)		;else init first element
	sojle w2,allvcx		;if length = 1, that's all
	xmovei w3,(o1)		;else repeat this element
	xmovei w4,1(o1)
	xblt w2,
allvcx:	caml free,lastl
	 call sgc
	ret1

;;; internal entry pt for allocing a vec to be used as a closure var vector
alclvc:	push free,[inum st%vec]
	push free,w2
	xmovei w3,1(free)
	tlo w3,(object ty%vec,0)
	getnum w2
	add free,w2
	movem o6,(w3)		; init back pointer
	move w4,w3
	aos w4
	  sojle w2,alcv1	;fill in the rest with nil
	  setzm (w4)
	  aoja w4,.-2
alcv1:	camge free,lastl
	 iret
	push q,w2
	push q,o6
	caml free,lastl		;[Victor] Because of SGC's stupidness,
				;[Victor] returning at -1 to repeat the test
	call sgc
	pop q,o6
	pop q,w2
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; VECTOR - make a simple vector
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

vector:	move n,[inum 0]
	jrst vectrn
	move n,[inum 1]
	jrst vectrn
	move n,[inum 2]
	jrst vectrn
	move n,[inum 3]
	jrst vectrn
	move n,[inum 4]
	jrst vectrn
	move n,[inum 5]
	jrst vectrn
;here for more than 5
	move w2,n			;w2 will be the length as inum
	maknum w2
	push free,[inum st%vec]		;make prefix, subtype and length
	push free,w2
	dmovem o1,1(free)		;save the data
	dmovem o3,3(free)
	movem o5,5(free)
	xmovei o1,1(free)		;here will be the result
	tlo o1,(object ty%vec,0)
	add free,n			;advance free beyond this all
	xmovei w2,1(free)		;fill the junk in here
	subi n,5			;we have already handled 5 args
vectrl:	subi w2,1
	pop q,(w2)			;now copy it
	sojg n,vectrl
	caml free,lastl
	 call sgc
	ret1

;here when everything is in the ac's
vectrn:	push free,[inum st%vec]
	push free,n
	xmovei w2,1(free)		;save pointer to return
	movei w3,o1			;place to get data from
	posnum n
vectrm:	sojl n,vectrx			;any more entries?
	push free,(w3)			;yes, use it
	aoja w3,vectrm			;and advance for next time
vectrx:	move o1,w2			;thing to return
	tlo o1,(object ty%vec,0)
ckgcx:	caml free,lastl
	 call sgc
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; LIST-TO-VECTOR*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;at the moment, this is used only in bootstrap code, where it ignores
;the second (type code) argument.  Sometime we will make it understand
;what is going on.

lst2vc:	push free,[inum st%vec]		;normal vector
	push free,[inum 0]		;will be count
	move o3,o1			;more convenient to have list here
	xmovei o1,1(free)		;will return this
	tlo o1,(object ty%vec)
lst2vl:	scons o3			;any more?
	jrst ckgcx			;no, exit, with possible GC
	doboth o2,o3			;yes, object to O2, rest to O3
	push free,o2			;put it in vector
	aos -1(o1)			;count it
	jrst lst2vl			;and look for any more

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; String concatenation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;STCONCAT
stconc:	push q,o2		;we only have enough AC's to work with one
	push p,[0]		;-2(p) will be count
	push p,[440740,,0]	;-1(p) will be dest pointer
	xmovei w2,2(free)
	setzm (w2)		;clear first word of string
	push p,w2
	call getstr		;byte pointer to w2/3; count to w4
sconc1:	sojl w4,sconc2		;count down source string
	ildb nil1,w2
	aos -2(p)		;count up destination
	idpb nil1,-1(p)
	move nil1,(p)		;get address
	setzb nil1,1(nil1)	;clear next word, for low order bits
	jrst sconc1
sconc2:	pop q,o1		;second source
	call getstr		;byte pointer to w2/3; count to w4
sconc3:	sojl w4,sconc4		;count down source string
	ildb nil1,w2
	aos -2(p)		;count up destination
	idpb nil1,-1(p)
	move nil1,(p)		;get address
	setzb nil1,1(nil1)	;clear next word, for low order bits
	jrst sconc3
sconc4:	move w3,-2(p)		;length
	tlo w3,(object(ty%sp5,0)) ;special GC code
	push free,w3
	move o1,free
	tlo o1,(object(ty%str,0)) ;make o1 string ptr from addr of start 
	move free,(p)		;end of string
	subi p,3		;get rid of byte ptr on stack
	camle free,lastl	;see if went beyond end of space
	 call sgc		;yes
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Array access functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;AREF - full-scale general reference
;Does simple types directly.  Escapes to Lisp (%SP-AREF) for anything
;  involving a header.
;O1 - array, O2 - index, O3 ... more indices, but we don't handle that
aref:	movei w3,1 ? jrst arfcal	;no indices??
	movei w3,0 ? jrst aref1a	;one index
	movei w3,1 ? jrst aref1a	;two indices
	movei w3,2 ? jrst aref1a	;three indices
	movei w3,3 ? jrst aref1a	;four indices
	movei w3,6 ? jrst arfcal

arfcal:	fjcaln [%spref]

;this entry from %sp-aref, aref3j
aref1:  gettyp o1
	xct .+1(w2)	;;TYPES
	jrst notarr		; atom
	jrst notarr		;  constant atom
	jrst notarr		; cons
	jrst notarr		;  constant cons
	jrst schref		; string
	jrst schref		;  constant string
	jrst notarr		; channel
	jrst notarr		;  constant channel
	jrst notarr		; eq hash table
	jrst notarr		; other hash table
	jrst svcref		; vector
	jrst notarr		; character
	jrst [fncall [%spref],2 ? retn] ; array header
	jrst notarr		; special (block)
	jrst sarref		; integer vector
	jrst sbtref		; bit vector
	repeat 16., jrst notarr	; numbers

;this entry from aref
aref1a: gettyp o1
	xct .+1(w2)	;;TYPES
	jrst notarr		; atom
	jrst notarr		;  constant atom
	jrst notarr		; cons
	jrst notarr		;  constant cons
	jrst schreq		; string
	jrst schreq		;  constant string
	jrst notarr		; channel
	jrst notarr		;  constant channel
	jrst notarr		; eq hash table
	jrst notarr		; other hash table
	jrst svcreq		; vector
	jrst notarr		; character
	jrst aref2t(w3)		; array header
	jrst notarr		; special (block)
	jrst sarreq		; integer vector
	jrst sbtreq		; bit vector
	repeat 16., jrst notarr	; numbers

notarr:	err1 o1,/Attempt to do array indexing on object that is not an array: ~S/
arrbnd:	err1 o2,/Array index out of bounds: ~S/

;o1 - array; O2 - index
;index into a string
schreq: jumpn w3,areesc		;to call %sp-aref
schref: move w2,o2
	tlc w2,(<object ty%sp5,0>#<object ty%lpi,0>) ;turn into ty%sp5
	caml w2,[object ty%sp5,0] ;bounds check the reference
	 caml w2,(o1)
	  jrst arrbnd		;out of bounds
	tlz w2,770000		;get bare number
	idivi w2,5		;o2 - words; O3 - bytes
	add o1,w2
	ldb o1,[.bp 177_29.,1(o1)
		.bp 177_22.,1(o1)
		.bp 177_15.,1(o1)
		.bp 177_8.,1(o1)
		.bp 177_1.,1(o1)](w3)
	makchr o1
	ret1

;o1 - array; O2 - index
;index into a simple vector
svcreq: jumpn w3,areesc		;to call %sp-aref
svcref: caml o2,[inum 0]
	caml o2,-1(o1)
	jrst arrbnd
fvcref: tlz o1,770000		;do this first so no overflow trap
	add o1,o2
	move o1,(o1)
	ret1

sbtreq: jumpn w3,areesc		;to call %sp-aref
sbtref: move w2,o2
	tlc w2,(<object ty%s36,0>#<object ty%lpi,0>) ;turn into ty%s36
	caml w2,[object ty%s36,0] ;bounds check the reference
	 caml w2,(o1)
	  jrst arrbnd		;out of bounds
	tlz w2,770000		;get bare number
;the obvious thing to do here is an adjbp, but that is as slow as
;two divides.  This code should be much better.
	idivi w2,36.
	lsh w3,30.
;note that we end up with the number of bits in bits 1 to 5 of
;W3, which is where we want to be
	move w4,[430140,,0]	;one bit byte pointer, to first bit, adr in O1
	sub w4,w3		;adjust to right bit
	add o1,w2		;and right word
	xmovei o1,1(o1)
	ldb o1,w4
	maknum o1
	ret1

;o1 - array; O2 - index
;index into a simple integer array
sarreq: jumpn w3,areesc		;to call %sp-aref
sarref: caml o2,[inum 0] ;bounds check the reference
	 caml o2,-1(o1)
	  jrst arrbnd		;out of bounds
	move w2,o2
	tlz w2,770000		;get bare number
;the obvious thing to do here is an adjbp, but that is as slow as
;two divides.  This code should be much better.
	move w4,-2(o1)		;get access code
	setz w3,		;and initialize W3 for shifting into
	ashc w2,-5(w4)		;w2 - words; w3 - bytes in high order
	move w4,sartab(w4)	;byte pointer, to first byte, adr in O1
	sub w4,w3		;adjust to right bit
	add o1,w2		;and right word
	tlz o1,770000
	ldb o1,w4
	maknum o1
	ret1

;used by sarref, sarset
sartab: 370140,,0
	360240,,0
	340440,,0
	301040,,0
	202040,,0
	4040,,0

;to process header, dispatch on how many indices
aref2t: jrst aref1i
	jrst aref2i
	jrst aref3i
	jrst aref4i

;1-index header
aref1i: move w3,[inum 5]	;expected header length
	came w3,ah%hsz(o1)
	 jrst areess		;if wrong
	caml o2,[inum0]
	caml o2,ah%ub1(o1)
	jrst areess		;if out of bounds
	jrst aref3j

;2-index header
aref2i: add w3,[inum 5]		;make expected header length
	came w3,ah%hsz(o1)
	jrst areess		;if wrong
	camge o3,ah%ub1+1(o1)
	caml o2,ah%ub1(o1)
	jrst areess		;if bounds error
	sub o2,[inum0]
	jumpl o2,arees2
	camge o3,[inum0]
	jrst arees2
	move w2,ah%ub1+1(o1)
	tlz w2,770000
	imul o2,w2
	add o2,o3
	jrst aref3j

;3-index header
aref3i: add w3,[inum 5]		;make expected header length
	camn w3,ah%hsz(o1)
	caml o4,ah%ub1+2(o1)
	jrst areess		;if something wrong
	camge o3,ah%ub1+1(o1)
	caml o2,ah%ub1(o1)
	jrst areess		;if bounds error
	sub o2,[inum0]
	jumpl o2,arees2
	sub o3,[inum0]
	jumpl o3,arees3
	camge o4,[inum0]
	jrst arees3
	move w2,ah%ub1+1(o1)
	tlz w2,770000
	imul o2,w2
	add o2,o3
	move w2,ah%ub1+2(o1)
	tlz w2,770000
	imul o2,w2
	setz o3,		;keep it clean
	add o2,o4
aref3j: tlz o2,770000
	add o2,ah%dsp(o1)
	move o1,ah%dat(o1)	;get vector object
	jrst aref1

;4-index header
aref4i: add w3,[inum 5]		;make expected header size
	camn w3,ah%hsz(o1)
	caml o5,ah%ub1+3(o1)
	jrst areess		;if something wrong
	camge o4,ah%ub1+2(o1)
	caml o3,ah%ub1+1(o1)
	jrst areess		;if bounds error
	camge o2,ah%ub1(o1)
	camge o5,[inum0]
	jrst areess		;if bounds error
	sub o2,[inum0]
	jumpl o2,arees2
	sub o3,[inum0]
	jumpl o3,arees3
	sub o4,[inum0]
	jumpl o4,arees4
	move w2,ah%ub1+1(o1)
	tlz w2,770000
	imul o2,w2
	add o2,o3
	move w2,ah%ub1+2(o1)
	tlz w2,770000
	imul o2,w2
	add o2,o4
	move w2,ah%ub1+3(o1)
	tlz w2,770000
	imul o2,w2
	setzb o3,o4		;bury all litter
	add o2,o5
	jrst aref3j

arees4: add o4,[inum 0]
arees3: add o3,[inum0]
arees2: add o2,[inum0]
areess: sub w3,[inum 5]
areesc:	addi w3,2
	fjcaln [%spref]

;ASET - full-scale general set
;Does many cases directly.  Escapes to Lisp (%SP-ASET) for anything
;  it can't handle.
;O1 - array, O2 - index, O3 ... more indices, but we don't handle that
aset:	movei w3,2 ? jrst astcal	;no indices??
	movei w3,0 ? jrst aset1a	;1 index
	movei w3,1 ? jrst aset1a	;2 indices
	movei w3,2 ? jrst aset1a	;3 indices
	movei w3,6 ? jrst astcal
astcal:	fjcaln [%spset]

;dispatch here from %sp-aset, aset3j
aset1:  gettyp o1
	xct .+1(w2)	;;TYPES
	jrst notarr		; atom
	jrst notarr		;  constant atom
	jrst notarr		; cons
	jrst notarr		;  constant cons
	jrst schset		; string
	jrst schset		;  constant string
	jrst notarr		; channel
	jrst notarr		;  constant channel
	jrst notarr		; eq hash table
	jrst notarr		; other hash table
	jrst svcset		; vector
	jrst notarr		; character
	jrst [fncall [%spset],3 ? retn]	; array header
	jrst notarr		; special (block)
	jrst sarset		; integer vector
	jrst sbtset		; bit vector
	repeat 16., jrst notarr	; numbers

;dispatch here from aset
aset1a: gettyp o1
	xct .+1(w2)	;;TYPES
	jrst notarr		; atom
	jrst notarr		;  constant atom
	jrst notarr		; cons
	jrst notarr		;  constant cons
	jrst schseq		; string
	jrst schseq		;  constant string
	jrst notarr		; channel
	jrst notarr		;  constant channel
	jrst notarr		; eq hash table
	jrst notarr		; other hash table
	jrst svcseq		; vector
	jrst notarr		; character
	jrst aset2t(w3)		; array header
	jrst notarr		; special (block)
	jrst sarseq		; integer vector
	jrst sbtseq		; bit vector
	repeat 16., jrst notarr	; numbers

;o1 - array; O2 - index; o3 - value
;index into a string
schseq: jumpn w3,aseesc		;if more than 1 index
schset: move w2,o2
	tlc w2,(<object ty%sp5,0>#<object ty%lpi,0>) ;turn into ty%sp5
	caml w2,[object ty%sp5,0] ;bounds check the reference
	 caml w2,(o1)
	  jrst arrbnd		;out of bounds
	tlz w2,770000		;get bare number
	idivi w2,5		;w2 - words; w3 - bytes
	add o1,w2
	dpb o3,[.bp 177_29.,1(o1)
		.bp 177_22.,1(o1)
		.bp 177_15.,1(o1)
		.bp 177_8.,1(o1)
		.bp 177_1.,1(o1)](w3)
	move o1,o3
	ret1

;o1 - array; O2 - index; o3 - value
;index into a simple vector
svcseq: jumpn w3,aseesc		;if more than 1 index
svcset: caml o2,[inum 0]
	caml o2,-1(o1)
	jrst arrbnd
fvcset: tlz o1,770000		;do this first so no overflow trap
	add o1,o2
	movem o3,(o1)
	move o1,o3
	ret1

sbtseq: jumpn w3,aseesc		;if more than 1 index
sbtset: move w2,o2
	tlc w2,(<object ty%s36,0>#<object ty%lpi,0>) ;turn into ty%s36
	caml w2,[object ty%s36,0] ;bounds check the reference
	 caml w2,(o1)
	  jrst arrbnd		;out of bounds
	tlz w2,770000		;get bare number
;the obvious thing to do here is an adjbp, but that is as slow as
;two divides.  This code should be much better.
	idivi w2,36.
	lsh w3,30.
;note that we end up with the number of bits in bits 1 to 5 of
;W3, which is where we want to be
	move w4,[430140,,0]	;one bit byte pointer, to first bit, adr in O1
	sub w4,w3		;adjust to right bit
	add o1,w2		;and right word
	xmovei o1,1(o1)
	dpb o3,w4
	move o1,o3
	ret1

;o1 - array; O2 - index; o3 - value
;index into a simple integer array
sarseq: jumpn w3,aseesc		;if more than 1 index
sarset: caml o2,[inum 0] ;bounds check the reference
	 caml o2,-1(o1)
	  jrst arrbnd		;out of bounds
	move w2,o2
	tlz w2,770000		;get bare number
;the obvious thing to do here is an adjbp, but that is as slow as
;two divides.  This code should be much better.
	move w4,-2(o1)		;get access code
	setz w3,		;and initialize W3 for shifting into
	ashc w2,-5(w4)		;w2 - words; w3 - bytes in high order
	move w4,sartab(w4)	;byte pointer, to first byte, adr in O1
	sub w4,w3		;adjust to right bit
	add o1,w2		;and right word
	tlz o1,770000
	dpb o3,w4
	move o1,o3
	ret1

;dispatch on number of indices
aset2t: jrst aset1i
	jrst aset2i
	jrst aset3i

;1-index header
aset1i: move w3,[inum 5]	;expected header length
	came w3,ah%hsz(o1)
	 jrst aseess		;if wrong
	caml o2,[inum0]
	caml o2,ah%ub1(o1)
	jrst aseess		;if out of bounds
	jrst aset3j

;2-index header
aset2i: add w3,[inum 5]		;make expected header length
	came w3,ah%hsz(o1)
	jrst aseess		;if wrong
	camge o3,ah%ub1+1(o1)
	caml o2,ah%ub1(o1)
	jrst aseess		;if bounds error
	sub o2,[inum0]
	jumpl o2,asees2
	camge o3,[inum0]
	jrst asees2
	move w2,ah%ub1+1(o1)
	tlz w2,770000
	imul o2,w2
	add o2,o3
	move o3,o4
	jrst aset3j

;3-index header
aset3i: add w3,[inum 5]		;make expected header length
	camn w3,ah%hsz(o1)
	caml o4,ah%ub1+2(o1)
	jrst aseess		;if something wrong
	camge o3,ah%ub1+1(o1)
	caml o2,ah%ub1(o1)
	jrst aseess		;if bounds error
	sub o2,[inum0]
	jumpl o2,asees2
	sub o3,[inum0]
	jumpl o3,asees3
	camge o4,[inum0]
	jrst asees3
	move w2,ah%ub1+1(o1)
	tlz w2,770000
	imul o2,w2
	add o2,o3
	move w2,ah%ub1+2(o1)
	tlz w2,770000
	imul o2,w2
	setz o3,		;don't leave a trace
	add o2,o4
	move o3,o5
aset3j: tlz o2,770000
	add o2,ah%dsp(o1)
	move o1,ah%dat(o1)	;get vector object
	jrst aset1

asees3: add o3,[inum0]
asees2: add o2,[inum0]
aseess: sub w3,[inum 5]
aseesc:	addi w3,3
	fjcaln [%spset]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Length and other oddities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;%sp-get-vector-length
gvclen:	gettyp o1
	xct .+1(w2)	;;TYPES
	jrst notarr		; atom
	jrst notarr		;  constant atom
	jrst notarr		; cons
	jrst notarr		;  constant cons
	jrst schlen		; string
	jrst schlen		;  constant string
	jrst notarr		; channel
	jrst notarr		;  constant channel
	jrst notarr		; eq hash table
	jrst notarr		; other hash table
	jrst svclen		; vector
	jrst notarr		; character
	jrst arhlen		; array header
	jrst notarr		; special (block)
	jrst sarlen		; integer vector
	jrst sbtlen		; bit vector
	repeat 16., jrst notarr	; numbers

schlen:	move o1,(o1)		; length as skip pointer
	tlc o1,(<object ty%sp5,0>#<object ty%lpi,0>) ;convert to inum
	ret1

arhlen:	move o1,ah%fil(o1)	; fill pointer is active length
	ret1

sarlen:
svclen:	move o1,-1(o1)		; normal length code
	ret1

sbtlen:	move o1,(o1)		; length as skip pointer
	tlc o1,(<object ty%s36,0>#<object ty%lpi,0>) ;convert to inum
	ret1

;slisp-array-p
slarrp:	gettyp o1
	caie w2,ty%arh
	jrst retnil
	jrst rett

;slisp-b-vector-p
slbvcp:	gettyp o1
	caie w2,ty%vec
	jrst retnil
	jrst rett

;slisp-u-vector-p
sluvcp:	gettyp o1
	caie w2,ty%ivc
	cain w2,ty%bvc
	jrst rett
	jrst retnil

;%sp-get-vector-access-type
gvcacc:	gettyp o1
	cain w2,ty%bvc
	jrst retzer
	move o1,-2(o1)
	ret1

;%sp-shrink-vector
; most of the complexity here is caused by the fact that we have to
; clear the area that is being removed from the vector.  This is because
; it is no longer covered by a skip pointer, so it had better be legal
; Lisp.  Clearing is the easiest way to ensure this.
srnkvc:	gettyp o1
	xct .+1(w2)
	jrst notarr		; atom
	jrst notarr		;  constant atom
	jrst notarr		; cons
	jrst notarr		;  constant cons
	jrst schsrn		; string
	jrst schsrn		;  constant string
	jrst notarr		; channel
	jrst notarr		;  constant channel
	jrst notarr		; eq hash table
	jrst notarr		; other hash table
	jrst svcsrn		; vector
	jrst notarr		; character
	jrst arhsrn		; array header
	jrst notarr		; special (block)
	jrst sarsrn		; integer vector
	jrst sbtsrn		; bit vector
	repeat 16., jrst notarr	; numbers

;shrink a string
schsrn:	getnum o2		;o2 - new number of char's
	move w2,o2		;make new descriptor
	tlo w2,(<object ty%sp5,0>)
	exch w2,(o1)		;w2 is now old descriptor
	tlz w2,770000		;w2 - old number of char's
	addi w2,4
	idivi w2,5		;w2 - old number of words
	addi o2,4
	idivi o2,5		;o2 - new number of chars
schsrd:	sub w2,o2		;w2 - difference in words
	jumple w2,schsrx	;do nothing
	xmovei w3,1(o1)		;w3 - address of first word beyond new str
	add w3,o2
	setzm (w3)		;clear it
	sojle w2,schsrx		;if just this one, nothing more
	xmovei w4,1(w3)		;else clear it all
	xblt w2,
schsrx:	setz o2,
	ret1

;shrink a vector
arhsrn:
svcsrn:	movem o2,-1(o1)
	ret1

;shrink an integer vector
  ;skip pointer, access type [small integer], #entries, data ...
sarsrn:	movem o2,-1(o1)		;put in new length code
	getnum o2		;o2 - new number of bytes
	move w2,-2(o1)		;w2 - access type
	rot o2,-5(w2)		;full words to right end
	tlze o2,760000		;bits would be here
	addi o2,1		;round up - now have words needed
	move w2,o2
	addi w2,2		;skip pointer must also include header
	tlo w2,(object ty%spc,0) ;make skip pointer
	exch w2,-3(o1)		;put in new, get old
	tlz w2,770000		;get bare number
	subi w2,2		;and convert back to words of data
	sub w2,o2		;w2 - difference in words
	jumple w2,schsrx	;do nothing
	xmovei w3,(o1)		;w3 - address of first word beyond new str
	add w3,o2
	setzm (w3)		;clear it
	sojle w2,schsrx		;if just this one, nothing more
	xmovei w4,1(w3)		;else clear it all
	xblt w2,
	setz o2,
	ret1

;shrink a bit string
sbtsrn:	getnum o2		;o2 - new number of char's
	move w2,o2		;make new descriptor
	tlo w2,(<object ty%s36,0>)
	exch w2,(o1)		;w2 is now old descriptor
	tlz w2,770000		;w2 - old number of bits
	addi w2,31.
	lsh w2,-5		;w2 - old number of words
	addi o2,31.
	lsh o2,-5		;o2 - new number of words
	jrst schsrd		;join common code

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Functions on strings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;%sp-string-compare
;takes two simple strings, returns index where they
;first differ.
;o1 - string; o2 - start; o3 - end
;o4 - string2; o5 - start; o6 - end [originally on Q]
strcmp:	pop q,o6	;get end into its AC
	move w4,o2	;return index into string1
;make O3 and O6 into counts	
	sub o3,o2
	sub o6,o5
;make O1/O2 into a byte pointer to the first
	move w2,o2
	tlz w2,770000		;get bare number
	idivi w2,5		;w2 - words; w3 - bytes
	add o1,w2
	move o2,[440740,,0
		 350740,,0
		 260740,,0
		 170740,,0
		 100740,,0](w3)
	xmovei o1,1(o1)
	exch o1,o2
;similarly O4/O5
	move w2,o5
	tlz w2,770000		;get bare number
	idivi w2,5		;w2 - words; w3 - bytes
	add o4,w2
	move o5,[440740,,0
		 350740,,0
		 260740,,0
		 170740,,0
		 100740,,0](w3)
	xmovei o4,1(o4)
	exch o4,o5
;now do the compare, using w2,w3 for the char's
;w4 is result
cmpstl:	sojl o3,cmpsx1		;first string ran out
	sojl o6,cmpsx2		;second string ran out
	ildb w2,o1
	ildb w3,o4
	came w2,w3
	jrst cmpsx2		;if differ, stop now
	aoja w4,cmpstl		;else incr count and try again

cmpsx1:	sojl o6,cmpsxb		;if second also out, return NIL
cmpsx2:	move o1,w4		;no, say they differ here
	setz o2,
	setzb o3,o4
	setzb o5,o6
	ret1

cmpsxb:	setz w4,
	jrst cmpsx2

;%sp-string-compare-ignore
;takes two simple strings, returns index where they
;first differ.  Ignores case
;o1 - string; o2 - start; o3 - end
;o4 - string2; o5 - start; o6 - end [originally on Q]
stricm:	pop q,o6	;get end into its AC
	move w4,o2	;return index into string1
;make O3 and O6 into counts	
	sub o3,o2
	sub o6,o5
;make O1/O2 into a byte pointer to the first
	move w2,o2
	tlz w2,770000		;get bare number
	idivi w2,5		;w2 - words; w3 - bytes
	add o1,w2
	move o2,[440740,,0
		 350740,,0
		 260740,,0
		 170740,,0
		 100740,,0](w3)
	xmovei o1,1(o1)
	exch o1,o2
;similarly O4/O5
	move w2,o5
	tlz w2,770000		;get bare number
	idivi w2,5		;w2 - words; w3 - bytes
	add o4,w2
	move o5,[440740,,0
		 350740,,0
		 260740,,0
		 170740,,0
		 100740,,0](w3)
	xmovei o4,1(o4)
	exch o4,o5
;now do the compare, using w2,w3 for the char's
;w4 is result
cmpisl:	sojl o3,cmpsx1		;first string ran out
	sojl o6,cmpsx2		;second string ran out
	ildb w2,o1
	cail w2,"a"
	 caile w2,"z"
	  jrst .+2
	   subi w2,40
	ildb w3,o4
	cail w3,"a"
	 caile w3,"z"
	  jrst .+2
	   subi w3,40
	came w2,w3
	jrst cmpsx2		;if differ, stop now
	aoja w4,cmpisl		;else incr count and try again
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Functions on characters
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;GET-AND-CHECK-INT.  Used in CHAR.SLISP
;make sure it is a char and return as inum
gchkch:	gettyp o1
	caie w2,ty%chr
	jrst [err1 o1,/Not a character: ~S/]
	tlc o1,(<object ty%chr,0>#<object ty%lpi,0>)
	ret1

;EQUAL-CHAR-INT is used by some of the character comparison functions.
;It loses font, bits, and case info.
eqchrn:	gettyp o1
	caie w2,ty%chr
	jrst [err1 o1,/Not a character: ~S/]
	andi o1,177
	cail o1,"a"
	 caile o1,"z"
	  jrst .+2
	   subi o1,40	
	maknum o1
	ret1

;INT-TO-CHAR.  Also used in CHAR.SLISP
; Turn a fixnum into a character.

int2ch:	tlc o1,(<object ty%chr,0>#<object ty%lpi,0>)
	ret1

;FAST-CHAR-UPCASE.  Doesn't check that it is really a character
fchrup:	movei n,1		;# vals rtned
	caml o1,[char "a"]
	camle o1,[char "z"]
	retn
	subi o1,40
	retn
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; The GC
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;SGC - version of GC that saves all AC's
sgc:	push p,w2
	push p,w3
	push p,w4
	push q,o1
	push q,o2
	push q,o3
	push q,o4
	push q,o5
	push q,o6
	call gc
	pop q,o6
	pop q,o5
	pop q,o4
	pop q,o3
	pop q,o2
	pop q,o1
	pop p,w4
	pop p,w3
	pop p,w2
	sos (p)
	sos (p)
	iret

; the garbage collector.  its init routine is called gcinit and
; takes these args:
;   - the beginning of constant data space, which is really at the
;	start of the first of the two data spaces
;   - the first word beyond the constant data space, which is the
;	beginning of the usable part of the first data space
;   - the first word beyond the initial strings.  FREE gets initialized
;	here.  The initial strings are simply in the first data space.
;	They get moved to the constant string space by PURIFY
;   - the start of the second data space
;   - the first word beyond the second data space
	; garbage collector variables:
	;free - last used location in data space
	;lastl - last legal location in this data space - 1.  Trigger a GC if
	;   someone tries to go beyond this.
	;stthis - start of this data space
	;enthis - end of this data space
	;stthat - start of other data space
	;enthat - end of other data space
	;stcnst - start of constant space, where constant atoms, etc., go
	;encnst - end of constant space
	;  at this point comes the constant string space.  There is no
	;  particular variable pointing to it, but datpgs counts it, as
	;  does encnpg.
	;encnpg - end of constant space - next page

	.scalar lastl,stthis,enthis,stthat,enthat,stcnst,encnst,encnpg

freesz==200000	;amount of free space at end of GC

gcinit:	
;init the variables describing the spaces
	pop q,enthat		;end of second data space
	pop q,stthat		;start of second data space
	pop q,enthis		;end of first data space
	pop q,free		;end of initial strings
	subi free,1		; free is last used
	pop q,w2		;end of constant area
	movem w2,stthis
	movem w2,encnst		;end of constant area
	tro w2,777		;to next page
	addi w2,1
	movem w2,encnpg
	pop q,stcnst		;start of constant area
;set up memory allocation variables for initial space
	move w2,free		;allow allocation of FREESZ words before GC
	addi w2,freesz
	movem w2,lastl		;lastl gives upper limit
	iret

;This is used for explicit user calls.
ugc:	call gc
	jrst retnil

	.scalar gcstrt,gcstrc,gctimt,gccont

;This is always used when you run out of space
gc:	movei nil1,.fhslf
	runtm
	movem nil1,gcstrt	;time starting GC
	move w2,free
	sub w2,stthis
	movem w2,gcstrc		;starting free space
	skipn @[.gcgag]		;if output
	jrst gc1		;none
	hrroi nil1,[asciz /
;GC: /]
	psout
	move w2,free
	sub w2,stthis
	movei nil1,.priou
	movei w3,10.
	nout
	 jfcl			;<
	hrroi nil1,[asciz / ==> /]
	psout
gc1:	setz nil1,
	call igc		; call internal gc
	skipn @[.gcgag]		;if output
	jrst gc2		;none
	move w2,free
	sub w2,stthis		;free space after
	movei nil1,.priou
	movei w3,10.
	nout
	 jfcl
	hrroi nil1,[asciz /, in /]
	psout
	movei nil1,.fhslf
	runtm
	sub nil1,gcstrt		;how much time?
	move w2,nil1
	movei nil1,.priou
	movei w3,10.
	nout
	 jfcl
	hrroi nil1,[asciz / msec.
/]
	psout
	setzm w2,@[datsec,,trmchn+ch%pos]
gc2:	movei nil1,.fhslf
	runtm
	sub nil1,gcstrt
	addm nil1,gctimt
	move w2,free
	sub w2,stthis		;new free space
	sub w2,gcstrc		;minus start
	movn w2,w2		;make positive - this is garbage gotten
	addm w2,gccont		;add to cumulative
	setzb nil,nil1
	iret

;This is a copying GC, modelled after the Lisp Machine GC, as
;described in Henry Baker's thesis.  There are two data spaces, old and new.
;A GC copies everything that is in use from old to new, and makes new the
;current one.  The main operation is translating objects.  If the object
;is absolute, e.g. an INUM, this is a no-op.  Only pointers into the old
;space are translated.  They are translated by finding the equivalent object
;in the new space, and using its pointer.  There are two cases:
;  - we have already moved the object.  In this case the first entry of
;	the old space copy is a pointer to the copy in new space.  These
;	pointers have the sign bit on, for easy detection.
;  - we have not moved the object.  In this case, we copy it to the end of
;	new space, and use the pointer to the beginning of this copy.
;At any given time, we have a pointer into new space.  Everything before
;this pointer has been translated.   Everything after it has not.  We also
;have to translate the stack and the constant area.  Indeed it is translating
;these areas that first puts something into new space to translate.

mark==400000,,0		;bit that says this has already been translated

;Because there are four different areas to translate, we have a separate
;routine to do the translation.
;  gctran:
;	w3 - first address to be translated.  W2 is updated, and is the
;		pointer mentioned above.  I.e. everything before W2 has
;		been translated
;	w4 - last address to be translated.
;	o5 - lower end of old space
;	o6 - upper end of old space

;The code within gctran avoids the use of the stacks, in order to avoid
;performance problems because of addressing conflicts between the stack
;and the areas being GC'ed.

gctran:	move o1,(w3)		;o1 - thing to be translated
	gettyp o1		;see what we have
	xct trntab(w2)		;translate depending upon type
	camge w3,w4		;see if done
	aoja w3,gctran		;no - next
	iret

;GCTRAX - special version of the above for doing new space.  Ends when
;we reach the free pointer
gctrax:	move o1,(w3)		;o1 - thing to be translated
	gettyp o1		;see what we have
	xct trntab(w2)		;translate depending upon type
	camge w3,free		;see if done
	aoja w3,gctrax		;no - next
	iret

;;TYPES
trntab:	jsp w2,cpyatm		; atom
	jfcl			;  constant atom
	jsp w2,cpycon		; cons
	jfcl			;  constant cons
	jsp w2,cpystr		; string
	jfcl			;  constant string
	jsp w2,cpychn		; channel
	jfcl			;  constant channel
	jsp w2,cpyeht		; eq hash table
	jsp w2,cpyoht		; other hash table
	jsp w2,cpyvec		; vector
	jfcl			; character
	jsp w2,cpyarh		; array header
	jsp w2,cpyspc		; special (block)
	jsp w2,cpyivc		; integer vector
	jsp w2,cpybvc		; bit vector
	jsp w2,cpyrea		; long flonum
	jfcl			; constant flonum
	repeat 4, jfcl		; iflons & jrst and jfcl in evhook
	jfcl			; jsp in atom block, constant ratios
	jsp w2,cpyrat		; ratios
	jsp w2,cpys36		; special block
	jsp w2,cpysp5		; special block
	jsp w2,cpybig		; bignum
	jfcl			; constant bignums
	repeat 4, jfcl		; inums

;here to translate a CONS cell - normally we copy it and use addr of new copy
;Make lists contiguous
cpycon:	caml o1,lbcon		;make sure valid pointer
	camle o1,ubcon
	jrst cpycgt		;test for garbage pointer
	skipge o2,(o1)		;do we already have a translation in old copy?
	jrst havcon		;yes - use it
	
	dmove o2,(o1)		;copy it - CDR will be in O3 for code below
	dmovem o2,1(free)
	xmovei o2,1(free)	;make address into CONS pointer
	tlo o2,(object(ty%con,0))
	movem o2,(w3)		;put it in place to be translated
cpycnl:	tlc o2,(mark\object(ty%con,0)) ;make a pointer to put into old copy
	movem o2,(o1)		;and put it there
	addi free,2		;advance free list
	smcons o3		;skip if CDR movable CONS (i.e. not constant)
	jrst (w2)		;not - return
;Now we loop on the CDR, in order to make lists be contiguous.  
;W3 - use FREE, since that is what we are translating
	move o1,o3
	caml o1,lbcon		;make sure valid pointer
	camle o1,ubcon
	jrst cpycgt		;test for garbage
	skipge o2,(o1)		;do we already have a translation in old copy?
	jrst (w2)		;yes - no CDR coding is needed.
	
	dmove o2,(o1)		;copy it
	dmovem o2,1(free)
	xmovei o2,1(free)	;make address into CONS pointer
	tlo o2,(object(ty%con,0))
	movem o2,(free)		;put it in place to be translated
	jrst cpycnl

havcon:	tlc o2,(mark\object(ty%con,0)) ;turn into a real cons pointer
	movem o2,(w3)		;put in place to be translated
	jrst (w2)

;CPYCONS garbage test
;Normally pointers should be into the old space.  I.e. the design is
;such that we never try to translate things twice.  However
;because of our "CDR-coding", it is possible that a pointer will
;be a pointer to the next word.  We check for that case explicitly.
cpycgt:	xmovei o2,-1(o1)	;strip type bits and subtract 1
	came o2,w3		;so is it pointing to next word?
	jrst cpygrb		;no - it is real garbage
	jrst (w2)		;yes - it is fake garbage - return

;here to translate an ATOM - at the moment just like cons cell
cpyatm:	caml o1,lbatm		;make sure valid pointer
	camle o1,ubatm
	jrst cpygrb		;garbage pointer (NB - nil also goes here)
	skipge o2,(o1)		;do we already have a translation in old copy?
	jrst havatm		;yes - use it
	movei o2,at%siz		;length of atom block
	move o3,o1		;source
	xmovei o4,1(free)	;dest
	xblt o2,
	xmovei o2,1(free)	;make address into CONS pointer
	tlo o2,(object(ty%atm,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%atm,0)) ;make a pointer to put into old copy
	movem o2,(o1)		;and put it there
	addi free,at%siz	;advance free list
	jrst (w2)

havatm:	tlc o2,(mark\object(ty%atm,0))
	movem o2,(w3)
	jrst (w2)

;here to copy string
cpystr:	caml o1,lbstr		;make sure valid pointer
	camle o1,ubstr
	jrst cpygrb		;garbage pointer
	skipge o2,(o1)		;do we already have a translation in old copy?
	jrst havstr		;yes - use it
	move o3,(o1)		;number of chars to copy
	tlz o3,770000		;make pure number
	addi o3,4
	idivi o3,5		;make # of wds
	addi o3,1		;and include the header
	xmovei o4,(o1)		;source
	xmovei o5,1(free)	;destination
	move o2,o5		;destination will be final result also
	add free,o3		;update free counter now
	xblt o3,		;do the copy
	tlo o2,(object(ty%str,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%str,0)) ;make a pointer to put into old copy
	movem o2,(o1)		;and put it there
	jrst (w2)

havstr:	tlc o2,(mark\object(ty%str,0))
	movem o2,(w3)
	jrst (w2)

;here to translate a CHANNEL - at the moment just like cons cell
cpychn:	caml o1,lbchn		;make sure valid pointer
	camle o1,ubchn
	jrst cpygrb		;garbage pointer
	skipge o2,(o1)		;do we already have a translation in old copy?
	jrst havchn		;yes - use it
	movei o2,ch%666+1	;length of channel block
	move o3,o1		;source
	xmovei o4,1(free)	;dest
	xblt o2,
	xmovei o2,1(free)	;make address into CONS pointer
	tlo o2,(object(ty%chn,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%chn,0)) ;make a pointer to put into old copy
	movem o2,(o1)		;and put it there
	addi free,ch%666+1	;advance free list
	jrst (w2)

havchn:	tlc o2,(mark\object(ty%chn,0))
	movem o2,(w3)
	jrst (w2)

;here to translate a REAL
cpyrea:	caml o1,lbrea		;make sure valid pointer
	camle o1,ubrea
	jrst cpygrb		;garbage pointer
	skipge o2,(o1)		;do we already have a translation in old copy?
	jrst havrea		;yes - use it
	dmove o2,(o1)		;copy it
	dmovem o2,1(free)
	move o2,2(o1)		;3 cells
	movem o2,3(free)
	xmovei o2,1(free)	;make address into CONS pointer
	tlo o2,(object(ty%flo,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%flo,0)) ;make a pointer to put into old copy
	movem o2,(o1)		;and put it there
	addi free,3		;advance free list
	jrst (w2)

havrea:	tlc o2,(mark\object(ty%flo,0))
	movem o2,(w3)
	jrst (w2)

;copy a ratio: just like a cons cell but no "cdr coding"
cpyrat:	caml o1,lbrat		;make sure valid pointer
	camle o1,ubrat
	jrst cpycgt		;test for garbage pointer
	skipge o2,(o1)		;do we already have a translation in old copy?
	jrst havrat		;yes - use it
	
	dmove o2,(o1)		;copy it
	dmovem o2,1(free)
	xmovei o2,1(free)	;make address into CONS pointer
	tlo o2,(object(ty%rat,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%rat,0)) ;make a pointer to put into old copy
	movem o2,(o1)		;and put it there
	addi free,2		;advance free list
	jrst (w2)		;return

havrat:	tlc o2,(mark\object(ty%rat,0)) ;turn into a real cons pointer
	movem o2,(w3)		;put in place to be translated
	jrst (w2)

;here to translate a BIGNUM
cpybig:	caml o1,lbbig		;make sure valid pointer
	camle o1,ubbig
	jrst cpygrb		;garbage pointer
	skipge o2,(o1)		;do we already have a translation in old copy?
	jrst havbig		;yes - use it
	move o2,(o1)		;size - this is the special size field
	tlz o2,770000		;clear type bits
	addi o2,1		;size is that +1 if you count this size field
	xmovei o3,(o1)		;source
	xmovei o4,1(free)	;dest
	move o5,o4		;save start addr in O5
	add free,o2		;advance free list
	xblt o2,
	tlo o5,(object(ty%big,0))
	movem o5,(w3)		;put it in place to be translated
	tlc o5,(mark\object(ty%big,0)) ;make a pointer to put into old copy
	movem o5,(o1)		;and put it there
	jrst (w2)

havbig:	tlc o2,(mark\object(ty%big,0))
	movem o2,(w3)
	jrst (w2)

;copy eq hash table -- we set the get and put routine pointers
;    to special routines that rehash the table next time a
;    get or put is attempted.
cpyeht:	
	caml o1,lbeht		;make sure valid pointer
	camle o1,ubeht
	 jrst cpygrb		;garbage pointer
	skipge o2,-1(o1)	;do we already have a translation in old copy?
	jrst haveht		;yes - use it
	dmove o3,[object ty%iadr,<codsec,,lgreh>
		  object ty%iadr,<codsec,,lpreh>]
	camle o3,ht%get(o1)	;is it EQ or EQL?
	 dmove o3,[object ty%iadr,<codsec,,grehsh>
		   object ty%iadr,<codsec,,prehsh>]
	dmovem o3,ht%get(o1)
	move o3,-1(o1)		;number of words to copy
	tlz o3,770000		;make pure number
	addi o3,1		;and include the header
	xmovei o4,-1(o1)	;source
	xmovei o5,1(free)	;destination
	xmovei o2,2(free)	;destination+1 will be final result 
	add free,o3		;update free counter now
	xblt o3,		;do the copy
	tlo o2,(object(ty%eht,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%eht,0)) ;make a pointer to put into old copy
	movem o2,-1(o1)		;and put it there
	jrst (w2)

haveht:	tlc o2,(mark\object(ty%eht,0))
	movem o2,(w3)
	jrst (w2)

;copy other hash tables--just like vectors
cpyoht:
	caml o1,lboht		;make sure valid pointer
	camle o1,uboht
	 jrst cpygrb		;garbage pointer
	skipge o2,-1(o1)	;do we already have a translation in old copy?
	jrst havoht		;yes - use it
	move o3,-1(o1)		;number of words to copy
	tlz o3,770000		;make pure number
	addi o3,1		;and include the header
	xmovei o4,-1(o1)	;source
	xmovei o5,1(free)	;destination
	xmovei o2,2(free)	;destination+1 will be final result 
	add free,o3		;update free counter now
	xblt o3,		;do the copy
	tlo o2,(object(ty%oht,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%oht,0)) ;make a pointer to put into old copy
	movem o2,-1(o1)		;and put it there
	jrst (w2)

havoht:	tlc o2,(mark\object(ty%oht,0))
	movem o2,(w3)
	jrst (w2)


cpyvec:	caml o1,lbvec		;make sure valid pointer
	camle o1,ubvec
	jrst cpygvc		;garbage pointer
	skipge o2,-1(o1)	;do we already have a translation in old copy?
	jrst havvec		;yes - use it
	move o3,-1(o1)		;number of words to copy
	tlz o3,770000		;make pure number
	addi o3,2		;and include the header
	xmovei o4,-2(o1)	;source
	xmovei o5,1(free)	;destination
	xmovei o2,3(free)	;destination+2 will be final result 
	add free,o3		;update free counter now
	xblt o3,		;do the copy
	tlo o2,(object(ty%vec,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%vec,0)) ;make a pointer to put into old copy
	movem o2,-1(o1)		;and put it there
	jrst (w2)

havvec:	tlc o2,(mark\object(ty%vec,0))
	movem o2,(w3)
	jrst (w2)

;we are running out of type codes.  We need a constant vector, for
;the OBLIST, but don't have one.  So any vector that points into
;the oblist is not copied.
cpygvc:	caml o1,[object ty%vec,<datsec,,datoff*1000>]
	camle o1,ubcvec
	jrst cpygrb
	jrst (w2)

;here to copy array header
cpyarh:	caml o1,lbarh		;make sure valid pointer
	camle o1,ubarh
	jrst cpygrb		;garbage pointer
	skipge o2,-1(o1)	;do we already have a translation in old copy?
	jrst havarh		;yes - use it
	move o3,-1(o1)		;number of words to copy
	tlz o3,770000		;make pure number
	addi o3,1		;and include the header
	xmovei o4,-1(o1)	;source
	xmovei o5,1(free)	;destination
	xmovei o2,2(free)	;destination+1 will be final result 
	add free,o3		;update free counter now
	xblt o3,		;do the copy
	tlo o2,(object(ty%arh,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%arh,0)) ;make a pointer to put into old copy
	movem o2,-1(o1)		;and put it there
	jrst (w2)

havarh:	tlc o2,(mark\object(ty%arh,0))
	movem o2,(w3)
	jrst (w2)

;here to copy bit vector
cpybvc:	caml o1,lbbvc		;make sure valid pointer
	camle o1,ubbvc
	jrst cpygrb		;garbage pointer
	skipge o2,(o1)		;do we already have a translation in old copy?
	jrst havbvc		;yes - use it
	move o3,(o1)		;number of bits to copy
	tlz o3,770000		;make pure number
	addi o3,35.
	idivi o3,36.		;make # of wds
	addi o3,1		;and include the header
	xmovei o4,(o1)		;source
	xmovei o5,1(free)	;destination
	move o2,o5		;destination will be final result also
	add free,o3		;update free counter now
	xblt o3,		;do the copy
	tlo o2,(object(ty%bvc,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%bvc,0)) ;make a pointer to put into old copy
	movem o2,(o1)		;and put it there
	jrst (w2)

havbvc:	tlc o2,(mark\object(ty%bvc,0))
	movem o2,(w3)
	jrst (w2)

;here to copy integer vector
cpyivc:	caml o1,lbivc		;make sure valid pointer
	camle o1,ubivc
	jrst cpygrb		;garbage pointer
	skipge o2,-1(o1)	;do we already have a translation in old copy?
	jrst havivc		;yes - use it
	move o3,-3(o1)		;number of words to copy
	tlz o3,770000		;make pure number
	addi o3,1		;and include the header
	xmovei o4,-3(o1)	;source
	xmovei o5,1(free)	;destination
	xmovei o2,4(free)	;destination+3 will be final result
	add free,o3		;update free counter now
	xblt o3,		;do the copy
	tlo o2,(object(ty%ivc,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%ivc,0)) ;make a pointer to put into old copy
	movem o2,-1(o1)		;and put it there
	jrst (w2)

havivc:	tlc o2,(mark\object(ty%ivc,0))
	movem o2,(w3)
	jrst (w2)

;here if given a garbage pointer or NIL
cpygrb:	jumpe o1,(w2)		;return if nil
	;;[Victor] Say more
	hrroi nil1,[asciz /Bad pointer detected by GC.  Pointer = #o/]
	psout
	dmovem w2,ilinia	;[Victor] use ill-mem-ref save area
	move w2,o1
	move w3,[no%mag+10]	;[Victor] unsigned octal
	movei nil1,.priou
	nout			;[Victor] type out
	 erjmp .+1
	hrroi nil1,[asciz /
Type CONTINUE to proceed.
/]
	psout
	dmove w2,ilinia		;[Victor] restore
	;;[Victor] end talking
;	hrroi nil1,[asciz /Bad pointer detected by GC.  Type CONTINUE to proceed.
;/]
;	psout
	setz nil1,
	haltf
	setzm (w3)		;get rid of it
	jrst (w2)

;here for special thing that GC should ignore. o1 is code,,length
cpyspc:	tlz o1,770000		;make pure number
	add w3,o1		;skip that many words
	jrst (w2)

;here for special thing that GC should ignore. o1 is code,,# of chars
cpysp5:	tlz o1,770000		;make pure number
	addi o1,4		;round
	idivi o1,5		;make # of wds
	add w3,o1		;skip that many words
	jrst (w2)

;here for special thing that GC should ignore. o1 is code,,# of bits
cpys36:	tlz o1,770000		;make pure number
	addi o1,35.		;round
	idivi o1,36.		;make # of wds
	add w3,o1		;skip that many words
	jrst (w2)

;the following variables contain lower and upper bounds for pointers
;of each type. this is just stthis and free from before the GC,
;with the appropriate type code filled in

.scalar lbcon,ubcon,lbatm,ubatm,lbstr,ubstr,lbchn,ubchn,lbrea,ubrea,lbbig,ubbig
.scalar lbvec,ubvec,lbarh,ubarh,lbbvc,ubbvc,lbivc,ubivc,lbeht,ubeht,lboht,uboht,lbrat,ubrat
.scalar ubcvec

inbnds:  ;bounds for areas
     ;cons
	move w3,[object ty%con,0]
	add w3,stthis
	movem w3,lbcon
	move w3,[object ty%con,0]
	add w3,free
	movem w3,ubcon
     ;atom
	move w3,[object ty%atm,0]
	add w3,stthis
	movem w3,lbatm
	move w3,[object ty%atm,0]
	add w3,free
	movem w3,ubatm
     ;string
	move w3,[object ty%str,0]
	add w3,stthis
	movem w3,lbstr
	move w3,[object ty%str,0]
	add w3,free
	movem w3,ubstr
     ;channel
	move w3,[object ty%chn,0]
	add w3,stthis
	movem w3,lbchn
	move w3,[object ty%chn,0]
	add w3,free
	movem w3,ubchn
     ;real
	move w3,[object ty%flo,0]
	add w3,stthis
	movem w3,lbrea
	move w3,[object ty%flo,0]
	add w3,free
	movem w3,ubrea
     ;bignum
	move w3,[object ty%big,0]
	add w3,stthis
	movem w3,lbbig
	move w3,[object ty%big,0]
	add w3,free
	movem w3,ubbig
     ;vector
	move w3,[object ty%vec,1]
	add w3,stthis
	movem w3,lbvec
	move w3,[object ty%vec,1]
	add w3,free
	movem w3,ubvec
	move w3,[object ty%vec,0]
	add w3,encnst
	movem w3,ubcvec
     ;eq hash table
	move w3,[object ty%eht,1]
	add w3,stthis
	movem w3,lbeht
	move w3,[object ty%eht,1]
	add w3,free
	movem w3,ubeht
     ;other hash table
	move w3,[object ty%oht,1]
	add w3,stthis
	movem w3,lboht
	move w3,[object ty%oht,1]
	add w3,free
	movem w3,uboht
     ;array header
	move w3,[object ty%arh,1]
	add w3,stthis
	movem w3,lbarh
	move w3,[object ty%arh,1]
	add w3,free
	movem w3,ubarh
     ;bit vector
	move w3,[object ty%bvc,1]
	add w3,stthis
	movem w3,lbbvc
	move w3,[object ty%bvc,1]
	add w3,free
	movem w3,ubbvc
     ;integer vector
	move w3,[object ty%ivc,1]
	add w3,stthis
	movem w3,lbivc
	move w3,[object ty%ivc,1]
	add w3,free
	movem w3,ubivc
	
     ;rational
	move w3,[object ty%rat,1]
	add w3,stthis
	movem w3,lbrat
	move w3,[object ty%rat,1]
	add w3,free
	movem w3,ubrat
	iret
	
igc:	call stcrit			;GC is critical section
  ;initialize for copying scan
	call inbnds		;initialize bounds
	move free,stthat	;start copy in other area
	subi free,1		;because designed for PUSH

  ;now scan the areas that are to be translated
;;;	it appears unnecessary to translate the constant addr blocks
;;;	xmovei w3,stadrs	;translate areas with address blocks
;;;	xmovei w4,enadrs
;;;	subi w4,1
;;;	call gctran
	xmovei w3,bpscod	;start with BPS in CODSEC
igcbpl:	push p,w3
	move w4,bps%le(w3)
	subi w4,1
	move w3,bps%ls(w3)
	call gctran
	pop p,w3		;see if more code sections
	skipe w3,bps%nx(w3)
	jrst igcbpl		;yes - do the next
	move w3,[baseq]		;translate data stack
	move w4,q
	call gctran
	move w3,[basesp]	;translate special PDL
	move w4,sp
	call gctran
	move w3,[basemv]	;translate MV stack
	move w4,mvp
	call gctran
	move w3,stcnst		;translate constant area
	move w4,encnst
	subi w4,1
	call gctran
	move w3,stthat		;now do the new space
	call gctrax

  ;clear the data area that we just got rid of.  This is to save
  ;swap space.

ifn ty%atm,[printx This code depends upon TY%ATM being 0]
  ;So that UBATM is in fact the original FREE.

gcfini:	move w2,stthis			;start of other section
	camge w2,encnpg			;but not pages with OBLIST on it
	move w2,encnpg
	move w3,ubatm			;end of other section
	lsh w2,-9.			;convert to page - first page
	lsh w3,-9.			;convert to page - last page
	sub w3,w2
	addi w3,1			;page count
	seto nil1,			;AC1 - unmap
	hrli w2,.fhslf			;AC2 - self,,first page
	tlo w3,(pm%cnt)			;AC3 - count
	pmap				;clear them all

  ;now reverse areas
	move w2,stthis
	exch w2,stthat
	movem w2,stthis
	move w2,enthis
	exch w2,enthat
	movem w2,enthis
  ;clear q above the point actually used.  This is necessary since
  ;compiled code sometimes does ADDI Q,+N.  The effect is that
  ;there may be data on Q that was not put there explicitly.  If a
  ;GC should happen before real data was put in, we could be in trouble
  ;if there were any pointers left over from a previous GC cycle.  To
  ;be safe, we must purge all old items from the Q section.  Other
  ;sections need not be cleared, since data is put in SP space and
  ;and free space only by PUSH or by adjusting FREE to beyond data
  ;actually used.
	move w2,q			;.Q + 1 is first to be cleared
	tro w2,777			;end of page is last
	sub w2,q			;here is number of words
	jumpe w2,igcldn			;forget it if none
	setzm 1(q)			;clear first
	caig w2,1			;done if only one
	jrst igcldn
	xmovei w3,1(q)			;source is .Q + 1
	xmovei w4,2(q)			;dest is one more
	xblt w2,			;clear them all
;now we have cleared remaining part of current page - kill higher pages
igcldn:	move w2,q
	tro w2,777
	addi w2,1			;first word of next page
	lsh w2,-9.			;w2 - page number of next page
	movei w3,endq_-9.		;page number beyond section
	skipn @[.%%STKLIM]		;expanded stack?
	movei w3,endqs_-9.		;yes - then to end of section
	sub w3,w2			;w3 - number of pages to clear
	jumpe w3,igpmdn			;done if none
	seto nil1,			;AC1 - unmap
	hrli w2,.fhslf			;AC2 - self,,first page
	tlo w3,(pm%cnt)			;AC3 - count
	pmap				;clear them all
  ;do the same thing for the MV stack, since there is sometimes
  ;data beyond MVP
igpmdn:	move w2,mvp			;.MVP + 1 is first to be cleared
	setzm 1(w2)			;clear first
	xmovei w3,1(w2)			;source is .Q + 1
	xmovei w4,2(w2)			;dest is one more
	tro w2,777			;end of page is last
	sub w2,mvp			;here is number of words
	jumpe w2,igcmdn			;forget it if none
	caig w2,1			;done if only one
	jrst igcmdn
	xblt w2,			;clear them all
;now we have cleared remaining part of current page - kill higher pages
igcmdn:	move w2,mvp
	tro w2,777
	addi w2,1			;first word of next page
	lsh w2,-9.			;w2 - page number of next page
	movei w3,endmv_-9.		;page number beyond section
	skipn @[.%%STKLIM]		;expanded stack?
	movei w3,endmvs_-9.		;yes - then to end of section
	sub w3,w2			;w3 - number of pages to clear
	jumpe w3,igmpdn			;done if none
	seto nil1,			;AC1 - unmap
	hrli w2,.fhslf			;AC2 - self,,first page
	tlo w3,(pm%cnt)			;AC3 - count
	pmap				;clear them all
  ;and set up trigger for next GC
igmpdn:	move o1,@[.GCTRIGGER]
	call getrea			;get real in W2/W3
	move w3,free			;now compute used
	sub w3,stthis			;  w3 _ used
	fltr w3,w3			;to floating point
	fmpr w2,w3			;now have real free space
	fixr w2,w2			;convert back to integer
	caige w2,freesz			;give him at least this much
	 movei w2,freesz		;no - use this
	add w2,free			;     + free
	move w3,enthis			;but not too big - end of this area
	subi w3,4000			;give a bit of extra space since
					;we can allocate beyond LASTL
	camle w2,w3			;if new LASTL is too big
	 move w2,w3			;then use upper bound instead
	movem w2,lastl
	setzb nil,nil1
	setzb o1,o2			;clear these AC's so have valid data
	setzb o3,o4
	setzb o5,o6
	call encrit			;no longer in critical section
	iret

;GCLEFT - amount of space left before the next GC
gcleft:	move w2,lastl
	sub w2,free
	jrst ret1nt
;purifier

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PURIFY
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;PURIFY is a special version of the GC that moves all as many objects
;as possible into constant space.  It is used after loading all the
;system functions to move them into constant space.  Since they won't
;be going away, that is safe.  And it speeds up future GC's considerably.

purify:	setzb o1,o2
	setzb o3,o4
	setzb o5,o6
;put the data into the other data area so that when we copy we are
;copying into the area that has the constant space.
	hlrz w2,free		;where are we?
	caige w2,datsc2		;want to have data in other area
	 call gc		;no, do it
	call stcrit
	call inbnds		;initialize bounds
;We copy into two separate areas. The first is at ENCNST, i.e. constant
;space.  The other is one section above this.  We need the second area
;because there has to be some place to put things that we can't make
;constant.  Note that FREE is used for the second region, and ENCNST
;for the first. Routines that copy into constant space will EXCH FREE,ENCNST
;at the beginning and end.
	move free,stthat	;start copy in other area
	add free,[1,,0]		;give us lots of free space

  ;now scan the areas that are to be translated
;;;	it appears unnecessary to translate the constant addr blocks
;;;	xmovei w3,stadrs	;translate areas with address blocks
;;;	xmovei w4,enadrs
;;;	subi w4,1
;;;	call gctran
	xmovei w3,bpscod	;start with BPS in CODSEC
pr1bpl:	push p,w3
	move w4,bps%le(w3)
	subi w4,1
	move w3,bps%ls(w3)
	call pr1trn
	pop p,w3		;see if more code sections
	skipe w3,bps%nx(w3)
	jrst pr1bpl		;yes - do the next
	move w3,[baseq]		;translate data stack
	move w4,q
	call pr1trn
	move w3,[basesp]	;translate special PDL
	move w4,sp
	call pr1trn
	move w3,[basemv]	;translate MV stack
	move w4,mvp
	call pr1trn
	move w3,stcnst		;translate constant area
	move w4,stthat
	subi w4,1
	call pr1trn
	move w3,stthat		;now do the new space
	call pr1trx
;done with copying.  Update things
	move w2,encnst
	movem w2,stthat
	subi w2,1
	tro w2,777		;to next page
	addi w2,1
	movem w2,encnpg
	move w2,encnst
	move w2,encnst
	sub w2,[datsec,,datoff*1000]
	subi w2,1
	lsh w2,-9
	addi w2,1
	movem w2,datpgs	;only this gets saved by SAVE command
	call gcfini		;do normal finish of GC
;need to do a real GC because of the large gap in our new space.
	call gc			;will do the encrit
	movei o1,nil
	ret1


pr1trn:	move o1,(w3)		;o1 - thing to be translated
	gettyp o1		;see what we have
	xct pr1tab(w2)		;translate depending upon type
	camge w3,w4		;see if done
	aoja w3,pr1trn		;no - next
	iret

;PR1TRX - special version of the above for doing new space.  
;Note that there are really two new spaces, one at ENCNST and
;the other at FREE.  We have to look at both.  Doing one can
;add more to the other, so we alternate among them until 
;nothing is added.  W3 gets the start of the constant area
;The stack variables give the place to restart the scan in each
;of the areas.
pr1trx:	push p,w3
	add w3,[1,,0]		;get start of other area
	push p,w3
	move w3,-1(p)		;get back pointer into constant area
;here is the loop over the area at ENCNST
pr1tx1:	move o1,(w3)		;o1 - thing to be translated
	gettyp o1		;see what we have
	xct pr1tab(w2)		;translate depending upon type
	camge w3,encnst		;see if done
	aoja w3,pr1tx1		;no - next
	movem w3,-1(p)		;done, save what we have seen
	move w3,(p)		;now go to other area
;here is the loop over the area at FREE
pr1tx2:	move o1,(w3)		;same loop, but over other area
	gettyp o1
	xct pr1tab(w2)
	camge w3,free
	aoja w3,pr1tx2
	movem w3,(p)		;save away end of this loop
	move w3,-1(p)		;see if we need the other one again
	camge w3,encnst
	jrst pr1tx1		;yes
	subi p,2		;get rid of junk on stack
	iret

;;TYPES
pr1tab:	jsp w2,puratm		; atom
	jfcl			;  constant atom
	jsp w2,purcon		; cons
	jfcl			;  constant cons
	jsp w2,purstr		; string
	jfcl			;  constant string
	jsp w2,purchn		; channel
	jfcl			;  constant channel
	jsp w2,cpyeht		; eq hash table
	jsp w2,cpyoht		; other hash table
	jsp w2,purvec		; vector
	jfcl			; character
	jsp w2,cpyarh		; array header
	jsp w2,cpyspc		; special (block)
	jsp w2,cpyivc		; integer vector
	jsp w2,cpybvc		; bit vector
	jsp w2,cpyrea		; long flonum
	jfcl			; constant flonum
	repeat 4, jfcl		; iflons & jrst and jfcl in evhook
	jfcl			; jsp in atom block, constant ratios
	jsp w2,cpyrat		; ratios
	jsp w2,cpys36		; special block
	jsp w2,cpysp5		; special block
	jsp w2,cpybig		; bignum
	jfcl			; constant bignums
	repeat 4, jfcl		; inums


;here to copy string
purstr:	skipge o2,(o1)		;do we already have a translation in old copy?
	jrst havpus		;yes - use it
	exch free,encnst
	move o3,(o1)		;number of chars to copy
	tlz o3,770000		;make pure number
	addi o3,4
	idivi o3,5		;make # of wds
	addi o3,1		;and include the header
	xmovei o4,(o1)		;source
	xmovei o5,1(free)	;destination
	move o2,o5		;destination will be final result also
	add free,o3		;update free counter now
	xblt o3,		;do the copy
	tlo o2,(object(ty%cst,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%cst,0)) ;make a pointer to put into old copy
	movem o2,(o1)		;and put it there
purxit:	exch free,encnst
	jrst (w2)

havpus:	tlc o2,(mark\object(ty%cst,0))
	movem o2,(w3)
	jrst (w2)

;here to translate a CONS cell - normally we copy it and use addr of new copy
;Make lists contiguous
purcon:	skipge o2,(o1)		;do we already have a translation in old copy?
	jrst hvpcon		;yes - use it
	exch free,encnst
	dmove o2,(o1)		;copy it - CDR will be in O3 for code below
	dmovem o2,1(free)
	xmovei o2,1(free)	;make address into CONS pointer
	tlo o2,(object(ty%ccn,0))
	movem o2,(w3)		;put it in place to be translated
purcnl:	tlc o2,(mark\object(ty%ccn,0)) ;make a pointer to put into old copy
	movem o2,(o1)		;and put it there
	addi free,2		;advance free list
	smcons o3		;skip if CDR movable CONS (i.e. not constant)
	jrst purxit		;not - return
;Now we loop on the CDR, in order to make lists be contiguous.  
;W3 - use FREE, since that is what we are translating
	move o1,o3
	skipge o2,(o1)		;do we already have a translation in old copy?
	jrst purxit		;yes - no CDR coding is needed.
	
	dmove o2,(o1)		;copy it
	dmovem o2,1(free)
	xmovei o2,1(free)	;make address into CONS pointer
	tlo o2,(object(ty%ccn,0))
	movem o2,(free)		;put it in place to be translated
	jrst purcnl

hvpcon:	tlc o2,(mark\object(ty%ccn,0)) ;turn into a real cons pointer
	movem o2,(w3)		;put in place to be translated
	jrst (w2)

;here to translate an ATOM - at the moment just like cons cell
puratm:	jumpe o1,(w2)		;ignore NIL
	skipge o2,(o1)		;do we already have a translation in old copy?
	jrst hvpatm		;yes - use it
	exch free,encnst
	movei o2,at%siz		;length of atom block
	move o3,o1		;source
	xmovei o4,1(free)	;dest
	xblt o2,
	xmovei o2,1(free)	;make address into CONS pointer
	tlo o2,(object(ty%cat,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%cat,0)) ;make a pointer to put into old copy
	movem o2,(o1)		;and put it there
	addi free,at%siz	;advance free list
	exch free,encnst
	jrst (w2)

hvpatm:	tlc o2,(mark\object(ty%cat,0))
	movem o2,(w3)
	jrst (w2)

;here to translate a CHANNEL - at the moment just like cons cell
purchn:	skipge o2,(o1)		;do we already have a translation in old copy?
	jrst hvpchn		;yes - use it
	exch free,encnst
	movei o2,ch%666+1	;length of channel block
	move o3,o1		;source
	xmovei o4,1(free)	;dest
	xblt o2,
	xmovei o2,1(free)	;make address into CONS pointer
	tlo o2,(object(ty%cch,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%cch,0)) ;make a pointer to put into old copy
	movem o2,(o1)		;and put it there
	addi free,ch%666+1	;advance free list
	exch free,encnst
	jrst (w2)

hvpchn:	tlc o2,(mark\object(ty%cch,0))
	movem o2,(w3)
	jrst (w2)

;the following code depends upon the fact that when purifying, the new
;area and the constant area are all less than FREE
purvec:	xmovei o2,(o1)		;kill type codes
	camg o2,encnst		;pointers into the new area are all constant
	jrst (w2)
	skipge o2,-1(o1)	;do we already have a translation in old copy?
	jrst havvec		;yes - use it
	exch free,encnst
	move o3,-1(o1)		;number of words to copy
	tlz o3,770000		;make pure number
	addi o3,2		;and include the header
	xmovei o4,-2(o1)	;source
	xmovei o5,1(free)	;destination
	xmovei o2,3(free)	;destination+2 will be final result 
	add free,o3		;update free counter now
	xblt o3,		;do the copy
	tlo o2,(object(ty%vec,0))
	movem o2,(w3)		;put it in place to be translated
	tlc o2,(mark\object(ty%vec,0)) ;make a pointer to put into old copy
	movem o2,-1(o1)		;and put it there
	exch free,encnst
	jrst (w2)
;read and print.
;This page contains all the code that depends upon the representation
;of atoms and strings.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;	print
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;**** WARNING ****
; It is possible that we are printing in the middle of explode.
; If so, GC's may happen at any TYO.  If a GC happens, the atom
; or string we are printing may move.  This means that any
; byte pointers we are geting char's from must be relative to
; some lisp AC or place on Q, so the GC relocates it.
;*****************

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; prinx is the main worker routine.  It obeys all the flags, but
;; 	doesn't change any.  It keeps count of the level.
;;	It may exit to %SP-PRINT-ARRAY or %SP-PRINT-STRUCTURE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;routine called by Spice routines:
;  (output-object thing level)
outobj:	move o2,[inum 0]		;default level
	push p,sp
	push p,[codsec,,ubdr1v]
	bindit %CPRLV,o2
	move o2,@[.stdout]
	jrst prinx+1

iprin:	push p,sp
	push p,[codsec,,unbind]
	move w2,[inum 0]
	bindit %CPRLV,w2
	skipn @[.PRNPRETTY]
	jrst prinxx
	push q,o1
	push q,o2
	bindit %STDOUT,o2
	fncall [%OUTPRETTY],1
	pop q,o2
	pop q,o1
	ret1

;entry for recursive call
prinx:	aos @[.CPRLV]
prinxx:	push q,o1		; save return value
	gettyp o1
	xct prtab(w2)

;;TYPES
prtab:	jrst pratom		; atom
	jrst pratom		;  constant atom
	jrst prlist		; cons
	jrst prlist		;  constant cons
	jrst prstr		; string
	jrst prstr		;  constant string
	jrst prchn		; channel
	jrst prcch		;  constant channel
	jrst prhtb		; eq hash table
	jrst prhtb		; other hash tab
	jrst prvec		; vector
	jrst prchr		; character
	jrst prarh		; array header
	jrst prspc		; special
	jrst privc		; integer vector
	jrst prbvc		; bit vector
	jrst prrea		; real
	jrst prerr		; undefined
	jrst prifl		; neg iflon
	jrst prifl		; neg iflon
	jrst prifl		; pos iflon
	jrst prifl		; pos iflon
	jrst prerr		; undefined
	jrst prrat		; ratio
	jrst prsp5		; special 5
	jrst prs36		; special 36
	jrst prbig		; bignum
	jrst prerr		; undefined
	jrst prnint		; neg integer
	jrst prnint		; neg integer
	jrst prpint		; pos integer
	jrst prpint		; pos integer

;;TY%CHR
;;TY%LPI
;Print a character, to be displayed.
prchr:	skipn @[.PRESC]
	jrst prchr3
	move o1,[char "#"]	;print a hash mark
	call tyo
	move o1,[char "\"]	;print a back slash
	call tyo
	move o1,(q)		;get char
	trnn o1,3600		;any printable funny bits?
	jrst prchr2		;no
;here if have funny bits	
	trne o1,200
	jrst [	movei w2,[asciz /CONTROL-/]
		call tyout
		move o1,(q)
		jrst .+1]
	trne o1,400
	jrst [	movei w2,[asciz /META-/]
		call tyout
		move o1,(q)
		jrst .+1]
	trne o1,1000
	jrst [	movei w2,[asciz /SUPER-/]
		call tyout
		move o1,(q)
		jrst .+1]
	trne o1,2000
	jrst [	movei w2,[asciz /HYPER-/]
		call tyout
		move o1,(q)
		jrst .+1]
	andi o1,177		;get just char part
	makchr o1
	push q,o2
	fncall [%CHRNAM],1	;see if there is a name
	pop q,o2
	jumpn o1,pratrc		;yes, print the name
;here when char after META-, etc., and is not named.  May need to
;  quote it
	move o1,(q)		;get back char
	andi o1,177
	makchr o1
	skipn funchr(o1)	;char need quoting?
	jrst prchr1		;no
	push q,o1
	move o1,[char "\"]
	call tyo
	pop q,o1
prchr1:	call tyo
	pop q,o1
	ret1

;here when char has no funny bits.  Never need to quote it
prchr2:	andi o1,177		;get just char part
	makchr o1
	push q,o2
	fncall [%CHRNAM],1	;see if there is a name
	pop q,o2
	jumpn o1,pratrc		;yes, print the name
;here to just print the char with no tests, etc.
prchr3:	move o1,(q)		;get back char
	andi o1,177
	makchr o1
	call tyo
	pop q,o1
	ret1

;;TY%STR
;;TY%ATM
;print an atom
pratom:	jumpe o1,prnil		;nil is special
	move w3,at%pna(o1)	;[Victor] Typechecking is good for you!
	caml w3,[object ty%str,0]	;[Victor] see if really IADR
	 camle w3,[object ty%cst,7777777777]
	  jrst [ push q,o1 ? jrst priadr]	;[Victor] end typechecking
;first print any package prefixes necessary
;the easy case: see if this is its home
	move o3,at%pkg(o1)	;look at package
	camn o3,@[.PACKAGE]	;if it is current
	jrst pratnc		;then nothing to do
	camn o3,@[.KEYPACKAGE]	;or if keyword
	jrst pratky		;then :
	jumpe o3,pratgs		;if null, it is gensym
;now see if accessible from current package.
	push q,o2
	move o1,at%pna(o1)	;print string
	call fndsym
	pop q,o2
	camn o1,(q)		;did we find the right symbol?
	jrst pratnc		;yes, no prefix needed
;not accessible, use : or :: as appropriate
	move o1,(q)
	push q,o2		;save I/O channel
	move o3,at%pkg(o1)	;package
	move o1,at%pna(o1)	;pname
	move o2,pk%ext(o3)	;external symbols
	call gethsh
	pop q,o2
	push q,o1		;save result of test
	move o1,-1(q)		;get back thing we are printing
	move o1,at%pkg(o1)	;its package
	move o1,pk%nam(o1)	;its name
	push q,o1		;prstr expects this to be saved
	call pratrc
	pop q,o1		;result of hash lookup
	jumpe o1,pratin		;not in external list, use ::
	jrst pratky		;else :

;here for gensym
pratgs:	skipe @[.PRGENSYM]	;only if both *print-gensym* and
	skipn @[.PRESC]		;*print-escape*
	jrst pratnc
	movei w2,[asciz /#:/]
	call tyout
	jrst pratyc

;here to print ::
pratin:	move o1,[char ":"]
	call tyo
;here to print prefix for keyword (or actually the : after anything)
pratky:	move o1,[char ":"]
	call tyo
	jrst pratyc
;;;;;;;;;;;
;main atom printer, after all the package stuff
;;;;;;;;;;;
;;; print atom no colons.  Here we see if the atom looks like a number.
pratnc:	move o1,(q)
	move o1,at%pna(o1)	;get pname
	push q,o1
	skipn @[.PRESC]		;full processing desired?
	jrst pratnx		;no
	move w3,o1		;get byte ptr to pname in -1(p)
	caml w3,[object ty%str,0]	;see if really IADR
	 camle w3,[object ty%cst,7777777777]
	  jrst priadr
	move w4,(w3)		;count in W4
	tlz w4,770000
	xmovei w3,1(w3)		;get addr of data part
	move w2,[440740,,0]	;now have byte pointer in W2/W3
	jumpe w4,pratyx		;null name, print as ||
	movei o6,4		;flags:
	;40: >1 . seen   20: 1 . seen  10: / seen
	; 4: not all ..   2: E seen     1: digit seen
prat0:	ildb nil1,w2
	move o3,@[010000+datsec,,sectab] ;see what it is
	call chkodg		;fixes up digitness depending on base
	camn o3,[inum rd%dot]
	 troa o6,20		;yes a dot
	  trza o6,4		;not all dots
	   jrst prat1		;may be dec. pt., keep looking
	camn o3,[inum rd%sgn]
	 jrst [caig w4,1 ? jrst pratnn ? jrst prat1]
	came o3,[inum rd%dig]
	 jrst pratnn		;no, not a number
	tro o6,1		;say saw a digit
  ;starts right.  make sure all members are legal
prat1:	sojle w4,prat2		;any more chars?
	ildb nil1,w2
	move o3,@[010000+datsec,,sectab] ;see what it is
	call chkodg		;fixes up digitness depending on base
	camn o3,[inum rd%dot]
	 jrst [ tron o6,20 ? jrst prat1	;first dot?
		trnn o6,4 ? jrst pratnn	;not all dots?
		tro o6,40 ? jrst prat1]	;saw 2 dots
	trne o6,40	; this is to let thru anything all dots
	 jrst pratnn	;  but squelch anything else w/ >1 dots
	trz o6,4		;not all dots
	camn o3,[inum rd%exp]
	   jrst [tro o6,20 ? trz o6,1	;want no dots, more digits
		 tron o6,2 ? sojg w4,prat0 ? jrst pratnn]
	camn o3,[inum rd%dig]
	 jrst [tro o6,1 ? jrst prat1] ;say saw a digit
	camn o3,[inum rd%slh]
	 troe o6,10		;only one / per #
	  jrst pratnn		;(or random constituent)
	trze o6,1		;need digits both sides of /
	 sojg w4,prat0		;new number after /
	  jrst pratnn

 ;ends without finding anything wrong
prat2:	move o3,@[010000+datsec,,sectab] ;see what last char was
	trne o6,5		;make sure we saw a digit (or all dots)
	 camn o3,[inum rd%sgn]	;not allowed to end in sign
	  jrst pratnn
	setzb nil1,o6		;back to proper context
	jrst pratyx		;print inside ||


;this is the main symbol printer.  Note that TYO can
;cause a GC, so our byte pointer must be a tad complex.

;here if there were colons printed, no need to check if it looks like a
; number
pratyc:	move o1,(q)
	move o1,at%pna(o1)	;get pname
pratrc:	push q,o1
	skipn @[.PRESC]		;full processing desired?
	 jrst pratnx		;no
	;falls thru
; here if it doesn't look like a number
pratnn:	setzb nil1,o6

	move w3,o1		;get byte ptr to pname in 
	caml w3,[object ty%str,0]	;see if really IADR
	 camle w3,[object ty%cst,7777777777]
	  jrst priadr
	move w4,(w3)		;count in W4
	tlz w4,770000
	xmovei w3,1(w3)		;get addr of data part
	move w2,[440740,,0]	;now have byte pointer in W2/W3
	jumpe w4,pratyx		;null name, print as ||
pratch:	sojl w4,pratnx
	ildb o1,w2
	caie o1,"|"		;these are \ed anyway, so don't 
	 cain o1,"\"		; bother to quote whole atom for them
	  jrst pratch	
	skipe funchr(o1)	;funny char?
	 jrst pratyx		;yes, then need quote
	cail o1,"a"
	 caile o1,"z"		;quote anything with lowercase
	  jrst pratch
	;falls thru

;; print a symbol between ||
pratyx:	move o1,[char "|"]
	call tyo
	move w3,(q)		;put byte ptr to pname in -1(p)
	move w4,(w3)		;count in W4
	tlz w4,770000
	push p,w4
	push p,[010740,,0]
	push p,[030000,,0]	;pointer is indexed off W3
	jumpe w4,pratx1		;null name, print as ||
pratx0:	sojl w4,pratx1
	move w3,(q)
	ildb o1,-1(p)
	caie o1,"|"
	 cain o1,"\"
	  call pratqc
	makchr o1
	call tyo
	jrst pratx0
	
pratx1:	move o1,[char "|"]
	call tyo
	subi p,3
	subi q,1
	pop q,o1
	ret1

pratqc:	push p,o1
	move o1,[char "\"]
	call tyo
	pop p,o1
	iret

; Normal printer for unquoted symbols	
pratnx:
	move o1,@[.PRCASE]	;see what to do about letters
	move w3,[trz o1,040]	;for UPCASE - the default
	camn o1,[$DOWNCASE]
	move w3,[tro o1,040]
	camn o1,[$CAPITALIZE]
	move w3,[ior o1,-3(p)]
	push p,w3
	push p,[0]		;flag that last thing was letter
	move w3,(q)		;put byte ptr to pname in -1(p)
	move w4,(w3)		;count in W4
	tlz w4,770000
	push p,w4
	push p,[010740,,0]
	push p,[030000,,0]	;pointer is indexed off W3
;-4(p) - thing to execute to determine case of letter
;-3(p) - flag that last was letter
;-2(p) - count
;-1(p) - byte pointer, but must load string pointer into W3
	skipn @[.PRESC]		;shall we \ \es?
	 jrst pratzz		;no
;main symbol printer loop
pratll:	sojl w4,eoprat
	move w3,(q)
	ildb o1,-1(p)
	cail o1,"A"		;upper case get casified
	 caile o1,"Z"
	  tdza w3,w3
	   jrst [xct -4(p) ? movei w3,040 ? jrst .+1]
	 movem w3,-3(p)
	caie o1,"|"
	 cain o1,"\"
	  call pratqc
	makchr o1
	call tyo
	jrst pratll

;end of atom print
eoprat:	subi p,5
	subi q,1
	pop q,o1
	ret1

;this print loop is used when *print-escape* is nil and not even \ is \'ed.
pratzz:	sojl w4,eoprat
	move w3,(q)
	ildb o1,-1(p)
	cail o1,"A"		;upper case get casified
	 caile o1,"Z"
	  tdza w3,w3
	   jrst [xct -4(p) ? movei w3,040 ? jrst .+1]
	movem w3,-3(p)
	makchr o1
	call tyo
	jrst pratzz

prnil:	move o1,[%NIL]
	push q,at%pna(o1)
	jrst pratnx

;;;;;;;;
;; CHKODG - routine to fix up syntax class
;;;;;;;;

;here to take the *print-base* into account
chkodg:	move o4,@[.BASE]	;look at base
	camn o4,[inum 10.]
	 iret			;if base 10, the tables are right
	camg o4,[inum 10.]
	 jrst chkodd	 	;base is .LT. 10, just check normal digits
;here when base .GT. 10.  Set up letters as digits
;O3 - type code
;O4 - base
;O5 - copy of char
	camge o3,[inum rd%con]	;only check out constituents
	 iret
	move o5,nil1		;upper case the object
	trz o5,040
	makchr o5		;make it a char
	sub o4,[<inum 16.>-<char "F">] ;convert base to highest letter used
	caml o5,[char "A"]	;now see if this is a letter-type digit
	 camle o5,o4
	  iret			;not, so leave things alone
    	move o3,[inum rd%dig] ;call it a digit
	iret

;here when base .LT. 10.  Turn digits above base into letters
chkodd:	came o3,[inum rd%dig]	;only look at things now called digits
	 iret
	move o5,nil1		;make the char legal
	makchr o5
	sub o4,[<inum 0>-<char "0">] ;convert base to character
	caml o5,[char "0"]	;see if still legal char
	 caml o5,o4
	  move o3,[inum rd%con]	;no, call random constituent
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;print a string in an array
prarst:	move w2,ah%fil(o1)	;length
	move w3,ah%dsp(o1)	;displacement
	adjbp w3,[010740,,0 ? 030000,,0]
	move o1,o3		;actual object
	jrst prstr1

;;TY%STR
;print a string
prstr:	move w2,o1		;string to print
	dmove w3,[010740,,0 ? 030000,,0] ;byte pointer to start
	move o1,w2
	move w2,(w2)		;get count

;w2 should be the count
;w3/w4 must have relative byte pointer to string, indexed off W3
;o1 should be the string
prstr1:	tlz w2,770000
	push q,o1		;save string in place where GC will adjust
	push p,w2
	push p,w3		;W2 is addr of TY%SPC - data in next wd
	push p,w4		;indexed off W3, which will have the string
	move o1,[char 42]	;open "
	skipe @[.PRESC]		;but only if *PRINT-ESCAPE*
	call tyo
pratlp:	move w3,(q)		;get start of string
	sosge -2(p)
	 jrst praten
	ildb w2,-1(p)		;get next byte to print
	skipn @[.PRESC]		;see if need to check
	jrst pratl0		;no
	caie w2,42		;"
	 cain w2,"\"
	  jrst .+2
	    jrst pratl0
	push p,w2		;if " or \, quote with \
	move o1,[char "\"]
	call tyo
	pop p,w2
pratl0:	makchr w2		;make it a char
	move o1,w2
 ;printing
	call tyo
	jrst pratlp

praten:	subi p,3
	subi q,1
	move o1,[char 42]	;end "
	skipe @[.PRESC]		;but only if *PRINT-ESCAPE*
	call tyo
	pop q,o1		;return saved value
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;print a bit vector in an array
prarbv:	move w2,ah%fil(o1)	;length
	move w3,ah%dsp(o1)	;displacement
	adjbp w3,[010140,,0 ? 030000,,0]
	move o1,o3		;actual object
	jrst prbvc1

;;TY%STR
;print a bit vector
prbvc:	skipn @[.PRARY]
	jrst prbvce
	move w2,o1		;string to print
	dmove w3,[000140,,0 ? 030000,,0] ;byte pointer to start
	move o1,w2
	move w2,(w2)		;get count

;w2 should be the count
;w3/w4 must have relative byte pointer to string, indexed off W3
;o1 should be the string
prbvc1:	tlz w2,770000
	push q,o1		;save string in place where GC will adjust
	push p,[0]		;count
	push p,w2
	push p,w3		;W2 is addr of TY%SPC - data in next wd
	push p,w4		;indexed off W3, which will have the string
	movei w2,[asciz /#*/]
	call tyout
prbvlp:	move w3,(q)		;get start of string
	sosge -2(p)
	 jrst prbven
	ildb o1,-1(p)		;get next byte to print
	add o1,[char "0"]
	call tyo
	jrst prbvlp

prbven:	subi p,4
	subi q,1
	pop q,o1		;return saved value
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;print a list
;This routine supplies the ( ) around a list, calling PRINC recursively
; to print the items inside
prlist:	move w2,@[.PRLEV]	;look at print-lev counter
	camg w2,@[.CPRLV]
	jumpn w2,prhash		;too deep, just use #.
	push p,[inum 0]		;this will be the count
 ;note that *PRINT-LEVEL* = NIL is a no-op because of the JUMPN
	push q,o1		;copy orig value so we can work with it
  ;left parent
	move o1,[char 50]	;lparent
	call tyo
  ;now the list of things inside
prlslp:	move o1,(q)		;get car of list
	docar o1,o1
	move w2,@[.PRLEN]	;look at print-length counter
	camg w2,(p)
	jumpn w2,prelpp		;too long, just use ...
 ;note that *PRINT-LENGTH* = NIL causes no limit
	call prinx
	aos (p)
	move o1,(q)
	docdr o1,o1		;now cdr to next elt
	movem o1,(q)
  ;now go to next.  There are several cases
  ; NIL - stop with right parent
  ; cons cell - go on
  ; other thing - use a final dot
	skipn o1		;if nil
	jrst prlsen		;then done
	scons o1		;continue if cdr is cons cell
	jrst prlsdt		;not, do . )
	move o1,[char " " ]	;space before next elt
	call tyo
	jrst prlslp

;here to print # if we are too deep
prhash:	move o1,[char "#"]
	call tyo
	pop q,o1
	ret1

;here to print ... if we are too long
prelpp:	subi p,1
prelp:	movei w2,[asciz /... )/]
	call tyout
	subi q,1
	pop q,o1
	ret1

;here if ends with . X rparent
prlsdt:	movei w2,[asciz / . /]
	call tyout
	move o1,(q)
	call prinx		;now print the last thing
prlsen:	subi q,1		;and forget it
	move o1,[char 51]	;rparent
	call tyo
	pop q,o1		;return original arg
	subi p,1
	ret1

;print a vector
;This routine supplies the #( ) around a vector, calling PRINC recursively
; to print the items inside
prvec:	move w2,-2(o1)
	camn w2,[inum st%str]
	jrst prsruc	
	skipn @[.PRARY]		;if not allowed to print arrays
	jrst prvece		;do the #<> thing
	move w2,@[.PRLEV]	;look at print-lev counter
	camg w2,@[.CPRLV]
	jumpn w2,prhash		;too deep, just use #.
	push q,[inum0] ;and count
  ;left parent
	move o1,[char 43]	;#
	call tyo
	move o1,[char 50]	;lparent
	call tyo
  ;now the list of things inside
prvecl:	move o1,-1(q)		;get object
	move o3,(q)		;and count
	caml o3,-1(o1)		;if something is still left
	jrst prvecx		;no, done
	posnum o3		;compute index
	add o3,o1		;now get address of element
	move o1,(o3)		;and element itself
	move w2,@[.PRLEN]	;look at print-length counter
	camg w2,(q)
	jumpn w2,prelp		;too long, just use ...
	call prinx
	aos o3,(q)		;to next count
	move o1,-1(q)		;object
	caml o3,-1(o1)		;if something still left
	jrst prvecx		;no, done
	move o1,[char 40]	;space
	call tyo
	jrst prvecl

prvecx:	move o1,[char 51]
	call tyo
	subi q,1
	pop q,o1
	ret1

;print a structure
prsruc:	push p,sp
	bindit %STDOUT,o2
	push q,o2
	move o2,@[.CPRLV]
	addi o2,1
	fncall [%OUTSTR],2
	pop q,o2
	pop q,o1
	jrst unbind

;print an array header
;This routine supplies the #A( ) around a vector, calling PRINC recursively
; to print the items inside
prarh:	move w2,-1(o1)		;see how many dim's
	came w2,[inum 5]	;if odd, don't print as string
	 jrst prarh1
	move o3,ah%dat(o1)	;see if this is really a string
	gettyp o3
	caie w2,ty%str
	 cain w2,ty%cst
	  jrst prarst
	cain w2,ty%bvc		;or bit vector
	 jrst prarbv
prarh1:	skipn @[.PRARY]		;if not allowed to print arrays
	jrst prarhe		;do the #<> thing
	move w2,@[.PRLEV]	;look at print-lev counter
	camg w2,@[.CPRLV]
	jumpn w2,prhash		;too deep, just use #.
	move o1,(q)
	push p,sp
	bindit %STDOUT,o2
	push q,o2
	move o2,@[.CPRLV]
	addi o2,1
	move w2,-1(o1)		;see how many dim's
	camle w2,[inum 1]
	 jrst pryar
	fncall [%OUTVEC],2	;vector format if one dim
	pop q,o2
	pop q,o1
	jrst unbind

pryar:	fncall [%OUTARR],2
	pop q,o2
	pop q,o1
	jrst unbind

;entry to print integer vectors
privc:	skipn @[.PRARY]		;if not allowed to print arrays
	jrst privce		;do the #<> thing
	move w2,@[.PRLEV]	;look at print-lev counter
	camg w2,@[.CPRLV]
	jumpn w2,prhash		;too deep, just use #.
	move o1,(q)
	push p,sp
	bindit %STDOUT,o2
	push q,o2
	move o2,@[.CPRLV]
	addi o2,1
	fncall [%OUTVEC],2	;do it in Lisp
	pop q,o2
	pop q,o1
	jrst unbind

;print a hash table
prhtb:	movei w2,[asciz /HASH-TABLE#/]
	jrst prfun

;print an I/O channel
prchn:	movei w2,[asciz /CHN#/]
;common code to print funny pointers
prfun:	push p,w2
	movei w2,[asciz /#</]
	call tyout
	pop p,w2
	call tyout
	move w3,(q)		;print addr
	tlz w3,770000		;clear type code
	setz w2,
	movei n,8.		;in octal
	call ibaset
	call prnmps
	movei w2,[asciz />/]
	call tyout
	pop q,o1
	ret1

;print an undefined object
prerr:	movei w2,[asciz /???#/]
	jrst prfun

;print a constant I/O channel
prcch:	movei w2,[asciz /CCH#/]
	jrst prfun

;print an address
pradr:	movei w2,[asciz /ADR#/]
	jrst prfun		;common code

;print an indirectable address
priadr:	subi q,1
	movei w2,[asciz /IADR#/]
	jrst prfun		;common code

;print a special object
prspc:	movei w2,[asciz /SPC#/]
	jrst prfun

;print a special object
prsp5:	movei w2,[asciz /SP5#/]
	jrst prfun

;print a special object
prs36:	movei w2,[asciz /S36#/]
	jrst prfun

;print a bit vector, if *print-array* is false
prbvce:	movei w2,[asciz /BVC#/]
	jrst prfun

;print a vector, if *print-array* is false
prvece:	movei w2,[asciz /VEC#/]
	jrst prfun

;print an integer vector, if *print-array* is false
privce:	movei w2,[asciz /IVC#/]
	jrst prfun

;print an array, if *print-array* is false
prarhe:	movei w2,[asciz /ARH#/]
	jrst prfun


;;TY%RAT
prrat:	skipe @[.prrad]		;if request to print radix
	call prrad1		;then do so
	move o1,(q)
	push q,1(o1)		;print a ratio:
	move o1,(o1)		;print the numerator
	call prnmnr
	move o1,[char "/"]	;print a slash
	call tyo
	pop q,o1		;print the denominator
	call prnmnr
	pop q,o1		;return the ratio
	ret1

;;this routine is called at the beginning of number i/o to 
; set register n to the appropriate line of bastab (below).
basset:	move n,@[.BASE]
	getnum n
ibaset:	movms n			;for input base, after defaulting
	cail n,2
	 caile n,16.
	  movei n,10.
	subi n,2
	imuli n,5
	add n,[codsec,,bastab]
	iret

;; table of constants for reading/printing in various bases
;; 2 words are used for the base, for use by dmul etc.
;; exp is the highest power of base that can be crammed into
;; two words.  bignums are read and printed in batches of exp digits.
;;	    base	base^exp	 		  exp
bastab:	0 ? 2.	?	400000,,0 ? 0			? 70.
	0 ? 3.	?	325423420677 ? 340306071161	? 54 
	0 ? 4.	?	400000,,0 ? 0			? 35.
	0 ? 5.	?	311745447150 ? 43164733651	? 36 
	0 ? 6.	?	335736203577 ? 273000000000	? 33 
	0 ? 7.	?	51425624134 ? 312645112101	? 30 
	0 ? 8.	?	200000,,0 ? 0			? 23.
	0 ? 9.	?	325423420677 ? 340306071161	? 26 
	0 ? 10.	?	330656,,232670 ? 273650,,0	? 21.
	0 ? 11.	?	221702201600 ? 111105213761	? 24 
	0 ? 12.	?	105215317330 ? 0		? 23 
	0 ? 13.	?	30305035631 ? 337332367351	? 22 
	0 ? 14.	?	134441045406 ? 202661000000	? 22 
	0 ? 15.	?	25272461637 ? 124147374417	? 21 
	0 ? 16.	?	100000,,0 ? 0			? 17.


;;TY%BIG
prbig:	skipe @[.prrad]		;if request to print radix
	call pradix		;then do so
	call basset		;point to right base info
	move o1,(q)		;here's the bignum to print
	getsiz w2,o1		;how big is it?
	caie w2,2		;if 2 wds, use small num print routine
	 jrst prbigx		; if bigger, special bignum routine
	dmove w2,1(o1)		;--for small (2-wd) case:
	jumpge w2,prnum1	;its all set if positive
	move o1,[char "-"]	;else print minus sign
	call tyo
	move o1,(q)
	dmovn w2,1(o1)		;and then print the magnitude
	jrst prnum1

prbigx:	push p,q		;number is >2 wds: use some stack space
	getsiz w4,o1		;p: saved q, number (msw first)
	add o1,w4		;find end of number
	sos o1			;(we reverse the doublewds for division)
	skipge (o1)		;if <0, print "-" and negate it
	 jrst pbxneg		; returns to pbxnrt
	aos o3,p		;o2 = saved p
	addi p,1(w4)
	setzb w2,w3		;we add a 0 doublewd at the beginning
	move nil1,o3		; for simplicity in division
	lsh w4,-1		;count doublewds
pbx1:	dmovem w2,(nil1)	;put on stack
	addi nil1,2		;bump pointer
	dmove w2,(o1)		;get dw from object
	tlz w2,400000		;make sure sign bits are 0
	tlz w3,400000
	subi o1,2		;decr obj ptr
	sojg w4,pbx1		;until done
	dmovem w2,(nil1)
pbxnrt:	move nil1,o3		;now to divide: nil1 moves along # again
	setzb w2,w3		;0,x first time along
pbxdiv:	dmove w4,(nil1)		;third-grade short division w/1-digit divisor
	skipl 2(n)		;divide by base^exp -- if negative, means
	 ddiv w2,2(n)		;base 2 or 4, and base^exp = 2^70
	dmovem w2,(nil1)	;--of course, digits are base 2^70
	dmove w2,w4		;replace dividend with quotient as we go
	addi nil1,2		;--as all we are interested in ultimately
	camg nil1,p		;  is the successive remainders
	 jrst pbxdiv
	move nil1,4(n)		;got a remainder.  divide it by base
pbx21:	dmove w4,w2		; exp times (see bastab)
	setzb w2,w3		;(good old 4-wd dividend)
	ddiv w2,(n)		;base (2 wds)
	makdig o1		;makes an inum for ascii code
	push q,o1		;stack digits on q
	sojg nil1,pbx21		;--exp times...
	skipa nil1,o3		;the # is rapidly shrinking, 
pbx0:	 addi nil1,2		;find where it begins
	caml nil1,p		;--if it doesn't begin, we're done
	 jrst pbx30
	dmove w2,(nil1)		;is this dw = 0?
	skipn w2
	 jumpe w3,pbx0		;yes, look some more
	setzb w2,w3		;no, dividend starts here
	jrst pbxdiv

pbx30:	sos p,o3		;done dividing! reset p, nil, etc.
	setz nil1,o3
pbx31:	pop q,o1		;oh, yeah, and type out the digits
	camn o1,[char "0"]	;--ignoring leading 0's
	 jrst pbx31
	camge q,(p)		;all 0's?
	 jrst [push q,o1 ? move o1,[char "0"] ? jrst .+1]
	skipa			;(1st time have non-0 digit we found above)
pbx32:	 pop q,o1		;get a digit
	call tyo		;type it
	came q,(p)		;is that all?
	 jrst pbx32		;nope
	subi p,1		;q already = this, just discard
	skip
	pop q,o1		;return object printed
	skipe @[.prrad]		;if request to print radix
	call prrdot		;then maybe trailing dot
	ret1

;;negate a number which was negative
pbxneg:	push p,o1		;not an obj just now
	push p,w4
	move o1,[char "-"]
	call tyo
	pop p,w4
	pop p,o1
	aos o3,p		;o3 = saved p
	addi p,1(w4)
	setzb w2,w3		;we add a 0 doublewd at the beginning
	move nil1,o3
	lsh w4,-1
pbxn1g:	dmovem w2,(nil1)	;put on stack
	addi nil1,2		;bump pointer
	setcm w2,(o1)		;get dw from object
	tlz w2,400000		;make sure sign bit is 0
	setcm w3,1(o1)
	tlz w3,400000
	subi o1,2		;decr obj ptr
	sojg w4,pbxn1g		;until done
	dmovem w2,(nil1)	;that was a one's complement..
	aos nil1		;point to next wd
pbxn2g:	aosl (nil1)		;add one to it
	 jrst pbxnrt		;stops when carry does
	setzm (nil1)
	soja nil1,pbxn2g

;;TY%INT
;;WORK	2	holds base for number output
prnint:	skipe @[.prrad]		;if request to print radix
	call pradix		;then do so
	move o1,[char "-"]	;print sign
	call tyo
	move w2,(q)		;move sign stuff to here when we
	negnum w2		;flush the -base foolishness
	movms w2
	jrst prnum0
prpint:	skipe @[.prrad]		;if request to print radix
	call pradix		;then do so
	move w2,(q)		;get the number, leaving it as ret val
	posnum w2		;numerical form
prnum0:	ashc w2,-35.		;flushed -base cruft
prnum1:	call basset
	call prnmps		;print it
	skipe @[.prrad]		;if request to print radix
	call prrdot		;then maybe trailing dot
	pop q,o1		;return arg
	ret1

;here if *print-radix* is T.  Print radix specifier if appropriate
;prradx - print appropriate # thing for radix, except if decimal
pradix:	move w2,@[.BASE]
	camn w2,[inum 10.]	;base 10 will be done by trailing period
	iret
;this entry allows printing of radix 10 also
prrad1:	move w2,@[.BASE]
	camn w2,[inum 2.]
	 jrst prrd2
	camn w2,[inum 8.]
	 jrst prrd8
	camn w2,[inum 16.]
	 jrst prrd16
	move o1,[char "#"]
	call tyo
	move o1,@[.BASE]
	call prnm10
	move o1,[char "r"]
	call tyo
	iret

prrd2:	move o1,[char "#"]
	call tyo
	move o1,[char "b"]
	call tyo
	iret

prrd8:	move o1,[char "#"]
	call tyo
	move o1,[char "o"]
	call tyo
	iret

prrd16:	move o1,[char "#"]
	call tyo
	move o1,[char "x"]
	call tyo
	iret



;prrdot - print trailing dot if appropriate
prrdot:	move w2,@[.BASE]
	came w2,[inum 10.]	;base 10 will be done by trailing period
	iret
	move o1,[char "."]
	jrst tyo


;PRNM10 - printer number in base 10, no radix labelling
prnm10:	push p,sp		;[RAF 4/26/82] no point after exp
	push sp,[%PRRAD]
	push sp,@[.PRRAD]
	setzm @[.PRRAD]
	push sp,[%BASE]
	push sp,@[.BASE]
	move w2,[inum 10.]
	movem w2,@[.BASE]
	call prinx
	jrst unbind		;[RAF 4/26/82] end

;PRNMNR - printer number current radix, no radix labelling
prnmnr:	push p,sp		;[RAF 4/26/82] no point after exp
	push sp,[%PRRAD]
	push sp,@[.PRRAD]
	setzm @[.PRRAD]
	call prinx
	jrst unbind		;[RAF 4/26/82] end

;; floating printers follow.  they do not use BASE, as floating #s
;; are always read and printed base 10. (decimal).

;print an iflon. 
prifl:	push p,[char "F"]	;single precision
	push p,[9.]		;print 9 digits
	move w2,o1		;put it in w2/3
	lsh w2,4
	setz w3,
	jrst prreax

;prrea - prints a real number.  There are three sections of code.
;  For numbers between 10e-3 and 10e7, we use F format.  
;  For other numbers we use E format, and there is separate code
;   for those bigger than 10e7 and those smaller than 10e-3
;  These routines are designed to print the exact representation,
;   up to as many digits as specified.  This is important if we
;   are to be able to write out any floating point number and read
;   it back in as exactly the same bit pattern.  This constraint
;   complicates the algorithm seriously.

;real in w2/w3
;exponent letter: -6
;digits: -5
;afterdot: -4
;zeros:  -3
;leading: -2
;number: -1/0
prrea:	push p,[char "D"]	;double precision
	push p,[21.]		;print 21 digits
	move o1,(q)		;get value to w2/3
	dmove w2,1(o1)
prreax:	addi p,5		;allocate locals
	skipl w2		;negative?
	jrst prrnng		;no
;here for negative floats
	push p,w2
	push p,w3
	move o1,[char "-"]
	call tyo
	pop p,w3
	pop p,w2
	dmovn w2,w2		;and use positive form
;here after sign done, number in w2/w3
prrnng:	caml w2,[10000000.0]	;is F form OK?
	 jrst prrbig		;no, too big
	camg w2,[0.001]
	 jrst prrsml		;no, too small
;here for numbers between 10e-3 and 10e7.  Print in F format.
;We shift the digits before the decimal place into an integer, and
;print it using a normal integer print routine.  Those after the
;decimal point are printed by repeatedly multiplying by 10.
;the routine to handle after the point is complicated by trying
;to suppress trailing zeros, and by making sure that we print
;at least one digit after the decimal point.
	ldb w4,[.bp 377_27.,w2]	;w4 _ exponent
	setz nil1,		;clear word we are going to shift into
	tlz w2,777000		;and exponent bits
	lshc nil1,10.-201(w4)	;shift integer part into nil1
	movn o1,w4		;now put the rest back
	lsh w2,201-10.(o1)
	ashc w2,9.-201(w4)	;left justify the fractional part
	dmovem w2,-1(p)		;save the fraction
	jumpn nil1,prrnzi	;if non-zero, continue
;here if integer part is zero
	move o1,[char "0"]
	call tyo
	setom -2(p)		;say leading zero
	jrst prrnzz		;done
;here if integer part is non-zero
prrnzi:	push q,[inum 0]		;will count digits printed here
	call prrint		;print nil1, the integer part
	pop q,w2
	getnum w2		;w2 is - of number of digits printed
	addm w2,-5(p)		;adjust number of digits needed
	setzm -2(p)		;say not leading zero
prrnzz:	setzm -3(p)		;say no suppressed zeros
	setzm -4(p)		;say nothing printed yet
	move o1,[char "."]
	call tyo
; -5 signif digits requested
; -4 digits printed after dot
; -3 zeros suppressed
; -2 we are printing leading zeros
prrflp:	skipg -5(p)		;more to print
	jrst prrflx		;no
	dmove w2,-1(p)		;get back fraction
	dmul w2,[0 ? 10.]	;next digit in w3, remainder w4,5
	dmovem w4,-1(p)
	jumpn w3,prrnzr		;non-zero is fairly easy
;here to print zero.  Both leading and trailing are odd
	skipn -2(p)		;leading?
	jrst prrtrz		;no, trailing
;leading zero
	move o1,[char "0"]	;always print it
	call tyo
	aos -4(p)		;something printed
	jrst prrflp		;and nothing else changes
;trailing zero
prrtrz:	sos -5(p)		;it is signifcant
	aos -3(p)		;suppress printing it
	jrst prrflp		;go look at next digit
;non-zero
prrnzr:	setzm -2(p)		;no longer in leading zero section
	add w3,[char "0"]	;turn thing to print into digit
	push q,w3		;save it
	skipg -3(p)		;any suppressed zeros?
	jrst prrnzx		;no
prrnzl:	move o1,[char "0"]	;yes
	call tyo
	aos -4(p)		;something printed
	sose -3(p)
	jrst prrnzl		;if more to do, do them
prrnzx:	pop q,o1		;now get back real digit
	call tyo
	aos -4(p)		;something printed
	sos -5(p)		;one more significant digit
	jrst prrflp		;see if more
;here when done
prrflx:	skipe -4(p)		;if nothing printed after decimal pt.
	jrst prradx
	move o1,[char "0"]	;then we need one zero
	call tyo

prradx:	subi p,6
	pop p,o1		;get correct exponent for number
	move w2,@[.RDDFLT]	;compare with read default
	move w3,[char "F"]	;assume single
	came w2,[%DBLFLT]	;except if double
	 camn w2,[%LNGFLT]
	  move w3,[char "D"]
	camn w3,o1		;if actual and default match
	jrst prrf6		;then that's all
	call tyo		;else put out marker
	move o1,[char "0"]
	call tyo
prrf6:	pop q,o1		;return the arg
	ret1

;print odd cases, zero and negative zero
prrodd:	jumpe w2,prrzro

;here for negative zero.  Note that this code thinks we now have
;a positive number, since it does dmovn for negatives.  -0 is the
;only case for which dmovn is still negative.  Simply replace it
;with the largest number and try again.  A minus sign has already
;been printed.

	dmove w2,[377777,,777777 ? 377777,,777777]
	jrst prrbig		;this is certainly big!

prrzro:	movei w2,[asciz /0.0/]
	call tyout
	jrst prradx

;print integer in nil1, decrementing digits
;at the end, nil1 is always 0
prrint:	idivi nil1,10.		;quot nil1, remainder w2
	push p,w2
	skipe nil1		;if anything to print first
	call prrint		;do so
	pop p,o1		;now print our thing
	add o1,[char "0"]
	sos (q)			;count digits
	call tyo
	iret

;prrbig is part of prrea, for numbers bigger than 1e7.  This
;uses a similar algorithm to the default case, except that
;it is printing in E format.  In order to make things exact,
;we have to use quad-word integer arithmetic.

;real in w2/w3
;digits: -6
;integer: -5/-4/-3/-2
;fraction: -1/0
prrbig:	addi p,1		;need one more local
	setzm -5(p)
	setzm -4(p)
	setzm -3(p)
	setzb nil1,-2(p)
	setzm -1(p)
	setzm (p)
	ldb w4,[.bp 377_27.,w2]	;w4 _ exponent
	tlz w2,777000		;and exponent bits
	subi w4,201-9.		;n _ number of bits to shift
	idivi w4,35.		;4 _ words, 5 _ bits
	xmovei n,-2(p)		;where to put integer if no word shift
	sub n,w4		;n _ where to put high order end of integer
	ashc nil1,(o1)		;nil1 _ high order integer word
	movn o1,o1
	ash w2,(o1)		;put the bits still in w2 back the right place
	movn o1,o1
	ashc w2,(o1)		;now get w2/w3 aligned right
	movem nil1,(n)		;put the three words away
	dmovem w2,1(n)
;since this number is .GT. 10^7, we must have an integer part.
	move w2,-6(p)		;number of digits requested
	maknum w2	
	push q,w2		;tell subroutine how many digits
	push q,[nil]		;flag for first digit done
	dmove nil,-5(p)		;pass the integer part as arg
	dmove w2,-3(p)
	call prrbnt		;print nil1, the integer part
;digits: -5
;exponent: -2
;fraction: -1/0
	move w2,-1(q)		;digits left to print (could be .LT. zero)
	getnum w2
	movem w2,-5(p)		;save current value
	sub w2,-6(p)		;number of digits before the decimal point
	movn w2,w2		;in positive form
	subi w2,1		;this is the exponent
	movem w2,-2(p)
prrbgl:	skipg -5(p)		;more to print
	jrst prrbgx		;no
	dmove w2,-1(p)		;get back fraction
	dmul w2,[0 ? 10.]	;next digit in w3, remainder w4,5
	dmovem w4,-1(p)
	add w3,[char "0"]	;turn thing to print into digit
	move o1,w3
	call tyo
	sos -5(p)		;one more significant digit
	jrst prrbgl		;see if more
;here when done
prrbgx:	move o1,-7(p)
	call tyo
	move nil1,-2(p)
	move w2,[inum 0]
	movem w2,(q)		;dummy arg for prrint
	call prrint
	subi p,8.
	subi q,2
	pop q,o1		;return value
	ret1

;special quadword integer print
; -1(q) - number of digits to print
; 0(q)  - nothing printed yet
;0/1/2/3 - number to print
;at the end, nil and nil1 are always zero
prrbnt:	
;divide by 10, quotient same place, remainder in 4
	move w4,nil
	idivi w4,10.
	movem w4,nil
	move w4,o1
	move o1,nil1
	divi w4,10.
	movem w4,nil1
	move w4,o1
	move o1,w2
	divi w4,10.
	movem w4,w2
	move w4,o1
	move o1,w3
	divi w4,10.
	movem w4,w3
	move w4,o1
;now have quotient in 0-3, remainder in 4
	push p,w4		;save remainder
	jumpn nil,prrbnr	;if anything left in number, recurse
	jumpn nil1,prrbnr
	jumpn w2,prrbnr
	skipe w3
prrbnr:	call prrbnt		;recursively print number
	pop p,o1		;now print our thing
	add o1,[char "0"]
;algorithm is guaranteed to leave these this way
;	setzb nil,nil1		;restore lisp context
	move w2,-1(q)		;number of digits left to print
	sos -1(q)		;count digits
	camle w2,[inum 0]	;if still want to print
	call tyo		;do so
	move o1,[char "."]	;decimal point
	skipe (q)		;if after first digit
	iret
	call tyo
;The following can be changed when this is integrated into
;boot.mid.  I needed something that would be nonzero in
;both boot.mid and the stripped down testing code.
	move o1,[char "X"]	;have done one, so set flag
	movem o1,(q)
	iret


;prrsml is part of prrea, for numbers smaller than 1e-3.  This
;uses a similar algorithm to the default case, except that
;it is printing in E format.  In order to make things exact,
;we have to use 6-word integer arithmetic.

;real in w2/w3
;digits: -8
;printed: -7
;exp: -6
;fraction: -5/-4/-3/-2/-1/0
prrsml:	jumpn w3,.+2		;if w3 is nonzero, can't be wierd
	jumple w2,prrodd	;odd cases are zero and negative zero
prrreg:	addi p,3		;need one more local
	setzm -5(p)
	setzm -4(p)
	setzm -3(p)
	setzb nil1,-2(p)
	setzm -1(p)
	setzm (p)
	ldb w4,[.bp 377_27.,w2]	;w4 _ exponent
	tlz w2,777000		;and exponent bits
	subi w4,201-9.		;n _ number of bits to shift
	idivi w4,35.		;4 _ words, 5 _ bits
;I find it easier to deal with left shifts, so move 5 positive
	jumpe o1,prrsmn
	addi o1,35.		;make bits positive
	subi w4,1		;and adjust words accordingly
prrsmn:	xmovei n,-6(p)		;where to put integer if no word shift
	sub n,w4		;n _ where to put high order end of integer
	ashc nil1,(o1)		;nil1 _ high order integer word
	movn o1,o1
	ash w2,(o1)		;put the bits still in w2 back the right place
	movn o1,o1
	ashc w2,(o1)		;now get w2/w3 aligned right
	movem nil1,(n)		;put the three words away
	dmovem w2,1(n)
	setom -7(p)		;say nothing printed yet
	setom -6(p)		;exponent if no leading zeros
;since this number is .LT. 10^-3, we have only a fraction
prrsll:	skipg -8(p)		;more to print
	jrst prrsmx		;no
	dmove w2,-1(p)		;get back fraction
	dmul w2,[0 ? 10.]	;
	dmovem w4,-1(p)
	dmove nil,w2		;carry to nil
	dmove w2,-3(p)
	dmul w2,[0 ? 10.]
	dadd w4,nil		;add in carry
	tlze w4,400000		;if it overflows
	 dadd w2,[0 ? 1]	;then carry that too
	dmovem w4,-3(p)
	dmove nil,w2		;carry out
	dmove w2,-5(p)
	dmul w2,[0 ? 10.]
	dadd w4,nil		;carry in
	tlze w4,400000
	 dadd w2,[0 ? 1]
	dmovem w4,-5(p)
	setzb nil,nil1
;digit now in w3
	jumpn w3,prrsnz		;go if nonzero
	skipl -7(p)		;or if non-leading
	jrst prrsnz
;here for leading zero
	sos -6(p)		;simply adjust exponent
	jrst prrsll
;here if something to print
prrsnz:	add w3,[char "0"]	;turn thing to print into digit
	move o1,w3
	call tyo
	move o1,[char "."]	;put point in
	aosn -7(p)		;if needed
	call tyo
	sos -8(p)		;one more significant digit
	jrst prrsll		;see if more
;here when done
prrsmx:	move o1,-9.(p)		;get correct exponent marker
	call tyo
	move o1,[char "-"]	;exponent always negative
	call tyo
	movn nil1,-6(p)		;get positive exponent
	push q,[inum 0]		;dummy arg for prrint
	call prrint
	subi q,1
	subi p,10.
	pop q,o1		;return original arg
	ret1

;;WORK
;recursive printer, number in w2.  Will print 36-bit numbers in positive form
prnmps:	dmove w4,w2		;move w2 to w2,w3 as double word
	setzb w2,w3		;now standard recursive printer
	ddiv w2,(n)		;base
	push p,o1		;save digit, retrieve base
	skipn w2		;but someone else has to print rest
	 skipe w3
	  call prnmps		;(unless zero, of course)
	pop p,w3
	makdig w3		;make char
	move o1,w3
	call tyo
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; now the normal entries
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

prin1:	move o2,@[.stdout]	;default value
	oustrm o2
iprin1:	push p,sp
	push p,[codsec,,ubdr1v]
	move w2,[%T]
	bindit %PRESC,w2
	jrst iprin

princ:	move o2,@[.stdout]	;default value
	oustrm o2
	push p,sp
	push p,[codsec,,ubdr1v]
	bindit %PRESC,nil
	jrst iprin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; %sp-write-string
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;o1 - string
;o2 - channel
;o3 - start
;o4 - end

wrtstr:	oustrm o2
	skipn o3		;if no start
	move o3,[inum 0]	;default to beginning
;handle complex arrays
	gettyp o1
	caie w2,ty%str
	 cain w2,ty%cst
	  jrst wrtst1		;yes, it's really a string
	caie w2,ty%arh
	 jrst getste		;not a string
	xtype ah%dat(o1)	;make sure it is really a string
	caie w2,ty%xst
	 jrst getste		;no error
	getnum o3
	add o3,ah%dsp(o1)	;add array displacement to start
	skipn o4		;specified end?
	move o4,ah%fil(o1)	;no, use fill pointer
	getnum o4
	add o4,ah%dsp(o1)	;yes, offset it by displacement
	move o1,ah%dat(o1)	;and use data vector
;now have a real string in O1, offset for start in O3
wrtst1:	
;now figure out beginning and end
	move w2,o3		;get start displacement
	getnum w2
	move w3,(o1)		;size as SPEC
	tlc w3,(<object ty%sp5>#<object ty%lpi>) ;convert to integer
	skipn w4,o4		;if no end
	move w4,w3		;then use end of string
	sub w4,w2		;now have the number of chars
	adjbp w2,[010740,,0 ? 030000,,0] ;byte pointer indirect off W3
	push p,w2
	push p,w3
	getnum w4
	push p,w4
	push q,o1
;-2(p) - byte point
;(p) - count
;(q) - string
wrtstl:	sosge (p)
	jrst wrtstx
	move w3,(q)		;byte pointer assumes string is here
	ildb o1,-2(p)
	makchr o1
	call tyo
	jrst wrtstl

wrtstx:	pop q,o1
	subi p,3
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; print to string
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;STPRNX - the basic routine
;  to speed things up, we keep a single string output stream
;	around, in DFOUST.  Normally we just use that.
;	But it is possible that this routine could be called
;	recursively, if one of the print functions happens to use
;	this.  In that case we want to force a new stream to be
;	created.  Hence we rebind DFOUST to NIL here.
;the caller must do an UNBIND
stprnx:	skipn o2,@[.dfoust]	;this is normally an output stream
	jrst [	push q,o1	;save the thing to print
		call oustrg	;get a new stream
		movem o1,@[.dfoust] ;save for later
		move o2,o1	;into O2
		pop q,o1
		jrst .+1]
	bindit %DFOUST,nil	;rebind this, in case of recursive call

;we reinit the stream, in case we aborted something due to an error
;having ch%bct = 0 will force a new buffer to be allocated the first
;time PUT is called.

	setzm ch%obl(o2)
	setom ch%pag(o2)
	setzm ch%bct(o2)
	call iprin
	move o1,o2
	jrst getost
	;our caller does UNBIND

;PRIN1-TO-STRING
prin1s:	push p,sp
	push p,[codsec,,ubdr1v]
	move w2,[%T]
	bindit %PRESC,w2
	jrst stprnx

;PRINC-TO-STRING
princs:	push p,sp
	push p,[codsec,,ubdr1v]
	bindit %PRESC,nil
	jrst stprnx

;STRINGIFY-OBJECT
stfyob:	move o2,@[.PRESC]
	push p,sp
	bindit %PRESC,o2
	call stprnx
	jrst ubdr1v

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;other random print things
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
terpri:	move o1,@[.stdout]	;default output
	move o2,o1
	oustrm o2
iterpr:	move w2,ch%dsp(o2)
	call @ch%trp(w2)
	jrst retnil

;lines0 - terpri if not at start of line
lines0:	move o1,@[.stdout]	;default channel
	move o2,o1
	oustrm o2
lin0:	move w2,ch%dsp(o2)
	call @ch%lps(w2)	;get position in line in W2
	skipg w2		;beyond start?
	jrst retnil		;at beginning, nothing to do
	jrst iterpr

;;;;; get line position
chrpos:	move o1,@[.stdout]	;default to std output
	oustrm o1		;validate it
	move o2,o1
	move w2,ch%dsp(o2)
	call @ch%lps(w2)
	jrst ret1nt

print:	move o2,@[.stdout]	;default output
	oustrm o2
	push q,o1		;save arg
	call iterpr
	move o1,(q)		;get back arg
	call iprin1
	move o1,[char 40]
	call tyo
	pop q,o1		;return arg
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  device control
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;[Victor] Check the arg in o1 instead of o2!!!

finout:	move o1,@[.stdout]	;default
	oustrm o1
	move w2,ch%dsp(o1)
	jrst @ch%fin(w2)

frcout:	move o1,@[.stdout]	;default
	oustrm o1
	move w2,ch%dsp(o1)
	jrst @ch%frc(w2)

clrout:	move o1,@[.stdout]	;default
	oustrm o1
	move w2,ch%dsp(o1)
	jrst @ch%cbo(w2)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  read
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;The read table is a vector with 3 elements:
;  character-attribute table - 128-element vector of integers
;  character-macro table - 128-element vector of functions
;  dispatch table - a-list character to 128-element vectors of functions

rt%atr==0	;character attribute table
rt%rdm==1	;character macro table
rt%dsp==2	;dispatch table

;RDTAB is a macro for refering to the current character attribute table.
; Y must contain a legal Lisp object
define rdtab(x,y,offset)
	move o6,y
	and o6,[770000,,177]
	move x,@[.crdtab]		;x is now read table
	move x,@offset+1(x)		;get the O6'th entry of attr tab
	termin

;RDTABR is like RDTAB, but it loads only the RH of the word
; Y must contain a legal Lisp object
define rdtabr(x,y,offset)
	move o6,y
	and o6,[770000,,177]
	move x,@[.crdtab]		;x is now read table
	hrrz x,@offset+1(x)		;get the O6'th entry of attr tab
	termin

;RDTABC is like RDTAB, but the contents of Y is a bare number.
;We have to clear O6 after that, since O6 must contain a legal
;Lisp object at the next GC.  Note that we can't use a different
;AC, since the type code for a vector requires O6.
define rdtabc(x,y)
	rdtab(x,y)
	setz o6,
	termin

;The actual table is elsewhere, to keep the code pure

;MAKRDT - create a read table initialized from irdatr and irdrdm
;return it in O1
makrdt:	
;first the top-level vector
	push free,[inum st%str]	;DEFSTRUCT
	push free,[inum 4]
	xmovei o1,1(free)	;this is what we will return
	tlo o1,(object(ty%vec,0))
	xmovei o2,1+4+2(free)	;this is the attribute vector
	tlo o2,(object(ty%vec,0))
	xmovei o3,1+4+2+128.+2(free) ;this is the read-macro vector
	tlo o3,(object(ty%vec,0))	
	push free,[%READTABLE]	;name of package
	push free,o2
	push free,o3
	push free,nil		;no dispatch as yet
;now attribute vector
	push free,[inum st%vec]
	push free,[inum 128.]
	movei w2,128.
	xmovei w3,irdatr	;from here
	xmovei w4,1(free)	;to here
	xblt w2,
	addi free,128.
;now read macro vector
	push free,[inum st%vec]
	push free,[inum 128.]
	movei w2,128.
	xmovei w3,irdrdm
	xmovei w4,1(free)
	xblt w2,
	addi free,128.
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SET-MACRO-CHARACTER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;o1 - char
;o2 - function
;o3 - [opt] non-terminating-p, default NIL
;o4 - [opt] read table, default *readtable*
smachr:	move o3,nil		;2 args, default non-term
	move o4,@[.crdtab]	;3 args, default read table
;set the entry in the attribute table to the secondary attribute for this char
	move o6,o1		;get char in position to index into table
	move o1,[inum rd%ntr]	;make it nonterminating
	skipn o3		;except if not non-terminating-P
	move o1,[inum rd%trm]	;then making it terminating
	movem o1,@rt%atr+1(o4)	;put it in the attribute table
;set that actual read macro entry
	movem o2,@rt%rdm+1(o4)
	move o1,[%T]		;well, that's what the manual says
	ret1

;the first two are delimiters.  You can test this as .LEQ. rd%trm
rd%wht==0	;whitespace
rd%trm==1	;terminating macro
rd%ntr==2	;non-terminating macro
rd%esc==3	;escape
rd%mes==4	;multiple-escape
;at the moment, the illegal syntax class is not implemented.  This
;  is legal, since the manual does not specify any character that
;  must have this attribute, and the only primitive for setting 
;  attributes is set-syntax-from-char.  I do implement the
;  illegal constituent attribute.  This differs in only one way:
;  You can put a constituent illegal character into a symbol by
;  using multiple escape, whereas you cannot put an illegal character
;  in that way.
;the following are all consituents.  You can test this as .GEQ. rd%con
rd%con==5	;constituent
rd%dot==6	;constituent-dot
rd%exp==7	;constituent-expt
rd%slh==10	;constituent-slash
rd%dig==11	;constituent-digit
rd%xdg==12	;constituent-letter-digit
rd%ddg==13	;constituent-decimal-digit
rd%sgn==14	;constituent-sign
rd%pkg==15	;package-delimiter
rd%ill==16	;constituent-illegal

;instrm ac is used to normalize a stream argument
define instrm(ac)
	camn ac,[%T]
	move ac,@[.trmio]
	skipn ac
	move ac,@[.stdin]
	xtype ac
	caie w2,ty%xch
	jrst [err1 ac,/Not a stream: ~S/]
   termin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-BYTE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;note that as an extension we allow read-byte and read-char to be
;mixed on the same channel.

;all but first are optional
;o1 - stream
rdbyte:	move o2,[%T]		;eof-errp
	move o3,nil		;eof-value
	instrm o1
	push q,o2		;save eof stuff over call
	push q,o3
	move o2,o1		;get channel to where desired
	call @ch%get(o2)
	 jrst rdchef		;eof
	 jfcl			;CR is a normal char
	subi q,2		;normal return
	hrrz w3,ch%typ(o2)	;get object type
	xct .+1(w3)
	jrst retchr		;7 bit char
	jrst retchr		;full char
	jrst ret1nt		;unsigned byte
	jrst getsgn		;signed byte

retchr:	move o1,w2
	makchr o1
	ret1

;the following code is not needed for 36-bit byte size, so
;  signed 36-bit bytes are implemented as unsigned.
getsgn:	hlrz w4,ch%typ(o2)	;number of bits in byte
	movei w3,36.
	sub w3,w4
	lsh w2,(w3)
	movn w3,w3
	ash w2,(w3)
	jrst ret1nt

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-CHAR
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;all args are optional
rdchar:	move o1,@[.stdin]	;set up omitted args: stream
	move o2,[%T]		;eof-errp
	move o3,nil		;eof-value
	move o4,nil		;recursivep. for now we ignore this
	instrm o1
irdchr:	push q,o2		;save eof stuff over call
	push q,o3
	move o2,o1		;get channel to where desired
	call tyie
	 jrst rdchef		;eof
	subi q,2		;normal return
	ret1

;here for EOF
rdchef:	skipe -1(q)		;does he want an error?
	jrst eoferr		;yes, give it to him
	move o1,(q)		;no, give him what he wanted
	subi q,2		;saved junk
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-CHAR-NO-HANG
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;all args are optional
rdchnh:	move o1,@[.stdin]	;set up omitted args: stream
	move o2,[%T]		;eof-errp
	move o3,nil		;eof-value
	move o4,nil		;recursivep. for now we ignore this
	instrm o1
	move w2,ch%dsp(o1)	;get dispatch vector
	call @ch%lsn(w2)	;see if there is input
	jumpl w2,retnil		;if buffer empty, return NIL
	jrst irdchr		;otherwise go to READ-CHAR

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PEEK-CHAR
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;all args are optional
peekch:	move o1,nil		;peek type
	move o2,@[.stdin]	;set up omitted args: stream
	move o3,[%T]		;eof-errp
	move o4,nil		;eof-value
	move o5,nil		;recursivep. for now we ignore this
	instrm o2
	push q,o3		;save EOF stuff for RDCHEF
	push q,o4
	jumpe o1,peekdo		;do the real peek
;here if have to skip something first
	came o1,[%T]
	jrst peektg		;here if skip for specific target
;here to skip whitespace
peekwl:	call tyie
	 jrst rdchef
	rdtabr w2,o1		;see what it is
	cain w2,rd%wht		;skip if white
	jrst peekwl		;white-space loop
	jrst peekun		;found something real, ready for UNREAD

;here to skip particular target
peektg:	push q,o1		;save target
peektl:	call tyie
	 jrst peekte		;end of file
	camn o1,(q)		;found target?
	jrst peekt1		;yes, do UNREAD
	jrst peektl		;no, loop some more

peekte:	subi q,1
	jrst rdchef		;canonical EOF processing
peekt1:	subi q,1
	jrst peekun		;do UNREAD

;here when no initial skipping
peekdo:	call tyie
	 jrst rdchef		;EOF

;entry for doing UNREAD
peekun:	call @ch%unr(o2)
	subi q,2		;normal return
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; UNREAD-CHAR
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;TY%CHN
unrdch:	jfcl			;ignore first arg
	move o2,@[.stdin]	;set up omitted args: stream
	instrm o2
	call @ch%unr(o2)	;do the unread
	move o1,nil		;returns NIL
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LISTEN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

listen:	move o1,@[.stdin]	;default if no stream
	instrm o1
	move w2,ch%dsp(o1)	;dispatch vector
	call @ch%lsn(w2)	;call listen
	jumple w2,retnil	;eof or buffer empty
	jrst rett

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CLEAR-INPUT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

clrinp:	move o1,@[.stdin]	;default if no stream
	instrm o1
	move w2,ch%dsp(o1)	;dispatch vector
	call @ch%cbi(w2)	;call clear buffer
	jrst retnil		;always returns nil

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FILE-POSITION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

filpos:	setz o2,nil		;default is return current
	instrm o1		;validate channel
	jumpn o2,setpos		;if second arg, set position
;here to return current position
	move o2,o1		;lower-level routine wants it in O2
	move w2,ch%dsp(o1)	;dispatch vector
	call @ch%cps(w2)	;call curpos
	jrst retnil		;failed, return NIL
	jrst ret1nt		;return integer

;here to set position
setpos:	exch o2,o1		;file to O2, position to O1
	camn o1,[$start]
	move o1,[inum 0]
	camn o1,[$end]
	move o1,[inum -1]
	call get1nt		;integer to W2
	move w3,ch%dsp(o2)	;dispatch vector
	call @ch%sps(w3)	;call setpos
	jrst retnil		;failed
	jrst rett		;succeeded

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-MAYBE-NOTHING
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;READ-MAYBE-NOTHING
;char in O1, stream in O2
;calls the macro entry for O1.
;if N=0, it didn't return anything, else value in O1
define rdmayn			;char in O1, stream in O2
	call rdmdsp
	termin

rdmdsp:	rdtab w2,o1,rt%rdm	;get read macro entry
	tlnn w2,(object(ty%num,0))
	jrst rdmdsx		;not a number, must be a real object
;here if the read macro is really an address.  Just call it
	exch o1,o2		;get args in the right places
	call (w2)
	retn			;pass MV's

;here to call a real function object
rdmdsx:	exch o1,o2		;get args in right places
	fncall w2,2
	retn			;pass MV's

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; FLUSH-WHITESPACE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1 - stream.  Wants EOFERP = T

uflswt:	move o2,o1
	instrm o2
	jrst flswht
;entry for internal use. assumes channel is in O2
;O2 is preserved
flswht:	call tyi
	rdtabr w2,o1		;see what it is
	cain w2,rd%wht		;skip if white
	jrst flswht
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-PRESERVING-WHITE-SPACE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;all args are optional
rdpws:	move o1,@[.stdin]	;set up omitted args: stream
	move o2,[%T]		;eof-errp
	move o3,nil		;eof-value
	move o4,nil		;recursivep
	instrm o1
;internal entry when all 4 args valid
irdpws:	push p,sp
	jumpn o4,rdpwnt
;if top-level entry, rebind some things
	bindit %EOFERP,o2
	bindit %EOFVAL,o3
	setzm @[.SHPEQL]	;reinit the sharp stuff
	setzm @[.SHPSHP]	;reinit the sharp stuff
rdpwnt:	push q,o1		;save channel
rdpwsl:	move o2,(q)		;get back channel
	call tyie
	 jrst rdpwef		;eof
	rdtabr w2,o1		;see what we have
	cain w2,rd%wht		;if whitespace
	jrst rdpwsl		;skip it
	rdmayn			;call read macro
	jumpe n,rdpwsl		;if no values, try again
	subi q,1		;saved channel
	jrst ubdr1v		;else return what the macro did

;here for EOF
rdpwef:	skipe @[.EOFERP]	;does he want an error?
	jrst eoferr		;yes, give it to him
	move o1,@[.EOFVAL]	;no, give him what he wanted
	subi q,1		;saved channel
	jrst ubdr1v

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;all args are optional
read:	move o1,@[.stdin]	;set up omitted args: stream
	move o2,[%T]		;eof-errp
	move o3,nil		;eof-value
	move o4,nil		;recursivep
	instrm o1
iread:	push q,o1		;save stream
	push q,o4		;save recursivep
	push p,sp
	call irdpws		;passing all 4 args
	push q,o1		;save returned value
;now skip whitespace.  We gobble something, and unread it if it isn't
	move o2,-2(q)		;get back channel
	call tyie		;gobble what we hope is whitespace
	 jrst readex		;if EOF, can't unread it anyway
	rdtabr w2,o1		;see what we have
	caie w2,rd%wht
	jrst readut		;not whitespace: we really didn't want this
	skipn -1(q)		;or if recursive
	jrst readex		;not recursive and whitespace, leave it
readut:	call @ch%unr(o2)
readex:	pop q,o1		;get value to return
	subi q,2		;kill saved recursivep
	jrst ubdr1v

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-FROM-STRING
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;this is the internal version.  Args are
; o1- string
; o2- eoferrp
; o3- eofvalue
; o4- start
; o5- end
; (q) - preserve-whitespace
;because read can trigger arbitrary code, we have to cons up a new
;  channel for the string input

stread:	push q,o2		;save I/O variables
	push q,o3
	dmove o2,o4		;and get args for instrg
	skipn o2		;instrg will normalize O3, but not O2
	move o2,[inum 0]
	call instrg+2		;have 2 optional args
	dmove o2,-1(q)		;get back args to read
	setz o4,		;and say not recursive
	skipe -2(q)		;preserve white?
	 jrst [ movem o1,-2(q)	;save channel
		call irdpws	;yes
		jrst .+3]
	movem o1,-2(q)		;save channel
	call iread		;else normal read
	move o2,-2(q)		;get back channel
	move o2,ch%cby(o2)	;number of chars read
	maknum o2
	subi q,3		;also gets rid of original 6th arg
	ret2			;returning 2 values

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-EXTENDED-TOKEN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;read the string up to the next delimiter.  Leaves resulting token
;;in read-buffer, returns a flag that is true if an escape (\\)
;;appeared, meaning that it has to be a symbol.

;o1 - stream
;o2 - opt readtable

rdextk:	move o2,@[.crdtab]	;default to current read table
	instrm o1
	push p,sp
	bindit %CRDTAB,o2	;this is how we use a read table
	move o2,o1		;I/O functions want stream in O2
	push q,[nil]		;flag for escape appeared
	hrlzi w3,440740		;w3/4 is byte ptr
	xmovei w4,2(free)
	push p,[0]		;[Victor] Flag for multiple-escape
	push p,[0]		;char count
	push p,w3
	push p,w4		;byte ptr is now -1(p)
	setzm (w4)		;clear first word of string
	call tyi		;EOF not allowed for first char
;main loop
rdextl:	rdtabr w2,o1		;see what we have
	cain w2,rd%mes		;[Victor] Multiple-escape?
	 jrst [	call tyi	;[Victor] yes - get next char
		move w2,[%T]	;[Victor] and say we saw an escape
		movem w2,(q)
		setcmm -3(p)	;[Victor] and flag odd multiple-escape
		rdtabr w2,o1	;[Victor] see what we got
		jrst .+1 ]
	caig w2,rd%trm		;if space or term macro
	 skipe -3(p)		;[Victor] and not in a multiple-escape
	  trna			;[Victor] 
	 jrst rdextu		;then done, but unread it
	cain w2,rd%esc		;escape?
	 jrst [	call tyi	;yes - get next char
		move w2,[%T]	;and say we saw escape
		movem w2,(q)
		jrst rdexte]	;and bypass upper-casing
	skipe -3(p)		;[Victor] If within a multiple-escape
	 jrst rdexte		;[Victor] then bypass upper-casing
	camg o1,[char "z"]
	 camge o1,[char "a"]
	  jrst .+2
	   subi o1,40		;convert to upper case
rdexte:	idpb o1,-1(p)		;use the char
	aos -2(p)		;count it
	move w2,(p)		;clear next word
	setzm 1(w2)
	call tyie
	 jrst rdextx		;stop at eof
	jrst rdextl		;else go process this char

;here at end - first entry is for unreading
rdextu:	call @ch%unr(o2)
rdextx:	move w3,-2(p)		;length
	tlo w3,(object(ty%sp5,0)) ;special GC code
	push free,w3
	move o1,free
	tlo o1,(object(ty%str,0)) ;make o1 string ptr from addr of start 
	move free,(p)		;end of string
	subi p,4		;get rid of byte ptr on stack [Victor]and flag
	pop q,o2		;flag for escape
	camle free,lastl	;see if went beyond end of space
	 call sgc		;yes
	pop p,w2
	call unbin1		;unbind read table
	ret2			;we are returning 2 values

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-DELIMITED-LIST
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1 - terminating char; O2 - stream
rdelst:	move o2,@[.stdin]	;optional arg
	instrm o2
	move o3,q		;make pointer to our pseudo-list
	tlo o3,(object(ty%ccn,0))
;O3 is now the tail of the list being built up
	push q,nil		;list header
	push q,o1		;save char
	push q,o2		;save stream
	push q,o3		;save list tail
rdelsl:	move o2,-1(q)		;get back stream
	call flswht		;flush white space
	camn o1,-2(q)		;find the terminator?
	jrst rdelsx		;yes, exit
	rdmayn			;dispatch to the macro
	jumpe n,rdelsl		;if nothing returned, go look for more
	docons o3,o1,nil	;else add this to the end of the list
	move o2,(q)		;get back list tail
	dorpd o2,o3		;add this to the end
	movem o3,(q)		;and make this the new end
	jrst rdelsl		;see if more

rdelsx:	move o1,-3(q)		;get head of list to return
	subi q,4
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-LINE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1 - stream; O2 - eoferrp; O3 - eofvalue; o4 - recursivep
;all args are optional
rdline:	move o1,@[.stdin]	;set up omitted args: stream
	move o2,[%T]		;eof-errp
	move o3,nil		;eof-value
	move o4,nil		;recursivep. for now we ignore this
	instrm o1
	push q,o2		;save eof stuff over call
	push q,o3
	move o2,o1		;get channel to where desired
	call tyie		;EOF is error only on first char
	 jrst rdchef		;canonical eof handling
;have a char, so set up string
	hrlzi w3,440740		;w3/4 is byte ptr
	xmovei w4,2(free)
	push p,[0]		;char count
	push p,w3
	push p,w4		;byte ptr is now -1(p)
	setzm (w4)		;clear first word of string
;characters in string
rdlnlp:	camn o1,[char eolchr]	;check for end of line
	 jrst rdlnen
	idpb o1,-1(p)		;put the char in the string
	aos -2(p)
	move w2,(p)		;clear next word
	setzm 1(w2)
	call tyie
	 jrst rdlnef		;EOF is equiv to end of line
	jrst rdlnlp

;here at end of line
rdlnef:	skipa o2,[%T]		;say end of line terminated
rdlnen:	setz o2,		;say normal end of line
	move w3,-2(p)		;length
	tlo w3,(object(ty%sp5,0)) ;special GC code
	push free,w3
	move o1,free
	tlo o1,(object(ty%str,0)) ;make o1 string ptr from addr of start 
	move free,(p)		;end of string
	subi p,3		;get rid of byte ptr on stack
	subi q,2		;get rid of junk on Q
	camle free,lastl	;see if went beyond end of space
	 call sgc		;yes
	ret2			;we are returning two things

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-QUOTE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;here if we find a quote. stream in O1
rdquot:	setzb o2,o3		;eofp, eofval
	move o4,[%T]		;recursive
	call iread
	docons o2,o1,nil	;(thing)
	move o3,[%quot]
	docons o1,o3,o2		;(quote thing)
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-COMMENT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1 - stream
rdcom:	move o2,o1
rdcoml:	call tyie
	 jrst rdcomx		;if EOF, done
	came o1,[char eolchr]	;end of line?
	jrst rdcoml		;no, try again
rdcomx:	ret0			;return no values

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-LIST
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1 - stream; o2 - ignore
;external entry
rdlist:	instrm o1
;internal entry
rdlst:	move o2,q		;this will be the tail of the list
	tlo o2,(object(ty%ccn,0))
	push q,nil		;list head
	push q,o2		;list tail
	push q,o1		;stream
rdlstl:	move o2,(q)		;stream
	call flswht		;get non-white char
	rdtabr w2,o1		;see what it is
	camn o1,[char 51]	;end of list?
	jrst rdlstx		;yes, done
	cain w2,rd%dot		;CONS format?
	jrst rdlstc		;yes, special
rdlstd:	rdmayn			;dispatch to macro
	jumpe n,rdlstl		;nothing there, try again
	docons o3,o1,nil	;else attach object to list
	move o2,-1(q)		;get tail
	dorpd o2,o3		;attach this
	movem o3,-1(q)		;and make it new tail
	jrst rdlstl		;now try again

;here at end of list
rdlstx:	move o1,-2(q)		;get back header
	subi q,3		;kill junk on stack
	ret1			;and return it

;here when we find a dot.  If followed by a delimiter, this is
;a dotted list.  Otherwise, just an atom starting with a period.
rdlstc:	push q,o1		;save the dot
	call tyi		;look at next char
	rdtabr w2,o1		;see what it is
	caile w2,rd%trm		;is it delimiter?
	jrst rdlsda		;no, dotted atom
	subi q,1		;got rid of the dot
	skipn -2(q)		;better have something already
	jrst [err /Nothing appears before . in list./]
	camn w2,rd%wht		;if whitespace
	call flswht		;then find non-white
	call rdaftd		;read after dot
	move o3,-1(q)		;get the old tail
	dorpd o3,o1		;make this the CDR
	jrst rdlstx		;and return the list

;here when dot is beginning of an atom
rdlsda:	call @ch%unr(o2)	;unread the next char
	pop q,o1		;get back the dot
	jrst rdlstd		;and go treat as normal char

;READ-AFTER-DOT
;O1 - char, O2 - stream
rdaftd:	push q,o2		;save the stream
rdaftl:	camn o1,[char 51]	;if close already
	jrst [err /Nothing after . in list./]
	rdmayn			;do the dispatch
	move o2,(q)		;nothing yet (comment)
	jumpn n,rdaftf		;found something
	call flswht		;so find something
	jrst rdaftl		;and go look at it
;here when we have an object in O1
;check for close paren
rdaftf:	push q,o1
rdaffl:	move o2,-1(q)		;get the channel back
	call flswht		;find next thing
	camn o1,[char 51]	;is it the right thing?
	jrst rdaftx		;yes
	rdmayn			;something is there
	jumpe n,rdaffl		;just a comment, so it's OK
	err /More than one object follows . in list./
;here to exit
rdaftx:	pop q,o1		;get the thing to return
	subi q,1
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-STRING
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;TY%STR
;here for string - very much like atom
;O1 - channel, O2 - close character
rdstr:	hrlzi w3,440740		;w3/4 is byte ptr
	xmovei w4,2(free)
	push p,[0]		;char count
	push p,w3
	push p,w4		;byte ptr is now -1(p)
	setzm (w4)		;clear first word of string
	push q,o1		;save channel
	push q,o2		;save close char
  ;characters in string
rdstlp:	move o2,-1(q)		;get back channel
	call tyi
	camn o1,(q)		;done?
	jrst rdsten		;yes
	rdtabr w2,o1		;see what it is
	cain w2,rd%esc		;escape char?
	call tyi		;yes, read next char
	idpb o1,-1(p)		;put the char in the string
	aos -2(p)
	move w2,(p)		;clear next word
	setzm 1(w2)
	jrst rdstlp

rdsten:	move w3,-2(p)		;length
	tlo w3,(object(ty%sp5,0)) ;special GC code
	push free,w3
	move o1,free
	tlo o1,(object(ty%str,0)) ;make o1 string ptr from addr of start 
	move free,(p)		;end of string
	subi p,3		;get rid of byte ptr on stack
	subi q,2		;get rid of junk on Q
	camle free,lastl	;see if went beyond end of space
	 call sgc		;yes
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-RIGHT-PAREN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

rdrpar:	skipn @[.RPARWHT]	;treat right paren as white?
	jrst [err /Unmatched right parenthesis/]
	ret0			;else treat as comment

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; READ-TOKEN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

define ouch
	aos -2(p)		;count the char
	idpb o1,-1(p)		;and put it in
	termin

define tokdsp(+dlm=r.sym,esc=r.sym,con=r.sym,dot=r.sym,exp=r.sym,slh=r.sym,dig=r.sym,xdg=r.sym,ddg=r.sym,sgn=r.sym,mes=r.sym,pkg=r.sym,\table)
jrst @table(w2)
table:	ifiw dlm
	ifiw dlm
	ifiw con
	ifiw esc
	ifiw mes
	ifiw con
	ifiw dot
	ifiw exp
	ifiw slh
	ifiw dig
	ifiw xdg
	ifiw ddg
	ifiw sgn
	ifiw pkg
	ifiw r.ill
	termin

;in general, the ac's in this routine are:
; O1 - current char
; O2 - channel
rdtok:	hrlzi w3,440740		;w3/4 is byte ptr
	xmovei w4,2(free)
	push p,[0]		;colons
	push p,[0]		;char count
	push p,w3
	push p,w4		;byte ptr is now -1(p)
	setzm (w4)		;make sure low order bit is clear
	push q,@[.PACKAGE]	;(Q) is package to use for this symbol
	exch o1,o2
;INITIAL CHAR
	rdtabr w2,o1
	call chkfdg		;if base is not 10, see if really a digit
	tokdsp sgn=r.sign,dig=r.ldig,xdg=r.xdig,ddg=r.ddig,dot=r.fdot,esc=r.esc,pkg=r.col,mes=r.mesc
;SIGN
r.sign:	ouch			;put char in buffer
	call tyie
	 jrst rsym
	rdtabr w2,o1
	call chkfdg
	tokdsp dig=r.ldig,xdg=r.xdig,ddg=r.ddig,dot=r.sdot,esc=r.esc,pkg=r.col,mes=r.mesc,dlm=rsymu
;XDIGITS   [sign] {hexdigits}+
;This is used instead of LEFTDIGIT when one of the "digits" is a letter.
;  This must be done separately because it can't become a floating pt. number
r.xdig:	camg o1,[char "z"]
	 camge o1,[char "a"]
	  jrst .+2
	   subi o1,40		;convert to upper case
	ouch
	call tyie
	 jrst makint
	rdtabr w2,o1
	call chkfdg
	tokdsp dig=r.xdig,xdg=r.xdig,slh=r.xrat,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=makntu
;DECIMALDIGIT   [sign] {digit}+
;This is like LEFTDIGIT but is used for digits that are greater than the
;base but still .LE. 10.  This is a number only if there is a decimal pt.
r.ddig:	ouch
	call tyie
	 jrst makint
	rdtabr w2,o1
	call chkfdg
	tokdsp dig=r.ddig,ddg=r.ddig,dot=r.mdot,exp=r.exp,slh=r.rat,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=rsymu

;LEFTDIGIT   [sign] {digit}+
r.ldig:	ouch
	call tyie
	 jrst makint
	rdtabr w2,o1
	call chkfdg
	tokdsp dig=r.ldig,xdg=r.xdig,ddg=r.ddig,dot=r.mdot,exp=r.exp,slh=r.rat,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=makntu
;MIDDLEDOT  [sign] {digit}+ dot
r.mdot:	ouch
	call tyie
	 jrst makint
	rdtabr w2,o1
	tokdsp dig=r.rdig,ddg=r.rdig,exp=r.exp,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=makntu
;RIGHTDIGIT  [sign] {digit}* dot {digit}+
r.rdig:	ouch
	call tyie
	 jrst makflt
	rdtabr w2,o1
	tokdsp dig=r.rdig,ddg=r.rdig,exp=r.exp,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=makflu
;SIGNDOT  [sign] dot
r.sdot:	ouch
	call tyie
	 jrst rsym
	rdtabr w2,o1
	tokdsp dig=r.rdig,ddg=r.rdig,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=rsymu
;FRONTDOT  dot
r.fdot:	ouch
	call tyie
	 jrst [err /Dot context error/]
	rdtabr w2,o1
	tokdsp dig=r.rdig,ddg=r.rdig,dot=r.dots,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=r.dce
r.dce:	err /Dot context error/
;EXPONENT exp
r.exp:	camg o1,[char "z"]
	 camge o1,[char "a"]
	  jrst .+2
	   subi o1,40		;convert to upper case
	ouch
	call tyie
	 jrst rsym
	rdtabr w2,o1
	tokdsp sgn=r.esign,dig=r.edig,ddg=r.edig,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=rsymu
;EXPTSIGN  got to exponent, and saw a sign
r.esig:	ouch
	call tyie
	 jrst rsym
	rdtabr w2,o1
	tokdsp dig=r.edig,ddg=r.edig,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=rsymu
;EXPTDIGIT  got to exponent, and saw [sign] digit
r.edig:	ouch
	call tyie
	 jrst makflt
	rdtabr w2,o1
	tokdsp dig=r.edig,ddg=r.edig,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=makflu
;XRATIO   [sign] {digit}+ slash
;this is like RATIO, but one of the digits is a letter
r.xrat:	ouch
	call tyie
	 jrst rsym
	rdtabr w2,o1
	call chkfdg
	tokdsp dig=r.xrtd,xdg=r.xrtd,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=rsymu
;XRATIODIGIT  [sign] {digit}+ slash {digit}+
;this is like RATIODIGIT, but one of the digits is a letter
r.xrtd:	camg o1,[char "z"]
	 camge o1,[char "a"]
	  jrst .+2
	   subi o1,40		;convert to upper case
	ouch
	call tyie
	 jrst makrat
	rdtabr w2,o1
	call chkfdg
	tokdsp dig=r.xrtd,xdg=r.xrtd,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=makrtu
;RATIO   [sign] {digit}+ slash
r.rat:	ouch
	call tyie
	 jrst rsym
	rdtabr w2,o1
	call chkfdg
	tokdsp dig=r.rtdig,xdg=r.xrtd,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=rsymu
;RATIODIGIT  [sign] {digit}+ slash {digit}+
r.rtdi:	ouch
	call tyie
	 jrst makrat
	rdtabr w2,o1
	call chkfdg
	tokdsp dig=r.rtdig,xdg=r.xrtd,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=makrtu
;DOTS  saw dot {dot}+
r.dots:	ouch
	call tyie
	 jrst [err /Too many dots/]
	rdtabr w2,o1
	tokdsp dot=r.dots,esc=r.esc,mes=r.mesc,pkg=r.col,dlm=r.tmd
r.tmd:	call @ch%unr(o2)
	err /Too many dots/
;SYM  not a dot, dots, or number
r.sym:	camg o1,[char "z"]
	 camge o1,[char "a"]
	  jrst .+2
	   subi o1,40		;convert to upper case
	ouch
	call tyie
	 jrst rsym
	rdtabr w2,o1
	tokdsp esc=r.esc,mes=r.mesc,pkg=r.col,dlm=rsymu
;ESCAPE
;don't put the escape in the buffer
;get next char literally
r.esc:	call tyie
	 jrst [err /End of file after escape character./]
	ouch
	call tyie
	 jrst rsym
	rdtabr w2,o1
	tokdsp esc=r.esc,mes=r.mesc,pkg=r.col,dlm=rsymu
;MULT-ESCAPE
r.mesc:	call tyi
	rdtabr w2,o1
	cain w2,rd%mes
	jrst r.mesd		;done if find close |
	cain w2,rd%esc		;if escape
	call tyi		;use next char
	ouch			;else use it
	jrst r.mesc		;and try again
r.mesd:	call tyie
	 jrst rsym
	rdtabr w2,o1
	tokdsp esc=r.esc,mes=r.mesc,pkg=r.col,dlm=rsymu
;COLON
r.col:	skipe @[.rdsup]		;if do-nothing mode
	 jrst r.sym		;then treat this as symbol
	skipe -3(p)		;make sure no colons before
	jrst [err /Too many colons in input./]
	aos -3(p)		;count
	xmovei o1,1(free)	;start of string
	move w2,-2(p)		;count of chars in string
	tlo w2,(object(ty%sp5,0)) ;special GC code
	movem w2,(o1)		;as header
;We aren't really going to advance the free list over this string
;and make it legal.  So we call it a constant string, to prevent
;the GC from choking over any pointers to it that may be left around.
	tlo o1,(object(ty%cst,0)) ;make o1 string ptr from addr of start 
	push q,o2
	move o2,@[.PKGOBARRAY]	;see if there is any package by that name
	call gethsh		;rtns 2 vals
	jumpe o2,[err /Package not found./]
	pop q,o2
	movem o1,(q)		;save as current.
;here we reset the read buffer
	hrlzi w3,440740		;w3/4 is byte ptr
	xmovei w4,2(free)
	dmovem w3,-1(p)
	setzm -2(p)
	call tyie
	 jrst [err /End of file after :/]
	rdtabr w2,o1
	tokdsp esc=r.esc,mes=r.mesc,pkg=r.int,dlm=r.itc
r.itc:	call @ch%unr(o2)
	err /Illegal terminating character after :/
;INTERN
r.int:	skipe @[.rdsup]		;if do-nothing mode
	 jrst r.sym		;then treat as symbol
	movei w2,2
	movem w2,-3(p)		;say 2 colons
	call tyie
	 jrst [err /End of file after ::/]
	rdtabr w2,o1
	tokdsp esc=r.esc,mes=r.mesc,pkg=r.tmc,dlm=r.idc
r.tmc:	err /Too many colons/
r.idc:	call @ch%unr(o2)
	err /Illegal terminating character after ::/
;RETURN-SYMBOL
rsymu:	call @ch%unr(o2)
rsym:	skipn w2,-3(p)		;any package stuff?
	jrst rsymin		;no, just do intern
	move o2,(q)		;get package
	came o2,@[.KEYPACKAGE]	;if keyword
	cain w2,2		;or if ::
	jrst rsymin		;then just intern
;here to just do FIND-SYMBOL for external
	xmovei o1,1(free)	;start of string
	move w2,-2(p)		;count of chars in string
	tlo w2,(object(ty%sp5,0)) ;special GC code
	movem w2,(o1)		;as header
;We aren't really going to advance the free list over this string
;and make it legal.  So we call it a constant string, to prevent
;the GC from choking over any pointers to it that may be left around.
	tlo o1,(object(ty%cst,0)) ;make o1 string ptr from addr of start 
	move o2,(q)		;get package
	move o2,pk%ext(o2)	;its external symbols
	call gethsh		;look it up
	jumpe o2,[err /Symbol after : not found as external symbol/]
	subi p,4
	subi q,1
	ret1

;here to call intern
rsymin:	pop p,w4		;get 2nd word of byte ptr
	subi p,1		;kill first word
	pop p,w3		;length in chars
	subi p,1		;colon count 
	pop q,o2		;package
	skipn @[.rdsup]		;if do-nothing mode
	jrst xinter
	jrst retnil		;just return NIL

;here for illegal character
r.ill:	err1 o1,/Illegal character in symbol/

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  This section is for reading numbers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  CHKFDG - correct the syntactic class of a character based on *INPUT-BASE*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;here to take the ibase into account
chkfdg:	move w3,@[.IBASE]	;look at base
	camn w3,[inum 10.]
	 iret			;if base 10, the tables are right
	camg w3,[inum 10.]
	 jrst chkfdd	 	;base is .LT. 10, just check normal digits
;here when base .GT. 10.  Set up letters as digits
	caige w2,rd%con		;only check out constituents
	 iret
	move w4,o1		;upper case the object
	trz w4,040
	sub w3,[<inum 16.>-<char "F">] ;convert base to highest letter used
	caml w4,[char "A"]	;now see if this is a letter-type digit
	 camle w4,w3
	  iret			;not, so leave things alone
	movei w2,rd%xdg		;call it an extended digit
	iret
;here when base .LT. 10.  Turn digits above base into decimal digits
chkfdd:	caie w2,rd%dig		;only look at things now called digits
	 iret
	sub w3,[<inum 0>-<char "0">] ;convert base to character
	caml o1,[char "0"]	;see if still legal char
	 caml o1,w3
	  movei w2,rd%ddg	;no, call decimal digit
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  MAKINT - integers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;Unfortunately, all the AC's and stacks are used here.  
;We do not use the count, but depend upon the fact that the data is ASCIZ.

;Note that RDTOK has already parsed this as a legal number, which lets
;use take some freedoms.

	.scalar numbpt,numbp2

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; I.  Initial dispatch
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;MAKINT - decode an integer, from characters stored at FREE.
;  All AC's are used.  The first entry is for cases where the terminator
;  has been read and we need to unread it.

makntu:	call @ch%unr(o2)
makint:	idpb nil,-1(p)		;make sure it's ASCIZ
	subi p,4		;kill off stuff from RDTOK
	subi q,1
	skipe @[.rdsup]		;if do-nothing mode
	 jrst retnil		;just return NIL
	hrlzi w2,440740		;w2/w3 is byte ptr
	xmovei w3,2(free)
;I'm not quite sure how this could be recursive, but I like to be safe.
	push p,sp
	push sp,[object(ty%lpi,<codsec,,numbpt>)]
	push sp,numbpt
	push sp,[object(ty%lpi,<codsec,,numbp2>)]
	push sp,numbp2
	dmovem w2,numbpt
	push p,[codsec,,unbind]		;force unbind for this
;now see what we have
	ildb o1,numbpt
	makchr o1
	rdtabr w2,o1		;see what we have
	caie w2,rd%sgn		;if not sign
	jrst rdnum		;must be digit
	camn o1,[char "-"]
	jrst rdneg
;here after +.  Must be a digit
	ildb o1,numbpt
	makchr o1
	jrst rdnum


;MAKRAT - decode a ratio, from characters stored at FREE.
;  All AC's are used.  The first entry is for cases where the terminator
;  has been read and we need to unread it.

makrtu:	call @ch%unr(o2)
makrat:	subi p,4		;kill off stuff from RDTOK
	subi q,1
	skipe @[.rdsup]		;if do-nothing mode
	 jrst retnil		;then just return NIL
	hrlzi w2,440740		;w2/w3 is byte ptr
	xmovei w3,2(free)
;I'm not quite sure how this could be recursive, but I like to be safe.
	push p,sp
	push sp,[object(ty%lpi,<codsec,,numbpt>)]
	push sp,numbpt
	push sp,[object(ty%lpi,<codsec,,numbp2>)]
	push sp,numbp2
	dmovem w2,numbpt
	push p,[codsec,,unbind]		;force unbind for this
;now see what we have
	ildb o1,numbpt
	makchr o1
	rdtabr w2,o1		;see what we have
	caie w2,rd%sgn		;if not sign
	jrst rdrat		;must be digit
	camn o1,[char "-"]
	jrst rdnrat
;here after +.  Must be a digit
	ildb o1,numbpt
	makchr o1
	jrst rdrat

;rdnrat - negative ratio
rdnrat:	ildb o1,numbpt		;get the first digit
	makchr o1
	call rdrat		;decode the number after it
	xnmtyp o1		;see what we have
	xct rdntab(w2)		;and negate it
	iret

;rdrat - ratio
rdrat:	call rdnum		;get the part before the slash
	push q,o1
	ildb o1,numbpt
	makchr o1
	call rdnum		;then the next
	pop q,o2		;get back first part
	exch o1,o2
	camn o2,[inum0]		;[Victor] x/0?
	 jrst divzro		;[Victor] lose!
	jrst rat		;make a ratio

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; II.  Negative integers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;TY%INT
;;TY%FLO
rdneg:	ildb o1,numbpt		;get the first digit
	makchr o1
	call rdnum		;decode the number after it
	xnmtyp o1		;see what we have
	xct rdntab(w2)		;and negate it
	iret
	
;;TYPES
rdntab:	call rdnrea		;flonum
	jfcl			;negative iflons (can't happen)
	call rdnifl		;pos iflons
	call rnnrat		;ratio
	jfcl			;special 5 and 36
	call rdnbig		;negate bignum
	jfcl			;neg inum (can't happen)
	call rdninu		;pos inum

;the reason we don't just use MINUS is that we want to negate in place,
;rather than cons'ing a new number cell
rdninu:	hrlzi w2,(<object(ty%lpi,0)>_1)
	subm w2,o1		;negate inum
	iret

rdnifl:	lsh o1,4		;negate iflon
	movns o1		;generally simple
	lsh o1,-4
	tlon o1,(<object ty%lnf,0>)	;(generally hits the sign bit)
	 hrlzi o1,(<object ty%lpf,0>)	;(unless someone types -0.0)
	iret

rnnrat:	push q,o1		;ratio: negate numerator
	move o1,(o1)		;get it
	xnmtyp o1		;same as above
	xct rdntab(w2)
	exch o1,(q)		;put it back in the fraction
	pop q,(o1)
	iret

;negate real
rdnrea:	dmove w2,1(o1)		;negate it in place
	dmovnm w2,1(o1)
	iret

;;TY%BIG
rdnbig:	getsiz w4,o1		;negate a bignum in place
	lsh w4,-1		;how many doublewords?
	sojle w4,rdnrea		;just one--easy
	move o2,o1		;use as moving pointer
rdnb2:	jfcl 17,.+1		;only works for #'s>0 
	dmovn w2,1(o2)		;and only on a KL
	jcry [addi o2,2 ? soja w4,rdnb2] ;this loop for low-order 0's
	jrst .+3
rdnb3:	 dmovn w2,1(o2)		;the rest for words left of the 
	 dsub w2,[0 ? 1]	; rightmost 1 bit
	dmovem w2,1(o2)		;..joined in progress
	addi o2,2		;bump address
	sojge w4,rdnb3		;count doublewords
	setz o2,		;not a valid object now
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; III.  RDNUM - the main integer reader
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;TY%INT
;;TY%BIG
;here for a digit
;RDNUM is a common routine called here and by the negative number
;handler.  
rdnum:	push p,q		;save q, since we will hack on it
	push p,[0]		;clear working areas
	push p,[nil]
	jrst rdnl1e	
;loop one - pushes the char's on the stack
  ;-2(p) - saved q
  ;-1(p) - number of digits seen
  ;(p) - point character
rdnml1:	ildb o1,numbpt
	makchr o1
rdnl1e:	rdtabr w2,o1		;see what we have
	cain w2,rd%dot		;decimal point?
	 jrst rdnmpt		;yes - process it
	caie w2,rd%slh		;slash?
	 camn o1,[char 0]	;terminator?
	  jrst rdnmtr		;yes, done	
;if here, we found a digit: stack it
	push q,o1		;stack next char
	aos -1(p)		;and count it
	jrst rdnml1	

;decimal pt
rdnmpt:	movem o1,(p)		;save point
	jrst rdnmtr

;here if termin
rdnmtr:	

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  IV. Building the actual number. 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;; Integers

;-3(p) - saved q
;-2(p) - number of digits
;-1(p) and 0(p) - base
;w2,w3 - number being built
;w4 - new digit

	pop p,o2		;get point if any
	move n,@[.IBASE]	;compute base
	posnum n		;internal value - this is the default
	jumpe o2,rdnmnb		;if no point given, that is it
	movei n,10.		;if point, we have decimal
rdnmnb:	call ibaset		;set up ibase table pointer
	push p,0
	push p,0		;placeholders
;nil1 is pointer to q
;now we go up the stack decoding the number
	xmovei nil1,1(q)	;last digit
	sub nil1,-2(p)		;first digit
	move w2,-2(p)		;# of digits
	camle w2,4(n)		;comp w/ #/digits in a doubleword
	 jrst rdnmbg
	setzb w2,w3		;simple special case routine for tiny numbers
	setzb w4,o1		; less than 1000000000000000000000 or so
rdnml2:	sosge -2(p)		;any digits left to scan?
	 jrst rdnmx2		;no - done
	dmul w2,(n)		;multiply old value by base
	dmove w2,w4		;get low-order part of quadruple result
	setz w4,
	move o1,(nil1)		;get the digit
	camle o1,[char "9"]	;if not a normal digit
	 jrst [	trz o1,040	;upper-case it
		sub o1,[<char "A">-10.] ;convert differently
		jrst .+2]
	sub o1,[char "0"]	;convert to value
	dadd w2,w4		;add in new digit
	aoja nil1,rdnml2	;go back for more digits

rdnmx2:	subi p,3		;kill old p things
	pop p,q			;put back q
	move nil1,nil		;return to LISP context
	jrst retint		;return INUM or small BIGNUM

;;-2(p) -- (also w2) # of digits
;; -1(p) & (p) -- base
;; read a bignum bigger than 2 words.  this routine consists of
;; two double loops:  the first makes 2-wd numbers out of each
;; 21-digit segment of the number; the second puts the segments
;; together in binary form.  The "odd segment" referred to is
;; that formed from the leading (n mod 21) digits.
rdnmbg:	idiv w2,4(n)		;how many chunks to do this # in
	move o4,p		;beginning of space for it 
	move o5,w2		;# of exp-digit segments
	move o3,w3		;# of digits in odd segment
	lsh o5,1		;use 2 wds per segment
	addi p,6(o5)		;get space
	lsh o5,-1
	dmovem o4,-3(p)		;-3(p) is old p; -2(p) is # of segs
	setzb w2,w3		;for following loop
	dmovem w2,-1(o4)	;not actually used
rdnmb2:	sojl o3,rdnmb3		;this loop reads an exp-or-less-digit #
	dmul w2,(n)		; into a doublewd as the simple case above
	dmove w2,w4		;get low-order part of quadruple result
	setz w4,
	move o1,(nil1)		;get the digit
	camle o1,[char "9"]	;if not a normal digit
	 jrst [	trz o1,040	;upper-case it
		sub o1,[<char "A">-10.] ;convert differently
		jrst .+2]
	sub o1,[char "0"]	;convert to value
	dadd w2,w4		;add in new digit
	aoja nil1,rdnmb2	;go back for more digits

rdnmb3:	dmovem w2,1(o4)		;successive dw's are stashed in space on p
	addi o4,2		;--the pointer thereinto
	move o3,4(n)		;counter for next segment
	setzb w2,w3		;each one is a separate number
	sojge o5,rdnmb2		;maybe do more segments
	sos o1,-3(p)		;point to the 00 in 00 seg seg seg ...
	addi o1,2		;point to first seg
	move o2,o1		;save to reinitialize o1
	move o3,-2(p)		;# of segs
rdnmb5:	dmove nil1,(o1)		;same number-forming algorithm as above--
	dmul nil1,2(n)		;base^exp
	dadd w3,2(o1)		;--but now the digits are two wds long
	tlze w3,400000		;propagate carry
	 dadd nil1,[0 ? 1]	;note how we cleverly use the space
	dmovem nil1,(o1)	;occupied by the segments to put the
	dmovem w3,2(o1)		;number as it grows
	subi o1,2		;loop back to do next digit of multiplication
	came o1,-3(p)
	 jrst rdnmb5
	addi o2,2		;loop back to do multiplication for next
	move o1,o2		; digit of number
	sojg o3,rdnmb5
	aos w4,-2(p)		;# of segments again, +1 to count odd one
	lsh w4,1		;two wds apiece
	maknum o2		;so gc doesn't kick
	setzb o3,o4		;contained non-objects
	setz o5,		;--me too
	call bigmak		;form the object
	move o3,o1		;moving ptr-save o1 to return
rdnmb6:	dmove w2,(o2)		;move the words from the stack to the object
	dmovem w2,1(o3)		;reversing the order of doublewords
	subi o2,2
	addi o3,2
	sojg w4,rdnmb6
	setzb o3,nil1		;non-obj
	move p,-3(p)		;throw away the stack space
	subi p,2
	pop p,q			;put back q
	jrst bgtrim		;return INUM or small BIGNUM

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  REAL numbers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  I. REAL dispatch
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

makflu:	call @ch%unr(o2)
makflt:	idpb nil,-1(p)		;make asciz
	subi p,4		;kill off stuff from RDTOK
	subi q,1
	skipe @[.rdsup]		;if do-nothing mode
	 jrst retnil		;just return NIL
	hrlzi w2,440740		;w2/w3 is byte ptr
	xmovei w3,2(free)
;I'm not quite sure how this could be recursive, but I like to be safe.
	push p,sp
	push sp,[object(ty%lpi,<codsec,,numbpt>)]
	push sp,numbpt
	push sp,[object(ty%lpi,<codsec,,numbp2>)]
	push sp,numbp2
	dmovem w2,numbpt
	push p,[codsec,,unbind]		;force unbind for this
;now see what we have
	ildb o1,numbpt
	makchr o1
	rdtabr w2,o1		;see what we have
	caie w2,rd%sgn		;if not sign
	jrst rdreal		;must be digit
	camn o1,[char "-"]
	jrst rdnrel
;here after +.  Must be a digit
	ildb o1,numbpt
	makchr o1
	jrst rdreal

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; II.  Negative reals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;TY%INT
;;TY%FLO
rdnrel:	ildb o1,numbpt		;get the first digit
	makchr o1
	call rdreal		;decode the number after it
	xnmtyp o1		;see what we have
	xct rdntab(w2)		;and negate it
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; III. Parsing subroutines for RDREA
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;rdint - read integer, results in w3
rdint:	ildb o1,numbpt
	makchr o1	
	rdtabr w2,o1
	call rdsgn		;get a sign - returns on Q
	call rdpint		;get a pos. integer - returns in w3
	pop q,o2		;sign - nil if pos, non-nil if neg
	skipe o2
	movn w3,w3
	iret

;rdsgn - get nil if + or no sign, non-nil if -
rdsgn:	push q,[nil]		;assume no sign
	caie w2,rd%sgn
	iret			;right - none
	move o2,[%t]
	camn o1,[char "-"]	;there is one, if negative
	movem o2,(q)		;return T
	ildb o1,numbpt
	makchr o1
	rdtabr w2,o1
	iret

;rdpint - get positive integer
rdpint:	push p,[0]		;number we are building
rdpinl:	caie w2,rd%dig		;more digits?
	jrst rdpinx		;no - return the 0
	move w3,(p)		;get old number
	imuli w3,10.		;shift by one digit
	move w2,o1		;and add in new one
	sub w2,[char "0"]
	add w3,w2
	movem w3,(p)		;put it back in stack
	ildb o1,numbpt
	makchr o1
	rdtabr w2,o1
	jrst rdpinl

rdpinx:	pop p,w3		;return in w3
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; IV. Real number scanning
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;TY%FLO
;;TY%IFL
rdreal:	push p,q		;save q, since we will hack on it
	push p,[0]		;clear working areas
	push p,[0]
	push p,[nil]
	jrst rdrl1e	
;loop one - pushes the char's on the stack
  ;-3(p) - saved q
  ;-2(p) - number of digits seen
  ;-1(p) - number of digits after point
  ;(p) - point character
rdrll1:	ildb o1,numbpt
	makchr o1
rdrl1e:	rdtabr w2,o1		;see what thing this is?
	cain w2,rd%dot
	 jrst rdrlpt		;yes - process it
	cain w2,rd%exp
	 jrst rdrlex		;exponent
	camn o1,[char 0]	;terminator?
	 jrst rdrltr		;yes - done with first loop
;here if digit
	push q,o1		;stack next char
	aos -2(p)		;and count it
	skipe (p)		;if seen point
	aos -1(p)		;count this as after point
	jrst rdrll1	
;decimal pt
rdrlpt:	movem o1,(p)		;save point
	jrst rdrll1

;exponent of some kind
rdrlex:	trz o1,40		;upper-case
	camn o1,[char "E"]
	  jrst rdrlee		;E exponent means default
	came o1,[char "D"]
	 camn o1,[char "L"]
	  jrst rdoub
	jrst rdexp		;only other choice is single

;here for default
rdrlee:	move o1,@[.RDDFLT]	;default format
	came o1,[%DBLFLT]
	 camn o1,[%LNGFLG]
	  jrst rdoub
	jrst rdexp

;here if we saw a D exponent
rdoub:	setom (p)		;indicate double precision
	call rdint		;read exp, returns in w3
	movn w3,w3		;subtract from digits after decimal
	addm w3,-1(p)
	jrst rdrl1		;that's all

;here if we saw E - go scan an exponent
rdexp:	call rdint		;read exp, returns in w3
	movn w3,w3		;subtract from digits after decimal
	addm w3,-1(p)
	setzm (p)		;clear double precision flag
	jrst rdrl1		;that's all

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; V. Real number value return
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


  ;-13(p) - saved q
  ;-12(p) - number of digits seen
  ;-11(p) - number of digits after point
  ;-10(p) - is it double prec
  ;-9,-8,-7,-6 - integer part
  ;-5,-4,-3,-2,-1,0  - fraction

rdrltr:	setzm (p)		;clear double precision flag
	move o1,@[.RDDFLT]	;default format
	came o1,[%DBLFLT]
	 camn o1,[%LNGFLG]
	  setom (p)
rdrl1:	movei w2,10.		;number of words needed
	push p,[0]
	sojg w2,.-1
	xmovei n,1(q)		;last digit
	sub n,-12.(p)		;first digit
;first, build up integer part if any
	move w4,-12.(p)		;number of digits
	sub w4,-11.(p)		;number before the point
	jumple w4,rdrfra	;if nothing, just do fraction
	movem w4,(p)
;loop over digits before point.  During this loop, (p) is the number
;of virtual digits before the point.  If this is greater than the
;number of digits typed (e.g. due to 12.0E12), fill with zeros.
;the loop is cleverly designed so that (p) gets decremented to zero,
;since later code assumes it is zero
rdrinl:	sosge (p)		;any more digits?
	 jrst rdrfra		;no, do fraction
	setzb nil,nil1		;assume this digit is zero
	sosge -12.(p)		;are there more real digits?
	 jrst rdrinn		;no
	move nil1,(n)		;yes, get the digit
	aos n			;advance the pointer to the next digit
	sub nil1,[char "0"]	;convert to value
rdrinn:	dmove w2,-7(p)		;get low order part of integer
	dmul w2,[0 ? 10.]	;multiply by 10
	dadd w4,nil		;add in the new digit	
	tlze w4,400000		;if it overflows
	 dadd w2,[0 ? 1]	;then carry out
	dmovem w4,-7(p)		;updated low order part
	dmove nil,w2		;carry out
	dmove w2,-9.(p)
	dmul w2,[0 ? 10.]
	dadd w4,nil		;carry in
	tlze w4,400000
	 dadd w2,[0 ? 1]
	dmovem w4,-9.(p)
	jumpn w2,toobig		;no carry out allowed here
	jumpn w3,toobig
	setzb nil,nil1
	jrst rdrinl		;to next digit

;here to handle the fraction.  This is the reverse of the normal
;algorithm for printing.  Note that it starts with the low-order
;digit.  After the previous code, the number of digits can't
;be greater than the number of digits after the point.  Alas, this
;crazy algorithm request hex-precision divides!
rdrfra:	xmovei n,(q)		;last digit
rdrfrl:	sosge -11.(p)		;digits left after point?
	jrst rdrfrx		;no, done
	setzb nil,nil1		;assume this digit is zero
	sosge -12.(p)		;are there more real digits?
	 jrst rdrfrn		;no
	move nil1,(n)		;yes, get the digit
	sos n			;advance the pointer to the next digit
	sub nil1,[char "0"]	;convert to value
rdrfrn:	dmove w2,-5(p)		;high order double word
	ddiv nil,[0 ? 10.]
	dmovem nil,-5(p)	;quotient
	dmove nil,w2		;remainder is here
	dmove w2,-3(p)
	ddiv nil,[0 ? 10.]
	dmovem nil,-3(p)
	dmove nil,w2
	dmove w2,-1(p)
	ddiv nil,[0 ? 10.]
	dmovem nil,-1(p)
	jrst rdrfrl		;process next digit

;here when all of the bits are in the 10-word chunk on the stack.
;now normalize and convert to floating point.
rdrfrx:	xmovei n,-9.(p)		;high-order word
	movei w4,10.		;call it word 4	
rdrnrl:	skipe w2,(n)		;anything there?
	 jrst rdrnrx		;yes, end of word search
	addi n,1		;no, go to next word
	sojg w4,rdrnrl		;and try again
;here if all words are zero
rdrzro:	setzb w2,w3		;so result is zero
	setz w4,
	jrst rdrx		;and that's all
;here if we find a non-zero word
rdrnrx:	jffo w2,.+2
	 0			;"impossible", as word must be nonzero
	move nil,(n)		;high order word
	setzb nil1,w2		;clear next words, just in case
	cail w4,2		;more than one significant word?
	move nil1,1(n)		;yes, get it
	cail w4,3		;are there maybe 3?
	move w2,2(n)		;yes, so get third also
	subi w3,9.		;w3 was bits needed to left justify
				;now it is bits needed to put in mantissae
	ashc nil,(w3)		;align first two
	movn w3,w3
	ash nil1,(w3)		;put back bits left in second word
	movn w3,w3
	ashc nil1,(w3)		;now align others
;we now have the data bits aligned in nil/nil1.  Add the exponent.
	imuli w4,35.		;35 bits per word
	sub w4,w3		;jffo count is negative sense
	subi w4,90.		;magic constant to get correct exponent
	skipe -10.(p)		;double precision?
	 jrst rdrrnd		;yes, round that way
;here to round to single precision
	trnn nil,10		;should round up?
	jrst rdrrnn		;no, simple
	addi nil,20		;yes, so increment
	tlnn nil,377000		;carry into exponent?
	jrst rdrrnn		;no, done
	ash nil,-1		;yes, renormalize
	addi w4,1		;and account for it
	jrst rdrrnn		;done with rounding
;here to round double precision
rdrrnd:	tlnn w2,200000		;should round up?
	jrst rdrrnn		;no, simple
	dadd nil,[0 ? 1]	;yes, so increment
	tlnn nil,377000		;carry into exponent?
	jrst rdrrnn		;no, done
	ashc nil,-1		;yes, renormalize
	addi w4,1		;and account for it
;here when rounding done
rdrrnn:	caile w4,377		;range check exponent
	jrst toobig		;overflow
	caige w4,0
	jrst rdrzro		;underflow
	dpb w4,[.bp 377_27.,nil] ;this is the exponent
	move w4,w2		;put in proper place
	dmove w2,nil

;here with value in w2/w3
rdrx:	setzb nil1,nil		;clean up NIL
	move w4,-10.(p)		;double precision? - flag to w4
	subi p,13.		;kill off junk
	pop p,q			;put back old q
	skipe w4		;double precision?
	 jrst rdrxd
	makifl w2		;make number into an iflon
	move o1,w2		;and return it
	ret1

toobig:	err /Floating overflow/

rdrxd:	push free,[object(ty%spc,2)] ;now make real number object
	move w4,free		;make pointer be right type
	tlo w4,(object(ty%flo,0))
	move o1,w4		;and return that
	push free,w2
	push free,w3
	camle free,lastl	;see if need GC
	 call sgc
	ret1			;that's all

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Package support
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;MAKPKG - for creating the initial packages LISP and KEYWORD
;O1 - package name, a string
;O2 - nicknames, a list of strings (or NIL)
;W4 - a list of the atoms, linked through AT%PKG

makpkg:	push q,o1
	push q,o2
	push p,w4
;have to make the hash tables first, so FREE doesn't move if
;makhsh GC's
	move o1,[%EQUAL]
	move o2,nil
	move o3,nil
	move o4,nil
	call makhsh
	push q,o1
	move o1,[%EQUAL]
	move o2,nil
	move o3,nil
	move o4,nil
	call makhsh
	push q,o1
;Q: name, nickname, internal, external
	push free,[inum st%str]		;say this is a structure
	push free,[inum pk%siz]		;size of this structure
	push free,[%PKGHEAD]		;header
	move o1,free			;make the vector pointer
	tlo o1,(object(ty%vec,0))
	push free,-3(q)			;name
	push free,-2(q)			;nicknames
	push free,nil			;uses
	push free,nil			;usedby
	push free,-1(q)			;internal
	push free,(q)			;external
	push free,nil			;shadowing
	movem o1,(q)			;save the structure
;now add the symbols in the list to the internal hash table
makpkl:	move o3,(p)			;get current symbol
	jumpe o3,makpkx
	move w3,at%pkg(o3)		;advance for next time
	movem w3,(p)
	move o1,at%pna(o3)		;pname is the key
	move o2,(q)			;package
	movem o2,at%pkg(o3)		;put it in the atom
	move o2,pk%int(o2)		;internal hash table
	tlo o3,(object(ty%cat,0))	;value is the atom itself
	call puthsh			;add to table
	jrst makpkl
;now add the package to the obarray
makpkx:	move o3,(q)			;return the package
	move o1,-3(q)			;the package name
	move o2,@[.PKGOBARRAY]
	call puthsh
	move o3,(q)			;package again
	skipn o1,pk%nic(o3)		;nickname?
	jrst makpkz			;no
	docar o1,o1			;yes, get it
	move o2,@[.PKGOBARRAY]
	call puthsh
makpkz:	move o1,(q)			;return the package
	subi q,4
	subi p,1
	ret1


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; FIND-SYMBOL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1 - string
;O2 [optional] - package

fndsym:	move o2,@[.PACKAGE]		;entry with one arg - default pkg
	push q,pk%use(o2)
	push q,o1
	push q,o2
;Q: uses; string; package
;first try externals
	move o2,pk%ext(o2)		;first look in externals
	call gethsh
	move o3,[$EXTERNAL]		;code for this
	jumpn o2,fndsyy			;yes, found it
;next internals
	move o1,-1(q)
	move o2,(q)
	move o2,pk%int(o2)
	call gethsh
	move o3,[$INTERNAL]
	jumpn o2,fndsyy			;found it
;next packages this one uses
fndsyl:	skipn o1,-2(q)			;uses anything?
	jrst fndsyn			;no, fails
	doboth o2,o1
	movem o3,-2(q)			;save CDR for later
	move o1,-1(q)			;string
	move o2,pk%ext(o2)
	call gethsh
	move o3,[$INHERITED]
	jumpn o2,fndsyy
	jrst fndsyl

;found something
fndsyy:	move o2,o3
	subi q,3
	ret2

;didn't
fndsyn:	setzb o1,o2
	subi q,3
	ret2

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; INTERN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1 - name
;O2 [optional] - package

intern:	move o2,@[.PACKAGE]	;supply optional arg
	call isstr
	 jrst [err1 o1,/~S not a string/]
	push q,o1
	push q,o2
	call fndsym+1		;call with 2 args -- rtns 2 vals
	jumpn o2,intrnz		;if got something, pass it back
;;TY%ATM
;here when we need to make a new symbol
	push free,[%.unbound]	;at%val - unbound
	move o3,free		;save addr of first for atom ptr
	push free,nil		;at%pro - no prop's yet
	push free,-1(q)		;at%pna - new pname
	push free,nil		;at%fun - no ftn defn
	push free,(q)		;at%pkg - this package
	push free,nil		;at%dsp - no ftn defn
	tlz o3,770000		;make it atom
	camle free,lastl	;see if went beyond end of space
	 call sgc		;yes
ifn ty%atm,[printx this code depends upon ty%atm being 0]
  ;Now do the actual INTERN
	move o2,(q)		;get the package
	move o1,-1(q)		;and the string
	movem o3,(q)		;and save the new symbol
	camn o2,@[.KEYPACKAGE]	;if keywords
	jrst intrnk		;special code
  ;here for normal package
	move o2,pk%int(o2)	;get internal hash table
	jrst intrny		;and say positive return
  ;here for keyword
intrnk:	movem o3,at%val(o3)	;make it self-eval
	move o2,pk%ext(o2)	;use external hash table
intrny:	call puthsh		;put this in
	move o1,(q)		;get back atom
	setz o2,		;2nd val nil if new atom
intrnz:	subi q,2
	ret2			;returning 2 values

;XINTER is a special version of INTERN designed to be called from READ.
;It finds the new string at the start of free space.  If the atom is
;already there, no extra free space is used.  If it has to create a
;new atom, the atom structure must be made here.
;	move w4,second word of byte pointer used to store the string
;	move w3, number of chars
;	call xinter
;	  returns atom in o1
;assumes string was started at FREE, and FREE was not updated.

;O2 - package

xinter:	xmovei o1,1(free)	;start of string
	push p,w4		;save new FREE for later
	sub w4,o1		;w4 is length in words
	tlo w3,(object(ty%sp5,0)) ;special GC code
	movem w3,(o1)		;as header
;we have not yet committed to actually using the new string.  If we
;don't, we want to make sure we don't leave spurious pointers lying
;around on the stack, etc.  So we call this a constant string, and
;change to to normal after we decide to make a new one.  We did actually
;have a GC problem without this code.
	tlo o1,(object(ty%cst,0)) ;make o1 string ptr from addr of start 
	push q,o1
	push q,o2
	call fndsym+1		;call with 2 args -- rtns 2 vals
	jumpn o2,xntrny		;if got something, pass it back
;;TY%ATM
;here when we need to make a new symbol
;turn the string from ty%cst into ty%str
	movsi w2,(<object ty%cst,0>#<object ty%str,0>)
	andcam w2,-1(q)
	move free,(p)		;update free to end of new string
	push free,[%.unbound]	;at%val - unbound
	move o3,free		;save addr of first for atom ptr
	push free,nil		;at%pro - no prop's yet
	push free,-1(q)		;at%pna - new pname
	push free,nil		;at%fun - no ftn defn
	push free,(q)		;at%pkg - this package
	push free,nil		;at%dsp - no ftn defn
	tlz o3,770000		;make it atom
	camle free,lastl	;see if went beyond end of space
	 call sgc		;yes
ifn ty%atm,[printx this code depends upon ty%atm being 0]
  ;Now do the actual INTERN
	move o2,(q)		;get the package
	move o1,-1(q)		;and the string
	movem o3,(q)		;and save the new symbol
	camn o2,@[.KEYPACKAGE]	;if keywords
	jrst xntrnk		;special code
  ;here for normal package
	move o2,pk%int(o2)	;get internal hash table
	call puthsh		;put this in
	move o1,(q)		;get back atom
	move o2,[$INTERNAL]	;say this is internal
	jrst xntrny		;and say positive return
  ;here for keyword
xntrnk:	movem o3,at%val(o3)	;make it self-eval
	move o2,pk%ext(o2)	;use external hash table
	call puthsh		;put it in
	move o1,(q)		;get atom
	move o2,[$EXTERNAL]	;and say this was external
xntrny:	subi q,2
	subi p,1
	ret2			;rtn 2 vals

illdot:	err /Dot context error/

illcom:	err /Comma must separate elements of a list/

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GENSYM
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

gensym:	jrst gensyd		;default case
;have an arg.  Can be string or integer
	skpint o1		;is it integer?
	jrst gensys		;no, try string
	movem o1,@[.GENSN]	;number, save it for next
	jrst gensyn		;have number in O1
;here if arg not an integer
gensys:	call isstr		;see if it is a string
	 jrst [err1 o1,/Argument to GENSYM neither string nor number: ~S/]
	movem o1,@[.GENSS]	;yes, save it away
;here for default case, increment the counter first
gensyd:	move o1,@[.GENSN]	;may be bignum, so do it the hard way
	call add1
	movem o1,@[.GENSN]
;here with .GENSN and .GENSS set
gensyn:	
;first copy the prefix
	move o1,@[.GENSS]	;get the prefix
	call getstr		;pointer in W2/W3, count in W4
	setz n,			;N will count char's in the new symbol
	push free,[object ty%sp5,0] ;length code for pname
	push p,free		;save pointer to this
	move o3,[440740,,0]	;o3/o4 is dest byte pointer
	xmovei o4,1(free)
	setzm 1(free)		;clear first word
	jumpe w4,getsnx		;now copy chars
getsnl:	ildb nil1,w2
	idpb nil1,o3
	aoj n,			;count it
	setzm 1(o4)		;make sure next word is clear
	sojg w4,getsnl
getsnx:	setzm 1(o4)
;finally, put in the number.  Since this can be a bignum, we
;have to call the general number printer.  we create a dummy
;channel pointing into the string we are making up.  This assumes
;that prnum isn't going to do any CONS's, which it isn't.
	dmovem o3,@[datsec,,dumchn+ch%bpt] ;byte pointer
	movem n,@[datsec,,dumchn+ch%bct] ;count
	xmovei n,gensyp		;put routine
	movem n,@[datsec,,dumchn+ch%put]
	setzb o3,o4		;return to Lisp context
	setz nil1,
	move o2,[object ty%cch,<datsec,,dumchn>]
	move o1,@[.GENSN]	;get the number
	call prnm10		;print it
	pop p,o2		;get back addr of string start
	move n,@[datsec,,dumchn+ch%bct] ;get back count
	iorm n,(o2)		;add in the count
	tlo o2,(object(ty%str,0)) ;and make it a string
	skipa free,@[datsec,,dumchn+ch%bpt+1] ;update free
;MAKE-SYMBOL
maksym:	move o2,o1	;NB: falling from above skips this
	push free,[%.unbound]	;at%val - unbound
	move o1,free		;save addr of first for atom ptr
	push free,nil		;at%pro - no prop's yet
	push free,o2		;at%pna - new pname
	push free,nil		;at%fun - no ftn defn
	push free,nil		;at%pkg - not interned
	push free,nil		;at%dsp - no ftn defn
	tlz o1,770000		;make it atom
	camle free,lastl	;see if went beyond end of space
	 call sgc		;yes
	ret1			;return it uninterned
	
;routine for tyo - note that no GC can happen during this
gensyp:	idpb w2,ch%bpt(o2)
	move nil1,ch%bpt+1(o2)	;clear the next word
	setzb nil1,1(nil1)
	aos ch%bct(o2)
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GENTEMP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;this is like GENSYM, but doesn't let the user reset the number,
;makes sure the result isn't interned, and interns it

;(gentemp &optional prefix package)
gentmp:	move o1,[makstr /T/]	;default prefix
	move o2,@[.PACKAGE]	;default package
	push q,o1		;save prefix
	push q,o2		;save package
;main loop - loop on counter until we find something unique
gentml:	move o1,@[.GENTSN]	;may be bignum, so do it the hard way
	call add1
	movem o1,@[.GENTSN]
;first copy the prefix
	move o1,-1(q)		;get the prefix
	call getstr		;pointer in W2/W3, count in W4
	setz n,			;N will count char's in the new symbol
	push free,[object ty%sp5,0] ;length code for pname
	push p,free		;save pointer to this
	move o3,[440740,,0]	;o3/o4 is dest byte pointer
	xmovei o4,1(free)
	setzm 1(free)		;clear first word
	jumpe w4,gentnx		;now copy chars
gentnl:	ildb nil1,w2
	idpb nil1,o3
	aoj n,			;count it
	setzm 1(o4)		;make sure next word is clear
	sojg w4,gentnl
gentnx:	setzm 1(o4)
;finally, put in the number.  Since this can be a bignum, we
;have to call the general number printer.  we create a dummy
;channel pointing into the string we are making up.  This assumes
;that prnum isn't going to do any CONS's, which it isn't.
	dmovem o3,@[datsec,,dumchn+ch%bpt] ;byte pointer
	movem n,@[datsec,,dumchn+ch%bct] ;count
	xmovei n,gensyp		;put routine
	movem n,@[datsec,,dumchn+ch%put]
	setzb o3,o4		;return to Lisp context
	setz nil1,
	move o2,[object ty%cch,<datsec,,dumchn>]
	move o1,@[.GENTSN]	;get the number
	call prnm10		;print it
	move o1,(p)		;get back addr of string start
	move n,@[datsec,,dumchn+ch%bct] ;get back count
	iorm n,(o1)		;add in the count
	tlo o1,(object(ty%str,0)) ;and make it a string
	move o2,(q)		;get package
	call fndsym+1		;look it up
	jumpn o2,gentmn		;already there, try again
;here if this symbol is OK
	pop p,o1		;get back addr of string start
	tlo o1,(object(ty%str,0)) ;and make it a string
	move free,@[datsec,,dumchn+ch%bpt+1] ;update free
	move o2,(q)		;get package
	subi q,2		;kill saved stuff	
	call intern+1		;and exit via intern
	ret1			;only return the atom

;here if we need to try again
gentmn:	subi free,1		;undo various sideeffects
	subi p,1
	jrst gentml		;and go try again
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  The Interpreter
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  Main loop
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;main read-eval-print
;This is not a full Common Lisp main loop.  That will be
;supplied in Lisp, and set up as the top level.  We do at least
;print multiple values.

topst:	movem p,savep'
	movem q,saveq'
	movem sp,savesp'
	move o1,[makstr /BOOT.INIT/]
	move o2,[$INPUT]
	move o3,[$DEFAULT]
	move o4,[$ERROR]
	move o5,[%STRCHR]
	call xopenf
	push q,o1		;save channel
topstl:	move o1,(q)		;get channel
	setz o2,		;no error on eof
	move o3,[%EOFOBJ]	;return this if EOF
	call read+3		;call read with one arg
	camn o1,[%EOFOBJ]
	 jrst topstx		;at EOF, start top level
	call ueval		;eval result
	jrst topstl		;back for more

topstx:	subi q,1

;here to restart top level command processing
toplev:	move w4,[%TOPLEV]	;is there an Slisp top level?
	skipn at%fun(w4)
	 jrst toplop
	  fncall w4,0		;yes, call it
toplop:	call chstlm		;reset stack limits if needed
	move o1,[object ty%cch,<datsec,,trmchn>] ;do talk if from terminal
	camn o1,@[.stdin]
	call lines0
	move o1,[makstr /*/]	;get prompt
	move o2,[object ty%cch,<datsec,,trmchn>] ;do talk if from terminal
	camn o2,@[.stdout]	;if output is to terminal
	call princ		;print the prompt
	call read
	call ueval		;(want mv's)
	call mv2lst		;convert MV's to a list, for easy printing
	call prnlst
	jrst toplop

;here to print a list of values
prnlst:	jumpe o1,prnlsn
	push q,o1
	call lines0
prnlsl:	pop q,o1
	jumpe o1,prnlsx
	pushcdr q,o1
	docar o1,o1
	call print
	jrst prnlsl

;here to print no values
prnlsn:	call lines0
	call terpri
	move o1,[makstr /<>/]
	call princ
prnlsx:	call terpri
	jrst terpri
	

;ATVAL(dest,atom) - when we have the actual atom
;;TY%ATM 
define atval(dest,atom)
	move dest,@[datsec,,at%val+atom]
	termin


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  Overall comments about the interpreter
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;Common Lisp has a fairly simple EVAL, except for the hooks to
;allow tracing, etc.  Most of the bulk of EVAL is the various
;user-level functions that set up the lexical binding variables
;in different ways.

;Most of the real work is done in APPLY.  In particular, it 
;contains the code to do lambda-binding, and to interpret the
;body.

;Note that our calling convention is that the first 5 args go in
;AC's O1 to O5.  Any additional args go on the stack.  For 0 to 5
;args, there are separate entry points for each number of args.
;When args are on the stack, we load the number of args into N.
;The internal conventions of the interpreter involve putting all
;the args on Q, with a count on P.  This is far more convenient
;for interpreted functions.  This does mean that functions such
;as FUNCALL and APPLY have to convert from one convention to another
;(and then IAPPLY converts back, in some cases).  Beware in the
;following code that a number of functions are entered not just
;at the label but at the next few instructions.  DECLSU sets up
;a dispatch table that goes directly to TMAERR and TFAERR for
;illegal numbers of arguments, and then to the function, +1, +2,
;etc., for all legal numbers.  Thus the function name is where we
;go for the minimum legal number of arguments.  E.g. if you
;want to call FUNCALL internally, be sure to use FUNCAL+n, where
;N is the number of args you are passing it - 1.

;We try to avoid doing CONS's in the interpreter, at almost all
;costs.  That's why we play games with stacks instead of making
;lists of things.  The most complex result of this involves the
;lexical enviornments.  The variables %VENV%, %BENV%, %FENV%, and
;%GENV% contain the lexical environment: V - local variable
;bindings, B - blocks, F - local function definitions, G - labels
;for GO.  These are all A-lists.  Normally we construct the
;A-lists on Q, instead of in the heap.  This makes sense because
;when we exit the function, we want it all to go away.  Whenever
;we return an environment to the user, e.g. by constructing a
;%LEXICAL-ENVIRONMENT, we call the function ENV2HP to copy these
;variables into the heap.  It resets the variables to point to their
;in-heap copies.  This must be done whenever there is any chance
;that someone is going to keep a pointer into this stuff other
;than those 4 variables.

;Binding is complicated, because a variable's value can be stored
;any of 3 places:  in its value cell, on %VENV% in the heap, and
;on %VENV% in the stack.  ALBIND handles that.  Because ALBIND
;may create new "cons cells" on the stack, nothing may be pushed
;on the stack when you call it.  This is a common source of bugs.

;See the MV support functions for how MV's are handled.  Please
;realize when doing this code that functions may return values in
;all of the Lisp AC's.

;Special variables are bound dynamically, as in Lisp 1.6.  The
;special PDL stores their old values.

;Note that we implement FEXPR's, although the spec doesn't include
;them.  This is because they are a convenient way to do some
;special forms.  We also have a real special form implementation,
;done by setting the address of the interpreter routine into
;AT%FEV.  In this case, EVAL dispatches directly to the routine
;fairly early in the code, without using APPLY at all.  We intend
;to make up code of this sort for the most commonly used functions,
;even ones that are not special forms, because it cuts down some
;of the interpreter overhead.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  EVAL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;Note that most of the work in EVAL is done in IAPPLY, which is
;%SP-INTERNAL-APPLY.

;(*EVAL exp &opt %v %f %b %g)
seval:	setz o2,		;entry vector
	setz o3,
	setz o4,
	setz o5,
	push p,sp
	bindit %%VENV%,o2
	bindit %%FENV%,o3
	bindit %%BENV%,o4
	bindit %%GENV%,o5
	move o2,[%T]		;presumably the user passed us real data
	bindit %%HENV%,o2
	call eval		;passing mv's...
	jrst unbind

;(EVAL exp)
ueval:	push p,sp
	bindit %%VENV%,nil
	bindit %%FENV%,nil
	bindit %%BENV%,nil
	bindit %%GENV%,nil
	bindit %%HENV%,nil
	call eval		;passing mv's
	jrst unbind

;(defun evalhook (form evalhookfn applyhookfn &opt %venv% %fenv% %benv% %genv%)
;  "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound
;  to applyhookfn.  Ignores these hooks once, for the top-level evaluation
;  of Form."

doevho:	jrst [setzb o4,o5 ? push q,nil ? push q,nil ? setz w4, ? jrst doevhn]
	setz o5,		;default %FENV%
	jrst [push q,nil ? push q,nil ? move w4,[%T] ? jrst doevhn]
	caile n,7		;6 or 7 args
	 jrst tmaerr
	caie n,7
	 push q,nil		;6 - default %GENV%
	move w4,[%T]		;presumably user passed us real data
doevhn:	push p,sp
	bindit %%HENV%,w4	;did user pass us real data?
	pop q,o6
	bindit %%GENV%,o6
	pop q,o6
	bindit %%BENV%,o6
	bindit %%FENV%,o5
	bindit %%VENV%,o4
	bindit %APPLYHOOK,o3
	bindit %EVALHOOK,o2
	move o6,[%T]
	bindit %SKEVHOOK,o6
	bindit %SKAPHOOK,nil
	call eval		;passing mv's
	jrst unbind

;(defun applyhook (function args evalhookfn applyhookfn
;		   &opt %venv% %fenv% %benv% %genv%)
;  "Applies Function to Args, with *Evalhook* bound to Evalhookfn and with
;  *Applyhook* bound to Applyhookfn.  Ignores the hook function once, for the
;  top-level application of Function to Args."
doapho:	jrst [setz o5, ? push q,nil ? push q,nil ? push q,nil ? setz w4,
	      jrst doaphn]
	jrst [push q,nil ? push q,nil ? push q,nil ? move w4,[%T]
	      jrst doaphn]
	caile n,8.		;6, 7, or 8 args
	 jrst tmaerr
	caie n,8.
	 push q,nil		;6 or 7 - default %GENV%
	caige n,7.
	 push q,nil		;6 - default %BENV%
	move w4,[%T]		;presumably user passed us real data
doaphn:	push p,sp
	bindit %%HENV%,w4	;did user pass us data?
	pop q,o6
	bindit %%GENV%,o6
	pop q,o6
	bindit %%BENV%,o6
	pop q,o6
	bindit %%FENV%,o6
	bindit %%VENV%,o5
	bindit %APPLYHOOK,o4
	bindit %EVALHOOK,o3
	move o6,[%T]
	bindit %SKEVHOOK,nil
	bindit %SKAPHOOK,o6
	call apply+1		;apply with 2 args (and n results)
	jrst unbind

;here if there is an *EVALHOOK*.  form in O1, hook in O2
evalho:	skipe @[.SKEVHOOK]	;unless told to skip
	jrst evalsh		;yes, skip hook once
	call env2hp		;copy the ENV variables to the heap
 ;set up for (funcall hook form ..ENV..)
	move o6,o2		;hook function
	atval o2,%%VENV%
	atval o3,%%FENV%
	atval o4,%%BENV%
	atval o5,%%GENV%
 ;rebind the hook to prevent recursion
	push p,sp
	bindit %EVALHOOK,nil
	fncall o6,5
	jrst unbind

;here if *SKIP-EVALHOOK* is set.  Skip hooking, but just this once
evalsh:	putval %SKEVHOOK,nil	;clear it, since it is once-only
	jrst evalnh		;and go do normal EVAL

;%EVAL - internal entry - keep current lexical env
eval:	skipe o2,@[.EVALHOOK]	;handle evalhook
	jrst evalho
evalnh:	movei n,1		;eeeech. I don't think there's a better way
	gettyp o1
	xct evaltb(w2)		;handle depending upon type

;;TYPES
evaltb:	jrst evalat		;atom
	jrst evalat
	jrst evalcn		;cons
	jrst evalcn
	retn			;string
	retn
	jrst evaler		;I/O channel
	jrst evaler
	jrst evaler		;hash table
	jrst evaler
	retn			;[Victor] vector (was jrst evaler)
	retn			;character
	jrst evalar		;array header
	jrst evaler		;special
	jrst evaler		;integer vector
	retn			;bit vector
	retn			;long float
	retn
	retn			;short float
	retn
	retn
	retn
	retn			;ratios
	retn
	jrst evaler		;special 36
	jrst evaler		;special 5
	retn			;bignum
	retn
	retn			;inum
	retn
	retn
	retn

evaler:	err1 o1,/Invalid form for EVAL: ~S/

;here for array header
evalar:	move o2,ah%dat(o1)	;see what the data is
	xtype o2
	caie w2,ty%bvc		;if a bit vector
	 cain w2,ty%xst		;or a string
	  retn			;then evals to itself
	jrst evaler		;else illegal

;EVALAT - here for an atom
evalat:	skipn o2,@[.%VENV%]	;any locals?
	jrst evala1		;no
	call iassq		;yes, try them first
	jumpn o2,evala2		;found anything?
evala1:	getgval o2,o1		;didn't, so try global value
	camn o2,[%.UNBOUND]
	jrst evalub
	move o1,o2
	retn

evala2:	docdr o1,o4		;found pair in %VENV% - return value part
	camn o1,[%INTSPC]	;but if %INTERNAL-SPECIAL
	jrst evala3		;then use special value
	retn

evala3:	docar o1,o4		;get back variable name
	jrst evala1		;and go get global value

;unbound error - here we establish an EVAL BLIP, as at EVALCN, so the
;debugger can process the error.  See the section below on stack hacking
;for what this means
evalub:	push p,sp
	push p,q		;save q for RETFROM
	push sp,nil		;eval blip
	push sp,o1		;put expression on SP for debugging
	push sp,[%savep]	;and saved p
	push sp,[inum 0]
	iorm p,(sp)
	docons o5,o1,nil	;actual var goes here
	move o1,nil		;don't know caller
	move o2,[$UNBND]
	move o3,[makstr /Unbound variable: ~S/]
	move o4,[makstr /Please define it before continuing/]
	fncall [%SIGCER],5
	move o1,-2(sp)		;get back var
	subi sp,4
	pop p,q
	pop p,sp
	jrst evalat

;here if form is an expression
evalcn:	
;For the break package, we put some information on the SP.  See the
;section below on stack hacking for what this means.
;Note that all of the special-purpose evaluators end with
;subi p,2 ? subi sp,4.  If you change the code below, you must
;change these.  Try searching for subi SP,4.
	push p,sp		;save old sp for unbind
	push p,q		;save q for RETFROM
	push sp,nil
	push sp,o1		;put expression on SP for debugging
	push sp,[%savep]	;and saved p
	push sp,[inum 0]
	iorm p,(sp)
;now we xct a location.  this is used to do single stepping, or anything
;else requiring a hook into the EVAL process.  This is the old ELISP
;eval hook, and may go away if the CL *EVALHOOK* turns out to take over
;all of its functions.
	xct evhook
;now see what we have
	docar o3,o1		;o3 - car of form
eval1:	gettyp o3
	xct eval1t(w2)

.scalar evhook

;;TYPES
eval1t:	jrst evdisp		;atom - dispatch function
	jrst evdsp1		; constant atom - also check for special
	jrst evsexp		;cons - either a lambda or lexical closure
	jrst evsexp
	repeat 36, jrst udf	;everything else

udf:	move o1,o3
udf1:	err1 o1,/Undefined function: ~S/

;(defun cerror-body (callers-name condition error-string continue-string args)

;here for case of atomic car that is undefined.  This one can be fixed by
;redefining it.

cudf:	push q,o1
	push q,o2
	push q,o3
	docons o5,o3,nil	;need to listify arg	
	move o1,nil		;don't know caller
	move o2,[$UNDEF]
	move o3,[makstr /Undefined function: ~S/]
	move o4,[makstr /Please define it before continuing/]
	fncall [%SIGCER],5
	pop q,o3
	pop q,o2
	pop q,o1
	jrst evdisp		;now try again


;main dispatch for atomic CAR
;here for constant atoms.  Special forms take precedence over all else
evdsp1:	caml o3,[object ty%cat,<datsec,,endobl>] ;only perm atoms have this
	jrst evdisp
	skipe w2,at%fev(o3)	;get evaluator for that atom
	jrst (w2)		;go there
evdisp:	jumpe o3,udf		;NIL is special, as at%fun(nil) is AC3
	skipe o2,@[%%FENV%]	;any local definition?
	jrst evlcfn		;maybe, let's see
evnlcf:	skipn o2,at%fun(o3)	;get function definition
	jrst cudf		;none
;now have definition in O2
evhdef:	docar o3,o2		;now check for binding, most common first
	came o3,[%SUBR]
	 camn o3,[%LAMBDA]
	  jrst evexpr		;normal form
	camn o3,[%MACRO]
	 jrst evmacr		;macro
	camn o3,[%FEXPR]
	 jrst evfexp		;fexpr
	jrst evexpr		;something odd, let apply worry about it

;here when %FENV% is non-nil
;o1=form, o2=%FENV%, o3=car form
evlcfn:	move o6,o1		;save form
	move o1,o3
	call iassq		;see if the function is locally bound
	move o1,o6		;restore form
	jumpe o2,evnlcf		;no local function
	docdr o2,o4		;(lambda ... or (macro lambda ...
	jrst evhdef		;have definition

;Here when CAR of the form is non-atomic.  Either a lambda, which will
; result in a lexical closure, or something really strange like an
; existing lexical closure:
;   O1 = form, O3 = car form, known to be a list
evsexp:	docar o2,o3
	camn o2,[%LAMBDA]	;if a lambda, make a closure
	jrst evsclo 
	move o2,o3		;else just apply whatever it is
	jrst evexpr
;here when function is really a lambda form
evsclo:	push q,o1		;save form for later
	call maklex		;max lexical closure
	move o2,o1		;put the closure here for evexpr
	pop q,o1		;get back form
	docar o3,o1		;car form (the function)
	docdr o4,o2		;cdr closure
	dorpa o4,o3		;put the function in as element 2
	jrst evexpr		;now let apply handle it

;;;;;;;;;;;;;;;;;;;
;;;; We now want to prepare for IAPPLY.  This takes the definition and
;;;; then the arguments on Q, and the count of args on 0(P).
;;;; Of course we still have the EVAL blip on SP, and saved SP and Q on P
;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;
;;;; EVEXPR
;;;;;;;;;;;;;;;;;;;
;here with O1 = form, O2 = definition, LAMBDA or SUBR
evexpr:	push q,o2		;save definition
	push p,[0]		;create count
evexpl:	docdr o1,o1		;get just the actuals
	jumpe o1,evexap		;stop when no more args
	push q,o1		;save actuals
	docar o1,o1		;first actual
	call eval		;eval it
	aos (p)			;count args
	exch o1,(q)		;get back actual list, save result
	jrst evexpl		;now see if there is anything more

;here when ready to do APPLY.  Either go to IAPPLY or call the hook
evexap:	skipn o1,@[.APPLYHOOK]	;is there one?
	jrst iapply		;no, go do %SP-INTERNAL-APPLY
	skipe @[.SKAPHOOK]	;%SKIP-APPLYHOOK?
	jrst evexsk		;yes
;we want to call the hook function as follows:
;  (hookfun function args %venv% ...)
;at the moment the stuff is
;    P, SP, standard EVAL blip (SP 4, P 2)
;    P - arg count
;    Q - definition, then args
;all the registers are free
	call env2hp		;copy the ENV variables to the heap
	setz o3,		;args will go here
evexal:	sosge (p)		;any args left?
	jrst evexax		;no, do the call
	pop q,o4		;yes, get last
	docons o3,o4,o3		;and add it to list
	jrst evexal	
evexax:	subi q,1		;don't need the definition
	subi p,1		;don't need the arg count
	move o2,-2(sp)		;get the original form from the blip
	docar o2,o2		;the function is the CAR
;by clever AC allocation, we now have the right args for FUNCALL in O1,O2,O3
;it remains only to supply the enviornment variables
 ;set up for (funcall hook form ..ENV..)
	atval o4,%%VENV%
	atval o5,%%FENV%
	atval o6,%%BENV%
	push q,o6
	atval o6,%%GENV%
	push q,o6
	movei n,7
 ;rebind the hook to prevent recursion
	bindit %APPLYHOOK,nil
	call funcall+<2*<6-1>>	;6+ arg funcall  (passes mv's)
	pop p,q			;canonical EVAL exit code
	jrst unbind

;here if *SKIP-APPLYHOOK*.  This is a once-only skip of the hooking.
evexsk:	putval %SKAPHOOK,nil	;clear it, so once-only
	jrst iapply		;no go do our thing
	
;;;;;;;;;;;;;;;;;;;
;;;; EVFEXP
;;;;;;;;;;;;;;;;;;;
;here with O1 = form, O2 = definition, (FEXPR LAMBDA or (FEXPR SUBR
evfexp:	pushcdr q,o2		;save definition
	push p,[1]		;create count, always one arg
	pushcdr q,o1		;pass unevaled actuals
	jrst iapply		;that's all, folks

;;;;;;;;;;;;;;;;;;;
;;;; EVMACR
;;;;;;;;;;;;;;;;;;;
;here with O1 = form, O2 = definition, (MACRO LAMBDA or (MACRO SUBR
evmacr:	exch o2,o1		;put form in O2
	docdr o1,o1		;definition in O1
	fncall @[.MEXPH],2
	call eval		;result(s) in Ox  -- SP and Q are on P
	subi sp,4		;kill eval blip
	subi p,2		;and saved SP,Q
	retn


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; APPLY
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;
;;;; IAPPLY - does most of the interesting work
;;;;   args: P, SP, standard EVAL blip (SP 4, P 2)
;;;;         P - arg count
;;;;	     Q - definition, then args
;;;;;;;;;;;;;;;;;;;;;;;

iapply:	move w2,-1(p)		;get back saved Q
	move o1,1(w2)		;definition
	docar o2,o1		;car definition
;now dispatch in order of likelihood
;note that we don't need to rebind the environment variables
;for SUBR's, since those variables are relevant only for 
;interpreted code.
	camn o2,[%SUBR]
	jrst apsubr
	bindit %%VENV%,nil
	bindit %%FENV%,nil
	bindit %%BENV%,nil
	bindit %%GENV%,nil
	bindit %%HENV%,nil
iappll:	camn o2,[%LAMBDA]
	jrst aplamb
	camn o2,[%LEXCLO]
	jrst aplexc
	err1 o1,/Illegal form: ~S/

illreb:	err /Trying to set T, NIL, or something that isn't a variable/

;invoke compiled code
apsubr:	move n,(p)		;get number of args
	docdr o2,o1		;get address
	docar w3,o2
	caig n,6
	 add w3,n
	caile n,6
	 addi w3,6
	dmove o1,2(w2)		;get the first 5 args
	dmove o3,4(w2)
	move o5,6(w2)		;[Victor] don't get o6!
	move o6,-2(sp)		;[Victor] get function name from EVAL blip
	call @(w3)		;allow mv's through
	subi p,1		;number of args
	pop p,q
	pop p,sp
	retn
	
;invoke lexical closure, the closure is O1
aplexc:	docdr o1,o1		;get to the function
	doboth o1,o1		;O1-ftn, O2-rest
	doboth o2,o2		;O2-venv, O3-rest
	putval %%VENV%,o2
	doboth o2,o3		;O2-fenv, O3-rest
	putval %%FENV%,o2
	doboth o2,o3
	putval %%BENV%,o2
	docar o2,o3
	putval %%GENV%,o2
	move o2,[%T]		;closures always have real data
	putval %%HENV%,o2
	movem o1,1(w2)		;save new definition
	docar o2,o1
	jrst iappll		;now go process it

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  Well, here it is, folks, the heart of the interpreter
;;;;  This code interprets lambdas.  It was obtained by
;;;;  hand-coding %SP-INTERNAL-APPLY from Spice Lisp.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;invoke lambda, the form is in O1
aplamb:	docdr o1,o1		;skip LAMBDA
	docar o5,o1		;O5 - var list
	docdr o1,o1		;O1 - body
	call extspc		;returns O1-updated body,O6-specials
	exch o1,o5		;O5 is final body; O1-var list
	setz w3,		;W3 - are we in optional section
	move n,(p)		;N - number of actuals
	move w4,-1(p)		;W4 - location of first actual

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Normal arguments
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;main binding loop.  One more thing is on Q than at entry
;  W3 - non-0 if we are processing optionals
;  W4 - location of prev actual
;  N - number of remaining actuals
;  O1 - remaining formals (list)
;  O2 - current formal
;  O3 - current actual
;  O5 - body
;  O6 - list of specials
albndl:	scons o1		;stop if more formals
	jrst albndx
	docar o2,o1		;O2 - current formal
	docdr o1,o1		;advance O1
;we try to optimize normal arguments by checking for unusual
;cases as quickly as possible.
	camge o2,[endamp]	;see if ampersand thing
	camge o2,[begamp]
	satom o2		;here if not ampersand
	jrst albndn		;ampersand or not symbol
;here for symbolic arg
	jumple n,albndd		;if no more actuals, use default
	aoj w4,			;get actual
	move o3,1(w4)
	call albind		;do the binding
	soja n,albndl		;and see if more

;here when no more formals
albndx:	jumple n,albody		;match, go do body
	cerr1 o1,/Ignore excess args./,/Excess arguments in function call: ~S/
	jrst albody		;ignore extras if continued

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Dispatch for various kinds of arguments
;;;;  The actual entry to this code is at ALBNDN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;here when formal is an ampersand-thing
;for speed, we just checked that it was an & argument.  Here
;we figure out which one
albnda:	camn o2,[%amopt]
	 aoja w3,albndl		;just set optionals flag and try again
	camn o2,[%amrest]
	 jrst alrest		;go process rest
	camn o2,[%amkey]
	 jrst alkey		;go process keys
	camn o2,[%amallow]
	 jrst [err1 o1,/&ALLOW-OTHER-KEYWORDS not legal here, remaining args: ~S/]
;for &aux, we should have used up all actuals
	came o2,[%amaux]
	 jrst [err1 o2,/Internal error: unknown & keyword: ~S/]
	jumple n,alaux		;match, go do aux
	cerr1 o1,/Ignore them./,/Too many arguments.  Extra: ~S/
	jrst alaux

;here when symbolic formal but no actual
albndd:	skipn w3		;better be in optionals section
	jrst [err /Too few arguments to function/]
	move o3,nil		;use NIL as default
	call albind		;bind it
	jrst albndl		;and see if more

;here when formal list has ampersand or non-symbol
;for speed, we did
albndn:	snatom o2
	jrst albnda		;ampersand

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; &OPT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;here for non-symbol.  Process an optional arg
	skipe w3		;better be processing optionals
	scons o2		;better be a cons
	 jrst [err1 o2,/Optional arg not a list: ~S/]
	docar o4,o2		;better start with a formal
	satom o4
	 jrst [err1 o2,/Formal arg not a symbol: ~S/]
;we now seem to have a legal default type formal
	jumple n,albnnn		;see if actual supplied
;default-type formal, for which actual is supplied
	aoj w4,			;yes, get actual
	move o3,1(w4)
	exch o2,o4		;get var in O2, save rest of expr in O4
	call albind		;do the binding
	move o3,[%T]		;say we supplied actual
	jrst albnnp		;and look for supplied-P

;default-type formal, for which actual is not supplied
albnnn:	docdr o3,o2		;default supplied?
	sncons o3
	 jrst albnnd		;yes, use it
	move o2,o4		;no, just bind formal
	jrst albndd		;to nil
;here when there is a default value supplied
;unfortunately, we have to EVAL it, so we have to save the kitchen sink
albnnd:	push q,o2		;save whole arg
	push p,w3
	push p,w4
	push q,o1
	push q,o4		;will be O2
	push q,o5
	push q,o6
	docar o1,o3		;get the thing to EVAL
	call eval
	move o3,o1		;put it in ACTUAL place
	pop q,o6
	pop q,o5
	pop q,o2
	pop q,o1
	pop p,w4
	pop p,w3
	pop q,o4
	call albind		;bind it
	move o3,nil		;say there was no arg supplied

;see if we have a supplied-P thing, i.e. (formal default supplied-P)
;the value to supply is in O3
albnnp:	docdr o2,o4
	scons o2
	 jrst albnnx
	docdr o2,o2
	scons o2
	 jrst albnnx
	docar o2,o2
	satom o2
	 jrst [err1 o2,/Formal argument not a symbol: ~S/]
	call albind
albnnx:	jumple n,albndl		;don't overdecrement
	soja n,albndl		;and see if more

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  Main body of function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;here to process the body
albody:	jumpe o5,albodn		;any body there?
	push q,o5		;yes, save it
albodl:	move o1,(q)		;get back the body
	doboth o1,o1		;O1 - next thing to do; O2 - rest
	jumpe o2,albodx		;if this is last, do it specially
	movem o2,(q)		;put back advanced body
	call eval		;eval for side-effect only
	jrst albodl
;here to eval last thing in the body
albodx:	call eval		;we have two things on P
albodn:	subi p,1		;skip saved arg count
	pop p,q
	jrst unbind

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; &REST
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;here to handle &REST
alrest:	scons o1		;better be (var ...)
	 jrst [err1 o1,/No variable after &REST: ~S/]
	docar o2,o1		;get the formal to which we bind rest
	docdr o1,o1		;and advance for next
	satom o2
	 jrst [err1 o1,/Formal for &REST not a symbol: ~S/]
	setz o3,		;O3 will be the list
	jumple n,alrstx		;done if no more actuals
;we use copies of w4 and n, since &key is legal after this, and
;it will need to see the actuals again
	move w2,n		;w2 is now count
	move w3,w4		;w3 is now pointer
	addi w3,1(w2)		;get to last actual	
alrstl:	pop w3,o4		;get actual
	docons o4,o4,o3
	move o3,o4
	sojg w2,alrstl
alrstx:	call albind		;bind to the formal
	scons o1		;any more formals?
	jrst albody		;no, execute the body
	docar o2,o1		;see what we have next in formals
	docdr o1,o1		;and advance it
	camn o2,[%amkey]	;only these two are legal
	 jrst alkey
	camn o2,[%amaux]
	 jrst alaux
illamp:	err1 o2,/& keyword in improper context: ~S/

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  &AUX
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;NB: maybe we should check N here to see if any actuals are
; left.  If so, note that alrest will leave N non-zero.
;here to handle &AUX
alaux:	scons o1		;any more formals?
	jrst albody		;no, go do body
	docar o2,o1		;get next formal
	docdr o1,o1		;and advance the list
	camge o2,[endamp]	;ampersands not legal here
	camge o2,[begamp]
	jrst .+2
	 jrst illamp
	snatom o2
	 jrst alauxb		;if atom, do it
	scons o2		;then better be a cons
	 jrst [err1 o2,/&AUX variable not a symbol: ~S/]
   ;o2 is (var value)
	doboth o2,o2		;o2 var, o3 (value)
	satom o2		;variable had better be
	 jrst [err1 o2,/&AUX variable not a symbol: ~S/]
	scons o3		;if value is missing
	 jrst alauxb		;just use NIL
   ;have to EVAL the value, so better save everything
	push q,o1
	push q,o2
	push q,o5
	push q,o6
	docar o1,o3		;get the expression
	call eval
	move o3,o1		;put it in O3, where ALBIND wants it
	pop q,o6
	pop q,o5
	pop q,o2		;variable
	pop q,o1		;rest of list
	call albind
	jrst alaux		;now see if more

;here to bind O2 to nil
alauxb:	setz o3,
	call albind
	jrst alaux

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  &KEY
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;Here to process keywords
;Unfortunately we have too much stuff to fit in the AC's.  Inside
;the main loop, for each keyword formal, we will push the following
;information on the stack, in the order given:
;  KEY - the keyword
;  VAR - the variable to be bound, usually the same as the key
;  INIT - the value to use if the user doesn't supply it
;  SVAR - a variable to bind that will show whether it was present
;The main loop uses the usual AC's
alkey:	trne n,1		;user better supply an even number of args
	 jrst [err1 o1,/Need even number of args after &KEY: ~S/]
	lsh n,-1		;N is now number of pair
alkeyl:	scons o1		;any formals left?
	jrst albody		;no, do the body
	docar o2,o1		;next keyword from formals
	docdr o1,o1		;advance for next time
	camn o2,[%amaux]	;if &AUX, we're done
	 jrst alaux
	camn o2,[%amallow]	;ignore &ALLOW-OTHER at the moment
	 jrst alkeyl
	camge o2,[endamp]	;other ampersand stuff is illegal here
	camge o2,[begamp]
	jrst .+2
	 jrst illamp
	satom o2		;if it's an atom, things are easy
	 jrst alkey1
	push q,o1		;will put the keyword here, saving O1 now
	push q,o2		;the variable
;in general, this is going to be a variable.  We need a symbol
;by the same name in the keyword package to act as the keyword
	move o1,at%pna(o2)	;the name
	move o2,@[.KEYPACKAGE]	;in this package
	push q,o5
	push q,o6
	push p,w4
	push p,n
	call intern+1
	pop p,n
	pop p,w4
	pop q,o6
	pop q,o5
	exch o1,-1(q)		;store keyword and restore O1
	push q,nil
	push q,nil
	jrst alkeyd		;do the keyword
;here we look for (key init svar), allowing defaults for missing ones
alkey1:	scons o2		;not atom, better be cons
	 jrst [err1 o2,/Keyword not a symbol: ~S/]
	docar o3,o2		;hope it is (:key ...)
	satom o3
	 jrst alkey4		;no, obscure form
	push q,o1		;this will be the keyword - save O1 now
	push q,o3		;this is the variable
	push q,o2		;have to save O2 also
	move o1,at%pna(o3)	;the name
	move o2,@[.KEYPACKAGE]	;in this package
	push q,o5
	push q,o6
	push p,w4
	push p,n
	call intern+1
	pop p,n
	pop p,w4
	pop q,o6
	pop q,o5
	pop q,o2
	exch o1,-1(q)		;use this as the key, get back O1
alkey5:	docdr o3,o2		;anything more?
	sncons o3
	 jrst alkey2		;yes
	push q,nil		;no, this is an easy one
	push q,nil
	jrst alkeyd		;do it
alkey2:	doboth o2,o3
	sncons o3		;anything more?
	 jrst alkey3		;yes
	push q,o2		;no, so have an INIT
	push q,nil		;but no SVAR
	jrst alkeyd
alkey3:	push q,o2		;have everything
	pushcar q,o3
	jrst alkeyd

;here for ((key var) init svar)
alkey4:	scons o3		;not atom, better be cons
	 jrst [err1 o3,/Keyword not a symbol: ~S/]
	doboth o3,o3		;O3 key, O4 (var)
	sncons o4
	satom o3
	 jrst [err1 o3,/Keyword not a symbol: ~S/]
	docar o4,o4		;O3 key, O4 var
	satom o4
	 jrst [err1 o4,/Formal not a symbol: ~S/]
	push q,o3
	push q,o4
	jrst alkey5		;now look for init and svar

;here once key, var, init, and svar are set up
alkeyd:	move w2,w4		;pointer to first variable
	move w3,n		;number of pairs
	jumple w3,alkeyi	;no args left, use init form
alkydl:	move o2,2(w2)		;get arg
	camn o2,-3(q)		;EQ to key?
	jrst alkydq		;yes, found it
	addi w2,2		;no, look for next user arg
	sojg w3,alkydl
;here if user has not supplied this keyword
alkeyi:	exch o1,-1(q)		;get init form
	push p,w4
	push q,o5
	push q,o6
	push p,n
	call eval
	pop p,n
	move o3,o1		;save result where ALBIND wants it
	pop q,o6
	pop q,o5
	pop p,w4
;we have to pop KEY, VAR, INIT, and SVAR off now, since ALBIND does
;not allow anything to be on Q
	move o4,(q)		;svar - save for later
	move o1,-1(q)		;"init" - we saved O1 there above
	move o2,-2(q)		;var
	subi q,4		;we don't need key any more
	call albind		;bind var to default
	jumpe o4,alkeyl		;if no SVAR, continue with next keyword
	move o2,o4		;move SVAR into variable position
	setz o3,		;bind to NIL, as user didn't specify value
	call albind
	jrst alkeyl		;now go for next keyword

;here if user did supply the keyword
alkydq:	move o3,3(w2)		;user's arg
;again, we have to pop everything off of Q
	move o4,(q)		;save SVAR here
	move o2,-2(q)		;get var to bind
	subi q,4		;don't need anything else
	call albind
	jumpe o4,alkeyl		;if no SVAR, continue with next keyword
	move o2,o4		;move SVAR into variable position
	move o3,[%T]		;bind to T, as user did specify value
	call albind
	jrst alkeyl		;that's all for this keyword

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; APPLY
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1, function
;O2 up args.  Differs from FUNCALL in that the last
;  arg is assumed to be a list
;Currently this is just a front-end to FUNCALL

apply:	jrst funcal	;no function args, so nothing to spread
	jrst app2
	jrst app3
	jrst app4
	jrst app5
;here if more than 5 args
	pop q,w3	;get the last
	subi n,1	;and remove from count
	jumpe w3,funcal+<2*<5-1>> ;if nothing, then just have 5 args
applnl:	scons w3
	 jrst [err1 w3,/Invalid final APPLY arg: ~S/]
	doboth w2,w3	;else push args
	push q,w2
	addi n,1	;and count them
	jumpn w3,applnl
	jrst funcal+<2*<6-1>> ;now do it
;here for small numbers of args
app2:	move w3,o2	;get last arg here
	jrst appl2	;and start spreading with O2
app3:	move w3,o3	;get last arg here
	jrst appl3	;and start spreading with O3
app4:	move w3,o4
	jrst appl4
app5:	move w3,o5
	jrst appl5
;here to do the spreading
appl2:	jumpe w3,funcal	;nothing to put in O2
	docar o2,w3
	docdr w3,w3
appl3:	jumpe w3,funcal+2
	docar o3,w3
	docdr w3,w3
appl4:	jumpe w3,funcal+4
	docar o4,w3
	docdr w3,w3
appl5:	jumpe w3,funcal+6
	docar o5,w3
	docdr w3,w3
	jumpe w3,funcal+10
	movei n,5
	jrst applnl	;more than 5, go loop

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; APPLY-BUT-LAST
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1, function
;O2 up args.  Differs from FUNCALL in that the net to last
;  arg is assumed to be a list
;Currently this is just a front-end to FUNCALL

appbl:	jrst funcal	;no function args, so nothing to spread
	jrst funcal+2	;only one arg - that one isn't spread
	jrst appbl3
	jrst appbl4
	jrst appbl5
;here if more than 5 args
	pop q,o6	;get the last
	subi n,1	;remove it from count
	caig n,5	;one to be spread also on the stack?
	jrst [move w3,o5  ;no, get it from O5
	      jrst apbl6]
	pop q,w3	;yes
	subi n,1	;remove it from count
apbl7:	jumpe w3,apblx
apbll:	doboth w2,w3	;push args
	push q,w2
	addi n,1	;and count them
	jumpn w3,apbll
apblx:	push q,o6	;last arg
	addi n,1	;count it
	jrst funcal+<2*<6-1>> ;now do it
;here for small numbers of args
appbl3:	move o6,o3	;get last arg here
	move w3,o2	;and start spreading O2
	jrst apbl3
appbl4:	move o6,o4
	move w3,o3
	jrst apbl4
appbl5:	move o6,o5
	move w3,o4
	jrst apbl5
;here to do the spreading
apbl3:	jumpe w3,[move o2,o6
		  jrst funcal+2]
	docar o2,w3
	docdr w3,w3
apbl4:	jumpe w3,[move o3,o6
		  jrst funcal+4]
	docar o3,w3
	docdr w3,w3
apbl5:	jumpe w3,[move o4,o6
		  jrst funcal+6]
	docar o4,w3
	docdr w3,w3
apbl6:	jumpe w3,[move o5,o6
		  jrst funcal+10]
	docar o5,w3
	docdr w3,w3
	movei n,5
	jrst apbl7

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; FUNCALL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;This function is long mostly because it is sort of unrolled.
;  I have optimized it for the case where the thing being called
;  is compiled.  If not, then we call IAPPLY.  Note that we
;  have to shift the arguments, since O2 becomes O1 when we
;  finally call the function, etc.
;O1, function
;O2 up args

;temporarily, I have really specialized code for 1 and 2 arg functions,
; because this is important for sequence functions

funcal:	movei w3,0		;entries for 1 to 5 args
	jrst funcle
	movei w3,1
	jrst funcle
	movei w3,2
	jrst funcle
	movei w3,3
	jrst funcle
	movei w3,4
	jrst funcle
;here for 6 or more.  The main complication is that the bottommost
;arg must go into the AC's
	movn w2,n		;get first arg from stack
	add w2,q
	move o6,6(w2)
	push p,[codsec,,[subi q,1 ? retn]] ;and at exit, clean it up
	subi n,1		;now adjust counts
	movei w3,6		;normally use entry 6 in vector
	cain n,5		;but if 5 args
	movei w3,5		;use that
;common code for all numbers of args
funcle:	exch o1,o2		;put args in right place
	exch o2,o3
	exch o3,o4
	exch o4,o5
	exch o5,o6
	fjcaln o6

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Utilities for EVAL.  Note that these come before EVAL in the source.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;EXTSPC - scans for special declarations.  Skips all decls and
; doc strings, so that O1 ends up pointing to the first real
; member of the body.
;O1- body
;O6 - any specials already seen
;returns updated body in O1, list of specials in O6
;preserves O5, assumes other AC's are free

;Note an optimization:  The first list of specials is simply moved
;to O6.  We only start copying if we see a second list.  The
;copy is made using CONS cells created on Q, since this list
;is no longer of interest once we stop processing this argument
;list.

extspc:	setz o6,		;result will go here
extspl:	scons o1		;anything left?
	 iret			;no, return what we have
	doboth o2,o1		;see what is first
	xtype o2		;see what we have
  ;the only array that is legal in code is a string, so we blithely
  ;assume that ty%xar must be one.
	caie w2,ty%xar
	 cain w2,ty%xst
	  jumpn o3,extspn	;string, skip it
  ;note the jumpn o3.  If the string is the last thing in the body,
  ;we want to return it as a value instead of treating it as doc.
extspf:	scons o2		;if not a cons either
	 iret			;that's all, return what we have
	doboth o3,o2		;O3,O4 are car,cdr of form
	camn o3,[%DECLARE]	;if declaration
	 jrst extspd		;go process it
  ;now look for a macro that expands to a DECLARE
	snatom o3		;see if CAR for the form is a symbol
	 skipn o3		;and non-NIL
	  iret			;not, that's all
	skipn o4,at%fun(o3)	;see if we have a definition
	 iret			;no
	scons o4		;make sure the defn has a CAR
	 iret			;no
	docar o3,o4		;take it
	came o3,[%MACRO]	;and is MACRO
	 iret			;no
	push q,o1
	push q,o5
	push q,o6
	move o1,o2		;form in O1
	move o2,o4		;definition in O2
	call imexp		;expand macro
	move o2,o1		;put new form where extspf wants it
	pop q,o6
	pop q,o5
	pop q,o1
	jrst extspf		;now evaluate expanded macro

;here to handle a DECLARE, form in O2, CDR in O4
;O1 must be preserved
extspd:	scons o4		;see if any more declarations in this form
	 jrst extspn		;no, continue with body
	doboth o3,o4		;decl in O3, rest in O4
	scons o3		;decl must be a list
	 jrst extspd		;not, forget it
	doboth o2,o3		;decl type in O2, items in O3
	came o2,[%SPEC]		;only look at SPECIAL decls
	 jrst extspd		;not, next decl
	jumpn o6,extspa		;already have some specials, append these
	move o6,o3		;first, just use the list - don't copy it
	jrst extspd		;look for more decls
;here to append list of specials in O3 to O6
;preserve O1 and O4
extspa:	scons o3		;stop at end of list
	jrst extspd		;look for more decls
	doboth o2,o3		;first item in O2, rest of list O3
 ;pseudo cons O2, O6 and put back in O6
	push q,o2		;(item . old-list)
	move w2,q		;create pseudo-CONS in Q
	tlo w2,(object(ty%ccn,0)) ;don't copy this guy!
	push q,o6
	move o6,w2		;this is new value of list
	jrst extspa		;next item in list	

;here to check next item in body
extspn:	docdr o1,o1		;advance
	jrst extspl		;and try again



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; MACRO expansion.  
;;;;  Most of this is setting up the lexical enviornment variables
;;;;  for the user functions.
;;;; Note that these guys return MV's.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;MACROEXPAND-1  form &opt %venv% %fenv% %benv% %genv%
mexp1:	jrst [setzb o2,o3 ? setzb o4,o5 ? setz o6, ? jrst mxp1n]
	setz o3,
	setz o4,
	setz o5,
	move o6,[%T]		;presumably user passed us real data
mxp1n:	push p,sp
	bindit %%VENV%,o2
	bindit %%FENV%,o3
	bindit %%BENV%,o4
	bindit %%GENV%,o5
	bindit %%HENV%,o6	;data on heap?
	call imexp1
	jrst unbind

;%MACROEXPAND-1
imexp1:	scons o1
	 jrst mexp1n		;if not cons, can't expand
	docar o2,o1		;now look at the car
	snatom o2		;better be atom
	 skipn o2		;nonNIL
	  jrst mexp1n
	skipe o3,@[%%FENV%]	;if have local definitions
	 jrst mexlc		;check them first
mexlcn:	skipn o3,at%fun(o2)	;better have a definition
	 jrst mexp1n
mexlcy:	scons o3		;and it better have a CAR
	 jrst mexp1n
	docar o4,o3		;take it
	came o4,[%MACRO]	;and it should be MACRO
	 jrst mexp1n
	docdr o2,o3		;definition in O2
	exch o1,o2	
	fncall @[.MEXPH],2	;normally funcall
	move o2,[%T]		;say did expand
	ret2

mexp1n:	setz o2,		;say didn't expand
	ret2

;here to check local function definitions

mexlc:	push q,o1		;save form
	dmove o1,o2
	call iassq		;see if the function is locally bound
	pop q,o1		;restore form
	jumpe o2,mexlcf		;no local function
	docdr o3,o4		;(lambda ... or (macro lambda ...
	jrst mexlcy		;have definition

mexlcf:	docar o2,o1		;restore O2
	jrst mexlcn		;and go look at atom

;MACROEXPAND  form &opt %venv% %fenv% %benv% %genv%
mexp:	jrst [setzb o2,o3 ? setzb o4,o5 ? setz o6, ? jrst mexpn]
	setz o3,
	setz o4,
	setz o5,
	move o6,[%T]		;presumably user passed us real data
mexpn:	push p,sp
	bindit %%VENV%,o2
	bindit %%FENV%,o3
	bindit %%BENV%,o4
	bindit %%GENV%,o5
	bindit %%HENV%,o6	;data on heap?
	call imexp
	jrst unbind

;%MACROEXPAND
imexp:	call imexp1		;do it once
	movei n,1
	jumpe o2,cpopj		;if nothing done, that's it
imexpl:	call imexp1		;else try again
	movei n,1
	jumpn o2,imexpl		;and keep going as long as more expansion
	move o2,[%T]		;say it expanded
	ret2

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  Variable binding.  ALBIND is used by all of the interpreter
;;;;  routines to bind variables.  This task is so complex in
;;;;  Common Lisp that everybody should use this one function.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;ALBIND - AC's must be set as in ALBNDL.  Add (O2 . O3) to %VENV%
;  Checks O2 to see if it is in list O6 before
;  doing this.  If so, bind O2 to O3 as special.
;uses only W2 as work
;***WARNING*** - we put cons cells on Q, so you had better not have
;  anything saved on Q.
;***WARNING*** - may change the value of O3
albind:	jumpe o2,illbnd
	snatom o2
;	came o2,[%NIL]
	camn o2,[%T]
	jrst illbnd
;look down the property list to see if this is globally special
	move w2,at%pro(o2)	;see if globally special
	jumpe w2,albslx		;no property list
albsll:	doboth nil1,w2		;nil1 - property, w2 - rest of plist
	came nil1,[%CONSTANT]	;constant or
	camn nil1,[%GLOSPEC]	;globally special?
	jrst albsly		;yes
	docdr w2,w2		;no, skip this value
	jumpn w2,albsll
;fall through at end of plist
albsln:	setz nil1,		;normalize NIL1
;done with property list, see if declared special locally
albslx:	jumpe o6,albinx		;if any specials, see if this is one
	move w2,o6		;copy to O4 so we can CDR it
albinl:	camn o2,(w2)		;compare formal to (CAR specials)
	jrst albins		;is special
	docdr w2,w2		;not this one, try next
	jumpn w2,albinl
;here if formal is not special
;we create a binding (formal . value) and put it on %VENV%
albinx:	skipe @[.%HENV%]	;in heap?
	jrst albinh		;yes, do real cons
	push q,o2		;(formal . value)
	move w2,q		;create pseudo-CONS in Q
	tlo w2,(object(ty%ccn,0)) ;don't copy this guy!
	push q,o3
	push q,w2		;((formal . value) ...old-list)
	addi w2,2		;O4 is now this new cell
	exch w2,@[.%VENV%] 	;it is new list, O4 is now old
	push q,w2
	iret	
;here to put the binding in the heap
albinh:	push free,o2		;(formal . value)
	move w2,free		;create real CONS this time
	tlo w2,(object(ty%con,0))
	push free,o3
	push free,w2		;((formal . value) ...old-list)
	addi w2,2		;O4 is now this new cell
	exch w2,@[.%VENV%]	;it is new list, O4 is now old
	push free,w2
	caml free,lastl		;make sure there is space
	 call sgc		;special version of GC that saves AC's
	iret
;here to bind as special
albins:	fasgbind o2,o3
	move o3,[%INTSPC]	;and say it was bound specially
	jrst albinx		;do lexical binding of this tag

;here if we found %GLOBALLY-SPECIAL or %CONSTANT property on the atom's plist
albsly:	came nil1,[%GLOSPEC]	;special?
	jrst illbnd		;no, must be constant
	skipn (w2)		;make sure it has non-NIL value
	jrst albsln		;value is NIL, so treat as non-special
	setz nil1,		;normalize NIL1
	jrst albins		;and bind as special

;here if somebody is trying to bind a constant
illbnd:	setz nil1,		;normalize NIL1
	err1 o2,/Attempt to bind a constant: ~S/
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;  Special forms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;EVEXIT is used to end all special forms, unless binding
; has been done.  This restores the stacks from what is done
; at the entrance to EVAL

define evexit
	subi p,2
	subi sp,4
	retn
	termin

define evex1v
	movei n,1
	evexit
	termin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; QUOTE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;QUOTE returns its argument
;This is a special form
;O1 - form
quote:	docdr o1,o1		;get the argument
	scons o1
	jrst [err1 o1,/QUOTE called with missing or bogus argument: ~S/]
	docar o1,o1		;has only one argument
	evex1v

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  COMMENT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;Comment ignores its argument and returns NIL
;O1 - form
evnil:	setz o1,
	evex1v

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  EVAL-WHEN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;(EVAL-WHEN control-list forms)
;execute forms if control-list contains EVAL
;O1 - form
evwhen:	docdr o1,o1
	docar o3,o1		;o3 - control-list
evwhnl:	scons o3		;end of control-list without EVAL?
	 jrst evnil		;yes, return NIL
	doboth o2,o3		;O2 - first item, O3 - rest of control list
	came o2,[%EVAL]
	jrst evwhnl		;not this time, try again
;it's OK to do the forms
	jrst progn		;now do them as progn.  Not that PROGN
				;starts with CDR, which will bypass the
				;control-list

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; PROGN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1 - form
progn:	docdr o1,o1		;get to the forms
;this is the extry for other forms that want to evaluate as PROGN
dprogn:	jumpe o1,prognn		;any body there?
	push q,o1		;yes, save it
;this is an entry
prognl:	move o1,(q)		;get back the body
	doboth o1,o1		;O1 - next thing to do; O2 - rest
	jumpe o2,prognx		;if this is last, do it specially
	movem o2,(q)		;put back advanced body
	call eval		;eval for side-effect only
	jrst prognl
;here to eval last thing in the body
prognx:	subi q,1
	call eval		;we have two things on P
prognn:	evexit			;pass mv's  ;**evexit**

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; *MACRO-EXPANSION*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1 - form
macxpn:	docdr o1,o1		;get to the forms
	docar o1,o1
	call eval
	evexit			;pass n

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; EVAL-AS-PROGN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1 - form
eprogn:	jumpe o1,ret1v		;any body there?
	push q,o1		;yes, save it
eprogl:	move o1,(q)		;get back the body
	doboth o1,o1		;O1 - next thing to do; O2 - rest
	jumpe o2,eprogx		;if this is last, do it specially
	movem o2,(q)		;put back advanced body
	call eval		;eval for side-effect only
	jrst eprogl
;here to eval last thing in the body
eprogx:	subi q,1
	jrst eval

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; PROG1
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

prog1:	docdr o1,o1
	scons o1
	 jrst [err /PROG1 with no forms/]
prog11:	doboth o1,o1		;O1 - first form; O2 - rest
	push q,nil		;save place for returned value
	push q,o2		;save rest of forms
	call eval		;now get the first value
	movem o1,-1(q)		;this is what we will return
prog1l:	move o1,(q)		;anything left?
	scons o1
	 jrst prog1x		;no
	doboth o1,o1		;O1 - next form; O2 - rest
	movem o2,(q)		;save rest again
	call eval		;for sideeffects
	jrst prog1l
prog1x:	subi q,1		;kill saved forms
	pop q,o1		;value to return
	evex1v

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; PROG2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

prog2:	docdr o1,o1		;get normal body
	scons o1
	 jrst [err /PROG2 with no forms/]
	doboth o1,o1		;O1 - first form; O2 - rest
	scons o2
	 jrst [err /PROG2 with only 1 form/]
	push q,o2		;save rest
	call eval		;do this for sideeffects
	pop q,o1		;this is now the second form and rest
	jrst prog11		;now join PROG1 for rest of form

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; LET*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;REBIND is used for rebinding the ENV variables.  It patches
; in a pointer to SP, for use by TOHEAP.  The problem is that
; when TOHEAP copies a list to the heap, we have to get all
; references to the list as well as the list itself.

define rebind(var,ac)
	atval ac,var
	bindit var,ac
	skipe ac		;if old value is NIL, don't need this
	skipe @[.%HENV%]	;is this list on Q?
	jrst .+10		;no, nothing funny
	move ac,sp		;make up pointer to SP
	maknum ac
	push q,ac
	move ac,q		;and link it into the list
	tlo ac,(object(ty%ccn,0))
	exch ac,@[var]
	push q,ac
	termin

;This one does sequential binding
lets:	docdr o1,o1		;forget the keyword
	scons o1
	 jrst [err /LET* without a list of variables/]
	docar o5,o1		;O5 - list of variables
	docdr o1,o1		;O1 - body
	rebind %%VENV%,o2	;establish new lexical context
	call extspc		;specials to O6, O1 updated
letsl:	scons o5		;any more vars?
	jrst letsb		;no, do body
	doboth o4,o5		;O4 - this variable, O5 - advanced
	scons o4		;init form?
	jrst letss		;no, better be symbol
	doboth o2,o4		;O2 - the variable, O3 - (init)
	jumpe o3,letsok		;NIL is OK
	scons o3
	 jrst [err1 o2,/Bogus init form in LET* for variable ~S/]
letsok:	push q,o1
	push q,o2
	push q,o5
	push q,o6
	docar o1,o3		;get the form to EVAL
	call eval
	move o3,o1		;put result where ALBIND wants it
	pop q,o6
	pop q,o5
	pop q,o2
	pop q,o1
	call albind		;bind var in O2 to value in O3, spc in O6
	jrst letsl		;see if more binding to do
;here for variable with no INIT form
letss:	move o2,o4		;put var where ALBIND wants it
	move o3,nil		;bind to NIL
	call albind		;bind var in O2 to value in O3, spc in O6
	jrst letsl		;see if more binding to do

;here to do the body.
;this is an entry
letsb:	jumpe o1,letsbn		;any body there?
	push q,o1		;yes, save it
letsbl:	move o1,(q)		;get back the body
	doboth o1,o1		;O1 - next thing to do; O2 - rest
	jumpe o2,letsbx		;if this is last, do it specially
	movem o2,(q)		;put back advanced body
	call eval		;eval for side-effect only
	jrst letsbl
;here to eval last thing in the body
letsbx:	call eval
letsbn:	pop p,q			;have to restore Q, since we bind on Q
	jrst unbind		;and restore %ENV% things

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; LET
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;This one does parallel binding
;We first stack the variables and bindings on the MV stack.
; at the end bind them all at once.
;We have to use the MV stack because ALBIND uses both SP and Q
let:	docdr o1,o1		;forget the keyword
	scons o1
	 jrst [err /LET without a list of variables/]
	docar o5,o1		;O5 - list of variables
	docdr o1,o1		;O1 - body
	rebind %%VENV%,o2	;establish new lexical context
	call extspc		;specials to O6, O1 updated
	push p,[0]		;count bindings here
	move n,mvp		;N will point to MV stack
letl:	scons o5		;any more vars?
	jrst letb		;no, do body
	doboth o4,o5		;O4 - this variable, O5 - advanced
	scons o4		;init form?
	jrst letls		;no, better be symbol
	doboth o2,o4		;O2 - the variable, O3 - (init)
	jumpe o3,letok		;NIL is OK
	scons o3
	 jrst [err1 o2,/Bogus init form in LET for variable ~S/]
letok:	push n,o2		;stack variable
	aos (p)			;count binding
	movem n,mvp		;save MV stack over EVAL
	push q,o1
	push q,o5
	push q,o6
	docar o1,o3		;get the form to EVAL
	call eval
	move n,mvp		;get back MV stack
	push n,o1		;stack value
	pop q,o6
	pop q,o5
	pop q,o1
	jrst letl		;see if more binding to do
;here for variable with no INIT form
letls:	push n,o4		;stack variable
	push n,nil		;stack value
	aos (p)			;count bindings
	jrst letl		;see if more binding to do

;here to do the bindings
letb:	sosge (p)		;any more to do?
	jrst letbx		;no
	pop n,o3		;yes, get value
	pop n,o2		;get variable
	call albind
	jrst letb

letbx:	subi p,1		;get rid of count
	movem n,mvp		;restore MVP to original
	jrst letsb		;go do body

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; PROGV
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;PROGV - (PROGV vars values ... forms ...)

progv:	docdr o1,o1		;get rid of PROGV
	rebind %%VENV%,o2	;establish new lexical context
	doboth o1,o1		;O1 - vars; O2 - rest of form
	push q,o2
	call eval		;O1 - evaluated var list
	push q,o1
	move o1,-1(q)		;rest of form
	doboth o1,o1		;O1 - values; O2 - rest of form
	movem o2,-1(q)		;save form for later
	call eval		;O1 - evaluated value list
	pop q,o4		;O4 - evaluated variable list
	pop q,o5		;O5 - body
progvl:	scons o4		;any vars left?
	jrst progvx		;no - do body
	docar o2,o4		;O2 - var
	scons o1		;any values left?
	jrst progvn		;no, make unbound
	docar o3,o1		;O3 - value
	call albins		;bind as special
	docdr o1,o1
	docdr o4,o4
	jrst progvl		;and see if any more

;here if nothing left in value list
progvn:	move o3,[%.UNBOUND]	;make unbound
	call albins		;specially
	docdr o4,o4		;advance only the variable list
	jrst progvl		;and if any more	

progvx:	move o1,o5		;get body
	jrst letsb		;and do it

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; AND
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

andf:	docdr o1,o1		;get to the forms
	scons o1		;any body there?
	jrst andn		;no, return T
	push q,o1		;yes, save it
andl:	move o1,(q)		;get back the body
	doboth o1,o1		;O1 - next thing to do; O2 - rest
	scons o2		;if this is last
	jrst andx		;do it specially
	movem o2,(q)		;put back advanced body
	call eval		;eval for side-effect only
	jumpn o1,andl		;continue as long as non-NIL
;this is an entry
exitq:	subi q,1
	evex1v			;return the NIL, the whole NIL, 
				;and nothing but the NIL
;here to eval last thing in the body
;this is an entry
andx:	subi q,1
	call eval
	evexit			;rtn all vals from last form

andn:	move o1,[%T]		;if null body, return T
	evex1v

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; OR
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

or:	docdr o1,o1		;get to the forms
	scons o1		;any body there?
	jrst orn		;no, return NIL
	push q,o1		;yes, save it
orl:	move o1,(q)		;get back the body
	doboth o1,o1		;O1 - next thing to do; O2 - rest
	scons o2		;if this is last
	jrst andx		;do it specially
	movem o2,(q)		;put back advanced body
	call eval		;eval for side-effect only
	jumpe o1,orl		;continue as long as NIL
	subi q,1
	evex1v			;else return the value

;this is an entry
orn:	move o1,nil		;return NIL
	evex1v


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; COND
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

cond:	pushcdr q,o1		;get to the forms
condl:	move o1,(q)		;get the body back
	scons o1		;anything left?
	jrst condn		;no, return NIL (popping Q)
	doboth o1,o1		;O1 - this clause; O2 - rest of body
	movem o2,(q)
	scons o1		;clause must not be atomic
	jrst [err1 o1,/Clause in COND is an atom: ~S/]
	pushcdr q,o1		;save rest of clause
	docar o1,o1		;get predicate
	call eval
	pop q,o2		;get back body
	jumpe o1,condl		;continue until we find true condition
	scons o2		;if body exists
	jrst exitq		;doesn't, return this value
	movem o2,(q)		;save it for PROGN
	jrst prognl		;and go do body as PROGN

condn:	subi q,1
	move o1,nil
	evex1v

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; IF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

if:	docdr o1,o1
	scons o1
	jrst [err /IF with no predicate/]
	doboth o1,o1		;O1 - pred; O2 - body
	scons o2
	jrst [err /IF with no body/]
	push q,o2		;save rest of form
	call eval
	jumpn o1,ift		;if true, do the next form
;here if condition is false
	pop q,o1		;this is the true clause
	docdr o1,o1		;now have false
	scons o1		;if nothing there
	jrst orn		;return NIL
	docar o1,o1		;else get the form
	call eval		;eval it
	evexit			;and return that (those)

;here if condition is true
ift:	pop q,o1
	docar o1,o1
	call eval
	evexit

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; MACRO-FUNCTION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

macfun:	jumpe o1,retnil		;NIL is never a function
	satom o1
	jrst [err1 o1,/MACRO-FUNCTION argument must be a symbol/]
	skipn o1,at%fun(o1)
	jrst ret1v		;not defined, can't be a macro
	scons o1		;better be a CONS
	jrst retnil
	docar o2,o1		;and begin with MACRO
	came o2,[%MACRO]
	jrst retnil
	docdr o1,o1		;return the LAMBDA
ret1v:	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; SPECIAL-FORM-P
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

spcfrm:	jumpe o1,retnil		;nil is never a special form
	satom o1
	jrst [err1 o1,/Argument to SPECIAL-FORM-P not a symbol: ~S/]
	gettyp o1
	caie w2,ty%cat		;only constant atoms have this field
	jrst retnil
	caml o1,[object ty%cat,<datsec,,endobl>] ;only perm atoms have this
	jrst retnil
	move o1,at%fev(o1)
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CONSTANTP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

constp:	gettyp o1
	xct .+1(w2)

	jrst cnstpa		;atom
	jrst cnstpa
	jrst cnstpc		;cons
	jrst cnstpc
	jrst rett		;string
	jrst rett
	jrst retnil		;I/O channel
	jrst retnil
	jrst retnil		;hash table
	jrst retnil
	jrst retnil		;vector
	jrst rett		;character
	jrst cnstph		;array header
	jrst retnil		;special
	jrst retnil		;integer vector
	jrst rett		;bit vector
	jrst rett		;long float
	jrst rett
	jrst rett		;short float
	jrst rett
	jrst rett
	jrst rett
	jrst rett		;ratios
	jrst rett
	jrst retnil		;special 36
	jrst retnil		;special 5
	jrst rett		;bignum
	jrst rett
	jrst rett		;inum
	jrst rett
	jrst rett
	jrst rett

;here for symbol. NIL, T, property %CONSTANT, keywordp
cnstpa:	jumpe o1,rett
;	came o1,[%NIL]
	camn o1,[%T]
	jrst rett
;look down the property list to see if this is globally special
	move o3,at%pro(o1)	;see if globally special
	jumpe o3,cnspax		;no property list
cnspal:	doboth o2,o3		;o2 - property, o3 - rest of plist
	camn o2,[%CONSTANT]	;constant or
	jrst rett		;yes
	docdr o3,o3		;no, skip this value
	jumpn o3,cnspal
;fall through at end of plist
cnspax:	move o2,at%pkg(o1)	;get package
	came o2,@[.KEYPACKAGE]	;see if keyword
	jrst retnil		;not
	jrst rett		;yes

;here for cons.  (QUOTE ..
cnstpc:	docar o1,o1
	came o1,[%QUOT]
	jrst retnil
	jrst rett

;here for array header. string or bit vector
cnstph:	move o2,ah%dat(o1)	;see what the data is
	xtype o2
	caie w2,ty%bvc		;if a bit vector
	 cain w2,ty%xst		;or a string
	  jrst rett		;then evals to itself
	jrst retnil		;else not constant

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; UNWIND-PROTECT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

unwind:	docdr o1,o1
	scons o1
	jrst [err /UNWIND-PROTECT with no arguments/]
	doboth o1,o1		;O1 - protected form; O2 - rest
	push q,o2
	call cunwnd		;main support routine
	jrst unwndc		;cleanup
	jrst unwndx		;exit
	jrst eval		;do the protected form

unwndc:	move o1,(q)		;get back the body
	scons o1		;anything left?
	iret			;no, so done with cleanups
	doboth o1,o1		;O1 - next thing to do; O2 - rest
	movem o2,(q)		;put back advanced body
	call eval		;eval for side-effect only
	jrst unwndc
unwndx:	subi q,1
	evexit	

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CATCH
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

catch:	docdr o1,o1
	scons o1
	jrst [err /CATCH with no tag specified/]
	doboth o1,o1		;o1 - tag; O2 - forms to do inside
	push q,o2		;save forms
	call eval
	call ccatch		;main support routine
	jrst catchx
;this is an entry
catchb:	move o1,(q)		;get back the body
	scons o1		;anything there?
	jrst retnil		;no - forget it
catchl:	doboth o1,o1		;O1 - next thing to do; O2 - rest
	jumpe o2,eval		;is this last?
	movem o2,(q)		;put back advanced body
	call eval		;eval for side-effect only
	move o1,(q)		;get back the body
	jrst catchl

catchx:	subi q,1
	evexit

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; THROW
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

throw:	docdr o1,o1
	scons o1
	jrst [err /No tag for THROW/]
	doboth o1,o1
	push q,o2		;save form for value
	call eval		;now have the tag
	call cthrow
	pop q,o1		;get back the form
	scons o1		;anything there?
	jrst retnil		;no - use NIL
	docar o1,o1		;yes
	call eval		;eval it
	retn			;pass mv's

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; BLOCK
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;The purpose of BLOCK is to establish a context from which
;you can return via RETURN-FROM.  In fact we simply do a CATCH,
;and RETURN-FROM is a THROW.  The only thing complex is that
;the tags are lexically scoped.  So they must be identified by
;searching %BENV%, instead of going up the stack as in CATCH.
;In fact what we do is CATCH with a unique tag.  Then %BENV%
;is an ALIST that goes from the block name to the corresponding
;unique tag.  Because we end up using CATCH, if the block
;is dead by the time RETURN is done, the tag will no longer be
;on the stack, and the user will get an error.  This is the
;desired effect.

;Now comes the bad part.  What do we use for the unique tag?
;We can't just use a stack pointer, because it may end up being
;in a lexical closure after the stack frame has been deallocated.
;Of course it is an error to RETURN to such a thing, but we have
;to make sure that if a user tries, his intent is clear and he
;gets an error (instead of exiting from a random form, for example).
;What I have decided to do is use a pointer to the entry on
;%BENV% itself.  Then we have to handle the fact that %BENV% starts
;out on the stack but may be copied to the heap.  This involves
;adding pointers to all references, as with %VENV%.

;WARNING: nextbl depends upon the fact that this function does
;a rebind of %%BENV% and then a CATCH.

dblock:	docdr o1,o1
	rebind %%BENV%,o2
	scons o1		;make sure something is there
	jrst [err /BLOCK without block name/]
	doboth o1,o1		;O1 - block name; O2 - body
	satom o1
	jrst [err1 o1,/BLOCK name is not a symbol: ~S/]
;now add blockname to beginning of %BENV%
	skipe @[.%HENV%]	;on heap?
	jrst block1
	push q,o1		;no, use stack - tag
	move o3,q
	tlo o3,(object(ty%ccn,0))
	exch o3,@[.%BENV%]	;now link into the list
	push q,o3
	jrst block2
block1:	docons o3,o1,@[.%BENV%]	;on heap, use normal CONS
	putval %%BENV%,o3
;now do the catch
block2:	move o1,@[.%BENV%]	;use the list itself as the tag
	call ccatch		;establish the CATCH blip
	jrst blockx
;add a pointer to %BENV% to point to the blip if necessary
	skipe @[.%HENV%]	;is this list on Q?
	jrst block3		;no, nothing funny
	xmovei o3,-2(sp)	;make up pointer to tag field in blip
	maknum o3
	push q,o3
	move o3,q		;link it into the list
	tlo o3,(object(ty%ccn,0))
	exch o3,@[.%BENV%]
	push q,o3
;and finally, do the body
block3:	push q,o2		;save body
	jrst catchb
;here is the exit
blockx:	subi q,1		;saved body
	pop p,q			;undo all those binds
	jrst unbind

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; RETURN and RETURN-FROM
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;see note at the end for why we do things a bit obscurely.

return:	docdr o3,o1
	move o2,nil		;use NIL as block name
	jrst retfrn

retfro:	docdr o1,o1
	scons o1
	jrst [err /RETURN-FROM without a block name/]
	doboth o2,o1		;tag to O2, body to O3
;this is an entry.  tag in O2, body in O3
retfrn:	push q,o2		;save the tag for later
	scons o3		;something to return?
	jrst [ move o1,nil ? jrst retfrv] ;no, use NIL
	docar o1,o3		;yes, use it
	call eval		;use any MV's we happen to get
retfrv:;now we have return values in the On's, and N is set.
	exch o1,(q)		;save O1 return value; get tag
	move o6,@[.%BENV%]	;list of tags
retfrl:	jumpe o6,[err1 o6,/Unseen block name in RETURN-FROM: ~S/]
	camn o1,(o6)		;look for the tag
	jrst retfry		;yes, found it
	docdr o6,o6
	jrst retfrl
;here when we have found the tag, O6 is the list itself, which is
;the CATCH tag
retfry:	move o1,o6
	call cthrow
;here when CTHROW calls us back.  O2-O5 and N are still set from
;above.  O1 was pushed onto Q
	pop q,o1		;back back O1
	retn			;passing mv's

;here is a very interesting bug that came up in the first
;version.  We computed the value to return at right after
;the CALL CTHROW, which is in fact what we are supposed to
;do.  The problem is, if that computation happened to do
;a TOHEAP, then suddenly our catch tag was no good.  Thus
;we now compute the return value first.  CTHROW forces
;MV's, so things get very interesting.  A comment in CTHROW
;documents what facts about it this code depends upon.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; TAGBODY
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;This uses %GENV% to save the environment for GO's.  Of course
;the CAR is the label.  The CDR is the tail of the form after
;the label. Note that this is simply a single CONS cell taken
;from the body, so we use the same support code as for %BENV%
;In order to establish a unique tag for the catch, we simply
;put a NIL in.  The top-level list pointing to that is the
;actual tag.

tagbod:	rebind %%GENV%,o2
	move o2,o1		;O2 is a copy of the body
;now build up the tags by looking at the body
	skipe @[.%HENV%]	;on heap?
	jrst tagbd2
;here is the one where we put the thing on the stack
;O1 - preserved; O2 - working copy of the body; O5 - unique tag
	push q,nil		;NIL is as good as anything
	move o3,q
	tlo o3,(object(ty%ccn,0))
	exch o3,@[.%GENV%]	;link it into the list
	push q,o3
;now we have the tag, we need pointer to fix the
;CATCH blip we are about to establish
	xmovei o4,4(sp)		;where tag will be
	maknum o4
	push q,o4
	move o3,q
	tlo o3,(object(ty%ccn,0)) ;link it into the list
	exch o3,@[.%GENV%]
	push q,o3
;now look for all GO tags
tagbd1:	docdr o2,o2
	scons o2		;anything left in body?
	jrst tagbd4		;no
	docar o3,o2		;O3 - item in body
	ssymb o3		;only worry about atoms
	jrst tagbd1
	push q,o2		;add this item to the list
	move o3,q
	tlo o3,(object(ty%ccn,0))
	exch o3,@[.%GENV%]	;now link into the list
	push q,o3
	jrst tagbd1

;now the version that uses the heap
tagbd2:	docons o3,nil,@[.%GENV%] ;make up the dummy for the unique tag
	putval %%GENV%,o3
tagbd3:	docdr o2,o2
	scons o2		;anything left in body?
	jrst tagbd4		;no
	docar o3,o2		;O3 - item in body
	ssymb o3		;only worry about atoms
	jrst tagbd3
	docons o3,o2,@[.%GENV%]	;add this item to the list
	putval %%GENV%,o3
	jrst tagbd3

;now do the catch
tagbd4:	pushcdr q,o1		;save the body
tagbda:	move o1,@[.%GENV%]	;find the unique tag
tagbd5:	skipn (o1)		;it has a NIL in the list
	jrst tagbd6
	docdr o1,o1		;not there, try next
	jrst tagbd5
tagbd6:	call ccatch		;establish the CATCH blip
	jrst tagbdx
;and finally, do the body
tagbdl:	move o1,(q)		;get back the body
	scons o1		;anything there?
	jrst retnil		;no - forget it
	doboth o1,o1		;O1 - next thing to do; O2 - rest
	movem o2,(q)		;put back advanced body
	ssymb o1		;if symbol, it is a label - ignore it
	call eval		;eval for side-effect only
	jrst tagbdl
;here is the exit for a single pass
tagbdx:	jumpe o1,tagbxx		;see if we just fell off the end
	movem o1,(q)		;no, a GO passed us something to do
	jrst tagbda		;so go do it
;this is the real exit
tagbxx:	subi q,1		;saved body
	pop p,q			;undo all those binds
	jrst unbind

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; GO
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

go:	docdr o3,o1
	scons o3
	jrst [err /GO without an argument/]
	docar o1,o3		;O1 - go tag
	move o2,@[.%GENV%]	;get the list of known tags
	call iassq		;anything there?
	jumpe o2,[err1 o1,/GO to a non-existent label: ~S/]
;the catch tag is the next NIL in the ALIST
	move o1,o2
gol:	docdr o1,o1
	scons o1
	jrst [err /Impossible error in GO/]
	skipe (o1)		;is this our NIL?
	jrst gol		;no
;do the throw
	call cthrow		;we have the tag, do the throw
	docdr o1,o4		;this is the code to execute
	ret1			;return that via throw

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; SETQ
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;SETQ - somewhat complicated by all the kinds of bindings
;This is a special form, so it is dispatched to directly from
;EVAL.  It should be impossible for the user to call this
;code directly
;O1 - form
setq:	setz o3,		;in case no forms, return NIL
	pushcdr q,o1		;use CDR form, as car is the SETQ
setql:	move o1,(q)		;get form
	jumpe o1,setqx		;if none, return value from O3
	doboth o1,o1		;O1 - variable, O2 - rest of form
	push q,o1		;save variable
	scons o2
	 jrst [err /SETQ with odd number of args/]
	doboth o1,o2		;O1 - value, O2 - rest of form
	movem o2,-1(q)		;save rest of form for later
	call eval		;now get value into O1
	move o3,o1		;save value where IASSQ won't bother it
	pop q,o1		;variable into O1
	satom o1
	 jrst [err1 o1,/Attempt to SETQ a non-symbol: ~S/]
	jumpe o1,illset
;	came o1,[%NIL]
	camn o1,[%T]
	jrst illset
;note that we do not check the property list for %CONSTANT
	skipn o2,@[.%VENV%]	;if there are locals
	jrst setqs		;no, use special cell
	call iassq		;yes, see if this is one
	jumpe o2,setqs		;no, use special cell
	docdr o5,o4		;see if bound to %INTERNAL-SPECIAL
	camn o5,[%INTSPC]
	jrst setqs		;yes, bind using special cell
	dorpd o4,o3		;put value in CDR of pair
	jrst setql		;and see if more forms to do
;here to bind using special cell
setqs:	setgval o1,o3
	jrst setql		;and see if more forms to do

setqx:	subi q,1		;form is now nil
	subi p,2		;saved SP and Q
	subi sp,4		;eval blip
	move o1,o3		;get value to right place
	ret1

illset:	err1 o1,/Attempt to SETQ a constant: ~S/

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; PSETQ
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;Modification of SETQ to do assignments in parallel

psetq:	docdr o1,o1
	push p,[0]		;count of number of vars
psetql:	scons o1		;anything more?
	jrst psetqb		;no, go bind
	aos (p)			;count vars
	doboth o1,o1		;O1 - variable, O2 - rest of form
	push q,o1		;save variable
	scons o2
	 jrst [err /PSETQ with odd number of args/]
	doboth o1,o2		;O1 - value, O2 - rest of form
	push q,o2		;save rest of form
	call eval		;now get value into O1
	exch o1,(q)		;save value on stack, get rest of form
	jrst psetql
;here to do the bindings
psetqb:	sosge (p)		;any more?
	jrst psetqx		;no, done
	pop q,o3		;value
	pop q,o1		;variable into O1
	satom o1
	 jrst [err1 o1,/Attempt to PSETQ a non-symbol: ~S/]
	jumpe o1,illset
;	came o1,[%NIL]
	camn o1,[%T]
	jrst illset
;note that we do not check the property list for %CONSTANT
	skipn o2,@[.%VENV%]	;if there are locals
	jrst psetqs		;no, use special cell
	call iassq		;yes, see if this is one
	jumpe o2,psetqs		;no, use special cell
	docdr o5,o4		;see if bound to %INTERNAL-SPECIAL
	camn o5,[%INTSPC]
	jrst psetqs		;yes, bind using special cell
	dorpd o4,o3		;put value in CDR of pair
	jrst psetqb		;and see if more forms to do
;here to bind using special cell
psetqs:	setgval o1,o3
	jrst psetql		;and see if more forms to do

psetqx:	subi p,1		;forget the count
	move o1,nil		;return NIL
	evex1v

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; MULTIPLE-VALUE-SETQ
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;(MULTIPLE-VALUE-SETQ (a b c) (values ...))

mvsetq:	docdr o1,o1
	scons o1
	jrst [err /No variables to bind in MULTIPLE-VALUE-SETQ/]
	pushcar q,o1		;save variables
	docdr o1,o1		
	scons o1
	jrst [err /No form to evaluate in MULTIPLE-VALUE-SETQ/]
	docar o1,o1
	call eval
	move w2,mvp		;addr of first value
	dmovem o1,1(w2)		;put everything there
	dmovem o3,3(w2)
	movem o5,5(w2)
	move o6,(q)		;get vars back
	skipn n			;if no values
	move o1,nil		;return NIL
	movem o1,(q)		;save value to return
;here to do the bindings
mvsetl:	scons o6		;more vars?
	jrst mvsetx		;no, done
	docar o1,o6		;var to O1
	docdr o6,o6		;and advance vars
	move o3,nil		;assume NIL value
	aoj w2,
	sosl n			;any more values?
	move o3,(w2)		;yes, use one; value to O3
	satom o1
	 jrst [err1 o1,/Attempt to MULTIPLE-VALUE-SETQ a non-symbol: ~S/]
	jumpe o1,illset
;	came o1,[%NIL]
	camn o1,[%T]
	jrst illset
;note that we do not check the property list for %CONSTANT
	skipn o2,@[.%VENV%]	;if there are locals
	jrst mvsets		;no, use special cell
	call iassq		;yes, see if this is one
	jumpe o2,mvsets		;no, use special cell
	docdr o5,o4		;see if bound to %INTERNAL-SPECIAL
	camn o5,[%INTSPC]
	jrst mvsets		;yes, bind using special cell
	dorpd o4,o3		;put value in CDR of pair
	jrst mvsetl		;and see if more forms to do
;here to bind using special cell
mvsets:	setgval o1,o3
	jrst mvsetl		;and see if more forms to do

mvsetx:	pop q,o1		;value to return
	evex1v

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; BOUNDP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;this is defined as checking only global bindings
boundp:	getgval o2,o1		;didn't, so try global value
	camn o2,[%.UNBOUND]
	jrst retnil
	jrst rett

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; MKUNBOUND
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;this is defined as checking only global bindings
mkunbd:	ssymb o1
	jrst [err1 o1,/MKUNBOUND called on non-symbol: ~S/]
	move o2,[%.UNBOUND]
	movem o2,at%val(o1)
	ret1
	
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; FBOUNDP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;true if there is a global definition, including built-in
fbndp:	jumpe o1,retnil
	satom o1
	jrst [err1 o1,/FBOUNDP called on non-symbol: ~S/]
	skipe at%fun(o1)
	jrst rett
;constant atom's may also be special forms
	gettyp o1
	cain w2,ty%cat
	caml o1,[object ty%cat,<datsec,,endobl>] ;only perm atoms have this
	jrst retnil
	skipn at%fev(o1)
	jrst retnil
	jrst rett

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; FMAKUNBOUND
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;true if there is a global definition, including built-in
fmkubd:	ssymb o1
	jrst [err1 o1,/FMAKUNBOUND called on non-symbol: ~S/]
	setzm at%fun(o1)
;constant atom's may also be special forms
	gettyp o1
	cain w2,ty%cat
	caml o1,[object ty%cat,<datsec,,endobl>] ;only perm atoms have this
	ret1
	setzm at%fev(o1)
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SYMBOL-FUNCTION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

symfun:	ssymb o1
	 jrst [err1 o1,/SYMBOL-FUNCTION called on non-symbol: ~S/]
	move o2,o1
	skipe o1,at%fun(o2)	;if there is a definition, use it
	 jrst ret1v
;constant atom's may also be special forms
	gettyp o2
	cain w2,ty%cat
	caml o2,[object ty%cat,<datsec,,endobl>] ;only perm atoms have this
	jrst [err1 o2,/Undefined function in SYMBOL-FUNCTION: ~S/]
	skipn o1,at%fev(o2)
	jrst [err1 o2,/Undefined function in SYMBOL-FUNCTION: ~S/]
;have a special form - return it, much good may it do him
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;DO
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;This is built into the interpreter because of a problem in bootstrapping.
;DO is defined in terms of DEFMACRO and DO.  DEFMACRO also uses DO.
;There seems no way other other than hardcoding DO.  This is a shallow
;hardcoding.  It makes no attempt to be more efficient.

do:	push q,o1		;save arg over GENSYM
	call gensym		;default form of GENSYM
	push q,nil
	push q,nil
	push q,nil
	push q,o1
;Q is now DECL, INITS, STEPS, TAG
	move o1,-4(q)		;get back arg
	docdr o1,o1		;skip the DO
	doboth o4,o1		;varlist
	doboth o5,o5		;endlist
;O4 - varlist
;O5 - endlist
;O6 - body

;now test for old-format DO
	jumpe o4,do12		;NIL is OK
	sncons o4
	jrst do12		;so is CONS
	jrst do1e		;atom is error
do12:	jumpe o5,do2		;NIL is OK
	sncons o5
	jrst do2		;so is CONS
do1e:	err1 o1,/Ill-formed DO -- possibly illegal old style DO? ~S/

;dig out the declarations.  Note that this does not detect macros
;that expand to declarations.
do2:	scons o6		;make sure this is really a list
	jrst do3		;no, done
	docar o1,o6		;get first form
	scons o1
	jrst do3		;done if it is atom
	docar o2,o1		;see if it is a declare
	came o2,[%DECLARE]
	jrst do3
	docons o1,o1,-3(q)	;add this to DECLS
	movem o1,-3(q)		;and put back on DECLS
	docdr o6,o6		;advance body beyond it
	jrst do2

;parse the varlist to get inits and steps
do3:	scons o4
	jrst do4		;done when no more varlist
	docar o1,o4		;look at first variable
	sncons o1
	jrst do31
;here if the variable is atomic
do30:	ssymb o1		;should be a symbol
	jrst do3e		;not, an error
do301:	docons o1,o1,-2(q)	;add to inits
	movem o1,-2(q)
	jrst do3l		;and loop
;(X)
do31:	doboth o2,o1		;look into it
	sncons o3		;nothing more there
	jrst do32		;there is, analyze it
	move o1,o2
	jrst do30		;just (X), process like X
;(X Y)
do32:	docdr w3,o3
	sncons w3		;nothing more than this
	jrst do33
	jrst do301		;just add the (X Y) to the inits
;(X Y Z) - now have O2=X, O3=(Y Z), w3=(Z)
do33:	sncons 1(w3)		;make sure there is nothing else
do3e:	jrst [err1 o4,/DO varlist is illegal: ~S/]
	docons o1,(o3),nil	;(Y)
	docons o1,o2,o1		;(X Y)
	docons o1,o1,-2(q)	;add to inits
	movem o1,-2(q)
	docons o1,o2,-1(q)	;add X and Z to steps
	docons o1,(w3),o1
	movem o1,-1(q)
do3l:	docdr o4,o4		;advance var list
	jrst do3		;and try again

;now construct the form
; `(block nil
;	(let ,(nreverse inits)
;	     ,@decls
;	     (tagbody ,tag
;		(and ,(car endlist)
;		     (return (progn ,@(cdr endlist))))
;		,@body
;		(psetq ,@(nreverse steps))
;		(go ,tag))))))

do4:	move o1,(q)		;tag
	docons o1,o1,nil
	docons o1,[%GOGO],o1	;(GO ,tag)
	docons o1,o1,nil	;((GO ...))
	move o2,-1(q)		;steps
	move o3,nil		;reverse into O3
	jumpe o2,do41x
do41l:	docons o3,(o2),o3
	docdr o2,o2
	docons o3,(o2),o3
	docdr o2,o2
	jumpn o2,do41l
  ;done with reverse.  now have steps in O3
	docons o3,[%PSETQ],o3	;(PSETQ ..steps..)
	docons o1,o3,o1		;((PSETQ ..) (GO ..))
do41x:	call do41s		;add body onto this
	docons o2,[%PROGN],1(o5) ;(PROGN ,@(CDR ENDLIST))
	docons o2,o2,nil	;((PROGN ...))
	docons o2,[%RETURN],o2	;(RETURN (PROGN ...))
	docons o2,o2,nil	;((RETURN ..))
	docons o2,(o5),o2	;(endcond (RETURN ..))
	docons o2,[%AND],o2	;(AND endcond (RETURN ..))
	docons o1,o2,o1		;((AND ..) body (PSETQ ..) (GO ..))
	docons o1,(q),o1	;( ,tag (AND ...) body (PSETQ ..) (GO ..))
	docons o1,[%TAGBODY],o1	;(TAGBODY ,tag (AND ) body (PSETQ ) (GO ))
	docons o1,o1,nil	;((TAGBODY ...))
	move o6,-3(q)		;decls
	jumpe o6,do43x
do43l:	docons o1,(o6),o1	;add decl to body
	docdr o6,o6
	jumpn o6,do43l
do43x:	docons o6,-3(q)		;(--decls-- (TAGBODY))
	move o6,-2(q)		;inits
	move o2,nil		;reverse into O2
	jumpe o6,do42x	
do42l:	docons o2,(o6),o2	;put on car now
	docdr o6,o6
	jumpn o6,do42l
do42x:	docons o1,o2,o1		;(inits -decls- (TAGBODY ..))
	docons o1,[%LET],o1	;(LET inits -decls- (TAGBODY ..))
	docons o1,o1,nil	;((LET ..))
	docons o1,nil,o1	;(NIL (LET..))
	docons o1,[%BLOCK],o1	;(BLOCK NIL (LET..))
	subi q,5
	ret1

;body in O6, main thing in O1, cons on the members of body
;uses Q
do41s:	scons o6
	iret			;end of O6, nothing to do
	pushcar q,o6
	docdr o6,o6		;do the rest of O6
	call do41s
	pop q,o6		;now do the CAR
	docons o1,o6,o1
	iret
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LEXICAL SUPPORT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;
;;;; MAKLEX - create a lexical closure based on the current values
;;;;    of the magic variables.  If they are in Q, we have to copy
;;;;    into the heap.  Garbages all AC's, returns in O1
;;;;;;;;;;;;;;;;;;;;;;;

;construct (%lexical-closure fn %venv% %fenv% %benv% %genv%)

maklex:	call env2hp
	docons o1,@[.%GENV%],nil
	docons o1,@[.%BENV%],o1
	docons o1,@[.%FENV%],o1
	docons o1,@[.%VENV%],o1
	docons o1,nil,o1		;leave space for the function
	docons o1,[%LEXCLO],o1
	ret1

;routine to make the internal lexical environment be on the heap.
;call this before creating a closure or returning the values of
;the environment variables to anyone else.  Preserves O1 and O2,
;but not much else.
env2hp:	atval o3,%%GENV%
	call toheap
	putval %%GENV%,o3
	atval o3,%%BENV%
	call toheap
	putval %%BENV%,o3
	atval o3,%%FENV%
	call toheap
	putval %%FENV%,o3
	atval o3,%%VENV%
	call toheap
	putval %%VENV%,o3
	move o3,[%T]	;say our environment is now real
	putval %%HENV%,o3
	iret


;subroutine to copy an a-list from Q space into the heap
;note that the list must be copied in order.  Also, any
;associations SP-pointers must be obeyed.
;They indicate places on SP where there are references to
;this list.  They must be changed when it is moved.

toheap:	skipe @[.%HENV%] ;already on heap?
	iret		;yes, no need to copy
	push q,nil	;make pseudo-cons on Q for list header
	move o4,q
	tlo o4,(object(ty%ccn,0));
	push q,nil

;skip if an odd object, i.e. other than atom or cons cell
define sodd(ac)
	tlnn ac,740000
	termin

define snodd(ac)
	tlne ac,740000
	termin

tohepl:	jumpe o3,tohepx	;could also be NIL
	docar o5,o3	;get first member of remainder
	snodd o5	;pointer to saved value on SP?
	jrst toheps	;yes, treat specially
	push free,nil	;new cell in top-level list
	move w2,free	;the new cell will be CAR
	tlo w2,(object(ty%con,0))
	push free,nil
	dorpd o4,w2	;link into the tail
	move o4,w2	;and make this the new tail
	call hpcopy	;copy member in O5
	dorpa o4,o5	;and put the copy there
	caml free,lastl
	 call sgc
	docdr o3,o3	;so much for this one
	jrst tohepl
tohepx:	pop q,o3	;get back head of list
	subi q,1
	iret

;Here with O5 containing an address to modify.
;This code is incredibly dangerous.  There had better not be a GC between
;here and the new "CONS".  Note that we assume that there is something
;left in the list.  REBIND does not create one of these pointers if
;the list is NIL.
toheps:	xmovei w2,1(free)	;this will be the next cell in the new list
	tlo w2,(object(ty%con,0))
	movem w2,(o5)		;put it in SP
	docdr o3,o3		;don't need this one any more
	jrst tohepl

;HPCOPY copies the structure in O5.  Only W2/W3 are free
hpcopy:	hlrz w2,o5		;is this on the stack?
	trz w2,3
ifn qsec-4,<printx /This code depends upon QSEC=4/>
	caie w2,(object(ty%ccn,<qsec,,0>))
	iret			;not on the stack, OK as is
	push q,1(o5)		;save the CDR
	docar o5,o5		;copy the CAR
	call hpcopy
	exch o5,(q)		;now the CDR
	call hpcopy
	docons o5,(q),o5	;and then do a CONS
	subi q,1
	iret
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Random stuff that could just about be done in LISP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; FUNCTION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;if arg is lambda, makes a closure
;if arg is symbol, gets its definition, including %FENV% stuff

funct:	docdr o1,o1
	scons o1
	jrst [err /FUNCTION with no argument/]
	docar o1,o1		;O1 is now the function
	scons o1
	jrst functs		;better be a symbol
;function is a CONS - better be a lambda
	docar o2,o1
	came o2,[%LAMBDA]
	jrst [err1 o1,/Invalid argument to FUNCTION: ~S/]
	skipe @[.%VENV%]	;if all ENV things are NIL, just return ftn
	jrst functc		;no, do a closure
	skipe @[.%FENV%]	;if all ENV things are NIL, just return ftn
	jrst functc		;no, do a closure
	skipe @[.%BENV%]	;if all ENV things are NIL, just return ftn
	jrst functc		;no, do a closure
	skipe @[.%GENV%]	;if all ENV things are NIL, just return ftn
	jrst functc		;no, do a closure
	evex1v			;can just return the function
;function is a lambda, and needs a closure
functc:	push q,o1		;save form for later
	call maklex		;max lexical closure
	pop q,o2		;get back form
	docdr o4,o1		;cdr closure
	dorpa o4,o2		;put the function in as element 2
functx:	evex1v
;function is a symbol
functs:	ssymb o1
	jrst [err1 o1,/Invalid argument to FUNCTION: ~S/]
	move o2,at%fun(o1)
	docar o3,o2
	camn o3,[%SUBR]		;if a subr, just return atom
	 jrst funct3
	move o2,@[.%FENV%]	;see if any lexical defn.
	call iassq
	jumpe o2,funct1		;no, try next thing
;here if there is a lexical definition
	docdr o1,o4		;get the definition
	docar o2,o1		;see what sort of thing it is
	came o2,[%FEXPR]
	camn o2,[%MACRO]
	jrst [err1 o1,/FUNCTION names a MACRO or FEXRP: ~S/]
	jrst functx
;no lexical defn, so if normal one
funct1:	skipn o2,at%fun(o1)
	jrst [err1 o1,/FUNCTION names something that is undefined: ~S/]
	docar o3,o2		;see what it is
	came o3,[%LAMBDA]
	camn o3,[%SUBR]
	jrst funct2
	camn o3,[%LEXCLO]
	jrst funct2
	jrst [err1 o1,/FUNCTION names something other than a normal function: ~S/]
funct2:	move o1,o2		;looks good
funct3:	evex1v

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; DECLARE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;This gets called only if somebody tries to EXECUTE the declare, i.e.
;if it is not in definition form.  We take it to be equivalent to
;PROCLAIM.

;O1 - form

declar:	docdr o1,o1		;O1 - list of declarations
	scons o1
	jrst prognn		;none left
	docar o3,o1		;O3 - particular declaration
	doboth o2,o3		;O2 - declaration type, O3 - list of things
	came o2,[%SPEC]		;only know this one
	jrst declar		;so go for next declaration if any
	push q,o1
	push q,o3
decla1:	move o2,(q)		;get list of things
	jumpe o2,decla2		;stop if none
	doboth o1,o2		;thing in o1, rest o2
	movem o2,(q)
	move o2,[%GLOSPEC]	;globally special
	move o3,[%T]
	call putp
	jrst decla1
;here after processing everything in one decl
decla2:	subi q,1
	pop q,o1
	jrst declar		;see if any more decls

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; DEFUN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1 - remaining body
;On Q:
; -4 name
; -3 varlist
; -2 documentation
; -1 declarations
; -0 TCONC pointer to declarations
defun:	docdr o1,o1
	scons o1
	jrst [err1 o1,/DEFUN with no name/]
	docar o2,o1		;get the name
	ssymb o2
	jrst [err1 o2,/Trying to DEFUN a non-symbol/]
	gettyp o2		;now see if it is a special form
	caie w2,ty%cat		;only constant atoms have this field
	jrst defun0		;can't be
	caml o2,[object ty%cat,<datsec,,endobl>] ;only perm atoms have this
	jrst defun0		;can't be
	skipe at%fev(o2)
	jrst [err1 o2,/Trying to DEFUN a special form/]
defun0:	push q,o2		;name
	docdr o1,o1
	scons o1
	jrst [err1 o1,/DEFUN with no variable list/]
	pushcar q,o1		;var list
	docdr o1,o1
	push q,nil
	move o2,q
	tlo o2,(object(ty%ccn,0)) ;make pointer to this
	push q,nil
	push q,o2		;save pointer
	
defunl:	scons o1		;anything else?
	jrst defunx		;no, do it
	doboth o2,o1		;get the current object
	xtype o2		;this is now the body, see what we have	
;since the only kind of array that would be legal in code is a string,
;we just assume that any TY%XAR that we find is a string.
	caie w2,ty%xst		;possible documentation?
	 cain w2,ty%xar		;[general-array format string]
	  jrst .+2
	jrst defun1		;no
;documentation
	sncons o3		;must have something after it
	skipe -2(q)		;and no documentation yet
	jrst defun1		;if not, not doc
	movem o2,-2(q)		;is doc
	move o1,o3		;so advance
	jrst defunl
;simple declaration, object in O2
defun1:	scons o2		;must be a CONS
	jrst defun2
	docar o3,o2		;and begin with DECLARE
	came o3,[%DECLARE]
	jrst defun2		;not a declare
defund:	docons o4,o2,nil	;make this declare a new tail
	move o3,(q)		;TCONC pointer
	dorpd o3,o4		;put this on the end
	movem o4,(q)		;and make this the new tail
	docdr o1,o1		;advance
	jrst defunl
;maybe something that expands to a declaration?
defun2:	scons o2		;must be a cons
	jrst defun3
	docar o3,o2
	ssymb o3		;and begin with an atom
	jrst defun3
	skipn o4,at%fun(o3)	;which is defined
	jrst defun3
	scons o4
	jrst defun3
	docar o4,o4
	came o4,[%MACRO]	;as a macro
	jrst defun3
	push q,o1		;save body
	move o1,o2		;get thing to expand
	call imexp
	movei n,1
	move o3,o1
	pop q,o1
	jumpe o2,defun3		;it must expand
	scons o3		;look at expansion
	jrst defun3
	docar o3,o3		;it must be a DECLARE
	came o3,[%DECLARE]
	jrst defun3
	docar o2,o1		;get back the original object
	jrst defund		;add it into the declarations
;here if not a declaration
defun3:	
defunx:	docons o1,-4(q),o1	;(name ..body..)
	docons o1,[%BLOCK],o1	;(block name ..body..)
	docons o1,o1,nil	;((block name ..body..))
	move o3,(q)		;TCONC pointer
	dorpd o3,o1		;put this on the end
	move o1,-1(q)		;get header: (..decl.. (block name ..body..))
	docons o1,-3(q),o1	;((..vars..) ..decl.. (block name ..body..))
	docons o1,[%LAMBDA],o1	;(lambda (..vars..) ...
;now do lexical closure if needed
	skipe @[.%VENV%]	;if all ENV things are NIL, just return ftn
	jrst defunc		;no, do a closure
	skipe @[.%FENV%]	;if all ENV things are NIL, just return ftn
	jrst defunc		;no, do a closure
	skipe @[.%BENV%]	;if all ENV things are NIL, just return ftn
	jrst defunc		;no, do a closure
	skipe @[.%GENV%]	;if all ENV things are NIL, just return ftn
	jrst defunc		;no, do a closure
	jrst defnnc		;no closure
;need a closure
defunc:	push q,o1		;save form for later
	call maklex		;max lexical closure
	pop q,o2		;get back form
	docdr o4,o1		;cdr closure
	dorpa o4,o2		;put the function in as element 2
defnnc:	move o2,-4(q)		;get name
	exch o1,o2		;put in definition
	call setdef		;=*= set fadrblocks to new def
;if documentation, do it
	skipn o3,-2(q)		;any doc?
	jrst defndc		;no
	move o2,[%fundoc]	;yes, use %fun-documentation property
	call putp
	move o1,-4(q)
defndc:	subi q,5
	evex1v

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; MACRO
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

macro:	docdr o1,o1
	scons o1
	jrst [err /MACRO with no function name/]
	doboth o1,o1		;O1 - is the name; O2 the body
	scons o2
	jrst [err /MACRO with no argument list/]
	docdr o4,o2		;O4 - a copy of body
macrol:	scons o4		;anything left?
	jrst macrox		;no, done
	doboth o3,o4		;O3 - next item in body; O4 - rest of body
	xtype o3		;is it a string?
;the only kind of array that is legal in code is a string, so assume
;that any TY%XAR is one
	caie w2,ty%xar
	 cain w2,ty%xst
	  jrst macrod		;yes
	scons o3		;or a DECLARE
	jrst macrox		;no, done
	docar o3,o3
	camn o3,[%DECLARE]
	jrst macrol		;yes, a DECLARE, so skip it
	jrst macrox		;no, end of search
;here when we find a doc string.  It is in O3
macrod:	push q,o1		;save name and body for later
	push q,o2
	move o2,[%FUNDOC]
	call putp
	pop q,o2
	pop q,o1
macrox:	docons o2,[%LAMBDA],o2	;(LAMBDA ..body..)
	docons o2,[%MACRO],o2	;(MACRO LAMBDA ..body..)
	movem o2,at%fun(o1)	;define it
	evex1v

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; FLET
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

flet:	docdr o1,o1
	scons o1		;make sure there are some functions
	jrst [err /FLET with no binding list/]
	rebind %%FENV%,o2
	push q,o1
	call env2hp		;MAKLEX will do this, so might as well
	pop q,o1		;do it now.  It will simply things a lot
				;to know we are in the heap
	doboth o4,o1		;O4 - list of bindings; O5 - body
	move o2,@[.%FENV%]	;O2 - new %FENV%
fletl:	scons o4		;any bindings left?
	jrst fletx		;no
	push q,o2
	push q,o4
	push q,o5
	call maklex		;O1 - lexical closure
	pop q,o5
	pop q,o4
	pop q,o2
;O1 - closure, O2 - new %FENV%, O4 - bindings left, O5 - body
	doboth o3,o4		;O3 - one binding; O4 - rest of bindings
	docons o6,[%LAMBDA],1(o3)  ;(lambda ...)
	docdr w2,o1
	dorpa w2,o6		;(closure (lambda...
	docons o3,(o3),o1	;(name (closure (lambda ...
	docons o2,o3,o2		;add to %FENV%
	jrst fletl		;any more bindings to do?

;this is an entry
fletx:	putval %%FENV%,o2	;establish the new value
	move o1,o5		;get body where PROGN wants it
	jrst letsb		;eval as progn

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; LABELS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

labels:	docdr o1,o1
	scons o1		;make sure there are some functions
	jrst [err /LABELS with no binding list/]
	rebind %%FENV%,o2
	push q,o1
	call env2hp		;MAKLEX will do this, so might as well
	pop q,o1		;do it now.  It will simply things a lot
				;to know we are in the heap
	doboth o4,o1		;O4 - list of bindings; O5 - body
;LABELS is complex because the closures must be done as of the end
; of the following loop, i.e. the functions must be able to see their
; own and the other definitions.  We add a dummy element onto the
; beginning of FENV, so that the closures will all have that CONS cell
; for their FENV components.  Then at the end we patch up FENV.
; each of them so that the FENV slot of their closures points to
	docons o2,nil,@[.%FENV%] ;dummy element on beginning
	exch o2,@[.%FENV%]	;O2 - new %FENV%
lablsl:	scons o4		;any bindings left?
	jrst lablsx		;no, fix up FENV
	push q,o2
	push q,o4
	push q,o5
	call maklex		;O1 - lexical closure
	pop q,o5
	pop q,o4
	pop q,o2
;O1 - closure, O2 - new %FENV%, O4 - bindings left, O5 - body
	doboth o3,o4		;O3 - one binding; O4 - rest of bindings
	docons o6,[%LAMBDA],1(o3)  ;(lambda ...)
	docdr w2,o1
	dorpa w2,o6		;(closure (lambda...
	docons o3,(o3),o1	;(name (closure (lambda ...
	docons o2,o3,o2		;add to %FENV%
	jrst lablsl

lablsx:	move o3,@[.%FENV%]	;get dummy cell at start of FENV
	docar o4,o2		;smash it to be = to new list
	dorpa o3,o4		;CAR
	docdr o4,o2		;CDR
	dorpd o3,o4	
	move o1,o5		;get body where PROGN wants it
	jrst letsb		;eval as progn

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; MACROLET
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

maclet:	docdr o1,o1
	scons o1		;make sure there are some functions
	jrst [err /MACROLET with no binding list/]
	rebind %%FENV%,o2
	push q,o1
	call env2hp		;MAKLEX will do this, so might as well
	pop q,o1		;do it now.  It will simply things a lot
				;to know we are in the heap
	doboth o4,o1		;O4 - list of bindings; O5 - body
	move o2,@[.%FENV%]	;O2 - new %FENV%
macltl:	scons o4		;any bindings left?
	jrst fletx		;no, fix up FENV
; O2 - new %FENV%, O4 - bindings left, O5 - body	
	push q,o2
	push q,o4
	push q,o5
	call maklex		;O1 - lexical closure
	push q,o1
;now get the macro definition
	move o2,-2(q)		;O2 - bindings left
	doboth o1,o2		;O1 - this one; O2 - rest
	movem o2,-2(q)		;update bindings left
	push q,o1		;and save this one
	docons o1,[%DEFMACRO],o1 ;make a defmacro form
	call imexp
	docar o3,o1		;see if this is a macroexpansion
	came o3,[%MACXPN]
	jrst macltt		;no
	docdr o1,o1		;yes, get the expansion
	docar o1,o1
macltt:	pop q,o3		;O3 - this binding
	pop q,o4		;O4 - lexical closure
	docdr o1,o1
	docdr o1,o1
	docons o1,[%LAMBDA],o1	;(lambda (vars ...
	docdr w2,o4
	dorpa w2,o1		;(closure (lambda...
	docons o1,[%MACRO],o4	;(macro closure (lambda ...
	docons o1,(o3),o1	;(name macro closure ...
	pop q,o5
	pop q,o4
	pop q,o2
	docons o2,o1,o2		;add to %FENV%
	jrst macltl

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; COMPILER-LET
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;This is a slight modification of LET, that binds all the variables special

comlet:	docdr o1,o1		;forget the keyword
	scons o1
	 jrst [err /COMPILER-LET without a list of variables/]
	docar o5,o1		;O5 - list of variables
	docdr o1,o1		;O1 - body
	rebind %%VENV%,o2	;establish new lexical context
	call extspc		;specials to O6, O1 updated
	push p,[0]		;count bindings here
	move n,mvp		;get mv stack pointer into N
cletl:	scons o5		;any more vars?
	jrst cletb		;no, do body
	doboth o4,o5		;O4 - this variable, O5 - advanced
	scons o4		;init form?
	jrst cletls		;no, better be symbol
	doboth o2,o4		;O2 - the variable, O3 - (init)
	jumpe o3,cletok		;NIL is OK
	scons o3
	 jrst [err1 o2,/Bogus init form in COMPILER-LET for variable ~S/]
cletok:	push n,o2		;stack variable
	aos (p)			;count binding
	push q,o1
	push q,o5
	push q,o6
	docar o1,o3		;get the form to EVAL
	movem n,mvp
	call eval
	move n,mvp
	push n,o1		;stack value
	pop q,o6
	pop q,o5
	pop q,o1
	jrst cletl		;see if more binding to do
;here for variable with no INIT form
cletls:	push n,o4		;stack variable
	push n,nil		;stack value
	aos (p)			;count bindings
	jrst cletl		;see if more binding to do

;here to do the bindings
cletb:	sosge (p)		;any more to do?
	jrst cletbx		;no
	pop n,o3		;yes, get value
	pop n,o2		;get variable
	call albins		;bind specially
	jrst cletb

cletbx:	subi p,1		;get rid of count
	movem n,mvp		;update stack pointer
	jrst letsb		;go do body
	
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Support for multiple values
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;Multiple values are returned in AC's O1 to O5, and in MVSTK.  MVSTK
;is really a stack, but normally we do not move the stack pointer.
;Arguments 6 and up always go at (MVP)+arg number.  In a few cases where
;we need to save values, we put arguments 1 to 5 in (MVP)+arg number,
;and then advance MVP to beyond the used values.  N is loaded with
;the number of values.

;All routines are responsible for setting N to the number of values
; they return.
; Previously there was a more complex values protocol which required
; a marker in the code following any call that could accept mv's.
; This is no longer necessary, but some of the code structure still
; reflects the necessity.  We can now jrst-hack an mv call.

	.scalar mvp	;Initialized at restr1, remembers MV stack

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; VALUES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;VALUES
;for 0 to 5, the values are in the right place
values:	ret0			;entry vector
	ret1			;make sure length of ret(n) macro
	ret2			; and EV calc in fadrblk are the same
	ret3
	ret4
	ret5
;here if args on the stack
	movei w2,-5(n)		;count down number of args
	move w3,mvp		;address of last arg
	add w3,n
valuel:	pop q,(w3)
	soj w3,
	sojg w2,valuel
	retn

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; VALUES-LIST
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

vallst:	call lst2mv		;create multiple values
	retn			;and return them

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; MULTIPLE-VALUE-LIST
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

mvlist:	docdr o1,o1
	docar o1,o1		;get the form to eval
	call eval
	call mv2lst		;turn them into a list
evex:	evex1v			;and return it

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; MULTIPLE-VALUE-CALL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

mvcall:	docdr o1,o1
	scons o1
	jrst [err /No function specified for MULTIPLE-VALUE-CALL/]
;we now make up the args for FUNCLX:
; on P: SP, Q, N
; on Q: function, then args
	xmovei w2,prognn	;evexit without setting n
	push p,w2
	push p,sp
	push p,q
	push p,[0]		;will count here
	doboth o1,o1		;O1 - function; O2 - arg list
	push q,o2		;save arg list
	call eval
	exch o1,(q)		;save function defn, get back args
;loop over the arg forms
mvcll:	scons o1		;anything left?
	jrst mvclx		;no, do the call
	doboth o1,o1
	push q,o2		;save rest of arg list
	call eval
	addm n,(p)		;keep count
	move w4,q		;save original Q for the following code
	subi q,1(n)		;but increment it to cover these args
	exch o1,(w4)		;it's cheaper just to save these all
	dmovem o2,1(w4)		;than to figure which we need
	dmovem o4,3(w4)
	caig n,5		;if no more than 5 args, that's all
	jrst mvcll
;there are more than 5 MV's.  Get them from MVSTACK
	movei w2,-5(n)		;number of extras
	move w3,mvp
	addi w3,6		;where they are now
	addi w4,5		;where they are going
	xblt w2,
	jrst mvcll

;here at the end to call the function
mvclx:	move w2,-1(p)	;get back the original Q
	move o1,1(w2)	;get the function definition
	sncons o1	;if cons, it should be ftn object already
	jrst mvclf
	ssymb o1	;make sure the function is legal
	 jrst [err1 o1,/Function name not a symbol: ~S/]
	skipn o2,at%fun(o1)
	 jrst udf1	;make sure it has a definition
	scons o2	;and make sure it is a cons
	 jrst udf1
	move o1,o2	;yes, we now have a definition in o1
mvclf:	move w2,-1(p)	;get back the original Q
	movem o1,1(w2)	;save the function definition
	push sp,nil	;create EVAL blip
	push sp,[%FUNCALL]
	push sp,[%savep]	;and saved p
	push sp,[<inum 0>-1]
	addm p,(sp)
	jrst iapply	;now go do our thing


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; MULTIPLE-VALUE-PROG1
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

mvprg1:	docdr o1,o1
	scons o1
	jrst [err /No forms for MULTIPLE-VALUE-PROG1/]
	doboth o1,o1		;O1: first form
	push q,o2		;save rest of the forms
	call eval		;do the first form
	call mv2stk		;put on MV stack
mvpr1l:	move o1,(q)		;get rest of forms
	scons o1		;any more?
	jrst mvpr1x		;no, done
	doboth o1,o1		;yes, get next
	movem o2,(q)
	call eval		;eval it
	jrst mvpr1l
mvpr1x:	subi q,1		;kill the saved form
	call stk2mv		;get back the MV's
	evexit

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; MULTIPLE-VALUE-BIND
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;(MULTIPLE-VALUE-BIND vars values-form ... forms ...)

mvbind:	docdr o1,o1		;get rid of PROGV
	rebind %%VENV%,o2	;establish new lexical context
	doboth o1,o1		;O1 - vars; O2 - rest of form
	push q,o2
	push q,o1
	move o1,-1(q)		;rest of form
	doboth o1,o1		;O1 - values; O2 - rest of form
	movem o2,-1(q)		;save form for later
	call eval		;O1(- etaluated value list
	push p,mvp		;save value so we can undo stack
	push p,mvp		;save for bind loop
	push p,n		;loc and count of values
	call mv2stk		;values0are now on the stack
	pop q,o5		;O5 - var list
	pop q,o1		;O1 - body
	call extspc		;find specials, to O6, update body in O1
mvbndl:	scons o5		;any vars left?
	jrst mvbndx		;no - do body
	docar o2,o5		;O2 - var
	sosge (p)		;any!values left?
	jrst mvbndn		;no, use NIL
	aos -1(p)		;yes, use next from MV stack
	move o3,@-1(p)
	call albind		;do the bind
	docdr o5,o5		;see if any more
	jrst mvbndl

;here to bind to NIL
mvbndn:	move o3,nil
	call albind		;do the bind
	docdr o5,o5		;see if any more
	jrst mvbndl

;here to do the body
mvbndx:	subi p,2		;no longer need count
	pop p,mvp		;remove values from MV stack
	jrst letsb		;do the body

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; multiple value routines called from compiled code
;;;; some of the utility routines following are also called
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; adjust-values -- used only for more than 5 values
;; direct code is used for 0-5.
;;; Receive desired number of vals in w2; actual # in N
adjval:	camg w2,n
	 jrst advret
	cail n,5
	 jrst advstk
	dmovem nil,o1(n)
	caige n,3
	 dmovem nil,o3(n)
	caige n,1
	 movem nil,o5
	movei n,5
advstk:	move w3,mvp
	add w3,n
	sub n,w2
	 push w3,nil
	 aojl n,.-1
advret:	move n,w2
	retn

;; values-call  -- we've done a bunch of push-values
vcall:	push p,sp	; this code from m-v-call above
	push p,q
	push p,nil		;not used, place holder
	push q,o1
	move w3,mvp		;mv stack pointer moves down in chunks
	setz w4,		;sum of mv counts
	call vcallx
	movem q,(p)
	sos q,w4
	subm q,(p)
	jrst mvclx

vcallx:	hrrz w2,(w3)		;count for this chunk
	subi w3,1(w2)		;move to next
	add w4,w2		;accumulate total
	sojle n,vcally		;hit bottom
	push p,w4
	call vcallx		;recursive
	pop p,w2
	aos w3			;skip the count word
	xblt w2,		;put on arg stack
	iret

vcally:	movem w3,mvp		;we're taking all the above off
	move n,w4		;total count
	addi w3,1		;fencepost
	move w4,q
	addi w4,1
	xblt w2,
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; MV2LST - turn multiple values into a list.  This is
;;;;   not called directly by the user, but is a useful utility.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;mv2lst - return multiple values as a list
mv2lst:	setz o6,		;return in O6
	jumpe n,mv2lax		;if no values, don't cons anything
	caig n,5
	jrst mv2lac		;ac's only
	move w3,mvp		;address of last value
	add w3,n
mv2lsl:	docons o6,(w3),o6
	soj n,			;count down number left
	cail n,6
	soja w3,mv2lsl
mv2lac:	xmovei w3,@[gindex n,<1,,o1-1>] ;addr of last value
mv2lal:	docons o6,(w3),o6
	soj w3,
	sojg n,mv2lal
mv2lax:	move o1,o6		;return list in O1
	ret1			;often useful for n to be right

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; LST2MV - turn a list into multiple values.  This is strictly
;;;;   an internal utility
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;lst2mv - return a list as multiple values
lst2mv:	setz n,0
	scons o1
	retn			;0
	doboth o1,o1		;1
	aoj n,
	scons o2
	retn
	doboth o2,o2		;2
	aoj n,
	scons o3
	retn
	doboth o3,o3		;3
	aoj n,
	scons o4
	retn
	doboth o4,o4		;4
	aoj n,
	scons o5
	retn
	doboth o5,o5		;5
	aoj n,
	scons o6
	retn
;more than 5 args, put on MVP
	move w2,mvp
	addi w2,5		;first excess arg goes here
lst2ml:	pushcar w2,o6
	docdr o6,o6
	aoj n,
	scons o6
	retn
	jrst lst2ml

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; MV2STK - move MV's to the MV stack.  This is
;;;;   not called directly by the user, but is a useful utility.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;mv2stk - put MV's on the MV stack
;note that all args above 5 are already there
mv2stk:	move w4,mvp	;base of stack
	dmovem o1,1(w4)
	dmovem o3,3(w4)
	movem o5,5(w4)
	add w4,n	;compute new base of stack
	maknum n
	push w4,n
	movem w4,mvp	;new base of stack
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; STK2MV - move MV's from stack to AC's.  This routine is
;;;;   not called directly by the user, but is a useful utility.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;stk2mv - get MV's from stack
;note that all args above 5 are already there
stk2mv:	move w4,mvp	;base of stack
	pop w4,n	;see how many we have
	posnum n	;get bare number
	sub w4,n	;now have new base of stack
	skipe o1,n	;if N is zero, we want to return NIL
	dmove o1,1(w4)
	dmove o3,3(w4)
	move o5,5(w4)
	movem w4,mvp	;new base of stack
	retn
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Stack code
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  These are the UCI Lisp stack mungers, for wizards only
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

adjust==0
;The second argument to GETSTK indicates what to do when the arg
;is out of range.  There are two choices:
;  ADJUST - adjust to be in range
;  address - go there

define getstk(ac,stkerr)	;convert AC from INUM to stack addr
	posnum ac		;convert to bare number
	lsh ac,1		;to offset
	add ac,[basesp-1]	;to address
ife stkerr,[
	camge ac,[basesp-1]	;if impossible
	move ac,[basesp-1]
	camle ac,sp
	move ac,sp
] ;ife stkerr
ifn stkerr,[
	caml ac,[basesp+1]	;if impossible
	camle ac,sp
	jrst stkerr		;then go here
] ;ifn stkerr
	termin

;spdlpt - return top of stack as INUM
spdlpt:	move w2,sp		;top of stack
	sub w2,[basesp-1]	;convert to offset from start
	lsh w2,-1		;divide by two - two words per "cell"
	maknum w2
	move o1,w2
	ret1

;stkptr(i) - return pseudo-pointer to stack
stkptr:	getstk o1,retnil	;convert to address
	subi o1,1		;pointer to CAR
	tlo o1,(object ty%ccn,0) ;call it constant so not GC'ed
	ret1

;spdlft(i) - return ith "CAR" from stack
spdlft:	move w2,o1
	getstk w2,retnil	;convert arg to stack addr
	move o1,-1(w2)		;CAR of stack pair
	ret1

;spdlrt(i) - return ith "CDR" from stack
spdlrt:	move w2,o1
	getstk w2,retnil	;convert arg to stack addr
	move o1,(w2)		;CDR of stack pair
	ret1

;nextev(i) - return INUM for next eval blip (entry with NIL CAR)
nextev:	move w2,o1
	getstk w2,retnil	;convert arg to stack addr
nxtev1:	camge w2,[basesp+1]	;below base?
	jrst retnil		;yes - failed
	skipn -1(w2)		;is it eval blip?
	jrst nxtev2		;yes - done
	subi w2,2		;no - try next
	jrst nxtev1
nxtev2:	sub w2,[basesp-1]	;convert to offset from start
	lsh w2,-1		;divide by two - two words per "cell"
	maknum w2
	move o1,w2
	ret1

;internal form of NEXTEV - returns stack addr in W2, addr of CDR (top word)
inextv:	move w2,o1
	getstk w2,retnil	;convert arg to stack addr
inxtv1:	camge w2,[basesp+1]	;below base?
	jrst retnil		;yes - failed
	skipn -1(w2)		;is it eval blip?
	iret			;yes - done
	subi w2,2		;no - try next
	jrst inxtv1

;go to specified context and return with given value (value in O2)
outval:	move o6,o2		;save value to return
	call inextv		;adjust to eval blip, new SP in W2
	jumpe o1,retnil		;if fails, return nil
	push q,o6
	addi w2,2		;unbind all up to saved P
	call cunbn1		;unbind to W2, doing unwindprotect
	pop sp,w2		;W2 is now saved P (with TY%ADR set)
	tlz w2,770000		;clear ty%ADR
	pop q,o1		;return value
	move p,w2
	pop p,q			;restore the rest from saved info
	pop p,sp
	ret1			;and do so

;go to specified context and try given form (form in O2)
sprevl:	call inextv		;adjust to eval blip, new SP in W2
	jumpe o1,cpopj		;if fails, return nil
	movem o2,(w2)		;save form in SPDL place
	jrst spred1		;and let spredo finish

;go to specified context and try again
spredo:	call inextv		;adjust to eval blip, new SP in W2
	jumpe o1,cpopj		;if fails, return nil
spred1:	addi w2,2		;unbind all up to saved P
	call cunbn1		;unbind to W2, closing files we pass
	pop sp,w2		;W2 is now saved P (with TY%ADR set)
	tlz w2,770000		;clear ty%ADR
	pop sp,o1		;dummy
	pop sp,o1		;expression being eval'ed
	move p,w2
	pop p,q			;restore the rest from saved info
	pop p,sp
	jrst eval		;now go try again

;speval(i,form) - eval form in context
speval:	push p,sp		;save current sp for unbind
	push q,o2		;save args
	move w2,o1		;w2 - his stack index
	getstk w2,adjust	;convert to actual SP index
	move w3,sp		;save current sp as stopping point
	push p,w2		;save this stuff for restoration
;loop over sp, restoring bindings
upst1:	caml w2,w3		;still in the past?
	jrst upst2		;no - done
	pop w3,o3		;value
	pop w3,o4		;var
	jumpe o4,upst1		;is eval blip
	skpnin o4		;or DECLFU thing
	 jrst upst1
	push sp,o4		;restore binding
	push sp,at%val(o4)	;  (save current)
	setgval o4,o3		;  (restore old)
	jrst upst1
upst2:	pop q,o1
	call eval
	call mv2stk
	pop p,w2
	pop p,w3
;loop over sp, unrestoring (?) bindings
;loop over sp, restoring bindings
upst3:	caml w3,sp		;still in the past?
	jrst upst6		;no - done
	pop sp,o5		;what should be current value
	pop sp,o4		;variable
	getgval o3,o4		;o3 - newly set value in historical enviorn
	setgval o4,o5		;go to current context
upst4:	caml w2,w3		;still historical stack to look at?
	jrst upst3		;no, just do upper half
	came o4,1(w2)		;same variable in historical stack?
	jrst upst5
	movem o3,2(w2)		;yes, so set new historical value
	addi w2,2
	jrst upst3
upst5:	addi w2,2		;wrong variable, try again
	jrst upst4

upst6:	call stk2mv
	retn

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; NEXTBL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;NEXTBL is the primary way that the debugger looks up the stack.
;It looks at both SP and P in parallel, so that it can find both
;interpreted and compiled calls.
;  args:  i, p
;  returns:  i, p, form
;i is the SP index, it its usual 0-based form
;p is P, as an inum, or NIL (see below)
;form is one of
;  eval blip: a CONS beginning with NIL
;  block:  a CONS beginning with the block name
;  compiled call: the function being called, an atom
;p is NIL for eval blips or blocks.  It is pointing to the PUSHJ for compiled
;i is the SP index for eval blips and blocks.  It is the previous value for
;	compiled calls.
;To get the next object, simply call NEXTBL again with the first two things
;it returned the last time.

;NB: currently blocks are not implemented

;the following is to allow getstk to expand in pass 1

;;;here if nothing to return
nxtblf:	setzb o1,o2
	setz o3,
	ret3

;nextbl(i,p)
nextbl:	move w2,o1
	getstk w2,nxtblf	;convert arg to stack addr
;First validate SP - W2
nxtbl1:	camge w2,[basesp+1]	;below base?
	jrst nxtblf		;yes - failed
	skipn -1(w2)		;should be an eval blip
	jrst nxtbl2		;yes
	subi w2,2		;no, back up
	jrst nxtbl1
;Now set up P - O2.  If user passed one, decrement it first
nxtbl2:	sosg o2			;already have a P value?
	move o2,2(w2)		;no, get it from blip
	move w3,w2		;search for next blip in w3
;Find next blip - W3.  May be basesp-1 if no more
nxtbl3:	subi w3,2		;no, back up
	camge w3,[basesp+1]	;below base?
	jrst nxtbl4		;yes - basesp-1
	skipe -1(w3)		;should be an eval blip
	jrst nxtbl3		;no, back up
;now set up limit for P search: O1
	skipa o1,2(w3)		;get p from blip
nxtbl4:	 move o1,[inum basep]	;limit if no more blips
;;;; Now see if any compiled calls before the next blip
nxtbl5:	camg o2,o1		;still in bounds?
	jrst nxtb10		;no, no compiled calls here
	move w4,(o2)		;get stack contents
	caml w4,[codsec,,0]	;is it reasonable for code?
	 camle w4,[37,,0]
nxtbl6:	  soja o2,nxtbl5	;no, try next stack loc
	move o3,-1(w4)		;now get the instruction there
	 erjmp nxtbl6		;if error, forget this
	hlrz o4,o3		;get opcode
	caie o4,(pushj p,@0)	;is it right for a compiled call?
	 soja o2,nxtbl5		;no, try again
	hrr w4,o3		;W4 is now addr of function block (we hope)
;here we skip to the end of the function address block, which is the
;atom being called.  Right after it, we will have either NIL or an inum
;(point to the next address block in a chain)
nxtbl7:	move o3,(w4)		;this should be a ty%iadr or the actual atom
	 erjmp nxtbl6		;protect against illegal addr
	snsymb o3		;make sure it is an atom
	 aoja w4,nxtbl7		;yes, so look for next
	skipe o3		;should be nil
	 skpnin o3		;or an inum
	  jrst .+2					
	   soja o2,nxtbl5	;no, try again
	move o3,-1(w4)		;get back the last atom.  This is return value
				;o2 is already set to the P value
nxtblx:	sub w2,[basesp-1]	;convert to offset from start
	lsh w2,-1		;divide by two - two words per "cell"
	maknum w2
	move o1,w2	
	ret3			;say we have 3 values

;;;here if no compiled calls.  Just return the blip
nxtb10:	camn w3,[basesp-1]	;was it a failure?
	 jrst nxtblf		;yes, return that
	xmovei o3,-1(w3)	;return a pseudo-cons for the blip
	tlo o3,(object(ty%ccn,0))
	move o2,nil		;no P value
	move w2,w3		;and SP value
	jrst nxtblx		;converted to index
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Support for compiled code
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;; Errors.  These are called by PUSHJ.

tfaerr:	err /Too few arguments supplied to function/

tmaerr:	err /Too many arguments supplied to function/

calund:	move w4,(p)		;get the rtn addr
	move w2,-1(w4)		;now get the instruction there
	 erjmp calunu		;if error, can't do much for him
	hlrz w3,w2		;get opcode
	caie w3,(pushj p,@0)	;is it right for a compiled call?
	 jrst calunu		;no, give up
	hrr w4,w2		;W4 is now addr of function block (we hope)
;here we skip to the end of the function address block, which is the
;atom being called.  Right after it, we will have either NIL or an inum
;(point to the next address block in a chain)
calunl:	move w3,(w4)		;this should be a ty%iadr or the actual atom
	 erjmp calunu		;protect against illegal addr
	snsymb w3		;make sure it is an atom
	 aoja w4,calunl		;yes, so look for next
	skipe w3		;should be nil
	 skpnin w3		;or an inum
	  jrst .+2					
	   jrst calunu
	push q,o1
	push q,o2
	move o1,-1(w4)		;get back the last atom.  This is it
	docons o1,o1,nil	;arg must be a list
	move o2,[makstr /Undefined function: ~S/]
	jrst calune		;join common code

;here if can't figure out the function
calunu:	push q,o1
	push q,o2
	setz o1,		;no arg
	move o2,[makstr /Undefined function called from compiled code/]
calune:	push q,o3		;save everything possible
	push q,o4
	push q,o5
	push p,n
	move o3,o2		;string goes here
	move o5,o1		;and args here
	move o1,nil		;don't know caller
	move o2,[$UNDEF]
	move o4,[makstr /Please define it before continuing/]
	fncall [%SIGCER],5
	pop p,n
	pop q,o5
	pop q,o4
	pop q,o3
	pop q,o2
	pop q,o1
	pop p,w2		;get return address
	jrst -1(w2)		;and go do call again

;;routines used by compiled code to cons up the Rest args. Entry points:
;;RestN used if more than 5 args are reqd or optional.
	; set w2 to the number of rqd+opt args you have (ie, the number
	; of args NOT to cons
restn:	move o6,nil
restn1:	docons o6,(q),o6
	sos n
	came n,w2
	 soja q,restn1
	movem o6,(q)
	iret

;;RestX is used if there are less than (or =) 5 rqd+opt args but more
 ; than 5 supplied args.  set w2 as in RestN
restx:	move o6,nil
	exch n,w2
	subi w2,5
restx1:	docons o6,(q),o6
	subi q,1
	sojg w2,restx1
	movei w2,5
	sub w2,n
	jumpn w2,rest5+1
	push q,o6
	iret
;;RestI, i=1--5, is for cases where 1 to 5 args were supplied.
 ; set w2 to the number of args TO cons (opposite of above).
rest5:	 move o6,nil
	docons o5,o5,o6
	sosg w2
	 iret
	skipa
rest4:	 move o5,nil
	docons o4,o4,o5
	sosg w2
	 iret
	skipa
rest3:	 move o4,nil
	docons o3,o3,o4
	sosg w2
	 iret
	skipa
rest2:	 move o3,nil
	docons o2,o2,o3
	sosg w2
	 iret
	skipa
rest1:	 move o2,nil
	docons o1,o1,o2
	iret

;; bind the vars in o1 to the new vals in o2
bindv:	move o4,o2	;need two regs for each
	move o2,o1
bindvl:	jumpe o2,cpopj	;end of list
	doboth o1,o2	;o1 - var, o2 - rest of varlist
	doboth o3,o4	;o3 - val, o4 - rest of vallist
	fasgbind o1,o3
	jrst bindvl	;and try for more

;lb1-lb5 are for lambda binding.  For example:
;  jsp w2,lb3
;  setam o1,@[object ty%atm,foo]
;  setam o2,@[object ty%atm,bar]
;  setam o4,@[object ty%atm,baz]
;LB3 is supposed to save the old bindings of the atoms on
;SP, and then return.  The SETAM's (which are equivalent to MOVEM's)
;will then put in the new bindings.  This code depends critically
;upon having SETAM's instead of MOVEM's.  SETAM has the highorder
;bit on, which means that when you use it in an index register you
;get local addressing.

lb5:	move w3,4(w2)		;w3 - setam o1,address of atom pointer
	push sp,(w3)		;push the atom pointer itself
	push sp,@(sp)		;and its value
lb4:	move w3,3(w2)		;w3 - setam o1,address of atom pointer
	push sp,(w3)		;push the atom pointer itself
	push sp,@(sp)		;and its value
lb3:	move w3,2(w2)		;w3 - setam o1,address of atom pointer
	push sp,(w3)		;push the atom pointer itself
	push sp,@(sp)		;and its value
lb2:	move w3,1(w2)		;w3 - setam o1,address of atom pointer
	push sp,(w3)		;push the atom pointer itself
	push sp,@(sp)		;and its value
lb1:	move w3,0(w2)		;w3 - setam o1,address of atom pointer
	push sp,(w3)		;push the atom pointer itself
	push sp,@(sp)		;and its value
	jrst (w2)

;now ub1 to ub5 unbind 1 to 5 things from the SP stack
ub5:	pop sp,@-1(sp)
	subi sp,1
ub4:	pop sp,@-1(sp)
	subi sp,1
ub3:	pop sp,@-1(sp)
	subi sp,1
ub2:	pop sp,@-1(sp)
	subi sp,1
ub1:	pop sp,@-1(sp)
	subi sp,1
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; functions to support LAP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;TY%INT - this entire section uses GETNUM and MAKNUM to handle
; numbers that can be addresses.  This works because the we don't
; allow addresses above 29 bits.  In principle we should use more
; complete code that allows full-size numbers.


;o1 - address
;o2 - opcode
;o3 - reg
;o4 - rest of instruction
;  build instruction (in w2) and put in address
;; exception to above comment.  the effective addr parameter to dinst
;; can be a bignum (for a full word's worth of significance).  The 
;; other fields are added rather than dpb'ed so this can work.
dinst:	exch o1,o4		;eff ad to o1
	call get1nt		;as mach wd to w2
	ldint w4,o2		;opcode
	lsh w4,27.		;to appropriate field
	add w2,w4
	ldint w4,o3		;reg field
	lsh w4,23.
	add w2,w4
	ldint w4,o4		;place to put it
	movem w2,(w4)		;do so
	ret1

;o1 - address to put it
;o2 - atom whose value to refer to
;  put pointer to value cell in address
dvalr:	;addi o2,at%val
	;pjrst dobj

;o1 - address to put it
;o2 - lisp object
;  put lisp object in address
dobj:	ldint w4,o1		;get absolute address
	movem o2,(w4)		;put lisp object there
	ret1

;o1 - address to put it
;o2 - number
dpword:	ldint w4,o1		;w3 - address
	move o1,o2
	call get1nt		;w2 - value
	movem w2,(w4)
	ret1

;o1 - is this a constant atom?
catmp:	gettyp o1
	caie w2,ty%cat
	jrst retnil
	jrst rett

getva:	move o1,at%val(o1)
	ret1

;getsec - get a free section
; returns section number in W4, all other AC's are unaffected
;first we try the "code sections", and then we get space from the
;free spaces.

getsec:	move w2,lstcsc		;section number of last section used
	cain w2,codsc2		;if last code section
	jrst getsc1		;go use free space
	cain w2,codsec
	movei w2,codsc2
	movem w2,lstcsc		;update last code section used
	iret

;here if we have to get a section from the end of free space.  Use the
;largest one.
getsc1:	push p,w3
	move w2,enthis
	sub w2,stthis		;w2 - length of this one
	move w3,enthat
	sub w3,stthat		;w3 - length of that one
	camge w3,w2
	jrst useths		;this one is larger, use it
;other space is bigger, use it
usetht:	move w2,enthat		;w2 - end of space
	sub w2,[1,,0]		;take a section
	move w3,w2		;see if we will have at least a section
	sub w3,[1,,0]
	camge w3,stthat		;well?
	jrst secerr		;no
	movem w2,enthat		;new upper limit
	lsh w2,-18.		;make section number
	pop p,w3
	iret			;and return it

;this space is bigger, use it
useths:	move w2,enthis		;w2 - end of space
	sub w2,[1,,0]		;take a section
	move w3,w2		;see if we will have at least a section
	sub w3,[1,,0]
	camge w3,stthis		;well?
	jrst secerr		;no
	subi w2,4000		;and the usual 4000 word buffer
	camle free,w2		;already into that area?
	 jrst usegc		;yes - need a GC
	camge w2,lastl		;if GC trigger is into the area
	movem w2,lastl		;new GC trigger
	addi w2,4000		;get back end of section
	movem w2,enthis		;new enthis
	lsh w2,-18.		;get section number
	pop p,w3
	iret			;and return it

;here if we are doing this space, and result would overlap already
;used portion.  Do a GC and then continue.  GC renames this as that
;so we go to USETHT
usegc:	camle free,w2		;SGC expects the test to be before it
	pushj p,sgc		;yes - need a GC
	jrst usetht

;here if there is not at least one section in the larger free space

secerr:	err /Not enough free space to allocate a section/

;getbps - allocate space in BPS.
; w2 - size needed in low
; w3 - size needed in high
; w4 - maximum number of functions called
; O1 - lisp #, desired section number, or NIL if can use any
;returns
; w2 - address for low
; w3 - address for high
;We must do low and high at the same time to make sure they are in the
;same section.

;** Uses all the non-Lisp AC's

getbps:	jumpe o1,getbp0			;here if don't care section
	ldint nil1,o1
	hrlz nil1,nil1			;address of descriptor
	tlnn nil1,777776		;is it section 1?
	xmovei nil1,bpscod		;yes - special
	imuli w4,fa%siz			;get number of words for ftn descrip
	push p,w4
	move w4,bps%le(nil1)		;first free
	add w4,w2			;add space we are going to use
	add w4,w3
	add w4,(p)
	camg w4,bps%hs(nil1)		;does it fit?
	jrst getbpf			;OK, found a good section
	err /Insufficient space in specified section/

getbp0:	xmovei nil1,bpscod		;get BPS descriptor for code section
	imuli w4,fa%siz			;get number of words for ftn descrip
	push p,w4			;save slop
getbpl:	move w4,bps%le(nil1)		;first free
	add w4,w2			;add space that we are going to use
	add w4,w3
	add w4,(p)
	camg w4,bps%hs(nil1)		;does it fit?
	jrst getbpf			;OK, found a good section
	skipn bps%nx(nil1)		;next section?
	jrst getbpn			;no more sections
	move nil1,bps%nx(nil1)
	jrst getbpl
;here if we run out of existing sections - make a new one
;NIL1 has the last section checked
getbpn:	move w4,w2			;make sure it is possible
	add w4,w3			;W4 - total size of request
	add w4,(p)
	caile w4,1000000-bps%st-numint
	jrst [setz nil1,
	      err /Attempt to allocate a chunk larger than 256K in BPS/]
	push p,nil1			;save address of previous section
	setz nil1,			;GETSEC can call the GC - make kosher
	move w4,w2			;save W2
	call getsec			;returns section number in W2
	pop p,nil1
	exch w2,w4			;get section number into W4
	hrlz w4,w4			;and make address of BPS descriptor
  ;now we have the address of the BPS descriptor - init it
	movem w4,bps%nx(nil1)		;link into old one
	move nil1,w4
	setzm bps%nx(nil1)		;NIL CDR for new one
	addi w4,bps%st			;start of low seg
	movem w4,bps%ls(nil1)
	movem w4,bps%le(nil1)
	hrri w4,endsec-numint		;now end of section, for high seg
	addi w4,1
	movem w4,bps%hs(nil1)
	addi w4,numint
	movem w4,bps%he(nil1)
  ;and set up internal function vector
	push p,w2
	push p,w3
	movei w2,numint			;number of internals
	xmovei w3,inttab		;start
	hll w4,nil1			;section
	hrri w4,endsec-numint		;place to put them
	xblt w2,
	pop p,w3
	pop p,w2
	jrst getbpf

inttab:	codsec,,adjval
	codsec,,bindv
	codsec,,ccatch
	codsec,,cunwnd
	codsec,,cthrow
	codsec,,lb1
	codsec,,lb2
	codsec,,lb3
	codsec,,lb4
	codsec,,lb5
	codsec,,stk2mv
	codsec,,mv2stk
	codsec,,rest1
	codsec,,rest2
	codsec,,rest3
	codsec,,rest4
	codsec,,rest5
	codsec,,restx
	codsec,,restn
	codsec,,tfaerr
	codsec,,tmaerr
	codsec,,ub1
	codsec,,ub2
	codsec,,ub3
	codsec,,ub4
	codsec,,ub5
	codsec,,unbin1
	codsec,,vcall
	codsec,,mv2lst
numint==.-inttab

;here when we get the address of an appropriate section in NIL1
getbpf:	move w4,w2			;save size
	move w2,bps%le(nil1)		;get next block
	addm w4,bps%le(nil1)		;and update address
	movn w3,w3
	addb w3,bps%hs(nil1)		;and update address
	setz nil1,
	subi p,1
	iret

;o1 - size of GC'ed area
;o2 - size of non-GC'ed area
;o3 - max number of functions called
;o4 - target section number, NIL if don't care
; allocate BPS
albps:	ldint w2,o1		;amount of GC'ed space
	ldint w3,o2		;amount of non-GC'ed space
	ldint w4,o3		;slop
	move o1,o4		;specified section here
	call getbps		;call internal routine
	maknum w2		;turn address into number
	maknum w3
	docons o1,w2,w3		;CONS them
	ret1

;; %int-ent-tab entry-pt sec-addr
intet:	getnum o1
	getnum o2
	camg o2,[codsec,,endsec]
	 skipa o2,[codsec,,inttab]
	  hrri o2,endsec-numint
	movni w3,numint
intetl:	camn o1,(o2)
	 jrst [maknum o2
		 move o1,o2
		 ret1]
	aos o2
	aojl w3,intetl
	setzb o1,o2
	ret1

;%FUNCTION-ADDRESS-BLOCK
;o1 - ftn
;o2 - address;  Only the section number of this address is used.  We
;  use BPS for that section.
;allocate an address block in BPS if there isn't one already, and
; put the dispatch address there

;**Uses all the AC's

;**** WARNING - in order to allow for this, whoever did the initial
;**** ALBPS should have supplied the number of functions to be called
;**** in the code.

fadrbl:	skipn o3,at%dsp(o1)	;already have one?
	 jrst fadrbn		;no - make one
	skpnum o3		;is it a real fadrblock?
	 jrst fadrbn		; no, ignore it
;here if we have an address block - make sure it is in the right section
	move o5,o3		;O5 is first function addr block
	ldb w3,[.bp <7777,,0>,o2] ;get desired section number
fadrlp:	ldb w2,[.bp <7777,,0>,o3] ;get section number of existing adr bl
	camn w2,w3
	 jrst fadrbx		;they match - done
	skipe o3,fa%nxt(o3)	;no - any more?
	 jrst fadrlp		;yes - check them
	jrst fadrnn		;no - create a new one for the right section

;Allocate a new address block and return it.
;This entry is used when there is no existing fadrblk
fadrbn:	setz o5,		;no old ftn addr block
fadrnn:	hllz w2,o2		;get addr of start of section
	camn w2,[inum <codsec,,0>] ;except codsec is special
	 move w2,[inum <codsec,,bpscod>]
  ;w2 is now the address of the BPS descriptor for the relevant section
	move o2,bps%le(w2)	;allocate from the low segment
	addi o2,fa%siz
	camle o2,bps%hs(w2)	;make sure there is room
	 jrst [setz o2,		;not legal Lisp object
	       err /No space for address block in required section/]
	movem o2,bps%le(w2)
	subi o2,fa%siz
	movei w2,fa%siz		;size
	xmovei w3,(o5)		;source [may be junk if O5 is 0: see below]
	move w4,o2		;dest
	jumpn o5,.+2		;if this is a new fadrblk,
	 xmovei w3,ccitab	; then we want an apply function fadrblk
	xblt w2,		;block transfer
	movem o1,fa%atm(o2)	;put in the atom
	movem o5,fa%nxt(o2)	;NEXT field
	maknum o2		;now turn address of block into legal number
	movem o2,at%dsp(o1)	;now make this the first address block
	push q,o2		;and return it
	jumpn o5,.+3		;=*= update if defn has changed
	 move o2,at%fun(o1)
	 call fblomp
	pop q,o1
	ret1

fadrbx:	move o1,o3
	ret1

;This must be same length as fadrblk
ccitab:	object ty%iadr,<codsec,,ccic0>
	object ty%iadr,<codsec,,ccic1>
	object ty%iadr,<codsec,,ccic2>
	object ty%iadr,<codsec,,ccic3>
	object ty%iadr,<codsec,,ccic4>
	object ty%iadr,<codsec,,ccic5>
	object ty%iadr,<codsec,,ccicn>
	0,,0
	0,,0

;;;Compiled Calls to Interpreted Code
cciceb:	push p,sp
	push p,q
	xct (w4)		;push p,[<#args>]
	move w3,-3(p)		;get the rtn addr
	hrr w3,-1(w3)		;save section no, get fadrblk addr
	trne w3,777770		;if an offset, o6 already has fn
	 xct 1(w4)		; otherwise get it
	push q,at%fun(o6)	;function definition
	push sp,nil	;create EVAL blip
	push sp,o6		;function (atom) name
	push sp,[%savep]	;and saved p
	push sp,[<inum 0>-1]
	addm p,(sp)
	jrst 2(w4)

;; cciceb executes the two instrs following the call at strategic times
ccic0:	jsp w4,cciceb
	 push p,[0]
	 move o6,7(w3)
	jrst iapply

ccic1:	jsp w4,cciceb
	 push p,[1]
	 move o6,6(w3)
	push q,o1
	jrst iapply

ccic2:	jsp w4,cciceb
	 push p,[2]
	 move o6,5(w3)
	push q,o1
	push q,o2
	jrst iapply

ccic3:	jsp w4,cciceb
	 push p,[3]
	 move o6,4(w3)
	push q,o1
	push q,o2
	push q,o3
	jrst iapply

ccic4:	jsp w4,cciceb
	 push p,[4]
	 move o6,3(w3)
	push q,o1
	push q,o2
	push q,o3
	push q,o4
	jrst iapply

ccic5:	jsp w4,cciceb
	 push p,[5]
	 move o6,2(w3)
	push q,o1
	push q,o2
	push q,o3
	push q,o4
	push q,o5
	jrst iapply

ccicn:	jsp w4,cciceb		;note that this puts the fn on q
	 push p,n
	 move o6,1(w3)
	move o6,(q)
	movei w2,5
	sub w2,n	;-(n - 5), - number of args on stack
	move w3,q	;XBLT wants first addr + 1.  Since we are going
			;  to ignore the ftn defn on top of stack, this
			;  is it
	xmovei w4,6(w3)	;move it up 6
	xblt w2,	;do the move
	move w4,o6
	dmovem w4,(w3)	;function definition, 1st arg
	dmovem o2,2(w3)	; other args
	dmovem o4,4(w3)
	addi q,5
	subi w3,1
	movem w3,-1(p)	;save this as saved Q
	jrst iapply

;in-line funcalls come here when obj is not an atom or there isn't a 
; fadrblock
;Unidentified Function Object
ufo:	aos w3,(p)		;get the rtn addr
	hrrz w3,-1(w3)		;next wd is real call, this is n
ufo1:	tlne o6,760000		;is it an atom?
	 jrst calpse		;no, interpret
	skipn w2,at%fun(o6)	;has it any definition?
	 jrst @ccitab(w3)	;no, (filter thru to CUDF)
	docar w4,w2
	came w4,[%SUBR]		;is it compiled?
	 jrst @ccitab(w3)	;no, interpret
	docdr w4,w2		; yes compiled, get dispatch vec.
	docar w2,w4
	movem w2,at%dsp(o6)	;makes a fake fadrblock
	add w2,w3
	jrst @(w2)		;and call

;;; secondary entry point for non-returning code.  
;;; push a fake return addr to fool ccic etc.
ufon:	push p,[codsec,,ufox]
	jrst ufo1
	jfcl			;do not fool with this sequence!!!!
ufox:	iret

calpse:	move w4,[%PSEUDO]
	movem o6,at%fun(w4)
	move o6,w4
	jrst @ccitab(w3)

;support routine for compiled code:
; create a closure function object.
; (this is an atom with fn defn, fadr block, and the
;  closure vector in its value cell)
;args:  O1 -- original atom for function,   O2 -- closure vector
;;TY%ATM
clogen:	push free,o2		;at%val - the closure vector
	move o3,free		;save addr of first for atom ptr
	push free,nil		;at%pro - no properties
	push free,at%pna(o1)	;at%pna - pname
	push free,at%fun(o1)	;at%fun - ftn defn
	push free,nil		;at%pkg - no package
	push free,at%dsp(o1)	;at%dsp - fadr block
	tlz o3,770000		;make it atom
	camle free,lastl	;see if went beyond end of space
	 call sgc		;yes
ifn ty%atm,[printx this code depends upon ty%atm being 0]
	move o1,o3
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; UNBIND and friends
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;UNBIND unwinds the SP stack.  Since this contains saved values of all
;variables that have been changed, this returns us to an old variable-
;binding context.  The context to return to is passed on P (or in W2, if
;you call UNBIND1).  We must check for EVAL blips, which are the one
;thing whic does not have saved values.  The type code for an EVAL blip
;is an isolated bit, so we can just check that bit.

;Note that UNBIND and CUNBIND are designed so that we can ^C out and
;restart the core image, and the restart code will continue the unbind
;without losing anything.  For this reason, SP is not popped until the
;value has been assigned, and the file closing is handled carefully also.

ubdr1v:	movei n,1		;return 1 val
unbind:	pop p,w2		;saved sp
	jrst unbin1

unbinl:	subi sp,2
unbin1:	camg sp,w2
	retn
 ;NB: we have to use W2/W3 because MV returning functions use all the On
	dmove w3,-1(sp)
	jumpe w3,unbinl		;ignore eval blips
	setgval w3,w4		;restore binding
	jrst unbinl

;WARNING:  CUNBIND may call UNWIND-PROTECT code.  Thus you should not
;have anything on the stack.  The normal convention is to force MV's,
;put them on the MV stack with MV2STK, then bring them back with
;STK2MV.
cunbin:	pop p,w2		;saved sp
	jrst cunbn1

cunbnl:	subi sp,2
cunbn1:	camg sp,w2
	retn
 ;NB: we have to use W2/W3 because MV returning functions use all the On
	dmove w3,-1(sp)
	jumpe w3,cunbnl		;ignore eval blips
	camn w3,[%unwpro]	;if unwind-protect
	jrst dounwn		;go do it
	setgval w3,w4		;restore binding
	jrst cunbnl

;here if we find an unwind-protect on the stack
dounwn:	push p,q		;throw restored the proper Q
	move w3,-2(sp)		;get saved Q
	tlz w3,770000		;pure number
	move q,w3
	push p,w2
	call (w4)		;cleanup form is there
	pop p,w2
	pop p,q
	jrst cunbnl

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; UNWIND-PROTECT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;CUNWND - support for compiled code
;  call cunwnd
;  jrst cleanup
;  jrst exit
;  body
;  retn
;cleanup:
;  body
;  iret
;exit:

;we do the following:
;  - on SP put an %UNWPRO blip, pointing to the CLEANUP code
;  - change P to have EXIT and then the instruction after the CALL CUNWND
;	Since the MV flag is after EXIT, this allows the subroutine for
;	the body to figure out whether it should return multiple values
cunwnd:	
;construct %UNWPRO blip
	push sp,[%dummy]	;save Q
	move w2,q
	maknum w2
	push sp,w2
	push sp,[%unwpro]	;now the actual UNWIND-PROTECT
	move w2,(p)		;our return address
	maknum w2
	push sp,w2
;now do the body
	call 2(w2)		;call the body
;now do the cleanup.  We can't use Q, because the code may be using
;Q for local variables.
	subi sp,4		;remove blip (cleanup not protected)
	call mv2stk		;save MV's around this call
	move w2,(p)		;get addr of cleanup
	call (w2)		;cleanup form is there
	call stk2mv		;get MV's back
	aos (p)
	retn			;return to EXIT

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CATCH
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;CCATCH - support for compiled code
;  move o1,tag
;  call ccatch
;  jrst exit
;  body
;  retn
;exit:

;The pseudo-variable .CATCH will always point to the top-most
; catch blip on the stack.  The saved values form a linked list
; of all of them.  The other part of the blip is the tag and address
ccatch:	push p,sp		;save full context for THROW
	push p,mvp
	push p,q
	move w2,sp
	maknum w2
	bindit %CATCH,w2	;rebind %CATCH
	push sp,[%DUMMY]
	push sp,o1		;also need the tag
	move w2,p		;and the current stack
	maknum w2
	push sp,[%DUMMY]
	push sp,w2
;now have the stack blip.  Do our thing
	move w2,-3(p)		;get our return address
	hrr w2,(w2)		;change it to EXIT
	exch w2,-3(p)
	call 1(w2)		;call the body
	subi p,2		;forget saved Q and MVP
	jrst unbind		;prune stack

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CTHROW
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;CTHROW - support for compiled code

;  O1 - tag
;  call cthrow
;  code to compute result
;  retn

cthrow:	push sp,[%DUMMY]
	push sp,o1		;save the tag
;retfro depends upon the fact that we don't touch any ac's above
;O1 before doing the call, and don't use Q or N
	move w2,(p)		;get addr of code
	call (w2)		;compute return value
	pop sp,o6		;get back the tag
	subi sp,1
	move w2,@[.catch]	;look up catch chain for the tag
cthrol:	jumpe w2,cthrof		;end of chain, failed
	camn o6,4(w2)		;the tag is here in the blip
	jrst cthros		;success
	move w2,2(w2)		;get next in chain
	jrst cthrol

;here if we find a matching CATCH
cthros:	call mv2stk		;put values on MV stack
	move p,6(w2)		;get the stack back
	posnum p
	move q,(p)		;Q and SP are on the stack
	move w2,-2(p)		;new SP
	call cunbn1		;unwind stack to there
	call stk2mv		;put MV's back
	move w2,-1(p)		;get back the old MVP
	movem w2,mvp
	subi p,3		; [*]
	retn			;we have MV's, if they are so desired
;[*] we couldn't pop q and w2 off p before calling cunbn1
; because it might invoke an unwind-protect which might do a throw
; to the same label!  At that point the info on P must still be there.

;here if didn't find the right tag
cthrof:	err1 o6,/THROW with no matching CATCH for tag ~S/

;VALSP - check for SP of odd size or with partial EVAL blip at top, due
;to interrupting an operation on the SP
;  This must be done at interrupt level, before the DEBRK
valsp:	move w3,savesp		;get known valid SP
	xor w3,sp		;compare with current
	trne w3,1		;if different parity
	subi sp,1		;then adjust to valid
	skipe -1(sp)		;if partial EVAL blip
	jrst (w2)		;not - done
	push sp,[%savep]	;finish the blip
	push sp,[inum 0]
	iorm p,(sp)
	jrst (w2)	
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Misc stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;TY%ATM
;%SP-SET-DEFINITION, o1 atom, o2, definition.
setdef:	ssymb o1
	 jrst setdns		;undefined if not symbol
	snsymb o2
	 move o2,at%fun(o2)
	movem o2,at%fun(o1)	;actual definition
	doboth o3,o2
	camn o3,[%SUBR]
	 call flasho
	doboth o3,o4
	camn o3,[%SUBR]
	 call flasho
	call fblomp
;We need to be able to define specials forms as macros also.  The
;following code would cause the macro definition to kill the
;special form.
;	gettyp o1		;if constant atom, has an evaluator
;	cain w2,ty%cat
;	setzm at%fev(o1)	;no evaluator
	ret1

;Not a symbol, setdef
setdns:	push q,o2
	cerr1 o1,/(RETURN '<symbol>)/,/Can't give function definition to ~S/
	pop q,o2
	jrst setdef

;trying to set NIL, setdef
setdnl:	push q,o2
	cerr /(RETURN '<symbol>)/,/Can't define NIL as a function/
	pop q,o2
	jrst setdef

; "flash-over" the inums in the defn to iadrs
flasho:	docar o3,o4
	movei w2,ty%iadr
	dpb w2,[.bp (770000),0(o3)]
	dpb w2,[.bp (770000),1(o3)]
	dpb w2,[.bp (770000),2(o3)]
	dpb w2,[.bp (770000),3(o3)]
	dpb w2,[.bp (770000),4(o3)]
	dpb w2,[.bp (770000),5(o3)]
	dpb w2,[.bp (770000),6(o3)]
	iret	

;;FADR Block stomping routine: takes an atom in o1 and func. defn in o2
;  leaves fadr block(s) of atom in appropriate state
fblomp:	skipn o3,at%dsp(o1)	
	 iret			; no fadr blocks
	jumpe o2,blomp1
	doboth o4,o2		;check the definition
	came o4,[%SUBR]		;is new defn a subr?
	 jrst blomp2		; no--
	docar o5,o5		; fundef = (SUBR #(...)) -- get vector
;	movei w4,ty%iadr	;;TY%IADR  ; yes, put entry pt addrs in blocks
blomp0:	dmove w2,(o5)		;get addrs 2 at a time and change type
;	dpb w4,[.bp (770000),w2]
;	dpb w4,[.bp (770000),w3]
	dmovem w2,fa%ds0(o3)		;stash in fadr block
	dmove w2,2(o5)
;	dpb w4,[.bp (770000),w2]
;	dpb w4,[.bp (770000),w3]
	dmovem w2,fa%ds2(o3)
	dmove w2,4(o5)
;	dpb w4,[.bp (770000),w2]
;	dpb w4,[.bp (770000),w3]
	dmovem w2,fa%ds4(o3)
	move w2,6(o5)
;	dpb w4,[.bp (770000),w2]
	movem w2,fa%dse(o3)
	skpnum o3		;no fa%nxt in a vector
	 iret
	skipe o3,fa%nxt(o3)	;are there more fadr blocks on the list?
	 jrst blomp0		; yes, go do 'em
	iret			;no

		; func def is nil, put undefined
blomp1:	dmove w2,[object(ty%iadr,<codsec,,calund>)
		  object(ty%iadr,<codsec,,calund>)]
	dmovem w2,fa%ds0(o3)
	dmovem w2,fa%ds2(o3)
	dmovem w2,fa%ds4(o3)
	movem w2,fa%dse(o3)
	skpnum o3		;no fa%nxt in a vector
	 iret
	skipe o3,fa%nxt(o3)
	 jrst blomp1
	iret

blomp2:	movei w2,fa%dse+1	; interpreted defn--put ccicx in fadrblocks
	xmovei w3,ccitab	;w2=number wds, w3=source, w4=dest
	move w4,o3
	xblt w2,
	skpnum o3		;no fa%nxt in a vector
	 iret
	skipe o3,fa%nxt(o3)	;more blocks?
	 jrst blomp2
	iret

;;TY%ATM
;FUNDEF(atom)
getdef:	ssymb o1
	 jrst retnil
	move o1,at%fun(o1)
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  Here are the environment functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

gjbfln==30
	.vector gjbuf(gjbfln)

st2buf:	move w2,[440700,,gjbuf]	;leaves nil1 and o1 garbaged
	move w3,(o1)
	tlz w3,770000
	hrlzi w4,440740
	tlz o1,770000
	aos o1
st2lp:	sojl w3,[idpb nil,w2 ? iret]
	ildb nil1,w4
	idpb nil1,w2
	jrst st2lp

sphost:	hrroi nil1,gjbuf	;get host name as a string
	seto w2,
	cvhst
	 erjmp unkhst
	idpb nil,nil1
	jrst buf2st

unkhst:	;; [Victor] Check DECnet host name first
	movei nil1,1		; .NDGLN
	movei w2,w3
	hrroi w3,gjbuf
	node			; Try DECnet
	 erjmp unkhs1
	idpb nil,w3		; Make asciZ
	jrst buf2st

unkhs1:	;; [Victor] End addition
	setzm gjbuf
	hrlzi nil1,(gj%old\gj%sht)
	hrroi w2,[asciz /system:hostname.txt/]
	gtjfn
	 erjmp vukhst
	move w3,nil1
	move w2,[<7_30.>+of%rd]
	openf
	 erjmp [move nil1,w3
		rljfn
		 erjmp vukhst
		jrst vukhst]
	hrroi w2,gjbuf
	movei w3,gjbfln*5-1
	movei w4,^M
	sin%
	 erjmp [idpb nil,w2
		closf
		 erjmp buf2st
		jrst buf2st]
	dpb nil,w2
	closf
	 erjmp buf2st
	jrst buf2st

vukhst:	setzb nil,nil1
	move o1,[makstr "UNKNOWN"]
	ret1

spsysv:	setzb w2,gjbuf
sysv01:	movei nil1,.sysver
	hrl nil1,w2
	getab
	 jrst buf2st
	movem nil1,gjbuf(w2)
	aoja w2,sysv01

eretnl:	setzb nil1,o1
	ret1

buf2st:	push free,[object ty%sp5,0]
	move o1,free
	tlo o1,(<object ty%str,0>)
	hrlzi w3,440740
	aos w4,free
	move w2,[440700,,gjbuf]
buf2lp:	ildb nil1,w2
	jumpe nil1,[move free,w4 ? ret1]
	idpb nil1,w3
	aos (o1)
	setzm 1(w4)
	jrst buf2lp

;; %sp-disms n -- sleep n (an inum) milliseconds
spdism:	move nil1,o1
	getnum nil1		;make real number
	disms			;rock-a-bye baby
	setzb nil1,o1		;return nil
	ret1

;; decode-universal-time -- do get-decoded-time on a given time
decut:	setz o2,		;default for time zone
	call get1nt
	setz w3,		;clisp time is seconds-based
	ashc w2,-17.		;20x time is days-based
	divi w2,86400.		;divide by # secs in a day
	add w2,[35254,,0]	;# days,,frac from 18 nov 1858 to 1 jan 1900
	setz w4,
	skipn o2		;time zone supplied?
	 jrst oddo		; no, use local
	tlo w4,(ic%utz)		;yes, use supplied one
	dpb o2,[.bp ic%tmz,w4]
	jrst oddo

;; get-decoded-time -- return sec, min, hr, day, mon, yr, wkdy, dst-p, zone
getdt:	seto w2,		;current daytime
	setz w4,		;default dst & zone
oddo:	odcnv			;explode daytime
	move n,mvp		;return multiple values
	hrrz o1,w4		;seconds since midnight
	idivi o1,60.
	maknum o2		;seconds
	movem o2,1(n)		;first return
	idivi o1,60.
	maknum o2		;minutes
	movem o2,2(n)		;second return
	maknum o1		;hours
	movem o1,3(n)		;third return
	hlrz o1,w3		;day of month, 0=first 20x
	addi o1,1		;1=first, clisp
	maknum o1
	movem o1,4(n)		;4th return
	hrrz o1,w2		;month, 0=jan 20x
	addi o1,1		;1=jan, clisp
	maknum o1
	movem o1,5(n)		;5th return
	hlrz o1,w2		;year
	maknum o1
	movem o1,6(n)		;6th return
	hrrz o1,w3		;day of week, 0=Monday (both)
	maknum o1
	movem o1,7(n)		;7th return
	setz o1,		;daylight-savings-time-p
	tlne w4,(ic%ads)
	 move o1,[%T]
	movem o1,8.(n)		;8th return
	ldb o1,[.bp ic%tmz,w4]	;time zone, 0=GMT, +=west (both)
	trne o1,40		;make it work east of Greenwich
	 	; this bug was rumored to have caused the
		; accident at Chernobyl
	 orcmi o1,77
	maknum o1
	movem o1,9.(n)		;9th return
	setzb nil1,o4		;yoost in case
	dmove o1,1(n)
	dmove o3,3(n)
	move o5,5(n)
	movei n,9.
	retn			;return 9 values!

;; %sp-enc-ut, used by encode-universal-time: secs day mon year zone
;;;  all params adjusted to our liking by the lisp code
encut:	hrl w2,o4		;year
	hrri w2,-1(o3)		;month
	hrlzi w3,-1(o2)		;day
	hrrz w4,o1		;secs
	jumpe o5,encut1		;if no zone supplied
	dpb o5,[.bp ic%tmz,w4]	;use time zone
	tlo w4,(ic%dsa\ic%utz)	;if zone supplied, don't use DST
;;now that the params are in the right regs, convert to 20x time
encut1:	idcnv
	 jrst eretnl
	setz nil1,
	jrst cltime		;convert 20x time to CLisp time

;; get-universal-time -- return # of seconds since 1 jan 1900 00:00:00-GMT
getut:	gtad			;get 20x format daytime
	move w2,nil1		;move to right reg
	setz nil1,		;clear nil
	jrst cltime

;;[Victor] get-internal-run-time -- return msec CPU time for this process
getirt:	movei nil1,1		;[Victor] 1 is code for job run time
;; get-internal-real-time -- return # msec since sys came up
getit:	hptim%			;[Victor] 0 (nil!) is code for system uptime
	 erjmp [err /Can't read time/]	;[Victor] 
	idivi nil1,100.		;[Victor] convert to msec
;	time			;[Victor] 
	move w2,nil1
	setz nil1,
	jrst ret1nt

;;[Victor] this is above, now
;; get-internal-run-time -- CPU time
;getirt:	movei nil1,.fhslf
;	runtm
;	move w2,nil1
;	setz nil1,
;	jrst ret1nt

cltime:	sub w2,[35254,,0]	;adjust from 20x base to Clisp base
	muli w2,86400.		;convert 20x daytime to CLISP form
	dadd w2,[0 ? 0,,400000]	;round up left half of w3 if needed  DKS
	ashc w2,-18.
	jrst retint

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;ROOM

;Free space currently used: 100000 words
;Free space left before next GC: 10000 words
;For more information, set *PRINT-GC-INFO* to T

room:	setz o1,	;default is no extra info
	push q,o1
	move o2,@[.STDOUT]
	call lin0
	movei w2,[asciz /;Free space currently used: /]
	call tyout
	move o1,free
	sub o1,stthis
	maknum o1
	call prnm10
	movei w2,[asciz / words
;Free space left before next GC: /]
	call tyout
	move o1,lastl
	sub o1,free
	maknum o1
	call prnm10
	movei w2,[asciz / words
/]
	call tyout
	pop q,o1
	jumpe o1,ret1v
	movei w2,[asciz /;For more information, set *PRINT-GC-INFO* to T
/]
	call tyout
	setz o1,
	ret1

;;;;used by the TIME macro
; get-gc-time
gctime:	move w2,gctimt
	jrst ret1nt

; speak-nwds
speak:	move w2,free	;gc count
	sub w2,stthis
	add w2,gccont
	jrst ret1nt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Arithmetic functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;TY%NUM
;;TY%INT

;movflo - loads double float number into w2 and w3 from pointer
define movflo(pnt)
	dmove w2,1(pnt)
	termin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; GETREA [internal only]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;TY%FLO
;Lisp object in O1.  Returns real value in W2/W3.
getrea:	skpnum o1
	 jrst notnum
	xtype o1
	xct gtrtab-ty%xfl(w2)
	iret			;already real, done

;;TYPES
;WARNING - this table is also used by DOUBLE, so be careful
gtrtab:	dmove w2,1(o1)		; long flonum ;;TY%FLO
	jrst gtrifl		; neg iflons
	jrst gtrifl		; pos iflons
	jrst gtrrat		; ratios
	jrst notnum		; complex (unimplemented)
	jrst gtrbig		; bignum
	jrst gtrinu		; neg inums
	jrst gtrinu		; pos inums
;;TY%IFL
gtrifl:	move w2,o1		;make double flo from iflon
	lsh w2,4
	setz w3,
	iret

gtrbig:	push q,o1
	call cnvb2l		;convert bignum to long float
	dmove w2,1(o1)
	pop q,o1		;leave something useful in o1
	iret

gtrrat:	push q,o1
	call cnvr2l		;convert ratio to long float
	dmove w2,1(o1)
	pop q,o1		;leave something useful in o1
	iret


;;TY%INU
;integer - convert to real.  We can't use FLOAT because that would limit
;us to the range of single precision numbers.  We produce a non-normalized
;real by adding an exponent, then add 0 to normalize it.
gtrinu:	move w3,o1
	getnum w3
	jumpl w3,gtrin1		;if negative, special
	move w2,[<62.+200>_27.]	;and exp in w2
	dfad w2,0		;normalize by adding 0
	iret

gtrin1:	movn w3,w3		;get positive form
	move w2,[<62.+200>_27.] ;and exp in w2
	dfad w2,0		;normalize by adding 0
	dmovn w2,w2		;negate the whole thing
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; FLOAT (number, other)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;returns a floating point number in the same format as OTHER,
; unless it is already floating.  If OTHER is unspecified, it defaults
; to SINGLE

float:	jrst defflo		;one arg, default to single
	xtype o2		;two args, see what type to use
	cain w2,ty%xfl		;use whatever it uses
	 jrst double
	;jrst flonum
	
;FLONUM - force to short real
flonum:	call getrea		;get real into W2/W3
retif:	fmpr w2,[201400,,4]	;round it
	makifl w2		;make number into an iflon
	move o1,w2		;and return it
	ret1

;DEFFLO - if real, leave alone, else convert to short real
;This code works because GTRTAB returns only for longs.  So shorts and
;  anything else will go off to RETIF and become shorts, and we
;  leave longs alone.
defflo:	skpnum o1
	 jrst notnum
	push p,[codsec,,retif]	;if the XCT JRST's, it will return to RETIF
	xtype o1
	xct gtrtab-ty%xfl(w2)
  ;here if it was already double
	subi p,1		;forget the retif, already long
	ret1			;already real, done

;DOUBLE - force to long real
double:	skpnum o1
	 jrst notnum
	push p,[codsec,,retflo]	;if the XCT JRST's, it will return to RETFLO
	xtype o1
	xct gtrtab-ty%xfl(w2)
  ;here if it was already double
	subi p,1		;forget the retflo, already long
cret1:	ret1			;already real, done

;TRIGAR - handle arguments to trig functions.
;  loads value to W2/W3,  W4 gets 0 if single prec, 1 if double
trigar:	skpnum o1
	 jrst notnum
	push p,[codsec,,trigx0]	;if the XCT JRST's, it is returning s.p.
	xtype o1
	xct gtrtab-ty%xfl(w2)
	subi p,1		;forget the ret1
	movei w4,1
	iret

trigx0:	movei w4,0
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  RATIONAL - convert anything to a rational number
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;TY%RAT
;lisp entry	turn anything into a ratio
ration:	xnmtyp o1		;check each number for integrity
	xct .+1(w2)		;;TYPES
	jrst xrtflo		;long flons
	jrst xrtifl		;iflons
	jrst xrtifl		;iflons
	jrst cret1		;ratios
	jrst notnum		;complex
	jrst cret1		;bignums
	jrst cret1		;inums
	jrst cret1		;inums

xrtifl:	move w3,o1
	lsh w3,4		;get machine flonum
	skipa w4,nil
xrtflo:	 dmove w3,1(o1)
;we assume that all bits are significant.  Thus we want to
;multiply by a power of 2 that represents the exponent

;here we have the number in W3/W4.  there is an
;implicit denominator of 1.0
	movm w2,w3		;get exponent in W2
	lsh w2,-27.
	subi w2,201		;difference in exponents
	push p,w2		;STACK: difference in exponents
	ash w3,8.		;mantissa only in W3/W4
	ash w3,-8.
	skipge (p)		;go elsewhere if need to multiply denom
	 jrst xrtif2
	skipg (p)
	 jrst xrtif3		;or if equal, particularly easy
;here if the numerator is bigger, so we have to multiply it by a power of 2
;actually we call LSHF and shift
	dmovem w3,work2+1	;put the actual number in an ersatz bignum
	move o1,[object ty%spc,2]
	movem o1,work2
	move o1,[object ty%cbg,<codsec,,work2>] ;pointer to bignum
	pop p,o2		;difference in exponents
	maknum o2		;must be a real lisp number
	call lshf		;we now have the numerator, shifted, in O1
;now put double floating 1 in O2
	push free,[object ty%spc,2]
	move o2,free
	tlo o2,(<object ty%big,0>)
	push free,[400,,0]
	push free,[0]
	caml free,lastl
	 call sgc	
	jrst ratio1		;and make a ratio

;here if exponents are the same.  No shifting needed
xrtif3:	subi p,1
;put number in O1
	push free,[object ty%spc,2]
	move o1,free
	tlo o1,(<object ty%big,0>)
	push free,w3
	push free,w4
;now put double floating 1 in O2
	push free,[object ty%spc,2]
	move o2,free
	tlo o2,(<object ty%big,0>)
	push free,[400,,0]
	push free,[0]
	caml free,lastl
	 call sgc	
	jrst ratio1		;and make a ratio

;here if the denominator is bigger, so we have to multiply it by a power of 2
;actually we call LSHF and shift
xrtif2:	pop p,o2		;difference in exponents
	push p,w3		;save numerator
	push p,w4
	move o1,[object ty%cbg,<codsec,,xrtdnm>] ;constant 1
	movm o2,o2		;abs value
	maknum o2		;must be a real lisp number
	call lshf		;we now have the numerator, shifted, in O1
	move o2,o1		;want it in o2
;now put the numerator in O1
	pop p,w4
	pop p,w3
	push free,[object ty%spc,2]
	move o1,free
	tlo o1,(<object ty%big,0>)
	push free,w3
	push free,w4
	caml free,lastl
	 call sgc	
	jrst ratio1		;and make a ratio

xrtdnm:	object ty%spc,2
	400,,0
	0

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  TRUNCATE number divisor - returns result and remainder
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

trunc:	move o2,[inum 1]	;if only one arg, second is 1
	move w3,o2		;otherwise do the division
	xtype o2		;what's second arg?
	xct doptab(w2)		;above, qv
	 jrst xdivid
	xtype o1
	xct a2itab(w2)
xdivid:	xct .+1-ty%xfl(w2)	;;TYPES
	jrst xdvflo		;long flons
	jrst xdvifl		;iflons
	jrst xdvifl		;iflons
	jrst xdvrat		;ratios
	jrst notnum		;complex
	jrst xdvbig		;bignums
	jrst xdvinu		;inums
	jrst xdvinu		;inums

;truncate floating point in 1/2
xdvflt:	jumpge nil1,xdvftx	;if nonneg, do it directly
	dmovn nil1,nil1
	call xdvftx
	dmovn nil1,nil1
	iret

xdvftx:	ldb w3,[.bp <377_27.>,nil1] ;get exponent
	movei o3,200		;no shift needed for this
	sub o3,w3		;o3 is now shift needed for mask
	jumpge o3,xdvrtz	;if all bits masked, use true zero
	dmove w3,[000777,,777777 ? 377777,,777777] ;mask
	ashc w3,(o3)		;mask needed for truncation
	tdz nil1,w3
	tdz w2,w4		;1/2 is now truncated result
	iret

;here to return zero
xdvrtz:	setzb nil1,w2
	iret

;;TY%FLO
xdvflo:	addi p,4		;make room for temps
	dmove nil1,1(o1)	;double precision divide
	dfdv nil1,1(o2)		;w2 - quotient
	call xdvflt		;truncate
	dmovem nil1,-3(p)	;save truncated quotient
	dfmp nil1,1(o2)		;now get back truncated product
	dmove w3,1(o1)		;original
	dfsb w3,nil1		;difference - this is remainder
	dmovem w3,-1(p)		;and save this too
	setzb o3,nil1		;make things legal again
	dmove w2,-1(p)		;get the second value
	call retflo		;now have remainder in Lisp form
	push q,o1
	dmove w2,-3(p)		;get truncated quotient
	call fixf02		;get integer
	pop q,o2		;remainder need to be in O2
	subi p,4
	ret2

;;TY%IFL
xdvifl:	push p,o1		;save original
	fdvr o1,w3		;single prec divide
	push p,o1		;save for first result
	call xrmift		;truncate
	fmpr o1,w3		;now get back truncated product
	move w2,-1(p)		;original
	fsbr w2,o1		;difference - this is remainder
	makifl w2		;make Lisp object
	push q,w2		;save it
	pop p,w2		;get back truncated quotient
	setz w3,		;make d.p.
	call fixf02		;get result as truncated integer
	pop q,o2		;get back remainder
	subi p,1		;forget original
	ret2

xdvrat:	camn o1,[object ty%crt,<codsec,,work>]
	 move o1,work
	camn o2,[object ty%crt,<codsec,,work>]
	 move o2,work
; now do the work.  use o1 - trunc(o1/o2)*o2
	push q,o1
	push q,o2
	call quot
	call fixf
	move o2,(q)		;get back divisor
	movem o1,(q)		;and save truncated result for later
	call times
	move o2,-1(q)
	exch o1,o2
	call diff
	move o2,o1		;remainder here
	move o1,(q)		;truncated quotient here
	subi q,2
	ret2

;;TY%BIG
xdvbig:	getsiz w2,o1		;size of dividend
	getsiz w3,o2		;siza divisa
	caile w2,4		;DDIV can handle <4wd>/<2wd>
	 jrst xdvbgb		;else go for mult wd routine
	caile w3,2
	 jrst xdvbgb
	dmove w3,1(o1)		;indeed, ddiv requires 4wd/2wd
	cain w2,4		;so we must do the sign-extend
	 jrst [dmove nil1,3(o1) ? jrst .+3]
	  move nil1,w3		;by hand if dividend is only 2wd.
	  ashc nil1,-70.
	jfcl 17,.+1		;overflow occurs if the quotient is 
	ddiv nil1,1(o2)		;bigger than 2 words, so go to 
	jov [skipn 1(o2) ? skipe 2(o2) ? jrst xdvbgb ? jrst .+1]
	push p,nil1		;save quotient
	push p,w2
	setz nil1,		;go back to normal context
	dmove w2,w3		;get remainder in canonical place
	call retint		;now have remainder as Lisp in O1
	push q,o1		;save it
	pop p,w3		;get back quotient
	pop p,w2
	call retint		;now have quotient as Lisp in O1
	pop q,o2		;and remainder
	ret2

xdvbgb:	call divrou		;this routine does the work--qv
;now active: o1,o2, addr/len of quot
;	     o3,o4, addr/len of rem
;  	     n  1's bit: neg quotient; 2's bit: neg remainder
	move w4,o2		;length of quotient
	add o2,o1		;o1 is pointer to quotient on the stack
	push p,o2		;this points to the end of it
;now active: w4: size, (p): addr of quot;  o3/o4 rem
	push p,o3
	push p,o4
	setzb nil1,o2		;clean up sensitive registers
	setzb o3,o4
	setz o5,
	call bigmak		;alloc space for the quotient
	pop p,o4
	pop p,o3
	pop p,o2		;copy from stack into heap.
	move o5,o1		;remember that the doublewords in
;now active: 
; w2/3 - work
; w4 - size/2,
; o1 - final object for quotient
; o2 - address of stack being copied
; o3/o4 - remainder
; o5 - address in final object being copied to
xdvcpy:	dmove w2,-2(o2)		;the heap object are in reverse order.
	dmovem w2,1(o5)		;lsd to msd
	addi o5,2		;up the bignum
	subi o2,2		;down the stack
	sojg w4,xdvcpy
	trne n,1		;see if it was negative
	 call rdnbig		;it was
	push p,n		;Save Our Sign!
	call bgtrim		;and trim bignum
	pop p,n
;now the same thing for the remainder
	move w4,o4		;length of quotient
	add o4,o3		;o1 is pointer to quotient on the stack
	push p,o4		;this points to the end of it
	move o4,o1		;save final object for quotient
;now active: w4: size, (p): addr of rem;  o4: quotient
	setzb o2,o3		; don't leave garbage for GC to see
	setz o5,
	call bigmak		;alloc space for the quotient
	pop p,o2		;copy from stack into heap.
	move o3,o1		;remember that the doublewords in
;now active: 
; w2/3 - work
; w4 - size/2,
; o1 - final object for rem
; o2 - address of stack being copied
; o3 - address in final object being copied to
; o4 - quotient
xdvcpr:	dmove w2,-2(o2)		;the heap object are in reverse order.
	dmovem w2,1(o3)		;lsd to msd
	addi o3,2		;up the bignum
	subi o2,2		;down the stack
	sojg w4,xdvcpr
	trne n,2		;see if it was negative
	 call rdnbig		;it was
	call bgtrim		;--n't (last use of sign, not saved)
	move o2,o1		;get remainder as CDR
	move o1,o4		;quotient as CAR
	pop q,p			;saved p
	tlz p,770000		;(we made it into an object for q)
	setz o3,		;clean up more regs
	setzb o4,o5
	ret2

;;TY%INT
;; after that, the inum divide routine is awfully anticlimactic:
xdvinu:	idiv o1,w3
	maknum o1		;quotient
	maknum o2		;remainder
	ret2

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; FIXF - this is used internally.  It is truncate for a single
;;;; argument, returning a single result.  Many of the pieces are
;;;; also called directly.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;Table for FIXF.  Either load d.p. float into W2 and return
;or do the FIXF ourselves.  (RET if already integer)
;;TY%IFL
fxftab:	dmove w2,1(o1)		; long flonum ;;TY%FLO
	call gtrifl		; neg iflons
	call gtrifl		; pos iflons
	jrst fxfrat		; ratios
	jrst notnum		; complex (unimplemented)
	iret			; bignum
	iret			; neg inums
	iret			; pos inums

fixf:	skpnum o1
	 jrst notnum
	xtype o1
	xct fxftab-ty%xfl(w2)
;we can handle this the easy way if what is in W2 is precise.  If
;any significant digits are in w3, then we have to do it the hard
;way.  the magic number below is 777,,777777.
fixf02:	camg w2,[134217727.0]	;   called from ratio
	camge w2,[-134217727.0]
	jrst truncb		;use bignum code
	fix o1,w2
	maknum o1		;always an INUM
	iret

fxfrat:	doboth o1,o1		;get two pieces of ratio
	jrst iquot		;truncating divide

;note - the code below really does floor, so we have to
;treat negatives specially to get truncate.
truncb:	jumpge w2,trncbx	;if nonneg, ok
	dmovn w2,w2		;make positive
	call trncbx		;truncate
	jrst minus		;make negative again

trncbx:	ldb w4,[.bp <777000,,0>,w2] ;get exponent field
	tlz w2,377000		;now clear the exponent (but not sign)
	tlne w2,400000		;if neg
	tlo w2,777000		;propagate sign
	trne w4,400		;if neg
	trc w4,777		;have to complement exponent
	subi w4,200+62.		;-200 to get actual exp, 62 to shift beyond .
	jumpe w4,retint		; return directly if shift is 0
	maknum w4		;make arg for lsh
	move o2,w4
	dmovem w2,work+1	;put the actual number in an ersatz bignum
	move o1,[object ty%spc,2]
	movem o1,work
	move o1,[object ty%cbg,<codsec,,work>] ;pointer to bignum
	jrst lshf

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Various utility routines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;TY%INT
;;TY%BIG
;Lisp object in O1.  Returns integer value in w2
get1nt:	skpnin o1		;;TY%NUM  --inums are last
	 jrst getin1
	caml o1,[object ty%big,0] ;;TY%NUM --bignums are next
	 jrst getin2
gtiner:	err1 o1,/Must be an integer: ~S/
;small integer
getin1:	move w2,o1
	getnum w2
	iret
;bignum -- we want the 1 bits out of 000000,,000001 ? 377777,,777777
getin2:	dmove w2,1(o1)
	lsh w3,1		;  000000,,000001 ? 777777,,777776
	lshc w2,35.		;  777777,,777777 ? 000000,,000000
	iret

;;TY%INT
;;TY%BIG
ret1nt:	ashc w2,-35.		;make a 2-wd quantity out of it
;return 2wd integer, in w2/3, as lisp object in o1
retint:	aoje w2,retinn		;[Victor] if high part is -1
	sojn w2,retbig		;[Victor] if high part isn't 0
	ldb w4,[.bp 37_31.,w3]	;[Victor]
	jumpn w4,retbig		;[Victor] if positive but > inum
;here to return inum		;[Victor]
retinu:	move o1,w3		;[Victor]
	maknum o1		;[Victor]
	ret1			;[Victor] 
				;[Victor] 
retinn:	ldb w4,[.bp 37_31.,w3]	;[Victor]
	cain w4,37		;[Victor]
	 jrst retinu		;[Victor] if negative
	subi w2,1		;[Victor] restore high part
;;[Victor] commented away
;	dmovem w2,w4		;save it in an odd place
;	jfcl 17,.+1
;	ashc w2,39.		;see if more than 31 significant bits
;	jov retbw4		;there were, so make a bignum
;	maknum o1		;"just happens" to be in the right place
;	ret1
;
;retbw4:	dmove w2,w4		;get it back

retbig:	push free,[object(ty%spc,2)] ;a small (2-wd) bignum
	move w4,free		;make pointer be right type
	tlo w4,(object(ty%big,0))
	move o1,w4		;and return that
	dmovem w2,1(free)
	addi free,2
	camle free,lastl	;see if need GC
	 call sgc
	ret1			;that's all

;;TY%BIG
;make a new bignum.  take the size in w4, return size/2 in w4,
; object ptr in o1
bigmak:	tlo w4,(<object(ty%spc,0)>)	;make gc skip wd
	push free,w4		;invalid gc state starts here
	move o1,free		;	 ...
	tlo o1,(object(ty%big,0))	;...
	tlz w4,(<object(ty%spc,0)>)	;...
	add free,w4		;... and ends here
	lsh w4,-1		;leave # of doublewords
	camle free,lastl	;see if need GC
	 call sgc
	iret			;that's all

;BIGM36 is like bigmak, but registers o3 to o6 have non-lisp stuff
bigm36:	tlo w4,(<object(ty%spc,0)>)	;make gc skip wd
	push free,w4		;invalid gc state starts here
	move o1,free		;	 ...
	tlo o1,(object(ty%big,0))	;...
	tlz w4,(<object(ty%spc,0)>)	;...
	add free,w4		;... and ends here
	lsh w4,-1		;leave # of doublewords
	camg free,lastl		;see if need GC
	 iret
	push p,o3
	push p,o4
	push p,o5
	push p,o6
	setzb o3,o4
	setzb o5,o6
	caml free,lastl		;[Victor] Because of SGC's stupidness,
				;[Victor] returning at -1 to repeat the test
	call sgc
	pop p,o6
	pop p,o5
	pop p,o4
	pop p,o3
	iret

	.vector work(7),work2(3) ;temps for representation changes

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; INTEGER-DECODE-FLOAT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; TY%IFL
;return values: mantissa as integer, exponent, sign
idecfl:	call getrea	;float now in w2,w3
	jumpl w2,idecln	
	push q,[inum 1]
ideclp:	ldb w4,[.bp 777_27.,w2] ;get exponent and sign
	subi w4,200+27.	;exp is excess-200
	tlnn o1,060000	;skip if single float
	subi w4,35.	;if double, we have more bits
	maknum w4	;make good lisp object
	push q,w4
	tlz w2,777000	;strip exponent and sign
	tlne o1,060000	;skip if long float
	 ashc w2,-35.	;for single, just use the one word
	call retint
	pop q,o2	;expon
	pop q,o3	;sign
	ret3

idecln:	dmovn w2,w2
	push q,[inum -1]
	jrst ideclp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; DECODE-FLOAT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;return as MV's: mantissa, expt, and sign
decflt:	call getrea	;float now in w2,w3
	jumpl w2,decfln	;process as positive
;here for non-negative
	move o2,[iflon 1.0] ;assume small
	tlnn o1,060000	;skip if it is
	move o2,[%FLONE] ;use long float one
	push q,o2	;non-neg, so this is the sign
decflp:	ldb w4,[.bp 777_27.,w2] ;get exponent and sign
	subi w4,200	;exp is excess-200
	maknum w4	;make good lisp object
	push q,w4
;now do the significand
	tlz w2,377000	;strip exponent
	tlo w2,200000	;put back base exponent
	tlnn o1,060000	;skip if single float
	 jrst [call retflo ? jrst .+2]
	 call retif
	pop q,o2	;expon
	pop q,o3	;sign
	ret3

;here for negative number
decfln:	dmovn w2,w2
	move o2,[iflon -1.0] ;assume short
	tlnn o1,060000	;skip if it is
	move o2,[%FLNONE] ;use long float -one
	push q,o2
	jrst decflp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; SCALE-FLOAT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;TY%IFL
;;; SCALE-FLOAT float1 int2, build a float
sclflt:	exch o1,o2
	call get1nt	;make the exponent into a bare number
	move w4,w2
	move o1,o2
	call getrea	;float is now in w2/w3
	jfcl 17,.+1
	fsc w2,(w4)
	jov [err /Exponent too large in SCALE-FLOAT/]
	tlnn o1,060000	;skip if result is a short float
	 jrst retflo
	 jrst retif

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; FLOAT-RADIX
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; FLOAT-RADIX, is always 2 for our implementation
fltrad:	move o1,[inum 2]
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; FLOAT-SIGN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;TY%IFL
;;; FLOAT-SIGN float1 float2, returns float2 with sign of float1.
fltsgn:	move o2,[iflon 1.0] ;default for arg 2
	call getrea	;make float1 into bare number
	move w4,w2	;get sign part of float1 into w4
	move o1,o2
	call getrea	;make float2 into a bare number
	xor w4,w2	;compare signs
	tlnn w4,400000
	 jrst .+4
	dmovn w2,w2	;if dissimilar, negate
	skipge w2	; be careful with top bit of second word
	tlo w3,400000
	tlnn o1,060000	;skip if result is a short float
	 jrst retflo
	 jrst retif

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;  GENERIC ARITHMETIC
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


; Generic arithmetic functions.  These functions handle mixed args
; of types inum, bignum, ratio, iflon, long float.
; The types are given in reverse coercion precedence order, ie, 
; with two args of different types, the one occurring earlier in
; the list will be converted to the type occurring later in the list.
; The main table used (by all functions) is DOPTAB.  The DOPTAB 
; entry corresponding to the xtype of the second argument is 
; executed, with a copy of the 2nd arg in w3.  If the second arg
; is an inum, w3 is converted to a machine integer in place and 
; the next instruction is skipped;  the first argument isn't even 
; looked at.  If the second arg is not an inum, both args are looked
; at, and converted according to the following table; no skip occurs.
;
;   if either arg is     and other is	other is converted; args left in
;	long flonum	any other type		o1, o2 as lisp objects
;	immed flonum	any except long		o1, w3 as machine flonums
;	ratio		any non-flonum		o1, o2 as lisp objects
;	bignum		any integer		o1, o2 as lisp objects
;
; w2 is left with the xtype of the type converted to.  Lflon, ratio,
; and bignum are converted to by placing data in the area WORK and
; a pointer to WORK in the appropriate register.


;;TYPES
;;TY%INT
doptab:	repeat 8,jrst notnm2	;atoms, etc
	jsp w4,dopa2l		;long flon
	jsp w4,dopa2f		;iflon
	jsp w4,dopa2f		;iflon
	jsp w4,dopa2r		;ratio
	jrst notnm2		;complex
	jsp w4,dopa2b		;bignum
	tloa w3,760000		;neg inum
	tlza w3,760000		;pos inum

; special macro for secondary type tables. leave xtype of o1 in w2,
; dispatching off an xnmtyp table to begin right after the macro.
define a1disp
	skpnum o1
	 jrst notnum
	xtype o1
	xct .+1-ty%xfl(w2)  termin
	
;arg 2 is long flon, convert arg 1 to long flon
dopa2l:	a1disp			;;TYPES
	jrst (w4)		;long flon
	jrst a2la1f		;iflon
	jrst a2la1f		;iflon
	jrst a2la1r		;ratio
	jrst notnum		;complex
	jrst a2la1b		;bignum
	jrst a2l1ni		;neg int
	jrst a2l1pi		;pos int

;;TY%INT
;;TY%FLO
a2l1ni:	tloa o1,760000
a2l1pi:	 tlz o1,760000
	fltr o1,o1
	jrst sto1lf

;;TY%IFL
;;TY%FLO
a2la1f:	lsh o1,4
sto1lf:	movem o1,work+1
	setzm work+2
	move o1,[object ty%spc,2]
	movem o1,work
	move o1,[object ty%cfl,<codsec,,work>]
	movei w2,ty%xfl
	jrst (w4)

; arg 1 is bignum, cnvt to long flon w/ std routine
a2la1b:	push p,w4
	pushj p,cnvb2l
	movei w2,ty%xfl
	iret

; 1st arg is a ratio, convert to long flon with std routine
a2la1r:	push p,w4
	pushj p,cnvr2l
	movei w2,ty%xfl
	iret

;arg 2 is iflon, cnvt other unless long, when cnvt a2 to long
dopa2f:	lsh w3,4		;arg 2 => machine flonum in w3
	a1disp			;;TYPES
	jrst a2fa1l		;long flon
	jrst a2fa1f		;iflon
	jrst a2fa1f		;iflon
	jrst a2fa1r		;ratio
	jrst notnum		;complex
	jrst a2fa1b		;bignum
	jrst a2f1ni		;neg int
	jrst a2f1pi		;pos int

;;WORK
; rat ==> long float  (they do this to leave sinking ships)
cnvr2l:	pushcar q,o1		;save numerator
	docdr o1,o1		;get denominator
	push q,o1		;save denom
;Ratios tend to have very big bignums.  First we truncate any bits
;we aren't going to be able to use.  If either number is bigger
;than we can represent as a real, but cut it down to size, remembering
;the adjustment factor.  At the end we will put the adjustments back.
	call intlen		;length of denom
	camg o1,[inum 177]	;too big for flonum?
	 jrst [push q,[inum 0]	;no, adjust by zero
	       jrst cvr2l1]
	subi o1,177		;by how much is it too big?
	push q,o1		;STACK: num; denom; denom adj
	movn o2,o1		;negate adjustment factor
	tlc o2,740000		;fix type code
	move o1,-1(q)		;get back the thing
	call lshf		;truncate it by shifting
	movem o1,-1(q)		;and put it back
cvr2l1:	move o1,-2(q)		;now the same game for the numerator
	call intlen		;length of denom
	camg o1,[inum 177]	;too big for flonum?
	 jrst [push q,[inum 0]	;no, adjust by zero
	       jrst cvr2l2]
	subi o1,177		;by how much is it too big?
	push q,o1		;STACK: num; denom; denom adj; num adj
	movn o2,o1		;negate adjustment factor
	tlc o2,740000		;fix type code
	move o1,-3(q)		;get back the thing
	call lshf		;truncate it by shifting
	movem o1,-3(q)		;and put it back
;now we are ready to divide the cut-down numbers
cvr2l2:	move o1,-2(q)		;get denom
	call getrea		;==> dflon in w2,3
	push p,w2
	push p,w3
	move o1,-3(q)		;now numerator
	call getrea
	jfcl 17,.+1
	dfdv w2,-1(p)		;do division for real
	jov ovrflo
	subi p,2		;discard
;now we adjust for the bits we removed
	move w4,(q)		;compute adjustment
	sub w4,-1(q)
	fsc w2,(w4)		;and scale result
	jov ovrflo
	subi q,4		;kill saved junk
	jrst w232l

;convert rat to short float
;; NB: does wierdness: saves w3; returns arg as machine float in o1
cnvr2f:	push p,w3		;this is the other arg in some arith rtns
	call cnvr2l		;the easy way: make a long float
	move o1,work+1		;get significant word
	fmpr o1,[201400,,4]	;round it
	trz o1,17
	pop p,w3		;restore other arg
	iret

;;TY%IFL
;;TY%FLO
a2fa1l:
sto2fl:	movem w3,work+1		;here with 1-wd flon in w3
	setzm work+2
	move o2,[object ty%spc,2]
	movem o2,work
	move o2,[object ty%cfl,<codsec,,work>]
	jrst (w4)

;;TY%IFL
a2fa1f:	lsh o1,4
	jrst (w4)

; arg 1 is bignum, cnvt to iflon w/ std routine
a2fa1b:	push p,w4
	pushj p,cnvb2f
	movei w2,ty%xif
	iret

; 1st arg is a ratio, convert to iflon with std routine
a2fa1r:	push p,w4
	pushj p,cnvr2f
	movei w2,ty%xif
	iret

;;TY%INT
;;TY%IFL
a2f1ni:	tloa o1,760000
a2f1pi:	 tlz o1,760000
	fltr o1,o1
	movei w2,ty%xif
	jrst (w4)

;2nd arg a ratio, make it a float if other is or make other a ratio
dopa2r:	a1disp			;;TYPES
	jrst a2ra1l		;a long flon
	jrst a2ra1f		;iflon
	jrst a2ra1f		;iflon
	jrst (w4)		;ratio
	jrst notnum		;complex
	jrst a2ra1i		;bignum
	jrst a2ra1i		;neg int
	jrst a2ra1i		;pos int

a2ra1l:	push p,w4
	exch o1,o2
	pushj p,cnvr2l
	exch o1,o2
	movei w2,ty%xfl
	iret

a2ra1f:	push p,w4
	exch o1,o2
	pushj p,cnvr2f
	move w3,o1
	lshc o1,36.+4
	movei w2,ty%xif
	iret

a2ra1i:	movem o1,work
	move o1,[inum 1]
	movem o1,work+1
	move o1,[object ty%crt,<codsec,,work>]
	movei w2,ty%xrt
	jrst (w4)

;2nd arg a bignum, make float or rat if other is or make other a bignum
dopa2b:	a1disp			;;TYPES
	jrst a2ba1l		;a long flon
	jrst a2ba1f		;iflon
	jrst a2ba1f		;iflon
	jrst a2ba1r		;ratio
	jrst notnum		;complex
	jrst (w4)		;bignum
	jrst a2b1ni		;neg int
	jrst a2b1pi		;pos int

a2ba1l:	push p,w4
	exch o1,o2
	pushj p,cnvb2l
	exch o1,o2
	movei w2,ty%xfl
	iret

a2ba1f:	push p,w4
	exch o1,o2
	pushj p,cnvb2f
	move w3,o1
	lshc o1,36.+4
	movei w2,ty%xif
	iret

a2ia1r:
a2ba1r:	movem o2,work
	move o2,[inum 1]
	movem o2,work+1
	move o2,[object ty%crt,<codsec,,work>]
	jrst (w4)

;;TY%INT
;;TY%BIG
a2b1ni:	tloa o1,760000		;arg one was a neg inum...
a2b1pi:	 tlz o1,760000		;... or a pos inum...
	movem o1,work+2		;make it into a 2-wd bignum
	ash o1,-35.
	movem o1,work+1
	move o1,[object ty%spc,2]
	movem o1,work
	move o1,[object ty%cbg,<codsec,,work>]
	movei w2,ty%xbg
	jrst (w4)

;;TYPES    arg two was int, but result not right. either oflo or 
; other arg wrong type.  
a2itab:	repeat 8, jrst notnum	;atoms and stuff
	jsp w4,a2ia1l		;long flon
	jsp w4,a2ia1f		;iflon
	jsp w4,a2ia1f		;iflon
	jsp w4,a2ia1r		;ratio
	jrst notnum		;complex
	jsp w4,a2ia1b		;bignum
	tlo o1,760000		;;TY%INT    - inums
	tlz o1,760000		;positive same


a2ia1l:	fltr w3,w3
	jrst sto2fl

;;TY%IFL
a2ia1f:	fltr w3,w3
	lsh o1,4
	jrst (w4)

;;TY%BIG
;-- other arg was a bignum already
a2ia1b:	move w2,w3		;smallest bignum is 2 words
	ashc w2,-35.
	dmovem w2,work+1
	move o2,[object ty%spc,2]
	movem o2,work	;save it in this fixed area
	move o2,[object ty%cbg,<codsec,,work>]
	movei w2,ty%xbg
	jrst (w4)

divzro:	err /Divide by zero/	;[Victor] Give up

ovrflo:	err /Floating overflow/

notnm2:	move o1,o2
notnum:	err1 o1,/Argument to a numerical function is not a number/

retzer:	move o1,[inum 0]
	setz nil1,
	ret1

;;;;;;;;;;;;; MULARn are used to do binary operations with more than one input

mular3:	push q,o3
	call @(p)		;do 1 and 2
	pop q,o2		;now 3
	pop p,w2
	jrst (w2)

mular4:	push q,o3
	push q,o4
	call @(p)		;do 1 and 2
	pop q,o2		;now 3
	call @(p)
	pop q,o2		;now 4
	pop p,w2
	jrst (w2)

mular5:	push q,o3
	push q,o4
	push q,o5
	call @(p)		;do 1 and 2
	pop q,o2		;now 3
	call @(p)
	pop q,o2		;now 4
	call @(p)
	pop q,o2		;now 5
	pop p,w2
	jrst (w2)

mularn:	push q,o2
	push q,o3
	push q,o4
	push q,o5
	subi n,1		;N = number of operations
	push p,n
mularl:	pop q,o2
	call @-1(p)
	sosle (p)
	jrst mularl
	subi p,2
	ret1	

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; +
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

eplus:	jrst retzer		;0 args: 0
	jrst ret1v		;one arg: itself
	jrst plus		;2: normal binary
	jrst [push p,[<codsec,,plus>] ? jrst mular3]
	jrst [push p,[<codsec,,plus>] ? jrst mular4]
	jrst [push p,[<codsec,,plus>] ? jrst mular5]
	jrst [push p,[<codsec,,plus>] ? jrst mularn]
plus:	move w3,o2		;here for binary
	movei n,1		;returns 1 result
	xtype o2		;what's second arg?
	xct doptab(w2)		;above, qv
	 jrst xplus
	skpin o1		;make sure first arg is inum
	 jrst plusx
	add o1,w3		;this is what we came for...
	skpnin o1		;will be neg if oflo
	 retn
	sub o1,w3		;woops
plusx:	xtype o1
	xct a2itab(w2)
xplus:	xct .+1-ty%xfl(w2)	;;TYPES
	jrst xplflo		;long flons
	jrst xplifl		;iflons
	jrst xplifl		;iflons
	jrst xplrat		;ratios
	jrst notnum		;complex
	jrst xplbig		;bignums
	jrst xplinu		;inums 
	jrst xplinu		;inums

;;TY%FLO
xplflo:	dmove w2,1(o1)
	dfad w2,1(o2)
;return long flon found in w2 and w3
retflo:	push free,[object(ty%spc,2)] ;now make real number object
	move w4,free		;make pointer be right type
	tlo w4,(object(ty%flo,0))
	move o1,w4		;and return that
	push free,w2
	push free,w3
	camle free,lastl	;see if need GC
	 call sgc
	ret1			;set # vals, lots of people call this

;;TY%IFL
xplifl:	fadr o1,w3		;do the addition
retifl:	makifl o1		;make into iflon object
	ret1			;set # vals, lots of people call this

; add two rats (and get a fink?)
;	a     c            ad + bc
;      --- + ---    =     ---------
;	b     d               bd

xplrat:	pushcar q,o1		;a
	pushcdr q,o1		;b
	pushcar q,o2		;c
	pushcdr q,o2		;d
	docdr o1,o1		;b
	docdr o2,o2		;d
	call times		;bd
	exch o1,-3(q)		;a
	pop q,o2		;d
	call times		;ad
	exch o1,-1(q)		;b
	pop q,o2		;c
	call times		;bc
	pop q,o2		;ad
	call plus		;ad+bc
	pop q,o2		;bd
	jrst rat

;;TY%BIG		add two bignums
xplbig:	move o3,o1		;save o1
	getsiz w3,o1		;find out how big they are
	getsiz w4,o2
	came w4,w3		;same size?
	 jrst xplbds		; no, use general routine
	caie w3,2		;yes: 2 words perchance
	 jrst  xplb2		; no...
	jfcl 17,.+1		;yes, all is very simple (& fast)
	dmove w2,1(o2)
	dadd w2,1(o3)
	jov w2oflo		;see if was more than 2-wd result
	jrst retint

;args same size but >2 wds.  slight simplification.
xplb2:	call bigmak		; answ that size too
	push p,0		;this is the size difference
	jrst xplbx0

xplbds:	camg w3,w4		;which is bigger?
	 jrst .+3
	  exch w3,w4		;put bigger size on w4
	  exch o2,o3		;put bigger ob in o2
	lsh w3,-1		;smaller size ==> #/dw's
	push p,w3
	call bigmak		;result gets size of larger
	sub w4,(p)		;difference in sizes
	exch w4,(p)		;use smaller for count, save diff
xplbx0:	move o4,o1		;result area, use as traveling ptr
	jrst xplbx2		;no carry into right end

;;the structure of the loops is wierd to preserve carry/oflo info.
;;sojx ruins the carry bits (but not overflow).
;;thus jcry's must be done before sojx's, but sojx's must be done
;;to see if an overflow test is warranted.
;;first loop is for adding digits where the numbers coincide;
;;second is to propagate the carry along the "overhang" of the
;;larger number.
;;All but the last pair are done as unsigned 70-bit numbers.
;;Thus the only thing to look at is Carry 1 (carry into the sign
;;bit).  The last pair is a signed 71-bit number.  Since it is
;;treated as signed, carries are handled automatically.  In this
;;case, the only case where we need to do something special is
;;when overflow is set, since that means that the current pair
;;of words is not big enough to contain the result.  The handling
;;of that overflow is explained at BMOFLO.  Bascially we just
;;create another doubleword to handle the overflow.  This means that
;;the last one becomes internal and we now ignore its sign bits.
xplbx1:	soje w4,xplbx3		;here if carry from previous digit
	dmove w2,[0 ? 1]
	skipa
xplbx2:	 setzb w2,w3		;here if no carry
	jfcl 17,.+1
	dadd w2,1(o2)		;add to carry bit
ifn 0,[	skipl 1(o3)		;[Victor]
	 tloa w2,400000		;[Victor]
	  tlz w2,400000		;[Victor] this sequence prevents oflo
] ;ifn 0
	dadd w2,1(o3)		;add to other digit
	dmovem w2,1(o4)		;stash
	addi o2,2		;advance pointers
	addi o3,2
	addi o4,2
	jcry1 xplbx1		;was there a carry this time?
	sojg w4,xplbx2		;no, are we out of digits
	skipa w3,[0]		;yes-- but remember there was no carry
xplbx3:	 movei w3,1		;out of digits with a carry, from above
	pop p,w4		;difference count
	jumpe w4,xplbx9		;if #'s same size, that was it!
	move w2,-1(o3)		;else extend sign of short one
	ash w2,-35.
	movem w2,work+3		;at +3 in case an arg occupies +0, 1, & 2!
	movem w2,work+4
	jrst xplbx6		;otherwise save carry status

xplbx4:	skipa w3,[1]		;here if carry
xplbx5:	 setz w3,		;here if no carry
	soje w4,xplbx9		;see if more digits
xplbx6:	setz w2,		;here if carry wd in w3 already
	jfcl 17,.+1
	dadd w2,1(o2)		;add carry to digit
	dadd w2,work+3		;and sign from short number
	dmovem w2,1(o4)		;stash
	addi o2,2		;bump pointers
	addi o4,2
	jcry1 xplbx4		;more carry?
	jrst xplbx5		;no carry
;here when out of digits.  W3 is set to carry from last word.
;normally this is not relevant, but if there was an overflow,
;then it is.
xplbx9:	jov bmofl3		;see if there was an overflow
	setzb o2,o3		;yes: clean up
	setz o4,

	;falls through
;;trim a bignum so that it occupies no more doublewords
;;than necessary to hold it.  in the extreme case, make an
;;inum.  enter w/ bignum in o1, exit with same (or inum in o1)
;;remember that unless we hack o1, we're merely returning the argument.
bgtrim:	getsiz w4,o1		;find the high-order end
	add w4,o1
	soj w4,			;adjust so that w4=o1 when we
bgt01:	soj w4,			; have just one doublewd left
	dmove w2,1(w4)		;get hi-order dw
	camn w4,o1		;was it also the low-order dw?
	 jrst bgtr2w		; yes, special case
ifn 0,[	xor w3,w2		;[Victor] nope; is it 0 or -1?
	jumpn w3,bgtr2x		;[Victor] no
	came w2,[-1]		;[Victor]
	jumpn w2,bgtr2x		;[Victor] also no
] ; ifn 0
;;[Victor] commented away (old code)
ife 0,[	jfcl 17,.+1		;nope: is it 0 or -1?
	ashc w2,70.
	jov [ret1]		;no.
	rot w2,1		;move the sign down to the next dw
] ; ife 0
	dpb w2,[.bp (400000),-1(w4)]
	setzm 1(w4)
	setzm 2(w4)
	sos (o1)
	sos (o1)
	soja w4,bgt01

;;only 2 words left, may be an inum
bgtr2w:
ifn 0,[	aoje w2,bgtr2n		;[Victor] if neg
	sojn w2,bgtr2x		;[Victor] if pos, non-inum
	tlne w3,(object ty%lpi,0)	;[Victor]
	 jrst bgtr2x		;[Victor] if not inum
bgtr2u:	move o1,w3		;[Victor]
	maknum o1		;[Victor]
bgtr2x:	ret1			;[Victor] 

bgtr2n:	tlc w3,(object ty%lpi,0)	;[Victor]
	 tlcn w3,(object ty%lpi,0)	;[Victor]
	  jrst bgtr2u		;[Victor]
	ret1			;[Victor] 
] ; ifn 0
;;[Victor] replaced by above (below old code)
ife 0,[	jfcl 17,.+1		;more than 31 significant bits?
	ashc w2,39.
	jov [ret1]		;yes, leave it as is
	ash w2,-4		;no, make it an inum
	maknum w2
	move o1,w2
	ret1
] ; ife 0
;;here w/ 2-wd result in o2/3 that overflowed
w2oflo:	call retbig
	;falls through
;;generalized overflow for bignum operations routine
;;come here with left wd of last op in w2, result obj in o1
;;result must have been the last thing consed
bmoflo:	aos (o1)		;extend length counter
	aos (o1)		; :: In an overflow, sign bit
	dmove w3,[0 ? 1]	; is wrong sign but correct magnitude
	skipl w2
	 dmove w3,[-1 ? -2]
	dmovem w3,1(free)	;needs smartening for interrupts
	addi free,2
	camle free,lastl	;see if need GC
	 call sgc
	ret1			;that's all

;This handles overflow on addition.  BMOFL3 assumes
;that the carry (from Carry 1) is in W3.  Since we are now going
;to need another doubleword, we now consider that the last
;addition was for an interior pair.  This means that we ignore
;the sign bits of the results and use carry 1.  We now compute a
;new high-order doubleword, adding together the carry, and the
;high-order pieces of the two summands.  However since the summands
;have both run out, this is particularly easy.  We are just dealing
;with 0 or -1, i.e. simple sign-extensions of the arguments.
;We can't possibly overflow from here, since we can handle any
;possible sum of three numbers taken from -1, 0, and 1.  If the
;result is 0 or -1, we don't really need to extend the number,
;since this will just be a sign-extension.  So we put the right
;sign back into the high-order end of the result.

bmofl3:	move w2,-1(o3)		;sign-extend the two summands
	ash w2,-35.
	add w3,w2		;and add them in
	move w2,-1(o2)		;other summand
	ash w2,-35.
	add w3,w2		;add it in
;subtract code joins here
bmof3x:	ldb w4,[.bp 1_35.,w3]	;get the sign bit
	dpb w4,[.bp 1_35.,-1(o4)] ;put it in previous result
	setzb o2,o3		;clear junk pointers
	setz o4,
	skipe w3		;now stop if no need to extend
	 camn w3,[-1]
	  jrst bgtrim
;use W3 as new high-order pair
	aos (o1)		;extend length counter
	aos (o1)
	move w2,w3		;make double precision
	ash w2,-35.		;make this pure sign extension
	dmovem w2,1(free)	;needs smartening for interrupts
	addi free,2
	camle free,lastl	;see if need GC
	 call sgc
	ret1

xplinu:	add w3,o1		;not inum but still 1 word
	move w2,w3
	ashc w2,-35.		;but return 2-wd bignum anyway
	jrst retbig

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; -
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

ediff:	jrst minus		;one arg: negate
	jrst diff		;2: normal binary
	jrst [push p,[<codsec,,diff>] ? jrst mular3]
	jrst [push p,[<codsec,,diff>] ? jrst mular4]
	jrst [push p,[<codsec,,diff>] ? jrst mular5]
	jrst [push p,[<codsec,,diff>] ? jrst mularn]
diff:	move w3,o2
	movei n,1		;returns 1 result
	xtype o2		;what's 2nd arg?
	xct doptab(w2)		;above, qv
	 jrst xdiff
	skpin o1		;make sure first arg is inum
	 jrst diffx		;no
	sub o1,w3		;this is what we came for...
	skpnin o1		;will be neg if oflo
	 retn
	add o1,w3		;woops
diffx:	xtype o1
	xct a2itab(w2)
xdiff:	xct .+1-ty%xfl(w2)	;;TYPES
	jrst xdfflo		;long flons
	jrst xdfifl		;iflons
	jrst xdfifl		;iflons
	jrst xdfrat		;ratios
	jrst notnum		;complex
	jrst xdfbig		;bignums
	jrst xdfinu		;inums
	jrst xdfinu		;inums

;;TY%FLO
xdfflo:	dmove w2,1(o1)
	dfsb w2,1(o2)
	jrst retflo

;;TY%IFL
xdfifl:	fsbr o1,w3		;do the subtraction
	jrst retifl

; subtract two rats (and get a mouse?)
;	a     c            ad - bc
;      --- - ---    =     ---------
;	b     d               bd

xdfrat:	pushcar q,o1		;a
	pushcdr q,o1		;b
	pushcar q,o2		;c
	pushcdr q,o2		;d
	docdr o1,o1		;b
	docdr o2,o2		;d
	call times		;bd
	exch o1,-3(q)		;a
	pop q,o2		;d
	call times		;ad
	exch o1,-1(q)		;b
	pop q,o2		;c
	call times		;bc
	pop q,o2		;ad
	exch o1,o2
	call diff		;ad-bc
	pop q,o2		;bd
	jrst rat


;;TY%BIG		subtract bignums
xdfbig:	move o3,o1		;save o1
	getsiz w3,o1		;find out how big they are
	getsiz w4,o2
	came w4,w3		;same size?
	 jrst xdfbds		;no, use general routine
	caie w3,2		;yes: 2 words perchance
	 jrst  xdfb2		; no...
	jfcl 17,.+1		;yes, all is very simple (& fast)
	dmove w2,1(o3)		;o3 is the minuend
	dsub w2,1(o2)		;o2 is the subtrahend
	jov w2oflo		;see if was more than 2-wd result
	jrst retint

;args same size but >2 wds.  slight simplification.
xdfb2:	call bigmak		;answ will be the same size
	setz o5,		;this is the which-bigger flag
	push p,0		;this is the size difference
	jrst xdfbx0

xdfbds:	setz o5,		;o5=0 ==> o2 is longer
	camg w3,w4		;which is bigger?
	 jrst .+3
	  exch w3,w4		;put bigger size on w4
	  seto o5,		;can't switch args, use flag
	lsh w3,-1		;smaller size ==> #/dw's
	push p,w3
	call bigmak		;result gets size of larger
	sub w4,(p)		;difference in sizes
	exch w4,(p)		;use smaller for count, save diff
xdfbx0:	move o4,o1		;result area, use as traveling ptr
	jrst xdfbx1+1		;no borrow from right end

;;the structure of the loops is wierd to preserve carry/oflo info.
;;sojx ruins the carry bits (but not overflow).
;;thus jcry's must be done before sojx's, but sojx's must be done
;;to see if an overflow test is warranted.

;;In principle we should be able to get this to work using
;;DSUB.  However neither Josh nor Hedrick have been able to do
;;so.  Thus I am going to do it the long but safe way:  negate
;;the second number explicitly be doing ones complement and 
;;adding one.  We start at XDFBX1+1, to do the add one.

;;The first loop is for adding digits where the numbers coincide;
;;second is to propagate borrowing along the "overhang" or
;;"underhang" of the larger number.

xdfbx1:	 soje w4,xdfbx3		;here if carry
	skipa nil1,[1]		;set up carry
xdfbx2:	setz nil1,		;clear carry
	jfcl 17,.+1		;clear all bits
	setcm w2,1(o2)		;negate the second number
	setcm w3,2(o2)
	dadd w2,nil		;add in carry
ifn 0,[	skipl 1(o3)		;[Victor]
	 tloa w2,400000		;[Victor]
	  tlz w2,400000		;[Victor] this sequence prevents oflo
] ; ifn 0
	dadd w2,1(o3)		;add to subtrahend
	dmovem w2,1(o4)		;stash
	addi o2,2		;advance pointers
	addi o3,2
	addi o4,2
	jcry1 xdfbx1		;was there a carry this time?
	sojg w4,xdfbx2		;no, are we out of digits
	skipa nil1,[0]		;yes-- and remember there was no carry
xdfbx3:	 movei nil1,1		;out of digits with carry, from above
	pop p,w4		;difference count
	jumpe w4,xdfbx9		;if #'s same size, that was it!
	skipn o5		;o5=0 ==> o2 is longer 
	 skipa w2,-1(o3)	; the subtrahend (ran out)
	  move w2,-1(o2)	;  the minuend (ran out)
	ash w2,-35.		;propagate the sign thereof
	movem w2,work+3		;at +3 in case an arg was at work+0!
	movem w2,work+4
	jrst xdfbx6		;otherwise save carry status

xdfbx4:	skipa nil1,[1]		;here if carry
xdfbx5:	 setz nil1,		;here if no carry
	soje w4,xdfbx9
xdfbx6:	jfcl 17,.+1		;here if carry wd in nil1 already
	jumpe o5,.+5		;o5=0 ==> o2 is longer
	 setcm w2,work+3	;sign of shorty
	 setcm w3,work+4
	 dadd w2,nil		;carry
	 dadd w2,1(o3)
	jumpn o5,.+5
	 setcm w2,1(o2)
	 setcm w3,2(o2)
	 dadd w2,nil		;carry
	 dadd w2,work+3		;sign of shorty
	dmovem w2,1(o4)		;stash
	addi o2,2		;bump pointers
	addi o3,2		;one is superfluous, but we don't know which
	addi o4,2
	jcry1 xdfbx4		;more carry?
	jrst xdfbx5		;no--out of digits?

xdfbx9:	jov bmofl1		;see if there was an overflow
	setzb o2,o3		;yes: clean up
	setzb o4,o5
	setz nil1,
	jrst bgtrim

;This handles overflow on subtraction.  See comments on BMOFL3.
;This expects carry to be in NIL1 and subtracts instead of
;adding.

bmofl1:	move w3,nil1		;get carry into reasonable AC
	setz nil1,		;and make this legal
	move w2,-1(o3)		;sign-extend the two summands
	ash w2,-35.
	add w3,w2		;add it in
	move w2,-1(o2)		;other one
	ash w2,-35.
	setcm w2,w2		;this one is to be subtracted
	add w3,w2		;add it in
	jrst bmof3x		;join addition code

xdfinu:	sub o1,w3		;both inums but result not
	move w2,o1
	ashc w2,-35.		;rtn smallest (2-wd) bignum
	jrst retbig


;;;;; MINUS doesn't really exist.  It is called from DIFF with one arg

;MINUS:
;we try to handle small integers quickly
minus:	xnmtyp o1		;right type?
	movei n,1		;returns 1 result
	movn o1,o1		;negate it
	xct minust(w2)		;yes if we don't jrst somewhere
	retn

;;TYPES
;table is in reverse order since type code negated above
minust:	jrst minusl		;long floats
	sub o1,[300000,,0]	;lo iflons
	sub o1,[300000,,0]	;hi iflons
	jrst minusr		;ratios
	jrst notnum		;complex (not implemented)
	jrst minusb		;bignums
	tlc o1,740000		;lo inums
	tlc o1,740000		;hi inums

;;TY%BIG
exnegb:	skipa o2,o1		;entry from absf etc.
minusb:	 movn o2,o1		;put it back, leave o1 free
	getsiz w4,o2		;new num of same size
	call bigmak		;ob in o1, size/2 in w4
	sojn w4,minuxb
	jfcl 17,.+1
	dmovn w2,1(o2)		;only one doublewd
	dmovem w2,1(o1)
	jov bmoflo		;check for -0
	jrst bgtr2w		;check it hasn't become an inum

;in 2s complement, we leave all low-order bits alone, along with the
;first 1 bit, then we complement all bits above that.  To do this will
;word instructions, we leave alone (or negate, it doesn't matter)
;low-order zero words, negate the first non-zero pair, and then 
;complement the words beyond that.
minuxb:	 move o3,o1		;general bignums
	dmove w2,1(o2)		;first loop until rightmost 1 bit found
	tlz w2,400000		;sign bit not used in low wds
	dmovnm w2,1(o3)		;negate the doubleword
	dadd o2,[2 ? 2]		;bump both pointers
	skipe -1(o3)		;keep going as long as it was zero
	 jrst minux2		;not zero, start flipping
	sojg w4,minuxb+1	;loop unless last doubleword
	jfcl 17,.+1		;this one has the real sign bit
	dmovn w2,1(o2)		;negate it
	dmovem w2,1(o3)
	setzb o2,o3		;clear these, now not objects
	jov bmoflo		;in case it was a multiple of -1x2^70
	jrst bgtrim		;in case it was a multiple of +1x2^70

;here after we have negated the first word.  Flip the rest
minux2:	dmovn w2,1(o2)		;doublewords beyond rightmost 1 bit
	dsub w2,[0 ? 1]		;merely flip all the bits
	dmovem w2,1(o3)
	dadd o2,[2 ? 2]		;bump the pointers
	sojg w4,minux2		;this *loop* includes the top dw
	setzb o2,o3		;not valid obs
	ret1			;the only shrink/expand cases were above

;;WORK
;; convert bignum to long float
cnvb2l:	push q,o1		;save bignum
	call intlen		;how many bits?
	posnum o1		;better be positive!
	cail o1,200		;test for num too big
	 jrst [pop q,o1 ? jrst ovrflo]
	push p,o1		;save that too
	move w2,o1		;how many bits in hi dw?
	idivi w2,70.
	jumpe w3,cbl02		;if 0 bits, that isn't really the high dw
cbl03:	movei w4,62.		;adjust for space taken by exponent
	sub w4,w3		;(this will be the "lsh factor")
	pop q,o1		;bignum again
	getsiz w2,o1		;how many words
	add o1,w2		;point to end
	push p,w2		;save # wds
	dmove w2,-1(o1)		;get hi dw
	ashc w2,(w4)		;who knows which way
	dmovem w2,work+1	;save
	pop p,w2		;# of wds again
	cain w2,2		;skip this next if only a 2-wd bignum
	 jrst cbl01
	dmove w2,-3(o1)		;also include bits from next-highest
	tlz w2,400000		;dw of bignum
	ashc w2,-70.(w4)	; -- in the right place
	dadd w2,work+1
	skipa
cbl01:	 dmove w2,work+1	;get number
	pop p,w4		;this was number of bits
	jfcl 17,.+1
	fsc w2,200(w4)		;put it in exponent
	jov ovrflo		;woops
w232l:	dmovem w2,work+1	;put back
	move o1,[object ty%spc,2]	;make an obj out of it
	movem o1,work
	move o1,[object ty%cfl,<codsec,,work>]
	iret

;here if IDIVI claims that there are no bits in the hi dw.  What has
;happened is that things came out even.  Instead of 3 dw's with the
;last having 0 bits, we want to claim that there are 2 dw's with the
;last one full.  Except of course if the number is 0...
cbl02:	jumpe w2,cbl03		;if zero, no adjustment
	movei w3,70.		;a full dw
	soja w2,cbl03		;but one fewer

;; convert bignum to iflon
;; NB: does wierdness: saves w3; returns arg as machine float in o1
cnvb2f:	push p,w3		;this is the other arg in some arith rtns
	call cnvb2l		;the easy way: make a long float
	move o1,work+1		;get significant word
	fmpr o1,[201400,,4]	;round it
	trz o1,17
	pop p,w3		;restore other arg
	iret

;;TY%RAT
minusr:	movn o1,o1		;was hacked in MINUS above
	pushcdr q,o1		;save denominator
	docar o1,o1
	call minus		;negate numerator
	pop q,o2
rltrat:				;rtn a ratio already in lowest terms
	push free,o1		; set up numerator
	move o1,free		; make address into ratio
	tlo o1,(object(ty%rat,0))
	push free,o2		; and denominator
	caml free,lastl		; make sure we have space 
	 call sgc		; garbage collect if no new cells
	ret1

minusl:	movn o1,o1
	dmovn w2,1(o1)		;lflon version - get number
	jrst retflo		;return the value

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; *
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

etimes:	jrst [move o1,[inum 1] ? ret1] ;0 args: 1
	jrst ret1v		;one arg: itself
	jrst times		;2: normal binary
	jrst [push p,[<codsec,,times>] ? jrst mular3]
	jrst [push p,[<codsec,,times>] ? jrst mular4]
	jrst [push p,[<codsec,,times>] ? jrst mular5]
	jrst [push p,[<codsec,,times>] ? jrst mularn]
;;TY%BIG		subtract bignums
times:	move w3,o2
	movei n,1		;returns 1 result
	xtype o2		;what's second arg?
	xct doptab(w2)		;above, qv
	 jrst xtimes
	xtype o1
	xct a2itab(w2)
xtimes:	xct .+1-ty%xfl(w2)	;;TYPES
	jrst xtiflo		;long flons
	jrst xtiifl		;iflons
	jrst xtiifl		;iflons
	jrst xtirat		;ratios
	jrst notnum		;complex
	jrst xtibig		;bignums
	jrst xtiinu		;inums
	jrst xtiinu		;inums

;;TY%FLO
xtiflo:	dmove w2,1(o1)		;double precision mult
	dfmp w2,1(o2)
	jrst retflo

;;TY%IFL
xtiifl:	fmpr o1,w3		;single prec mult
	jrst retifl

; multiply two rats (and get a ratsnest?)
;	a   c            ac
;      --- ---    =     ----
;	b   d            bd

xtirat:	pushcar q,o1
	docdr o1,o1
	pushcar q,o2
	docdr o2,o2
	call times
	exch o1,-1(q)
	pop q,o2
	call times
	pop q,o2
	jrst rat

;;TY%BIG      multiply bignums
xtibig:	move o3,o1		;save o1
	getsiz w3,o1		;find out how big they are
	getsiz w4,o2
	add w4,w3		;size of result
	caie w4,4		;both args 2wds by chance?
	 jrst  xtib2		; no...
	call bigmak
	jfcl 17,.+1		;yes, all is very simple (& fast)
	dmove nil1,1(o2)
	dmul nil1,1(o3)
	dmovem nil1,3(o1)
	dmovem w3,1(o1)
	move w2,nil1		;bmoflo expects this here
	setz nil1,		;and everybody else expects this here
	jov bmoflo		;oflo for the dmul
	jrst bgtrim		;on the other hand...

xtib2:	call bigmak		;alloc core for new number
	getsiz w2,o1		;its size
	sos w2			;less one
	move w3,o1
	aos w4,w3		;copy from first element
	aos w4			;...to second
	setzm (w3)		;fill it with zeroes
	xblt w2,
	push p,o1		;save: new number
	push p,o2		;multiplier
	push p,o3		;multiplicand
	move o1,o2		;clear the sign bits of the internal
	call zisbit		;(ie, nonsignificant) doublewords
	move o1,o3		;of both args
	call zisbit
	getsiz w4,o2		;form doubleword counts for both args
	lsh w4,-1		;for looping purposes
	push p,w4
	getsiz w4,o3
	lsh w4,-1
	push p,w4
	push p,0		;this will hold the carry
	push p,0
	move o2,-5(p)		;multiplier
	move o5,-6(p)		;product
;; the following is a double nested loop in four parts. 
;; essentially it merely loops across the multiplicand inside a loop
;; across the multiplier, multiplying the digits and adding up the results.
;; the inner loop body appears four times in different forms, however,
;; to avoid extraneous testing inside it.  the first incarnation is the
;; main case, for internal digits (doublewords) of both numbers. it does
;; positive carries only.  The other incarnations are for the most-
;; significant digits of one or the other number, which are distinguished
;; by having significant sign bits, and must do signed carries.  the last
;; incarnation is only done once: it handles the MSD's of both numbers,
;; and has to handle overflow as well.
	;falls in
	sosg -3(p)		;multiplier size counter
	 jrst xtiml5		;do n-1 times, skip if ctr is 1
xtiml0:	move o1,-4(p)		;multiplicand
	move o3,o5		;product
	move o4,-2(p)		;multiplicand size ctr
	setzb nil1,w2		;clear carry
	soje o4,xtiml1		;do n-1 times, skip if 1
xtimlp:	dmovem nil1,-1(p)	;save previous carry
	dmove nil1,1(o1)	;multiplicand loop
;According to a lemma in Knuth, the product plus the partial product digit
; plus the old carry must fit into two digits.  So we don't have to worry
; about carry out of the high-order digit.
;In this loop, all numbers are non-neg, so we can test for overflow easily.
	dmul nil1,1(o2)		;multiplier digit constant through this loop
	dadd w3,1(o3)		;add into partial prod
	tlze w3,400000		;check for carry (& keep PP sign bits clear)
	 jrst [dadd nil1,[0 ? 1] ? jrst .+1] ;propagate carry
	dadd w3,-1(p)		;carry in
	tlze w3,400000		;check for overflow here too
	 jrst [dadd nil1,[0 ? 1] ? jrst .+1] ;propagate carry
	dmovem w3,1(o3)		;9x9=81, that was the 1, this is the 8
	addi o1,2		;multiplicand digit
	addi o3,2		;partial product digit
	sojg o4,xtimlp		;counter
xtiml1:	dmovem nil1,-1(p)	;save previous carry
	dmove nil1,1(o1)	;last iteration for sign digit 
;a simple extension of Knuth's algorithm will show that the product plus
;the old partial product digit plus the carry will fit into two words
;this depends upon the fact that the digit from the multiplicand must
;be non-negative.  Note that the quad-word result is signed.  We
;actually save it in that form, since the high-order double-word will
;only be used the next time through this code.  The low-order double-word
;will be used in the loop above, so it must of course be regarded as
;non-negative.
	dmul nil1,1(o2)		; of multiplicand
ifn 0,[	skipl -1(p)		;[Victor]
	 jrst [	tlo w3,400000	;[Victor]
		dadd w3,-1(p)	;[Victor]
		tlzn w3,400000	;[Victor] 
		 dadd nil1,[0 ? 1]	;[Victor]
		jrst xtimc2 ]	;[Victor] another oflo avoider
] ; ifn 0
	tlz w3,400000		;insignificant sign bit
;the carry in is non-negative, so this is easy
	dadd w3,-1(p)		;carry in
	tlze w3,400000		;check for overflow here too
ifn 0,[	  dadd nil1,[0 ? 1]	;[Victor] Why not?
]
ife 0,[	 jrst [dadd nil1,[0 ? 1] ? jrst .+1] ;propagate carry
]
;Because 1(o3) is the high-order double-word from the last time through
;this code, it is signed.  Thus we must do a full quad-word signed add.
;This code is simplified because we know that the high-order double-word
;cannot overflow.
xtimc2:				;[Victor] 
	jfcl 17,.+1		;clear carry bits
	dadd w3,1(o3)		;from PP.  This number is signed
	jcry1 [dadd nil1,[0 ? 1] ? jrst .+1] ;propagate carry
	tlz w3,400000		;clear sign bit, as this is now non-signif sign
	movem w4,2(o3)		;save result in partial product
	exch w3,1(o3)		;and get prev value, so we can sign-extend it
	ashc w3,-70.		;W3/4 is now high double-word of PP
	dadd nil1,w3		;this one can't overflow
	dmovem nil1,3(o3)	;new PP.  *WARNING* This one is signed
	addi o2,2		;now do new multiplier digit
	addi o5,2		;shift range in product
	sose -3(p)		;count multiplier digits
	 jrst xtiml0
;here to loop again with the last multiplier digit.  This is different
;because it is signed.  However the digits from the PP are not.  So the
;results will still fit into a quad-word without overflow.  This time 
;the carry is going to be signed.
xtiml5:	move o1,-4(p)		;last multiplier digit: a whole nother
	move o3,o5		; multiplicand loop
	move o4,-2(p)
	setzb nil1,w2		;clear carry
	soje o4,xtiml7		;again only loop n-1 times
xtiml6:	dmovem nil1,-1(p)	;save previous carry
	dmove nil1,1(o1)	;multiplicand -- internal digit
	dmul nil1,1(o2)		;multiplier  -- sign digit
ifn 0,[	skipl 1(o3)		;[Victor]
	 jrst [	tlo w3,400000	;[Victor]
		dadd w3,1(o3)	;[Victor]
		tlzn w3,400000	;[Victor]
		 dadd nil1,[0 ? 1]	;[Victor]
		jrst xtimc7 ]	;[Victor] also avoid oflo
] ;ifn 0
	tlz w3,400000		;insigificant sign bit
	dadd w3,1(o3)		;PP
	tlze w3,400000		;check for overflow 
ifn 0,[	 dadd nil1,[0 ? 1]	;[Victor] 
]
ife 0,[	 jrst [dadd nil1,[0 ? 1] ? jrst .+1] ;propagate carry
]
xtimc7:				;[Victor] 
	jfcl 17,.+1		;carry is signed, so slightly more complex
	dadd w3,-1(p)		;now add in carry.  This is signed
	 jcry1 [dadd nil1,[0 ? 1] ? jrst .+1] ;propagate carry
	tlz w3,400000		;clear sign bit, as it is internal
	dmovem w3,1(o3)		;save result in partial product
	move w3,-1(p)		;and get prev value, so we can sign-extend it
	ashc w3,-70.		;W3/4 is now high double-word of PP
	dadd nil1,w3		;this one can't overflow
	addi o1,2		;new multiplicand digit
	addi o3,2		;new PP digit
	sojg o4,xtiml6
;here we have high-order double-words of both.  Here everything is signed.
xtiml7:	dmovem nil1,-1(p)	;save previous carry
	dmove nil1,1(o1)
	jfcl 17,.+1
	dmul nil1,1(o2)
;note that we use NIL as a flag that overflow happened.  Also, we set
;NIL1 to 0.  In effect we bias it by 400000,,0, so allow us to continue
;doing arithmetic with it.  We will test for NIL nonzero later and
;undo this bias.
	jov [movei nil,1 ? setz nil1, ? jrst .+1] ;overflow can be only this
	jfcl 17,.+1		;carry is signed, so slightly more complex
	dadd w3,-1(p)		;now add in carry.  This is signed
;we now use (P) to keep track of the carry into NIL1/W2.  As we are summing
;a few 1's, 0's, or -1's, we can only need one word.  We are concerned that
;NIL1 could overflow if we ended up adding 1 and then -1 to it.  We know
;that NIL1 will hold the result, so if we get everything to be added to it
;into one AC, then we are guaranteed not to overflow.
	setzm (p)		;init carry
	 jcry1 [aos (p) ? jrst .+1] ;carry from DADD above
	move n,-1(p)		;now get high-order double-word of carry
	ash n,-35.		;sign-extension of old one
	addm n,(p)		;put that into the carry
	jfcl 17,.+1
	dadd w3,1(o3)		;now add in the partial product, also signed.
	 jcry1 [aos (p) ? jrst .+1] ;handle carry here, too
	move n,1(o3)		;and sign-extension
	ash n,-35.
	addm n,(p)		;into the carry
	dmovem w3,1(o3)		;now have result for PP	
	move w3,(p)		;get carry
	ashc w3,-35.		;make it double-word
	dadd nil1,w3		;and do it.
	setz w4,		;assume not 2**gazillion
;if the original multiply overflows, we set NIL1 to zero.  This is a cheap
;way of making sure the NIL1/W2 can hold what it is supposed to.  If this
;happened, there are two possibilities:
;  1) due to various carries, we really end up with a result starting in
;	377777,,... instead of the impossible 400000,,...  In that case
;	NIL1 will now be less than zero.  We simply add back 400000,,0,
;	which will then give us the proper number.  
;  2) we really have 2^N.  In this case NIL1 will still be zero.
;	We set W4 to indicate a real overflow
	jumpn nil,[setz nil,	;we had an overflow
		jumpe nil1,[seto w4, ? jrst .+1]  ;real overflow, set the flag
		add nil1,[400000,,0] ;no overflow, undo bias
		jrst .+1]
	dmovem nil1,3(o3)	;put result in memory
	subi p,6		;all our temps
	pop p,o1		;let's not forget the quotient
	setz nil1,		;reconform to Lisp reg. standards
	setzb o2,o3
	setzb o4,o5
	jumpn w4,[seto w2, ? jrst bmoflo] ;ie, if -2**gazillion
	jrst bgtrim		;    if not

;; zero internal sign bits in a bignum
;; only the sign bits in the leading words of the doublewords are zeroed
zisbit:	getsiz w4,o1
	lsh w4,-1
	hrlzi w3,400000
	jrst .+3
zisbi2:	 andcam w3,1(o1)
	 addi o1,2
	sojg w4,zisbi2
	iret

;;TY%INT
xtiinu:	move w2,o1		;two inums: save arg 1
	lsh o1,4		;do in times-16 so overflo
	jfcl 17,.+1		; will check inum bounds
	imul o1,w3		;one wd mult
	jov xtiiov		;too big, use 2 wd
	ash o1,-4		;inum fits, return it
	maknum o1
	retn

xtiiov:	mul w2,w3		;(no poss. of oflo since were inums)
	jrst retbig

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; /
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

equot:	jrst [move o2,o1 ? move o1,[inum 1] ? jrst quot] ;one arg: invert
	jrst quot		;2: normal binary
	jrst [push p,[<codsec,,quot>] ? jrst mular3]
	jrst [push p,[<codsec,,quot>] ? jrst mular4]
	jrst [push p,[<codsec,,quot>] ? jrst mular5]
	jrst [push p,[<codsec,,quot>] ? jrst mularn]

;; general division
quot:	xnmtyp o1		;check each number for integrity
	movei n,1		;returns 1 result
	caige w2,ty%xbg-ty%xfl
	 jrst quot1
	xnmtyp o2
	caige w2,ty%xbg-ty%xfl
	 jrst quot1
	jrst ratio1
quot1:	move w3,o2
	xtype o2		;what's second arg?
	xct doptab(w2)		;above, qv
	 jrst xquot
	xtype o1
	xct a2itab(w2)
xquot:	xct .+1-ty%xfl(w2)	;;TYPES
	jrst xquflo		;long flons
	jrst xquifl		;iflons
	jrst xquifl		;iflons
	jrst xqurat		;ratios
	jrst notnum		;complex
	jrst ratio1		;bignums
	jrst ratioi		;inums
	jrst ratioi		;inums

;;TY%FLO
xquflo:	dmove w2,1(o1)		;double precision divide
	dfdv w2,1(o2)
	jrst retflo

;; Integer routines are replaced with ratio operations for Common Lisp.
;; Never fear, the bignum divide routine gets used from inside them.
;;TY%INT
; currently this routine can't be reached by the logic...
ratioi:	move w2,o1
	idiv o1,w3
	jumpn o2,ra2ioi		;check for remainder
	maknum o1		;none, it's an int
	retn

ra2ioi:	dmove o1,w2		;nope, put'em back
	maknum o1
	maknum o2
	jrst ratio1		;use general routine

;;TY%IFL
xquifl:	fdvr o1,w3		;single prec divide
	jrst retifl

; divide two rats (and conquer?)
;	a   c            ad
;      --- ---    =     ----
;	b   d            bc

xqurat:	pushcar q,o1
	docdr o1,o1
	pushcdr q,o2
	docar o2,o2
	call times
	exch o1,-1(q)
	pop q,o2
	call times
	pop q,o2		;get back denom (it may be negative)
	jrst ratio1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; IQUOT - truncating integer divide - for internal use only
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; for integer division only
iquot:	move w3,o2
	xtype o2		;what's second arg?
	xct doptab(w2)		;above, qv
	 jrst xiquot
	xtype o1
	xct a2itab(w2)
xiquot:	xct .+1-ty%xfl(w2)	;;TYPES
	jrst notnum		;long flons
	jrst notnum		;iflons
	jrst notnum		;iflons
	jrst notnum		;ratios
	jrst notnum		;complex
	jrst xqubig		;bignums
	jrst xquinu		;inums
	jrst xquinu		;inums

;;TY%BIG
xqubig:	getsiz w2,o1		;size of dividend
	getsiz w3,o2		;siza divisa
	caile w2,4		;DDIV can handle <4wd>/<2wd>
	 jrst xqubgb		;else go for mult wd routine
	caile w3,2
	 jrst xqubgb
	dmove w3,1(o1)		;indeed, ddiv requires 4wd/2wd
	cain w2,4		;so we must do the sign-extend
	 jrst [dmove nil1,3(o1) ? jrst .+3]
	  move nil1,w3		;by hand if dividend is only 2wd.
	  ashc nil1,-70.
	jfcl 17,.+1		;overflow occurs if the quotient is 
	ddiv nil1,1(o2)		;bigger than 2 words, so go to 
	jov [skipn 1(o2) ? skipe 2(o2) ? jrst xqubgb ? jrst .+1]
	move w3,w2		;general case code if it happens--
	move w2,nil1		;unless divisor was 0, when we return
	setz nil1,		;some random junk.
	jrst retint

xqubgb:	call divrou		;this routine does the work--qv
	move w4,o2		;length of quotient
	add o2,o1		;o1 is pointer to quotient on the stack
	push p,o2		;this points to the end of it
	setzb nil1,o2		;clean up sensitive registers
	setzb o3,o4
	setz o5,
	call bigmak		;alloc space for the quotient
	pop p,o2		;copy from stack into heap.
	move o3,o1		;remember that the doublewords in
xqucpy:	dmove w2,-2(o2)		;the heap object are in reverse order.
	dmovem w2,1(o3)		;lsd to msd
	addi o3,2		;up the bignum
	subi o2,2		;down the stack
	sojg w4,xqucpy
	pop q,p			;saved p
	tlz p,770000		;(we made it into an object for q)
	setzb o2,o3		;clean up more regs
	trne n,1		;see if quotient was negative
	 call rdnbig		;it was
	jrst bgtrim		;--n't

;; this routine does bignum division, leaving the results on the stack.
;; it expects dividend (as lisp pointer) in o1 and divisor in o2.
;; it leaves:	o1: pointer to quotient		(all as bare addresses
;;		o2: length of quotient		 and numbers, not
;;		o3: pointer to remainder	 lisp objects)
;;		o4: length of remainder
;;	    on p: data for all of the above
;;	    on q: saved p as address object
;;	    in n: 1 if quotient is neg, 2 if remainder is neg, 3 if both
;;(the idea is to avoid negating remainder if only quotient is to be
;; used, and vice versa) (the algorithm requires generating both)
;;	all other registers:  garbage
divrou:	pop p,o5		;our return address
	move w4,p		;make an addr obj
	tlo w4,(inum0)
	push q,w4		;save it
	setz n,			;numpsh sets n to n xor (minusp o1)
	addi p,2		;elbow room for wierd spec case (see div2cg)
	call numpsh		; and throws o1's bignum's data on p
	imuli n,3		;use sign of dividend as sign of remainder
	pop p,o4		;and leaves pointer and length on p also
	pop p,o3
	move o1,o2		;do the divisor also
	call numpsh		;numpsh leaves the number in positive form
	move o1,(p)		;(reversing the order of the doublewords)
	camge o4,(p)		;if the dividend is shorter than the divisor,
	 jrst divz0		;  quotient = 0, remainder = dividend
	push p,o3		;now n is set for the sign of the q and r
	push p,o4		;and both sets of ptr/lens are on p
	caie o1,2		;there follows a simple routine for
	 jrst div2bg		;use when the divisor is only 2 wds long
	move o2,-3(p)		;otherwise jump to div2bg
	lsh o4,-1		;o4 counts doublewords
	dmove w2,-2(o3)		;o3 moves along the dividend
dvrdiv:	dmove w4,(o3)		;third-grade short division w/1-digit divisor
	ddiv w2,(o2)		;o2 points to the divisor
	dmovem w2,-2(o3)	;--of course, digits are base 2^70
	dmove w2,w4		;replace dividend with quotient as we go
	addi o3,2
	 sojg o4,dvrdiv
	dmovem w2,-2(o3)
	dmove o1,-1(p)		;pointer to quotient, which has replaced
	subi o1,2		;dividend
	subi o3,2		;pointer to remainder, right after it
	movei o4,2		;length of remainder
	jrst (o5)		;return to sender, at address unknown

;; If the dividend is shorter than the divisor, ie 3/99999999999999999999,
;; the quotient is 0 and the remainder is the dividend
divz0:	pop p,o2		;divisor length, ignored
	pop p,o1		;divisor ptr
	setzm (o1)		;make remainder 0
	setzm 1(o1)		;two wds long
	movei o2,2		;divisor len
	jrst (o5)		;return

;; takes the bignum whose pointer is in o1, and pushes it (all the data)
;; onto p.  actually pushes the magnitude, ie negates it if negative.
;; also, if negative, xors register n with -1 (for determination of
;; the sign of the result after this is done twice).  clears all the
;; sign bits of the internal (nonsignificant) doublewords in the number.
;; leaves pointer and length on the top of p.
numpsh:	getsiz w4,o1	
	add o1,w4		;find end of number
	sos o1			;(we reverse the doublewds for division)
	move nil1,p
	pop p,w2		;our return address
	push p,0		;space in case of overflow in converting neg
	push p,0		; number.  See dvrneg
	push p,0		;a 0 digit on the front ameliorates
	push p,0		;many of the algorithms
	addi p,(w4)		;w4 is the length
	addi nil1,4		;nil1 points to our new space
	push p,nil1		;push it
	push p,w4		; the length
	push p,w2		; rtn addr
	lsh w4,-1		;count doublewds
	skipge (o1)		;if <0, negate it
	 jrst dvrneg
dvr1:	dmove w2,(o1)		;get dw from object
	tlz w2,400000		;make sure sign bits are 0
	tlz w3,400000
	dmovem w2,(nil1)	;put on stack
	addi nil1,2		;bump pointer
	subi o1,2		;decr obj ptr
	sojg w4,dvr1		;until done
	retn

;;negate a number which was negative
dvrneg:	trc n,1
dvrn1g:	setcm w2,(o1)		;get dw from object
	setcm w3,1(o1)
	tlz w3,400000
	tlz w2,400000		;make sure sign bit is 0
	dmovem w2,(nil1)	;put on stack
	addi nil1,2		;bump pointer
	subi o1,2		;decr obj ptr
	sojg w4,dvrn1g		;until done
	sos nil1		;that was a one's complement..
dvrn2g:	aosl (nil1)		;add one to it
	 jrst dvrn3g		;stops when carry does
	setzm (nil1)
	soja nil1,dvrn2g
dvrn3g:	caml nil1,-2(p)		;carried back into leading 0?
	 retn			;no, done
	sos -2(p)		;yes, adjust back one 
	sos -2(p)
	aos -1(p)		;and say one longer
	aos -1(p)
	retn

;; this is the main division routine. enter at your own risk.
;; there are lots of hidden assumptions about what digits must
;; be zero or less than other digits, and when overflow can happen.
;; this is a "guessing" algorithm, ie it attempts to find the right
;; next digit of the quotient by dividing the top two remaining
;; digits of the dividend by the top digit of the divisor.  this
;; guess is correct in all but 3 out of 2^70 cases, providing we
;; normalize the dividend (ie, shift it left until the high-order
;; bit in the top digit is a 1). We do this, so we must also shift
;; the result back.  If the guess was wrong, it was too high by
;; 1 or 2.  We must add back the divisor (having subtracted it as
;; multiplied by too high a number) and modify the quotient digit.
;; For a mathematical analysis of all these shenanigans, see Knuth
;; (volume II, Seminumerical Algorithms / the classical algorithms)

; "This code *should* be hard to read.  After all, it was hard to write!"

div2bg:	dmove o1,-3(p)		;find the leftmost bit of the dividend
	dmove w2,(o1)		;here's the leftmost word
	move w4,o1		;another ptr to leftmost wd
	jumpn w2,.+4		;leftmost wd is 0, prepare to 
	  aos o1		;shift number 1 wd as well as n bits
	  sos o2		;ptr moves up, length down
	  move w2,w3
	jffo w2,.+1		;find leftmost bit
	sos o3,w3		;bits to shift (not including sign bit)
	push p,w4		;this will be 1 if a wordshift, else 0
	subm o1,(p)
	call ashbig		;shift it
	skipe (p)		;zero last word if a wordshift
	 setzm 1(w4)
div2dg:	dmove o1,-2(p)		;now shift the divisor the same amount
	dadd o1,[-2 ? 2]	;give it 2 extra words since it may
	dmovem o1,-2(p)		;have more bits in the high digit
	move w4,o1		;than the dividend
	add o1,(p)		;same word-shift flag
	call ashbig		;same everything
	skipe (p)
	 setzm 1(w4)
	push p,o3		;# of bits shifted
	push p,-3(p)		;dividend/quotient pointer
	move w2,-5(p)		;length of divisor/remainder (in wds)
	lsh w2,-1		;now in doubleword digits
	push p,w2
	move w3,-4(p)		;length of dividend
	lsh w3,-1		;in digits
	sub w3,w2		;makes length of quotient
	push p,w3
	push p,o5		;rtn addr
;;P at this point:
;; 0(p) = rtn addr
;; -1(p) = # of digits in quotient
;; -2(p) = # of digits in divisor (and remainder)
;; -3(p) = points to beginning of quotient (to move)
;; -4(p) = # of bits numbers are shifted (mod 35)
;; -5(p) = # of wds numbers are shifted (0 or 1)
;; -6(p) = # of wds in dividend
;; -7(p) = pointer to dividend
;; -10(p) = # of wds in divisor
;; -11(p) = pointer to divisor

; nil1 thru o2 are used for arithmetic.
; o3 --> divisor digit under consideration
; o4 --> most recently created quotient digit
; o5 --> dividend digit under consideration
; o6 = digit count for inner loop

	;	There once was a student at Trinity
	;	Who solved the square root of infinity.
	; 	  While counting the digits,
	;	  He was siezed by the fidgits;
	;	Dropped science, and took up divinity.

	move o4,-3(p)		;quotient
	subi o4,2		;elbow room needed
divdvl:	move o3,-11(p)		;divisor
	xmovei o5,2(o4)		;dividend
	dmove nil1,(o5)		;divide top two digits in dividend
	dmove w3,2(o5)
	jfcl 17,.+1
	ddiv nil1,(o3)		;by top digit in divisor
	jov divdov		; if overflow, use highest "digit"
	skipn nil1		;skip the loop if this gives 0
	 jumpe w2,diveol
	dmovem nil1,(o4)	;else move the quotient to the quotient
; this is the test in Knuth step D3.  see if the second digit of
; the divisor times the new quotient digit is greater than the remainder
; appended to the third digit of the dividend.  If so, the guess was
; too high, and is decremented.  
divtst:	dmove o1,w3		;get the remainder out of the way
	dmove nil1,2(o3)	;second digit of divisor
	dmul nil1,(o4)		; times new quotient digit
	dsub o1,nil1		; "for comparison purposes only"
	jumpg o1,divmsb		; 1/2/3/4 =< o1/o2/... -> divmsb
	jumpl o1,divgth		; 1/2/3/4 > o1/o2/... -> divgth
	jumpg o2,divmsb
	dmove o1,4(o5)
	dsub o1,w3
	jumpl o1,divgth
; here we multiply the divisor by the last digit of the quotient and
; subtract that from the dividend.  This cannot produce more than a
; one-bit carry as the quotient cannot by this point be more than 
; 1 greater than its correct value.
; corresponds to Knuth step D4
divmsb:	add o3,-10(p)		;divisor ptr + divisor len -> end thereof
	add o5,-10(p)		;dividend, only go in len(divisor) wds
	move o6,-2(p)		;# of divisor digits for subtract loop
	dmove o1,[0 ? 0]	;initial borrow
divsbl:	subi o3,2		; divisor pointer
	subi o5,2		; dividend pointer
	dmove nil1,(o3)		;multiply the divisor
	dmul nil1,(o4)		;by the quotient
	dadd nil1,o1		;juggle the borrow
	dmove o1,2(o5)		;and subtract it from the dividend
	dsub o1,w3
	tlze o1,400000		;check for borrow
	 dadd nil1,[0 ? 1]	; running in the red...
	dmovem o1,2(o5)		;replace in dividend
	dmove w3,(o5)		;next digit from dividend
	dsub w3,nil1		;subtract the other product digit
	dmove o1,[0 ? 0]
	tlze w3,400000		;check for borrow
	 dmove o1,[0 ? 1]	; use next time around
	dmovem w3,(o5)		;else put that one back too
	sojg o6,divsbl		;  Counting the digits ...
	jumpn o2,divstm		; check for "overdrawn" subtraction
; at the end of the subtract loop we check to see if we borrowed all the
; way out the end.  if so we have a 3-in-2^70 overguess, so go to divstm.
	; fall thru
; Otherwise, we are all set to housekeep our way to loop for the next digit.
diveol:	addi o4,2		;bump the quotient pointer one digit
	sose -1(p)		;this is the #-of-digits-in-quotient counter
	 jrst divdvl		; maybe go do the next, else through
	xmovei o1,2(o4)		;make pointer to remainder
	move o2,-10(p)		;length of divisor/remainder
	add o1,o2		;point to end of remainder
	movn o3,-4(p)		;bit shift offset
	sos w4,o1		;remainder pointer
	sub w4,-5(p)		;word shift 0/1
	sub o2,-5(p)		;this loop shifts the remainder back
	soje o2,divrh1		;the same amount the divisor & dividend
divrsh:	dmove w2,-1(w4)		;were shifted forth.  the quotient is
	ashc w2,(o3)		;of course already correct (since
	movem w3,(o1)		;a*2^n / b*2^n = a/b).  this loop has
	dsub w4,[1 ? 1]		;to go in the opposite direction from
	sojg o2,divrsh		;the other shift loop
divrh1:	move w2,(w4)		;last word, shift in 0's
	ash w2,(o3)
	movem w2,(o1)
	skipe -5(p)		;clear hi-order wd if a word shift
	 setzm (w4)
	dmove o1,-7(p)		;ptr, length of dividend/quotient
	subi o1,2		;we moved this back one digit
	sub o2,-10(p)		;len(dividend)-len(divisor)=len(quotient)
	xmovei o3,2(o4)		;quotient ptr moved off end now -> remainder
	move o4,-10(p)		;length of divisor/remainder
	setzb o5,o6		;clean up junk
	retn			;whew finally at last

; Divgth: guess too high.  subtract one from last quotient digit
; [question: I cannot prove that this will never be zero in those cases
;  that this routine is entered for the second time.  However Knuth
;  indicates no test or error condition for the subtract.]
; Divdov: divide overflowed. use "9" for the quotient digit.
; Both: then multiply the high order divisor digit by the above 
; quotient digit and subtract that from the two high order dividend
; digits.  (the result will be compared to a quantity computed at divtst.
; However if it (the result) has a non-zero first digit, the quantity
; need not be computed as the result of the test is assured, so we jump
; straight to divmsb.)
; this is all part of Knuth D3
divgth:	dmove nil1,(o4)		;guess too high, decrement quotient
	dsub nil1,[0 ? 1]
	skipa
divdov:	 dmove nil1,[377777777777 ? 377777777777] ; div oflo, use "9"
	dmovem nil1,(o4)	;save as latest quotient digit
	push p,o3		;save for working regs
	push p,o4
	dmove nil1,(o5)		;first digit dividend
	dmove w3,2(o5)		;second digit dividend
	dmove o1,(o3)		; divisor 1st dig
	dmul o1,(o4)		; quotient again
	dsub w3,o3		; this gives a remainder
	tlze w3,400000		;  this is a four-word subtract
	 dsub nil1,[0 ? 1]	;   do the borrowing
	dsub nil1,o1
	pop p,o4		;restore
	pop p,o3
	jumpl nil1,doverr
	skipn nil1		;if first digit (2 wds) is 0, -> divtst
	 jumpe w2,divtst	; if 1st dig >0, this # must be the greater
	jrst divmsb		; so go straight to divmsb

doverr:	err /An impossible condition has arisen in division./

; Subtracted too much.  In spite of our vigilant efforts, the quotient
; was too big for its britches.  Decrement it and add the divisor 
; back to the dividend.
; this corresponds to D6 in Knuth.
divstm:	dmove nil1,(o4)		; decrement quotient
	dsub nil1,[0 ? 1]
	dmovem nil1,(o4)	;save back
; now add the divisor back.  loop cntl is similar to main inner loop above
	add o3,-10(p)		; point to end of divisor
	add o5,-10(p)		; point divisor's length into dividend
	move o6,-2(p)		;# of divisor digits for add loop
	dmove o1,[0 ? 0]	;initial carry
divadl:	subi o3,2
	subi o5,2
	dmove nil1,(o3)		; divisor
	dadd nil1,2(o5)		; dividend	(can't oflo)
	dadd nil1,o1		; carry in	(can't oflo)
	dmove o1,[0 ? 0]	; carry out
	tlze nil1,400000	;  ...
	 dmove o1,[0 ? 1]	;  ...
	dmovem nil1,2(o5)	;replace in dividend
	sojg o6,divadl
	dmove nil1,(o5)		;last dividend digit
	dadd nil1,o1		;carry
	tlzn nil1,400000	;clear "carry out"
	 jrst doverr		; keep it honest
	dmovem nil1,(o5)	;replace last digit
	jrst diveol		;your program is rejoined in progress...

;; shift o2 words from (o1) left o3 bits and put them at (w4)
ashbig:	 soje o2,ashb1g		;only 1 wd?
	dmove w2,(o1)		;main loop--dmove to get bits to shift in
	ashc w2,(o3)
	movem w2,(w4)
	dadd w4,[1 ? 1]		;bump both pointers
	sojg o2,ashbig+1
ashb1g:	move w2,(o1)		;last word, shift in 0's
	ash w2,(o3)
	movem w2,(w4)
	retn

;; ** end of bignum divide routine **
;; whew

;;TY%INT
;; after that, the inum divide routine is awfully anticlimactic:
xquinu:	idiv o1,w3
	setz o2,		;squelch the remainder
	maknum o1
	retn

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; RAT - create a ratio - internal routine only
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;check for negativity wrong
ratio1:	push q,o1
	push q,o2
	move o1,o2
	call minusp
	jumpn o1,negden
	pop q,o2
	pop q,o1
	jrst ratin

negden:	pop q,o1
	call minus
	exch o1,(q)
	call minus
	pop q,o2
	jrst ratin

;; you dirty rat...
;take ints in o1,o2 and make a ratio out of them
rat:	xnmtyp o1		;check each number for integrity
	caige w2,ty%xbg-ty%xfl
	 jrst [err1 o1,/Attempting to take ratio of non-integers/]
	xnmtyp o2
	caige w2,ty%xbg-ty%xfl
	 jrst [err1 o2,/Attempting to take ratio of non-integers/]

; here if we know both are integers already
ratin:	movei n,1		;returns 1 result
	camn o2,[inum0]		;[Victor] Check for divide-by-zero
	 jrst divzro		;[Victor] Catch it
	came o2,[inum 1]	;if demoninator is 1
	 camn o1,[inum0]	; or numerator is 0,
	  retn			;  the fraction = the numerator
	push q,o1		;divide each by their gcd
	push q,o2
	call gcd
	camn o1,[inum 1]	;already in lowest terms?
	 jrst [pop q,o2 ? pop q,o1 ? jrst rltrat]
	exch o1,-1(q)
	move o2,-1(q)
	call iquot
	exch o1,-1(q)
	exch o1,(q)
	pop q,o2
	call iquot
	move o2,o1
	pop q,o1
	camn o2,[inum 1]	;if denom = 1
	 retn			;merely return numerator
	jrst rltrat		;rat "cons"

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; numerical predicates - general support
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;see whether a list of arguments is monotonic in some predicate.
;The predicate is pushed onto the stack.  0 args is illegal, 1 
;returns T trivially, 2 calls the function directly.

mono3:	push q,o3
	push q,o2
mono3r:	call @(p)
	jumpe o1,mono3x
	pop q,o1
	pop q,o2
	pop p,w2
	jrst (w2)

mono3x:	subi q,2
	subi p,1
	retn

mono4:	push q,o4
	push q,o3
	push q,o2
mono4r:	call @(p)
	jumpe o1,mono4x
	pop q,o1
	move o2,(q)
	jrst mono3r

mono4x:	subi q,3
	subi p,1
	retn

mono5:	push q,o5
	push q,o4
	push q,o3
	push q,o2
mono5r:	call @(p)
	jumpe o1,mono5x
	pop q,o1
	move o2,(q)
	jrst mono4r

mono5x:	subi q,4
	subi p,1
	retn

monon:	push sp,[.dummy]
	push sp,o5		;save O5 for main loop
	subi n,5
	push p,n		;save count
	push p,[codsec,,.+3]
	push p,-2(p)
	jrst mono5		;see if first 5 are OK
	jumpe o1,mononx		;if not, stop
;now look at the extra args
mononl:	sosg (p)		;if at least 2, use the rest
	jrst monond
	dmove o1,-1(q)
	subi q,1		;no longer need last one
	call @-1(p)
	jumpe o1,mononx		;stop at first failure
	jrst mononl

;here if we have to look at O5 and the first extra arg
monond:	move o1,(sp)
	pop q,o2
	subi p,1
	pop p,w2
	subi sp,2
	jrst (w2)

;exit on failure
mononx:	pop p,n			;number of args left
	subi q,1(n)		;get rid of them
	subi p,1
	subi sp,2
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; =  numerical equality
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

eeqp:	jrst rett		;1 always succeeds
	jrst eqp		;2 - do operation directly
	jrst [push p,[codsec,,eqp] ? jrst mono3] ;3
	jrst [push p,[codsec,,eqp] ? jrst mono4] ;4
	jrst [push p,[codsec,,eqp] ? jrst mono5] ;5
	jrst [push p,[codsec,,eqp] ? jrst monon]

eqp:	camn o1,o2
	 jrst rett
	move w3,o2
	xtype o2		;what's second arg?
	xct doptab(w2)		;above, qv
	 jrst xeqp
	xtype o1
	xct a2itab(w2)
xeqp:	xct .+1-ty%xfl(w2)	;;TYPES
	jrst xeqflo		;long flons
	jrst xeqifl		;iflons
	jrst xeqifl		;iflons
	jrst xeqrat		;ratios
	jrst notnum		;complex
	jrst xeqbig		;bignums
	jrst retnil		;inums 
	jrst retnil		;inums

xeqflo:	dmove w2,1(o1)
	came w2,1(o2)		;=*= using dfsb gave overflos
	 jrst retnil
	came w3,2(o2)
	 jrst retnil
	jrst rett

;;TY%IFL
xeqifl:	came o1,w3
	 jrst retnil
	jrst rett

; since rats are always supposed to be in lowest terms, merely compare
; the numerators and denominators
xeqrat:	pushcar q,o1
	docdr o1,o1
	pushcar q,o2
	docdr o2,o2
	call eqp
	jumpe o1,[subi q,2 ? ret1]
	pop q,o2
	pop q,o1
	jrst eqp

xeqbig:	getsiz w2,o1
	getsiz w3,o2
	came w2,w3
	 jrst retnil
	move w4,w3
	lsh w4,-1
	add w2,o1
	add w3,o2
	dmove o1,-1(w2)
	came o1,-1(w3)
	 jrst xeqrnl
	move o1,(w3)
	tlz o1,400000
	tlz o2,400000
	came o2,o1
	 jrst xeqrnl
	soje w4,xeqrtt
	hrlzi o3,400000
xeqmlp:	subi w2,2
	subi w3,2
	andcam o3,-1(w2)
	andcam o3,-1(w3)
	dmove o1,-1(w2)
	dsub o1,-1(w3)
	jumpn o1,xeqrnl
	jumpn o2,xeqrnl
	sojg w4,xeqmlp
xeqrtt:	setzb o2,o3
	jrst rett

xeqrnl:	setzb o2,o3
	jrst retnil

notin2:	err1 o2,/Argument to integer function not an integer: ~S/
notint:	err1 o1,/Argument to integer function not an integer: ~S/

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; REM - remainder
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

rem:	move w3,o2
	movei n,1		;returns 1 result
	xtype o2		;what's second arg?
	xct doptab(w2)		;above, qv
	 jrst xrem
	xtype o1
	xct a2itab(w2)
xrem:	xct .+1-ty%xfl(w2)	;;TYPES
	jrst xrmflo		;long flons
	jrst xrmifl		;iflons
	jrst xrmifl		;iflons
	jrst xrmrat		;ratios
	jrst notnum		;complex
	jrst xrmbig		;bignums
	jrst xrminu		;inums
	jrst xrminu		;inums

; odd routine. work entirely in true lisp objects, so undo
; normalization done by entry routine.
xrmrat:	camn o1,[object ty%crt,<codsec,,work>]
	 move o1,work
	camn o2,[object ty%crt,<codsec,,work>]
	 move o2,work
; now do the work.  use o1 - trunc(o1/o2)*o2
xrmflo:	push q,o1
	push q,o2
	call quot
	call fixf
	pop q,o2
	call times
	pop q,o2
	exch o1,o2
	jrst diff

;truncate machine float in o1
xrmift:	jumpge o1,xrmftx	;if non-neg, do it directly
	movn o1,o1		;else have to do it the hard way
	call xrmftx
	movn o1,o1
	iret

xrmftx:	ldb w2,[.bp <377_27.>,o1] ;get exponent
	movei w4,200		;no shift needed for this
	sub w4,w2		;w4 is now shift needed for mask
	jumpge w4,xrmrtz	;if all bits masked, use 0
	move w2,[000777,,777777] ;mask
	ash w2,(w4)		;mask needed for truncation
	tdz o1,w2		;o1 is now truncated result
	iret

;here to return zero
xrmrtz:	setz o1,
	iret

;immed float
xrmifl:	push p,o1
	push p,w3
	fdvr o1,w3
	call xrmift		;truncate o1
	pop p,w3
	fmpr o1,w3		;multiply back
	pop p,w3
	exch o1,w3
	fsbr o1,w3
	makifl o1
	ret1

xrmbig:	getsiz w2,o1
	getsiz w3,o2
	caile w2,4
	 jrst xrmbgb
	caile w3,2
	 jrst xrmbgb
	dmove w3,1(o1)
	cain w2,4
	 jrst [dmove nil1,3(o1) ? jrst .+3]
	  move nil1,w3
	  ashc nil1,-70.
	jfcl 17,.+1
	ddiv nil1,1(o2)
	jov [skipn 1(o2) ? skipe 2(o2) ? jrst xrmbgb ? jrst .+1]
	move w2,w3
	move w3,w4
	setz nil1,
	jrst retint

xrmbgb:	call divrou
	move w4,o4
	add o3,o4
	push p,o3
	setzb nil1,o2
	setzb o3,o4
	setz o5,
	call bigmak
	pop p,o2
	move o3,o1
xrmcpy:	dmove w2,-2(o2)
	dmovem w2,1(o3)
	addi o3,2
	subi o2,2
	sojg w4,xrmcpy
	pop q,p
	tlz p,770000
	setzb o2,o3
	trne n,2		;see if remainder was negative
	 call rdnbig
	jrst bgtrim

;;TY%INT
xrminu:	idiv o1,w3		;bogus ucilisp truncating int divide
	move o1,o2		;get the remainder
	setz o2			;kill old copy
	maknum o1
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ODDP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

oddp:	skpint o1		;make sure it is an integer
	 jrst notint
	skpin o1		;if inum
	 move o1,2(o1)		;bignum, get low-order word
	trnn o1,1
	jrst retnil
	jrst rett

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; EVENP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

evenp:	skpint o1		;make sure it is an integer
	 jrst notint
	skpin o1		;if inum
	 move o1,2(o1)		;bignum, get low-order word
	trne o1,1
	jrst retnil
	jrst rett

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; GCD
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

egcd:	jrst retzer		;no arg: return 0
	jrst absf		;one arg: itself
	jrst gcd
	jrst [push p,[<codsec,,gcd>] ? jrst mular3]
	jrst [push p,[<codsec,,gcd>] ? jrst mular4]
	jrst [push p,[<codsec,,gcd>] ? jrst mular5]
	jrst [push p,[<codsec,,gcd>] ? jrst mularn]

;GCD - main binary operation
gcd:	move w3,o2
	movei n,1		;returns 1 result
	xtype o2		;what's second arg?
	xct doptab(w2)		;above, qv
	 jrst xgcd
	xtype o1
	xct a2itab(w2)
xgcd:	xct .+1-ty%xfl(w2)	;;TYPES
	jrst xgcdno		;long flons
	jrst xgcdno		;iflons
	jrst xgcdno		;iflons
	jrst xgcdno		;ratios
	jrst notnum		;complex
	jrst xgdbig		;bignums
	jrst xgdinu		;inums
	jrst xgdinu		;inums

xgcdno:	err /Can't take GCD of non-integers/

xgdbig:	camn o1,[object ty%cbg,<codsec,,work>]
	 jrst [move o1,work+2 ? maknum(o1) ? jrst .+1]
	camn o2,[object ty%cbg,<codsec,,work>]
	 jrst [move o2,work+2 ? maknum(o2) ? jrst .+1]
;the algorithm only works for nonneg's, so take abs of both
	push q,o2		;O2 on stack, O1 in register
	call absf
	exch o1,(q)		;ABS(O1) on stack, O2 in register
	call absf
	push q,o1		;ABS(O1), ABS(O2) on stack, ABS(O2) in register
	move o2,o1
	move o1,-1(q)		;ABS(O1), ABS(O2) on stack and register
	call lessp
	jumpe o1,.+4
	 dmove o1,-1(q)
	 exch o1,o2
	 dmovem o1,-1(q)
	dmove o1,-1(q)
	pop q,-1(q)
xgdbgl:	call rem		;Euclid's algorithm (the hard way)
	pop q,o2
	exch o1,o2
	camn o2,[inum0]
	 jrst absf
	push q,o2
	jrst xgdbgl

;;TY%INT
xgdinu:	movm w2,w3		;GCD ignores sign
	movms o1
	jumpe w2,xgdret		;if either 0 return the other
	jumpe o1,ret1nt
	setz o2,		;binary GCD: find common power of 2
xgdip2:	trnn w2,1
	 trne o1,1
	  jrst xgdime
	lsh o1,-1		;shift both numbers right until 
	lsh w2,-1		; one of them is odd
	aoja o2,xgdip2

xgdime:	tlne w2,1		;make w2 the even one
	 exch w2,o1
xgdilp:	movn w3,w2		;shift right until odd
	eqv w3,w2
	jffo w3,.+2
	 skipa			;(already odd)
	  lsh w2,-35.(w4)
	camge w2,o1		;make w2 the larger one
	 exch w2,o1
	sub w2,o1		;--the difference
	jumpn w2,xgdilp		;continue until 0
	lsh o1,(o2)		;restore power of 2
	setz o2,
xgdret:	tlo o1,(inum0)
	iret

sieve:
	.byte 9
	1. ? 11. ? 13. ? 17. ? 19. ? 23. ? 29. ? 31. ? 37. ? 41. ? 43.
	47. ? 53. ? 59. ? 61. ? 67. ? 71. ? 73. ? 79. ? 83. ? 89. ? 97.
	101. ? 103. ? 107. ? 109. ? 113. ? 121. ? 127. ? 131. ? 137.
	139. ? 143. ? 149. ? 151. ? 157. ? 163. ? 167. ? 169. ? 173.
	179. ? 181. ? 187. ? 191. ? 193. ? 197. ? 199. ? 209.
	.byte
sivsiz:	48.
sivptr:	441100,,sieve

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; PRIME - this is not an official CL function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

prime:	move w2,o1		;find the next prime >=arg
	getnum w2
	call iprime
	jrst ret1nt

iprime:	idivi w2,210.
	imuli w2,210.
	push p,w2
	dmove w4,sivsiz
iprim1:	ildb w2,o1
	camge w2,w3
	 sojg w4,iprim1
	sos w4
	push p,w4
	push p,o1
	add w2,-2(p)
	call iprimp
	jumpn o1,iprim4
iprim2:	dmove w3,-1(p)
	sojle w3,iprim5
iprim3:	ildb w2,w4
	add w2,-2(p)
	dmovem w3,-1(p)
	call iprimp
	jumpe o1,iprim2
iprim4:	dmove w3,-1(p)
	ldb w2,w4
	add w2,-2(p)
	subi p,3
	ret1

iprim5:	dmove w3,sivsiz
	move w2,-2(p)
	addi w2,210.
	movem w2,-2(p)
	jrst iprim3

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; PRIMEP - say if a number is prime.  Not an offical CL function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

primep:	move w2,o1
	getnum w2
	caie w2,2		;2 is prime
	 cain w2,3		;3 is prime
	  jrst rett
	caie w2,5		;5 is prime
	 cain w2,7		;7 is prime
	  jrst rett
	caig w2,10.		;other numbers <= 10 are not
	 jrst retnil
	movei n,1		;returns 1 result
	move w4,w2
	idivi w4,2		;divisible by 2?
	 jumpe o1,[retn]	; yes, not prime
	move w4,w2
	idivi w4,3		;by 3?
	 jumpe o1,[retn]
	move w4,w2
	idivi w4,5		;by 5?
	 jumpe o1,[retn]
	move w4,w2
	idivi w4,7		;by 7?
	 jumpe o1,[retn]
	caige w2,121.		;other numbers less than 11^2 are prime
	 jrst rett		;after this, the number is as if chosen
				;from the sieve table
iprimp:	addi p,5
; -4(p) -- the number in question
; -3(p) -- inner loop count (ranges over the sieve table)
; -2(p) -- byte pointer into sieve table
; -1(p) -- base, for which sieve table contains offsets
;   (p) -- the estimated square root
	movem w2,-4(p)
	jffo w2,.+1		;estimate square root of the #
	move w4,w2		;take a number with half as many bits
	subi w3,36.
	ash w3,-1
	lsh w4,(w3)
	idiv w2,w4		;divide the original # by it
	addi w2,1
	add w2,w4		;and take the average of it and the quotient
	lsh w2,-1
	addi w2,1		;rounding up at every turn so we are sure
	movem w2,(p)		;the estimate is >= the actual root
	dmove w2,sivsiz
	sos w2			;don't try to divide by 1
	ibp w3
	dmovem w2,-3(p)
	setzm -1(p)
pploop:	ildb w2,w3
	add w2,-1(p)
	caml w2,(p)
	 jrst [subi p,5 ? jrst rett]
	move w4,-4(p)
	idiv w4,w2
	jumpe o1,[subi p,5 ? jrst retnil]
	sosle -3(p)
	 jrst pploop
	dmove w2,sivsiz
	dmovem w2,-3(p)
	move w2,-1(p)
	addi w2,210.
	movem w2,-1(p)
	jrst pploop

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; BOOLE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;BOOLE
;o1 - which function
;o2 - arg 1
;o3 - arg 2
boole:	move n,o1		;put SETZ O1,W3 here
	andi n,17		;get number from 0 to 17
	lsh n,29.		;put into bits 074000,,0
;as usual, try to do inum case quickly.
	skpnin o2
	 skpin o3
	  jrst xboole		;may have bignum's
	getnum o2
	getnum o3
	ior n,[setz o2,o3]
	xct n
	maknum o2
	move o1,o2
	setzb o2,o3
	ret1

xboole:	dmove o1,o2		;get args into ac's for DOPTAB
	move w3,o2
	xtype o2		;what's second arg?
	xct doptab(w2)		;above, qv
	 jrst boowho
	xtype o1
	xct a2itab(w2)
boowho:	xct .+1-ty%xfl(w2)	;;TYPES
	jrst booerr		;long flons
	jrst booerr		;iflons
	jrst booerr		;iflons
	jrst booerr		;ratios
	jrst notnum		;complex
	jrst boobig		;bignums
	jrst booerr		;inums [impossible]
	jrst booerr		;inums [impossible]

booerr:	err /BOOLE only takes integers/

;;TY%BIG		booleate bignums
boobig:	ior n,[setz w2,1(o2)]	;make instruction to booleate
	move o3,o1		;save o1
	getsiz w3,o1		;find out how big they are
	getsiz w4,o2
	came w4,w3		;same size?
	 jrst boobds		;no, use general routine
	caie w3,2		;yes: 2 words perchance
	 jrst  boob2		; no...
	dmove w2,1(o3)		;yes, all is very simple (& fast)
	xct n			;setxx w2,1(o2)
	xor n,[<setz w2,1(o2)>#<setz w3,2(o2)>]
	xct n			;setxx w3,2(o2)
	jrst retint

;args same size but >2 wds.  slight simplification.
boob2:	call bigmak		;answ will be the same size
	setz o5,		;this is the which-bigger flag
	push p,0		;this is the size difference
	jrst boobx0

boobds:	setz o5,		;o5=0 ==> o2 is longer
	camg w3,w4		;which is bigger?
	 jrst .+3
	  exch w3,w4		;put bigger size on w4
;normally we would use SETO O5, but this would cause trouble for BIGMAK
	  move o5,[%T]		;can't switch args, use flag
	lsh w3,-1		;smaller size ==> #/dw's
	push p,w3
	call bigmak		;result gets size of larger
	sub w4,(p)		;difference in sizes
	exch w4,(p)		;use smaller for count, save diff
boobx0:	move o4,o1		;result area, use as traveling ptr
;;	jrst boobx2             falls thru

;;the structure of the loops is wierd because it was copied from subtract.
;;first loop is for booleing digits where the numbers coincide;
;;second is to propagate borrowing along the "overhang" or
;;"underhang" of the larger number.

boobx2:	dmove w2,1(o3)
	xct n			;setxx w2,1(o2)
	xor n,[<setz w2,1(o2)>#<setz w3,2(o2)>]
	xct n			;setxx w3,2(o2)
	xor n,[<setz w2,1(o2)>#<setz w3,2(o2)>]
	dmovem w2,1(o4)		;stash
	addi o2,2		;advance pointers
	addi o3,2
	addi o4,2
	sojg w4,boobx2		; are we out of digits
boobx3:	pop p,w4		;difference count
	jumpe w4,boobx9		;if #'s same size, that was it!
	skipn o5		;o5=0 ==> o2 is longer 
	 skipa w2,-1(o3)
	  move w2,-1(o2)
	ash w2,-35.		;propagate the sign of the shorter
	movem w2,work+3		;at +3 in case an arg was at work+0!
	movem w2,work+4
boobx6:	jumpe o5,.+2		;o5=0 ==> o2 is longer
	 xmovei o2,work+2
	jumpn o5,.+2
	 xmovei o3,work+2
	dmove w2,1(o3)
	xct n			;setxx w2,1(o2)
	xor n,[<setz w2,1(o2)>#<setz w3,2(o2)>]
	xct n			;setxx w3,2(o2)
	xor n,[<setz w2,1(o2)>#<setz w3,2(o2)>]
	dmovem w2,1(o4)		;stash
	addi o2,2		;bump pointers
	addi o3,2		;one is superfluous, but we don't know which
	addi o4,2
	sojg w4,boobx6		;out of digits?
boobx9:	setzb o2,o3		;yes: clean up
	setzb o4,o5
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ASH
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;This was called LSH in Elisp, so all the labels use that.  Note that
;LSH and ASH are the same operation when we model a semiinfinite bit
;stream, as we do here.

;;WORK - warning: FIXF replies on the fact that WORK is not used when a
;bignum is passed.
lshf:	move w4,o2		;2nd arg: # of bits to lsh first arg
	skpin o2
lsherr:	 jrst [err /Improper value in arg to LSH/]
	movei n,1		;rtn 1 val
	getnum w4
inlsh:	a1disp			;;TYPES
	jrst lshflo		;a long flon
	jrst lshifl		;iflon
	jrst lshifl		;iflon
	jrst lshrat		;ratio
	jrst notnum		;complex
	jrst lshbig		;bignum
	jrst lshint		;neg int
	jrst lshint		;pos int

;;TY%FLO			floating numbers are scaled
lshflo:	dmove w2,1(o1)
	jfcl 17,.+1
	fsc w2,(w4)
	jov ovrflo
	jrst retflo

;;TY%IFL
lshifl:	lsh o1,4
	jfcl 17,.+1
	fsc o1,(w4)
	jov ovrflo
	jrst retifl

lshrat:	push q,1(o1)
	move o1,(o1)
	call inlsh
	pop q,o2
	jrst rat

;;WORK
lshint:	getnum o1		;
	move w2,o1
	ashc w2,-35.
	dmovem w2,work+1
	cail w4,70.
	 jrst lshiov
	camg w4,[-70.]
	 movni w4,70.
	jfcl 17,.+1
	ashc w2,(w4)
	jov lshiov
	jrst retint

lshiov:	move o1,[object ty%spc,2]
	movem o1,work	;save it in this fixed area
	move o1,[object ty%cbg,<codsec,,work>]
	;jrst lshbig

;;TY%BIG
lshbig:	skipge w2,w4		; separate left and right lsh's
	 jrst lshbng
	jumpe w2,[retn]		;... and none at all
	idivi w2,70.		;# of bits => # of doublewds, bits
	skipe w3		;even dw boundary?
	 aosa w2		;no, bump #dws to cover extra piece
	  movei w3,70.		;call it a 70-bit shift
	getsiz w4,o1		;how big is the number?
	lsh w4,-1		;gives # of dws
	add w4,w2		;original size + amount to lsh = new size
	lsh w4,1		;in wds again
	move o2,o1		;save obj ptr while making new no.
	push p,w2		;save # of dws
	push p,w3		;save # of bits
	call bigmak		;ptr in o1, size/2 in w4
	getsiz w2,o1		;its size
	sos w2			;less one
	move w3,o1
	aos w4,w3		;copy from first element
	aos w4			;...to second
	setzm (w3)		;fill it with zeroes
	xblt w2,
	move o3,o1		;copy to move
	move o4,(p)		;# bits to shift
	subi o4,70.		;--backward
	move o5,(p)		;--forward (see algorithm below)
	move w2,-1(p)		;# dws to shift
	sos w2			;fencepost fudge factor
	lsh w2,1		;use as # of wds
	add o3,w2		;word-shifting by offsetting pointers
	getsiz w4,o2		;of original
	lsh w4,-1		;dws
	dmove w2,1(o2)		;low order dw
	ashc w2,(o5)		;shift left
	dmovem w2,1(o3)		;plunk into place
	soje w4,eolblp		;see if also the high-order dw...
lshbgl:	dadd o2,[2 ? 2]		;main loop: bump both pointers
	dmove w2,1(o2)		;get input dw whose low order bits will fall
	ashc w2,(o5)		;in this output dword, and shift it left
	dmovem w2,1(o3)		;save; then get dw just below, whose high
	dmove w2,-1(o2)		;order bits will fall in the output dw
	tlz w2,400000		;--clear the sign bit--
	ashc w2,(o4)		;shift it *right*
	dadd w2,1(o3)		;put the two together (there's no "dior" inst)
	dmovem w2,1(o3)		;place in output dw
	sojg w4,lshbgl		;loop
eolblp:	dmove w2,1(o2)		;high order dw:
	ashc w2,(o4)		;the right shift part only,
	dmovem w2,3(o3)		; without clearing the sign bit
	setzb o2,o3		;clean up
	setzb o4,o5
	subi p,2
	jrst bgtrim		;and return the number

;this is for right shifts: various things are different
lshbng:	idivi w2,70.		;# of bits => # of doublewds, bits
	getsiz w4,o1		;how big is the number?
	lsh w4,-1		;gives # of dws
	add w4,w2		;original size + amount to lsh = new size
	lsh w4,1		;in wds again
	jumple w4,retzer	;if we're shifting it out of existance
	cain w4,2		;if a single doubleword
	 jrst lshb22		; use special case routine
	move o2,o1		;save obj ptr while making new no.
	push p,w2		;save # of dws
	push p,w3		;save # of bits
	call bigmak		;ptr in o1, size/2 in w4
	move o3,o1		;copy to move
	move o4,(p)		;# bits to shift
	addi o4,70.		;--backward
	move o5,(p)		;--forward (see algorithm below)
	getsiz w4,o3		;size of new no.
	lsh w4,-1		;in dws
	sos w4			;lose one in the process
	move w2,-1(p)		;# dws to shift
	lsh w2,1		;use as # of wds
	sub o2,w2		;word-shifting by offsetting pointers
lshbnl:	dmove w2,1(o2)		;get input dw whose high order bits will fall
	tlz w2,400000		;--clear the sign bit--
	ashc w2,(o5)		;in this output dword, and shift it right
	dmovem w2,1(o3)		;save; then get dw just above, whose low
	dmove w2,3(o2)		;order bits will fall in the output dw
	ashc w2,(o4)		;shift it left
	dadd w2,1(o3)		;put the two together (there's no "dior" inst)
	dmovem w2,1(o3)		;place in output dw
	dadd o2,[2 ? 2]		;bump both pointers
	sojg w4,lshbnl		;loop
eolbnl:	dmove w2,1(o2)		;high order dw:
	ashc w2,(o5)		;the right shift part only,
	dmovem w2,1(o3)		; without clearing the sign bit
	setzb o2,o3		;clean up
	setzb o4,o5
	subi p,2
	jrst bgtrim		;and return the number

lshb22:	getsiz w4,o1		;for cases when only the high-order dw
	add o1,w4		;of arg is used
	move w4,w3		;right shift of 2-wd bignum
	dmove w2,-1(o1)
	ashc w2,(w4)
	jrst retint

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Byte functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;a byte specifier is a cons cell, of which the first is size
;second is position

;BYTE is CONS, but first make sure the pieces are inum's
byte:	camge o1,[inum 0]	;normally, is positive inum
	 jrst byteb1		;bad first arg
byte2:	camge o2,[inum 0]
	 jrst byteb2
;if possible, produce a hardware byte pointer (in the RH)
byted:	move w2,o1
	add w2,o2
	caml w2,[<inum 0>+<inum 36.>] ;less then 36?
	 jrst bytedc		;no, do cons
;we make 35 the maximum because things would get messy if we
; ended up playing with the sign bit.  This is already more
; than an INUM can handle.
;make hardware byte pointer
	lsh o1,24.		;size
	move w3,o2		;position
	lsh w3,30.
	ior o1,w3		;combine in O1
	hlrz o1,o1		;put in RH
	maknum o1		;and make inum
	ret1

bytedc:	docons o1,o1,o2
	ret1

;here if odd first arg
byteb1:	skpin o1		;is it inum?
	 jrst [err1 o1,/Byte size can't be negative: ~S/]
	skpint o1		;maybe bignum?
	 jrst [err1 o1,/Byte size must be integer: ~S/]
	getsiz w4,o1		;find the other end
	add w4,o1		; --with the significant sign bit
	skipge -1(w4)		;is it negative
	 jrst [err1 o1,/Byte size can't be negative: ~S/]
	move o1,[inum 17777777777] ;this is big enough for practical purposes
	jrst byte2

;here if odd second entry
byteb2:	skpin o2		;is it inum?
	 jrst [err1 o2,/Byte position can't be negative: ~S/]
	skpint o2		;maybe bignum?
	 jrst [err1 o2,/Byte position must be integer: ~S/]
	getsiz w4,o2		;find the other end
	add w4,o2		; --with the significant sign bit
	skipge -1(w4)		;is it negative
	 jrst [err1 o2,/Byte position can't be negative: ~S/]
	move o2,[inum 17777777777] ;this is big enough for practical purposes
	jrst byted

;byte-size is CAR for general case
bytsiz:	skpin o1
	 jrst car
	ldb w2,[.bp 007700,o1]	;and this wierd place for INUM
	jrst ret1nt

;byte-position is CDR for general case
bytpos:	skpin o1
	 jrst cdr
	ldb w2,[.bp 770000,o1]	;and this wierd place for INUM
	jrst ret1nt

;O1 - number ;;WORK
doldb:	skpint o2		;integer?
	 jrst notin2		;no - error
	skpin o1		;simple byte pointer?
	 jrst doldbb		;no, use general method
	skpin o2		;bignum?
	 jrst [	move o2,2(o2)	;yes, get low order word
		jrst .+2]
	getnum o2		;no, get bare number
	hrlz o1,o1		;put byte pointer in right place
	hrri o1,o2		;say it points into O2
	ldb w2,o1		;do it
	jrst ret1nt

;general code for byte pointer that is a CONS
doldbb:	doboth o3,o1		;O3 - size; O4 - position
;BYTE made sure these are inum's
	getnum o3
	getnum o4
	jumpe o3,[setzb o3,o4 ? jrst retzer] ;code below blows up if no result
	skpnin o2		;if not bignum, simulate one
	 jrst [	getnum o2
		movem o2,work+2
		ash o2,-35.	;sign-extend this for high order word
		movem o2,work+1
		move o2,[object ty%spc,2]
		movem o2,work
		move o2,[object ty%cbg,<codsec,,work>]
		jrst .+1]
;here when result will not fit in 2 words
	move o5,o3		;size
	idivi o5,70.		;O5 - dw's, O6 - bits
	move w4,o5		;w4 - space needed for result
	skipe o6
	addi w4,1		;now have dw's
	lsh w4,1		;convert to words
	call bigm36		;O1 - result bignum; w4 - size in dw's
   ;o5/o6 are already set  up
   ;o4 has position
   ;o2 has source
   ;o1 has result
	move o3,o4		;position of result in source
	idivi o3,70.		;o3 - offset in dw's; o4 - offset in bits
	movn o4,o4		;need to do right shift
	lsh o3,1
	add o3,o2		;o3 - address of first dw
	getsiz w4,o2
	add o2,w4		;o2 - address beyond source
	move w4,o1		;w4 - address of first dw in result
	move n,-1(o2)		;get high order of last dw
	ash n,-35.		;sign-extend
;n - sign-extend of last dw
;O6 - extra bits in result
;O5 - full-size dw's in result
;O4 - bits to shift
;O3 - address of current dw in source
;O2 - address of dw beyond last dw in source
;w4 - address of current dw in result
;nil/nil1/w2/w3 - temp for computing result dw
ldbbgl:	caml o3,o2		;yes.  this dw exist?
	 jrst [	move w2,n	;no, use sign-extend
		move w3,n
		jrst .+2]
	dmove w2,1(o3)		;yes, use it
	addi o3,2		;get next
	jumpe o4,ldbbns		;if no shift, skip this junk
	caml o3,o2		;get next, to shift in
	 jrst [	move nil,n	;no, simulate it, too
		move nil1,n
		jrst .+2]
	dmove nil,1(o3)
;now we do a 4-word ash
	ashc w2,(o4)		;contribution from last dw
	ashc nil,70.(o4)	;contribution from this dw
	ior w2,nil		;put them together
	ior w3,nil1
ldbbns:	dmovem w2,1(w4)		;and put them in
	addi w4,2
	sojg o5,ldbbgl		;and see if more dw's
;generally, we come here twice:
; 1) with O5 containing 0, when above loop is done.  Then go back
;      once more to compute partial leading dw
; 2) with O5 containing -1, when that dw has been put in
	jumpl o5,ldbprt		;ready to handle partial dw
	jumpn o6,ldbbgl		;if need extra bits, go back again
;here when we don't need any partial word
	movsi w2,400000
	andcam w2,-1(w4)	;result is always positive
ldbbgx:	setzb o2,o3
	setzb o4,o5
	setzb nil,nil1
	jrst bgtrim		;return this result

;here when we just computed a partial dw.  Need O6 bits of it
;W2/W3 still contains the DW
ldbprt:	movei o5,70.
	sub o5,o6		;70-n: number of bits to chop off
	ashc w2,(o5)
	tlz w2,400000		;fill with zero's, as this is non-neg
	movn o5,o5		;now shift back
	ashc w2,(o5)
	dmovem w2,-1(w4)	;and put it back
	setz o6,
	jrst ldbbgx

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; MASK-FIELD
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1 - number ;;WORK
mskfld:	skpint o2		;integer?
	 jrst notin2		;no - error
	skpin o1		;simple byte pointer?
	 jrst mskbig		;no, use general method
	skpin o2		;bignum?
	 jrst [	move o2,2(o2)	;yes, get low order word
		jrst .+2]
	getnum o2		;no, get bare number
	hrlz o1,o1		;put byte pointer in right place
	hrri o1,o2		;say it points into O2
	ldb w2,o1		;get the field
	ldb w3,[.bp 770000000000,o1] ;get position
	lsh w2,(w3)		;put the field back where it goes
	jrst ret1nt

;general code for byte pointer that is a CONS
mskbig:	doboth o3,o1		;O3 - size; O4 - position
;BYTE made sure these are inum's
	getnum o3
	getnum o4
	jumpe o3,[setzb o3,o4 ? jrst retzer] ;code below blows up if no result
	skpnin o2		;if not bignum, simulate one
	 jrst [	getnum o2
		movem o2,work+2
		ash o2,-35.	;sign-extend this for high order word
		movem o2,work+1
		move o2,[object ty%spc,2]
		movem o2,work
		move o2,[object ty%cbg,<codsec,,work>]
		jrst .+1]
;here when result will not fit in 2 words
	move o5,o3		;to end of requested byte
	add o5,o4		;bit number
	idivi o5,70.		;o5 - dw's, o6 - bits
	move w4,o5		;size of output in dws
	skipe o6		;round up
	addi w4,1
	lsh w4,1		;and convert to words
	call bigm36		;O1 - result bignum; w4 - size in dw's
	setzm 1(o1)		;clear it
	move w2,w4		;word count
	lsh w2,1
	xmovei w3,1(o1)
	xmovei w4,2(o1)
	xblt w2,
   ;o5/o6 are already set  up
   ;o4 has position
   ;o2 has source
   ;o1 has result
	move o3,o4		;position of result in source
	idivi o3,70.		;o3 - offset in dw's; o4 - offset in bits
	sub o5,o3		;O5 is full dws to copy
	movn o4,o4		;need to do right shift
	lsh o3,1		;offset to first dw
	move w4,o1		;w4 - address of first dw in result
	add w4,o3
	add o3,o2		;o3 - address of first dw in source
	getsiz w2,o2
	add o2,w2		;o2 - address beyond source
	move n,-1(o2)		;get high order of last dw
	ash n,-35.		;sign-extend
;n - sign-extend of last dw
;O6 - bits in last word of result
;O5 - full-size dw's in result
;O4 - bits to shift
;O3 - address of current dw in source
;O2 - address of dw beyond last dw in source
;w4 - address of current dw in result
;nil/nil1/w2/w3 - temp for computing result dw
	jrst .+2		;first time, do want to clear low order bits
mskbgl:	setz o4,		;second time through, no need to clear loword
	caml o3,o2		;yes.  this dw exist?
	 jrst [	move w2,n	;no, use sign-extend
		move w3,n
		jrst .+2]
	dmove w2,1(o3)		;yes, use it
	addi o3,2		;advance for next
	jumpe o4,mskbns		;if no shift, skip this junk
;now clear the bits below this
	ashc w2,(o4)		;contribution from last dw
	movn o4,o4
	ashc w2,(o4)
mskbns:	dmovem w2,1(w4)		;and put them in
	addi w4,2
	sojg o5,mskbgl		;and see if more dw's
;generally, we come here twice:
; 1) with O5 containing 0, when above loop is done.  Then go back
;      once more to compute partial leading dw
; 2) with O5 containing -1, when that dw has been put in
	jumpl o5,mskprt		;ready to handle partial dw
	jumpn o6,mskbgl		;if need extra bits, go back again
;here when we don't need any partial word
	movsi w2,400000
	andcam w2,-1(w4)	;result is always positive
mskbgx:	setzb o2,o3
	setzb o4,o5
	jrst bgtrim		;return this result

;here when we just computed a partial dw.  Need O6 bits of it
;W2/W3 still contains the DW
;o4 is position within the double-word
mskprt:	movei o5,70.
	sub o5,o6		;70-n: number of bits to chop off
	ashc w2,(o5)
	tlz w2,400000		;fill with zero's, as this is non-neg
	movn o5,o5		;now shift back
	ashc w2,(o5)
	dmovem w2,-1(w4)	;and put it back
	setz o6,
	jrst mskbgx

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; DPB
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;O1 - new byte, O2 - byte spec, O3 - integer
dodpb:	skpint o3		;integer?
	 jrst notin2		;no - error
	skpin o2		;simple byte pointer?
	 jrst dodpbb		;no, use general method
	skpin o3		;bignum?
	 jrst [	move w2,2(o3)	;yes, get low order word
		jrst .+3]
	move w2,o3		;put first data word in w2
	getnum w2
	hrlz w3,o2		;put byte pointer in right place
	hrri w3,w2		;say it points into w2
	skpin o1		;is O1 a bignum?
	 jrst [	move w4,2(o1)	;yes, get its loworder word
		jrst .+3]
;use W4 instead of O1 because we may do a BIGMAK below
	move w4,o1
	getnum w4		;no, get value
	dpb w4,w3		;do it
	skpnin o3		;is data word a bignum?
	 jrst ret1nt		;yes, just return the result
;here if the data word is a bignum.  We have to copy it.
	getsiz w4,o3		;make place to put copy
	call bigmak		;result in O1
	move nil1,w2		;put new value in NIL1
	getsiz w2,o3		;number of words
	addi w2,1		;copy header also
	xmovei w3,(o3)		;source
	xmovei w4,(o1)		;destination
	xblt w2,
	movem nil1,2(o1)	;put in new word
	setz nil1,
	ret1
;o1 - new byte
;o2 - byte spec
;o3 - integer
;general code for byte pointer that is a CONS
dodpbb:	doboth o4,o2		;O4 - size; O5 - position
;BYTE made sure these are inum's
	getnum o4
	getnum o5
	jumpe o4,[setzb o4,o5 ? jrst retzer] ;code below blows up if no result
	skpnin o3		;if not bignum, simulate one
	 jrst [	getnum o3
		movem o3,work+2
		ash o3,-35.	;sign-extend this for high order word
		movem o3,work+1
		move o3,[object ty%spc,2]
		movem o3,work
		move o3,[object ty%cbg,<codsec,,work>]
		jrst .+1]
;now a place to put the result.  The size is MAX of the original size
;and the end of the new position.  Copy original into it, sign-extending
;if necessary
	getsiz w4,o3		;size of original
	tlo w4,(<object(ty%spc,0)>)	;make gc skip wd
	push free,w4		;invalid gc state starts here
	move w3,free		;result is in W3 for the moment
	tlo w3,(object(ty%big,0))	;...
	tlz w4,(<object(ty%spc,0)>)	;...
	add free,w4		;... and ends here
	exch w3,o3		;result now in O3, original in W3
;copy original data to result
	getsiz w2,w3		;count in w2
	xmovei w3,1(w3)		;source
	xmovei w4,1(o3)		;result
	xblt w2,
	move n,[tlz w2,400000]	;N is instruction to set sign
	skipge -1(w4)
	 move n,[tlo w2,400000]
;now see if we need anything more because position goes beyond high-order
;end of original
	move w2,o4		;bit number at end of field
	add w2,o5
	idivi w2,70.		;convert to double-words
	push p,w2		;save bit data for end
	push p,w3
	skipe w3		;round up
	addi w2,1
	lsh w2,1		;convert to words
	getsiz w3,o3		;current size
	camg w2,w3		;any more to do?
	 jrst dpbnmr		;no more
	sub w2,w3
	add free,w2
	addm w2,(o3)		;also extend count of result
	move w3,-1(w4)		;last word we copied
	ash w3,-35.		;make it 0 or -1
	movem w3,(w4)		;use it as next
	move w3,w4		;resume here
	xmovei w4,1(w4)		;and just propagate first word
	subi w2,1
	xblt w2,
;now we have a place to put the new byte. Current AC's are
;O1 - new byte
;O3 - result
;O4 - size of byte
;O5 - position of byte
;P - saved dw's and bits of end of field
;N - instruction to set sign bit in W2
dpbnmr:	skpnin o1		;if not bignum, simulate one
	 jrst [	getnum o1
		movem o1,work+2
		ash o1,-35.	;sign-extend this for high order word
		movem o1,work+1
		move o1,[object ty%spc,2]
		movem o1,work
		move o1,[object ty%cbg,<codsec,,work>]
		jrst .+1]
	idivi o5,70.		;O5 - leading dw's; O6 - leading bits
	move o2,o1		;O2 - initial source addr [needs +1]
	move o1,o3		;O1 - final result
	move w2,o5
	lsh w2,1
	add o3,w2		;O3 - initial result addr [needs +1]
	sub o5,-1(p)		;O5 - minus number of DW's
	movn o5,o5
	movn o4,o6
	getsiz w2,o2		;analyze source
	add w2,o2
	push p,w2
	move w2,-1(w2)		;get highorder word
	ash w2,-35.		;sign extend
	push p,w2
;O6 - bit offset to field
;O5 - full-size dw's in field
;O4 -  - bit offset to field
;O3 - address of current dw in result
;O2 - address of current dw in source
;N - instruction to set result sign into W2
;nil/nil1/w2/w3 - temp for computing result dw
;P: -3: dw addr of end of field
;   -2: bit addr of end of field
;   -1: pointer to end of source
;   0 : sign extend of source
	dmove w2,1(o3)		;get result dw
	ashc w2,70.(o4)		;get rid of unneeded bits
	tlz w2,400000		;fill with 0's
	ashc w2,-70.(o6)	;and put back in normal place
	dmove nil,1(o2)		;first dw of new byte
	ashc nil,(o6)		;shift into position
	ior w2,nil		;put them together
	ior w3,nil1
	xct n			;set sign in W2
	jumple o5,dpbprt	;last word to do - handle specially
	dmovem w2,1(o3)		;put it back in result
;now do interior words
	sojle o5,dpbbnx		;stop if no full words to do
dpbbnl:	addi o2,2
	addi o3,2
	camle o2,-1(p)		;anything left in source?
	jrst [	move w2,(p)	;no, use sign-extension
		move w3,(p)
		jrst .+2]
	dmove w2,-1(o2)		;get word we used before
;this is a 4-register right shift
	tlz w2,400000		;fill with 0's
	ashc w2,-70.(o6)	;shift out the bits we used last time
	caml o2,-1(p)		;anything left in source?
	jrst [	move nil,(p)	;no, use sign-extension
		move nil1,(p)
		jrst .+2]
	dmove nil,1(o2)		;get next double-word
	ashc nil,(o6)		;get those bits from next word
	ior w2,nil
	ior w3,nil1		;put them together
	xct n			;set sign in W2
	jumple o5,dpbprt	;last word to do - handle specially
	dmovem w2,1(o3)		;put them in result
	sojg o5,dpbbnl		;keep doing for all full words
;here after we have finished all full words
dpbbnx:	jumpl o5,dpbprt		;ready to handle partial dw
	skipe -2(p)		;if extra bits
	jrst dpbbnl		;then do them
dpbbgx:	setzb o2,o3
	setzb o4,o5
	setzb nil,nil1
	setz o6,
	subi p,4
;we played with FREE above, but didn't do a GC because all the
;regs were messed up.
	camle free,lastl	;see if need GC
	 call sgc
	jrst bgtrim		;return this result

;here when we are working on a partial word, i.e. a word where
;the new data does not include the high-order bit of the result
;W2/W3 contains the new dw
dpbprt:	movei o6,70.
	sub o6,-2(p)		;70-n: number of bits to chop off
	ashc w2,(o6)
	movn o6,o6
	tlz w2,400000		;fill with 0
	ashc w2,(o6)		;now put back in right place
	dmove nil,1(o3)		;original dw
	movn o6,-2(p)		;number of bits to come from new data
	ashc nil,(o6)		;kill those in old dw
	movn o6,o6
	ashc nil,(o6)
	ior w2,nil		;now combine them
	ior w3,nil1
	dmovem w2,1(o3)		;and put in new data
	jrst dpbbgx		;now exit

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; INTEGER-LENGTH
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;note to the reader:  this function has had the "new bignum" fix
; applied to it, plus common-lisp specific fixes.  Don't restore
; it to the Elisp definition.

intlen:	camge o1,[object ty%big,0]
	 jrst [err1 o1,/Not an integer/]
	skpin o1
	 jrst ilbig
	move w2,o1
	getnum w2
	skipge w2
	setcm w2,w2		;by common-lisp defn, we complement negatives
	jffo w2,.+2		;number of leading zeros to O2
	 movei w3,36.		;if no 1 found, say all leading zeros
	move o1,[inum 36.]	;convert from leading zeros to digits
	subb o1,w3		;put result in O2 also so it is legal Lisp obj
	ret1

ilbig:	getsiz w4,o1
	add o1,w4		;addr of high order dw
	dmove w2,-1(o1)		;get it
;by common lisp definition, we complement negative numbers
;the result can't be all zero's, since that is the result
;of a leading -1, which would have been normalized away
	jumpge w2,.+4
	 setcm w2,w2
	 setcm w3,w3
	 tlz w3,400000
	jumpn w2,.+3
	 subi w4,1
	 move w2,w3
	imuli w4,35.
	jffo w2,.+1
	subi w3,1
	sub w4,w3
	maknum w4
	move o1,w4
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Some predicates
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;numberp
;;TYPES
nump:	skpnum o1
	 jrst retnil
	jrst rett

;zerop
zerop:	camn o1,[inum0] ;first check for most common
	 jrst rett		;it is
	skpnin o1		;else if inum not 0
	 jrst retnil
	xnmtyp o1		;then try the rest
	xct zeropt(w2)

;;[Victor] Some BOOLE operation creates the bignum 0, so check for it
;;TY%BIG
zpbig:	getsiz w2,o1		;find out how big it is
zpbigl:	sojl w2,rett
	skipe 1(o1)
	 jrst retnil
	addi o1,1
	jrst zpbigl

;;TYPES
zeropt:	jrst zeropr		; real
	jrst retnil		; neg iflon
	jrst zpifl		; pos iflon
	jrst zprat		;ratio
	jrst notnum		;complex
	jrst zpbig		;[Victor] (was: bignum -- 0 is an inum)
	jrst syserr		;already tested for
	jrst syserr		;already tested for

syserr:	err /Impossible error/

zpifl:	camn o1,[object ty%lpf,0]
	 jrst rett
	jrst retnil

;;TY%FLO
zeropr:	skipn 1(o1)
	 skipe 2(o1)
	  jrst retnil
	jrst rett

;;TY%RAT
zprat:	docar o1,o1		;a ratio is zero only if
	jrst zerop		;the numerator is

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 1-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;SUB1
;we try to handle small integers quickly
sub1:	sos o1
	movei n,1		;returns 1 result
	skpnin o1		;if underflow or not an inum
	 retn			;that's usually it...
	aos o1			;..we jumped the gun
	xnmtyp o1		;what kind of number
	xct sub1t(w2)

;;TYPES
sub1t:	jrst s1lflo		;long flon
	jrst s1iflo		;neg iflon
	jrst s1iflo		;pos iflon
	jrst sb1rat		;ratio
	jrst notnum		;complex (not implemented)
	jrst sb1big		;bignum
	jrst s1uflo		;arg was smallest inum, rtn a bignum
	jrst syserr		;(pos inums)
	
;;TY%FLO
s1lflo:	movflo o1		;can't overflow
	dfsb w2,[1.0 ? 0]
	jrst retflo

;;TY%IFL
s1iflo:	lsh o1,4		;save type bits
	fsbri o1,(1.0)		;can't overflow
	jrst retifl

;;TY%INT
;;TY%BIG
; inum underflow, only one possible value
s1uflo:	dmove w2,[-1 ? -020000000001]
	jrst retbig

;;TY%RAT
sb1rat:	dmove o1,(o1)		;(a/b)-1 = (a-b)/b
	push q,o2		;furthermore, lowest terms are preserved
	call diff
	pop q,o2
	jrst rltrat

sb1big:	move o2,[inum 1]	;note the incredibly sophistocated
	jrst diff		;way this is done...

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 1+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;ADD1
;we try to handle small integers quickly
add1:	aojl o1,a1oflo		;overflo of inum makes word negative
	movei n,1		;returns 1 result
	skpnin o1	;was it an inum after all?
	 retn			;...yes
	sos o1			;no--undo our overeager incrementation
	xnmtyp o1		;what kind of number
	xct add1t(w2)

;;TYPES
add1t:	jrst a1lflo		;long flon
	jrst a1iflo		;neg iflon
	jrst a1iflo		;pos iflon
	jrst ad1rat		;ratio
	jrst notnum		;complex (not implemented)
	jrst ad1big		;bignum
	jrst syserr		;inums should have been gotten above
	jrst syserr		;(pos inums)

;;TY%INT
;;TY%BIG
; inum overflow. there's only one possible value...
a1oflo:	dmove w2,[0 ? 020000,,0]
	jrst retbig

;;TY%FLO
a1lflo:	movflo o1
	dfad w2,[1.0 ? 0]	;can't overflow
	jrst retflo

;;TY%IFL
a1iflo:	lsh o1,4		;move the type bits out of harm's way
	fadri o1,(1.0)		;can't overflow
	jrst retifl

;;TY%RAT
ad1rat:	dmove o1,(o1)		;(a/b)+1 = (a+b)/b
	push q,o2		;furthermore, lowest terms are preserved
	call plus
	pop q,o2
	jrst rltrat

ad1big:	move o2,[inum 1]	;note the incredibly sophistocated
	jrst plus		;way this is done...

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; MINUSP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;minusp
minusp:	xnmtyp o1
	xct minupt(w2)		;skip if negative
	 tdza o1,o1		;nil
	  move o1,[%T]		;T
	ret1

;;TYPES
minupt:	skipl 1(o1)		; long flon  ;;TY%FLO
	skipa			;minus iflons
	jfcl			;plus flons
	jrst [docar(o1,o1) ? jrst minusp]  ;ratio ;;TY%RAT
	jrst notnum		; complex (not implemented)
	jrst mnpbig		; bignum
	skipa			; neg inums
	jfcl			; pos inums

;;TY%BIG
mnpbig:	getsiz w4,o1		;find the other end
	add w4,o1		; --with the significant sign bit
	skipl -1(w4)		;is it negative
	 jrst retnil		; no
	jrst rett		;yes

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; PLUSP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;plusp
plusp:	xnmtyp o1
	xct pluspt(w2)		;skip if positive
	 tdza o1,o1		;nil
	  move o1,[%T]		;T
	ret1

;;TYPES
pluspt:	skipg 1(o1)		; long flon  ;;TY%FLO
	jfcl			;minus iflons
	camn o1,[iflon 0.0]	;plus flons
	jrst [docar(o1,o1) ? jrst plusp]  ;ratio ;;TY%RAT
	jrst notnum		; complex (not implemented)
	jrst plpbig		; bignum
	jfcl			; neg inums
	camn o1,[inum 0]	; pos inums

;;TY%BIG
;zero isn't a bignum, so it is enough to check the highorder word
;for .GE. 0.
plpbig:	getsiz w4,o1		;find the other end
	add w4,o1		; --with the significant sign bit
	skipge -1(w4)		;is it positive?
	 jrst retnil		; no
	jrst rett		;yes

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ABS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;abs
absf:	movei n,1		;returns 1 result
	xnmtyp o1
	xct absft(w2)
	jrst notnum

;;TYPES
absft:	jrst absflo		;long flons
	jrst absifl		;neg iflons
	retn			;pos iflons
	jrst absrat		;ratios
	jrst notnum		;complex
	jrst absbig		;bignum
	jrst absinu		;neg inum
	retn			;pos inum

;;TY%INT
absinu:	tlo o1,760000
	movns o1
	camn o1,[020000,,0]
	 jrst a1oflo
	tlo o1,(inum0)
	retn

;;TY%FLO
absflo:	dmovn w2,1(o1)
	jumpge w2,retflo
	retn

;;TY%IFL
absifl:	lsh o1,4		;save type bits
	movns o1		;we know it's negative
	jrst retifl

;;TY%RAT
absrat:	push q,1(o1)		;save the denominator
	move o1,(o1)		;abs the numerator
	call absf
	pop q,o2
	jrst rltrat		;still in lowest terms

absbig:	getsiz w4,o1		;find the other end
	add w4,o1		; --with the significant sign bit
	skipl -1(w4)		;is it negative
	 retn			; no, return it
	jrst exnegb		;yes, negate it

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; >  >=  <=  <
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

egreat:	jrst rett		;1 always succeeds
	jrst greatp		;2 - do operation directly
	jrst [push p,[codsec,,greatp] ? jrst mono3] ;3
	jrst [push p,[codsec,,greatp] ? jrst mono4] ;4
	jrst [push p,[codsec,,greatp] ? jrst mono5] ;5
	jrst [push p,[codsec,,greatp] ? jrst monon]

egrete:	jrst rett		;1 always succeeds
	jrst greate		;2 - do operation directly
	jrst [push p,[codsec,,greate] ? jrst mono3] ;3
	jrst [push p,[codsec,,greate] ? jrst mono4] ;4
	jrst [push p,[codsec,,greate] ? jrst mono5] ;5
	jrst [push p,[codsec,,greate] ? jrst monon]

elessp:	jrst rett		;1 always succeeds
	jrst lessp		;2 - do operation directly
	jrst [push p,[codsec,,lessp] ? jrst mono3] ;3
	jrst [push p,[codsec,,lessp] ? jrst mono4] ;4
	jrst [push p,[codsec,,lessp] ? jrst mono5] ;5
	jrst [push p,[codsec,,lessp] ? jrst monon]

elesse:	jrst rett		;1 always succeeds
	jrst lesse		;2 - do operation directly
	jrst [push p,[codsec,,lesse] ? jrst mono3] ;3
	jrst [push p,[codsec,,lesse] ? jrst mono4] ;4
	jrst [push p,[codsec,,lesse] ? jrst mono5] ;5
	jrst [push p,[codsec,,lesse] ? jrst monon]


greatp:	xmovei n,[camg o1,o2 ? jumpg w2,rett ? camg o1,w3 ? camle o1,-1(w3)
		  camle o2,o1 ? jumpg o1,xlprtt ? jumpl o1,xlprnl
		  jumpg o2,xlprtt ? skipg w3,-1(w3) ? jumpg w2,rett
		  skipg w2 ? jumpg w3,retnil ? jumpg w4,rett ? soje w4,xlprnl]
	jrst bincmp

greate:	xmovei n,[camge o1,o2 ? jumpge w2,rett ? camge o1,w3 ? camle o1,-1(w3)
		  camle o2,o1 ? jumpg o1,xlprtt ? jumpl o1,xlprnl
		  jumpg o2,xlprtt ? skipg w3,-1(w3) ? jumpg w2,rett
		  skipg w2 ? jumpg w3,retnil ? jumpg w4,rett ? soje w4,xlprtt]
	jrst bincmp

lessp:	xmovei n,[caml o1,o2 ? jumpl w2,rett ? caml o1,w3 ? camge o1,-1(w3)
		  camge o2,o1 ? jumpl o1,xlprtt ? jumpg o1,xlprnl
		  jumpg o2,xlprnl ? skipl w3,-1(w3) ? jumpl w2,rett
		  skipl w2 ? jumpl w3,retnil ? jumpl w4,rett ? soje w4,xlprnl]
	jrst bincmp

lesse:	xmovei n,[camle o1,o2 ? jumple w2,rett ? camle o1,w3 ? camge o1,-1(w3)
		  camge o2,o1 ? jumpl o1,xlprtt ? jumpg o1,xlprnl
		  jumpg o2,xlprnl ? skipl w3,-1(w3) ? jumpl w2,rett
		  skipl w2 ? jumpl w3,retnil ? jumpl w4,rett ? soje w4,xlprtt]
	jrst bincmp

;the comments are for greaterp
bincmp:	skpnin o1
	 skpin o2
	  jrst lessp1
				xct 0(n)
	;camg o1,o2	
	 jrst retnil
	jrst rett

lessp1:	move w3,o2
	push p,n		;some conversion routines use this
	xtype o2		;what's second arg?
	xct doptab(w2)		;above, qv
	 jrst xlessp
	xtype o1
	xct a2itab(w2)
xlessp:	pop p,n
	xct .+1-ty%xfl(w2)	;;TYPES
	jrst xlpflo		;long flons
	jrst xlpifl		;iflons
	jrst xlpifl		;iflons
	jrst xlprat		;ratios
	jrst notnum		;complex
	jrst xlpbig		;bignums
	jrst xlpifl		;inums (can't get here, but if we could,
	jrst xlpifl		;inums  the same instrs would work.)

;;TY%FLO
xlpflo:	dmove w2,1(o1)
	dfsb w2,1(o2)
				 xct 1(n)
	;jumpg w2,rett
	jrst retnil

;;TY%IFL
xlpifl:				xct 2(n)
	;camg o1,w3
	 jrst retnil
	jrst rett

; compare two rats (why?)
;	a     c           
;      --- < ---    =      ad < bc
;	b     d 

xlprat:	pushcar q,o1		;a
	pushcdr q,o2		;d
	docdr o1,o1		;b
	docar o2,o2		;c
	push p,n
	call times		;bc
	exch o1,-1(q)		;a
	pop q,o2		;d
	call times		;ad
	pop q,o2		;bc
	pop p,n
	jrst bincmp

xlpbig:	getsiz w2,o1
	getsiz w3,o2
	came w2,w3
	 jrst xlpdfs		;different sizes
	move w4,w3
	lsh w4,-1
	add w2,o1
	add w3,o2		;get high-order part
	dmove o1,-1(w2)
				xct 3(n)
	;camle o1,-1(w3)	;this part definitely succeeds?
	 jrst xlprtt
	came o1,-1(w3)		;this part definitely fails?
	 jrst xlprnl
	move o1,(w3)		;get 2nd word of this 2-wd pair
	tlz o1,400000
	tlz o2,400000
				xct 4(n)
	;camle o2,o1		;this part definitely succeeds?
	 jrst xlprtt
	came o2,o1		;this part definitely fails?
	 jrst xlprnl
				xct 15(n)
	;soje w4,xlprnl		;stop if equal, say NIL
	hrlzi o3,400000
xlpmlp:	subi w2,2		;now loop on other 2-wd chunks
	subi w3,2
	andcam o3,-1(w2)
	andcam o3,-1(w3)
	dmove o1,-1(w2)
	dsub o1,-1(w3)
				xct 5(n)
	;jumpg o1,xlprtt	;this part definitell succeeds
				xct 6(n)
	;jumpl o1,xlprnl	;this part definitely fails
;NB: we only need the JUMPG in the following, since if the thing
;is negative, the first test will catch it
				xct 7(n)
	;jumpg o2,xlprtt	;this part definitely succeeds
				xct 15(n)
	;soje w4,xlprnl		;stop if equal, say NIL
	jrst xlpmlp
xlprnl:	setzb o2,o3
	jrst retnil

xlprtt:	setzb o2,o3
	jrst rett

;different sizes, sizes in w2, w3
;if sizes are diff, values can't be the same.  First test
;for different signs, then compare the sizes to get the values
xlpdfs:	move w4,w2
	sub w4,w3
	add w2,o1
	add w3,o2
	move w2,-1(w2)
				xct 10(n)
	;skipg w3,-1(w3)
				 xct 11(n)
	 ;jumpg w2,rett
				xct 12(n)
	;skipg w2
				 xct 13(n)
	 ;jumpg w3,retnil
	xor w4,w2
				xct 14(n)
	;jumpg w4,rett
	jrst retnil


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; /=   no duplicates
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

allne:	jrst rett		;1 arg- trivial
	jrst [call eqp ? jrst not]  ;2 arg- do binary
	jrst [	push q,o1 ? push q,o2 ? push q,o3 ? movei n,3
		jrst allnel]	;3 arg - do the loop
	jrst [  push q,o1 ? push q,o2 ? push q,o3 ? push q,o4
		movei n,4 ? jrst allnel]  ;4 arg
	jrst [  push q,o1 ? push q,o2 ? push q,o3 ? push q,o4
		push q,o5 ? movei n,5 ? jrst allnel]
	push q,o1
	push q,o2
	push q,o3
	push q,o4
	push q,o5
;here with all args on stack, and number in N
;use simple n-squared comparison
allnel:	push p,n
	push p,n
	addi q,1
;outer loop - first target is each in turn
allnl:	subi q,1		;kill one on stack each time
	sosg n,-1(p)		;any more in outer loop?
	jrst allney		;no, return yes
	movem n,(p)
;inner loop - second targe is all others
allnil:	sosge n,(p)		;any more comparisons?
	jrst allnl		;no, advance outer loop
	move o1,(q)		;yes, get the args
	movni n,1(n)		;offset from top of Q for second
	add n,q
	move o2,(n)
	call eqp
	jumpn o1,allnen		;found an equal pair, fail
	jrst allnil		;no, advance inner loop

;here if all comparisons fail.  We will have removed all from the stack
allney:	move o1,[%T]
	subi p,2
	subi q,1
	ret1

;here if a comparison succeeds.  have 1+N things on stack
allnen:	move n,-1(p)		;how many on stack
	subi q,1(n)		;make stack offset
	subi p,2
	move o1,nil
	ret1

	consta
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Irrational functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;
;;; One-arg Fortran functions
;;;;;;;;;;;;;

define mktrig (l,s,d)
	.global s,d
l:	call trigar
	move o1,[ifiw s
		   ifiw d] (w4)
	jrst trigfn
	termin

mktrig lsqrt,sqrt.,dsqrt.
mktrig lacos,acos.,dacos.
mktrig lasin,asin.,dasin.
mktrig lcos,cos.,dcos.
mktrig lcosh,cosh.,dcosh.
mktrig lexp,exp.,dexp.
mktrig lsin,sin.,dsin.
mktrig lsinh,sinh.,dsinh.
mktrig ltan,tan.,dtan.
mktrig ltanh,tanh.,dtanh.
mktrig lllog,alog.,dlog.
mktrig llatan,atan.,datan.

.global flgv.,flgon.,forer.,mther.
	flgv.==0
	flgon.==0

;generic code for trig functions
trigfn:	push p,[codsec,,retif ? codsec,,retflo](w4) ;routine to return val
        dmovem w2,reaarg
        push p,q                ;Q is arg reg
        movem p,lispp           ;save for error handling
        xmovei q,arglis
        pushj p,(o1)
        pop p,q
        dmove w2,nil
        setzb nil,nil1
	iret

;;;;;;;;;;;;;;;;;;;;
;; 2-arg Fortran functions
;;;;;;;;;;;;;;;;;;;;

define mktri2 (l,s,d)
	.global s,d
l:	push p,[ifiw [ifiw s
		      ifiw d]]
	jrst trigf2
	termin

mktri2 lexpt,exp3.,dexp3.
mktri2 latan2,atan2.,datn2.

;two-arg function
trigf2:	push q,o2
	call trigar		;first arg
	push p,w4		;save type flag
	dmovem w2,reaarg
	pop q,o1
	call trigar		;second arg
	dmovem w2,reaar2
	pop p,w3
	and w4,w3		;only use d.p. if both are
	move w3,[codsec,,retif ? codsec,,retflo](w4) ;routine to return val
	exch w3,(p)		;get back addrs of function
	add w3,w4
        push p,q                ;Q is arg reg
        movem p,lispp           ;save for error handling
        xmovei q,argli2
        pushj p,@(w3)
        pop p,q
        dmove w2,nil
        setzb nil,nil1
	iret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Odd things
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;ATAN - use 1 or 2-arg Fortran form
latan:	jrst llatan
	jrst latan2

;;;; LOG - use 1-arg Fortran or divide
llog:	jrst lllog		;one arg, this one is easy
;two args, we want log 1/log 2
	push q,o2
;first arg
	call trigar		;first arg
	push p,w4		;save type flag
	dmovem w2,reaarg
        push p,q                ;Q is arg reg
        movem p,lispp           ;save for error handling
        xmovei q,arglis
        pushj p,@[ifiw alog.
		  ifiw dlog.](w4)
	dmovem nil,reaar2	;save result of first in reaar2
	setzb nil,nil1		;trigar needs this
;second arg
	move q,(p)		;get back q
	pop q,o1
	call trigar
	andm w4,-1(p)		;save final result flag
	dmovem w2,reaarg
	xmovei q,arglis
	pushj p,@[ifiw alog.
		  ifiw dlog.](w4)
;now compute the result
	dmove w2,reaar2		;get back first result
	dfdv w2,nil		;compute final result
	setzb nil,nil1		;back to lisp context
	pop p,q	
	pop p,w4		;flag
	subi q,1		;don't need saved arg now
	jrst @[ifiw retif
	       ifiw retflo](w4)


;
forer.: pushj p,forpt           ;print error message
;
forpt:  push p,nil1             ;save a register
        move nil1,-1(p)         ;get old PC
        ldb nil1,[.bp 17_23.,-1(nil1)] ;get AC field from XCT
        cain nil1,10            ;string specified?
        skipa nil1,@-1(17)      ;load address of string
        movei nil1,[asciz /Overflow/] ;default
        tlo nil1,777777         ;make ASCIZ
        esout
        hrroi nil1,[asciz /
/]                              ;end with CRLF
        psout
        pop p,nil1              ;restore reg
        aos (p)                 ;skip arg to XCT
        popj p,

mther.: exch a,(p)              ;t1 - addr of error block
        move a,4(a)             ;byte pointer
        esout%                  ;? and message
        move p,lispp            ;get back saved P
        pop p,q                 ;and Q
        setzb nil,nil1		;make sure we are in lisp
	err /Error from Fortran/	

repeat 0,[  ;at the moment random is done in Lisp
random: push p,q
        movem p,lispp           ;save for error handling
        movei q,ranarg
        pushj p,ran
        pop p,q
        move w2,nil
        setz w3,
        setzb nil,nil1
        jrst @[codsec,,retif]

        0
ranarg: 0
        0
;
lsetrn: movei w4,setran
        jrst intin

;here to pass an integer, Lisp version in O1
intin:  pushj p,@[codsec,,get1nt]
        movem w2,reaarg         ;put down the arg
        push p,q                ;save Q, which is arg reg
        movem p,lispp           ;save for error handling
        xmovei q,irglis
        pushj p,(w4)
        pop p,q
        setz o1,
        setzb nil,nil1
        popj p,

lsavrn: movei w4,savran
        jrst intout

intout: push p,q
        movem p,lispp           ;save for error handling
        xmovei q,irglis
        pushj p,(w4)
        pop p,q
        move w2,reaarg
        setzb nil,nil1
        jrst @[codsec,,ret1nt]

] ;repeat 0

starti:
       
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; overflow
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;The following code is the overflow/underflow handler.  This is
;needed for the Fortran stuff to work right.  In order to avoid
;rewriting all of this code, we use the same AC's as in Pascal.
;This means we will have to restore Lisp context at the end.

        ovr==1_35.      ;any overflow
        cry0==1_34.     ;carry 0
        cry1==1_33.     ;carry 1
        fov==1_32.      ;some floating pt. error
        fxu==1_24.      ;floating underflow
        ndv==1_23.      ;some division by zero

t==0	;Pascal ac definitions (yuck)
a==1
b==2
c==3
d==4
e==5
f==6
g==7
h==10

;The following routines are called from the Lisp level routines to
;set the action for floating divide check, overflow, and underflow.
;The action is a single Lisp inum:  0=correct, 1=warn&correct, 2=Lisp error,
;3=do nothing.   The Lisp routines do type checking.

fedact:
        xmovei w2,actd
        jrst feact
feoact:
        xmovei w2,acto
        jrst feact
feuact:
        xmovei w2,actu
        jrst feact
feact:
        move w3,o1              ;Get action as a bare number
        getnum w3

        cain w3,0               ;Case on the action
        move w4,[ifiw fecorr]   ;Action = correct
        cain w3,1
        move w4,[ifiw fewarn]   ;Action = correct & warn
        cain w3,2
        move w4,[ifiw feerr]    ;Action = lisp error
        cain w3,3
        move w4,[ifiw feret]    ;Action = nothing

        movem w4,(w2)           ;Save the action
        iret                     ;Return


;AC usage:
;  e - error code
;  f - address
;  g/h - value to return
;  t-d - temps

apracs==-20

;The following routine is designed to be called by SWTRP%.

ovrflw:

;;;;;(1) Forget it all unless next instruction is JFCL 0,0
;Lots of stray fixed point errors may happen in ELISP.  So we try to keep
;this code as short as possible for cases we don't care about.

        addi p,19.             ;for safety, as we sometimes use above stack
        dmovem 0,apracs(p)      ;first part of AC save
        dmove t,trpflg          ;full error pc and flags
        move a,(a)              ;next instruction
        tlnn t,(fov)            ;if floating error
        camn a,[jfcl]           ;or next instruction JFCL 0,0
        jrst ovrfli             ;then we are interested
        dmove 0,apracs(p)       ;no, forget it all
        subi p,19.
        xjrstf trpflg           ;continue

            ;Here if we are interested in the floating error.
ovrfli:
        dmovem 2,apracs+2(p)    ;Save the rest of the ACs
        movei 0,<p-4>           ;# ACs left to save
        movei 1,4
        xmovei 2,apracs+4(p)
        xblt 0,

        move a,trpadr           ;Get next instruction
        move a,(a)              ;
        camn a,[jfcl]           ;If JFCL 0,0,
        jrst fecorr             ;then correct the result.

                                ;Otherwise, take the user-specified action.
        hlrz e,trpflg           ;Get flags in RH
        andi e,(ndv\fov\fxu)    ;Clear all but these
        lsh e,-5                ;Right-justify ndv
        trze e,(1_27.)          ;Fov set?
        iori e,1_2.             ;Move it to right end
        jrst @action(e)         ;Dispatch to the appropriate action.


;Here to raise a Lisp error.  The AC's are now free, as we are going to
;bomb.

feerr:
        move a,[ovr\cry0\cry1\fov\fxu\ndv]
                                ;clear bits so next error is right
        andcam a,trpflg
        move o1,aprtab(e)       ;get right error message
	setzb nil,nil1		;may have junk here
	xmovei w2,d.fer0	;go here for the error
	movem w2,trpadr
	xjrstf trpflg

;Here to print a warning and then correct the result.

fewarn:
        hrroi a,[asciz/%/]
        psout
        move a,aprtab(e)        ;Get error message (Lisp string)
        hrroi a,1(a)            ;Get a jsys str ptr
        psout
        hrroi a,[asciz/
/]
        psout

;Here to correct the result.

fecorr:
        xmovei f,apracs(p)      ;F is used below
        move a,trpadr   ;full error pc
        move a,-1(a)    ;instruction interrupted
;the place we have to clear depends upon the operation that blew up
;so the following code uses a table with one entry for each opcode,
;specifying a routine to use.
        ldb b,[.bp 777_27.,a] ;op code of one that blew
        cail b,110      ;if not 110-377
        caile b,377
        jrst feret      ;then ignore
        subi b,110      ;get offset into dispatch table
        adjbp b,[.bp 77_30.,zertab] ;get pointer to routine code
        ldb c,b         ;c _ routine code
        pushj p,@zerdis(c)      ;go to routine
        trz e,10        ;some routines set this bit

;Here to clean up and return

feret:
        setzm trpflg            ;clear flags for next time
        movei 0,<p-4>           ;restore ac's
        xmovei 1,apracs+4(p)
        movei 2,4
        xblt 0,
        dmove 0,apracs(p)
        dmove 2,apracs+2(p)
        subi p,19.
        xjrstf trpflg           ;return

maxint==377777777777
minint==400000000000
maxflt==377777777777
minflt==-377777777777

;values to use in case of various kinds of overflow.  The first
;table is for nonnegative results, the second for negative
aprval: maxint              ;int overflow - not used
        maxint              ;int divide
        0                   ;impossible
        0                   ;impossible
        maxflt              ;flt overflow
        maxflt              ;flt divide
        0                   ;flt underflow
        0                   ;impossible
;negatives
        minint              ;-int overflow - not used
        minint              ;-int divide
        0                   ;impossible
        0                   ;impossible
        minflt              ;-flt overflow
        minflt              ;-flt divide
        0                   ;-flt underflow
        0                   ;impossible

;This is a dispatch table of routines to go to for various kinds of
;instruction.
zerdis: ifiw    clrn            ;noop
        ifiw    clra            ;clear one AC
        ifiw    clra2           ;clear two AC's
        ifiw    clra4           ;clear four AC's
        ifiw    clrm            ;clear memory
        ifiw    clrm2           ;clear two memory loc's
        ifiw    clram           ;clear AC and memory
        ifiw    clra2m          ;clear two AC's and memory

;nothing
clrn:   popj p,

;clear one AC
clra:   ldb b,[.bp 17_23.,a] ;ac field
        add b,f         ;where it is stored
        skipge (b)      ;if negative
        tro e,10        ;use negative table
        move t,aprval(e) ;get value to clear to
        movem t,(b)     ;clear ac
        popj p,

;clear AC and AC+1
clra2:  ldb b,[.bp 17_23.,a] ;ac
        move c,b
        add c,f         ;relocate to where stored
        skipge (c)      ;if negative
        tro e,10        ;use negative table
        move t,aprval(e) ;get value to clear to
        movem t,(c)
        addi b,1        ;next ac
        andi b,17
        add b,f
        movem t,(b)
        popj p,

;clear AC to AC+3, handling wraparounds
clra4:  ldb a,[.bp 17_23.,a] ;ac
        move b,a
        add b,f
        skipge (b)      ;if negative
        tro e,10        ;use negative value
        move t,aprval(e) ;get value to clear to
        movem t,(b)
        movei c,3       ;three more ac's
clra4l: addi a,1
        move b,a
        andi b,17
        add b,f
        movem t,(b)
        sojg c,clra4l
        popj p,

;clear effective address
clrm:   ldb b,[.bp 17_18.,a] ;index reg
        tlz a,777757    ;now clear op code,ac, and index from instruction
        caie b,0                ;unless no index reg
         tlo a,c                ;modify to use index c
        tlo a,(xmovei b,)       ;movei
        add b,f         ;relocate to addr of index reg used
        move c,(b)      ;and get contents of index reg
        xct a           ;do it - b now has addr of thing to be changed
        skipge (b)      ;if negative
        tro e,10        ;use negative value
        move t,aprval(e) ;get value to clear to
        tdnn b,[777776777760] ;is it an AC?
        jrst clrac      ;if it is an ac, it is special
        movem t,(b)     ;no - just do it
        popj p,

clrac:  move c,b        ;can't garbage b
        add c,f         ;relocate into user ac's
        movem t,(c)     ;clear it
        popj p,

;clear effective address and E+1
clrm2:  pushj p,clrm    ;do first one
        aos b           ;now go to next
        tdnn b,[777776777760] ;is it an AC?
        jrst clrac
        movem t,(b)
        popj p,

;clear AC and E
clram:  pushj p,clra
        pushj p,clrm
        popj p,

;clear AC, AC+1, and E
clra2m: pushj p,clra2
        pushj p,clrm
        popj p,

;The following codes are used in the table of opcode data.  They are
;offsets in the dispatch table above.
        dn==0
        da==1
        da2==2
        da4==3
        dm==4
        dm2==5
        dam==6
        da2m==7

;here we have a table of what to clear for each instruction
; that can cause overflow/underflow, etc.  It simply indicates where
; the results of that instruction go.  This table was made up when I
; was half asleep, so please report any errors in it.  Its accuracy
; is obviously crucial to the behavior of this code.
zertab: .byte 6
	da2 ? da2 ? da2 ? da2 ? da2 ? da2 ;110-115
        da4 ? da4 ? dn ? da2 ? da ? dn    ;116-123
	dn ? dm2 ? da ? da ? da2 ? dam    ;124-131
	da ? dn ? dn ? dn ? dn ? dn       ;132-137
	da ? da2 ? dm ? dam ? da ? da     ;140-145
	dm ? dam ? da ? da2 ? dm ? dam    ;146-153
	da ? da ? dm ? dam ? da ? da2     ;154-161
	dm ? dam ? da ? da ? dm ? dam     ;162-167
	da ? da2 ? dm ? dam ? da ? da     ;170-175
	dm ? dam ? dn ? dn ? dn ? dn      ;176-203
	dn ? dn ? dn ? dn ? da ? da       ;204-211
	dm ? dm ? dn ? dn ? dn ? dn       ;212-217
	da ? da ? dm ? dam ? da2 ? da2    ;220-225
	dm ? da2m ? da2 ? da2 ? dm ? da2m ;226-233
	da2 ? da2 ? dm ? da2m ? dn ? dn   ;234-241
	.byte
        0                               ;242-247
        0                               ;250-255
        0                               ;256-263
	.byte 6
	dn ? dn ? dn ? dn ? da ? da       ;264-271
	dm ? dam ? da ? da ? dm ? dam     ;272-277
	.byte
        0                               ;300-305
        0                               ;306-313
        0                               ;314-321
        0                               ;322-327
        0                               ;330-335
	.byte 6
	dn ? dn ? da ? da ? da ? da       ;336-343
	da ? da ? da ? da ? dm ? dm       ;344-351
	dm ? dm ? dm ? dm ? dm ? dm       ;352-357
	da ? da ? da ? da ? da ? da       ;360-365
	da ? da ? dm ? dm ? dm ? dm       ;366-373
	dm ? dm ? dm ? dm ? dn ? dn       ;374-377
	.byte

;Table of error messages indexed by type of exception.

aprtab: makstr /Integer overflow/
        makstr /Integer divide check/
        0
        0
        makstr /Floating overflow/
        makstr /Floating divide check/
        makstr /Floating underflow/
        0

;Dispatch table of actions indexed by type of exception:
;
action:
        ifiw    feerr
        ifiw    feerr
        ifiw    fewarn
        ifiw    fewarn
acto:   ifiw    feerr
actd:   ifiw    feerr
actu:   ifiw    fewarn
        ifiw    fewarn
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Hash table functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;TY%ATM
;SXHASH -- rtn a number dependent on the equalness of an object
sxhash:	gettyp o1
	movei n,1		;returns 1 result
	xct sxhtab(w2)
	retn
;;TYPES
sxhtab:	jrst sxatom		; atom
	jrst sxatom
	jrst sxcons		; cons
	jrst sxcons
	jrst sxstrg		; string
	jrst sxstrg
	jrst sxchan		; channel
	jrst sxchan
	jrst sxhh		; hash table
	jrst sxhh
	jrst sxvect		; vector
	tlc o1,(<object ty%lpi#ty%chr>)		; character
	jrst sxarry		; array
	tlc o1,(<object ty%lpi#ty%spc>)		; skip pointer
	jrst sxivec		; integer vector
	jrst sxbvec		; bit vector
	jrst sxlflo		; long flonum
	jrst sxlflo		; long flonum
	tlc o1,(<object ty%lpi#ty%lnf>)		; neg iflons
	tlc o1,(<object ty%lpi#ty%lnf>)		; neg iflons
	tlc o1,(<object ty%lpi#ty%lpf>)		; pos iflons
	tlc o1,(<object ty%lpi#ty%lpf>)		; pos iflons
	jrst sxcons		; ratios
	jrst sxcons
	tlc o1,(<object ty%lpi#ty%s36>)		; bit vector skip pointer
	tlc o1,(<object ty%lpi#ty%sp5>)		; character skip pointer
	jrst sxbig		; bignum
	jrst sxbig
	tlc o1,(<object ty%lpi#ty%lni>)		; neg inums
	tlc o1,(<object ty%lpi#ty%lni>)
	retn			; pos inums
	retn

;;TY%INT    ---   all of the below


;;TY%ATM
;;TY%STR
sxatom:	jumpe o1,[move o1,[inum 1] ? retn]	;(sxhash ()) = 1
	move o1,at%pna(o1)	;otherwise take bits from the first
sxstrg:	call getstr
;w2/w3 is pointer; w4 is count
	move o1,w4		;accum hash in O1
	imuli o1,111
	caile w4,10.		;only use first 10 chars
	 movei w4,10.
	jumpe w4,sxstrx
sxstrl:	ildb nil1,w2
	xor o1,nil1
	rot o1,10
	sojg w4,sxstrl
sxstrx:	setz nil1,
	posnum o1		;clear stray bits
	maknum o1
	retn

sxbvec:	call getbvc
;w2/w3 is pointer; w4 is count
	move o1,w4		;accum hash in O1
	imuli o1,111
	caile w4,36.		;only use first 36 bits
	 movei w4,36.
	jumpe w4,sxbvcx
sxbvcl:	ildb nil1,w2
	xor o1,nil1
	rot o1,2
	sojg w4,sxbvcl
sxbvcx:	setz nil1,
	posnum o1		;clear stray bits
	maknum o1
	retn


;array - if it is really string or bit vector, treat it that way
sxarry:	move o2,ah%dat(o1)
	gettyp o2
	caie w2,ty%str
	 cain w2,ty%cst		;if string
	  jrst sxstrg		;then let them handle it
	cain w2,ty%bvc		;ditto bit vector
	 jrst sxbvec
;else make up a number that depends upon structure only
	rot w2,6
	xor w2,ah%dsp(o1)
	rot w2,10
	xor w2,ah%hsz(o1)
	maknum w2
	move o1,w2
	retn


;;TY%CON
;;; [PEM]: Don't loop on circular objects. With a reasonable limit
;;;        in sxcnsc the hash code will be good enough anyway.

	.vector sxcnsc		;[PEM,Victor] 

;;TY%XCN
;;TY%XRT
;;TYPES
;[Victor] Skip if not cons or ratio (the types hashed with sxcons)
define sncnrt(x)
	xtype x
	caie w2,ty%xcn
	 cain w2,ty%xrt
	termin

sxcons:	movei w2,17.		;[PEM,Victor] Reset limit to seventeen
	movem w2,sxcnsc		;[PEM,Victor] 
	call sxcns		;[PEM] Call the hash function
	retn			;[PEM] 

sxcns2:	aos (p)			;[PEM] Return +2
sxcns:	sosg sxcnsc		;[PEM] Enough?
	 jrst sxcns1		;[PEM] Yes, return 1
	push q,1(o1)		;for a cons cell:
	move o1,(o1)		;take the sxhash of the car
	sncnrt o1		;[PEM,Victor] Hashed with sxcons?
	 call sxcns2		;[PEM] Yes. Recurse but return to .+2
	call sxhash
	imuli o1,8009.		;times a prime number
	push p,o1
	pop q,o1		;plus the sxhash of the cdr
	sncnrt o1		;[PEM,Victor] Hashed with sxcons?
	 call sxcns2		;[PEM] Yes. Recurse but return to .+2
	call sxhash
	add o1,(p)
	subi p,1
	movms o1		;..chucking any extra bits that might
	tlo o1,(inum0)		; happen to have been generated.
	retn

sxcns1:	movei o1,1		;[PEM] Return one
	maknum o1		;[PEM] Lisp number
	retn			;[PEM] 

; channel.  There are no characteristics that will survive closing
;	and opening on a different file.  Either we have to use
;	a constant, or we have to add a word in the channel block
;	and save a specific SXHASH code.  I am not taking time to do
;	that now.  If somebody really puts lots of channels in an
;	equal hash table, we can fix this up.  (Normally we would use
;	an EQ hash table for channels.)
sxchan:	move o1,[inum ty%chn]	;well, what do you want?
	retn

; hash table - most of the parameters will change as we add 
;	associations.  As with channels, there isn't a lot we can do.
;	Here we use the type of hash table
sxhh:	move o1,ht%get(o1)	;different for each type
	posnum o1
	maknum o1
	retn

; vector - since EQUAL is EQ on vectors, we can't depend upon anything
;	like the data.  The only things that won't change are the length
;	and subtype
sxvect:	move o1,-1(o1)		;number of words
	rot o1,10.
	xor o1,-2(o1)		;subtype
	posnum o1
	maknum o1
	retn

; integer vector - again, there isn't much we can use
sxivec:	move o1,-2(o1)		;access type
	rot o1,20.
	xor o1,-1(o1)		;number of words
	posnum o1
	maknum o1
	retn


;;TY%FLO
sxlflo:	;same code  --  hash the first three words of the object
;;TY%BIG
sxbig:	move w2,(o1)
	add w2,1(o1)
	add w2,2(o1)
	imuli w2,10101
	lsh w2,-6
	tlo w2,(inum0)
	move o1,w2
	retn

; Hash Tables:  a hash table is essentially a two-level vector,
; of which the top is a record-like structure:
ht%siz==0	; the number of slots in the table (an inum)
ht%rxf==1	; rehash expansion factor, an iflon
ht%lf==2	; load factor, the fraction of a table which may be filled 
ht%rht==3	; rehash trigger, ht%lf (an iflon) as an inum
ht%nsu==4	; number of slots in use (an inum)
ht%ptr==5	; points to the vector which is the actual table
ht%get==6	; address of the routine to do GETHASH for this table
ht%put==7	; address of the routine to do PUTHASH for this table
; the actual table is a separate vector for ease of rehashing.  It contains
; two words per "slot", one for key and one for value.  Whenever ht%nsu
; exceeds ht%rht, the table is rehashed, with a size of ht%rxf * ht%siz
; (rounded up to the next prime).
;    For EQ hash tables, the table must be rehashed after every garbage
; collection.  To avoid rehashing if the table is not being used, it
; is rehashed at the next get or put instead of during GC.  GC merely
; changes the get and put routine addresses to grehsh and prehsh, which
; rehash, reset the addresses, and proceed to the normal get or put.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MAKE-HASH-TABLE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;(make-hash-table &key :test :size :rehash-size :rehash-threshold)

;until we get keywords fully working, just take 4 arguments


;this is complex, because the user can specify absolute or relatives
;for each arg.
;this entry is used internally
makhsh:	xtypea w2,o2
	xtypea w3,o3
	xtypea w4,o4
	cail w2,ty%xni		;if size was specified as INUM
;NB: we put O2 as bare integer temporarily.
	 jrst [	getnum o2
		jrst makhss]	;we are in fairly good shape
;here if no size specified
	cail w4,ty%xni		;else if threshold specified
	 jrst [	move o2,o4	;then 
		getnum o2
		fltr o2,o2	;as floating
		fmpr o2,[2.5]	;implied table size
		fixr o2,o2
		jrst makhss]
	cail w3,ty%xni		;if rehash-size was specified
	 jrst [	move o2,o3
		getnum o2	;then get it as integer
		fltr o2,o2	;as floating
		fmpr o2,[1.6666667]
		fixr o2,o2	;back to integer
		jrst makhss]
	move o2,[64.]		;else assume 64
;now we have a valid initial table size.  look at rehash size.
makhss:	cail w3,ty%xni		;if rehash-size given as integer
	 jrst [	getnum o3	;use ratio of it
		fltr o3,o3
		fltr w2,o2	;to original size
		fdvr o3,w2
		fadr o3,[1.0]	;have to add one since it was increment
		camge o3,[1.2]	;don't let it be less than 1.2
		 move o3,[1.2]
		makifl o3	;and make Lispish
		jrst makhsr]
	caie w3,ty%xif		;if already iflon, we're OK
	 cain w3,ty%xif+1
	  jrst makhsr
	cain w3,ty%xfl		;if long float, convert to short
	 jrst [	move o3,1(o3)	;the easy way
		makifl o3
		jrst makhsr]
	move o3,[iflon 1.6]	;else use default
;now have rehash-size.  look at load-factor
makhsr:	cail w4,ty%xni		;if load-factor given as integer
	 jrst [	getnum o4	;use ratio of it
		fltr o4,o4
		fltr w2,o2	;to original size
		fdvr o4,w2
		camle o4,[0.8]	;but don't let it get bigger than .8
		 move o4,[0.8]
		makifl o4	;and make Lispish
		jrst makhsl]
	caie w4,ty%xif		;if already iflon, we're OK
	 cain w4,ty%xif+1
	  jrst makhsl
	cain w4,ty%xfl		;if long float, convert to short
	 jrst [	move o4,1(o4)	;the easy way
		makifl o4
		jrst makhsl]
	move o4,[iflon 0.4]	;else use default
;now have load factor. Go to the right routine
makhsl:	maknum o2		;get this guy to Lisp
	skipn o1		;if he defaulted it
	move o1,[%EQL]		;use EQL
	move o6,o1		;get args in right places
	move o1,o2
	dmove o2,o3
	came o6,[%EQL]
	 camn o6,@[datsec,,%EQL+at%fun]
	  jrst m1ht
	came o6,[%EQ]
	 camn o6,@[datsec,,%EQ+at%fun]
	  jrst mhasht
	came o6,[%EQUAL]
	 camn o6,@[datsec,,%EQUAL+at%fun]
	  jrst m2ht
	err1 o6,/Invalid type of hash table in MAKE-HASH-TABLE: ~S/


;HASHP - is it a hash table?
hashp:	xtype o1
	caie w2,ty%xht
	 jrst retnil		;no
	jrst rett		;yes

;; (make-hash-table size rehash-size load-factor)
; all args are optional.
mhasht:	skipn o1		;size given?
	 move o1,[inum 64.]	;no, use 64
	camge o1,[inum 10.]	;bigger than 10?
	 move o1,[inum 10.]	;no, use 10
	skipn o2		;rehash size given?
	 move o2,[iflon 1.6]	;no, use 1.6
	skipn o3		;load factor given?
	 move o3,[iflon 0.4]	;no, use .4
	push free,[inum 10]	;now create the top-level vector (length 8)
	push free,o1		;ht%siz (later we primeify this)
	push free,o2		;ht%rxf (arg 2...)
	push free,o3		;ht%lf  (arg 3)
	call prime		;o1 --> o1
	movem o1,-2(free)	;--> ht%siz
	move w2,o1
	move w3,(free)
	call mpyixf		;ht%siz * ht%lf (gives inum)
	push free,w2		;--> ht%rht
	push free,[inum0]	;ht%nsu
	push free,nil		;ht%ptr
	push free,[object ty%iadr,<codsec,,eqghsh>]	;ht%get
	push free,[object ty%iadr,<codsec,,eqphsh>]	;ht%put
	move w2,free		;create hash table pointer
	subi w2,7		; (which we'll return)
	tlo w2,(<object ty%eht>)	;the type code
	push q,w2		;stash it temporarily
	lshc w4,6		;multiply the size by two
	lsh o1,1		;(it's an inum)
	lshc w4,-6
	call makvec		;make the actual table part
	exch o1,(q)		;get the header pointer again
	pop q,5(o1)		;insert table ptr into ht%ptr
	ret1

; multiply inum (w2) by iflon (w3) returning inum in w2
mpyixf:	getnum w2
	fltr w2,w2
	lsh w3,4
	fmpr w2,w3
	fixr w2,w2
	maknum w2
	iret

; divide inum (w2) by iflon (w3) returning inum in w2
divibf:	getnum w2
	fltr w2,w2
	lsh w3,4
	fdvr w2,w3
	fixr w2,w2
	maknum w2
	iret

;; (make-eql-hash-table ...) -- calls make-hash-table, and replaces
;; the dispatch addresses with eql-using ones
;;  eql is a variant of eq, so we must still rehash at GC
m1ht:	call mhasht
	dmove w2,[object ty%iadr,<codsec,,elghsh>	;ht%get
		  object ty%iadr,<codsec,,elphsh>]	;ht%put
	dmovem w2,ht%get(o1)
	ret1

;; (make-equal-hash-table ...) -- calls make-hash-table, replaces
;; the dispatch addresses with equal-using ones, and changes the type.
;; equal hash uses sxhash codes, so no need to rehash at GC
m2ht:	call mhasht
	dmove w2,[object ty%iadr,<codsec,,lghsh>	;ht%get
		  object ty%iadr,<codsec,,lphsh>]	;ht%put
	dmovem w2,ht%get(o1)
	tlc o1,(<object ty%eht>#<object ty%oht>)
	ret1

; The following functions are generic over kind of hash table.
; they are done by dispatch off the specific routine addresses
; stored in the hash table header.

; (gethash key table default)
; default is optional, default default is nil. default is returned 
; if key not found
gethsh:	move o3,nil		;here if default not supplied
	xtype o2		;make sure it's a hash table
	cain w2,ty%xht
	 jrst @ht%get(o2)	;dispatch to whatever gethash routine
	err /GETHASH: not hash table/

; (puthash key table value)
puthsh:	exch o2,o3		;easier to do this than to fix
				;all the functions.
	xtype o3		;make sure it's a hash table
	cain w2,ty%xht
	 jrst @ht%put(o3)	;dispatch to whatever puthash routine
	err /PUTHASH: not hash table/

; (remhash key table)
remhsh:	xtype o2		;make sure it's a hash table
	caie w2,ty%xht
	 jrst [err /REMHASH: not hash table/]
	move w2,ht%get(o2)
	jrst -1(w2)	;dispatch to whatever remhash routine

;; These are the routine the garbage collector sets the get/put
; entries in the header to for eq hash tables.  They perform a
; rehash on the table before doing the indicated function.
	jrst rrehsh		;must be at grehsh-1
grehsh:	push q,o1		;save args
	push q,o2
	push q,o3
	move o1,o2		;restore normal get/put addrs
	dmove w2,[object ty%iadr,<codsec,,eqghsh>
		  object ty%iadr,<codsec,,eqphsh>]
	dmovem w2,ht%get(o1)
	call rehash		;rehash
	pop q,o3		;restore args
	pop q,o2
	pop q,o1
	jrst eqghsh		;proceed to get

; rehash for puthash
prehsh:	push q,o1		;save args
	push q,o2
	push q,o3
	move o1,o3		;reset normal get/put addrs
	dmove w2,[object ty%iadr,<codsec,,eqghsh>
		  object ty%iadr,<codsec,,eqphsh>]
	dmovem w2,ht%get(o1)
	call rehash		;rehash the table
	pop q,o3		;restore args
	pop q,o2
	pop q,o1
	jrst eqphsh		;proceed to put

; rehash for remhash -- comes from jrst at grehsh-1
rrehsh:	push q,o1		;save args
	push q,o2
	move o1,o2		;restore normal get/put addrs
	dmove w2,[object ty%iadr,<codsec,,eqghsh>
		  object ty%iadr,<codsec,,eqphsh>]
	dmovem w2,ht%get(o1)
	call rehash		;rehash
	pop q,o2		;restore args
	pop q,o1
	jrst eqrhsh		;proceed to remhash

; gethash routine for eq hash tables
; eq hash function is simply the whole raw object word value mod
; the table size.

;table organization is simply an array of length 2p (p a prime)
;which has for each key at k, the value at k+p

	jrst eqrhsh		;must be at eqghsh-1
eqghsh:	move w2,ht%siz(o2)	;table size
	getnum w2
	skipn w3,o1		;key
	 jrst [move o1,[object ty%iadr] ? jrst .-1]	;substitute if nil
	idiv w3,w2		;get remainder   key/size
	move w3,ht%ptr(o2)	;table address
	add w3,w4		;plus remainder
	came o1,(w3)		;= key sought?
	 jrst egh2		; no
	add w3,w2		;yes, add table size to find value
	move o1,(w3)		;which get
	move o2,[%T]
	ret2

; for secondary probing we keep adding the remainder and reducing
; mod the table size.  since t.s. is prime, this will cycle thru
; all entries randomly and be 0 last.

;registers:  w2=table size; w3=successive secondary hash indices;
;	     w4=original hash index; o1=key; o2=table; o3=default rtn val;
;	     o4=indirect word pointing to the base of the table
;		and indexed off w3

egh2:	skipn (w3)		;key in table /= arg key
	 jrst eghnf		;slot empty => not in table
	move o4,ht%ptr(o2)	;else secondary hash
	tlc o4,(<object ty%vec>#<object w3>)	;make indirect wd
	skipn w3,w4		;original remainder
	 movei w4,1		;if it was 0
eghlop:	add w3,w4		;add remainder
	caml w3,w2		;reduce mod t.s.
	 sub w3,w2
	camn o1,@o4		;a hit?
	 jrst eghfnd		; yes
	skipe @o4		;empty?
	 jumpn w3,eghlop	;no
	setz o4,		;yes empty, return default (o4 wasn't an obj)
eghnf:	move o1,o3
	move o2,nil		;say didn't find it
	ret2

eghfnd:	add w3,w2		;yes found key, now get value
	move o1,@o4		;and return it
	move o2,[%T]		;say we found it
	setz o4,		;kill nasty invalid object
	ret2

;; puthash for eq hash tables.  o1=key, o2=value, o3= table
eqphsh:	move w2,ht%siz(o3)
	getnum w2
	skipn w3,o1		;nil
	 jrst [move o1,[object ty%iadr] ? jrst .-1]
	idiv w3,w2		;hash
	move w3,ht%ptr(o3)
	add w3,w4		;lookup
	camn o1,(w3)		;match
	 jrst ephrpl		;key there, replace val
	skipe (w3)		;was a key there?
	 jrst eph2		;yes, look some more
	movem o1,(w3)		;new key: ass whole new entry
	add w3,w2
	movem o2,(w3)		;stash value
ephcnt:	move o1,o2		;return value
	aos w2,ht%nsu(o3)	;increment 
	camg w2,ht%rht(o3)
	 jrst ephret
	push q,o2
	move o1,o3
	call rehash
	pop q,o1
ephret:	ret1

;key already there; merely replace the value
ephrpl:	add w3,w2
	movem o2,(w3)		;stash value
	move o1,o2		;also return it
	ret1

; the look algorithm is of course exactly the same--we even use the same
;registers:  w2=table size; w3=successive secondary hash indices;
;	     w4=original hash index; o1=key; o2=value; o3=table;
;	     o4=indirect word pointing to the base of the table
;		and indexed off w3

eph2:	move o4,ht%ptr(o3)
	tlc o4,(<object ty%vec>#<object w3>)
	skipn w3,w4
	 movei w4,1
ephlop:	add w3,w4
	caml w3,w2
	 sub w3,w2
	skipn @o4
	 jrst ephemp
	camn o1,@o4
	 jrst ephfnd
	jumpn w3,ephlop
	err /hash tab wedged/

; found empty slot
ephemp:	movem o1,@o4		;deposit the key
	add w3,w2
	movem o2,@o4		;and the value
	setz o4,
	jrst ephcnt		;and go count the new slot

; found old slot with that key
ephfnd:	add w3,w2		;need only the value
	movem o2,@o4
	setz o4,
	move o1,o2		;rtn val
	ret1			;no need to count

;remhash for eq hash tables  o1=key, o2=table
; return T if found/removed, NIL if not found
; deletion is done by replacing the key in the table with a
;  special code.  We can't merely remove it since that might
; break secondary hash chains.  The deleted markers will go away
; next time the table is rehashed.
eqrhsh:	move w2,ht%siz(o2)
	getnum w2
	skipn w3,o1		;nil
	 jrst [move o1,[object ty%iadr] ? jrst .-1]
	idiv w3,w2		;hash
	move w3,ht%ptr(o2)
	add w3,w4		;lookup
	came o1,(w3)		;match
	 jrst erh2
	move o1,[object ty%iadr,86.]	;insert "deleted" code
	movem o1,(w3)
	add w3,w2
	setzm (w3)		;clear value so it can be GC'ed
	move o1,[%t]		;return T
	ret1

; same secondary hash as everybody else...
erh2:	skipn (w3)
	 jrst erhnf		;empty, return nil
	move o4,ht%ptr(o2)
	tlc o4,(<object ty%vec>#<object w3>)
	skipn w3,w4
	 movei w4,1
erhlop:	add w3,w4
	caml w3,w2
	 sub w3,w2
	camn o1,@o4
	 jrst erhfnd
	skipe @o4
	 jumpn w3,erhlop
	setz o4,
erhnf:	setz o1,		;return nil
	ret1

erhfnd:	move o1,[object ty%iadr,86.]	;found, insert "deleted" code
	movem o1,@o4
	add w3,w2
	setzb o4,@o4		;clear value so it can be GC'ed
	move o1,[%t]		;return T
	ret1

;; rehash a table, either for size expansion or because the EQ hash
; keys (based on addresses) are invalid after a GC.
; accepts table in o1
rehash:	move w2,ht%nsu(o1)	;no need to rehash if 0 entries
	camn w2,[inum0]
	 iret
	push q,o1		;save
	push q,ht%put(o1)	;the puthash routine for later use
;Here is what is going to be in W4 eventually.  We use a zero pointer
;at the moment and fill in the actual address later.  That is because
;a GC can happen in the MAKVEC, called below, which will change the
;address.
;	move w4,ht%ptr(o1)	;pointer to the old table vector
;	tlz w4,(<object 77>)	;make an indirect indexed off w2 ptr
;	tlo w4,(<object w2>)
;here is the best we can do at the moment
	move w4,[object w2]	;this will be a pointer indexed off W2
	move w3,ht%siz(o1)	;size of the old
	getnum w3		;as bare no. in w3
	movn w2,w3		;negative in w2, counts up to 0
	add w4,w3		;bump by table size to match negative counter
	push p,w4		;save everything
	push p,w2
	push p,w3

; the next little sequence is to compute the new table size.  If we are
; doing an expansion, it's just the expansion factor times the current size:
;  ht%siz * ht%rxf.   If this is a GC-triggered rehash, we take the max of 
; the current size and the size an expansion would have given had the table 
; been small enough that the existing items would have caused an expansion:
;  ht%rxf * ht%nsu / ht%lf.  We find out which case we have by seeing if the
; table is full to the trigger level.  (Actually the formulae would give the
; same result, but here it is faster to check than to do the work every time.
	move w2,ht%nsu(o1)	;slots used
	camge w2,ht%rht(o1)	;>= trigger level?
	 skipa w3,ht%lf(o1)	;no, do nsu/lf
	  skipa w2,ht%siz(o1)	;yes, use current size
	   call divibf		;(only for nsu/lf case)
	move w3,ht%rxf(o1)	;multiply whatever that was by rxf
	call mpyixf
	camge w2,ht%siz(o1)	;but never shrink the table.
	 move w2,ht%siz(o1)
	move o1,w2
	call prime		;round up to nearest prime #
	move o2,-1(q)
	movem o1,ht%siz(o2)	;--> new size
	move w2,o1
	move w3,ht%lf(o2)	;use it to compute new trigger level
	call mpyixf
	movem w2,ht%rht(o2)
	move w2,[inum0]		;the new table is empty so far...
	movem w2,ht%nsu(o2)
	lshc w4,6		;double the prime number for the new
	lsh o1,1		; vector size.
	lshc w4,-6
	call makvec
	move o2,-1(q)		;get back the main hash table
;now here we fill in the address part of W4
	move w4,ht%ptr(o2)	;the old pointer
	tlz w4,770000		;address only
	addm w4,-2(p)		;put it into saved W4
	movem o1,ht%ptr(o2)	;and save the new pointer.

;; this is similar to the maphash loop: we go through the table
;  getting key/value pairs, only instead of calling a function, we
;  merely insert them into the new table.  The control data is 
;  simpler than maphash since we know there can't be a GC inside
;  the loop.
rehl1:	move w4,-2(p)
	dmove w2,-1(p)
rehl2:	skipn o1,@w4
	 aojl w2,rehl2
	jumpge w2,eoreh
	camn o1,[object ty%iadr,86.]
	 jrst rehl2+1		; a "deleted" marker, re-enter search loop
	camn o1,[object ty%iadr,nil]
	 move o1,nil
	add w4,w3
	move o2,@w4
	aos w2
	movem w2,-1(p)
	move o3,-1(q)
	call @(q)
	skipge -1(p)
	 jrst rehl1
eoreh:	subi p,3
	subi q,2
	iret


;; These are the routine the garbage collector sets the get/put
; entries in the header to for eql hash tables.

;; ***** these routines (lgreh in particular) MUST LIE BETWEEN
;;       eqghsh and elghsh in that order for the garbage
;;       collector to be able to distinguish eq and eql hash tables.
;;	 Consult routine CPYEHT.

	jrst lrreh		;must be at lgreh-1
lgreh:	push q,o1		;save args
	push q,o2
	push q,o3
	move o1,o2		;restore normal get/put addrs
	dmove w2,[object ty%iadr,<codsec,,elghsh>
		  object ty%iadr,<codsec,,elphsh>]
	dmovem w2,ht%get(o1)
	call rehash		;rehash
	pop q,o3		;restore args
	pop q,o2
	pop q,o1
	jrst elghsh		;proceed to get

; rehash for puthash
lpreh:	push q,o1		;save args
	push q,o2
	push q,o3
	move o1,o3		;reset normal get/put addrs
	dmove w2,[object ty%iadr,<codsec,,elghsh>
		  object ty%iadr,<codsec,,elphsh>]
	dmovem w2,ht%get(o1)
	call rehash		;rehash the table
	pop q,o3		;restore args
	pop q,o2
	pop q,o1
	jrst elphsh		;proceed to put

; rehash for remhash -- comes from jrst at lgreh-1
lrreh:	push q,o1		;save args
	push q,o2
	move o1,o2		;restore normal get/put addrs
	dmove w2,[object ty%iadr,<codsec,,elghsh>
		  object ty%iadr,<codsec,,elphsh>]
	dmovem w2,ht%get(o1)
	call rehash		;rehash
	pop q,o2		;restore args
	pop q,o1
	jrst elrhsh		;proceed to remhash

; hash routines for eql hash tables
; we simply use eq hash routines for everything except numbers,
;  and equal hash routines for numbers

	jrst elrhsh		;must be at elghsh-1
elghsh:	xtype o1		;what type object is the key?
	xct eqlhtb(w2)
	 jrst eqghsh		;if not number, use eq hash
	jrst lghsh		;if number, use equal hash

elphsh:	xtype o1		;what type object is the key?
	xct eqlhtb(w2)
	 jrst eqphsh		;if not number, use eq hash
	jrst lphsh		;if number, use equal hash

elrhsh:	xtype o1		;what type object is the key?
	xct eqlhtb(w2)
	 jrst eqrhsh		;if not number, use eq hash
	jrst lrhsh		;if number, use equal hash

;;TYPES		(note immediate numbers are equal only if eq)
eqlhtb:	jfcl			; atom
	jfcl			; cons
	jfcl			; string
	jfcl			; channel
	jfcl			; hash table
	jfcl			; vector
	jfcl			; address
	jfcl			; array
	skipa			; long flonum
	jfcl			; neg iflons
	jfcl			; pos iflons
	skipa			; ratios
	skipa			; complex (unimplemented)
	skipa			; bignum
	jfcl			; neg inums
	jfcl			; pos inums

	jrst lrhsh		;remhash vector at lghsh-1
;; gethash for equal hash tables
; ("equal" here means Common Lisp equal, ie, equalt.)
lghsh:	jumpe o1,[move o1,[object ty%iadr] ? jrst .+1]	;substitute if nil
	push q,o3		;default value
	push q,o2		;table
	push q,o1		;key
	call sxhash		;obtain hash value for key
	move o2,-1(q)
	move w2,ht%siz(o2)	;table size
	getnum w2
	move w3,o1
	idiv w3,w2
	move w3,ht%ptr(o2)	;table address
	push p,w3
	add w3,w4		;plus remainder
	push p,w2		;size
	push p,w3		;position
	push p,w4		;hash function value
	move o1,(q)
	skipn o2,(w3)
	 jrst lghnf
	call equal		;match?
	move w3,-1(p)
	jumpe o1,lgh2		; no
	add w3,-2(p)		;yes, add table size to find value
	move o1,(w3)		;which get
	move o2,[%T]		;we found it
	subi q,3
	subi p,4
	ret2

; for secondary probing we keep adding the remainder and reducing
; mod the table size.  since t.s. is prime, this will cycle thru
; all entries randomly and be 0 last.

; stacks: q: -2=default, -1=table, 0=key
;	  p: -3=table base, -2=size, -1=posn, 0=hash fn val
lgh2:	skipn (w3)		;key in table /= arg key
	 jrst lghnf		;slot empty => not in table
	skipn w3,(p)		;original remainder
	 aos (p)		;if it was 0
	movem w3,-1(p)
lghlop:	add w3,(p)		;add remainder
	caml w3,-2(p)		;reduce mod t.s.
	 sub w3,-2(p)
	movem w3,-1(p)		;save for looping
	add w3,-3(p)		;add in base address
	move o1,(q)
	skipn o2,(w3)
	 jrst lghnf		;woops, an empty slot
	call equal		;match?
	jumpn o1,lghfnd		; yes
	skipe w3,-1(p)		;should never be necessary, since=>table full
	 jrst lghlop		;no
lghnf:	move o1,-2(q)
	move o2,nil		;didn't find it
	subi q,3
	subi p,4
	ret2

lghfnd:	move w3,-1(p)		;get posn as computed
	add w3,-2(p)		;add table size to get value
	add w3,-3(p)		;and base addr
	move o1,(w3)		;and return it
	move o2,[%T]		;found it
	subi q,3
	subi p,4
	ret2

;; puthash for equal hash tables.  o1=key, o2=value, o3= table
lphsh:	jumpe o1,[move o1,[object ty%iadr] ? jrst .+1]	;substitute if nil
	push q,o3		;table
	push q,o2		;value
	push q,o1		;key
	call sxhash		;obtain hash value for key
	move o2,-2(q)
	move w2,ht%siz(o2)	;table size
	getnum w2
	move w3,o1
	idiv w3,w2
	move w3,ht%ptr(o2)	;table address
	push p,w3
	add w3,w4		;plus remainder
	push p,w2		;size
	push p,w4		;h(key), to match loop below
	push p,w4		;hash function value
	move o1,(q)
	skipn o2,(w3)
	 jrst lphemp
	call equal		;match?
	move w3,-1(p)
	jumpe o1,lph2		; no
;key already there; merely replace the value
lphrpl:	move o1,-1(q)		;value
	move w3,-1(p)
	add w3,-3(p)		;key posn
	add w3,-2(p)		;value posn
	movem o1,(w3)		;stash value
	subi q,3
	subi p,4
	ret1

; slot empty, fill it in
lphemp:	dmove o1,-1(q)		;value, key
	move w3,-1(p)
	add w3,-3(p)		;key posn
	movem o2,(w3)		;new key: ass whole new entry
	add w3,-2(p)
	movem o1,(w3)		;stash value
	move o3,-2(q)
	subi q,3
	subi p,4
	aos w2,ht%nsu(o3)	;increment # of entries
	camg w2,ht%rht(o3)	;if higher than trigger,
	 jrst ret1v
	push q,o1		;rehash
	move o1,o3
	call rehash
	pop q,o1
	ret1			;and return

; secondary hash search
; stacks: q: -2=table, -1=value, 0=key
;	  p: -3=table base, -2=size, -1=posn, 0=hash fn val
lph2:	skipn w3,(p)		;original remainder
	 aos (p)		;if it was 0
lphlop:	add w3,(p)		;add remainder
	caml w3,-2(p)		;reduce mod t.s.
	 sub w3,-2(p)
	movem w3,-1(p)		;save for looping
	add w3,-3(p)		;add in base address
	move o1,(q)
	skipn o2,(w3)
	 jrst lphemp		;aha, an empty slot
	call equal		;match?
	jumpn o1,lphrpl		; yes
	skipe w3,-1(p)		;should never be necessary, since=>table full
	 jrst lphlop		;no
	err /hash tab wedged/


;remhash for equal hash tables  o1=key, o2=table
; return T if found/removed, NIL if not found
; deletion is done by replacing the key in the table with a
;  special code.  We can't merely remove it since that might
; break secondary hash chains.  The deleted markers will go away
; next time the table is rehashed.
lrhsh:	jumpe o1,[move o1,[object ty%iadr] ? jrst .+1]	;substitute if nil
	push q,o2		;table
	push q,o1		;key
	call sxhash		;obtain hash value for key
	move o2,-1(q)
	move w2,ht%siz(o2)	;table size
	getnum w2
	move w3,o1
	idiv w3,w2
	move w3,ht%ptr(o2)	;table address
	push p,w3
	add w3,w4		;plus remainder
	push p,w2		;size
	push p,w4		;hf val, to be posn
	push p,w4		;hash function value
	move o1,(q)
	skipn o2,(w3)
	 jrst lrhnf
	call equal		;match?
;[Victor,PEM] Hack here.
	jumpe o1,lrh2		; no match
lrhfnd:	move w3,-1(p)
	add w3,-3(p)		;recompute position on the side
	move o1,[object ty%iadr,86.]	;insert "deleted" code
	movem o1,(w3)
	add w3,-2(p)		; add table size to find value
	setzm (w3)		;clear value so it can be GC'ed
	skipa o1,[%t]		;return T
lrhnf:	 setz o1,		;return NIL
	subi q,2
	subi p,4
	ret1			;and return

; for secondary probing we keep adding the remainder and reducing
; mod the table size.  since t.s. is prime, this will cycle thru
; all entries randomly and be 0 last.

; stacks: q: -1=table, 0=key
;	  p: -3=table base, -2=size, -1=posn, 0=hash fn val
lrh2:	skipn w3,(p)		;original remainder
	 aos (p)		;if it was 0
lrhlop:	add w3,(p)		;add remainder
	caml w3,-2(p)		;reduce mod t.s.
	 sub w3,-2(p)
	movem w3,-1(p)		;save for looping
	add w3,-3(p)		;add in base address
	move o1,(q)
	skipn o2,(w3)
	 jrst lrhnf		;woops, an empty slot
	call equal		;match?
	jumpn o1,lrhfnd		; yes
	skipe w3,-1(p)		;should never be necessary, since=>table full
	 jrst lrhlop		;no
	jrst lrhnf


;; (MAPHASH <function> <hashtable>)   <Function> is a fn of 2 args.
;; it will be called on each key,value pair in <hashtable>.  
maphsh:	push q,o1
	push q,o2
	move w3,ht%siz(o2)
	getnum w3
	movn w2,w3
	push p,w2
	push p,w3

mphl1:	move w4,(q)
	move w4,ht%ptr(w4)
	tlz w4,(<object 77>)
	tlo w4,(<object w2>)
	dmove w2,-1(p)
	add w4,w3
mphl2:	skipn o1,@w4		;[VICTOR] Use right AC
	 aojl w2,mphl2
	jumpge w2,eomph
	camn o1,[object ty%iadr,86.]	;[VICTOR] Right here too
	 jrst mphl2+1		; a deleted marker, re-enter search loop
	camn o1,[object ty%iadr,nil]	;[VICTOR] Right here too
	 move o1,nil
	add w4,w3
	move o2,@w4
	aos w2
	movem w2,-1(p)
	fncall -1(q),2
	skipge -1(p)
	 jrst mphl1
eomph:	subi p,2
	subi q,2
	jrst retnil

;; (HASH-TABLE-COUNT <hashtable>)
;; number of used entries
hshcnt:	move w3,ht%siz(o1)
	getnum w3
	movn w2,w3
	move w4,ht%ptr(o1)
	tlz w4,(<object 77>)
	tlo w4,(<object w2>)
	add w4,w3
	move o1,[inum 0]
hshcnl:	skipn o2,@w4
	 aojl w2,hshcnl
	jumpge w2,eohshc
	camn o2,[object ty%iadr,86.]
	 jrst hshcnl+1		; a deleted marker, re-enter search loop
	addi o1,1
	aojl w2,hshcnl
eohshc:	ret1

clrhsh:	xtype o1
	caie w2,ty%xht
	 jrst [err /CLRHASH: not hash table/]
	move w2,ht%siz(o1)
	getnum w2
	lsh w2,1
	subi w2,1
	move w3,ht%ptr(o1)
	move w4,w3
	aos w4
	setzm (w3)
	xblt w2,
	move w2,[inum0]
	movem w2,ht%nsu(o1)
	ret1

;*** end of hash table functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; vector functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;makvec - o1 size
makvec:	setz o2,			;this function initializes to NIL

;alloc-B-vector - O1 size; O2 object with which to init
albvec:	gettyp o1
	caie w2,ty%lpi			;better be low pos int
	 jrst makver			;(low means <2^30)
	;;[Victor] Kludge to prevent garbage XBLT
	;;Do GC test in advance, but I don't feel like rewriting the
	;;whole routine, since it's a kludge anyway.
albve0:	move w3,free		;[Victor] Get old free pointer
	move w2,o1		;[Victor] w2 - size as number
	posnum w2		;[Victor]
	addi w3,2		;[Victor] add 2 for header
	add w3,w2		;[Victor] add length of vector
	camge w3,lastl		;[Victor] Check for out-of-space NOW!
	 jrst albve1		;[Victor] No need for GC
	skipa			;[Victor] Skip over SGC return address
	 jrst albve0		;[Victor] Come here from SGC.
				;[Victor] Then compute things again
	 call sgc		;[Victor] Do it.
albve1:	;;[Victor] Now continue just as usual, we know we have room.
	push free,[inum st%vec]		;assume subtype 0
	push free,o1			;start with size
	move w2,o1			;w2 - size as number
	posnum w2
	xmovei o1,1(free)		;save start as returned vector
	tlc o1,(object(ty%vec,0))
	xmovei w3,1(free)		;w3 - start of data
	add free,w2
	jumpe w2,makv1			;nothing more if size 0
	movem o2,(w3)			;initialize first word
	subi w2,1			;need to clear this many more
	jumpe w2,makv1			;no more to do
	xmovei w4,1(w3)			;copy from start to start+1
	xblt w2,
makv1:	camle free,lastl	;see if went beyond end of space
	 call sgc		;yes
	ret1				;object already in o1

makver:	err1 o1,/Size of vector must be non-negative integer/
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; EMACS interface
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

.scalar edfork,edpc
.vector edacs(20)

;offsets into the editor's (teco's) buffer block
;  all values are byte offsets from the begining of the section unless 
;  otherwise noted. (see INFO:TECORD.INFO for more information)
bufbeg==0			;BEG - start of the buffer
bufbgv==1			;BEGV - virtual start of buffer
bufpt==2			;PT - point in this buffer
bufgpt==3			;GPT - start of gap
bufvz==4			;VZ - virtual end of buffer
bufz==5				;Z - end of buffer
bufext==6			;EXTRAC - size of gap
bufcal==7			; - routine to call for protocol service
bufarg==10			; - argument for above routine
				;   if arg >= 0  then
				;	buffer must be at least that large
				;   else teco will do a jcl read
bufmod==11			;MODIFF - if the buffer was modified
bufrdo==12			;RDONLY - if the buffer is read only


;edkill - kill the current editor fork if it exists
edkill:	movei n,1		;returns 1 result
	skipn nil1,edfork	;is there one?
	 retn			;no, just return
	kfork			;kill it
	rfrkh			;release it's handle
	erjmp .+1		;ignore errors
	setzm edfork		;clear these
	setzm edpc
	setzb nil1,o1
	ret1			;end of edkill

;gedfrk - make sure we have an editor fork.  Creating it if needed.
gedfrk:	skipe edfork		;have one already?
	jrst gedfrx		;yes - just return its number
	setzm edpc		;say fork not started
	movsi nil1,(cr%cap)	;pass cap's (mostly ^C)
	cfork
	 jrst [err /Can't create editor fork/]
	movem nil1,edfork	;save fork handle
	movei w2,edsec		;make section for him
	call maksec
	 jrst [err /Can't make section for editor/]
	hrlz nil1,edfork	;fork,,0
	move w2,[.fhslf,,edsec*1000] ;self,,editor section
	move w3,[pm%cnt\pm%rwx\1000] ;the whole section, r/w/x
	pmap
;first try EDITOR:.  It must exist and be TECO-based.  Else
;just use EMACS.
	move nil1,[gj%old\gj%sht]
	hrroi w2,[asciz /EDITOR:/]
	gtjfn
	 jrst gedemc
	move w2,[1,,.fbusw]	;look at user-settable word
	movei w3,w4		;put it in W4
	gtfdb
	hlrz w4,w4		;get LH
	cain w4,'TEC'		;see if TECO-based
	jrst gedhav		;yes, have it
;here to use EMACS instead.  It had better be TECO-based!
gedemc:	move nil1,[gj%old\gj%sht]
	hrroi w2,[asciz /SYS:EMACS.EXE/]
	gtjfn
	 jrst [err /Can't open SYS:EMACS.EXE/]
gedhav:	hrl nil1,edfork		;fork,,jfn
	get			;get EMACS into memory
	setz nil1,
gedfrx:	move w2,edfork		;return the editor's fork handle
	maknum w2		;as a legit number
	move o1,w2
	ret1			;end of gedfrk

;edcall - call the editor's FS Superior handler with an arg of O1.
edcall:	skipn edpc		;has editor been run already?
	 jrst [	push q,o1	;no, run then stop the editor
		call edcret
		pop q,o1
		jrst .+1 ]
	call edregs		;get the editor's ACs
	move w4,w2		;save the address of the buffer block
	call get1nt		;get the word integer form of the arg	
	hrli w4,edsec		;create an extended addressing pointer
	movem w2,bufarg(w4)	;save the argument for FS Superior
	push p,edpc		;save the old pc
	movei w3,bufcal(w4)	;get the address of  FS Superior
	movem w3,edpc
	setz o1,
	call edrun		;run it
	pop p,edpc
	ret1			;end of edcall

;edjcl - pass some jcl (a string in O1) to the editor
; returns the string
edjcl:	call mflnam		;put the string into FILNAM
	hrroi nil1,filnam
	rscan
	 jrst [err /Can't do RSCAN/]
	setz nil1,
	ret1			;end of edjcl

;edregs - read the editor's registers into edacs
; and return the address of the editor's buffer block
edregs:	move nil1,edfork
	move w2,[codsec,,edacs]	;where to put them acs
	rfacs			;get the acs
	setz nil1,
	move w2,edacs+2		;return address of editor's buffer block
	hrli w2,edsec
	iret			;end of edregs

;edrun - start or continue the editor.
; If O1 is NIL and the fork has been started, continue it by starting at EDPC
; else if O1 is a small integer, start the fork at that entry vector offset
; else just start the fork at offset zero
edrun:	movei w4,ourtym		;save current terminal status
	call gettym
;;[Victor] Uncommented three lines
	hlrz nil1,erchin	;cancel ^G if any
	trnn nil1,400000	;if -1, none at all
	dti	
	skipn o1		;If O1 is NIL
	skipn edpc		;and if editor started
	skipa
	 jrst [	xmovei w4,edtym	;continue editor
		call settym	;set up EMACS's terminal status
		move nil1,edfork
		move w2,edpc	;and "continue" it from EDPC
		sfork
		jumpa edwait ]	;and wait for the return
	gettyp o1		;else if O1
	cain w2,ty%lpi		; is an inum
	 jrst [ldint w2,o1	; get the starting offset
		jrst .+2 ]	; and go start the fork
	setz w2,		;else if O1 is T or fork not started, offset 0
	move nil1,edfork	;start emacs
	setz edpc		;signal a start
	sfrkv
edwait:	wfork			;wait for it to get back to us
	call edchex		;check for ^C (must be right after wfork)
	xmovei w4,edtym		;get status from editor
	call gettym
	move nil1,edfork
	rfsts
	movem w2,edpc		;save PC for continue
	xmovei w4,ourtym	;and put back ours
;;[Victor] Uncommented three lines
	move nil1,erchin	;put back ^G if any
	tlnn nil1,400000	;if -1, none at all
	ati	
	call settym
	setz nil1,		;fix nil
	call edregs		;get the registers of the editor
	move w2,edacs+3		;return the number arg from the FS EXIT
	jrst ret1nt		;end of edrun

;EDCHEX - check exit from editor.  This is to be called
; immediately after each WFORK.  It checks to see if the editor was
; ^C'ed.  If so, it does HALTF, and continues the editor when it is
; continued.  It returns to the instruction before its call, so that
; had better be a wfork.
edchex:	push p,nil1		;save AC1, the fork
	rwm			;look at interrupts
	tlne w2,(1_34.)		;level 1 in progress?
	 jrst edchcc		;yes - ^C
	pop p,nil1		;no, continue normally
	iret			;end of edchex

edchcc:	movei w4,edtym		;save editor terminal status
	call gettym
	movei w4,ourtym		;restore out terminal status
	call settym
	haltf
	movei w4,edtym		;restore editor terminal status
	call settym
	move nil1,(p)		;handle
	rfsts			;get PC to W2
	pop p,nil1		;handle again
;this code obviously works only because EMACS is a one-section
;program.  It will also fail if EMACS is execute-only.  Unfortunately
;continuing doesn't always work, so even though this is less elegant,
;it is more reliable.
 	andi w2,777777		;throw away flags
	sfork
	sos (p)			;return to WFORK
	sos (p)
	iret			;end of edchcc


tymlen==5		;length of block used to save term params

	.vector ourtym(tymlen),edtym(tymlen)

;gettym - move current terminal parameters into block whose addr is in W4
gettym:	movei nil1,.fhjob	;get job's interrupt word
	rtiw
	dmovem w2,3(w4)
	movei nil1,.priou
	rfmod
	movem w2,0(w4)
	rfcoc
	dmovem w2,1(w4)
	setz nil1,
	iret			;end of gettym

;settym - set terminal parameters from block whose addr is in W4
settym:	movei nil1,.fhjob
	dmove w2,3(w4)
	stiw
	 erjmp .+1
	movei nil1,.priou
	move w2,0(w4)
	sfmod
	stpar
	dmove w2,1(w4)
	sfcoc
	setz nil1,
	iret			;end of settym

;edput - low-level I/O routine
;o2 - channel
;w2 - char
edput:	sosge ch%bct(o2)	;any space left?
	jrst [ 	push p,w2	;make sure these are preserved
		push p,w3
		move o1,o2	;use current channel
		aos ch%bct(o2)	;undo failing SOS
		call edclip+1	;account for use so far
	       	move o1,[inum 5620.]	;make gap 1K words
		call gedbuf	;try to expand the buffer
		move w2,edacs+2	;see what we got
		hrli w2,edsec
		move w3,bufext(w2)
		movem w3,ch%bct(o2)	;remeber new buffer space
		pop p,w3
		pop p,w2
		jrst edput]	;and try again
	idpb w2,ch%bpt(o2)
	jrst putact		;end of edput

;edget - low-level I/O routine
;o2 - channel
;w2 - char
edget:	skipl w2,ch%lka(o2)	;lookahead?
	 jrst getlka		;yes, use it
	sosge ch%bct(o2)	;any chars left?
	 jrst getclr		;no, throw EOF
	ildb w2,ch%bpt(o2)
	aos (p)			;assume no cr
	aos (p)
	movem w2,ch%lst(o2)	;save for unread
	cain w2,15		;cr?
	 jrst trmcr		;yes, check for lf
	iret

;edclrb - clear the buffer
edclrb:	call edcret		;make sure we have a valid buffer
	call edregs		;get editor ACs
	move w3,bufz(w2)	;compute physical size
	sub w3,bufbeg(w2)
	add w3,bufext(w2)
	movem w3,bufext(w2)	;now call it all gap
	move w3,bufbeg(w2)	;everything else at start
	movem w3,bufbgv(w2)
	movem w3,bufpt(w2)
	movem w3,bufgpt(w2)
	movem w3,bufvz(w2)
	movem w3,bufz(w2)
	move w2,bufext(w2)	;return size
	jrst ret1nt

;edwrit - return a channel for writing into a buffer at point
edwrit:	call edcret		;make sure we have a valid buffer
	move o1,[inum 5620.]
	call gedbuf
	call makchn		;returns a new channel object in o1
	move w2,[codsec,,edput] ;use special output routine that puts into buf
	movem w2,ch%put(o1)
	move w2,[disp eddsp]
	movem w2,ch%dsp(o1)
  ; now adjust the buffer so there is a reasonable size gap
	move w2,edacs+2
	hrli w2,edsec
	move w3,bufext(w2)	;tell EDGET the gap size
	movem w3,ch%bct(o1)
	move w3,bufpt(w2)	;get start of insert
	adjbp w3,[440740,,0 ? edsec,,0]	;build a byte pointer to it
	dmovem w3,ch%bpt(o1)	;save it in channel control block
	ret1			;end of getbuf

;edgap - ask the editor to move the gap to the end
edgap:	setz o1,		;don't kill currect editor
	skipe edfork		;has the editor been run?
	skipn edpc
	 jrst [	err /Editor hasn't been run/]
	call edregs		;get address of editor's buffer block
	push p,bufpt(w2)	;save old point
	move w3,bufz(w2)	;put point at end
	movem w3,bufpt(w2)
	setzm bufarg(w2)	;ask for the gap to be closed
	push p,edpc		;save old pc
	movei w2,bufcal(w2)	;get FS Superior address
	movem w2,edpc		;and start there
	setz o1,
	call edrun
	move w2,edacs+2
	hrli w2,edsec
	pop p,edpc		;restore old pc
	pop p,bufpt(w2)		;restore point
	ret1			;end of edgap

;edread - return a channel for reading from the buffer
edread:	call edgap		;close the gap
	call makchn		;returns a new channel object in o1
	move w2,[codsec,,edget] ;use special input routine that read fr list
	movem w2,ch%get(o1)
	move w2,[disp eddsp]
	movem w2,ch%dsp(o1)
	call edregs		;get address of editor's buffer block
	move w3,bufbgv(w2)	;begin of buffer (bytes from start of section)
	adjbp w3,[440740,,0 ? edsec,,0]	;w3/4 gets byte pointer
	dmovem w3,ch%bpt(o1)
	move w3,bufvz(w2)	;end
	sub w3,bufbgv(w2)	;- begin
	movem w3,ch%bct(o1)	;--> length
	ret1			;end of edread

;edcret - make sure the editor has a valid buffer
;  run the editor (and tell it to stop) if needed
edcret:	call gedfrk		;make sure we have an editor	
	skipe edpc		;has the editor been run?
	 jrst ret1v		;yes, done
	move o1,[makstr /CLISP M(M.M Lisp Mode)0FSEXIT/]
	call edjcl
	call edrun		;start it
	ret1			;end of edcret

;gedbuf - make the gap O1 bytes at point
;  returns  the size of the buffer.
gedbuf:	move w2,o1		;get the real size
	posnum w2
	push p,w2		;save the size
	call edcret		;make sure we have a buffer in the editor fork
	call edregs		;get address of editor's buffer block
	move w3,bufpt(w2)	;is it in right place?
	came w3,bufgpt(w2)
	 jrst gedbu0		;no
	move w3,bufext(w2)	;gap size
	caml w3,0(p)		;is it big enough?
	 jrst gedbu1		;yes - nothing to do
;here if we need to ask for more space
gedbu0:	move w3,0(p)		;total buffer size we need (in chars)
	movem w3,bufarg(w2)
	push p,bufpt(w2)	;this is going to move PT to after new space
	push p,edpc		;save old editor pc
	movei w2,bufcal(w2)	;addr to start him at
	movem w2,edpc		;start editor here
	setz o1,
	call edrun
	pop p,edpc		;restore original editor pc
	call edregs		;get the editor's buffer block again
	pop p,w3		;old PT
	sub w3,bufpt(w2)	;old - new PT (negative)
	addm w3,bufpt(w2)	;adjust things to move point back
	addm w3,bufgpt(w2)
	addm w3,bufvz(w2)
	addm w3,bufz(w2)
	movn w3,w3		;now add this garbage into gap
	addb w3,bufext(w2)	;w3 also gets gap size
	camge w3,0(p)		;is it big enough?
	jrst [err /EMACS couldn't make big enough buffer/]	;no
gedbu1:	pop p,w2		;cleanup wanted size
	move w2,w3		;return the buffer size
	jrst ret1nt		;end of gedbuf


;edclip chan - call after done writing - updates point, etc.
edclip:	movei o1,nil		;default to current output
	oustrm o1		;and validate channel
	move w3,ch%put(o1)	;is this an editor channel
	came w3,[codsec,,edput]
	 jrst [ err /not an editor channel/]	;no, die
	call edregs		;get the address of the editor's buffer block
	move w3,bufext(w2)	;gap when we started
	sub w3,ch%bct(o1)	;- gap now - this is number of char's written
	addm w3,bufz(w2)	;adjust everything
	addm w3,bufvz(w2)
	addm w3,bufgpt(w2)
	addm w3,bufpt(w2)
	movn w3,w3
	addm w3,bufext(w2)
	setzm ch%bct(o1)	;say there is no more space in the buffer
	ret1			;end of edclip

;editor-set-modified (T/NIL)
edmod:	call edregs		;get addr of buffer
	skipe w3,o1		;if modified
	seto w3,		;normalize to -1
	movem w3,bufmod(w2)
	ret1

;editor-modified-p
edmdp:	call edregs		;get addr of buffer
	skipe w3,bufmod(w2)	;if modified
	 jrst rett
	jrst retnil
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; STUBS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

d.fer0:	fncall [%ERROR],1
	retn

d.cer0:	fncall [%CERROR],2
	retn

d.fer1:	fncall [%ERROR],2
	retn

d.cer1:	fncall [%CERROR],3
	retn

cerror:	jfcl		;2 args
	jfcl		;3 args
	jfcl		;4 args
	jrst cerrrn	;5 args
	jfcl
cerrrn:	push q,o2
	call lines0
	pop q,o1
	call print
	call terpri
	jrst restar

error:	setz o2,	;1 arg
	jfcl		;2 args
	jfcl		;3 args
	jfcl		;4 args
	jfcl 		;5 args
	jfcl		;6 or more
errorn:	push q,o2
	push q,o1
	call lines0
	pop q,o1
	call print
	call terpri
	pop q,o1
	call print
	call terpri
	jrst restar

clrin:	ret1

cubin1:	jrst unbin1

the:	docdr o1,o1
	docdr o1,o1
	docar o1,o1
	call eval
	evexit

;substr (simple string, start, count)
substr:	xtype o1
	caie w2,ty%xst
	jrst [err1 o1,/Arg to SUBSTR must be a string/]
	push free,[inum 5]
	push free,o1
	move o1,free
	tlo o1,(object(ty%arh,0))
	push free,o3
	push free,nil
	push free,o2
	subi o3,1
	push free,o3
	ret1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; UNBOX - unpack an object (primarily for debugging)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;Returns two non-negative integer values:
;; the pointer (right 30 bits), and the type (left 6 bits).

unbox:	ldb o2,[.bp 77_30.,o1]
	tlz o1,770000
	maknum o1
	maknum o2
	ret2


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FACTT - test function for debugging
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;This function is mostly for debugging the debugger.  When the
;;interpreted piece is defined, it is a recursive factorial, where
;;alternate plies are interpreted and compiled.   This is supposed
;;to look like the code compiled by the compiler.

	.scalar factds

facti:
factt:
;once-only initialization, but who cares about speed for this?
	move w2,@[.facti+at%dsp] ;get function dispatch
	xmovei w2,1(w2)		;the right entry	
	hrrm w2,factt0
	movei w3,ccic1		;fix up the block, which currently
	hrrm w3,(w2)		;points here
;now the code
	push q,o1
	call zerop
	jumpn o1,factt1		;is zero, return 1
	move o1,(q)
	call sub1
factt0:	pushj p,@0
	pop q,o2
	jrst times

factt1:	subi q,1
	move o1,[inum 1]
	ret1

;there is a bug in Midas that causes not enough space to be allocated
;in pass 1.  The following is a fix for that.  It generates one more
;word of constants in pass 1 than pass 2.

["abcd"]
if1 [
["abce"]
]
if2 [
["abcd"]
]

	consta			;make sure all pure stuff is down

funchr:	%T			;null
	%T			;^A
	%T			;^B
	%T			;^C
	%T			;^D
	%T			;^E
	%T			;^F
	%T			;^G - eol
	%T			;^H
	%T			;^I - spacing
	%T			;^J - lf
	%T			;^K - vert tab
	%T			;^L - form feed
	%T			;^M - cr
	%T			;^N
	%T			;^O
	%T			;^P
	%T			;^Q
	%T			;^R
	%T			;^S
	%T			;^T
	%T			;^U
	%T			;^V
	%T			;^W
	%T			;^X
	%T			;^Y - comment
	%T			;^Z - comment
	%T			;esc
	%T			;^\
	%T			;^]
	%T			;^^
	%T			;^_
	%T			;40 - space
	NIL			;!
	%T			;"
	%T			;#
	NIL			;$
	NIL			;%
	NIL			;&
	%T			;'
	%T			;(
	%T			;)
	NIL			;*
	NIL			;+
	%T			;,
	NIL			;-
	NIL			;.
	NIL			;/
repeat 10.,NIL			;0 - 9
	%T			;:
	%T			;;
	NIL			;<
	NIL			;=
	NIL			;>
	NIL			;?
	NIL			;@
repeat 26.,NIL			;A-Z
	NIL			;[
	%T			;\
	NIL			;]
	NIL			;^
	NIL			;_
	%T			;`
repeat 26.,NIL			;lower case
	NIL			;{
	NIL			;|
	NIL			;}
	NIL			;~
	%T			;delete


;The following stuff is used only for initialization.  Thus it should
;be in the pure section

;The following stuff is used only in initialization.  
;initial read table attributes

irdatr:	inum rd%ill		;null
	inum rd%ill		;^A
	inum rd%ill		;^B
	inum rd%ill		;^C
	inum rd%ill		;^D
	inum rd%ill		;^E
	inum rd%ill		;^F
	inum rd%ill		;^G - eol
	inum rd%ill		;^H
	inum rd%wht		;^I - spacing
	inum rd%wht		;^J - lf
	inum rd%ill		;^K - vert tab
	inum rd%wht		;^L - form feed
	inum rd%wht		;^M - cr
	inum rd%ill		;^N
	inum rd%ill		;^O
	inum rd%ill		;^P
	inum rd%ill		;^Q
	inum rd%ill		;^R
	inum rd%ill		;^S
	inum rd%ill		;^T
	inum rd%ill		;^U
	inum rd%ill		;^V
	inum rd%ill		;^W
	inum rd%ill		;^X
	inum rd%ill		;^Y - comment
	inum rd%ill		;^Z - comment
	inum rd%ill		;esc
	inum rd%ill		;^\
	inum rd%ill		;^]
	inum rd%ill		;^^
	inum rd%ill		;^_
	inum rd%wht		;40 - space
	inum rd%con		;!
	inum rd%trm		;"
	inum rd%con		;#
	inum rd%con		;$
	inum rd%con		;%
	inum rd%con		;&
	inum rd%trm		;'
	inum rd%trm		;(
	inum rd%trm		;)
	inum rd%con		;*
	inum rd%sgn		;+
	inum rd%con		;,
	inum rd%sgn		;-
	inum rd%dot		;.
	inum rd%slh		;/
repeat 10.,inum rd%dig		;0 - 9
	inum rd%pkg		;:
	inum rd%trm		;;
	inum rd%con		;<
	inum rd%con		;=
	inum rd%con		;>
	inum rd%con		;?
	inum rd%con		;@
repeat 3.,inum rd%con		;A-C
repeat 3.,inum rd%exp		;D-F
repeat 5.,inum rd%con		;G-K
	inum rd%exp		;L
repeat 6.,inum rd%con		;M-R
	inum rd%exp		;S
repeat 7.,inum rd%con		;T-Z
	inum rd%con		;[
	inum rd%esc		;\
	inum rd%con		;]
	inum rd%con		;^
	inum rd%con		;_
	inum rd%con		;`
repeat 3.,inum rd%con		;a-c
repeat 3.,inum rd%exp		;d-f
repeat 5.,inum rd%con		;g-k
	inum rd%exp		;l
repeat 6.,inum rd%con		;m-r
	inum rd%exp		;s
repeat 7.,inum rd%con		;t-z
	inum rd%con		;{
	inum rd%mes		;|
	inum rd%con		;}
	inum rd%con		;~
	inum rd%ill		;delete

;initial read macro table.  If a characater does not have a read
;macro definition, we use RDTOK.  We use this even for whitespace
;and other kinds of characters for which this entry should never
;be used.

irdrdm:	inum <codsec,,rdtok>	;null - should never get through
	inum <codsec,,rdtok>	;^A
	inum <codsec,,rdtok>	;^B
	inum <codsec,,rdtok>	;^C
	inum <codsec,,rdtok>	;^D
	inum <codsec,,rdtok>	;^E
	inum <codsec,,rdtok>	;^F
	inum <codsec,,rdtok>	;^G - eol
	inum <codsec,,rdtok>	;^H
	inum <codsec,,rdtok>	;^I - spacing
	inum <codsec,,rdtok>	;^J - lf
	inum <codsec,,rdtok>	;^K - vert tab
	inum <codsec,,rdtok>	;^L - form feed
	inum <codsec,,rdtok>	;^M - cr
	inum <codsec,,rdtok>	;^N
	inum <codsec,,rdtok>	;^O
	inum <codsec,,rdtok>	;^P
	inum <codsec,,rdtok>	;^Q
	inum <codsec,,rdtok>	;^R
	inum <codsec,,rdtok>	;^S
	inum <codsec,,rdtok>	;^T
	inum <codsec,,rdtok>	;^U
	inum <codsec,,rdtok>	;^V
	inum <codsec,,rdtok>	;^W
	inum <codsec,,rdtok>	;^X
	inum <codsec,,rdtok>	;^Y - comment
	inum <codsec,,rdtok>	;^Z - comment
	inum <codsec,,rdtok>	;esc
	inum <codsec,,rdtok>	;^\
	inum <codsec,,rdtok>	;^]
	inum <codsec,,rdtok>	;^^
	inum <codsec,,rdtok>	;^_
	inum <codsec,,rdtok>	;40 - space
	inum <codsec,,rdtok>	;!
	inum <codsec,,rdstr>	;"
	inum <codsec,,rdtok>	;#
	inum <codsec,,rdtok>	;$
	inum <codsec,,rdtok>	;%
	inum <codsec,,rdtok>	;&
	inum <codsec,,rdquot>	;'
	inum <codsec,,rdlst>	;(
	inum <codsec,,rdrpar>	;)
	inum <codsec,,rdtok>	;*
	inum <codsec,,rdtok>	;+
	inum <codsec,,rdtok>	;,
	inum <codsec,,rdtok>	;-
	inum <codsec,,rdtok>	;.
	inum <codsec,,rdtok>	;/
repeat 10.,inum <codsec,,rdtok>	;0 - 9
	inum <codsec,,rdtok>	;:
	inum <codsec,,rdcom>	;;
	inum <codsec,,rdtok>	;<
	inum <codsec,,rdtok>	;=
	inum <codsec,,rdtok>	;>
	inum <codsec,,rdtok>	;?
	inum <codsec,,rdtok>	;@
repeat 26.,inum <codsec,,rdtok>	;A - Z
	inum <codsec,,rdtok>	;[
	inum <codsec,,rdtok>	;\
	inum <codsec,,rdtok>	;]
	inum <codsec,,rdtok>	;^
	inum <codsec,,rdtok>	;_
	inum <codsec,,rdtok>	;`
repeat 26.,inum <codsec,,rdtok>	;a - z
	inum <codsec,,rdtok>	;{
	inum <codsec,,rdtok>	;|
	inum <codsec,,rdtok>	;}
	inum <codsec,,rdtok>	;~
	inum <codsec,,rdtok>	;delete

	variab			;then all variables

;one long real arg
        xwd -1,0                ;one arg
arglis: rarg reaarg             ;here is the arg
        0

reaarg: 0                       ;place for arg
        0

;two long real args
	xwd -2,0
argli2:	rarg reaarg
	rarg reaar2

reaar2:	0
	0

;one integer arg
        xwd -1,0                ;one arg
irglis: iarg reaarg             ;here is the arg
        0

;save P in case of error return
lispp:  0

trpblk:
trpflg: 0               ;flags
trpadr: 0               ;PC
        0               ;eff addr
trpnpc: xwd codsec,ovrflw ;addr of trap routine [in init, add in section]

inprch:	asciz /*/		;initial prompt

erchin:	"G"-100,,3		;initial ATI specification for ERRCH

chntab:	<2_30.>\<codsec,,cncint>	;0 - ^C
	0	;1
	0	;2
	<2_30.>\<codsec,,cngint>	;3 - ^G
	0	;4
	<2_30.>\<codsec,,cnbint>	;5 - ^B
	0	;6
	0	;7
	0	;8
	<2_30.>\<codsec,,pdlovr>	;9 - PDL overflow (impossible)
	0	;10
	<2_30.>\<codsec,,illins>	;11 - file data error
	0	;12 - disk full
	0	;13
	0	;14
	<2_30.>\<codsec,,illins>	;15 - ill instruction
	<2_30.>\<codsec,,illmem>	;16 - ill mem read
	<2_30.>\<codsec,,illmem>	;17 - ill mem write
	0	;18
	0	;19
	<2_30.>\<codsec,,sysres>	;20 - system resources
	0	;21
	0	;22
	0	;23
	<1_30.>\<codsec,,cnyint>	;24 - ^Y
repeat 13.,[0]

fremap:	-1		;64 bits
	777777777400
;Start of OBLIST.  This has to go up in the section where garbage
;collection is done.

	normal==.	

	loc datoff*1000	;stay out of the AC's
	strloc==datof2*1000  ;constant strings go here in datsc2

atmlst==0		;end of list of all atoms
katmls==0		;end of list of all keyword atoms

;FA%SIZ
define declad(addr,min,max)	;declare address block
	object ty%lpi,<codsec,,normal>	;put in pointer to it
...a==addr
highadr==.
	loc normal
repeat min,[
	object ty%iadr,<codsec,,tfaerr>]
repeat max-min+1,[
	object ty%iadr,<codsec,,...a>
...a==...a+..incr]
repeat 6-max,[
	object ty%iadr,<codsec,,tmaerr>]
	object ty%cat,<datsec,,highadr-6>
	0
normal==.
	loc highadr
	termin

..incr==1

;macros for defining atoms

;   a macro to make a pname body
;   must be pointed to by a valid (constant) string pointer
define mkpnam &string&
	datloc==.
	loc strloc
pnstln==.length string
	object ty%sp5,pnstln
	ascii string
	strloc==.
	loc datloc
termin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;a simple atom
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

define declat(atname,prefix)
;cons cell in oblist - car is this atom, cdr points to next oblist entry

object ty%cat,<datsec,,.>

ifb [prefix][
%!atname=<object ty%cat,<datsec,,.>>
if1 ifdef .!atname,printx /.!atname redefined/
.!atname=<datsec,,.>
]
ifnb [prefix][
%!prefix=<object ty%cat,<datsec,,.>>
if1 ifdef .!prefix,printx /.!prefix redefined/
.!prefix=<datsec,,.>
]

;beginning of atom - value, prop list, pname, ftn def
	%.UNBOUND		;;at%val
	nil			;;at%pro
	object ty%str,<datsec,,strloc>	;;at%pna
	nil			;;at%fun
	atmlst			;;at%pkg
atmlst==<datsec,,.-5>
	nil			;;at%dsp
	nil			;;at%fev
;PNAME - this is a string
	mkpnam |atname|
termin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;an atom with a SYM property
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

define declsy(atname,symval,prefix)
;cons cell in oblist - car is this atom, cdr points to next oblist entry

object ty%cat,<datsec,,.>

ifb [prefix][
%!atname=<object ty%cat,<datsec,,.>>
if1 ifdef .!atname,printx /.!atname redefined/
.!atname=<datsec,,.>
]
ifnb [prefix][
%!prefix=<object ty%cat,<datsec,,.>>
if1 ifdef .!prefix,printx /.!prefix redefined/
.!prefix=<datsec,,.>
]

;beginning of atom - value, prop list, pname, ftn def
	%.UNBOUND		;;at%val
	object ty%ccn,<datsec,,.+6>	;;at%pro
	object ty%str,<datsec,,strloc>	;;at%pna
	nil			;;at%fun
	atmlst			;;at%pkg
atmlst==<datsec,,.-5>
	nil			;;at%dsp
	nil			;;at%fev
	%SYM
	object ty%ccn,<datsec,,.+1>
	inum symval
	nil
;PNAME - this is a string
	mkpnam |atname|
termin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;an atom with a SYM property that is a code address
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

define declep(atname,symval,prefix)
;cons cell in oblist - car is this atom, cdr points to next oblist entry

object ty%cat,<datsec,,.>

ifb [prefix][
%!atname=<object ty%cat,<datsec,,.>>
if1 ifdef .!atname,printx /.!atname redefined/
.!atname=<datsec,,.>
]
ifnb [prefix][
%!prefix=<object ty%cat,<datsec,,.>>
if1 ifdef .!prefix,printx /.!prefix redefined/
.!prefix=<datsec,,.>
]

;beginning of atom - value, prop list, pname, ftn def
	%.UNBOUND		;;at%val
	object ty%ccn,<datsec,,.+6>	;;at%pro
	object ty%str,<datsec,,strloc>	;;at%pna
	nil			;;at%fun
	atmlst			;;at%pkg
atmlst==<datsec,,.-5>
	nil			;;at%dsp
	nil			;;at%fev
	%SYM
	object ty%ccn,<datsec,,.+1>
	inum <codsec,,symval>
	nil
;PNAME - this is a string
	mkpnam |atname|
termin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;a keyword-package atom
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

define declky(atname,prefix)
;cons cell in oblist - car is this atom, cdr points to next oblist entry

object ty%cat,<datsec,,.>

ifb [prefix][
$!atname=<object ty%cat,<datsec,,.>>
]
ifnb [prefix][
$!prefix=<object ty%cat,<datsec,,.>>
]

;beginning of atom - value, prop list, pname, ftn def
	object ty%cat,<datsec,,.>	;;at%val
	nil			;;at%pro
	object ty%str,<datsec,,strloc>	;;at%pna
	nil			;;at%fun
	katmls			;;at%pkg
katmls==<datsec,,.-5>
	nil			;;at%dsp
	nil			;;at%fev
;PNAME - this is a string
	mkpnam |atname|
termin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;DECLVA - an atom with a value
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

define declva(atname,val,prefix)
;cons cell in oblist - car is this atom, cdr points to next oblist entry

object ty%cat,<datsec,,.>

ifb [prefix][
%!atname=<object ty%cat,<datsec,,.>>
if1 ifdef .!atname,printx /.!atname redefined/
.!atname=<datsec,,.>
]
ifnb [prefix][
%!prefix=<object ty%cat,<datsec,,.>>
if1 ifdef .!prefix,printx /.!prefix redefined/
.!prefix=<datsec,,.>
]

;beginning of atom - value, prop list, pname, ftn def
	val			;;at%val
	nil			;;at%pro
	object ty%str,<datsec,,strloc>	;;at%pna
	nil			;;at%fun
	atmlst			;;at%pkg
atmlst==<datsec,,.-5>
	nil			;;at%dsp
	nil			;;at%fev
;PNAME - this is a string
	mkpnam |atname|
termin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;an atom with SUBR property, having min to max args
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

define declsu(atname,addr,min,max,prefix)
;cons cell in oblist - car is this atom, cdr points to next oblist entry

object ty%cat,<datsec,,.>

ifb [prefix][
%!atname=<object ty%cat,<datsec,,.>>
if1 ifdef .!atname,printx /.!atname redefined/
.!atname=<datsec,,.>
]
ifnb [prefix][
%!prefix=<object ty%cat,<datsec,,.>>
if1 ifdef .!prefix,printx /.!prefix redefined/
.!prefix=<datsec,,.>
]

;beginning of atom - value, prop list, pname, ftn def
	%.UNBOUND		;;at%val
	nil			;;at%pro
	object ty%str,<datsec,,strloc>	;;at%pna
	object ty%ccn,<datsec,,.+4>	;;at%fun
	atmlst			;;at%pkg
atmlst==<datsec,,.-5>
	declad addr,min,max	;;at%dsp
	nil			;;at%fev
;ftn defn
	%SUBR
	object ty%ccn,<datsec,,.+1>
	object ty%vec,<datsec,,.+4>
	nil
;dispatch vector
	inum st%vec		;normal vector
	object ty%lpi,7
...a==addr
repeat min,[
	object ty%iadr,<codsec,,tfaerr>]
repeat max-min+1,[
	object ty%iadr,<codsec,,...a>
...a==...a+1]
repeat 6-max,[
	object ty%iadr,<codsec,,tmaerr>]

;PNAME - this is a string
	mkpnam |atname|
termin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; special DECLSU for wierd names
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

define declss(atname,atlen,addr,min,max,prefix)
;cons cell in oblist - car is this atom, cdr points to next oblist entry

object ty%cat,<datsec,,.>

%!prefix=<object ty%cat,<datsec,,.>>
if1 ifdef .!prefix,printx /.!prefix redefined/
.!prefix=<datsec,,.>

;beginning of atom - value, prop list, pname, ftn def
	%.UNBOUND		;;at%val
	nil			;;at%pro
	object ty%str,<datsec,,strloc>	;;at%pna
	object ty%ccn,<datsec,,.+4>	;;at%fun
	atmlst			;;at%pkg
atmlst==<datsec,,.-5>
	declad addr,min,max	;;at%dsp
	nil			;;at%fev
;ftn defn
	%SUBR
	object ty%ccn,<datsec,,.+1>
	object ty%vec,<datsec,,.+4>
	nil
;dispatch vector
	inum st%vec		;normal vector
	object ty%lpi,7
...a==addr
repeat min,[
	object ty%iadr,<codsec,,tfaerr>]
repeat max-min+1,[
	object ty%iadr,<codsec,,...a>
...a==...a+1]
repeat 6-max,[
	object ty%iadr,<codsec,,tmaerr>]

;PNAME - this is a string
	datloc==.
	loc strloc
	object ty%sp5,atlen
	atname
	strloc==.
	loc datloc

termin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;an atom with SUBR property, having min to max args, unusual INCR
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

define declsi(atname,addr,min,max,incr,prefix)
;cons cell in oblist - car is this atom, cdr points to next oblist entry

..incr==incr
object ty%cat,<datsec,,.>

ifb [prefix][
%!atname=<object ty%cat,<datsec,,.>>
if1 ifdef .!atname,printx /.!atname redefined/
.!atname=<datsec,,.>
]
ifnb [prefix][
%!prefix=<object ty%cat,<datsec,,.>>
if1 ifdef .!prefix,printx /.!prefix redefined/
.!prefix=<datsec,,.>
]

;beginning of atom - value, prop list, pname, ftn def
	%.UNBOUND		;;at%val
	nil			;;at%pro
	object ty%str,<datsec,,strloc>	;;at%pna
	object ty%ccn,<datsec,,.+4>	;;at%fun
	atmlst			;;at%pkg
atmlst==<datsec,,.-5>
	declad addr,min,max	;;at%dsp
	nil			;;at%fev
;ftn defn
	%SUBR
	object ty%ccn,<datsec,,.+1>
	object ty%vec,<datsec,,.+4>
	nil
;dispatch vector
	inum st%vec		;normal vector
	object ty%lpi,7
...a==addr
repeat min,[
	object ty%iadr,<codsec,,tfaerr>]
repeat max-min+1,[
	object ty%iadr,<codsec,,...a>
...a==...a+incr]
repeat 6-max,[
	object ty%iadr,<codsec,,tmaerr>]

;PNAME - this is a string
	mkpnam |atname|

..incr==1		;put back normal INCR
termin

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;DECLMA - declare a MACRO
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

define declma(atname,addr,prefix)
;cons cell in oblist - car is this atom, cdr points to next oblist entry

object ty%cat,<datsec,,.>

ifb [prefix][
%!atname=<object ty%cat,<datsec,,.>>
if1 ifdef .!atname,printx /.!atname redefined/
.!atname=<datsec,,.>
]
ifnb [prefix][
%!prefix=<object ty%cat,<datsec,,.>>
if1 ifdef .!prefix,printx /.!prefix redefined/
.!prefix=<datsec,,.>
]

;beginning of atom - value, prop list, pname, ftn def
	%.UNBOUND		;;at%val
	nil			;;at%pro
	object ty%str,<datsec,,strloc>	;;at%pna
	object ty%ccn,<datsec,,.+4>	;;at%fun
	atmlst			;;at%pkg
atmlst==<datsec,,.-5>
	declad addr,1,1		;;at%dsp
	nil			;;at%fev
;ftn defn
	%MACRO
	object ty%ccn,<datsec,,.+1>
	%SUBR
	object ty%ccn,<datsec,,.+1>
	object ty%vec,<datsec,,.+4>
	nil
;dispatch vector
	inum st%vec		;normal vector
	object ty%lpi,7
	object ty%iadr,<codsec,,tfaerr>
	object ty%iadr,<codsec,,addr>
repeat 5,[
	object ty%iadr,<codsec,,tmaerr>]

;PNAME - this is a string
	mkpnam |atname|
termin


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;a SPECIAL FORM, no function definition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

define declsp(atname,addr,prefix)
;cons cell in oblist - car is this atom, cdr points to next oblist entry

object ty%cat,<datsec,,.>

ifb [prefix][
%!atname=<object ty%cat,<datsec,,.>>
if1 ifdef .!atname,printx /.!atname redefined/
.!atname=<datsec,,.>
]
ifnb [prefix][
%!prefix=<object ty%cat,<datsec,,.>>
if1 ifdef .!prefix,printx /.!prefix redefined/
.!prefix=<datsec,,.>
]

;beginning of atom - value, prop list, pname, ftn def
	%.UNBOUND		;;at%val
	nil			;;at%pro
	object ty%str,<datsec,,strloc>	;;at%pna
	nil			;;at%fun
	atmlst			;;at%pkg
atmlst==<datsec,,.-5>
	nil			;;at%dsp
	inum <codsec,,addr>	;;at%fev
;PNAME - this is a string
	mkpnam |atname|
termin


;Here is the oblist, the list of all atoms.  Note that the space used by
;the atoms and their property lists is not in free space.  so if they are
;changed, the GC won't recover the space.

stadrs==normal	;start of area in low seg with addresses

;the following atoms have special effects in APPLY.  They must be first
begamp=object ty%cat,<datsec,,.>
declat &OPTIONAL,amopt
declat &REST,amrest
declat &AUX,amaux
declat &KEY,amkey
declat &ALLOW-OTHER-KEYS,amallow
endamp=object ty%cat,<datsec,,.>
declsu +,eplus,0,6,plus
declsu -,ediff,1,6,diff
declsu *,etimes,0,6,times
declsu /,equot,1,6,quoto
declsu =,eeqp,1,6,eeqp
declsu /=,allne,1,6,allne
declss 360000000000,1,elessp,1,6,elsp
declss 361720000000,2,elesse,1,6,elese
declss 370000000000,1,egreat,1,6,egrp
declss 371720000000,2,egrete,1,6,egep
declsu 1+,add1,1,1,add1
declsu 1-,sub1,1,1,sub1
declsu ABS,absf,1,1
declep ADJUST-VALUES,adjval,adjval
declsu %ALLOCATE-BPS,albps,4,4,albps
declsu %SP-ALLOC-ARRAY,allarh,1,1,allarh
declsu %SP-ALLOC-B-VECTOR,allvec,2,2,allvec
declsu %SP-ALLOC-STRING,allstr,1,1,allstr
declsu %SP-ALLOC-U-VECTOR,allivc,2,2,allivc
declep ALLOC-CLOSURE-VECTOR,alclvc,alclvc
declsp AND,andf
declky APPEND
declsu APPLY,apply,1,6,aply
declsu APPLY-BUT-LAST,appbl,1,6,appbl
declsu APPLYHOOK,doapho,4,6,doapho
declva *APPLYHOOK*,nil,applyhook
declsi AREF,aref,1,6,2
declsu ARRAYP,arrayp,1,1,aryp
declat %SP-AREF,spref
declsi %ASET,aset,2,6,2
declat %SP-ASET,spset
declsu ASET1,aset1,3,3
declsu ASH,lshf,2,2
declsu ACOS,lacos,1,1
declsu ASIN,lasin,1,1
declsu ASSQ,assq,2,2
declsu ATAN,latan,1,2
declsu ATOM,atomp,1,1,atomp
declat %BENV%
declsu BIGNUMP,bignmp,1,1
declep BINDV,bindv
declsi BIT,aref,1,6,2
declsu BITP,bitp,1,1
declsi %BITSET,aset,2,6,2
declsu BIT-VECTOR-P,bitvcp,1,1,bitvcp
declsp BLOCK,dblock
declsu BOOLE,boole,3,3
declsu BOUNDP,boundp,1,1
declat BREAK-LOOP-CATCHER,brlpc
declky BROADCAST
declsu BYTE,byte,2,2,xbyte
declsu BYTE-POSITION,bytpos,1,1,bytep
declsu BYTE-SIZE,bytsiz,1,1,bytes
declky CAPITALIZE
declsu CAR,car,1,1
declsp CATCH,catch,dcatch
declsi %SP-CBIT,aref,1,6,2,spcbit
declsi %SP-CBITSET,aset,2,6,2,spcbts
declep CCATCH,ccatch
declsu CDR,cdr,1,1
declsu CERROR,cerror,2,6
declsi CHAR,aref,1,6,2
declat CHARACTER
declat CHAR-NAME,chrnam
declsu CHARPOS,chrpos,0,1
declsi %CHARSET,aset,2,6,2
declsu CHARACTERP,chrp,1,1,chrp
declsu CLEAR-INPUT,clrinp,0,1,clrinp
declsu %SP-CLOSE,closef,1,2,closef
declsu CLRHASH,clrhsh,1,1
declsu CLEAR-OUTPUT,clrout,0,1,clrout
declep CLOGEN,clogen
declsp COMMENT,evnil
declsu COMMONP,comonp,1,1,comnp
declsu COMPILED-FUNCTION-P,comfnp,1,1,comfnp
declsp COMPILER-LET,comlet,comlet
declsp COND,cond
declsu CONS,cons,2,2
declsu CONSP,consp,1,1
declat %CONSTANT,constant
declsu CONSTANTP,constp,1,1,cnstp
declsu COS,lcos,1,1
declsu COSH,lcosh,1,1
declky CREATE
declep CUNWIND,cunwnd
declep CTHROW,cthrow
declsu DDT,calddt,0,0
declsp DECLARE,declare
declsu DECODE-FLOAT,decflt,1,1,decflt
declsu DECODE-UNIVERSAL-TIME,decut,1,2,decut
declky DEFAULT
declat DEFMACRO
declsp DEFUN,defun
declsu DELETE-FILE,deletf,1,1,deletf
declsu %DEPOSIT-INSTRUCTION,dinst,4,4,dinst
declsu %DEPOSIT-OBJECT-POINTER,dobj,2,2,dobj
declsu %DEPOSIT-VALUE-REFERENCE,dvalr,2,2,dvalr
declsu %DEPOSIT-WORD,dpword,2,2,dpword
declsu DIRECTORY,direct,0,1
declma DO,do
declat DOUBLE-FLOAT,dblflt
declsu %SP-DOUBLE-FLOAT,double,1,1,spdoub
declsu DOUBLE-FLOATP,lngflp,1,1,dblfp
declky DOWNCASE
declsu DPB,dodpb,3,3,dodpb
declky ECHO
declsu EDITOR-BUFFER-SIZE,gedbuf,1,1,gedbuf
declsu EDITOR-CALL-FORK,edcall,1,1,edcall
declsu EDITOR-CLEAR-BUFFER,edclrb,0,0,edclrb
declsu EDITOR-CLIP-BUFFER,edclip,0,1,edclip
declsu EDITOR-CREATE-FORK,edcret,0,0,edcret
declsu EDITOR-GET-FORK,gedfrk,0,0,gedfrk
declsu EDITOR-KILL-FORK,edkill,0,0,edkill
declsu EDITOR-MODIFIED-P,edmdp,0,0,edmdp
declsu EDITOR-READ-CHANNEL,edread,0,0,edread
declsu EDITOR-RUN-FORK,edrun,1,1,edrun
declsu EDITOR-SET-JCL,edjcl,1,1,edjcl
declsu EDITOR-SET-MODIFIED,edmod,1,1,edmod
declsu EDITOR-WRITE-CHANNEL,edwrit,0,0,edwrit
declsu %SP-ENCODE-UNIVERSAL-TIME,encut,5,5,encut
declky END
declat *EOF*,eof
declsu EQ,eq,2,2
declsu EQL,eql,2,2
declsu EQUAL,equal,2,2
declsu EQUAL-CHAR-INT,eqchrn,1,1,eqchrn
declsu ERROR,error,1,6
declky ERROR
declky ESCAPE
declsu EVAL,ueval,1,1
declsu *EVAL,seval,1,5,seval
declsu %EVAL,eval,1,1
declsu EVAL-AS-PROGN,eprogn,1,1,eprogn
declsu EVALHOOK,doevho,3,6,doevho
declva *EVALHOOK*,nil,evalhook
declsp EVAL-WHEN,evwhen,evwhen
declsu EVENP,evenp,1,1
declsu EXIT,exit,0,0
declsu EXP,lexp,1,1
declsu %SP-EXPT,lexpt,2,2,expt
declky EXTERNAL
declsu FACT-COMPILED,factt,1,1,factt
declsu FACT-INTERPRETED,facti,1,1,facti
declsu FAST-CHAR-UPCASE,fchrup,1,1,fchrup
declsu FBOUNDP,fbndp,1,1
declat %FENV%
declat FEXPR
declsu FILE-AUTHOR,wrtaut,1,1,wrtaut
declsu FILE-LENGTH,fillen,1,1,fillen
declsu FILE-POSITION,filpos,1,2,filpos
declsu FILE-WRITE-DATE,wrtdat,1,1,wrtdat
declsu FIND-SYMBOL,fndsym,1,2,fndsym
declsu FINISH-OUTPUT,finout,0,1,finout
declsu FIXNUMP,fxnump,1,1
declsp FLET,flet
declsu FLOAT,float,1,2
declsu FLOATP,floatp,1,1,fltp
declsu FLOAT-RADIX,fltrad,1,1,fltrad
declsu FLOAT-SIGN,fltsgn,1,2,fltsgn
declsu FLUSH-WHITESPACE,uflswt,1,1,flswht
declsu FMAKUNBOUND,fmkubd,1,1
declsu FORCE-OUTPUT,frcout,0,1,frcout
declsu FRESH-LINE,lines0,0,1,frshln
declsu FSET,setdef,2,2
declat FSUBR
declsi FUNCALL,funcal,1,6,2
declsp FUNCTION,funct,func
declsu FUNCTIONP,functp,1,1,funcp
declsu %FUNCTION-ADDRESS-BLOCK,fadrbl,2,2,fadrbl
declat %FUN-DOCUMENTATION,fundoc
declsu GC,ugc,0,0
declsu GCD,egcd,0,6
declva *GC-TRIGGER*,<iflon 1.0>,gctrigger
declsu GENSYM,gensym,0,1
declsu GENTEMP,gentmp,0,2
declat %GENV%
declsu GET,xget,2,3
declsu GET-AND-CHECK-INT,gchkch,1,1,gchkch
declsu GET-BUFFER-STREAM-STRING,sbfstr,1,1,sbfstr
declsu GET-DECODED-TIME,getdt,0,0,getdt
declsu %SP-GET-DEFINITION,getdef,1,1,getdef
declsu GET-GC-TIME,gctime,0,0,gctime
declsu GETHASH,gethsh,2,3
declep GET1NT,get1nt		;[Victor] 
declsu GET-INTERNAL-REAL-TIME,getit,0,0,getit
declsu GET-INTERNAL-RUN-TIME,getirt,0,0,getirt
declsu GET-OUTPUT-STREAM-STRING,getost,1,1,getost
declsu GET-TERMINAL-MODES,gtmod,1,1,gtmod
declsu GET-UNIVERSAL-TIME,getut,0,0,getut
declsu %SP-GET-VALUE,getva,1,1,getva
declsu %SP-GET-VECTOR-ACCESS-TYPE,gvcacc,1,1,gvcacc
declsu %SP-GET-VECTOR-LENGTH,gvclen,1,1,gvclen
declat GLOBALLY-SPECIAL,glospec
declsp GO,go,gogo
declsu HASH-TABLE-COUNT,hshcnt,1,1,hshcnt
declsu HASH-TABLE-P,hashp,1,1,hashp
declsu HEADER-LENGTH,svclen,1,1,arhlen
declsu HEADER-REF,fvcref,2,2,fvcref
declsu HEADER-SET,fvcset,3,3,fvcset
declat %HENV%
declsu %SP-HOST,sphost,0,0,sphost
declsu IDENTITY,ident,1,1
declsp IF,if
declky INHERITED
declky INPUT
declsu INPUT-STREAM-P,instrp,1,1,istrmp
declsu INTEGER-DECODE-FLOAT,idecfl,1,1,idecfl
declsu INTEGER-LENGTH,intlen,1,1,intlen
declsu INTEGERP,intp,1,1
declsu %INT-ENT-TAB,intet,2,2,intet
declsu INTERN,intern,1,2
declky INTERNAL
declsu INT-TO-CHAR,int2ch,1,1,int2ch
declky IO
declat *KEYWORD-PACKAGE*,keypackage
declsu KEYWORDP,keywp,1,1
declsp LABELS,labels
declat LAMBDA
declep LB1,lb1
declep LB2,lb2
declep LB3,lb3
declep LB4,lb4
declep LB5,lb5
declsu LDB,doldb,2,2,xldb
declsp LET,let
declsp LET*,lets,lets
declat %LEXICAL-CLOSURE%,lexclo
declat *LISP-BOOT-FORM*,botfrm	;[Victor] New feature
declat *LISP-PACKAGE*,lisppackage
declsu LISTEN,listen,0,1
declsu LISTP,listp,1,1
declsu LIST-TO-VECTOR*,lst2vc,2,2,lst2vc
declsu LOG,llog,1,2
declat LONG-FLOAT,lngflt
declsu %SP-LONG-FLOAT,double,1,1,splong
declsu LONG-FLOATP,lngflp,1,1,lngfp
declsp MACRO,macro
declsu MACROEXPAND,mexp,1,5,mexp
declsu %MACROEXPAND,imexp,1,1,imexp
declsu MACROEXPAND-1,mexp1,1,5,mexp1
declsu %MACROEXPAND-1,imexp1,1,1,imxp1
declva *MACROEXPAND-HOOK*,<%funcal>,mexph
declsp *MACROEXPANSION*,macxpn,macxpn
declsu MACRO-FUNCTION,macfun,1,1,macfun
declsp MACROLET,maclet,maclet
declsu %SP-MAKE-BROADCAST-STREAM,makbrd,1,1,mkbrd
declsu MAKE-BUFFER-STREAM,bfstrg,0,0,bfstrg
declsu %SP-MAKE-CONCATENATED-STREAM,makcon,1,1,mkcon
declsu MAKE-ECHO-STREAM,makech,2,2,makech
declsu MAKE-FILL-POINTER-OUTPUT-STREAM,flstrg,1,1,flstrg
declsu %SP-MAKE-HASH-TABLE,makhsh,4,4,makhsh
declsu MAKE-STRING-INPUT-STREAM,instrg,1,3,instrg
declsu MAKE-STRING-OUTPUT-STREAM,oustrg,0,0,oustrg
declsu MAKE-SYMBOL,maksym,1,1,maksym
declsu MAKE-SYNONYM-STREAM,maksyn,1,1,mksyn
declsu MAKE-TWO-WAY-STREAM,maktow,2,2,mktow
declsu MAKUNBOUND,mkunbd,1,1
declsu MAPHASH,maphsh,2,2
declsu MASK-FIELD,mskfld,2,2,mskfld
declat MERGE-PATHNAMES,mrgnam
declsu MINUSP,minusp,1,1
declat MOD
declsp MULTIPLE-VALUE-BIND,mvbind,mvbind
declsp MULTIPLE-VALUE-CALL,mvcall,mvcall
declsp MULTIPLE-VALUE-LIST,mvlist,mvlist
declsp MULTIPLE-VALUE-PROG1,mvprg1,mvprg1
declsp MULTIPLE-VALUE-SETQ,mvsetq,mvsetq
declep MVP,mvp,mvp
declsy %SP-N,n,spn
declsu NAMESTRING,namstr,1,1
declky NEWEST
declky NEW-VERSION,newver
declsu NEXTBL,nextbl,2,2
declsu NEXTEV,nextev,1,1
declsu NOT,not,1,1
declsu NULL,not,1,1
declsu NUMBERP,nump,1,1
declsy O1,o1
declsy O2,o2			;[Victor]
declsy O3,o3			;[Victor]
declsy O4,o4			;[Victor]
declsy O5,o5			;[Victor]
declsy O6,o6
declsu ODDP,oddp,1,1
declky OLDEST
declsu %SP-OPEN,xopenf,5,5,xopenf
declsp OR,or
declky OUTPUT
declat OUTPUT-ARRAY,outarr
declsu OUTPUT-OBJECT,outobj,1,2,outobj
declat OUTPUT-PRETTY-OBJECT,outpretty
declsu OUTPUT-STREAM-P,oustrp,1,1,ostrmp
declat OUTPUT-STRUCTURE,outstr
declat OUTPUT-VECTOR,outvec
declsu OUTVAL,outval,2,2
declky OVERWRITE
declsy %SP-P,p,spp
declat PACKAGE,pkghead
declat *PACKAGE*,package
declat *PACKAGE-OBARRAY*,pkgobarray
declsu %SP-PARSE-NAMESTRING,prsnam,4,4,prsnam
declky PASS-ALL,passall
declat PATHNAME
declky PAUSE
declsu PEEK-CHAR,peekch,0,5,peekch
declsu PLUSP,plusp,1,1
declep POP-VALUES,stk2mv,popval
declsu PRIME,prime,1,1
declsu PRIMEP,primep,1,1,primp
declsu PRIN1,prin1,1,2
declsu PRIN1-TO-STRING,prin1s,1,1,prn1s
declsu PRINC,princ,1,2
declsu PRINC-TO-STRING,princs,1,1,prncs
declsu PRINT,print,1,2,prnt
declva *PRINT-ARRAY*,<%T>,prary
declva *PRINT-PRETTY*,<nil>,prnpretty
declva *PRINT-BASE*,<inum 10.>,base
declva *PRINT-CASE*,<$UPCASE>,prcas
declva *PRINT-ESCAPE*,<%T>,presc
declva *PRINT-GC-INFO*,nil,gcgag
declva *PRINT-GENSYM*,<%T>,prgensym
declva *PRINT-LENGTH*,nil,prlen
declva *PRINT-LEVEL*,nil,prlev
declva *PRINT-RADIX*,nil,prrad
declky PROBE
declsu PROBE-FILE,profil,1,1,profil
declsp PROG1,prog1
declsp PROG2,prog2
declsp PROGN,progn
declsp PROGV,progv
declsp PSETQ,psetq
declat PSEUDOFUNCTION
declsu PURIFY,purify,0,0,purify
declep PUSH-VALUES,mv2stk,pushva
declsu %PUT,putp,3,3,putp
declsu %PUTHASH,puthsh,3,3,puthsh
declsy %SP-Q,q,spq
declsp QUOTE,quote,quot
declat *RAISE,raise
declsu RATIONAL,ration,1,1
declsu RATIONALIZE,ration,1,1,ratize
declsu RATIONALP,ratnlp,1,1,ratnlp
declsu RATIOP,ratiop,1,1,ratop
declsu READ,read,0,4
declva *READ-BASE*,<inum 10.>,ibase
declsu READ-BYTE,rdbyte,1,3,rdbyte
declsu READ-CHAR,rdchar,0,4,rdchar
declsu READ-CHAR-NO-HANG,rdchnh,0,4,rdchnh
declva *READ-DEFAULT-FLOAT-FORMAT*,%SNGFLT,rddflt
declsu READ-DELIMITED-LIST,rdelst,1,2,rdelst
declsu READ-EXTENDED-TOKEN,rdextk,1,2,rdextk
declsu %SP-READ-FROM-STRING,stread,6,6,rfstr
declsu READ-LINE,rdline,0,4,rdline
declsu READ-LIST,rdlist,2,2,rdlist
declsu READ-PRESERVING-WHITESPACE,rdpws,0,4,rdpws
declva *READ-SUPPRESS*,nil,rdsup
declat READTABLE
declat *READTABLE*,crdtab
declat *REAL-EOF-ERRORP*,eoferp
declat *REAL-EOF-VALUE*,eofval
declsu REM,rem,2,2
declsu REMHASH,remhsh,2,2
declsu REMPROP,remp,2,2
declky RENAME
declky RENAME-AND-DELETE,rendel
declsu RENAME-FILE,rnamef,2,2,rnamef
declep REST1,rest1
declep REST2,rest2
declep REST3,rest3
declep REST4,rest4
declep REST5,rest5
declsu RESTART-LISP,restar,0,0,restar
declep RESTN,restn
declep RESTX,restx
declep RET1NT,ret1nt		;[Victor]
declep RETINT,retint		;[Victor]
declsp RETURN,return
declsp RETURN-FROM,retfro,retfro
declva RIGHT-PAREN-WHITESPACE,%T,rparwh
declsu ROOM,room,0,1
declsu RPLACA,rplaca,2,2,rplca
declsu RPLACD,rplacd,2,2
declsy SP,sp
declsu %SP-SAREF1,aref1,2,2,aref1
declsu %SP-SASET1,aset1,3,3,sast1
declsu SAVE,xsave,1,2
declsu %SP-SBIT,sbtref,2,2,sbtref
declsu SBIT,sbtref,2,2
declsu %SP-SBITSET,sbtset,3,3,sbtset
declsu %SBITSET,sbtset,3,3
declsu SCALE-FLOAT,sclflt,2,2,sclflt
declsu SCHAR,schref,2,2
declsu %SCHARSET,schset,3,3
declva SECONDARY-ATTRIBUTE-TABLE,%sectab,secatr
declsu SEQUENCEP,seqp,1,1,seqp
declsu SET,set,2,2
declsu %SP-SET-DEFINITION,setdef,2,2,setdef
declsu SET-MACRO-CHARACTER,smachr,2,4,smachr
declsu %SET-PLIST,ssympr,2,2,stplst
declsp SETQ,setq
declsu %SP-SET-TERMINAL-MODES,sstmod,2,2,stmod
declva SHARP-EQUAL-ALIST,nil,shpeql
declva SHARP-SHARP-ALIST,nil,shpshp
declsu %SP-SHORT-FLOAT,flonum,1,1,spshort
declsu SHORT-FLOATP,shtflp,1,1,shtflp
declsu %SP-SHRINK-VECTOR,srnkvc,2,2,srnkvc
declat SIGNAL-CERROR,sigcer
declat SIGNED-BYTE,sgnbyte
declat SILENT
declsu SIMPLE-BIT-VECTOR-P,simbvc,1,1,simbvc
declsu SIMPLE-STRING-P,simstr,1,1,simstr
declsu SIN,lsin,1,1
declsu SINH,lsinh,1,1
declat SINGLE-FLOAT,sngflt
declsu %SP-SINGLE-FLOAT,flonum,1,1,spsngle
declsu SINGLE-FLOATP,shtflp,1,1,sngfp
declsu SIMPLE-VECTOR-P,simvec,1,1,simvec
declva *SKIP-APPLYHOOK*,nil,skaphook
declva *SKIP-EVALHOOK*,nil,skevhook
declsu %SP-SLEEP,spdism,1,1,spdism
declsu SLISP-ARRAY-P,slarrp,1,1,slarrp
declsu SLISP-B-VECTOR-P,slbvcp,1,1,slbvcp
declsu SLISP-U-VECTOR-P,sluvcp,1,1,sluvcp
declsu SLISP-VECTOR-P,simvec,1,1,slvcp
declsu SPDLFT,spdlft,1,1
declsu SPDLRT,spdlrt,1,1
declsu SPEAK-NWDS,speak,0,0,speak
declat SPECIAL,spec
declsu SPECIAL-FORM-P,spcfrm,1,1,spcfrm
declsu SPEVAL,speval,2,2
declsu SPREDO,spredo,1,1
declsu SPREVL,sprevl,2,2
declsu SQRT,lsqrt,1,1
declva *STANDARD-INPUT*,<object ty%cch,<datsec,,trmchn>>,stdin
declva *STANDARD-OUTPUT*,<object ty%cch,<datsec,,trmchn>>,stdout
declky START
declat STD-LISP-READTABLE,srdtab
declat %%STKLIM
declsu STKPTR,stkptr,1,1
declsu STREAM-ELEMENT-TYPE,strelt,1,1,strelt
declsu STREAMP,strmp,1,1
declat STRING-CHAR,strchr
declsu SPDLPT,spdlpt,0,0
declsu %SP-STRING-COMPARE,strcmp,6,6,strcmp
declsu %SP-STRING-COMPARE-IGNORE,stricm,6,6,stricm
declsu STRING-CONCATENATE,stconc,2,2,stconc
declsu STRINGIFY-OBJECT,stfyob,1,2,stfyob
declsu STRINGP,strngp,1,1
declsu STRUCTUREP,strucp,1,1
declat SUBR
declsu SUBSTR,substr,3,3
declky SUPERSEDE
declsu SVREF,svcref,2,2
declsu %SP-SVREF,fvcref,2,2,spvref
declsu %SVSET,svcset,3,3
declsu %SP-SVSET,fvcset,3,3,spvset
declsu SXHASH,sxhash,1,1
declsu SYMBOLP,symbp,1,1
declat SYM
declsu SYMBOL-FUNCTION,symfun,1,1,symfun
declsu SYMBOL-NAME,symnam,1,1,symnam
declsu SYMBOL-PACKAGE,sympkg,1,1,sympkg
declsu SYMBOL-PLIST,symprp,1,1,symprp
declsu SYMBOL-VALUE,symval,1,1,symval
declsu %SP-SYSVER,spsysv,0,0,spsysv
declva T,%t
declsp TAGBODY,tagbod
declsu TAN,ltan,1,1
declsu TANH,ltanh,1,1
declva *TERMINAL-IO*,<object ty%cch,<datsec,,trmchn>>,trmio
declsu TERPRI,terpri,0,1
declsp THE,the
declsp THROW,throw
declep %TOO-FEW-ARGS,tfaerr,tfaat
declep %TOO-MANY-ARGS,tmaerr,tmaat
declat %TOP-LEVEL,toplev
declat *TRACE-OUTPUT*,trcout
declky TRANSLATE
declsu TRUENAME,trunam,1,1
declsu TRUNCATE,trunc,1,2
declsu %SP-TYPE,sptype,1,1,sptype
declep UB1,ub1
declep UB2,ub2
declep UB3,ub3
declep UB4,ub4
declep UB5,ub5
declep UFO,ufo
declep UNBIND,unbin1
declky UNBOUND-VARIABLE,unbnd
declsu UNBOX,unbox,1,1
declky UNDEFINED-FUNCTION,undef
declsu UNREAD-CHAR,unrdch,0,2,unrdch
declat UNSIGNED-BYTE,unsbyte
declsp UNWIND-PROTECT,unwind,unwind
declky UPCASE
declsu USER-HOMEDIR-PATHNAME,homdir,0,1,homdir
declsi VALUES,values,0,6,2
declep VALUES-CALL,vcall,vcall
declsu VALUES-LIST,vallst,1,1,vallst
declep VALUES-TO-LIST,mv2lst,v2lst
declsi VECTOR,vector,0,6,2,vectr
declsu VECTORP,vectrp,1,1,vctrp
declat %VENV%
declsy W2,w2
declsy W3,w3
declsy W4,w4			;[Victor]
declky WILD
declky WRAP
declsu WRITE-BYTE,wrtbyt,2,2,wrtbyt
declsu WRITE-CHAR,writch,1,2,writch
declsu %SP-WRITE-STRING,wrtstr,4,4,wrtstr
declsu ZEROP,zerop,1,1

declat NIL

%atmls==atmlst		;end of the list
%kyatl==katmls

;everything below here is not on the oblist, but will be translated by the
;GC.  This is the place to put variables that you want the GC to look at.

;first we have a list of values used internally.  These are required to
;be atoms, but we don't want the user using them.  So we keep them off
;the OBLIST.

atmlst==0	;so .UNBOUND doesn't have a bogus address in it
declat .UNBOUND

enadrs==normal	;end of area in section 1 with address blocks

define declfu(obj,val)
%!obj=inum <datsec,,.>
.!obj=<datsec,,.>
	val
termin

declfu BOTMSG,nil		;greeting message for saved file
declfu CPRLV,<inum 0>		;current recursive print level
declfu DFOUST,nil		;default output string for PRINx-TO-STRING
declfu RECP,nil			;recursivep
declfu SAVEP,nil		;used to flag saved P for eval blip
declfu DUMMY,nil		;dummy with no special meaning
declfu UNWPRO,nil		;unwind-protect blip
declfu CATCH,nil		;chain of catches
declfu GENSN,<inum 0>		;previous number from GENSYM
declfu GENSS,<object ty%str,<datsec,,strloc>> ;prefix for GENSYM
	mkpnam /G/
declfu GENTSN,<inum 0>		;previous number from GENTEMP


	inum st%vec		;normal vector
	inum 128.		;size of vector
sectab:
repeat 40,inum rd%ill		;control chars
	inum rd%ill		;40 - space
	inum rd%con		;!
	inum rd%con		;"
	inum rd%con		;#
	inum rd%con		;$
	inum rd%con		;%
	inum rd%con		;&
	inum rd%con		;'
	inum rd%con		;(
	inum rd%con		;)
	inum rd%con		;*
	inum rd%sgn		;+
	inum rd%con		;,
	inum rd%sgn		;-
	inum rd%dot		;.
	inum rd%slh		;/
repeat 10.,inum rd%dig		;0 - 9
	inum rd%pkg		;:
repeat 6.,inum rd%con		;; to @
repeat 3.,inum rd%con		;A-C
repeat 3.,inum rd%exp		;D-F
repeat 5.,inum rd%con		;G-K
	inum rd%exp		;L
repeat 6.,inum rd%con		;M-R
	inum rd%exp		;S
repeat 7.,inum rd%con		;T-Z
repeat 6.,inum rd%con		;[ to `
repeat 3.,inum rd%con		;a-c
repeat 3.,inum rd%exp		;d-f
repeat 5.,inum rd%con		;g-k
	inum rd%exp		;l
repeat 6.,inum rd%con		;m-r
	inum rd%exp		;s
repeat 7.,inum rd%con		;t-z
	inum rd%con		;{
	inum rd%con		;|
	inum rd%con		;}
	inum rd%con		;~
	inum rd%ill		;rubout

%sectab==<object ty%vec,<datsec,,sectab>>

  ;cfiles contains alternate saved SP, channel.  The idea is that if
  ;SP is ever restored to less than the saved value, that channel
  ;should be closed, and the entry popped off CFILES.

tail==ch%666-7

;;TY%CHN
trmchn:	object ty%spc,ch%666
	.priin
	80.
	0
	codsec,,trmget
	codsec,,trmput
	disp trmdsp
	-1
	0
	codsec,,trmbuf
	block tail-3
	makstr /TTY:/	

;DUMCHN is a dummy channel for use by EXPLODE and similars.  Note
;that this makes all such routines non-reentrant.
;;TY%CHN
dumchn:	object ty%spc,ch%666
	0
	-1
	0
	codsec,,clsdio
	codsec,,clsdio
	disp clsdsp
	-1
	block tail

;intspc is just a random unique thing to be used in marking
;atoms as bound specially.  Originally we used an atom
;%INTERNALLY-SPECIAL.  However this caused problems when
;apropos tried to evaluate it.  It is much safer not to
;let this or UNBOUND be in any hash table

intspc:	nil
	nil
%intspc==<object ty%ccn,<datsec,,intspc>>

eofobj:	%EOF
	nil
%eofobj==<object ty%ccn,<datsec,,eofobj>>

flone:	object ty%spc,2
	1.0
	0
%flone==<object ty%cfl,<datsec,,flone>>

flnone:	object ty%spc,2
	-1.0
	0
%flnone==<object ty%cfl,<datsec,,flnone>>

%keynic==<object ty%ccn,<datsec,,.>>
	makstr //
	nil

.dumchn==<object ty%cch,<datsec,,dumchn>>

;Here is the MV stack
mvstk:	repeat 1000, nil

endobl:
endstr==strloc
	loc .rl1

	block normal-140

	end start