home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 254b.lha / AMXLISP_v2.0 / lsp / interface.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1989-05-10  |  9.0 KB  |  233 lines
  1. ;------------- XLISP INTERFACE WITH AMIGA KERNEL ------------------------
  2. ; (C) Copyright Francois Rouaix 1987
  3. ;------------------------------------------------------------------------
  4. ;Added function to XLISP 1.7 core:
  5. ;   memory-byte
  6. ;   memory-word
  7. ;   memory-long
  8. ;   callasm
  9. ;------------------------------------------------------------------------
  10. ;Format for the XLincludes:
  11. ;(Structure-name (field)*)
  12. ;for each field the format is:
  13. ;(fieldname offset type)
  14. ;type is :
  15. ;   field=BYTE or eq         : 1
  16. ;   field=WORD or eq         : 2
  17. ;   field=LONG or eq         : 4
  18. ;   field=APTR               : byte . t
  19. ;   field=array              : size-of-array . type-of-elements
  20. ;   field=structure          : structurename
  21. ;   field=structure pointer  : structurename . t
  22.  
  23.  
  24.  
  25.  
  26.  
  27. ;We first define a Class 'Amiga' that knows only two methods that are:
  28. ;read-field (address type)  :<address> is the absolute address in memory
  29. ;                           :<type> is the length in bytes to be
  30. ;                           read (1,2 or 4)
  31. ;write-field (address type value)   :the same, with <value> being the
  32. ;                                   :value to store in memory
  33. ;If <obj> is an instance of <class> class, it is apparently
  34. ;impossible to get the symbol used to define this class
  35. ;all we can get is #<Object: ...> by (send <obj> :class)
  36. ;So we implement :
  37. ;a class variable <defined> where we store an a-list of
  38. ;objects . name.
  39. ;And two methods (name & add-name) for this feature
  40. ;it may be interessant to store  the links between include files
  41. ;to provide an "autoload" for structure definitions
  42.  
  43.  
  44.  
  45. ;---you should never call this function----
  46. (defun  read-field (address type)
  47.    (cond ((equal type 1)   ;BYTE
  48.           (memory-byte address))
  49.          ((equal type 2)  ;WORD
  50.           (memory-word address))
  51.          ((equal type 4)  ;LONG
  52.           (memory-long address))
  53.          ((consp type)  ;ARRAY/STRUCT/PTR/UNION
  54.           (if (numberp (car type))
  55.             ;this is an ARRAY
  56.               (let* ((nb (car type))
  57.                      (ln (cdr type))
  58.                      (tmpvector (make-array nb)))
  59.                     (dotimes (i nb tmpvector)
  60.                              (aset tmpvector
  61.                                    i
  62.                                    (read-field (+ address
  63.                                                   (* i (if (numberp ln)
  64.                                                            ln
  65.                                                            (send (send (eval ln) :new 0) :size-of))))
  66.                                                (if (numberp ln)
  67.                                                    ln
  68.                                                    (cons ln t)))
  69.                              )))
  70.             ;STRUCT/PTR/UNION
  71.               (let* ((tmpstruct ( send (eval (car type)) :new
  72.                              (if (null (cdr type))
  73.                                  address            ; the structure is here
  74.                                  (memory-long address))))) ; it is a pointer
  75.                    tmpstruct)))
  76.  
  77.          (t (error "Bad field description" type))))
  78.  
  79.  
  80. (defun write-field (address type value)
  81.    (cond ((equal type 1) (memory-byte address value))
  82.          ((equal type 2) (memory-word address value))
  83.          ((equal type 4) (memory-long address value))
  84.          (t
  85.           (if (numberp (car type))       ;this is an array
  86.               (let ((ln (cdr type)))
  87.                    (dotimes (i ln value)
  88.                             (write-field (+ address (* i ln))
  89.                                          type
  90.                                          (aref value i))))
  91.  
  92.               ;this is a structure
  93.               (if (null (cdr type)) ;the structure is really here
  94.                   (print "Not yet implemented")
  95.                   ;(mvmemory (aref value 0)
  96.                   ;          (size-of (type-of champ))
  97.                   ;          address)
  98.                   (memory-long address value))))))
  99.  
  100.  
  101. ;there is apparently a problem with Lattice v3.03 's calloc
  102. ;examine the (send class :new ..) method
  103. ;when called with no class variables, we get an "insufficient vector space"
  104. ;it seems that the newvector() call fails because we ask a null allocation
  105. ;and returns a NULL that looks like an out_of_memory error
  106.  
  107. (setq Amiga (send Class :new '() '(defined)))
  108.  
  109. (send Amiga :answer :read-field '(address type) (cddr (getfn read-field)))
  110. (send Amiga :answer :write-field '(address type value) (cddr (getfn write-field)))
  111. (send Amiga :answer :name '(obj) '((cassoc obj defined)))
  112. (send Amiga :answer :add-name '(obj name)
  113.          '((setq defined (cons (cons obj name) defined))))
  114.  
  115. (defun class-of (o) (send o :name (send o :class)))
  116.  
  117. ;for each C structure in RKM, we will define a class, that has Amiga
  118. ;for super-class and:
  119. ;-a class variable <descript> : containing the description
  120. ;of the  fields of the structure (see complete definition in docs)
  121. ;-a class variable <size> : the size (in bytes) of the structure
  122. ;-an instance variable <pointer> : the actual pointer in memory
  123. ;-a method <access-field> with the parameters : <field-name>
  124. ;            and eventually the <value> to store in that field.
  125. ;-a method <isnew> to force initialization of pointer variable
  126.  
  127.  
  128.  
  129. ;this function to share the body definition of the method
  130. ;"->" (pronounce access-field) for every structure definition
  131. ;further access to this body via (cddar afshare)
  132. ;                                       not in 2.0 see getfn macro
  133. ;pointer, description and size are local variables, within the scope
  134. ;of the method
  135. (defun afshare (fieldname & optional value)      ; don't call this
  136.    (when (eq pointer 0)
  137.          (error "Uninitialized structure: " self))   ;security
  138.    (let* ((fieldinfo (assoc fieldname description))  ;return alist entry
  139.           (offset (cadr fieldinfo))                  ;get offset
  140.           (type (cddr fieldinfo)))                   ;get field description
  141.           (when (null offset)                        ;
  142.                 (error "Bad field name: " fieldname))
  143.           (if (null value)
  144.               (send self :read-field (+ offset pointer) type)
  145.               (send self :write-field (+ offset pointer) type value))))
  146.  
  147.  
  148.  
  149.  
  150. (setq include-path "xlinclude:")
  151. (setq include-suffix ".l")
  152. (defun load-c-struct (includename &optional structlist)
  153.    (let ((handle (open (strcat include-path includename include-suffix))))
  154.         (when (null handle)
  155.               (error "Can't find include file: " includename))
  156.         (do ((l (read handle) (read handle)))
  157.             ((null l) (close handle))
  158.             (when (or (null structlist) (member (car l) structlist))
  159.                 (define-c-struct l)))))
  160.  
  161. (defmacro define-c-struct (l)
  162. `(progn
  163.    (set (car ,l) (send Class :new '(pointer) '(description size) Amiga))
  164.    (send (eval (car ,l)) :answer :isnew '(ptr) (cddr (getfn isnewshare)))
  165.    (send (eval (car ,l)) :answer :ptr '() '(pointer))
  166.    (send (eval (car ,l)) :answer :-> '(fieldname &optional value)
  167.                                  (cddr (getfn afshare)))
  168.    (send (eval (car ,l)) :answer :init '(descript) (cddr (getfn initshare)))
  169.    (send (eval (car ,l)) :answer :size-of '() (cddr (getfn size-of)))
  170.    (send (eval (car ,l)) :answer :fshow '() (cddr (getfn showshare)))
  171.  
  172.    (let ((tmp (send (eval (car ,l)) :new 0)))
  173.          (send tmp :init (cdr ,l))
  174.          (send tmp :add-name (eval (car ,l)) (symbol-name (car ,l))))))
  175.  
  176.  
  177. ;example of structure definitio  (done by define-c-struct)
  178. ;(setq Window (Class :new '(pointer) '(description size) Amiga))
  179. ;(Window :answer :isnew '(ptr) (cddar isnewshare))
  180. ;(Window :answer :ptr '() '(pointer))
  181. ;(Window :answer :-> '(fieldname &optional value)
  182. ;                              (cddar afshare))
  183. ;(Window :answer :init '(descript) (cddar initshare))
  184. ;(setq w0 (Window :new 0))
  185. ;(w0 :init --the description loaded from include file--)
  186. ;(w0 :add-name w0 (symbol-name 'window))
  187.  
  188. (defun isnewshare (ptr)
  189.    (setq pointer ptr)
  190.    self)
  191.  
  192. ;isnewshare should also compute the size of the structure
  193. ;and initialize the class variable <size>
  194. (defun initshare (descript)
  195.    (setq description descript)
  196.    self)
  197.  
  198. ; shared function for computing size of structure
  199. ;descript is in the scope
  200. (defun size-of ()
  201.    (let* ((lastfield (last description))
  202.           (lastoffset (cadar lastfield))
  203.           (lln (cddar lastfield)))
  204.          (+ lastoffset
  205.             (cond ((atom lln) lln)
  206.                   (t (if (numberp (car lln))
  207.                          (* (car lln) (cdr lln))
  208.                          (if (cdr lln)
  209.                              4
  210.                              (send (car lln) :size-of))))))))
  211.  
  212. (defun showshare ()
  213.    (setq *breakenable* ())
  214.    (mapc (lambda (field)
  215.             (princ (symbol-name (car field)))
  216.             (princ ": ")
  217.             (errset
  218.                (let ((fval (send self :-> (car field))))
  219.                   (if (objectp fval)
  220.                       (progn (princ (class-of fval))
  221.                              (princ "  ")
  222.                              (princ (send fval :ptr)))
  223.                       (princ fval))
  224.                   (terpri))
  225.                t )
  226.             )
  227.  
  228.           description)
  229.    (setq *breakenable* t)
  230.    )
  231.  
  232.  
  233.