Changeset 6222


Ignore:
Timestamp:
Apr 8, 2007, 4:13:30 PM (13 years ago)
Author:
gb
Message:

DEFGLOBAL = DEFSTATIC.
DEFLOADVAR makes its argument static.
WITH-MACPTRS is saner.
WITH-ENCODED-CSTR writes NUL octet(s) to the end of the encoded string.
MAKE-GCABLE-RECORD, COPY-RECORD.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/lib/macros.lisp

    r5974 r6222  
    691691     (%defparameter ',var ,value ,doc)))
    692692
    693 (defmacro defglobal (&environment env var value &optional doc)
     693
     694(defmacro defstatic (&environment env var value &optional doc)
     695  "Syntax is like DEFPARAMETER.  Proclaims the symbol to be special,
     696but also asserts that it will never be given a per-thread dynamic
     697binding.  The value of the variable can be changed (via SETQ, etc.),
     698but since all threads access the same static binding of the variable,
     699such changes should be made with care."
    694700  (if (and doc (not (stringp doc))) (signal-program-error "~S is not a string." doc))
    695701  (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*))
     
    701707
    702708
     709(defmacro defglobal (&rest args)
     710  "Synonym for DEFSTATIC."
     711  `(defstatic ,@args))
     712
     713
    703714(defmacro defloadvar (&environment env var value &optional doc)
    704715  `(progn
    705      (defvar ,var ,@(if doc `(nil ,doc)))
     716     (defstatic ,var ,nil ,@(if doc `(,doc)))
    706717     (def-ccl-pointers ,var ()
    707718       (setq ,var ,value))
    708719     ',var))
     720
     721
    709722
    710723
     
    11501163  `(multiple-value-call #'list ,form))
    11511164
    1152 (defmacro multiple-value-bind (varlist values-form &body body &environment env)
    1153   (multiple-value-bind (body decls)
    1154                        (parse-body body env)
    1155     (let ((ignore (make-symbol "IGNORE")))
    1156       `(multiple-value-call #'(lambda (&optional ,@varlist &rest ,ignore)
    1157                                 (declare (ignore ,ignore))
    1158                                 ,@decls
    1159                                 ,@body)
    1160                             ,values-form))))
    1161 
    1162 (defmacro multiple-value-setq (vars val)
    1163   (if vars
    1164     `(values (setf (values ,@(mapcar #'(lambda (s) (require-type s 'symbol)) vars))  ,val))
    1165     `(prog1 ,val)))
    1166 
    1167 (defmacro nth-value (n form)
    1168   "Evaluate FORM and return the Nth value (zero based). This involves no
    1169   consing when N is a trivial constant integer."
    1170   `(car (nthcdr ,n (multiple-value-list ,form))))
     1165
    11711166
    11721167
     
    13241319(defmacro with-macptrs (varlist &rest body &environment env)
    13251320  (multiple-value-bind (body other-decls) (parse-body body env)
    1326     (collect ((bindings)
     1321    (collect ((temp-bindings)
     1322              (temp-decls)
     1323              (bindings)
    13271324              (our-decls)
    13281325              (inits))
    13291326      (dolist (var varlist)
     1327        (let* ((temp (gensym)))
     1328          (temp-decls temp)
    13301329        (if (consp var)
    13311330          (progn
    13321331            (our-decls (car var))
    1333             (bindings `(,(car var) (%null-ptr)))
     1332            (temp-bindings `(,temp (%null-ptr)))
     1333            (bindings `(,(car var) ,temp))
    13341334            (if (cdr var)
    1335               (inits `(%setf-macptr ,(car var) ,@(cdr var)))))
     1335              (inits `(%setf-macptr ,temp ,@(cdr var)))))
    13361336          (progn
    13371337            (our-decls var)
    1338             (bindings `(,var (%null-ptr))))))
    1339   `(let* ,(bindings)
    1340      (declare (dynamic-extent ,@(our-decls))
    1341      (declare (type macptr ,@(our-decls)))
    1342      ,@other-decls)
     1338            (temp-bindings  `(,temp  (%null-ptr)))
     1339            (bindings `(,var ,temp))))))
     1340  `(let* ,(temp-bindings)
     1341    (declare (dynamic-extent ,@(temp-decls)))
     1342    (declare (type macptr ,@(temp-decls)))
    13431343    ,@(inits)
    1344      ,@body))))
     1344    (let* ,(bindings)
     1345      (declare (type macptr ,@(our-decls)))
     1346      ,@other-decls
     1347      ,@body)))))
     1348
    13451349
    13461350(defmacro with-loading-file (filename &rest body)
     
    15921596                                 &rest body &environment env)
    15931597  (let* ((encoding (get-character-encoding encoding-name))
    1594          (str (gensym)))
     1598         (nul-vector (character-encoding-nul-encoding encoding))
     1599         (str (gensym))
     1600         (len (gensym))
     1601         (i (gensym)))
    15951602    (multiple-value-bind (body decls) (parse-body body env nil)
    15961603      `(let* ((,str ,string))
    15971604        (%stack-block ((,sym (cstring-encoded-length-in-bytes ,encoding ,str ,start ,end) :clear t))
    15981605          ,@decls
    1599           (encode-string-to-memory ,encoding ,sym 0 ,str ,start ,end)
     1606          (let* ((,len (encode-string-to-memory ,encoding ,sym 0 ,str ,start ,end)))
     1607            (declare (fixnum ,len))
     1608            (dotimes (,i (length ,nul-vector))
     1609              (setf (%get-unsigned-byte ,sym ,len) (aref ,nul-vector ,i))
     1610              (incf ,len)))
    16001611          ,@body)))))
    16011612
     
    27842795  (dolist (item inits result)
    27852796    (let* ((name (car item))
    2786            (record-name (cadr item))
    2787            (inits (cddr item))
    2788            (ftype (%foreign-type-or-record record-name)))
     2797           (record-name (cadr item))
     2798           (inits (cddr item))
     2799           (ftype (%foreign-type-or-record record-name))
     2800           (ordinal (foreign-type-ordinal ftype))
     2801           (ordinal-form (if (< ordinal max-canonical-foreign-type-ordinal)
     2802                           ordinal
     2803                           `(foreign-type-ordinal (load-time-value (%foreign-type-or-record ',record-name))))))
     2804      (setq result (nconc result `((%set-macptr-type ,name ,ordinal-form))))
    27892805      (if (typep ftype 'foreign-record-type)
    2790         (setq result (nconc result (%foreign-record-field-forms name ftype record-name inits)))
    2791         (progn
    2792           ;(setq result (nconc result `((%assert-macptr-ftype ,name ,ftype))))
    2793           (when inits
    2794             (if (and ftype (null (cdr inits)))
     2806        (setq result
     2807              (nconc result (%foreign-record-field-forms name ftype record-name inits)))
     2808        (progn
     2809          (when inits
     2810            (if (and ftype (null (cdr inits)))
    27952811              (setq result
    27962812                    (nconc result
    27972813                           `((setf ,(%foreign-access-form name ftype 0 nil)
    2798                               ,(car inits)))))
     2814                              ,(car inits)))))
    27992815              (error "Unexpected or malformed initialization forms: ~s in field type: ~s"
    28002816                     inits record-name))))))))
     
    28252841  (%foreign-type-or-record-size recname :bytes))
    28262842
    2827 (defmacro make-record (record-name &rest initforms)
    2828   "Expand into code which allocates and initalizes an instance of the type
    2829 denoted by typespec, on the foreign heap. The record is allocated using the
    2830 C function malloc, and the user of make-record must explicitly call the C
    2831 function free to deallocate the record, when it is no longer needed."
     2843(defun make-record-form (record-name allocator &rest initforms)
    28322844  (let* ((ftype (%foreign-type-or-record record-name))
     2845         (ordinal (foreign-type-ordinal ftype))
     2846         (ordinal-form (if (< ordinal max-canonical-foreign-type-ordinal)
     2847                         ordinal
     2848                         `(foreign-type-ordinal (load-time-value (%foreign-type-or-record ',record-name)))))
    28332849         (bits (ensure-foreign-type-bits ftype))
    28342850         (bytes (if bits
     
    28382854         (p (gensym))
    28392855         (bzero (read-from-string "#_bzero")))   
    2840     `(let* ((,p (malloc ,bytes)))
     2856    `(let* ((,p (,allocator ,bytes)))
     2857      (%set-macptr-type ,p ,ordinal-form)
    28412858      (,bzero ,p ,bytes)
    28422859      ,@(%foreign-record-field-forms p ftype record-name initforms)
    28432860      ,p)))
     2861 
     2862(defmacro make-record (record-name &rest initforms)
     2863  "Expand into code which allocates and initalizes an instance of the type
     2864denoted by typespec, on the foreign heap. The record is allocated using the
     2865C function malloc, and the user of make-record must explicitly call the C
     2866function free to deallocate the record, when it is no longer needed."
     2867  (apply 'make-record-form record-name 'malloc initforms))
     2868
     2869(defmacro make-gcable-record (record-name &rest initforms)
     2870  "Like MAKE-RECORD, only advises the GC that the foreign memory can
     2871   be deallocated if the returned pointer becomes garbage."
     2872  (apply 'make-record-form record-name '%new-gcable-ptr initforms))
     2873
     2874(defmacro copy-record (type source dest)
     2875  (let* ((size (* (%foreign-type-or-record-size type :words) #+64-bit-target 1 #+32-bit-target 2))
     2876         (src (gensym "SRC"))
     2877         (dst (gensym "DST"))
     2878         (accessor #+64-bit-target '%get-unsigned-long #+32-bit-target '%get-unsigned-word)
     2879         (i (gensym "I"))
     2880         (j (gensym "J")))
     2881    `(with-macptrs ((,src ,source)
     2882                    (,dst ,dest))
     2883      (do* ((,i 0 (+ ,i #+64-bit-target 4 #+32-bit-target 2))
     2884            (,j 0 (+ ,j 1)))
     2885           ((= ,j ,size))
     2886        (declare (fixnum ,i))
     2887        (setf (,accessor ,dst ,i) (,accessor ,src ,i))))))
     2888
     2889     
     2890   
    28442891
    28452892(defmacro with-terminal-input (&body body)
     
    34083455                                            (the (unsigned-byte 8) (ash ,arg -24)))))))))))
    34093456   
     3457
     3458(defmacro multiple-value-bind (varlist values-form &body body &environment env)
     3459  (multiple-value-bind (body decls)
     3460                       (parse-body body env)
     3461    (let ((ignore (make-symbol "IGNORE")))
     3462      `(multiple-value-call #'(lambda (&optional ,@varlist &rest ,ignore)
     3463                                (declare (ignore ,ignore))
     3464                                ,@decls
     3465                                ,@body)
     3466                            ,values-form))))
     3467
     3468(defmacro multiple-value-setq (vars val)
     3469  (if vars
     3470    `(values (setf (values ,@(mapcar #'(lambda (s) (require-type s 'symbol)) vars))  ,val))
     3471    `(prog1 ,val)))
     3472
     3473(defmacro nth-value (n form)
     3474  "Evaluate FORM and return the Nth value (zero based). This involves no
     3475  consing when N is a trivial constant integer."
     3476  `(car (nthcdr ,n (multiple-value-list ,form))))
Note: See TracChangeset for help on using the changeset viewer.