(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER")
(il:filecreated "19-Oct-87 14:53:33" il:{erinyes}<lispusers>lyric>packed-structure.\;1 4305
il:|changes| il:|to:| (il:setfs logbitp) (il:functions def-packed-structure signed-ldb)
il:|previous| il:|date:| "29-Sep-87 18:13:33"
il:|{IE:PARC:XEROX}<LISP>LYRIC>LISPUSERS>PACKED-STRUCTURE.;1|)
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:packed-structurecoms)
(il:rpaqq il:packed-structurecoms ((il:functions def-packed-structure signed-ldb) (il:setfs logbitp) (il:prop il:makefile-environment il:packed-structure))
)
(defdefiner def-packed-structure il:structures (name &rest slots) (let* ((*package* (symbol-package name)) (count 0) (max-count 0) (locations)) (labels ((slot-name (slot) (car slot)) (slot-type (slot) (let ((type (getf (cddr slot) (quote :type) t))) (cond ((subtypep type (quote (member nil t))) (quote :boolean)) (t (il:* il:\; " punt for now, this should really coerce other things into stuff that looks like signed or unsigned byte ") type)))) (infix (x y) (intern (format nil "~A-~A" (string x) (string y)))) (slot-location (slot) (cdr (assoc (slot-name slot) locations))) (slot-supplied-p (slot) (infix (slot-name slot) "SUPPLIED-P")) (slot-signed (slot) (and (listp (slot-type slot)) (eq (car (slot-type slot)) (quote signed-byte)))) (slot-size (slot) (let ((type (slot-type slot))) (case type (:boolean 1) (t (ecase (car type) ((unsigned-byte signed-byte) (second type)))))))) (mapc (function (lambda (slot) (when (getf (cddr slot) (quote :overlay)) (setq count 0)) (push (cons (slot-name slot) count) locations) (incf count (slot-size slot)) (setq max-count (max max-count count)))) slots) (il:bquote (progn (deftype (il:\\\, name) nil (quote (unsigned-byte (il:\\\, count)))) (il:\\\,@ (mapcar (function (lambda (s) (il:bquote (defmacro (il:\\\, (infix name (slot-name s))) (x) (il:\\\, (cond ((eq (slot-type s) (quote :boolean)) (il:bquote (il:bquote (logbitp (il:\\\, (quote (il:\\\, (slot-location s)))) (il:\\\, x))))) (t (il:bquote (il:bquote ((il:\\\, (quote (il:\\\, (if (slot-signed s) (quote signed-ldb) (quote ldb))))) (il:\\\, (quote (il:\\\, (byte (slot-size s) (slot-location s))))) (il:\\\, x))))))))))) slots)) (defmacro (il:\\\, (infix "MAKE" name)) (&key (il:\\\,@ (mapcar (function (lambda (s) (list (slot-name s) (second s) (slot-supplied-p s)))) slots)) &aux (value 0)) (il:\\\,@ (mapcar (function (lambda (s) (il:bquote (when (il:\\\, (slot-supplied-p s)) (setq value (il:\\\, (cond ((eq (slot-type s) (quote :boolean)) (il:bquote (il:bquote (logior (if (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (ash 1 (slot-location s))))) 0) (il:\\\, value))))) ((slot-signed s) (il:bquote (il:bquote (dpb (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (byte (slot-size s) (slot-location s))))) (il:\\\, value))))) (t (il:bquote (il:bquote (logior (ash (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (slot-location s))))) (il:\\\, value)))))))))))) slots)) value))))))
(defun signed-ldb (bytespec integer) (flet ((sign-extend (number position) (if (logbitp (1- position) number) (dpb number (byte position 0) -1) number))) (sign-extend (ldb bytespec integer) (byte-size bytespec))))
(define-setf-method logbitp (index integer) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-method integer) (il:* il:\; "get SETF method for integer.") (let ((btemp (il:gensym)) (il:* il:\; "Temp var for index") (store (il:gensym)) (il:* il:\; "Temp var for new value") (stemp (first stores)) (il:* il:\; "Temp var for int to store.")) (values (cons btemp temps) (il:* il:\; "Temporary variables.") (cons index vals) (il:* il:\; "Value forms.") (list store) (il:* il:\; "Store variables.") (il:bquote (let (((il:\\\, stemp) (if (il:\\\, store) (logior (il:\\\, access-form) (ash 1 (il:\\\, btemp))) (logandc2 (il:\\\, access-form) (ash 1 (il:\\\, btemp)))))) (il:\\\, store-form) (il:\\\, store))) (il:* il:\; "Storing form") (il:bquote (logbitp (il:\\\, btemp) (il:\\\, access-form)))))))
(il:putprops il:packed-structure il:makefile-environment (:readtable "XCL" :package "XCL-USER"))
(il:putprops il:packed-structure il:copyright ("Xerox Corporation" 1987))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop