Trailing-Edge
-
PDP-10 Archives
-
clisp
-
clisp/upsala/jsys-handy.clisp
There are no other files named jsys-handy.clisp in the archive.
;;; Handy functions for the JSYS interface.
;;; Things to think of:
;;;* Don't write in pnames or non-null strings. They are copied
;;; (to make asciZ), so nothing good will happen.
;;;* Don't use too short argument blocks, or too short strings, since
;;; anything might happen.
;;;* Remember to do (string-trim '(#\null) <string>) before using a
;;; string written by e.g. DIRST%.
(in-package 'si)
(export '(copy-string-with-z make-jsys-arg-block
bignum-as-cons
word-value bvc-as-words
18-bit-sign-extend 36-bit-sign-extend))
(defun bignum-as-cons (big)
"Takes a (positive) bignum, returns it as a cons suitable for JSYS.
If BIG is already a fixnum (which fits without consing), it is returned."
(if (fixnump big)
big
(if (> (integer-length big) 36)
(cerror "Give a smaller one" "Bignum too long")
(cons (ldb (byte 18 18) big) (ldb (byte 18 0) big)))))
(defun make-bit-vector (len &optional &key words)
"Make a simple-bit-vector of length LEN.
If :WORDS is non-nil, make it (* len 36) long."
(make-array (if words (* len 36) len) :element-type 'bit))
(defun set-word (index bits value)
"Sets word Index of the simple-bit-array Bits to Value."
(when (and (typep bits 'simple-bit-vector)
(<= index (truncate (length bits) 36)))
(let ((base (* index 36)))
(dotimes (i 36)
(setf (bit bits (+ i base)) (ldb (byte 1 (- 35 i)) value))))))
(defun copy-string-with-z (string)
"Returns an ASCIZ string."
(let ((str (make-string (1+ (length string)))))
(replace str string)
str))
;;; Don't look at this code, it uses UNBOX exactly the way it shouldn't.
;;; But, %JSYS is a kludge anyway...
(defun interpret-jsys-arg (arg)
"Interprets an object the same way as %JSYS does,
but doesn't handle STREAMs."
(typecase arg
(null 0)
(fixnum arg)
(cons (+ (dpb (interpret-jsys-arg (car arg)) (byte 18 18) 0)
(dpb (interpret-jsys-arg (cdr arg)) (byte 18 0) 0)))
(simple-string
(logior #o610000000000
(1+ (lisp::unbox (if (eql (char arg 0) #\null)
arg
(copy-string-with-z arg))))))
(symbol (interpret-jsys-arg (print-name symbol)))
(simple-bit-vector (1+ (lisp::unbox arg)))))
(defun word-value (bvc word)
"Gives the value of the WORDth word of the simple-bit-vector BVC"
(let ((val 0)
(base (* word 36)))
(dotimes (j 36 val)
(setq val (dpb (bit bvc (+ base j))
(byte 1 (- 35 j)) val)))))
(defun bvc-as-words (bvc)
"Given a bit-vector, returns it as a list of word values"
(do ((i 1 (1+ i))
(wds `(,(word-value bvc 0)) `(,@wds ,(word-value bvc i))))
((>= i (truncate (length bvc) 36)) wds)))
(defun make-jsys-arg-block (wordlist)
"Makes a JSYS arg block from the elements of the list.
Each element is used the same way as the arguments to %JSYS,
except for STREAMs."
(let ((bits (make-bit-vector (length wordlist) :words t)))
(dotimes (i (length wordlist) bits)
(let ((word (nth i wordlist)))
(set-word i bits (interpret-jsys-arg word))))))
(defun 18-bit-sign-extend (18bit)
(if (logbitp 17 18bit)
(- (logxor 18bit #o777777))
18bit))
(defun 36-bit-sign-extend (36bit)
(if (logbitp 35 36bit)
(- (logxor 36bit #o777777777777))
36bit))