home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / OS2XLSP1.ZIP / STRUCT.LSP < prev    next >
Text File  |  1988-07-21  |  5KB  |  149 lines
  1. ; struct.lsp -- structures for OS2XLISP 
  2. ; Andrew Schulman 11-June-1988
  3. ; rewrote (sum) and (make-list) without recursion 15-June-1988
  4. ; using &aux instead of (let) 17-June-1988
  5. ; added support for arrays and imbedded strings 20-July-1988
  6. ; added option to (unpack-struct) to return raw data rather than assoc list
  7. ; moved comments to struct.doc
  8.  
  9. ;======================================================================
  10. ; helper routines
  11.  
  12. ; this interprets 0 as 4 (code for string pointers)
  13. (define (sum lst &aux (sum 0))
  14.     (dolist (elem lst sum)
  15.         (setf sum (+ sum (if (zerop elem) 4 elem)))))
  16.  
  17. (define (make-list length init &aux (lst nil))
  18.     (if (zerop length) 
  19.         ()
  20.         (dotimes
  21.             (i length lst)
  22.             (setf lst (cons init lst)))))
  23.             
  24. ; write non-recursive version later             
  25. ; can flatten assoc-lists into property-lists
  26. (define (flatten lst)
  27.     (cond
  28.         ((null lst)
  29.             nil)
  30.         ((atom lst)
  31.             (list lst))
  32.         (t
  33.             (append
  34.                 (flatten (car lst))
  35.                 (flatten (cdr lst))))))
  36.                     
  37. (define (conv-array s)
  38.     (* (conv (car s) nil) (cadr s)))
  39.     
  40. (define (conv s do-conv)
  41.     (if (listp s)
  42.         (if do-conv
  43.             (conv-array s)
  44.             s)
  45.     ; else
  46.         (case s
  47.             ((0 1 2 4 8)            s)
  48.             ((str string)           0)
  49.             ((byte char)            1)
  50.             ((word int short)       2)
  51.             ((long fixnum ptr)      4)
  52.             ((float flonum double)  8)
  53.             (t (error "Bad structure element type")))))
  54.  
  55. (define (convert-template template keep)
  56.     (mapcar
  57.         (lambda (size &aux (sz (listp size)))
  58.             (cond
  59.                 ((and keep sz)
  60.                     (list (conv (car size) nil) (cadr size)))
  61.                 (keep
  62.                     (conv size nil))
  63.                 (sz
  64.                     (conv (car size) t))))
  65.             template))
  66.  
  67. (define (peek-array a s)
  68.     (if (eq 'CHAR (car s))
  69.         ; string (array of CHAR)
  70.         (peek a 0)
  71.         ; other array
  72.         (unpack-struct
  73.             (make-list (cadr s) (conv (car s) nil))
  74.             a)))
  75.  
  76. ;======================================================================
  77. ; make packed OS/2-compatible data structure from description in Lisp list
  78. (define (make-struct template &optional data)
  79.     (let*
  80.         ((template (convert-template template nil))
  81.          (str (make-string 32 (sum template)))
  82.          (len (length template))
  83.          (offset 0))
  84.         (cond
  85.             ((not data)
  86.                 (setf data (make-list len 0)))
  87.             ((atom data)
  88.                 (setf data (make-list len data)))
  89.             (t
  90.                 (let
  91.                     ((diff (- len (length data))))
  92.                     (cond
  93.                         ((plusp diff)
  94.                             (nconc data (make-list diff 0)))
  95.                         ((minusp diff)
  96.                             (error "make-struct: template/data mismatch"))))))
  97.         (mapcar
  98.             (lambda (size info)
  99.                 ;;; (format stdout "~A ~A\n" size info) ;;; debugging
  100.                 (if (zerop size)
  101.                     (setf size 4)
  102.                     (if (member size '(1 2 4 8))
  103.                         (poke (+ ^str offset) info size)
  104.                         ; __temporary__ initialization of arrays
  105.                         (dotimes
  106.                             (i size)
  107.                             (poke (+ ^str i) info 1))))
  108.                 (setf offset (+ offset size)))
  109.             template
  110.             data)
  111.         str))
  112.  
  113. ;======================================================================
  114. ; turn OS/2 data structure and description into a Lisp assoc list
  115. (define (unpack-struct template str)
  116.     (let
  117.         ((template (convert-template template t))
  118.          (addr (if (eq 'STRING (type-of str)) ^str str))
  119.          (offset 0)
  120.          (s 0)
  121.          (info 0))
  122.         (mapcar
  123.             (lambda (size &aux (a (+ addr offset)))
  124.                 (setf s
  125.                     (if (listp size) (car size) size))
  126.                 (prog2
  127.                     (setf info
  128.                         (cond
  129.                             ((listp s)                      
  130.                                 (peek-array a s))           ; array
  131.                             ((and (zerop s) (not (zerop (peek a 4))))
  132.                                 (peek (peek a 4) 0))        ; string ptr
  133.                             (t
  134.                                 (peek a s))))               ; normal
  135. ;                    (if (and name-flag (listp size))
  136.                          (list (cadr size) info)
  137. ;                        info)
  138.                     (setf offset (+ offset
  139.                         (cond
  140.                             ((listp s) (conv-array s))      ; array
  141.                             ((zerop s) 4)                   ; string ptr
  142.                             (t s))))))                      ; normal
  143.             template)))
  144.  
  145. ;======================================================================
  146. ; extract data from the structure
  147. (define (get-elem struct instance elem)
  148.     (cadr (assoc elem (unpack-struct struct instance))))
  149.