12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379 |
- % This file contains a mixture of two sorts of things:
- % (A) PSL functions that are not defined in the files that I will
- % load to make myself a compiler, but that are required. For instance
- % various bits of the PSL compiler use "word" arithmetic (as in
- % wplus2). That would compile inline into a single machine code instruction
- % but it does not make good sense during cross-compilation where the issue
- % or word-length and data tagging on the host can not be relied on.
- %
- % (B) Replacements for some things that are defined in the compiler-related
- % sources but where the definitions are sufficiently PSL-specific that
- % I need to introduce my own replacements if I am to survive using some
- % alternative Lisp for bootstrapping. A significant set of functions
- % here are those that simulate a raw block of memory that can be accessed
- % either by bytes or words. Such memory is used to collect an image of
- % generated code and that is then written out to create a fasl file. PSL
- % can use memory directly. I simulate it using a vector in which I place
- % 64-bit integers, and I have ugly code involving shift and mask operations
- % for when I need to accesss it as if it was arranged in bytes.
- % There are other places where the code exploits or relies on detailed
- % PSL representation of data (eg idinf).
- % A further understandable jolly is that the PSL sources contain a number
- % of instances of definitions along the line
- % (de stringp (u) (stringp u))
- % which rely on the compiler generating in-line code for the body of
- % the function. Some such definitions are present within files i wish to
- % load to pick up other things in them! So instating my own version and
- % then setting a 'lose flag lets me make progress.
- %
- % (C) At the end of this file I read in "mytrace.lsp" which is my own
- % implementation of tracing code. Both VSL and PSL have perfectly
- % respectable trace capabilities of their own, but having my own one
- % here lets me arrange that test runs produce (almost) identical output
- % whichever platform they are run on, and the ability to do direct
- % log file comparisons to track down discrepancies is very useful.
- %
- %
- % I hope that every function (and macro) defined here ends up flagged
- % as 'lose so that a subsequent apparent definition in a PSL file that I
- % process does not override it.
- % At least for bootstrapping I need to restore MY version of SPACES
- (de spaces (n) % Print n blanks.
- (cond
- ((zerop n) nil)
- (t (princ " ") (spaces (sub1 n)))))
- (de intp (x) (and (fixp x) (not (bignump x))))
- (de flag1 (x y) (flag (list x) y))
- (de remflag1 (x y) (remflag (list x) y))
- (dm control (x)
- (list 'logand (list 'char-code (list 'quote (cadr x))) 31))
- (dm cntrl (x)
- (list 'logand (list 'char-code (list 'quote (cadr x))) 31))
- (de continuableerror (errnum message errorform*)
- (progn (errorprintf "***** %l" message)))
- (de main ())
- % Now the things just needed for creating fasl files... I will add things in
- % here to start with and maybe move them to psl-support-2.lsp later...
- (de concat (a b) (string-concat a b))
- (de binarywrite (stream val)
- (binarywritebyte stream val)
- (binarywritebyte stream (setq val (rsh val 8)))
- (binarywritebyte stream (setq val (rsh val 8)))
- (binarywritebyte stream (setq val (rsh val 8)))
- (binarywritebyte stream (setq val (rsh val 8)))
- (binarywritebyte stream (setq val (rsh val 8)))
- (binarywritebyte stream (setq val (rsh val 8)))
- (binarywritebyte stream (rsh val 8)))
- % This writes 16 identical bytes as a way of putting a mark in a binary
- % output stream...
- (de binarymarker (stream n)
- %- (setq n (lor (lsh n 8) n))
- %- (setq n (lor (lsh n 16) n))
- %- (setq n (lor (lsh n 32) n))
- %- (binarywrite stream n)
- %- (binarywrite stream n)
- nil)
- (de binarywritebyte (stream val)
- (prog (of)
- (setq of (wrs stream))
- (prinbyte (land val 255))
- (wrs of)
- (return val)))
- % I will simulate byte vectors using vectors of 64-bit integers, and here
- % I will pack the bytes little-endian. Note that the implementation here
- % requires that the Lisp used for bootstrapping can work with full 64-bit
- % integers.
- % I will arrange that 16, 32 and 64-bit values can be read and written
- % from arbitrarily-aligned addresses. This is done by expanding the
- % access code to work byte by byte.
- (de byte (v n)
- (prog (o s)
- (setq n (plus2 v n))
- (setq o (rsh n 3))
- (setq s (times2 (land n 7) 8))
- (return (land 255 (rsh (getv memory o) s)))))
- (de putbyte (v n val)
- (prog (o s w)
- (setq n (plus2 v n))
- (setq o (rsh n 3))
- (setq s (times (land n 7) 8))
- (setq w (getv memory o))
- (setq m (difference 16#ffffffffffffffff (lsh 16#ff s)))
- (setq w (land w m))
- (setq w (lor w (lsh val s)))
- (putv memory o w)
- (return val)))
- % Now similar for halfwords (16 bits)
- (de halfword (v n)
- (lor (byte v n)
- (lsh (byte v (plus n 1)) 8)))
- (de puthalfword (v n val)
- (putbyte v n (land val 16#ff))
- (putbyte v (plus n 1) (land (rsh val 8) 16#ff))
- val)
- % ... and 32-bit words
- (de word32 (v n)
- (lor (halfword v n)
- (lsh (halfword v (plus n 2)) 16)))
- (de putword32 (v n val)
- (puthalfword v n (land val 16#ffff))
- (puthalfword v (plus n 2) (land (rsh val 16) 16#ffff))
- val)
- % This one tricked me for some while - a "halfword" here is a 32-bit value!
- (de put_a_halfword (addr val)
- (putword32 addr 0 val))
- (de word (v n)
- (lor (word32 v n)
- (lsh (word32 v (plus n 4)) 32)))
- (de putword (v n val)
- % PSL seems to be willing to pass NIL or a symbol whose name is a single
- % character here. I will patch that up in a gruesome manner!
- (if (and (idp val) (leq (id2int val) 128))
- (setq val (plus (id2int val) (lsh 254 56))))
- (putword32 v n (land val 16#ffffffff))
- (putword32 v (plus n 4) (land (rsh val 32) 16#ffffffff))
- val)
- (de wgetv (v n)
- (getv memory (plus (rsh v 3) n)))
- (de wputv (v n val)
- (putv memory (plus (rsh v 3) n) val))
- (de known-free-space ()
- (mkint (wquotient (wdifference heapupperbound heaplast)
- addressingunitsperitem)))
- (de free-bps ()
- (wquotient (wdifference lastbps nextbps)
- addressingunitsperitem)
- )
- (de gtheap (number-of-items)
- % Allocates heap space. As soon as all uses of (GTHEAP NIL) are
- % removed from code, this function can be removed, and REAL-GTHEAP
- % can become GTHEAP.
- (if (null number-of-items)
- (known-free-space)
- (real-gtheap number-of-items)
- )
- )
- (de real-gtheap (number-of-items)
- % This function handles the normal case where there is no trap handling
- % to be done. It is written so that no stack frame is allocated, which
- % vastly improves performance (at least on the 68000).
- (let ((result heaplast))
- (setf heaplast (wplus2 heaplast (wtimes2 number-of-items
- addressingunitsperitem)))
- (if (wlessp heaplast heaptrapbound)
- result
- (error "out of heap"))))
- (de delheap (lowpointer highpointer)
- (when (weq highpointer heaplast)
- (setq heaplast lowpointer)))
- %(de gtstr (upper-bound)
- % % Allocate a string of UPPER-BOUND+1 characters.
- % (let* ((n-words (strpack upper-bound))
- % (str (gtheap (+ 1 n-words))))
- % (setf (getmem str) (mkitem hbytes-tag upper-bound))
- % (setf (wgetv str n-words) 0) % clear last word, including last byte
- % str
- % ))
- (de gtstr (upper-bound)
- % Allocate a string of UPPER-BOUND+1 characters.
- (let* ((n-words (strpack upper-bound))
- (str (gtheap (+ 1 n-words))))
- % Note that wputv uses a word index not a byte one.
- (wputv str 0 (mkitem hbytes-tag upper-bound))
- (wputv str n-words 0) % clear last word, including last byte
- str
- ))
- % GTCONSTSTR is defined in the kernel
- %(de gthalfwords (upper-bound)
- % % Allocate space for a halfwords vector of UPPER-BOUND+1 elements.
- % (let* ((n-words (halfwordpack upper-bound))
- % (ptr (gtheap (+ n-words 1))))
- % (setf (getmem ptr) (mkitem hhalfwords-tag upper-bound))
- % ptr
- % ))
- (de gthalfwords (upper-bound)
- % Allocate space for a halfwords vector of UPPER-BOUND+1 elements.
- (let* ((n-words (halfwordpack upper-bound))
- (ptr (gtheap (+ n-words 1))))
- (wputv ptr 0 (mkitem hhalfwords-tag upper-bound))
- ptr
- ))
- %(de gtvect (upper-bound)
- % % Allocate space for a vector of UPPER-BOUND+1 elements.
- % (let ((ptr (gtheap (+ (vectpack upper-bound) 1))))
- % (setf (getmem ptr) (mkitem hvect-tag upper-bound))
- % ptr
- % ))
- (de gtvect (upper-bound)
- % Allocate space for a vector of UPPER-BOUND+1 elements.
- (let ((ptr (gtheap (+ (vectpack upper-bound) 1))))
- (wputv ptr 0 (mkitem hvect-tag upper-bound))
- ptr
- ))
- %(de gtevect (upper-bound)
- % % Allocate space for an evector of UPPER-BOUND+1 elements.
- % (let ((ptr (gtheap (+ (evectpack upper-bound) 1))))
- % (setf (getmem ptr) (mkitem hvect-tag upper-bound))
- % ptr
- % ))
- (de gtevect (upper-bound)
- % Allocate space for an evector of UPPER-BOUND+1 elements.
- (let ((ptr (gtheap (+ (evectpack upper-bound) 1))))
- (wputv ptr 0 (mkitem hvect-tag upper-bound))
- ptr
- ))
- %(de gtcontext ()
- % % allocate space for an environment descriptor (7 entries)
- % (let ((ptr (gtheap (+ (contextpack) 1))))
- % (setf (getmem ptr) (mkitem hvect-tag (contextpack)))
- % ptr))
- (de gtcontext ()
- % allocate space for an environment descriptor (7 entries)
- (let ((ptr (gtheap (+ (contextpack) 1))))
- (wputv ptr 0 (mkitem hvect-tag (contextpack)))
- ptr))
- %(de gtbvect (upper-bound)
- % % allocate space for a bvector - four words per entry
- % (let ((ptr (gtheap (+ (bvectpack upper-bound) 1))))
- % (setf (getmem ptr) (mkitem hvect-tag (bvectpack upper-bound)))
- % ptr))
- (de gtbvect (upper-bound)
- % allocate space for a bvector - four words per entry
- (let ((ptr (gtheap (+ (bvectpack upper-bound) 1))))
- (wputv ptr 0 (mkitem hvect-tag (bvectpack upper-bound)))
- ptr))
- % GTWRDS is defined in the kernel
- %(de gtfixn ()
- % % Allocate space for a fixnum.
- % (let ((ptr (gtheap (+ (fixpack) 1))))
- % (setf (getmem ptr) (mkitem hwords-tag (- (fixpack) 1)))
- % ptr
- % ))
- (de gtfixn ()
- % Allocate space for a fixnum.
- (let ((ptr (gtheap (+ (fixpack) 1))))
- (wputv ptr 0 (mkitem hwords-tag (- (fixpack) 1)))
- ptr
- ))
- (de gtfltn ()
- % Allocate space for a floating point number on a double-word boundary.
- (let ((x (gtheap 0))
- ptr)
- (if (neq (remainder x 8) 4)
- (gtheap 1))
- (setf ptr (gtheap (+ (floatpack) 1)))
- (setf (getmem ptr) (mkitem hwords-tag (- (floatpack) 1)))
- ptr
- ))
- % GTID is defined in the kernel.
- % GTBPS is defined in the kernel.
- %% Attempt to allocate more bps space at the end of the image by calling
- %% external-allocatemorebps. Warn user and set fluid so we can head off
- %% an unexec.
- %%
- (de try-other-bps-spaces (number-of-items)
- (let ((morebps (external-allocatemorebps)))
- (when (wgreaterp morebps 0)
- (printf "Warning, allocating additional bps space of %w items.%n"
- (quotient morebps 4))
- (printf " Cannot savesystem after allocating additional bps space.%n")
- (setq using-other-bps-spaces* t))))
- % Return space to BPS, but make sure that nextbps will not intrude down into
- % the heap, as might be the case after calling try-other-bps-spaces.
- (de delbps (bottom top)
- (when (and (weq nextbps top)
- (wgreaterp bottom bpslowerbound))
- (setq nextbps bottom)))
- (de gtwarray (n)
- %. Allocate N words for WVar/WArray/WString
- (if (null n)
- (wquotient (wdifference lastbps nextbps)
- addressingunitsperitem)
- (let ((b (wdifference lastbps (wtimes2 n addressingunitsperitem))))
- (if (wgreaterp nextbps b)
- (stderror '"Ran out of WArray space")
- (setq lastbps b))
- )))
- (de delwarray (bottom top)
- %. Return space for WArray
- (when (weq lastbps bottom)
- (setq lastbps top)))
- (de allocatefaslspaces ()
- (prog (b)
- (setq b (gtwarray nil))
- % how much is left?
- (setq b (idifference b (iquotient b 3)))
- (setq faslblockend* (gtwarray 0))
- % pointer to top of space
- (setq bittablebase* (gtwarray b))
- % take 2/3 of whatever's left
- (setq currentoffset* 0)
- (setq bittableoffset* 0)
- % The "loc" here seems to be much like the C use of "&" to grab an
- % address. Well (loc (wgetv a n)) might be rather like (plus a n) but
- % in the end I will need to worry about byte vs word addressing.
- % (setq codebase*
- % (loc (wgetv bittablebase* % split the space between
- % (iquotient b % bit table and code
- % (iquotient bittable-entries-per-word
- % addressingunitsperitem)))))
- % Here is a first-try re-work.
- (setq codebase*
- (plus bittablebase* % split the space between
- (iquotient b % bit table and code
- (iquotient bittable-entries-per-word
- addressingunitsperitem))))
- % Ensure that codebase* is 8-byte aligned.
- (setq codebase* (times 8 (quotient codebase* 8)))
- (setq maxfasloffset* (idifference faslblockend* codebase*))
- (setq orderedidlist* (cons nil nil))
- (setq nextidnumber* first-local-id-number)))
- % This mess yields a value in the range 0 to 127 for symbols that are
- % 1 character long if that character has ASCII code in the range 0 to 127.
- % I also force nil to yield 128. For other symbols I return 256 and hope that
- % the only call to this is from findidnumber!
- (setq **nil-id-value** 128)
- (de idinf (u)
- (cond ((null u) **nil-is-value**)
- ((cdr (explode2 u)) 256)
- (t (char-code u))))
- % been inserted early, and a simple redefinition of idinf was thus
- % ineffective.
- (de findidnumber (u)
- (prog (i)
- (return (cond ((ileq (setq i (idinf u)) 128) i)
- ((setq i (get u fasl-idnumber-property*)) i)
- (t (put u fasl-idnumber-property* (setq i nextidnumber*))
- (setq orderedidlist* (tconc orderedidlist* u))
- (setq nextidnumber* (iadd1 nextidnumber*)) i)))))
- % OK, I am reconstructing my understanding by inspecting the code here..
- % this makes relocation information as 2 bits of tag within a 16, 32 or
- % 64 bit item, with the relocinf in the rest. Well in a 64-bit item
- % the tag has space for 10 bits. I think that is probably because it is in
- % the top 8 bits of where a fixnum could go, leaving the high 8 bits for the
- % tag that PSL uses for identifying sorts of data.
- %
- %(de makerelocword (reloctag relocinf)
- % (iplus2 (ilsh reloctag 30) (ilsh (ilsh relocinf 2) -2)))
- (de makerelocword (reloctag relocinf)
- (plus (lsh reloctag 30) (land relocinf 16#3fffffff)))
- % My belief is that the "54" here is so that there can be 2 bits of tag
- % just below where there would be 8 bits of PSL tag in a PSL finum. Now
- % on a 32-bit system one might still imagine 8 bits of PSL tag and 2 bits
- % of relocation-type tag leaving 22 bits for the real information in a
- % relocation word. However on a 64-bit system with the PSL tag in bits
- % 56-63 and the relocation tag in bits 54 and 55 that leaves 54 rather then
- % 22 bits for useful purposes. So my suspicion is that somebody was not
- % thinking things fully through when they adapted this bit of code...
- %(de makerelocinf (reloctag relocinf)
- % (iplus2 (ilsh reloctag 54) (field relocinf 42 22)))
- (de makerelocinf (reloctag relocinf)
- (plus2 (lsh reloctag 54) (land relocinf 16#003fffffffffffff)))
- % For a word the stored inf just loses the top 2 bits of the inf to
- % leave 30 bits.
- % For the "inf" case it keeps the low 22 (or matbe 54!) bits of 64
- % For the halfword case I suspect it is keeping the bottom 14 bits of 32. On
- % a 64-bit system this feels like the low 14 bits up the upper 32 bits of the
- % word ???????? So I will comment this out and expect that on a 64-it
- % target it is never used - if it is I will need to think harder.
- % (de makerelochalfword (reloctag relocinf)
- % (iplus2 (ilsh reloctag 14) (field relocinf 18 14)))
- % I think that the use if "field" here is not at all a help as regards
- % clarity! Simpler use of shift and mask operations will leave things
- % easier to understand!
- % (de getbittable (baseaddress bitoffset)
- % (field (ilsh (byte baseaddress (ilsh bitoffset -2))
- % (idifference (itimes2 (field bitoffset 62 2) 2) 6))
- % 62 2))
- %
- % (de putbittable (baseaddress bitoffset value2)
- % (prog (m b c)
- % (setq b
- % (iland (byte baseaddress (setq m (ilsh bitoffset -2)))
- % (ilsh (idifference -1 (itimes2 3 256))
- % (idifference -2
- % (setq c (itimes2 (field bitoffset 62 2) 2))))))
- % (putbyte baseaddress m (if (eq value2 0)
- % b
- % (ilor b (ilsh value2 (idifference 6 c)))))))
- % getbittable(base, offset) =
- % w = byte(base, offset/4); % 4 bitpairs per byte
- % n = offset & 3;
- % return (w >> (2*n)) & 3
- % I will find bits of this code look way neater if I have a right
- % shift operator as well as a left shift one.
- (de rsh (w n) (lsh w (iminus n)))
- (de irsh (w n) (ilsh w (iminus n)))
- % I am writing these out as sequences of operations and avoiding
- % use of the PSL "field" selector because I believe that what I have here
- % is much easier for me to read and understand.
- (de getbittable (baseaddress bitoffset)
- (prog (o b s)
- (setq o (irsh bitoffset 2)) % 4 nybbles in each byte
- (setq b (byte baseaddress o)) % the byte with data in
- (setq s (itimes 2 (iland bitoffset 3))) % bit position
- (setq s (idifference 6 s)) % make big-endian
- (return (iland (irsh b s) 3))))
- (de putbittable (baseaddress bitoffset value2)
- (prog (o b m s)
- (setq o (irsh bitoffset 2)) % address of relevant byte
- (setq b (byte baseaddress o)) % byte to work within
- (setq s (itimes 2 (iland bitoffset 3))) % position within byte
- (setq s (idifference 6 s)) % make big-endian
- (setq m (idifference 16#ff (ilsh 3 s))) % mask
- (setq b (iland b m)) % Clear existing
- (setq b (ilor b (ilsh value2 s)))
- (putbyte baseaddress o b)))
- % Maybe somebody needed to work out what name they were using...
- (de bittable (a b) (getbittable a b))
- (de mapobl (ff)
- (mapc (oblist) ff))
- (de binarywriteblock (stream vec len)
- (prog (o b i lenb)
- (binarymarker stream 16#bb)
- (setq o (wrs stream))
- (setq i 0)
- (setq lenb (times len 8)) % length is given in WORDS
- top(cond
- ((not (lessp i lenb)) (go done)))
- (prinbyte (byte vec i))
- (setq i (add1 i))
- (go top)
- done
- (wrs o)
- (binarymarker stream 16#ee)
- (return len)))
- (de mkstring (bound fill)
- (prog (s)
- (setq s (gtstr bound))
- (dotimes (i (add1 bound))
- (putbyte s i fill))
- (return (mkstr s))))
- % I think that PSL made a mistake when it defined FIELD to count bits
- % from the most significant, because that puts implicit information about
- % whether we are thinking of a 32 or 64 bit system within it.
- (de field (x start length)
- (prog ()
- (setq x (rsh x (difference 64 (plus start length))))
- (return (land x (sub1 (lsh 1 length))))))
- (de stderror (msg)
- (error 99 msg))
- (de exitlisp () (stop 0))
- % copyd is invoked (bothtimes ..) within the for-macro.sl source file,
- % but easy-non-sl.sl uses some macros defined in for-macro. To break the
- % circularity I define copyd here.
- (de copyd (new old)
- (prog (olddef)
- (setq olddef (getd old))
- (if (pairp olddef)
- (putd new (car olddef) (cdr olddef))
- (stderror (bldmsg "%r has no definition in CopyD" old)))
- (return new)))
- (dm defun (u) (cons 'de (cdr u)))
- (de codep (u) nil)
- (de ncons (u) (cons u nil))
- (de posintp (n) (and (fixp n) (geq n 0)))
- (dm errorprintf (u)
- (list 'errorprintf1 (cadr u) (cons 'list (cddr u))))
- (de errorprintf1 (fmt args)
- (terpri)
- (printf_internal fmt args)
- nil)
- (de remob (u)
- (terpri)
- (princ "+++ REMOB not performed on ")
- (print u)
- u)
- % This definition of totalcopy may be insufficient? The issue of copying
- % strings and vectors presumably arises.
- (de totalcopy (x)
- (copy x))
- % This definition is from nonkernel/loop-macros.sl, but that file contains
- % a definition of FOR that clashes with the version that I seem to need (which
- % is in util/for-macro.sl).
- (dm foreach (u)
- %. Macro for MAP functions
- %
- % From RLISP
- %
- % Possible forms are:
- % (foreach x in u do (foo x)) --> (mapc u (function (lambda (x) (foo x))))
- % (foreach x in u collect (foo x)) --> (mapcar u ...)
- % (foreach x in u conc (foo x)) --> (mapcan u ...)
- % (foreach x in u join (foo x)) --> (mapcan u ...)
- % (foreach x on u do (foo x)) --> (map u ...)
- % (foreach x on u collect (foo u)) --> (maplist u ...)
- % (foreach x on u conc (foo x)) --> (mapcon u ...)
- % (foreach x on u join (foo x)) --> (mapcon u ...)
- %
- (prog (action body fn lst mod var)
- (setq var (cadr u))
- (setq u (cddr u))
- (setq mod (car u))
- (setq u (cdr u))
- (setq lst (car u))
- (setq u (cdr u))
- (setq action (car u))
- (setq body (cdr u))
- (setq fn
- (cond ((eq action 'do) (if (eq mod 'in)
- 'mapc
- 'map))
- ((or (eq action 'conc) (eq action 'join)) (if (eq mod
- 'in)
- 'mapcan
- 'mapcon))
- ((eq action 'collect) (if (eq mod 'in)
- 'mapcar
- 'maplist))
- (t (stderror
- (bldmsg "%r is an illegal action in ForEach"
- action)))))
- (return (list fn lst
- (list 'function
- (cons 'lambda (cons (list var) body)))))))
- (dm repeat (u)
- %
- % From RLISP
- % Form is (repeat exp1 ... expN bool)
- % Repeat until bool is true, similar to Pascal, etc.
- %
- (cons 'prog
- (cons 'nil
- (cons '$loop$
- (foreach x on (cdr u) collect (if (null (cdr x))
- (list 'cond (list (list 'not (car x)) '(go $loop$)))
- (car x)))))))
- (de first (u) (car u))
- (de second (u) (cadr u))
- (de third (u) (caddr u))
- (de fourth (u) (cadddr u))
- (de nth (u n)
- (cond
- ((equal n 1) (car u))
- (t (nth (cdr u) (sub1 n)))))
- % I will also want IFOR, but the other things defined in util/inum.sl would
- % potentially clobber VSL versions of iplus etc.. so I lift the definition
- % out to here.
- (dm ifor (u)
- % U is of the form: (IFOR (FROM var start end step) (DO body))
- (let ((step (nth (second u) 5)))
- (if (fixp step)
- (constant-increment-ifor u)
- (variable-increment-ifor u)
- )))
- (de variable-increment-ifor (u)
- (let* ((var (second (second u)))
- (start (third (second u)))
- (finish (fourth (second u)))
- (step (nth (second u) 5))
- (action (first (third u)))
- (body (cons 'progn (cdr (third u))))
- (result (list (list 'setq var start)))
- (x (list 'IDIFFERENCE finish var))
- (label1 (gensym))
- (label2 (gensym)))
- (unless (onep step)
- (setf x (list 'ITIMES2 step x))
- )
- (unless (eq action 'DO)
- (stderror "Only do expected in SysLisp FOR")
- )
- `(PROG (,var)
- (SETQ ,var ,start)
- ,label1
- (COND ((ILESSP ,x 0) (GO ,label2)))
- ,body
- (SETQ ,var (IPLUS2 ,var ,step))
- (GO ,label1)
- ,label2
- )))
- (de constant-increment-ifor (u)
- (let* ((var (second (second u)))
- (start (third (second u)))
- (finish (fourth (second u)))
- (step (nth (second u) 5))
- (action (first (third u)))
- (body (cons 'progn (cdr (third u))))
- (result (list (list 'setq var start)))
- (comparison(if (minusp step) 'ILESSP 'IGREATERP))
- (label1 (gensym)))
- (unless (eq action 'DO)
- (stderror "Only do expected in SysLisp FOR")
- )
- `(PROG (,var)
- (SETQ ,var ,start)
- ,label1
- (COND ((,comparison ,var ,finish) (RETURN 0)))
- ,body
- (SETQ ,var (IPLUS2 ,var ,step))
- (GO ,label1)
- )))
- (de onoff* (u val)
- (foreach x in u do
- (cond ((idp x) (set (intern (list2string (cons '!* (explode2 x)))) val)))))
- (dm on (u)
- (list 'onoff* (mkquote (cdr u)) t))
- (dm off (u)
- (list 'onoff* (mkquote (cdr u)) nil))
- (flag '(on off) 'ignore)
- (de int2id-internal (u)
- (cond ((equal u **nil-id-value**) nil)
- ((and (greaterp u -1) (lessp u 256)) (code-char u))
- (t 'unknown)))
- (dm load (x)
- (list 'evload (mkquote (cdr x))))
- (de evload (x)
- (foreach u in x do (load1 u)))
- (setq modules-loaded* nil)
- (de load1 (u)
- (cond ((memq u modules-loaded*) nil)
- ((memq u '(fasl-decls hash-decls))
- (dskin (string-concat "$pxk/" (string-concat (id2string u) ".sl"))))
- ((memq u '(fast-vector))
- (dskin (string-concat "$pu/" (string-concat (id2string u) ".sl"))))
- )
- (setq modules-loaded* (cons u modules-loaded*)))
- (de unboundp (u) (not (boundp u)))
- (de fboundp (u) (not (null (getd u))))
- (de funboundp (u) (null (getd u)))
- (de dskin (u) (rdf u))
- (flag '(dskin) 'ignore)
- (de pp (x) (prettyprint x))
- (de string-concat (a b)
- (setq a (explode a))
- (setq b (explode b))
- (compress (append
- (reverse (cdr (reverse a)))
- (cdr b))))
- %%%% This doesn't work, as gtbps must return the address of the vector
- %(de gtbps (n) (mkvect n))
- (de gtbps (n) 47114711)
- (de string-equal (x y) (equal x y))
- (de channelprin2 (ch x)
- (let!* ((s (wrs ch)))
- (prog1
- (prin2 x)
- (wrs s))))
- (de channelterpri (ch)
- (let!* ((s (wrs ch)))
- (prog1
- (terpri)
- (wrs s))))
- (setq stringgensymcounter* 0)
- (de stringgensym ()
- (let ((x (explode2 (setq stringgensymcounter* (plus2 stringgensymcounter* 1)))))
- (while (lessp (length x) 4)
- (setq x (cons '!0 x)))
- (compress (cons '!" (append (cons 'l x) '(!"))))))
- (dm errset (u)
- (list 'errorset (list 'quote (cadr u))
- (if (null (cddr u)) t (caddr u))
- nil))
- (de id2int (x) (print (list "ID2INT called on" x)) 4711)
- (de id2int (x)
- (cond ((null x) **nil-id-value**)
- ((equal (length (explode2 x)) 1) (char-code (car (explode2 x))))
- (t 4711)))
- % converts a binary integer in a machine word into a lisp integer
- (de int2sys (x) x)
- (de sys2fixn (x) x)
- (de binaryopenwrite (name) (open name 'output))
- (de binaryclose (ff) (close ff))
- % Functions that operate on machine words
- % use integer functions for now
- (de wshift (x y) (lshift x y))
- (de wplus2 (x y) (plus2 x y))
- (de wtimes2 (x y) (times2 x y))
- (de wquotient (x y) (quotient x y))
- (de wdifference (x y) (difference x y))
- (de wgreaterp (x y) (greaterp x y))
- (de wlessp (x y) (lessp x y))
- (de wgeq (x y) (geq x y))
- (de wleq (x y) (leq x y))
- (de weq (a b) (equal a b))
- (de wand (x y) (logand x y))
- (de wor (x y) (logor x y))
- (dm land (u) (cons 'logand (cdr u)))
- (dm lor (u) (cons 'logor (cdr u)))
- (dm iland (u) (cons 'logand (cdr u)))
- (dm ilor (u) (cons 'logor (cdr u)))
- (dm string (u) (list 'list2string (cons 'list (cdr u))))
- (de evectorp (x) nil)
- (de bigp (u) (bignump u))
-
- (de isizev (u) (size u))
- (de igetv (a b) (indx a b))
- (de channelposn (f)
- (prog (r)
- (setq f (wrs f))
- (setq r (posn))
- (wrs f)
- (return r)))
- (de channelwritechar (f ch)
- (setq f (wrs f))
- (prin2 (if (numberp ch) (code-char ch) ch))
- (wrs f)
- ch)
- % This mess yields a value in the range 0 to 127 for symbols that are
- % 1 character long if that character has ASCII code in the range 0 to 127.
- % I also force nil to yield 128. For other symbols I return 256 and hope that
- % the only call to this is from findidnumber!
- (de idinf (u)
- (cond ((null u) 128)
- ((cdr (explode2 u)) 256)
- (t (char-code u))))
- % Here we have sometihng of a joke! in PSL the compiler generates calls
- % to functions that are part of the PSL kernel in an abbreviated way
- % because it know that they are present in compiled not interpreted form.
- % I have not yet understood what the consequences would be if a user then
- % redefined one of these with an interpreted version! Anyway to have any
- % prospect of binary compatibility between cross-build code and native
- % build code I have to know what PSL had happened to implement this way!
- (flag '(
- !%clear!-catch!-stack !%displaced!-macro !%get !%reclaim !%throw
- !%uncatch !*!*float!*!* !*catch !*define!-constant !*doubletofloat
- !*fassign !*fdifference !*fgreaterp !*flessp !*floattodouble
- !*fp!-check!-for!-exceptions !*fplus2 !*fquotient !*freset !*fsqrt
- !*ftimes2 !*load!-for!-compiler !*throw !*wfix !*wfloat !_slowcons
- !_slowgtfltn abs aconc add1 add1!-hardcase addload addressapply0
- adjoin adjoinq adjustcase alghandler allocate!-string allocate!-words
- allocatemorebps and ans anyuser!-homedir!-string append apply ass
- assoc assoc!* atom atsoc backtrace beforegcsystemhook bigp binaryclose
- binaryopenappend binaryopenread binaryopenupdate binaryopenwrite
- binarypositionfile binaryread binaryreadblock binarywrite binarywriteblock
- bindeval bldmsg bothtimes break breakcontinue breakedit breakerrmsg
- breakeval breakquit breakretry bstackoverflow bstackunderflow bstructp
- build!-trap!-message bvectorp caaaar caaadr caaar caadar caaddr caadr
- caar cadaar cadadr cadar caddar cadddr caddr cadr captureenvironment car
- case catch catch!-all catchsetup catchsetupaux cd cdaaar cdaadr cdaar
- cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr
- cdr cfserror channeleject channelerror channelfindposition channelflush
- channellinelength channellposn channelnotopen channelposn channelprin1
- channelprin2 channelprin2t channelprinc channelprint channelprintbstruct
- channelprintbvector channelprintcontext channelprintevector channelprintf
- channelprintfunarg channelprintid channelprintpair channelprintsgd
- channelprintstring channelprintunbound channelprintvector channelread
- channelreadch channelreadchar channelreadeof channelreadline
- channelreadlistordottedpair channelreadquotedexpression
- channelreadrightparen channelreadtoken channelreadtokenwithhooks
- channelreadvector channelspaces channelspaces2 channeltab channelterpri
- channeltyi channeltyo channelunreadchar channelwritebitstraux
- channelwritebitstring channelwriteblankoreol channelwritebstruct
- channelwritebvector channelwritebytes channelwritechar
- channelwritecodepointer channelwritecontext channelwriteevector
- channelwritefixnum channelwritefloat channelwritefunarg
- channelwritehalfwords channelwriteid channelwriteinteger
- channelwritepair channelwritesgd channelwritestring channelwritesysfloat
- channelwritesysinteger channelwriteunbound channelwriteunknownitem
- channelwritevector channelwritewords charsininputbuffer checklinefit
- clear!-warray clear!-wstring clearbindings clearcompresschannel clearerr
- cleario clearonechannel close code!-number!-of!-arguments code!-putd
- codeaddressp codeapply codeevalapply codep coerce1 coerce2 commentoutcode
- compiledcallinginterpretedaux compiler!-constant compiletime compress
- compresserror compressreadchar compute!-prompt!-string compute!-relocation
- concat cond cons console!-newline console!-print!-number
- console!-print!-string const constantp conterror contextp
- continuableerror contopenerror copy copybytes copyevector copyevectortofrom
- copyfltn copyfromallbases copyfrombase copyfromrange copyfromstack
- copyfromstaticheap copyhalfwords copyhalfwordstofrom copyitem
- copyitem1 copypairitem copystring copystringtofrom copyvector
- copyvectortofrom copywarray copywrds copywrdstofrom ctime
- current!-stack!-pointer date date!-and!-time date!-int!-to!-string
- datebuffer!-to!-string de defconst define!-constant deflist del
- delasc delascip delatq delatqip delbps delete delete!-file deletip
- delheap delq delqip delwarray depositextrareglocation
- depositfunctioncelllocation depositvaluecelllocation df difference
- difference!-hardcase digit digittonumber divide dm dn do!-relocation
- do!-relocation!-new ds dskin dskin!-file dskin!-step dskin!-stream
- dumplisp echooff echoon egetv eject eputv eq eqcar eqn eqstr equal error
- errorprintf errorset errortrap errprin errset eupbv eval evalinitforms
- evand evcond evdefconst evectorequal evectorp evlis evload evor
- evprogn evreload exit exit!-with!-status exitlisp expand expand_file_name
- expandsetf explode explode2 explode2n explodecn exploden explodewritechar
- exprp expt!-rec external!-allocatemorebps external_alarm
- external_anyuser_homedir_string external_charsininputbuffer
- external_exit external_fullpath external_getenv external_link
- external_mkdir external_pwd external_rmdir external_setenv external_stat
- external_strlen external_system external_timc external_time
- external_ualarm external_unlink external_user_homedir_string faslin
- faslin!-bad!-file faslin!-intern fastapply fastlambdaapply fatalerror
- fclose fcntl fcodep fdummy fexprp fflush fgetc fgets filep filestatus
- findcatchmarkandthrow findfreechannel findposition first firstkernel
- fix fix!-hardcase fixp flag flagp flambdalinkp flatsize flatsize2
- flatsizewritechar float floatdifference floatgreaterp floatlessp floatp
- floatplus2 floatquotient floattimes2 floatzerop flock fluid fluid1
- fluidp flushbuffer flushstdoutputbuffer fopen force!-heap!-enlargement
- foreach fork fourth fpehandler fputc fread free!-bps fseek funargp
- funboundp function fwrite gc!-trap gc!-trap!-level gcstats gensym
- geq get get!-exec!-path get!-fullpath get!-heap!-trap get!-heap!-try!-reclaim
- get!-image!-path get!-registry!-value get_execfilepath get_file_status
- get_imagefilepath get_registry_value getd getenv getfcodepointer getfntype
- gethostid getpid getprintprecision getsocket getstartupname getunixargs
- getv gget global global1 globalinstall globallookup globalp globalremove
- go greaterp greaterp!-hardcase gtbps gtbps!-nil!-error gtbvect gtconststr
- gtcontext gtevect gtfixn gtfltn gthalfwords gtheap gtid gtstr gtvect
- gtwarray gtwrds hash!-function hash!-into!-table helpbreak hist
- history!-append history!-fetch history!-reset history!-set!-input
- history!-set!-output history!-state histprint id!-intern id2int
- id2string idapply idp ieee_flags ieee_handler illegalstandardchannelclose
- illhandler implode importforeignstring imports independentclosechannel
- independentreadchar independentwritechar indexerror indx init!-file!-string
- init!-fluids init!-gcarray init!-pointers initcode initialize!-new!-id
- initialize!-symbol!-table initialize!-warray initialize!-wstring
- initializeinterrupts initializeinterrupts!-1 inp input!-case
- instantiateinform int2code int2id intern internal_aftergcsystemhook
- internal_beforegcsystemhook interngensym internp interpbacktrace interrogate
- intersectionq intfloat inthandler ioerror iovhandler kernel!-fatal!-error
- killhandler known!-free!-space land land!-hardcase lapin lastcar lastkernel
- lastpair lbind1 lconc length leq lessp lessp!-hardcase linelength
- linux_close linux_open lisp2char list list2 list2set list2setq list2string
- list2vector list3 list4 list5 liter lnot lnot!-hardcase load
- load!-for!-compiler load1 loader!-main loadtime local!-to!-global!-id
- lor lor!-hardcase lposn lshift!-hardcase lxor lxor!-hardcase macrop
- make!-bytes make!-halfwords make!-manual!-evector make!-vector make!-words
- makeds makefcode makeflambdalink makefunbound makeidfreelist
- makeinputavailable makeunbound map map2 mapc mapc2 mapcan mapcar
- mapcon maplist mapobl markandcopyfromid max max2 mem member memq
- min min2 minus minus!-hardcase minusp minusp!-hardcase mkevector
- mkflagvar mkquote mkstring mkvect modeless!-dskin!-file modify
- modulep moreheap nconc ncons ne neq newid nexprp next noncharactererror
- noniderror noninteger2error nonintegererror noniochannelerror
- nonlisterror nonnumber1error nonnumber2error nonnumbererror nonpairerror
- nonpositiveintegererror nonsequenceerror nonstringerror nonvectorerror
- nonwordserror not nth null numberp oblist off old!-flag1 old!-put
- old!-remflag1 old!-remprop oldchannelprin1 oldchannelprin2 oldfloatfix
- on onep!-hardcase onoff!* open or os_cleanup_hook os_startup_hook
- output!-case package pair pairp pbind1 pclose plantcodepointer
- plantlambdalink plantunbound plus plus2 plus2!-hardcase pnth popen
- posn pp pre!-main prettyprint prin1 prin2 prin2l prin2t print printf
- printf1 printf2 printwithfreshline prog prog2 progn prop psl_main
- pslsignalhandler putc putentry putv putw pwd quit quote quotient
- quotient!-hardcase rangeerror rassoc ratom rdf rds read read!-id!-table
- readch readchar reader!-intern readinbuf readline readonlychannel
- real!-gtheap recip reclaim reclaim2 redo reload relocate!-inf relocate!-word
- remainder remainder!-hardcase remd remflag remob rempropl reset
- rest restoreenvironment return returnaddressp returnnil reverse reversip
- robustexpand rplaca rplacd rplacw safecar safecdr sassoc savesystem
- search!-string!-for!-character second seghandler semctl semget semop
- set set!-bndstk!-size set!-gc!-trap!-level set!-heap!-size set!-history!-state
- set_bndstk_size set_heap_size setenv setindx setlinebuf
- setmacroreference setprintprecision setprop setq setsub setsubseq
- sgdp shmat shmctl shmdt shmget signal sigrelse sigunwind size sleep
- spaces spaces2 standardlisp staticintfloat stderror step string string!=
- string!-intern string2list string2vector stringequal stringgensym stringp
- sub sub1 sub1!-hardcase subla sublis subseq substip suck!-in!-files
- sun3_sigset sys2fixn sys2int syscleario sysclose sysmaxbuffer sysopenread
- sysopenwrite syspowerof2p sysreadrec system systemmarkasclosedchannel
- systemopenfileforinput systemopenfileforoutput systemopenfilespecial
- syswriterec tab tconc terminalinputhandler terpri testlegalchannel
- third throw throwaux timc time times times2 times2!-hardcase
- top!-loop!-eval!-and!-print top!-loop!-read toploop tostringwritechar
- totalcopy tr trst try!-other!-bps!-spaces tyi tyo typeerror unbindn
- unboundp unchecked!-prop unchecked!-put unchecked!-setprop
- unchecked!-string!-equal unchecked!-string!-intern undefinedfunction!-aux
- unexec unfluid unfluid1 unionq unix!-profile unix!-time unixcd unixcleario
- unixclosesocket unixopen unixputc unixputn unixputs unixsocketopen
- unixstring unixstrlen unprotected!-dskin!-stream unreadchar unwind!-all
- unwind!-protect upbv usagetypeerror user!-homedir!-string uxacos
- uxasin uxassign uxatan uxatan2 uxcos uxdifference uxdoubletofloat uxexp
- uxfix uxfloat uxfloattodouble uxgreaterp uxlessp uxlog uxplus2
- uxquotient uxsin uxsqrt uxtan uxtimes2 uxwritefloat uxwritefloat8
- valuecell vaxreadchar vaxwritechar vector vector2list vector2string
- vectorp verbosebacktrace wait writechar writefloat writenumber1
- writeonlychannel writesocket writestring writesysinteger wrongcasecharp
- wrs xcons xgetw xidapply0 xidapply1 xidapply2 xidapply3 xidapply4
- xn xnq yesp zerop zerop!-hardcase)
- 'fastcallable)
- (de fastcallablep (u)
- (flagp u 'fastcallable))
- % Redefine a couple of functions that do not work out of the box
- (de printexpression (x)
- ((lambda (expressioncount*)
- (prog (hd tl fn)
- (setq x (resolvewconstexpression x))
- (cond ((or (numberp x) (stringp x)) (prin2 x))
- ((idp x) (prin2 (findlabel x)))
- ((atom x)
- (errorprintf "***** Oddity in expression %r" x)
- (prin2 x))
- (t
- (setq hd (car x)) (setq tl (cdr x))
- (cond
- ((setq fn (get hd 'binaryasmop))
- (when (greaterp expressioncount* 0)
- (prin2 asmopenparen*))
- (printexpression (car tl)) (prin2 fn)
- (printexpression (cadr tl))
- (when (greaterp expressioncount* 0)
- (prin2 asmcloseparen*)))
- ((setq fn (get hd 'unaryasmop)) (prin2 fn)
- (printexpression (car tl)))
- ((setq fn (get hd 'asmexpressionformat))
- (apply 'printf_internal
- (list fn
- (foreach y in tl collect
- (list 'printexpression
- (mkquote y))))))
- ((and (setq fn (getd hd))
- (equal (car fn) 'macro))
- (printexpression (apply (cdr fn) (list x))))
- ((setq fn (get hd 'asmexpressionfunction))
- (apply fn (list x)))
- (t
- (errorprintf "***** Unknown expression %r"
- x)
- (printf "*** Expression error %r ***" x)))))))
- (plus expressioncount* 1)))
- (de size (x)
- (cond ((stringp x) (difference (length (explode2 x)) 1))
- ((vectorp x) (upbv x))
- ((bignump x) (difference (length (cdr x)) 1))
- (t nil)))
- (de indx (s n)
- (cond ((stringp s) (char-code (nth (explode2 s) (plus2 n 1))))
- (t (getv s n))))
- (de intp (x) (and (fixp x) (not (bignump x))))
- (de sunsymbolp (x)
- (setq x (explode2 x))
- (prog nil
- lbl
- (cond ((null x) (return t))
- ((not (or (liter (car x)) (eq (car x) '!_))) (return nil)))
- (setq x (cdr x))
- (go lbl)))
- (de asm-char-downcase (c)
- (if (and (leq 65 c) (leq c 90))
- (plus c 32)
- x)))
- (de auxaux (i)
- (list2string (list (code-char i))))
- (dm codeprintf (x) (cons 'fprintf (cons 'codeout* (cdr x))))
- (dm dataprintf (x) (cons 'fprintf (cons 'dataout* (cdr x))))
- %(def-pass-1-macro Char (u)
- %. PSL Character constant macro
- % (DoChar U))
- % Table driven char macro expander
- (de DoChar (u)
- (cond
- ((idp u) (or
- (get u 'charvalue)
- ((lambda (n) (cond ((lessp n 128) n))) (id2int u))
- (CharError u)))
- ((pairp u) % Here's the real change -- let users add "functions"
- ((lambda (fn)
- (cond
- (fn (apply fn (list (dochar (cadr u)))))
- (t (CharError u))))
- (cond ((idp (car u)) (get (car u) 'char-prefix-function)))))
- ((and (fixp u) (geq u 0) (leq u 9)) (plus u 48)) % 48 = (char 0)
- (t (CharError u))))
- (de CharError (u)
- (ErrorPrintF "*** Unknown character constant: %r" u)
- 0)
- % This is needed for ASM generation, see $pxk/main-start.sl
- (put 'symnam 'symbol 'symnam)
- (put 'symfnc 'symbol 'symfnc)
- (put 'symget 'symbol 'symget)
- (put 'symval 'symbol 'symval)
- (put 'symprp 'symbol 'symprp)
- (setq toploopeval* 'eval)
-
- %(de OperandPrintIndirect (x) % (Indirect x)
- % (progn (setq x (cadr x))
- % (if (regp x) (progn
- % (prin2 "(")
- % (PrintOperand x)
- % (Prin2 ")"))
- % (prin2 "*")
- % (PrintOperand x)
- % (prin2 " / ")
- % (prin1 x)
- % (Prin2 ""))
- %))
- %
- %
- %(de asmprintvaluecell (x)
- % (printexpression (list 'plus2 'symval
- % (list 'times (compiler-constant 'addressingunitsperitem)
- % (list 'idloc (cadr x)))))
- % (princ " / ")
- % (prin1 x))
- (flag '(evload) 'ignore)
- % $pu/if.sl defines an IF macro that uses symbols as keywords THEN, ELIF
- % and ELSE. It is coded using the NEXT macro from $pnk/loop-macros.sl, but
- % if I load that file then it gives a version of FOR that conflicts with
- % $pu/for-macro.sl. So I will provide NEXT manually here - not that I think
- % that use of it was a good idea!
- (dm next (u) % Continue Loop
- '(go $loop$))
- (dm bothtimes (x) (cons 'progn (cdr x)))
- (dm compiletime (x) (cons 'progn (cdr x)))
- (dm loadtime (x) (cons 'progn (cdr x)))
- % This seems to be called at cross-compile time with NIL as the
- % second argument. That seems a bit weird to me.
- (de mkitem (tag x)
- (cond
- ((null (integerp tag)) (print (list '++++ 'mkitem tag x)) (mkitem 0 x))
- ((null (integerp x)) (print (list '++++ 'mkitem tag x)) (mkitem tag 0))
- (t (land 16#ffffffffffffffff (lor
- (lsh tag 56)
- (land x 16#00ffffffffffffff))))))
- (de imports (u) nil)
- % (de codewritestring (x)
- % (setq x (strinf x))
- % (setq s (strlen x))
- % (binarywrite codeout* s)
- % (binarywriteblock codeout* (strbase x) (strpack s)))
- (de codewritestring (x)
- (prog (len w)
- (binarymarker codeout* 16#55)
- (setq x (explode2 x))
- (setq len (sub1 (length x)))
- (setq w (times 8 (strpack len))) % 8 bytes per word
- (binarywrite codeout* len)
- (foreach b in x do (binarywritebyte codeout* (char-code b)))
- (while (lessp (setq len (add1 len)) w)
- (binarywritebyte codeout* 0))))
- (de codefiletrailer ()
- (prog (s len)
- (binarymarker codeout* 16#22)
- (systemfaslfixup)
- (binarywrite codeout* (idifference (isub1 nextidnumber*)
- first-local-id-number))
- (binarymarker codeout* 16#33)
- % Number of local IDs
- (foreach x in (car orderedidlist*) do
- (progn (remprop x fasl-idnumber-property*)
- (codewritestring (faslid2string x))))
- (binarymarker codeout* 16#44)
- (binarywrite codeout* % S is size in words
- (setq s
- (iquotient
- (iplus2 currentoffset*
- (isub1 addressingunitsperitem))
- addressingunitsperitem)))
- (binarymarker codeout* 16#66)
- (binarywrite codeout* initoffset*)
- (binarywriteblock codeout* codebase* s)
- (if *compact-bittable
- (let((b (compact-bittable bittablebase* bittableoffset*))
- (bpw (quotient bitsperword 8)))
- (binarywrite codeout*
- (setq s (iquotient
- (iplus2 (car b)
- (isub1 bpw))
- bpw)))
- (setq b (explode2 (cdr b)))
- (setq len (length b))
- (setq s (times 8 s))
- (binarymarker codeout* 16#77)
- (foreach b1 in b do
- (binarywritebyte codeout* (char-code b1)))
- (while (lessp (setq len (add1 len)) s)
- (binarywritebyte codeout* 0))
- % (binarywriteblock codeout* (strbase(strinf (cdr b))) s)
- )
- (binarymarker codeout* 16#88)
- (progn
- (binarywrite codeout*
- (setq s
- (iquotient
- (iplus2 bittableoffset*
- (isub1 bittable-entries-per-word))
- bittable-entries-per-word)))
- (binarywriteblock codeout* bittablebase* s)
- ))
- (binarymarker codeout* 16#99)
- (deallocatefaslspaces)))
- (de compact-bittable(base max)
- (prog (i d bl b l s sb)
- (setq i (setq d 0))
- (ifor (from i 0 (isub1 max) 1)
- (do
- (progn
- (setq b (bittable base i))
- (if (or (not (eq b 0)) % nonzero entry
- (eq d 16#3f) % maximum offset
- )
- (progn
- (push (logor (lsh b 6) d) bl)
- (setq d 1)
- )
- (setq d (iadd1 d))
- )
- )))
- % OK - we have now built up a list bl of the non-zero entries. Each
- % has the entry number in the low 6 bits and then 2 bits of data at the top.
- (setq bl (cons 0 bl))
- (setq bl (reversip bl))
- % Now in the correct order.
- (setq l (length bl))
- % I want to pack it as a string. BEWARE of several issues. Firstly this
- % string contains a pretty arbitrary sequence of bytes, the last of which
- % is a zero byte and that must be included as part of the string. It may
- % not be valid UTF8 so passing it through print code could potentially cause
- % trouble.
- (setq s (list-to-string bl))
- % (setq s (mkstring (isub1 l) 0))
- % (setq sb (strbase (strinf s)))
- % (setq b (isub1 l))
- % (ifor (from i 0 b 1) (do (setf (byte sb i) (pop bl))))
- (return (cons l s))))
- (de initialize-wstring (address init n)
- (prog (i)
- (setq init (explode2 init))
- (setq n (times n 8))
- (setq i 0)
- top (cond
- ((lessp i n) (return nil))
- (init (putbyte address i (char-code (car init)))
- (setq init (cdr init)))
- (t (putbyte address i 0)))
- (setq i (add1 i))
- (go top)))
- (flag '(spaces intp flag1 remflag1 control cntrl continuableerror main
- concat binarywrite binarywritebyte byte putbyte halfword
- puthalfword put_a_halfword putword wgetv wputv known-free-space
- free-bpsgtheap real-gtheap delheap gtstrgthalfwords gtvect
- gtevect gtcontext gtbvect gtfixn gtfltn try-other-bps-spaces
- delbps gtwarray delwarray allocatefaslspaces isinf
- findidnumber makerelocword makerelocinf makerelochalfword
- lsh rsh getbittable putbittable bittable mapobl binarywriteblock
- mkstring field stderror exitlisp copyd codep ncons posintp
- errorprintf1 remobtotalcopy variable-increment-ifor
- constant-increment-ifor onoff* int2id-internal evload load1
- unboundp fboundp funboundp dskin pp string-concat gtbps
- string-equal channelprin2 channelterpri stringgensym id2int
- id2int int2sys sys2fixn binaryopenwrite binaryclose wshift
- wplus2 wtimes2 wquotient wdifference wgreaterp wlessp wgeq wleq
- weq wand wor evectorp bigp isizev igetv channelposn
- channelwritechar idinf fastcallablep defun errorprintf foreach
- repeat ifor on off imports putmem putbyte put_a_halfword int2id
- load errset land lor iland ilor string putword next bothtimes
- compiletime loadtime mkitem imports codewritestring codefiletrailer
- compact-bittable length member memq last lastcar lastpair
- initialize-wstring)
- 'lose)
- (rdf "mytrace.lsp")
- % A function ASSOC1 is defined using LAP in one of the source files
- % I need to load as part of the compiler - thus tending to require that
- % a working compiler/LAP is available at an early stage. By putting in
- % a dummy definition here I avoid that crashing things, and as I read in
- % more files I will instate a locally workable version of LAP - but note
- % that I will install one suitable for cross rather than local compilation.
- (de lap (u)
- (print "+++++ lap called before it is defined +++++")
- (print u)
- nil)
- % end of file
|