Changeset 8771


Ignore:
Timestamp:
Mar 13, 2008, 11:21:43 AM (12 years ago)
Author:
gb
Message:

revert to earlier versions

Location:
branches/working-0711/ccl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/l1-readloop.lisp

    r8768 r8771  
    321321;  declared/proclaimed INLINE in env
    322322(defun note-function-info (name lambda-expression env)
    323   (when (lambda-expression-p lambda-expression)
    324     (multiple-value-bind (lfbits keyvect) (encode-lambda-list (cadr lambda-expression) t)
    325       (record-function-info name
    326                             (cons (cons lfbits keyvect)
    327                              (retain-lambda-expression name lambda-expression env))
    328                             env)
    329       t)))
    330 
    331 ;;; And this is different from FUNCTION-INFORMATION.
     323  (let ((definition-env (definition-environment env)))
     324    (if definition-env
     325      (let* ((already (assq (setq name (maybe-setf-function-name name))
     326                            (defenv.defined definition-env)))
     327             (info nil))
     328        (when (lambda-expression-p lambda-expression)
     329          (multiple-value-bind (lfbits keyvect) (encode-lambda-list (cadr lambda-expression) t)
     330            (setq info (cons (cons lfbits keyvect)
     331                             (retain-lambda-expression name lambda-expression env)))))
     332          (if already
     333            (if info (%rplacd already info))
     334            (push (cons name info) (defenv.defined definition-env)))))
     335    name))
     336
     337; And this is different from FUNCTION-INFORMATION.
    332338(defun retrieve-environment-function-info (name env)
    333339 (let ((defenv (definition-environment env)))
     
    339345    name))
    340346
    341 ;;; Must differ from -something-, but not sure what ...
     347; Must differ from -something-, but not sure what ...
    342348(defun note-variable-info (name info env)
    343349  (let ((definition-env (definition-environment env)))
  • branches/working-0711/ccl/lib/macros.lisp

    r8770 r8771  
    1616
    1717;;; Macros (and functions/constants used at macroexpand-time) ONLY.
    18 
     18 
    1919(in-package "CCL")
    2020
     
    617617      (%define-symbol-macro ',name ',expansion))))
    618618
    619 (defun record-function-info (name info env)
    620   (let ((definition-env (definition-environment env)))
    621     (if definition-env
    622       (let* ((already (assq (maybe-setf-function-name name)
    623                             (defenv.defined definition-env))))
    624         (if already
    625           (if info (%rplacd already info))
    626           (push (cons name info) (defenv.defined definition-env))))))
    627   name)
    628 
    629 
    630619;; ---- allow inlining setf functions
    631620(defmacro defun (spec args &body body &environment env &aux global-name inline-spec)
     
    17101699    `(progn
    17111700      (eval-when (:compile-toplevel)
    1712         (record-function-info ',name
    1713                               ',(multiple-value-bind (bits keys)
    1714                                                      (encode-lambda-list
    1715                                                       (adjust-defmethod-lambda-list lambda-list))
    1716                                                      (list (cons bits keys) nil))
    1717                               ,env))
     1701        (note-function-info ',name '(lambda ,(adjust-defmethod-lambda-list lambda-list)) ,env))
    17181702      (compiler-let ((*nx-method-warning-name*
    17191703                      (list ',name
     
    18391823                 (t
    18401824                  `(function (lambda () ,form))))))
    1841     (let* ((readers ())
    1842            (writers ()))
    1843       (setq class-name (require-type class-name '(and symbol (not null))))
    1844       (setq superclasses (mapcar #'(lambda (s) (require-type s 'symbol)) superclasses))
    1845       (let* ((options-seen ())
    1846              (slot-names))
    1847         (flet ((canonicalize-defclass-option (option)
    1848                  (let* ((option-name (car option)))
    1849                    (if (member option-name options-seen :test #'eq)
    1850                      (duplicate-options class-options)
    1851                      (push option-name options-seen))
    1852                    (case option-name
    1853                      (:default-initargs
    1854                          (let ((canonical ())
    1855                                (initargs-seen ()))
    1856                            (let (key val (tail (cdr option)))
    1857                              (loop (when (null tail) (return nil))
    1858                                    (setq key (pop tail)
    1859                                          val (pop tail))
    1860                                    (when (memq key initargs-seen)
    1861                                      (SIGNAL-PROGRAM-error "Duplicate initialization argument name ~S in :DEFAULT-INITARGS of DEFCLASS ~S" key class-name))
    1862                                    (push key initargs-seen)
    1863                                    (push ``(,',key ,',val  ,,(make-initfunction val)) canonical))
    1864                              `(':direct-default-initargs (list ,@(nreverse canonical))))))
    1865                      (:metaclass
    1866                       (unless (and (cadr option)
    1867                                    (typep (cadr option) 'symbol))
    1868                         (illegal-option option))
    1869                       `(:metaclass  ',(cadr option)))
     1825    (setq class-name (require-type class-name '(and symbol (not null))))
     1826    (setq superclasses (mapcar #'(lambda (s) (require-type s 'symbol)) superclasses))
     1827    (let* ((options-seen ())
     1828           (signatures ())
     1829           (slot-names))
     1830      (flet ((canonicalize-defclass-option (option)
     1831               (let* ((option-name (car option)))
     1832                 (if (member option-name options-seen :test #'eq)
     1833                   (duplicate-options class-options)
     1834                   (push option-name options-seen))
     1835                 (case option-name
     1836                   (:default-initargs
     1837                       (let ((canonical ())
     1838                             (initargs-seen ()))
     1839                         (let (key val (tail (cdr option)))
     1840                           (loop (when (null tail) (return nil))
     1841                              (setq key (pop tail)
     1842                                    val (pop tail))
     1843                              (when (memq key initargs-seen)
     1844                                (SIGNAL-PROGRAM-error "Duplicate initialization argument name ~S in :DEFAULT-INITARGS of DEFCLASS ~S" key class-name))
     1845                              (push key initargs-seen)
     1846                              (push ``(,',key ,',val  ,,(make-initfunction val)) canonical))
     1847                           `(':direct-default-initargs (list ,@(nreverse canonical))))))
     1848                   (:metaclass
     1849                    (unless (and (cadr option)
     1850                                 (typep (cadr option) 'symbol))
     1851                      (illegal-option option))
     1852                    `(:metaclass  ',(cadr option)))
     1853                   (:documentation
     1854                    `(:documentation ',(cadr option)))
     1855                   (t
     1856                     (list `',option-name `',(cdr option))))))
     1857             (canonicalize-slot-spec (slot)
     1858               (if (null slot) (signal-program-error "Illegal slot NIL"))
     1859               (if (not (listp slot)) (setq slot (list slot)))
     1860               (let* ((slot-name (require-type (car slot) 'symbol))
     1861                      (initargs nil)
     1862                      (other-options ())
     1863                      (initform nil)
     1864                      (initform-p nil)
     1865                      (initfunction nil)
     1866                      (type nil)
     1867                      (type-p nil)
     1868                      (allocation nil)
     1869                      (allocation-p nil)
     1870                      (documentation nil)
     1871                      (documentation-p nil)
     1872                      (readers nil)
     1873                      (writers nil))
     1874                 (when (memq slot-name slot-names)
     1875                   (SIGNAL-PROGRAM-error "Multiple slots named ~S in DEFCLASS ~S" slot-name class-name))
     1876                 (push slot-name slot-names)
     1877                 (do ((options (cdr slot) (cddr options))
     1878                      name)
     1879                     ((null options))
     1880                   (when (null (cdr options)) (signal-program-error "Illegal slot spec ~S" slot))
     1881                   (case (car options)
     1882                     (:reader
     1883                      (setq name (cadr options))
     1884                      (push name signatures)
     1885                      (push name readers))
     1886                     (:writer                     
     1887                      (setq name (cadr options))
     1888                      (push name signatures)
     1889                      (push name writers))
     1890                     (:accessor
     1891                      (setq name (cadr options))
     1892                      (push name signatures)
     1893                      (push name readers)
     1894                      (push `(setf ,name) signatures)
     1895                      (push `(setf ,name) writers))
     1896                     (:initarg
     1897                      (push (require-type (cadr options) 'symbol) initargs))
     1898                     (:type
     1899                      (if type-p
     1900                        (duplicate-options slot)
     1901                        (setq type-p t))
     1902                      ;(when (null (cadr options)) (signal-program-error "Illegal options ~S" options))
     1903                      (setq type (cadr options)))
     1904                     (:initform
     1905                      (if initform-p
     1906                        (duplicate-options slot)
     1907                        (setq initform-p t))
     1908                      (let ((option (cadr options)))
     1909                        (setq initform `',option
     1910                              initfunction
     1911                              (if (constantp option)
     1912                                `(constantly ,option)
     1913                                `#'(lambda () ,option)))))
     1914                     (:allocation
     1915                      (if allocation-p
     1916                        (duplicate-options slot)
     1917                        (setq allocation-p t))
     1918                      (setq allocation (cadr options)))
    18701919                     (:documentation
    1871                       `(:documentation ',(cadr option)))
     1920                      (if documentation-p
     1921                        (duplicate-options slot)
     1922                        (setq documentation-p t))
     1923                      (setq documentation (cadr options)))
    18721924                     (t
    1873                       (list `',option-name `',(cdr option))))))
    1874                (canonicalize-slot-spec (slot)
    1875                  (if (null slot) (signal-program-error "Illegal slot NIL"))
    1876                  (if (not (listp slot)) (setq slot (list slot)))
    1877                  (let* ((slot-name (require-type (car slot) 'symbol))
    1878                         (initargs nil)
    1879                         (other-options ())
    1880                         (initform nil)
    1881                         (initform-p nil)
    1882                         (initfunction nil)
    1883                         (type nil)
    1884                         (type-p nil)
    1885                         (allocation nil)
    1886                         (allocation-p nil)
    1887                         (documentation nil)
    1888                         (documentation-p nil))
    1889                    (when (memq slot-name slot-names)
    1890                      (SIGNAL-PROGRAM-error "Multiple slots named ~S in DEFCLASS ~S" slot-name class-name))
    1891                    (push slot-name slot-names)
    1892                    (do ((options (cdr slot) (cddr options))
    1893                         name)
    1894                        ((null options))
    1895                      (when (null (cdr options)) (signal-program-error "Illegal slot spec ~S" slot))
    1896                      (case (car options)
    1897                        (:reader
    1898                         (setq name (cadr options))
    1899                         (push name readers))
    1900                        (:writer                     
    1901                         (setq name (cadr options))
    1902                         (push name writers))
    1903                        (:accessor
    1904                         (setq name (cadr options))
    1905                         (push name readers)
    1906                         (push `(setf ,name) writers))
    1907                        (:initarg
    1908                         (push (require-type (cadr options) 'symbol) initargs))
    1909                        (:type
    1910                         (if type-p
    1911                           (duplicate-options slot)
    1912                           (setq type-p t))
    1913                                         ;(when (null (cadr options)) (signal-program-error "Illegal options ~S" options))
    1914                         (setq type (cadr options)))
    1915                        (:initform
    1916                         (if initform-p
    1917                           (duplicate-options slot)
    1918                           (setq initform-p t))
    1919                         (let ((option (cadr options)))
    1920                           (setq initform `',option
    1921                                 initfunction
    1922                                 (if (constantp option)
    1923                                   `(constantly ,option)
    1924                                   `#'(lambda () ,option)))))
    1925                        (:allocation
    1926                         (if allocation-p
    1927                           (duplicate-options slot)
    1928                           (setq allocation-p t))
    1929                         (setq allocation (cadr options)))
    1930                        (:documentation
    1931                         (if documentation-p
    1932                           (duplicate-options slot)
    1933                           (setq documentation-p t))
    1934                         (setq documentation (cadr options)))
    1935                        (t
    1936                         (let* ((pair (or (assq (car options) other-options)
    1937                                          (car (push (list (car options)) other-options)))))
    1938                           (push (cadr options) (cdr pair))))))
    1939                    `(list :name ',slot-name
    1940                      ,@(when allocation `(:allocation ',allocation))
    1941                      ,@(when initform-p `(:initform ,initform
    1942                                           :initfunction ,initfunction))
    1943                      ,@(when initargs `(:initargs ',initargs))
    1944                      ,@(when readers `(:readers ',readers))
    1945                      ,@(when writers `(:writers ',writers))
    1946                      ,@(when type-p `(:type ',type))
    1947                      ,@(when documentation-p `(:documentation ,documentation))
    1948                      ,@(mapcan #'(lambda (opt)
    1949                                    `(',(car opt) ',(if (null (cddr opt))
    1950                                                        (cadr opt)
    1951                                                        (cdr opt)))) other-options)))))
    1952           (let* ((direct-superclasses superclasses)
    1953                  (direct-slot-specs (mapcar #'canonicalize-slot-spec slots))
    1954                  (other-options (apply #'append (mapcar #'canonicalize-defclass-option class-options )))
    1955                  (reader-args '((#.(encode-lambda-list '(x))) nil))
    1956                  (writer-args '((#.(encode-lambda-list '(x y))) nil)))
    1957             `(progn
    1958               (eval-when (:compile-toplevel)
    1959                 (%compile-time-defclass ',class-name ,env)
    1960                 (progn                  ,@(mapcar #'(lambda (r) `(record-function-info ',r ',reader-args ,env))
    1961                                                   readers)
    1962                                         ,@(mapcar #'(lambda (w) `(record-function-info ',w ',writer-args ,env))
    1963                                                   writers)))
     1925                      (let* ((pair (or (assq (car options) other-options)
     1926                                       (car (push (list (car options)) other-options)))))
     1927                        (push (cadr options) (cdr pair))))))
     1928                 `(list :name ',slot-name
     1929                   ,@(when allocation `(:allocation ',allocation))
     1930                   ,@(when initform-p `(:initform ,initform
     1931                                        :initfunction ,initfunction))
     1932                   ,@(when initargs `(:initargs ',initargs))
     1933                   ,@(when readers `(:readers ',readers))
     1934                   ,@(when writers `(:writers ',writers))
     1935                   ,@(when type-p `(:type ',type))
     1936                   ,@(when documentation-p `(:documentation ,documentation))
     1937                   ,@(mapcan #'(lambda (opt)
     1938                                 `(',(car opt) ',(if (null (cddr opt))
     1939                                                     (cadr opt)
     1940                                                     (cdr opt)))) other-options)))))
     1941        (let* ((direct-superclasses superclasses)
     1942               (direct-slot-specs (mapcar #'canonicalize-slot-spec slots))
     1943               (other-options (apply #'append (mapcar #'canonicalize-defclass-option class-options ))))
     1944          `(progn
     1945            (eval-when (:compile-toplevel)
     1946              (%compile-time-defclass ',class-name ,env)
     1947              (progn
     1948                ,@(mapcar #'(lambda (s) `(note-function-info ',s nil ,env))
     1949                          signatures)))
    19641950              (ensure-class-for-defclass ',class-name
    1965                :direct-superclasses ',direct-superclasses
    1966                :direct-slots ,`(list ,@direct-slot-specs)
    1967                ,@other-options))))))))
     1951                            :direct-superclasses ',direct-superclasses
     1952                            :direct-slots ,`(list ,@direct-slot-specs)
     1953                            ,@other-options)))))))
    19681954
    19691955(defmacro define-method-combination (name &rest rest &environment env)
     
    19841970      `(progn
    19851971         (eval-when (:compile-toplevel)
    1986            (record-function-info ',function-name '((,(encode-lambda-list lambda-list)) nil) ,env))
     1972           (note-function-info ',function-name '(lambda ,lambda-list nil) ,env))
    19871973         (let ((,gf (%defgeneric
    19881974                     ',function-name ',lambda-list ',method-combination ',generic-function-class
Note: See TracChangeset for help on using the changeset viewer.