/[cmucl]/src/pcl/fin.lisp
ViewVC logotype

Diff of /src/pcl/fin.lisp

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

revision 1.5 by ram, Sat Oct 19 17:22:26 1991 UTC revision 1.6 by ram, Mon Jun 1 18:37:58 1992 UTC
# Line 106  explicitly marked saying who wrote it. Line 106  explicitly marked saying who wrote it.
106  ;;;       This must be SETF'able.  ;;;       This must be SETF'able.
107  ;;;  ;;;
108    
109  (eval-when (compile eval load)  (eval-when (compile load eval)
   
110  (defconstant funcallable-instance-data  (defconstant funcallable-instance-data
111               '(wrapper slots)               '(wrapper slots)
112    "These are the 'data-slots' which funcallable instances have so that    "These are the 'data-slots' which funcallable instances have so that
113     the meta-class funcallable-standard-class can store class, and static     the meta-class funcallable-standard-class can store class, and static
114     slots in them.")     slots in them.")
115    )
 ); eval-when (compile eval load)  
116    
117  (defmacro funcallable-instance-data-position (data)  (defmacro funcallable-instance-data-position (data)
118    (if (and (consp data)    (if (and (consp data)
119             (eq (car data) 'quote)             (eq (car data) 'quote))
            (boundp 'funcallable-instance-data))  
120        (or (position (cadr data) funcallable-instance-data :test #'eq)        (or (position (cadr data) funcallable-instance-data :test #'eq)
121            (progn            (progn
122              (warn "Unknown funcallable-instance data: ~S." (cadr data))              (warn "Unknown funcallable-instance data: ~S." (cadr data))
123              `(error "Unknown funcallable-instance data: ~S." ',(cadr data))))              `(error "Unknown funcallable-instance data: ~S." ',(cadr data))))
124        `(position ,data funcallable-instance-data :test #'eq)))        `(position ,data funcallable-instance-data :test #'eq)))
125    
126  (defun called-fin-without-function ()  (proclaim '(notinline called-fin-without-function))
127    (defun called-fin-without-function (&rest args)
128      (declare (ignore args))
129    (error "Attempt to funcall a funcallable-instance without first~%~    (error "Attempt to funcall a funcallable-instance without first~%~
130            setting its funcallable-instance-function."))            setting its funcallable-instance-function."))
131    
132    
   
   
133  ;;;  ;;;
134  ;;; In Lucid Lisp, compiled functions and compiled closures have the same  ;;; In Lucid Lisp, compiled functions and compiled closures have the same
135  ;;; representation.  They are called procedures.  A procedure is a basically  ;;; representation.  They are called procedures.  A procedure is a basically
# Line 209  explicitly marked saying who wrote it. Line 206  explicitly marked saying who wrote it.
206                  '(#xD0 #xAC #x11 #x5C #xD0 #xAC #x1 #x57 #x17 #xA7 #x5)                  '(#xD0 #xAC #x11 #x5C #xD0 #xAC #x1 #x57 #x17 #xA7 #x5)
207                  #+PA                  #+PA
208                  '(#x4891 #x3C #xE461 #x6530 #x48BF #x3FF9)                  '(#x4891 #x3C #xE461 #x6530 #x48BF #x3FF9)
209                  #-(or MC68000 SPARC BSP I386 VAX PA)                  #+MIPS
210                    '(#x8FD4 #x1E #x2785 #x2EEF #xA0 #x8 #x14 #xF000)
211                    #-(or MC68000 SPARC BSP I386 VAX PA MIPS)
212                  '(0 0 0 0)))                  '(0 0 0 0)))
213    
214    
# Line 384  explicitly marked saying who wrote it. Line 383  explicitly marked saying who wrote it.
383            (neq *boot-state* 'complete)            (neq *boot-state* 'complete)
384            (eq (class-of exp) *the-class-t*))            (eq (class-of exp) *the-class-t*))
385        (let ((*print-lexical-closure* nil))        (let ((*print-lexical-closure* nil))
386          (funcall (get 'si:print-lexical-closure ':definition-before-pcl)          (funcall (original-definition 'si:print-lexical-closure)
387                   exp stream slashify-p))                   exp stream slashify-p))
388        (let ((*print-escape* slashify-p)        (let ((*print-escape* slashify-p)
389              (*print-lexical-closure* exp))              (*print-lexical-closure* exp))
390          (print-object exp stream))))          (print-object exp stream))))
391    
392  (eval-when (load eval)  (unless (boundp '*boot-state*)
393    (unless (boundp '*boot-state*)    (setq *boot-state* nil))
394      (setq *boot-state* nil))  
395    (unless (get 'si:print-lexical-closure ':definition-before-pcl)  (redefine-function 'si:print-lexical-closure 'pcl-print-lexical-closure)
     (setf (get 'si:print-lexical-closure ':definition-before-pcl)  
           (symbol-function 'si:print-lexical-closure)))  
   (setf (symbol-function 'si:print-lexical-closure)  
         (symbol-function 'pcl-print-lexical-closure)))  
396    
397  (defvar *function-name-level* 0)  (defvar *function-name-level* 0)
398    
# Line 408  explicitly marked saying who wrote it. Line 403  explicitly marked saying who wrote it.
403             (<= *function-name-level* 2))             (<= *function-name-level* 2))
404        (let ((*function-name-level* (1+ *function-name-level*)))        (let ((*function-name-level* (1+ *function-name-level*)))
405          (generic-function-name function))          (generic-function-name function))
406        (apply (get 'si:function-name ':definition-before-pcl) function other-args)))        (apply (original-definition 'si:function-name) function other-args)))
407    
408  (eval-when (eval load)  (redefine-function 'si:function-name 'pcl-function-name)
   (unless (get 'si:function-name ':definition-before-pcl)  
     (setf (get 'si:function-name ':definition-before-pcl)  
           (symbol-function 'si:function-name)))  
   (setf (symbol-function 'si:function-name)  
         (symbol-function 'pcl-function-name)))  
409    
410  (defun pcl-arglist (function &rest other-args)  (defun pcl-arglist (function &rest other-args)
411    (let ((defn nil))    (let ((defn nil))
# Line 428  explicitly marked saying who wrote it. Line 418  explicitly marked saying who wrote it.
418                  (funcallable-instance-p defn)                  (funcallable-instance-p defn)
419                  (generic-function-p defn))                  (generic-function-p defn))
420             (generic-function-pretty-arglist defn))             (generic-function-pretty-arglist defn))
421            (t (apply (get 'zl:arglist ':definition-before-pcl) function other-args)))))            (t (apply (original-definition 'zl:arglist) function other-args)))))
422    
423  (eval-when (eval load)  (redefine-function 'zl:arglist 'pcl-arglist)
   (unless (get 'zl:arglist ':definition-before-pcl)  
     (setf (get 'zl:arglist ':definition-before-pcl)  
           (symbol-function 'zl:arglist)))  
   (setf (symbol-function 'zl:arglist)  
         (symbol-function 'pcl-arglist)))  
424    
425    
426  ;;;  ;;;
# Line 1302  dbg: Line 1287  dbg:
1287  ;;;  ;;;
1288  (defun allocate-funcallable-instance-1 ()  (defun allocate-funcallable-instance-1 ()
1289    (let* ((len (+ (length funcallable-instance-data) fin-data-offset))    (let* ((len (+ (length funcallable-instance-data) fin-data-offset))
1290           (res (kernel:%make-funcallable-instance           (res (kernel:%make-funcallable-instance
1291                 len                 len
1292                 #'called-fin-without-function)))                 #'called-fin-without-function)))
1293      (dotimes (i (length funcallable-instance-data))      (dotimes (i (length funcallable-instance-data))
1294        (kernel:%set-funcallable-instance-info res (+ i fin-data-offset) nil))        (kernel:%set-funcallable-instance-info res (+ i fin-data-offset) nil))
1295      (kernel:%set-funcallable-instance-info res fin-name-slot nil)      (kernel:%set-funcallable-instance-info res fin-name-slot nil)
# Line 1324  dbg: Line 1309  dbg:
1309  ;;;    Set the function that is called when FIN is called.  ;;;    Set the function that is called when FIN is called.
1310  ;;;  ;;;
1311  (defun set-funcallable-instance-function (fin new-value)  (defun set-funcallable-instance-function (fin new-value)
1312      (declare (type function new-value))
1313    (assert (funcallable-instance-p fin))    (assert (funcallable-instance-p fin))
1314    (ecase (kernel:get-type new-value)    (ecase (kernel:get-type new-value)
1315      (#.vm:closure-header-type      (#.vm:closure-header-type
1316       (let ((len (- (kernel:get-closure-length new-value)       (let ((len (- (kernel:get-closure-length new-value)
1317                     (1- vm:closure-info-offset))))                     (1- vm:closure-info-offset))))
1318         (cond ((> len fin-name-slot)         (cond ((> len fin-name-slot)
1319                (set-funcallable-instance-function                (set-funcallable-instance-function
1320                 fin                 fin
1321                 #'(lambda (&rest args)                 #'(lambda (&rest args)
1322                     (apply new-value args))))                     (apply new-value args))))
1323               (t               (t
1324                (dotimes (i fin-data-offset)                (dotimes (i fin-data-offset)
1325                  (kernel:%set-funcallable-instance-info                  (kernel:%set-funcallable-instance-info
1326                   fin i                   fin i
1327                   (if (>= i len)                   (if (>= i len)
1328                       nil                       nil
1329                       (kernel:%closure-index-ref new-value i))))                       (kernel:%closure-index-ref new-value i))))
1330                (kernel:%set-funcallable-instance-function                (kernel:%set-funcallable-instance-function
1331                 fin                 fin
1332                 (kernel:%closure-function new-value))))))                 (kernel:%closure-function new-value))))))
1333      (#.vm:function-header-type      (#.vm:function-header-type
1334       (kernel:%set-funcallable-instance-function fin new-value)))       (kernel:%set-funcallable-instance-function fin new-value)))
1335    new-value)    new-value)
# Line 1371  dbg: Line 1357  dbg:
1357  (defmacro funcallable-instance-data-1 (fin slot)  (defmacro funcallable-instance-data-1 (fin slot)
1358    (if (constantp slot)    (if (constantp slot)
1359        `(sys:%primitive c:closure-ref ,fin        `(sys:%primitive c:closure-ref ,fin
1360                         (+ (or (position ,slot funcallable-instance-data)                         (+ (or (position ,slot funcallable-instance-data)
1361                                (error "Unknown slot: ~S." ,slot))                                (error "Unknown slot: ~S." ,slot))
1362                            fin-data-offset))                            fin-data-offset))
1363        (ext:once-only ((n-slot slot))        (ext:once-only ((n-slot slot))
1364          `(kernel:%closure-index-ref          `(kernel:%closure-index-ref
1365            ,fin            ,fin
1366            (+ (or (position ,n-slot funcallable-instance-data)            (+ (or (position ,n-slot funcallable-instance-data)
1367                   (error "Unknown slot: ~S." ,n-slot))                   (error "Unknown slot: ~S." ,n-slot))
1368               fin-data-offset)))))               fin-data-offset)))))
1369  ;;;  ;;;
1370  (defmacro %set-funcallable-instance-data-1 (fin slot new-value)  (defmacro %set-funcallable-instance-data-1 (fin slot new-value)
1371    (ext:once-only ((n-fin fin)    (ext:once-only ((n-fin fin)
1372                    (n-slot slot)                    (n-slot slot)
1373                    (n-val new-value))                    (n-val new-value))
1374      `(progn      `(progn
1375         (kernel:%set-funcallable-instance-info         (kernel:%set-funcallable-instance-info
1376          ,n-fin          ,n-fin
1377          (+ (or (position ,n-slot funcallable-instance-data)          (+ (or (position ,n-slot funcallable-instance-data)
1378                 (error "Unknown slot: ~S." ,n-slot))                 (error "Unknown slot: ~S." ,n-slot))
1379             fin-data-offset)             fin-data-offset)
1380          ,n-val)          ,n-val)
1381         ,n-val)))         ,n-val)))
1382  ;;;  ;;;
1383  (defsetf funcallable-instance-data-1 %set-funcallable-instance-data-1)  (defsetf funcallable-instance-data-1 %set-funcallable-instance-data-1)
1384    
1385  ); End of #+cmu progn  ); End of #+cmu progn
1386    
   
1387    
1388  ;;;  ;;;
1389  ;;; Kyoto Common Lisp (KCL)  ;;; Kyoto Common Lisp (KCL)

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

  ViewVC Help
Powered by ViewVC 1.1.5