/[cmucl]/src/clx/macros.lisp
ViewVC logotype

Diff of /src/clx/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by ram, Mon May 14 14:48:53 1990 UTC revision 1.2 by ram, Thu Nov 7 16:58:12 1991 UTC
# Line 56  Line 56 
56           (increment (get name 'byte-width :not-found)))           (increment (get name 'byte-width :not-found)))
57      (when (eq increment :not-found)      (when (eq increment :not-found)
58        ;; Check for TYPE in a different package        ;; Check for TYPE in a different package
59        (when (not (eq (symbol-package name) (find-package 'xlib)))        (when (not (eq (symbol-package name) *xlib-package*))
60          (setq name (xintern name))          (setq name (xintern name))
61          (setq increment (get name 'byte-width :not-found)))          (setq increment (get name 'byte-width :not-found)))
62        (when (eq increment :not-found)        (when (eq increment :not-found)
# Line 381  Line 381 
381         (ecase format         (ecase format
382           ((card8 int8)           ((card8 int8)
383            (maker 4))            (maker 4))
384           ((card16 int16)           ((card16 int16 char2b)
385            (maker 2))            (maker 2))
386           ((card32 int32)           ((card32 int32)
387            (maker 1)))))))            (maker 1)))))))
# Line 529  Line 529 
529    
530  (defun mask-get (index type-values body-function)  (defun mask-get (index type-values body-function)
531    (declare (type function body-function)    (declare (type function body-function)
532             (downward-funarg body-function))             #+clx-ansi-common-lisp
533               (dynamic-extent body-function)
534               #+(and lispm (not clx-ansi-common-lisp))
535               (sys:downward-funarg body-function))
536    ;; This is a function, because it must return more than one form (called by get-put-items)    ;; This is a function, because it must return more than one form (called by get-put-items)
537    ;; Functions that use this must have a binding for %MASK    ;; Functions that use this must have a binding for %MASK
538    (let* ((bit 0)    (let* ((bit 0)
# Line 560  Line 563 
563    
564  (defun mask-put (index type-values body-function)  (defun mask-put (index type-values body-function)
565    (declare (type function body-function)    (declare (type function body-function)
566             (downward-funarg body-function))             #+clx-ansi-common-lisp
567               (dynamic-extent body-function)
568               #+(and lispm (not clx-ansi-common-lisp))
569               (sys:downward-funarg body-function))
570    ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES    ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES
571    ;; A 32 bit value follows for each non-nil value.    ;; A 32 bit value follows for each non-nil value.
572    `((let ((%mask 0)    `((let ((%mask 0)
# Line 621  Line 627 
627    
628  (defun get-put-items (index type-args putp &optional body-function)  (defun get-put-items (index type-args putp &optional body-function)
629    (declare (type (or null function) body-function)    (declare (type (or null function) body-function)
630             (downward-funarg body-function))             #+clx-ansi-common-lisp
631               (dynamic-extent body-function)
632               #+(and lispm (not clx-ansi-common-lisp))
633               (sys:downward-funarg body-function))
634    ;; Given a lists of the form (type item item ... item)    ;; Given a lists of the form (type item item ... item)
635    ;; Calls body-function with four arguments, a function name,    ;; Calls body-function with four arguments, a function name,
636    ;; index, item name, and optional arguments.    ;; index, item name, and optional arguments.
# Line 669  Line 678 
678  (defmacro with-buffer-request-internal  (defmacro with-buffer-request-internal
679            ((buffer opcode &key length sizes &allow-other-keys)            ((buffer opcode &key length sizes &allow-other-keys)
680             &body type-args)             &body type-args)
   (declare (values request-number))  
681    (multiple-value-bind (code index item-sizes)    (multiple-value-bind (code index item-sizes)
682        (get-put-items 4 type-args t)        (get-put-items 4 type-args t)
683      (let ((length (if length `(index+ ,length *requestsize*) '*requestsize*))      (let ((length (if length `(index+ ,length *requestsize*) '*requestsize*))
# Line 687  Line 695 
695  (defmacro with-buffer-request  (defmacro with-buffer-request
696            ((buffer opcode &rest options &key inline gc-force &allow-other-keys)            ((buffer opcode &rest options &key inline gc-force &allow-other-keys)
697             &body type-args &environment env)             &body type-args &environment env)
   (declare (values request-number))  
698    (if (and (null inline) (macroexpand '(use-closures) env))    (if (and (null inline) (macroexpand '(use-closures) env))
699        `(flet ((.request-body. (.display.)        `(flet ((.request-body. (.display.)
700                  (declare (type display .display.))                  (declare (type display .display.))
701                  (with-buffer-request-internal (.display. ,opcode ,@options)                  (with-buffer-request-internal (.display. ,opcode ,@options)
702                    ,@type-args)))                    ,@type-args)))
703           #+ansi-common-lisp           #+clx-ansi-common-lisp
704           (declare (dynamic-extent #'.request-body.))           (declare (dynamic-extent #'.request-body.))
705           (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn)           (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn)
706                 'with-buffer-request-function-nolock                 'with-buffer-request-function-nolock
# Line 733  Line 740 
740                             (type reply-buffer .reply-buffer.))                             (type reply-buffer .reply-buffer.))
741                    (progn .display. .reply-buffer. nil)                    (progn .display. .reply-buffer. nil)
742                    ,reply-body))                    ,reply-body))
743             #+ansi-common-lisp             #+clx-ansi-common-lisp
744             (declare (dynamic-extent #'.request-body. #'.reply-body.))             (declare (dynamic-extent #'.request-body. #'.reply-body.))
745             (with-buffer-request-and-reply-function             (with-buffer-request-and-reply-function
746               ,buffer ,multiple-reply #'.request-body. #'.reply-body.))               ,buffer ,multiple-reply #'.request-body. #'.reply-body.))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5