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
		      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)
    (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)

;;; 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)))
     (logior #o610000000000
	    (1+ (lisp::unbox (if (eql (char arg 0) #\null)
			       (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))

(defun 36-bit-sign-extend (36bit)
  (if (logbitp 35 36bit)
      (- (logxor 36bit #o777777777777))