Changeset 8884


Ignore:
Timestamp:
Mar 25, 2008, 4:25:34 PM (11 years ago)
Author:
mb
Message:

Fix bugs and bootstrapping issue.

DEFINITION-TYPE-INSTANCE signals an error (instead of going into an
infinite loop) when asked the instance of an unknown type.

Defined a definition-type for callbacks.

source-files.lisp now knows how to compile and load itself (relies on
the early- stuff in l0-source-files.lisp)

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

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-0/l0-source-files.lisp

    r8882 r8884  
    2424(defvar *early-source-files* '())
    2525
    26 (defun record-source-file (name definition-type-name)
     26(defun early-record-source-file (name definition-type-name)
    2727  (push (list definition-type-name name *loading-toplevel-location*)
    2828        *early-source-files*))
    2929
    30 (defun register-definition-type (name)
     30(defun early-register-definition-type (name)
    3131  (push name *early-definition-types*))
    3232
    33 (defun definition-name-equal-p (a b)
     33(defun early-definition-name-equal-p (a b)
    3434  "Returns T if A and B represent the same definition-name."
    3535  (let ((seen '()))
     
    4040                (when (or (member a seen)
    4141                          (member b seen))
    42                   (return-from definition-name-equal-p nil))
     42                  (return-from early-definition-name-equal-p nil))
    4343                (push a seen)
    4444                (push b seen)
     
    4848      (rec a b))))
    4949
    50 (defun remove-definition-source (type-name name)
     50(defun early-remove-definition-source (type-name name)
    5151  (setf *early-source-files*
    5252        (delete-if (lambda (def)
    5353                     (and (eq (first def) type-name)
    54                           (definition-name-equal-p (second def) name)))
     54                          (early-definition-name-equal-p (second def) name)))
    5555                   *early-source-files*))
    5656  *early-source-files*)
     57
     58(setf (fdefinition 'record-source-file) #'early-record-source-file
     59      (fdefinition 'register-definition-type) #'early-register-definition-type
     60      (fdefinition 'remove-definition-source) #'early-remove-definition-source)
  • branches/working-0711/ccl/level-1/l1-callbacks.lisp

    r6934 r8884  
    8181    ;; already done by defpascal expansion
    8282    (when name (set name trampoline))
    83     (record-source-file name 'defcallback)
     83    (record-source-file name 'callback)
    8484    (when (and doc-string *save-doc-strings*)
    8585      (setf (documentation name 'variable) doc-string))
    8686    (when *fasload-print* (format t "~&~S~%" name))
    8787    (or name trampoline)))
    88 
    8988
    9089(defun %lookup-pascal-function (index)
  • branches/working-0711/ccl/level-1/l1-init.lisp

    r8882 r8884  
    267267If T we store as much source location information as we have available.
    268268
    269 If :NO-TEXT we don't store the original source code.")
     269If :NO-TEXT we don't store a copy of the original source text.")
    270270
    271271(defvar *modules* nil
  • branches/working-0711/ccl/lib/source-files.lisp

    r8882 r8884  
    2525(in-package "CCL")
    2626
    27 (defparameter *old-record-source-file*
    28   (prog1
    29       *record-source-file*
    30     ;; this needs to be in the value of parameter so that it is evaluated before the call to
    31     ;; record-source-file in the execution of the defparameter itself.
    32     (setf *record-source-file* nil))
    33   "While compiling this file we don't want *record-source-file*, this stores the value of
    34   *record-source-file* on entry to this file.")
     27(setf (fdefinition 'record-source-file) #'early-record-source-file
     28      (fdefinition 'register-definition-type) #'early-register-definition-type)
    3529
    3630;;;; * Mapping names of things to the text which defines the thing.
     
    131125;;;; ** Storing definitions for a name
    132126
    133 (defun record-source-file (name definition-type-name &optional (toplevel-source-note *loading-toplevel-location*))
     127(defun real-record-source-file (name definition-type-name &optional (toplevel-source-note *loading-toplevel-location*))
    134128  "Records where the thing of type DEFINITION-TYPE-NAME named NAME is stored.
    135129
    136130NAME is a definition-name; DEFINITION-TYPE-NAME is a symbol naming a definition-type-name (see
    137131definition-type-instance) or a definition-type object; TOPLEVEL-SOURCE-NOTE is the source-note."
    138   (when (and *record-source-file* toplevel-source-note)
     132  (if toplevel-source-note
    139133    (let* ((definition-type (definition-type-instance definition-type-name))
    140134           (source-note  toplevel-source-note)
     
    149143              (source-note-file-name source-note)))
    150144      (setf (definition-source definition-type name) source-note)
    151       (list definition-type-name (effective-name definition-type name) source-note))))
     145      (list definition-type-name (effective-name definition-type name) source-note))
     146    (remove-definition-source definition-type-name name)))
    152147
    153148;;;; * Framework for definig definition-types
     
    178173
    179174DEFINITION-TYPE-NAME, a symbol, is the short name of the definition-type."
    180   (find definition-type-name *definition-types*
    181         :key #'definition-type-name))
     175  (or (find definition-type-name *definition-types*
     176            :key #'definition-type-name)
     177      (error "No definition type named ~S." definition-type-name)))
    182178
    183179(defmacro define-definition-type (name supers &rest options)
     
    196192     ',name))
    197193
    198 (defun register-definition-type (name)
     194(defun real-register-definition-type (name)
    199195  (let ((name (definition-type-full-name name)))
    200196    (setf *definition-types* (delete name *definition-types* :key #'definition-type-name))
     
    404400  (%assert-function-name-p cons)
    405401  cons)
     402
     403;;;; ** conditions
     404
     405(define-definition-type condition (class-definition-type)
     406  (:default-name-function symbol))
     407
     408;;;; ** callbacks
     409
     410;;;; Can't put this in l1-callbacks since it's loaded before clos.
     411
     412(define-definition-type callback (function-definition-type)
     413  (:default-name-function symbol))
    406414
    407415;;;; * Finding definitions from a name
     
    468476;;;; * Done loading the r-s-f stuff. Do some housekeeping.
    469477
    470 (setf *record-source-file* *old-record-source-file*)
    471 
    472478;; Now that the real r-s-f framework is ready we can go back and fixup the early stuff. This early
    473479;; stuff is everything that we wanted to register before having defined the registration/recording
     
    478484  while *early-definition-types*
    479485  for type-name = (pop *early-definition-types*)
    480   do (register-definition-type type-name))
     486  do (real-register-definition-type type-name))
    481487
    482488(loop
    483489  while *early-source-files*
    484490  for (type name source-note) = (pop *early-source-files*)
    485   do (record-source-file name type source-note))
     491  do (real-record-source-file name type source-note))
     492
     493(setf (fdefinition 'record-source-file) #'real-record-source-file
     494      (fdefinition 'register-definition-type) #'real-register-definition-type)
Note: See TracChangeset for help on using the changeset viewer.