Google
 

Trailing-Edge - PDP-10 Archives - clisp - clisp/upsala/jsys.lap
There are no other files named jsys.lap in the archive.
;;; -*-Lisp-*-
; AIDA::SS:<CLISP.UPSALA>JSYS.LAP.10, 21-Jul-86 17:26:59, Ed: PEM
; Rehacked %jsys and the local subroutine (label 21). If the GC runs with
; non-lisp objects on Q (or in O%), u loose. Uses P now.
;;;
;;; JSYS interface for Common Lisp,
;;; written by Bj|rn Victor, Computing Sc. Dept, Uppsala University, Sweden. 
;;;
;;; Inspired by MacLisp LAP program by Marty@OZ (based on Midas code by
;;; PAO@EE), which is more powerful, but hairier...
;;;
;;; (%jsys <jsnum> [<ac1> [<ac2> [<ac3> [<ac4>]]]])
;;; => (<ac1> <ac2> <ac3> <ac4>) if no error,
;;; or 60xxxx if jsys error.
;;;
;;; <jsnum> is the number of the jsys you wish to execute.
;;; Symbolic values for the jsi are available in the file
;;; CLISP:JSYS-TABLE.CLISP, and should be accessed with #. as in
;;; (%jsys #.dirst <string-storage> (cons #o500000 5))
;;;
;;; The next four args (five coming real soon...) are optional and are the
;;; contents of the accumulators for the jsys.  The function attempts to
;;; decode the Common Lisp data structures into meaningful data for the jsys
;;; as follows:
;;;
;;;	NIL		Zero.
;;;	FIXNUM		Is provided 'as is' (only 30 significant bits!)
;;;	SYMBOL		Provides a pointer to an asciz string of the
;;;			printname.  No good for writing, just reading.
;;;	SIMPLE-STRING	Provides a pointer to the asciz representation of the
;;;			string.  If the string is empty, it is OK to write on
;;;			it, but it can't be 'recycled'.
;;;	CONS		The car of the cons is interpreted according to the
;;;			same rules and is used as the left half of the
;;;			accumulator.  The cdr is used as the right half.
;;;			Thus, to provide flags in the left and right halves,
;;;			do (<LHflags> . <RHflags>).  If either the car or the
;;;			cdr of the argument is another cons, the results will
;;;			be undefined. 
;;;	STREAM		If the stream is associated with a JFN, the JFN is
;;;			provided as jsys argument.
;;;	SIMPLE-BIT-VECTOR
;;;			The address of the bits is used.
;;;			This can be used for setting up an argument block.
;;;
;;; Any other data type (BIGNUMs, COMPLEX, RATIOs etc) is an error.
;;;
;;; ******** NOTES ********
;;; Please bear in mind:
;;; * We use extended addressing. Don't use (-1 . string) for string pointers,
;;;   this code is better at making them.
;;; * Watch out with using the STREAM argument, since only the JFN is used,
;;;   and a STREAM object is much, much more than that.
;;; * Don't write on Pnames or non-null strings.  Nothing useful will happen.
;;; * Remember a fixnum has only 30 significant bits.  If you need the ms 6
;;;   bits, use the CONS cons-truct.
;;;

(in-package "SI")		; In the System-Internals package
(export '(%jsys jsys))
(require "LAP2")		; Need LAP extensions
(require "OPCODES")		; Need KL10 opcodes


;;; [PEM]: Check that %j is a list before calling mapcar.
(defmacro jsys (jsys &optional &rest acs)
  "Execute a JSYS with acs.  Returns same as %jsys, but only 36 bits."
  `(let ((%j (%jsys ,jsys ,@acs)))
     (if (listp %j)
	 (mapcar #'(lambda (x) (logand x #o777777777777)) %j)
	 %j)))


;;; [PEM]: BEWARE!! Don't store anything but legal lisp objects onto Q or
;;; in O1-O6 (and preferably, don't use O6 at all) when calling routines 
;;; that may cause GC!

#_(lap #_si::%jsys expr
       (entry-points (2-few 2 3 4 5 6 2-many))
       #0_("Too many args - %JSYS!" #o340000000000 simple-string
	   "Bad argument to %JSYS - ~s" #o370400)
       (code-start)
; Get jsys args on the stack
(label 2)    (move o2 nil)
	     (jrst 1)
(label 3)    (movei w2 1)
	     (icall rest2)
	     (jrst 1)
(label 4)    (movei w2 2)
	     (icall rest3)
	     (jrst 1)
(label 5)    (movei w2 3)
	     (icall rest4)
	     (jrst 1)
(label 6)    (movei w2 4)
	     (icall rest5)
	     (jrst 1)
(label 7)    (movei w2 1)
	     (icall restx)
(label 1)    (caile n 5)	;Too many args? (4 acs+1 reqd)
              (jrst 12)
	     (push p 0)		; Save NIL
	     (push p 1)		;Save jsys acs
	     (push p 2)
	     (push p 3)
	     (push p 4)
	     (push p o1)	;Save jsys number
	     (movem o2 o1)	;Set up arglist ptr
	     (lcall 21)		;Set up args in acs
	     (pop p o1)
	     (jsys 0 0 o1)	;Execute the jsys
	     (erjmp 13)		;erjmp
	     (erjmp 13)		;one more (for erstr%)
	     (push p 4)		;Save resulting 4 on P
	     (push p 3)		;               3
	     (push p 2)		;               2
	     (push p 1)		;               1
	     (setzb 1 0)	;Clear NIL fast!
	     (pop p 2)		;Get a number from P
	     (icall ret1nt)	;Make lisp object
	     (push q o1)	;Save it on Q
	     (pop p 2)
	     (icall ret1nt)	;Again
	     (push q o1)
	     (pop p 2)
	     (icall ret1nt)	;Again
	     (push q o1)
	     (pop p 2)
	     (icall ret1nt)	;Again
	     (move o2 nil)	;NIL
	     (icall cons)	;Cons ac4 and NIL
	     (move o2 o1)	;Make result CDR
	     (pop q o1)		;of cons with ac3
	     (icall cons)
	     (move o2 o1)
	     (pop q o1)		;and ac2
	     (icall cons)
	     (move o2 o1)
	     (pop q o1)		;and ac1
	     (icall cons)
(label 11)   (pop p 4)		;Pop jsys acs
	     (pop p 3)
	     (pop p 2)
	     (pop p 1)
	     (pop p 0)
	     (popj p)		;Return (list ac1 ac2 ac3 ac4) in o1

;;; Too many args
(label 12)   (move o1 (constant 0))
	     (call error 1)
	     (popj p)
;;; JSYS error handler - returns error number as fixnum
(label 13)   (movei 1 #o400000)	;.fhslf
	     (jsys 0 #o12)	;geter
	     (tlz 2 -1)		;Clear fork handle
	     (icall ret1nt)	;Make lisp number
	     (jrst 11)		;and go pop things

;;; Local subroutine to get ac values
(label 21)   (adjsp p 6)	;Local var ptr (one slot for the return addr)
	     (movem o1 -5 p)	;Save arglist
	     (setz w2)
	     (setz w3)
	     (dmovem w2 -4 p)	;Clear ac vars
	     (dmovem w2 -2 p)
	     (xmovei w4 -5 p)	;Set up local stack
(label 22)   (move o1 -5 p)	;Get arglist
	     (move o2 1 o1)	;get cdr
	     (movem o2 -5 p)	;Save cdr
	     (move o1 0 o1)	;Get car
	     (push p w4)
	     (push p o1)
	     (push p o2)
	     (lcall 30)
	     (pop p o2)
	     (pop p o1)
	     (pop p w4)
	     (push w4 w2)	;Push on local stack
	     (jumpe o2 29)	;(null (cdr args))
	     (jrst 22)		;Iterate
(label 29)   (move w4 -1 p)	;Get ac values
	     (move w3 -2 p)
	     (move w2 -3 p)
	     (move 1 -4 p)	;****WATCH OUT!!
	     (adjsp p -6)
	     (popj p)		;Done

;;; Local workroutine.
;;; Takes lisp object in o1, tries to return machine word in w2
(label 30)   (skipn w2 o1)	;In case of NIL
	      (popj p)
; Check for fixnum
	     (hlrz w2 o1)
	     (caige w2 #o340000) ;Fixnum?
	      (jrst 31)		;Nope
	     (icall get1nt)
	     (popj p)
; Symbol
(label 31)   (tlne o1 #o360000)	;Atomp
	      (jrst 32)		;Nop
	     (move o1 2 o1)	;Get pname ptr
; Enter here with Lisp string pointer in o1
(label 39)   (skipn w2 1 o1)	;Empty? (For output?)
	      (jrst 38)		; Yes, don't care about asciz
	     (hrrz w2 0 o1)	;Get length
	     (push p o1)
	     (addi w2 1)	;+1 (make asciz)
	     (icall ret1nt)	;Make a lisp fixnum
	     (move o2 o1)
	     (move o1 (constant 2)) ; simple-string
	     (call make-sequence 2) ; Make a string
	     (move o2 0 p)	; Get old string
	     (call replace 2)	;He he
	     (movem o1 0 p)	;Smash
	     (pop p o1)
(label 38)   (xmovei w2 1 o1)	; Get absolute address
	     (tlo w2 #o610000)	; Make g1bpt
	     (popj p)
; Cons
(label 32)   (tlnn o1 #o340000)	;Check if
	      (tlnn o1 #o20000)	;this is a Cons
	        (jrst 33)	;Nope
	     (push p 0)
	     (push p o1)
	     (move o1 0 o1)	;Get car
	     (lcall 30)		;Recurse
	     (movem w2 -1 p)	;Save
	     (pop p o1)
	     (move o1 1 o1)	;Get cdr
	     (lcall 30)		;Recurse
	     (pop p w3)
	     (hrl w2 w3)
	     (popj p)
; Simple-string
(label 33)   (hrli w3 #o370400)	;XTYPE
	     (hrri w3 o1)
	     (ldb w2 w3)	;Get typecode
	     (caie w2 2)	;Simple-string-p
	      (jrst 34)		;nil
	     (jrst 39)		;handle like a printname
; Stream
(label 34)   (hrli w3 #o370400)	;XTYPE
	     (hrri w3 o1)
	     (ldb w2 w3)	;Get typecode
	     (caie w2 3)	;StreamP
	      (jrst 35)		;No
	     (hrre w2 1 o1)	;Get JFN
	     (caig w2 0)	;Valid JFN?
	      (jrst 40)		;No
	     (popj p)
; Simple-Bit-Vector
(label 35)   (hrli w3 #o360500)	;GETTYP
	     (hrri w3 o1)
	     (ldb w2 w3)	;Get typecode
	     (caie w2 #o17)	;simple-bit-vector-p
	      (jrst 36)		;No
	     (move w2 0 o1)	;Get ty%s36<length>
	     (tlz w2 #o770000)	;Clear bits
	     (idivi w2 36.)
	     (skipe 0 w3)	;Dividable by 36?
	      (jrst 40)		;No, user probably doesn't want this
	     (xmovei w2 1 o1)	;OK, return address of bits
	     (popj p)
; Other
(label 36)
; Error
(label 40)   (move o2 o1)	;Get object
	     (move o1 (constant 3)) ;And string
	     (call error 2)	;Object!
	     (popj p)
)