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