/[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.4 by ram, Fri Sep 30 16:05:07 1994 UTC revision 1.4.2.1 by pw, Tue May 23 16:36:04 2000 UTC
# Line 15  Line 15 
15  ;;; Texas Instruments Incorporated provides this software "as is" without  ;;; Texas Instruments Incorporated provides this software "as is" without
16  ;;; express or implied warranty.  ;;; express or implied warranty.
17  ;;;  ;;;
18    #+cmu
19    (ext:file-comment
20      "$Header$")
21    
22  ;;; CLX basicly implements a very low overhead remote procedure call  ;;; CLX basicly implements a very low overhead remote procedure call
23  ;;; to the server.  This file contains macros which generate the code  ;;; to the server.  This file contains macros which generate the code
# Line 222  Line 225 
225          (svref ',(apply #'vector keywords) ,value))))          (svref ',(apply #'vector keywords) ,value))))
226    ((index thing &rest keywords)    ((index thing &rest keywords)
227     `(write-card8 ,index (position ,thing     `(write-card8 ,index (position ,thing
228                                    #+lispm ',keywords ;; Lispm's prefer lists                                    (the simple-vector ',(apply #'vector keywords))
                                   #-lispm (the simple-vector ',(apply #'vector keywords))  
229                                    :test #'eq)))                                    :test #'eq)))
230    ((index thing &rest keywords)    ((index thing &rest keywords)
231     (let ((value (gensym)))     (let ((value (gensym)))
232       `(let ((,value (position ,thing       `(let ((,value (position ,thing
233                                #+lispm ',keywords                                (the simple-vector ',(apply #'vector keywords))
                               #-lispm (the simple-vector ',(apply #'vector keywords))  
234                                :test #'eq)))                                :test #'eq)))
235          (and ,value (write-card8 ,index ,value))))))          (and ,value (write-card8 ,index ,value))))))
236    
# Line 242  Line 243 
243          (svref ',(apply #'vector keywords) ,value))))          (svref ',(apply #'vector keywords) ,value))))
244    ((index thing &rest keywords)    ((index thing &rest keywords)
245     `(write-card16 ,index (position ,thing     `(write-card16 ,index (position ,thing
246                                     #+lispm ',keywords ;; Lispm's prefer lists                                     (the simple-vector ',(apply #'vector keywords))
                                    #-lispm (the simple-vector ',(apply #'vector keywords))  
247                                     :test #'eq)))                                     :test #'eq)))
248    ((index thing &rest keywords)    ((index thing &rest keywords)
249     (let ((value (gensym)))     (let ((value (gensym)))
250       `(let ((,value (position ,thing       `(let ((,value (position ,thing
251                                #+lispm ',keywords                                (the simple-vector ',(apply #'vector keywords))
                               #-lispm (the simple-vector ',(apply #'vector keywords))  
252                                :test #'eq)))                                :test #'eq)))
253          (and ,value (write-card16 ,index ,value))))))          (and ,value (write-card16 ,index ,value))))))
254    
# Line 262  Line 261 
261          (svref ',(apply #'vector keywords) ,value))))          (svref ',(apply #'vector keywords) ,value))))
262    ((index thing &rest keywords)    ((index thing &rest keywords)
263     `(write-card29 ,index (position ,thing     `(write-card29 ,index (position ,thing
264                                     #+lispm ',keywords ;; Lispm's prefer lists                                     (the simple-vector ',(apply #'vector keywords))
                                    #-lispm (the simple-vector ',(apply #'vector keywords))  
265                                     :test #'eq)))                                     :test #'eq)))
266    ((index thing &rest keywords)    ((index thing &rest keywords)
267     (if (cdr keywords) ;; IF more than one     (if (cdr keywords) ;; IF more than one
268         (let ((value (gensym)))         (let ((value (gensym)))
269           `(let ((,value (position ,thing           `(let ((,value (position ,thing
270                                    #+lispm ',keywords                                    (the simple-vector ',(apply #'vector keywords))
                                   #-lispm (the simple-vector ',(apply #'vector keywords))  
271                                    :test #'eq)))                                    :test #'eq)))
272              (and ,value (write-card29 ,index ,value))))              (and ,value (write-card29 ,index ,value))))
273         `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0)))))         `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0)))))
# Line 534  Line 531 
531    
532  (defun mask-get (index type-values body-function)  (defun mask-get (index type-values body-function)
533    (declare (type function body-function)    (declare (type function body-function)
534             #+clx-ansi-common-lisp             (dynamic-extent body-function))
            (dynamic-extent body-function)  
            #+(and lispm (not clx-ansi-common-lisp))  
            (sys:downward-funarg body-function))  
535    ;; 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)
536    ;; Functions that use this must have a binding for %MASK    ;; Functions that use this must have a binding for %MASK
537    (let* ((bit 0)    (let* ((bit 0)
# Line 568  Line 562 
562    
563  (defun mask-put (index type-values body-function)  (defun mask-put (index type-values body-function)
564    (declare (type function body-function)    (declare (type function body-function)
565             #+clx-ansi-common-lisp             (dynamic-extent body-function))
            (dynamic-extent body-function)  
            #+(and lispm (not clx-ansi-common-lisp))  
            (sys:downward-funarg body-function))  
566    ;; 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
567    ;; A 32 bit value follows for each non-nil value.    ;; A 32 bit value follows for each non-nil value.
568    `((let ((%mask 0)    `((let ((%mask 0)
# Line 632  Line 623 
623    
624  (defun get-put-items (index type-args putp &optional body-function)  (defun get-put-items (index type-args putp &optional body-function)
625    (declare (type (or null function) body-function)    (declare (type (or null function) body-function)
626             #+clx-ansi-common-lisp             (dynamic-extent body-function))
            (dynamic-extent body-function)  
            #+(and lispm (not clx-ansi-common-lisp))  
            (sys:downward-funarg body-function))  
627    ;; Given a lists of the form (type item item ... item)    ;; Given a lists of the form (type item item ... item)
628    ;; Calls body-function with four arguments, a function name,    ;; Calls body-function with four arguments, a function name,
629    ;; index, item name, and optional arguments.    ;; index, item name, and optional arguments.
# Line 705  Line 693 
693                  (declare (type display .display.))                  (declare (type display .display.))
694                  (with-buffer-request-internal (.display. ,opcode ,@options)                  (with-buffer-request-internal (.display. ,opcode ,@options)
695                    ,@type-args)))                    ,@type-args)))
          #+clx-ansi-common-lisp  
696           (declare (dynamic-extent #'.request-body.))           (declare (dynamic-extent #'.request-body.))
697           (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn)           (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn)
698                 'with-buffer-request-function-nolock                 'with-buffer-request-function-nolock
# Line 745  Line 732 
732                             (type reply-buffer .reply-buffer.))                             (type reply-buffer .reply-buffer.))
733                    (progn .display. .reply-buffer. nil)                    (progn .display. .reply-buffer. nil)
734                    ,reply-body))                    ,reply-body))
            #+clx-ansi-common-lisp  
735             (declare (dynamic-extent #'.request-body. #'.reply-body.))             (declare (dynamic-extent #'.request-body. #'.reply-body.))
736             (with-buffer-request-and-reply-function             (with-buffer-request-and-reply-function
737               ,buffer ,multiple-reply #'.request-body. #'.reply-body.))               ,buffer ,multiple-reply #'.request-body. #'.reply-body.))

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.4.2.1

  ViewVC Help
Powered by ViewVC 1.1.5