/[gcl]/gcl/pcl/gcl_pcl_impl_low.lisp
ViewVC logotype

Diff of /gcl/pcl/gcl_pcl_impl_low.lisp

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

revision 1.2 by camm, Sat Jul 23 08:55:59 2005 UTC revision 1.3 by camm, Wed Sep 7 03:07:18 2005 UTC
# Line 7  Line 7 
7  (setq  *EVAL-WHEN-COMPILE* t)  (setq  *EVAL-WHEN-COMPILE* t)
8  )  )
9    
10  (defmacro memq (item list) `(member ,item ,list :test #'eq))  (import '(si::memq) 'pcl)
11    ;(defmacro memq (item list) `(member ,item ,list :test #'eq))
12  (defmacro assq (item list) `(assoc ,item ,list :test #'eq))  (defmacro assq (item list) `(assoc ,item ,list :test #'eq))
13  (defmacro posq (item list) `(position ,item ,list :test #'eq))  (defmacro posq (item list) `(position ,item ,list :test #'eq))
14    
# Line 290  object set_cclosure (result_cc,value_cc, Line 291  object set_cclosure (result_cc,value_cc,
291            (si::s-data-name includes)))))            (si::s-data-name includes)))))
292    
293  (defun structure-type-internal-slotds (type)  (defun structure-type-internal-slotds (type)
294     (si::s-data-slot-descriptions (get type 'si::s-data))     (si::s-data-slot-descriptions (get type 'si::s-data)))
   )  
295    
296  (defun structure-type-slot-description-list (type)  (defun structure-type-slot-description-list (type)
297    (or (cdr (gethash type *structure-table*))    (or (cdr (gethash type *structure-table*))
298        (mapcan #'(lambda (slotd)        (mapcan #'(lambda (slotd)
299                    (when (and slotd (car slotd))                    (when (and slotd (car slotd))
300                      (let ((offset (fifth slotd)))                      (let ((read-only-p (fourth slotd))
301                        (let ((reader #'(lambda (x)                            (offset (fifth slotd)))
302                                           (si:structure-ref1 x offset)                        (let ((reader (lambda (x) (si:structure-ref1 x offset)))
303                                           ))                              (writer ;(if read-only-p
304                              (writer #'(lambda (v x)                                          ;(lambda (v x) (si:structure-ref1 x offset))
305                                          (si:structure-set x type offset v))))                                        (lambda (v x) (si:structure-set x type offset v))))
306                          #+turbo-closure (si:turbo-closure reader)                          #+turbo-closure (si:turbo-closure reader)
307                          #+turbo-closure (si:turbo-closure writer)                          #+turbo-closure (si:turbo-closure writer)
308                          (let* ((reader-sym                          (let* ((reader-sym
309                                  (let ((*package* *the-pcl-package*))                                  (let ((*package* *the-pcl-package*))
310                                    (intern (format nil "~s SLOT~D" type offset))))                                    (intern (format nil "~s SLOT~D" type offset))))
311                                 (writer-sym (get-setf-function-name reader-sym))                                 (writer-sym (get-setf-function-name reader-sym))
312                                 (slot-name (first slotd))                                 (slot-name (first slotd)))
                                (read-only-p (fourth slotd)))  
313                            (setf (symbol-function reader-sym) reader)                            (setf (symbol-function reader-sym) reader)
314                            (setf (symbol-function writer-sym) writer)                            (setf (symbol-function writer-sym) writer)
315                            (do-standard-defsetf-1 reader-sym)                            (do-standard-defsetf-1 reader-sym)
316                            (list (list slot-name                            (list (list slot-name
317                                          (find-symbol (concatenate 'string (symbol-name type) "-" (symbol-name slot-name))
318                                                       (symbol-package type))
319                                        reader-sym                                        reader-sym
320                                        (and (not read-only-p) writer))))))))                                        writer
321                                          (third slotd)
322                                          (second slotd))))))))
323                (let ((slotds (structure-type-internal-slotds type))                (let ((slotds (structure-type-internal-slotds type))
324                      (inc (structure-type-included-type-name type)))                      (inc (structure-type-included-type-name type)))
325                  (if inc                  (if inc
# Line 330  object set_cclosure (result_cc,value_cc, Line 333  object set_cclosure (result_cc,value_cc,
333  (defun structure-slotd-accessor-symbol (slotd)  (defun structure-slotd-accessor-symbol (slotd)
334    (second slotd))    (second slotd))
335    
 ;(defun structure-slotd-writer-function (slotd)  
 ;  (third slotd))  
   
336  (defun structure-slotd-reader-function (slotd)  (defun structure-slotd-reader-function (slotd)
337    (third slotd))    (third slotd))
338    
339  (defun structure-slotd-writer-function (slotd)  (defun structure-slotd-writer-function (slotd)
340    (fourth slotd))    (fourth slotd))
341    
342    (defun structure-slotd-type (slotd)
343      (fifth slotd))
344    
345    (defun structure-slotd-init-form (slotd)
346      (sixth slotd))
347    
348  (defun renew-sys-files()  (defun renew-sys-files()
349    ;; packages:    ;; packages:
350    (compiler::get-packages "sys-package.lisp")    (compiler::get-packages "sys-package.lisp")

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

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26