Changeset 10942


Ignore:
Timestamp:
Oct 2, 2008, 6:43:48 PM (11 years ago)
Author:
gz
Message:

Propagate r10938:r10941 (duplicate definition warnings) to trunk

Location:
trunk/source
Files:
31 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/X86/x86-lap.lisp

    r10924 r10942  
    307307
    308308
    309 (defstruct (frag-list (:include ccl::dll-header)))
     309(defstruct (frag-list (:include ccl::dll-header) (:constructor nil)))
    310310
    311311;;; ccl::dll-header-last is unit-time
  • trunk/source/compiler/nx-basic.lisp

    r10309 r10942  
    511511    (:lambda . "Suspicious lambda-list: ~s")
    512512    (:result-ignored . "Function result ignored in call to ~s")
     513    (:duplicate-definition . report-compile-time-duplicate-definition)
    513514    (:program-error . "~a")))
    514515
     516(defun report-compile-time-duplicate-definition (condition stream)
     517  (destructuring-bind (name old-file new-file &optional from to) (compiler-warning-args condition)
     518    (format stream
     519            "Duplicate definitions of ~s~:[~*~;~:* (as a ~a and a ~a)~]~:[~;, in this file~:[~; and in ~s~]~]"
     520            name from to
     521            (and old-file new-file)
     522            (neq old-file new-file)
     523            old-file)))
    515524
    516525(defun report-compiler-warning (condition stream)
    517526  (let* ((warning-type (compiler-warning-warning-type condition))
    518          (format-string (cdr (assq warning-type *compiler-warning-formats*))))
     527         (format-string (cdr (assq warning-type *compiler-warning-formats*)))
     528         (name (reverse (compiler-warning-function-name condition))))
    519529    (format stream "In ")
    520     (print-nested-name (reverse (compiler-warning-function-name condition)) stream)
     530    (print-nested-name name stream)
     531    (when (every #'null name)
     532      (let ((position (compiler-warning-stream-position condition)))
     533        (when position (format stream " at position ~s" position))))
    521534    (format stream ": ")
    522535    (if (typep format-string 'string)
  • trunk/source/compiler/nx0.lisp

    r10367 r10942  
    10821082                       containing-env (afunc-environment afunc)
    10831083                       lambda-form (afunc-lambdaform afunc)))
    1084         (let* ((defenv (definition-environment env)))
    1085           (if (cdr (setq info (if defenv (cdr (assq sym (defenv.defined defenv))))))
    1086             (setq lambda-form (cdr info)
     1084        (setq info (cdr (retrieve-environment-function-info sym env)))
     1085        (if (def-info.lambda info)
     1086            (setq lambda-form (def-info.lambda info)
    10871087                  token sym
    1088                   containing-env (new-lexical-environment defenv))
     1088                  containing-env (new-lexical-environment (definition-environment env)))
    10891089            (unless info
    10901090              (if (cdr (setq info (assq sym *nx-globally-inline*)))
    10911091                (setq lambda-form (%cdr info)
    10921092                      token sym
    1093                       containing-env (new-lexical-environment (new-definition-environment nil)))))))))
     1093                      containing-env (new-lexical-environment (new-definition-environment nil))))))))
    10941094    (values lambda-form (nx-closed-environment env containing-env) token)))
    10951095
     
    19221922                         (case deftype
    19231923                           (:global-mismatch (innermost-lfun-bits-keyvect def))
    1924                            (:environment-mismatch (values (caadr def) (cdadr def)))
     1924                           (:environment-mismatch
     1925                              (values (def-info.lfbits (cdr def)) (def-info.keyvect (cdr def))))
    19251926                           (t (let* ((lambda-form (afunc-lambdaform def)))
    19261927                                (if (lambda-expression-p lambda-form)
    19271928                                  (encode-lambda-list (cadr lambda-form))))))
    19281929      (when bits
    1929         (unless (typep bits 'fixnum) (bug "Bad bits!"))
     1930        (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
    19301931        (let* ((nargs (length arglist))
    19311932               (minargs (if spread-p (1- nargs) nargs))
  • trunk/source/compiler/nxenv.lisp

    r10366 r10942  
    3030#+x8664-target (require "X8664ENV")
    3131
    32 ;
     32#-BOOTSTRAPPED (unless (fboundp '%cons-def-info)
     33                 (fset '%cons-def-info (lambda (&rest args) args nil))
     34                 (fset 'def-info.lfbits (lambda (def-info) def-info nil))
     35                 (fset 'def-info.keyvect (lambda (def-info) def-info nil))
     36                 (fset 'def-info.lambda (lambda (def-info) def-info nil)))
     37#-BOOTSTRAPPED (unless (fboundp 'retrieve-environment-function-info)
     38                 (fset 'retrieve-environment-function-info (lambda (name env) name env nil)))
    3339
    3440(defconstant $vbittemporary 16)    ; a compiler temporary
  • trunk/source/level-1/l1-application.lisp

    r10914 r10942  
    304304  #+unix '("home:ccl-init" "home:\\.ccl-init")
    305305  #+windows "home:ccl-init")
    306 
    307 (defmethod application-error ((a application) condition error-pointer)
    308   (declare (ignore condition error-pointer))
    309   (quit))
  • trunk/source/level-1/l1-callbacks.lisp

    r10629 r10942  
    2121(defstatic *callback-lock* (make-lock))
    2222
    23 
    24 ;;; MacOS toolbox routines were once written mostly in Pascal, so some
    25 ;;; code still refers to callbacks from foreign code as "pascal-callable
    26 ;;; functions".
    27 
    28 ; %Pascal-Functions% Entry
    29 (def-accessor-macros %svref
    30   pfe.routine-descriptor
    31   pfe.proc-info
    32   pfe.lisp-function
    33   pfe.sym
    34   pfe.without-interrupts
    35   pfe.trace-p)
    36 
    37 (defun %cons-pfe (routine-descriptor proc-info lisp-function sym without-interrupts)
    38   (vector routine-descriptor proc-info lisp-function sym without-interrupts nil))
    3923
    4024;;; (defcallback ...) expands into a call to this function.
  • trunk/source/level-1/l1-clos-boot.lisp

    r10937 r10942  
    175175
    176176
    177 (defun %slot-definition-class (slotd)
    178   (standard-slot-definition.class slotd))
    179 
    180177(defun %slot-definition-location (slotd)
    181178  (standard-effective-slot-definition.location slotd))
     
    279276
    280277;;; This becomes (apply #'make-instance <method-class> &rest args).
    281 (defun %make-method-instance (class &key
    282                                     qualifiers
    283                                     specializers
    284                                     function                               
    285                                     name
    286                                     lambda-list
    287                                     &allow-other-keys)
    288   (let* ((method
    289           (%instance-vector (%class-own-wrapper class)
    290                             qualifiers
    291                             specializers
    292                             function
    293                             nil
    294                             name
    295                             lambda-list)))
    296     (when function
    297       (let* ((inner (closure-function function)))
    298         (unless (eq inner function)
    299           (copy-method-function-bits inner function)))
    300       (lfun-name function method))
    301     method))
     278(fset '%make-method-instance
     279      (nlambda bootstrapping-%make-method-instance (class &key
     280                                                          qualifiers
     281                                                          specializers
     282                                                          function
     283                                                          name
     284                                                          lambda-list
     285                                                          &allow-other-keys)
     286        (let* ((method
     287                (%instance-vector (%class-own-wrapper class)
     288                                  qualifiers
     289                                  specializers
     290                                  function
     291                                  nil
     292                                  name
     293                                  lambda-list)))
     294          (when function
     295            (let* ((inner (closure-function function)))
     296              (unless (eq inner function)
     297                (copy-method-function-bits inner function)))
     298            (lfun-name function method))
     299          method)))
    302300 
    303301       
     
    872870
    873871;; Redefined in l1-clos.lisp
    874 (defun maybe-remove-make-instance-optimization (gfn method)
    875   (declare (ignore gfn method))
    876   nil)
     872(fset 'maybe-remove-make-instance-optimization
     873      (nlambda bootstrapping-maybe-remove-make-instance-optimization (gfn method)
     874        (declare (ignore gfn method))
     875        nil))
    877876
    878877(defun %add-standard-method-to-standard-gf (gfn method)
     
    13281327
    13291328
    1330 (defun set-find-class (name class)
    1331   (clear-type-cache)
    1332   (let* ((cell (find-class-cell name t))
    1333          (old-class (class-cell-class cell)))
    1334     (when class
    1335       (if (eq name (%class.name class))
    1336         (setf (info-type-kind name) :instance)))
    1337     (setf (class-cell-class cell) class)
    1338     (update-class-proper-names name old-class class)
    1339     class))
     1329(fset 'set-find-class (nfunction bootstrapping-set-find-class ; redefined below
     1330                                 (lambda (name class)
     1331                                   (clear-type-cache)
     1332                                   (let* ((cell (find-class-cell name t))
     1333                                          (old-class (class-cell-class cell)))
     1334                                     (when class
     1335                                       (if (eq name (%class.name class))
     1336                                         (setf (info-type-kind name) :instance)))
     1337                                     (setf (class-cell-class cell) class)
     1338                                     (update-class-proper-names name old-class class)
     1339                                     class))))
    13401340
    13411341
    13421342;;; bootstrapping definition. real one is in "sysutils.lisp"
    1343 
    1344 (defun built-in-type-p (name)
    1345   (or (type-predicate name)
    1346       (memq name '(signed-byte unsigned-byte mod
    1347                    values satisfies member and or not))
    1348       (typep (find-class name nil) 'built-in-class)))
     1343(fset 'built-in-type-p (nfunction boostrapping-built-in-typep-p
     1344                                  (lambda (name)
     1345                                    (or (type-predicate name)
     1346                                        (memq name '(signed-byte unsigned-byte mod
     1347                                                     values satisfies member and or not))
     1348                                        (typep (find-class name nil) 'built-in-class)))))
    13491349
    13501350
     
    25192519;;; Bootstrapping version of union
    25202520(unless (fboundp 'union)
    2521 (defun union (l1 l2)
    2522   (dolist (e l1)
    2523     (unless (memq e l2)
    2524       (push e l2)))
    2525   l2)
     2521  (fset 'union (nlambda bootstrapping-union (l1 l2)
     2522                 (dolist (e l1)
     2523                   (unless (memq e l2)
     2524                     (push e l2)))
     2525                 l2))
    25262526)
    25272527
  • trunk/source/level-1/l1-clos.lisp

    r10426 r10942  
    176176
    177177;; Bootstrapping version, replaced in l1-typesys
    178 (defun standardized-type-specifier (spec)
    179   (when (and (consp spec)
    180              (memq (%car spec) '(and or))
    181              (consp (%cdr spec))
    182              (null (%cddr spec)))
    183     (setq spec (%cadr spec)))
    184   (if (consp spec)
    185     (cons (%car spec) (mapcar #'standardized-type-specifier (%cdr spec)))
    186     (or (cdr (assoc spec '((string . base-string))))
    187         spec)))
     178(fset 'standardized-type-specifier
     179      (nlambda bootstrapping-standardized-type-specifier (spec)
     180        (when (and (consp spec)
     181                   (memq (%car spec) '(and or))
     182                   (consp (%cdr spec))
     183                   (null (%cddr spec)))
     184          (setq spec (%cadr spec)))
     185        (if (consp spec)
     186          (cons (%car spec) (mapcar #'standardized-type-specifier (%cdr spec)))
     187          (or (cdr (assoc spec '((string . base-string))))
     188              spec))))
    188189
    189190;;; The type of an effective slot definition is the intersection of
     
    11851186
    11861187
    1187 ;;; Fake method-combination
     1188;;; Fake method-combination, redefined in lib;method-combination.
    11881189(defclass method-combination (metaobject)
    1189   ((name :accessor method-combination-name :initarg :name)))
     1190  ((name :initarg :name)))
    11901191
    11911192
  • trunk/source/level-1/l1-dcode.lisp

    r10426 r10942  
    611611  (sgf.method-combination gf))
    612612
    613 (defun %combined-method-methods  (cm)
    614   (combined-method.thing cm))
    615 
    616 (defun %combined-method-dcode (cm)
    617   ;(require-type cm 'combined-method)
    618   (combined-method.dcode cm))
    619 
    620 
    621613; need setters too
    622614
  • trunk/source/level-1/l1-files.lisp

    r10872 r10942  
    128128
    129129                   
    130 (defun %shrink-vector (vector to-size)
    131   (cond ((eq (length vector) to-size)
    132          vector)
    133         ((array-has-fill-pointer-p vector)
    134          (setf (fill-pointer vector) to-size)
    135          vector)
    136         (t (subseq vector 0 to-size))))
    137 
    138130(defun namestring-unquote (name)
    139131  #+(and windows-target bogus)
     
    258250
    259251
    260 (defun pathname-host (thing)  ; redefined later in this file
    261   (declare (ignore thing))
    262   :unspecific)
    263 
    264 (defun pathname-version (thing)  ; redefined later in this file
    265   (declare (ignore thing))
    266   nil)
     252(fset 'pathname-host (nfunction bootstrapping-pathname-host   ; redefined later in this file
     253                                (lambda (thing)
     254                                  (declare (ignore thing))
     255                                  :unspecific)))
     256
     257(fset 'pathname-version (nfunction bootstrapping-pathname-version   ; redefined later in this file
     258                                   (lambda (thing)
     259                                     (declare (ignore thing))
     260                                     nil)))
    267261
    268262(defmethod print-object ((pathname pathname) stream)
  • trunk/source/level-1/l1-format.lisp

    r10426 r10942  
    4848(defun pop-format-arg (&aux (args *format-arguments*))
    4949  (if (null args)
    50       (format-error "Missing argument"))
    51     (progn
    52      (setq *format-arguments* (cdr args))
    53      (%car args)))
     50    (format-error "Missing argument"))
     51  (progn
     52    (setq *format-arguments* (cdr args))
     53    (%car args)))
    5454 
    5555;SUB-FORMAT parses (a range of) the control string, finding the directives
     
    292292
    293293;;;This function is shadowed by CCL in order to use ~{ to print error messages.
    294 (defun format (stream control-string &rest format-arguments)
    295   (declare (dynamic-extent format-arguments))
    296   (when (null stream)
    297    (return-from format
    298     (with-output-to-string (x)
    299      (apply #'format x control-string format-arguments))))
    300   (if (eq stream t)
    301     (setq stream *standard-output*)
    302     (unless (streamp stream) (report-bad-arg stream 'stream)))
    303   (if (functionp control-string)
    304     (apply control-string stream format-arguments)
    305     (progn
    306       (setq control-string (ensure-simple-string control-string))
    307       (let* ((*format-original-arguments* format-arguments)
    308              (*format-arguments* format-arguments)
    309              (*format-control-string* control-string))
    310         (catch 'format-escape
    311          (sub-format stream 0 (length control-string)))
    312         nil))))
    313 
    314 (defun format-error (&rest args)
    315    (format t "~&FORMAT error at position ~A in control string ~S "
    316              *format-index* *format-control-string*)
    317    (apply #'error args))
     294(fset 'format
     295      (nlambda bootstrapping-format (stream control-string &rest format-arguments)
     296        (declare (dynamic-extent format-arguments))
     297        (block format
     298          (when (null stream)
     299            (return-from format
     300              (with-output-to-string (x)
     301                (apply #'format x control-string format-arguments))))
     302          (if (eq stream t)
     303            (setq stream *standard-output*)
     304            (unless (streamp stream) (report-bad-arg stream 'stream)))
     305          (if (functionp control-string)
     306            (apply control-string stream format-arguments)
     307            (progn
     308              (setq control-string (ensure-simple-string control-string))
     309              (let* ((*format-original-arguments* format-arguments)
     310                     (*format-arguments* format-arguments)
     311                     (*format-control-string* control-string))
     312                (catch 'format-escape
     313                  (sub-format stream 0 (length control-string)))
     314                nil))))))
     315
     316(fset 'format-error
     317      (nlambda bootstrapping-format-error (&rest args)
     318        (format t "~&FORMAT error at position ~A in control string ~S "
     319                *format-index* *format-control-string*)
     320        (apply #'error args)))
    318321
    319322(defun format-no-flags (colon atsign)
  • trunk/source/level-1/l1-pathnames.lisp

    r10872 r10942  
    435435                    (when (null (cdr dir))
    436436                      (setq dir (car dir))
    437                       (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors)))))
    438     (cond ((eq path wild) t)
    439           ((only-wild wild)
    440            t)
    441           (t (let ((result t))
    442                (block nil
    443                  (while (and path wild)
    444                    (let ((pathstr (car path))
    445                          (wildstr (car wild)))
    446                      (case wildstr
    447                        (:wild (setq wildstr "*"))
    448                        (:wild-inferiors (setq wildstr "**")))
    449                      (case pathstr
    450                        (:wild (setq pathstr "*"))
    451                        (:wild-inferiors (setq pathstr "**")))
    452                      (when (not
    453                             (cond ((string= wildstr "**")
    454                                    (setq result (%pathname-match-dir1 path (cdr wild)))
    455                                    (return-from nil))
    456                                   ((%path-str*= pathstr wildstr))))
    457                        (setq result nil)
    458                        (return-from nil))
    459                      (setq wild (cdr wild) path (cdr path))))
    460                  (when (and (or path wild)(not (only-wild wild)))
    461                    (setq result nil)))
    462                result)))))
    463 
    464 (defun %pathname-match-dir0 (path wild)
    465   (flet ((only-wild (dir)
    466                     (when (null (cdr dir))
    467                       (setq dir (car dir))
    468437                      (when (consp dir) (setq dir (cadr dir)))
    469438                      (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors)))))
  • trunk/source/level-1/l1-readloop.lisp

    r10426 r10942  
    404404    lambda-expression))
    405405
     406
     407(defun %cons-def-info (type &optional lfbits keyvect lambda specializers qualifiers)
     408  (ecase type
     409    (defun nil)
     410    (defmacro (setq lambda '(macro) lfbits nil)) ;; some code assumes lfbits=nil
     411    (defgeneric (setq lambda (list :methods)))
     412    (defmethod (setq lambda (list :methods (cons qualifiers specializers)))))
     413  (vector lfbits keyvect *loading-file-source-file* lambda))
     414
     415(defun def-info.lfbits (def-info)
     416  (and def-info (svref def-info 0)))
     417
     418(defun def-info.keyvect (def-info)
     419  (and def-info (svref def-info 1)))
     420
     421(defun def-info.file (def-info)
     422  (and def-info (svref def-info 2)))
     423
     424(defun def-info.lambda (def-info)
     425  (let ((data (and def-info (svref def-info 3))))
     426    (and (eq (car data) 'lambda) data)))
     427
     428(defun def-info.methods (def-info)
     429  (let ((data (and def-info (svref def-info 3))))
     430    (and (eq (car data) :methods) (%cdr data))))
     431
     432(defun def-info-with-new-methods (def-info new-methods)
     433  (unless (eq (def-info.type def-info) 'defgeneric) (error "Bug: not method info: ~s" def-info))
     434  (if (eq new-methods (def-info.methods def-info))
     435    def-info
     436    (let ((new (copy-seq def-info)))
     437      (setf (svref new 3) (cons :methods new-methods))
     438      new)))
     439
     440(defun def-info.macro-p (def-info)
     441  (let ((data (and def-info (svref def-info 2))))
     442    (eq (car data) 'macro)))
     443
     444(defun def-info.type (def-info)
     445  (if (null def-info) nil  ;; means FTYPE decl or lap function
     446    (let ((data (svref def-info 3)))
     447      (ecase (car data)
     448        ((nil lambda) 'defun)
     449        (:methods 'defgeneric)
     450        (macro 'defmacro)))))
     451
     452(defparameter *one-arg-defun-def-info* (%cons-def-info 'defun (encode-lambda-list '(x))))
     453
     454(defvar *compiler-warn-on-duplicate-definitions* t)
     455
     456(defun combine-function-infos (name old-info new-info)
     457  (let ((old-type (def-info.type old-info))
     458        (new-type (def-info.type new-info)))
     459    (cond ((and (eq old-type 'defgeneric) (eq new-type 'defgeneric))
     460           ;; TODO: Check compatibility of lfbits...
     461           ;; TODO: check that all methods implement defgeneric keys
     462           (let ((old-methods (def-info.methods old-info))
     463                 (new-methods (def-info.methods new-info)))
     464             (loop for new-method in new-methods
     465                   do (if (member new-method old-methods :test #'equal)
     466                        (when *compiler-warn-on-duplicate-definitions*
     467                          (nx1-whine :duplicate-definition
     468                                     `(method ,@(car new-method) ,name ,(cdr new-method))
     469                                     (def-info.file old-info)
     470                                     (def-info.file new-info)))
     471                        (push new-method old-methods)))
     472             (def-info-with-new-methods old-info old-methods)))
     473          ((or (eq (or old-type 'defun) (or new-type 'defun))
     474               (eq (or old-type 'defgeneric) (or new-type 'defgeneric)))
     475           (when (and old-type new-type *compiler-warn-on-duplicate-definitions*)
     476             (nx1-whine :duplicate-definition name (def-info.file old-info) (def-info.file new-info)))
     477           (or new-info old-info))
     478          (t
     479           (when *compiler-warn-on-duplicate-definitions*
     480             (apply #'nx1-whine :duplicate-definition
     481                    name
     482                    (def-info.file old-info)
     483                    (def-info.file new-info)
     484                    (cond ((eq old-type 'defmacro) '("macro" "function"))
     485                          ((eq new-type 'defmacro) '("function" "macro"))
     486                          ((eq old-type 'defgeneric) '("generic function" "function"))
     487                          (t '("function" "generic function")))))
     488           new-info))))
     489
     490(defun record-function-info (name info env)
     491  (let* ((definition-env (definition-environment env)))
     492    (if definition-env
     493      (let* ((defs (defenv.defined definition-env))
     494             (already (if (listp defs) (assq name defs) (gethash name defs))))
     495        (if already
     496          (setf (%cdr already) (combine-function-infos name (%cdr already) info))
     497          (let ((new (cons name info)))
     498            (if (listp defs)
     499              (setf (defenv.defined definition-env) (cons new defs))
     500              (setf (gethash name defs) new))))
     501        info))))
     502
     503
    406504;;; This is different from AUGMENT-ENVIRONMENT.
    407 ;;; If "info" is a lambda expression, then
    408 ;;;  record a cons whose CAR is (encoded-lfun-bits . keyvect) and whose cdr
    409 ;;;  is the lambda expression iff the function named by "name" is
    410 ;;;  declared/proclaimed INLINE in env
    411505(defun note-function-info (name lambda-expression env)
    412506  (let* ((info nil)
     
    414508    (when (lambda-expression-p lambda-expression)
    415509      (multiple-value-bind (lfbits keyvect) (encode-lambda-list (cadr lambda-expression) t)
    416         (setq info (cons (cons lfbits keyvect)
    417                          (retain-lambda-expression name lambda-expression env)))))
     510        (setq info (%cons-def-info 'defun lfbits keyvect
     511                                   (retain-lambda-expression name lambda-expression env)))))
    418512    (record-function-info name info env))
    419513  name)
     
    422516(defun retrieve-environment-function-info (name env)
    423517 (let ((defenv (definition-environment env)))
    424    (if defenv (assq (maybe-setf-function-name name) (defenv.defined defenv)))))
     518   (when defenv
     519     (let ((defs (defenv.defined defenv))
     520           (sym (maybe-setf-function-name name)))
     521       (if (listp defs) (assq sym defs) (gethash sym defs))))))
    425522
    426523(defun maybe-setf-function-name (name)
  • trunk/source/level-1/l1-streams.lisp

    r10822 r10942  
    43054305  (%string-push-extend char (string-stream-ioblock-string ioblock)))
    43064306
    4307 (defmethod stream-force-output ((stream string-output-stream)) nil)
    4308 
    43094307(defun fill-pointer-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
    43104308  (let* ((end (+ start-char num-chars))
  • trunk/source/level-1/l1-typesys.lisp

    r10818 r10942  
    34463446                                     '(args-ctype values-ctype function-ctype))))
    34473447
    3448 (defun function-ctype-p (x) (istruct-typep x 'function-ctype))
    34493448(defun valuec-ctype-p (x) (istruct-typep x 'values-ctype))
    34503449
  • trunk/source/level-1/l1-utils.lisp

    r10712 r10942  
    9292;;; to avoid clutter - done
    9393
    94 (defun physical-pathname-p (file)(declare (ignore file)) nil) ; redefined later
     94(fset 'physical-pathname-p (lambda (file)(declare (ignore file)) nil)) ; redefined later
    9595
    9696
    9797;(%defvar *enqueued-window-title* nil)
    9898
    99 (defun booted-probe-file (file)
    100   (declare (ignore file))
    101   nil)
     99(fset 'booted-probe-file (lambda (file) (declare (ignore file)) nil))
    102100
    103101(queue-fixup
  • trunk/source/level-1/sysutils.lisp

    r10937 r10942  
    528528(defparameter *outstanding-deferred-warnings* nil)
    529529
    530 
    531 (defun %defer-warnings (override &optional flags)
    532   (%istruct 'deferred-warnings (unless override *outstanding-deferred-warnings*) nil nil flags))
     530(defun call-with-compilation-unit (thunk &key override)
     531  (let* ((*outstanding-deferred-warnings* (%defer-warnings override)))
     532    (multiple-value-prog1 (funcall thunk)
     533      (report-deferred-warnings))))
     534
     535(defun %defer-warnings (override &optional flags &aux (parent *outstanding-deferred-warnings*))
     536  (%istruct 'deferred-warnings
     537            (unless override parent)
     538            nil
     539            (if (or override (not parent))
     540              (make-hash-table :test #'eq)
     541              (deferred-warnings.defs parent))
     542            flags))
    533543
    534544(defun report-deferred-warnings ()
    535545  (let* ((current *outstanding-deferred-warnings*)
    536546         (parent (deferred-warnings.parent current))
    537          (defs (deferred-warnings.defs current))
    538547         (warnings (deferred-warnings.warnings current))
    539548         (any nil)
     
    541550    (if parent
    542551      (setf (deferred-warnings.warnings parent) (append warnings (deferred-warnings.warnings parent))
    543             (deferred-warnings.defs parent) (append defs (deferred-warnings.defs parent))
    544552            parent t)
    545553      (let* ((file nil)
     554             (defs (deferred-warnings.defs current))
    546555             (init t))
    547556        (flet ((signal-warning (w)
     
    553562                   (def nil))
    554563              (when (if (typep w 'undefined-function-reference)
    555                       (not (setq def (or (assq wfname defs)
     564                      (not (setq def (or (gethash wfname defs)
    556565                                         (let* ((global (fboundp wfname)))
    557566                                           (if (typep global 'function)
     
    561570              (if (or (typep def 'function)
    562571                      (and (consp def)
    563                            (consp (cdr def))
    564                            (consp (cadr def))
    565                            (caadr def)))
     572                           (def-info.lfbits (cdr def))))
    566573                (when (cdr args)
    567574                  (destructuring-bind (arglist spread-p)
     
    579586                                (compiler-warning-stream-position w))
    580587                          (signal-warning w2))))))
    581                 (if (or (and (consp def)
    582                              (consp (cdr def))
    583                              (consp (cadr def))
    584                              (eq (cdadr def) 'macro))
    585                         (typep def 'simple-vector))
     588                (if (def-info.macro-p (cdr def))
    586589                  (let* ((w2 (make-condition
    587590                              'macro-used-before-definition
  • trunk/source/level-1/x86-trap-support.lisp

    r10898 r10942  
    275275(defun (setf indexed-gpr-macptr) (new xp igpr)
    276276  (setf (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))) new))
    277 (defun indexed-gpr-macptr (xp igpr)
    278   (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))))
    279277(defun encoded-gpr-macptr (xp gpr)
    280278  (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
  • trunk/source/lib/arrays-fry.lisp

    r2325 r10942  
    217217         vector)
    218218        (t (subseq vector 0 to-size))))
    219 
    220219
    221220
  • trunk/source/lib/ccl-export-syms.lisp

    r10221 r10942  
    102102     unignore
    103103     *warn-if-redefine-kernel*
     104     without-duplicate-definition-warnings
    104105     require-type
    105106     dovector
  • trunk/source/lib/compile-ccl.lisp

    r10899 r10942  
    310310
    311311(defun compile-ccl (&optional force-compile)
     312 (with-compilation-unit ()
    312313  (update-modules 'nxenv force-compile)
    313314  (update-modules *compiler-modules* force-compile)
     
    323324    (require-modules other-lib)
    324325    (require-update-modules *code-modules* force-compile))
    325   (compile-modules *aux-modules* force-compile))
     326  (compile-modules *aux-modules* force-compile)))
    326327
    327328
     
    353354
    354355(defun xcompile-ccl (&optional force)
     356 (with-compilation-unit ()
    355357  (compile-modules 'nxenv force)
    356358  (compile-modules *compiler-modules* force)
     
    362364  (compile-modules (target-other-lib-modules) force)
    363365  (compile-modules *code-modules* force)
    364   (compile-modules *aux-modules* force))
     366  (compile-modules *aux-modules* force)))
    365367
    366368(defun require-update-modules (modules &optional force-compile)
     
    371373    (update-modules module force-compile))))
    372374
    373 (defun compile-level-1 (&optional force-compile)
    374   (compile-modules (target-level-1-modules (backend-name *host-backend*))
    375                    force-compile))
    376 
    377 
    378 
    379  
    380375
    381376(defun target-xcompile-ccl (target &optional force)
  • trunk/source/lib/defstruct-lds.lisp

    r10421 r10942  
    244244     `(progn
    245245       (remove-structure-defs  ',struct-name) ; lose any previous defs
    246         ,(defstruct-slot-defs sd refnames env)
     246        ,.(defstruct-slot-defs sd refnames env)
    247247        ,.(if constructor (list (defstruct-constructor sd constructor)))
    248248        ,.(defstruct-boa-constructors sd boa-constructors)
    249         ,.(if copier (list (defstruct-copier sd copier env)))
    250         ,.(if predicate (defstruct-predicate sd named predicate))
     249        ,.(if copier (defstruct-copier sd copier env))
     250        ,.(if predicate (defstruct-predicate sd named predicate env))
    251251        (eval-when (:compile-toplevel)
    252252          (define-compile-time-structure
     
    259259         ,(if (and predicate (null (sd-type sd))) `',predicate)
    260260         ,.(if documentation (list documentation)))
    261         ,(%defstruct-compile sd refnames)
     261        ,.(%defstruct-compile sd refnames env)
    262262       ;; Wait until slot accessors are defined, to avoid
    263263       ;; undefined function warnings in the print function/method.
     
    381381
    382382(defun defstruct-copier (sd copier env)
    383   `(progn
    384      (eval-when (:compile-toplevel)
    385        (record-function-info ',copier (list (list (encode-lambda-list '(x)))) ,env))
    386      (fset ',copier
    387            ,(if (eq (sd-type sd) 'list) '#'copy-list '#'copy-uvector))
    388      (record-source-file ',copier 'function)))
    389 ; (put 'COPY-SHIP 'nx-alias 'copy-list)
    390 
    391 (defun defstruct-predicate (sd named predicate &aux (arg (gensym)))
    392   (let* ((sd-name (sd-name sd))
     383  `((eval-when (:compile-toplevel)
     384      (record-function-info ',copier ',*one-arg-defun-def-info* ,env))
     385    (fset ',copier
     386          ,(if (eq (sd-type sd) 'list) '#'copy-list '#'copy-uvector))
     387    (record-source-file ',copier 'function)))
     388
     389(defun defstruct-predicate (sd named predicate env)
     390  (declare (ignore env))
     391  (let* ((arg (gensym))
     392         (sd-name (sd-name sd))
    393393         (body
    394394          (case (sd-type sd)
     
    398398               (< ,named (uvsize ,arg))
    399399               (eq (uvref ,arg ,named) ',sd-name))))))
    400     `((setf (symbol-function ',predicate) #'(lambda (,arg) ,body))
    401       (record-source-file ',predicate 'function))))
     400    `((defun ,predicate (,arg) ,body))))
    402401
    403402; End of defstruct-lds.lisp
  • trunk/source/lib/defstruct.lisp

    r10409 r10942  
    2121(eval-when (eval compile)
    2222  (require 'defstruct-macros)
     23
    2324)
    2425
    25 
     26#-BOOTSTRAPPED
     27(unless (boundp '*one-arg-defun-def-info*)
     28  (setq *one-arg-defun-def-info* nil))
    2629
    2730(defvar %structure-refs% (make-hash-table :test #'eq))
     
    130133
    131134;;; return stuff for defstruct to compile
    132 (defun %defstruct-compile (sd refnames)
     135(defun %defstruct-compile (sd refnames env)
    133136  (let ((stuff))   
    134137    (dolist (slot (sd-slots sd))
     
    142145                (warn "Accessor ~s at different position than in included structure"
    143146                      accessor)))
    144             (let ((fn (slot-accessor-fn slot accessor)))
     147            (let ((fn (slot-accessor-fn slot accessor env)))
    145148              (push
    146149               `(progn
    147                   ,fn
     150                  ,.fn
    148151                  (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot)))
    149152               stuff))))))
    150     `(progn ,@(nreverse stuff))))
     153    (nreverse stuff)))
    151154
    152155
     
    183186;;; the same.
    184187
    185 (defparameter *defstruct-share-accessor-functions* t)
    186 
    187 (defun slot-accessor-fn (slot name &aux (ref (ssd-reftype slot))
    188                               (offset (ssd-offset slot)))
    189     (cond ((eq ref $defstruct-nth)
    190            (if (and  (%i< offset 10) *defstruct-share-accessor-functions*)
    191              `(fset ',name
     188
     189(defparameter *defstruct-share-accessor-functions* t)   ;; TODO: isn't it time to get rid of this?
     190
     191(defun slot-accessor-fn (slot name env &aux (ref (ssd-reftype slot)) (offset (ssd-offset slot)))
     192  (cond ((eq ref $defstruct-nth)
     193         (if (and  (%i< offset 10) *defstruct-share-accessor-functions*)
     194           `((eval-when (:compile-toplevel)
     195               (record-function-info ',name ',*one-arg-defun-def-info* ,env))
     196              (fset ',name
    192197                    ,(symbol-function
    193198                      (%svref '#(first second third fourth fifth
    194                                        sixth seventh eighth ninth tenth) offset)))
    195              `(defun ,name (x)  (nth ,offset x))))
    196           ((eq ref $defstruct-struct)
    197            (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
    198              `(fset ',name , (%svref *struct-ref-vector* offset))
    199              `(defun ,name (x)  (struct-ref x ,offset))))
    200           ((or (eq ref target::subtag-simple-vector)
    201                (eq ref $defstruct-simple-vector))
    202            (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
    203              `(fset ',name ,(%svref *svref-vector* offset))
    204              `(defun ,name (x)  (svref x ,offset))))
    205           (t `(defun ,name (x) (uvref x ,offset)))))
     199                                 sixth seventh eighth ninth tenth) offset))))
     200           `((defun ,name (x)  (nth ,offset x)))))
     201        ((eq ref $defstruct-struct)
     202         (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
     203           `((eval-when (:compile-toplevel)
     204               (record-function-info ',name ',*one-arg-defun-def-info* ,env))               
     205             (fset ',name , (%svref *struct-ref-vector* offset)))
     206           `((defun ,name (x)  (struct-ref x ,offset)))))
     207        ((or (eq ref target::subtag-simple-vector)
     208             (eq ref $defstruct-simple-vector))
     209         (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
     210           `((eval-when (:compile-toplevel)
     211               (record-function-info ',name ',*one-arg-defun-def-info* ,env))
     212             (fset ',name ,(%svref *svref-vector* offset)))
     213           `((defun ,name (x)  (svref x ,offset)))))
     214        (t `((defun ,name (x) (uvref x ,offset))))))
    206215
    207216(defun defstruct-reftype (type)
     
    211220
    212221(defun defstruct-slot-defs (sd refnames env)
     222  (declare (ignore env))
    213223  (let ((ref (defstruct-reftype (sd-type sd))) name defs)
    214224    (dolist (slot (sd-slots sd))
     
    219229          (push name defs))))
    220230    (setq defs (nreverse defs))
    221     (let* ((info (list (cons (dpb 1 $lfbits-numreq 0) nil))))
    222       `(progn
    223         (eval-when (:compile-toplevel)
    224           ,@(mapcar #'(lambda (name) `(record-function-info ',name ',info ,env)) defs))
    225         (declaim (inline ,@defs))))))
     231    `((declaim (inline ,@defs)))))
    226232
    227233;;;Used by setf and whatever...
  • trunk/source/lib/format.lisp

    r10431 r10942  
    391391; in l1-format
    392392(defvar *logical-block-xp* nil)
    393 (defun pop-format-arg (&aux (args *format-arguments*)(xp *logical-block-xp*))
    394   (when xp
    395     (if (pprint-pop-check+ args xp) ; gets us level and length stuff in logical block
    396       (throw 'logical-block nil)))           
    397   (if (and (null args)(null xp)) ; what if its 3?
    398       (format-error "Missing argument")
    399     (progn
    400      (setq *format-arguments* (cdr args))
    401      (%car args))))
     393
     394(without-duplicate-definition-warnings
     395 (defun pop-format-arg (&aux (args *format-arguments*)(xp *logical-block-xp*))
     396   (when xp
     397     (if (pprint-pop-check+ args xp)    ; gets us level and length stuff in logical block
     398       (throw 'logical-block nil)))           
     399   (if (and (null args)(null xp))       ; what if its 3?
     400     (format-error "Missing argument")
     401     (progn
     402       (setq *format-arguments* (cdr args))
     403       (%car args)))))
    402404
    403405; SUB-FORMAT is now defined in L1-format.lisp
  • trunk/source/lib/macros.lisp

    r10828 r10942  
    625625      (%define-symbol-macro ',name ',expansion))))
    626626
    627 (defun record-function-info (name info env)
    628   (let* ((definition-env (definition-environment env)))
    629     (if definition-env
    630       (let* ((already (assq name (defenv.defined definition-env))))
    631         (if already
    632           (if info (%rplacd already info))
    633           (push (cons name info) (defenv.defined definition-env)))
    634         info))))
    635 
    636627;; ---- allow inlining setf functions
    637628(defmacro defun (spec args &body body &environment env &aux global-name inline-spec)
     
    662653                   doc)))
    663654      `(progn
    664          (eval-when (:compile-toplevel)
    665            (note-function-info ',spec ',lambda-expression ,env))
    666655         (%defun (nfunction ,spec ,lambda-expression) ',info)
    667656         ',spec))))
     
    746735    `(let* ((,temp (function-to-function-vector ,f)))
    747736      (%svref ,temp (the fixnum (1- (the fixnum (uvsize ,temp))))))))
    748 
    749 ; %Pascal-Functions% Entry
    750 ; Used by "l1;ppc-callback-support" & "lib;dumplisp"
    751 (def-accessor-macros %svref
    752   pfe.routine-descriptor
    753   pfe.proc-info
    754   pfe.lisp-function
    755   pfe.sym
    756   pfe.without-interrupts
    757   pfe.trace-p)
    758737
    759738(defmacro cond (&rest args &aux clause)
     
    951930  `(function (lambda ,paramlist ,@body)))
    952931
     932; This isn't
     933(defmacro nlambda (name (&rest arglist) &body body)
     934  `(nfunction ,name (lambda ,arglist ,@body)))
    953935
    954936(defmacro when (test &body body)
     
    14581440        OVERRIDE true causes that form to grab any enclosed warnings, even if
    14591441        it is enclosed by another WITH-COMPILATION-UNIT."
    1460   `(let* ((*outstanding-deferred-warnings* (%defer-warnings ,override)))
    1461      (multiple-value-prog1 (progn ,@body) (report-deferred-warnings))))
     1442  `(flet ((with-compilation-unit-body ()
     1443            ,@body))
     1444     (declare (dynamic-extent #'with-compilation-unit-body))
     1445     (call-with-compilation-unit #'with-compilation-unit-body :override ,override)))
    14621446
    14631447; Yow! Another Done Fun.
     
    17371721       (eval-when (:compile-toplevel)
    17381722         (record-function-info ',(maybe-setf-function-name name)
    1739                               ',(list (list (encode-gf-lambda-list
    1740                                              lambda-list)))
    1741                               ,env))
    1742        (compiler-let ((*nx-method-warning-name*
    1743                        (list ',name
    1744                              ,@(mapcar #'(lambda (x) `',x) qualifiers)
    1745                              ',specializers)))
    1746          (ensure-method ',name ,specializers-form
     1723                               ',(%cons-def-info 'defmethod (encode-gf-lambda-list lambda-list) nil nil
     1724                                                 specializers qualifiers)
     1725                               ,env))
     1726       (compiler-let ((*nx-method-warning-name* '(,name ,@qualifiers ,specializers)))
     1727         (ensure-method ',name ,specializers-form
    17471728                        :function ,function-form
    17481729                        :qualifiers ',qualifiers
     
    19121893                      (readers nil)
    19131894                      (writers nil)
    1914                       (reader-info (list (cons (dpb 1 $lfbits-numreq 0) nil)))
    1915                       (writer-info (list (cons (dpb 2 $lfbits-numreq 0) nil))))
     1895                      (reader-info (%cons-def-info 'defmethod (dpb 1 $lfbits-numreq 0) nil nil (list class-name)))
     1896                      (writer-info (%cons-def-info 'defmethod (dpb 2 $lfbits-numreq 0) nil nil (list t class-name))))
    19161897                 (when (memq slot-name slot-names)
    19171898                   (SIGNAL-PROGRAM-error "Multiple slots named ~S in DEFCLASS ~S" slot-name class-name))
     
    20212002        (eval-when (:compile-toplevel)
    20222003          (record-function-info ',(maybe-setf-function-name function-name)
    2023                                  ',(list (list (encode-gf-lambda-list lambda-list)))
     2004                                 ',(%cons-def-info 'defgeneric (encode-gf-lambda-list lambda-list))
    20242005                                 ,env))
    20252006        (let ((,gf (%defgeneric
     
    28472828       (funcall-with-error-reentry-detection ,thunk))))
    28482829
     2830(defmacro without-duplicate-definition-warnings (&body body)
     2831  `(compiler-let ((*compiler-warn-on-duplicate-definitions* nil))
     2832     ,@body))
     2833
     2834
    28492835#+ppc-target
    28502836(defmacro scan-for-instr (mask opcode fn pc-index &optional (tries *trap-lookup-tries*))
  • trunk/source/lib/method-combination.lisp

    r2325 r10942  
    9292
    9393; Need to special case (find-method-combination #'find-method-combination ...)
    94 (defmethod find-method-combination ((generic-function standard-generic-function)
    95                                     method-combination-type
    96                                     method-combination-options)
    97   (%find-method-combination
    98    generic-function method-combination-type method-combination-options))
     94(without-duplicate-definition-warnings ;; override version in l1-clos-boot.lisp
     95 (defmethod find-method-combination ((generic-function standard-generic-function)
     96                                     method-combination-type
     97                                     method-combination-options)
     98   (%find-method-combination
     99    generic-function method-combination-type method-combination-options)))
    99100
    100101(defun %find-method-combination (gf type options)
  • trunk/source/lib/misc.lisp

    r10902 r10942  
    158158  (%get-documentation thing doc-id))
    159159
    160 (defun set-documentation (thing doc-id new)
    161   (setf (documentation thing doc-id) new))
    162 
    163160(defmethod (setf documentation) (new thing doc-id)
    164161  (%put-documentation thing doc-id new))
  • trunk/source/lib/nfcomp.lisp

    r10732 r10942  
    146146                            :report (lambda (stream) (format stream "Skip compiling ~s" src))
    147147                            (return))))))
     148
     149(defvar *fasl-compile-time-env* nil)
    148150
    149151(defun %compile-file (src output-file verbose print load features
     
    200202             (defenv (new-definition-environment))
    201203             (lexenv (new-lexical-environment defenv))
     204             (*fasl-compile-time-env* (new-lexical-environment (new-definition-environment)))
    202205             (*fcomp-external-format* external-format))
    203206        (let ((forms nil))
    204207          (let* ((*outstanding-deferred-warnings* (%defer-warnings nil)))
    205208            (rplacd (defenv.type defenv) *outstanding-deferred-warnings*)
     209            (setf (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*))
     210
    206211            (setq forms (fcomp-file src orig-src lexenv))
     212
    207213            (setf (deferred-warnings.warnings *outstanding-deferred-warnings*)
    208                   (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*))
    209                   (deferred-warnings.defs *outstanding-deferred-warnings*)
    210                   (append (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*)))
     214                  (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*)))
    211215            (when *compile-verbose* (fresh-line))
    212216            (multiple-value-bind (any harsh) (report-deferred-warnings)
     
    257261
    258262(defun %compile-time-eval (form env)
     263  (declare (ignore env))
    259264  (let* ((*target-backend* *host-backend*))
    260265    ;; The HANDLER-BIND here is supposed to note WARNINGs that're
     
    272277      (funcall (compile-named-function
    273278                `(lambda () ,form)
    274                 :env env :policy *compile-time-evaluation-policy*)))))
     279                :env *fasl-compile-time-env*
     280                :policy *compile-time-evaluation-policy*)))))
    275281
    276282
     
    428434      (let* ((*fcomp-previous-position* nil))
    429435        (loop
    430           (let* ((*fcomp-stream-position* (file-position stream)))
     436          (let* ((*fcomp-stream-position* (file-position stream))
     437                 (*nx-warnings* nil))
    431438            (unless (eq read-package *package*)
    432439              (fcomp-compile-toplevel-forms env)
     
    443450            (when (eq eofval form) (return))
    444451            (fcomp-form form env processing-mode)
     452            (fcomp-signal-or-defer-warnings *nx-warnings* env)
    445453            (setq *fcomp-previous-position* *fcomp-stream-position*))))
    446454      (while (setq form *fasl-eof-forms*)
     
    625633(defun define-compile-time-constant (symbol initform env)
    626634  (note-variable-info symbol t env)
    627   (let ((definition-env (definition-environment env)))
    628     (when definition-env
     635  (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*))
     636        (definition-env (definition-environment env)))
     637    (when (or compile-time-defenv definition-env)
    629638      (multiple-value-bind (value error)
    630639                           (ignore-errors (values (%compile-time-eval initform env) nil))
     
    632641          (warn "Compile-time evaluation of DEFCONSTANT initial value form for ~S while ~
    633642                 compiling ~S signalled the error: ~&~A" symbol *fasl-source-file* error))
    634         (push (cons symbol (if error (%unbound-marker-8) value)) (defenv.constants definition-env))))
     643        (let ((cell (cons symbol (if error (%unbound-marker-8) value))))
     644          (when definition-env
     645            (push cell (defenv.constants definition-env)))
     646          (when compile-time-defenv
     647            (push cell (defenv.constants compile-time-defenv))))))
    635648    symbol))
    636649
     
    678691
    679692(defun define-compile-time-macro (name lambda-expression env)
    680   (let ((definition-env (definition-environment env)))
    681     (when definition-env
    682       (push (list* name
    683                    'macro
    684                    (compile-named-function lambda-expression :name name :env env))
    685             (defenv.functions definition-env))
    686       (record-function-info name (list (cons nil 'macro)) env))
     693  (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*))
     694        (definition-env (definition-environment env)))
     695    (when (or definition-env compile-time-defenv)
     696      (let ((cell (list* name
     697                         'macro
     698                         (compile-named-function lambda-expression :name name :env env))))
     699        (when compile-time-defenv
     700          (push cell (defenv.functions compile-time-defenv)))
     701        (when definition-env
     702          (push cell (defenv.functions definition-env))))
     703      (record-function-info name (%cons-def-info 'defmacro) env))
    687704    name))
    688705
    689706(defun define-compile-time-symbol-macro (name expansion env)
    690   (let* ((definition-env (definition-environment env)))
    691     (if definition-env
    692       (push (cons name expansion) (defenv.symbol-macros definition-env)))
     707  (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*))
     708        (definition-env (definition-environment env)))
     709    (when (or definition-env compile-time-defenv)
     710      (let ((cell (cons name expansion)))
     711        (when compile-time-defenv
     712          (push cell (defenv.functions compile-time-defenv)))
     713        (when definition-env
     714          (push cell (defenv.functions definition-env)))))
    693715    name))
    694716
     
    758780          (setf (car (cadr doc)) nil))
    759781        (setq doc nil)))
     782    (when (and (consp fn) (eq (%car fn) 'nfunction))
     783      (note-function-info (cadr fn) (caddr fn) env))
    760784    (if (and (constantp doc)
    761785             (setq fn (fcomp-function-arg fn env)))
  • trunk/source/lib/pprint.lisp

    r10214 r10942  
    12781278
    12791279
    1280 (defun pprint (object &optional (stream *standard-output*))
    1281   "Prettily output OBJECT preceded by a newline."
    1282   (setq stream (decode-stream-arg stream))
    1283   (terpri stream)
    1284   (let ((*print-escape* T) (*print-pretty* T))
    1285     (write-1 object stream))
    1286   (values))
     1280(without-duplicate-definition-warnings  ;; override l1-io version.
     1281 (defun pprint (object &optional (stream *standard-output*))
     1282   "Prettily output OBJECT preceded by a newline."
     1283   (setq stream (decode-stream-arg stream))
     1284   (terpri stream)
     1285   (let ((*print-escape* T) (*print-pretty* T))
     1286     (write-1 object stream))
     1287   (values)))
    12871288
    12881289
  • trunk/source/lib/sequences.lisp

    r10121 r10942  
    995995    temp))
    996996
    997 ;;; Modified to clear the elements between the old and new fill pointers
    998 ;;; so they won't hold on to garbage.
    999 (defun vector-delete (item vector test test-not key start end inc count
    1000                            &aux (length (length vector)) pos fill val)
    1001   (setq key (adjust-key key))
    1002   (multiple-value-setq (test test-not) (adjust-test-args item test test-not))
    1003   (setq end (check-sequence-bounds vector start end))
    1004   (if (%i< inc 0) (psetq start (%i- end 1) end (%i- start 1)))
    1005   (setq fill (setq pos start))
    1006   (loop
    1007     (if (or (eq count 0) (eq pos end)) (return))
    1008     (if (matchp2 item (setq val (aref vector pos)) test test-not key)
    1009       (setq count (%i- count 1))
    1010       (progn
    1011         (if (neq fill pos) (setf (aref vector fill) val))
    1012         (setq fill (%i+ fill inc))))
    1013     (setq pos (%i+ pos inc)))
    1014   (if (%i> fill pos) (psetq fill (%i+ pos 1) pos (%i+ fill 1)))
    1015   (loop
    1016     (if (eq pos length) (return))
    1017     (setf (aref vector fill) (aref vector pos))
    1018     (setq fill (%i+ fill 1) pos (%i+ pos 1)))
    1019   (when (gvectorp (array-data-and-offset vector))
    1020     (let ((old-fill (fill-pointer vector))
    1021           (i fill))
    1022       (declare (fixnum i old-fill))
    1023       (loop
    1024         (when (>= i old-fill) (return))
    1025         (setf (aref vector i) nil)
    1026         (incf i))))
    1027   (setf (fill-pointer vector) fill)
    1028   vector)
    1029 
    1030 
    1031997; The vector will be freshly consed & nothing is displaced to it,
    1032998; so it's legit to destructively truncate it.
  • trunk/source/library/lispequ.lisp

    r10731 r10942  
    272272(def-accessors (logical-pathname) %svref
    273273  ()                                    ; 'logical-pathname
    274   %pathname-directory
    275   %pathname-name
    276   %pathname-type 
     274  nil                                   ; %pathname-directory
     275  nil                                   ; %pathname-name
     276  nil                                   ; %pathname-type 
    277277  %logical-pathname-host
    278278  %logical-pathname-version)
     
    14051405  )
    14061406
     1407;;; MacOS toolbox routines were once written mostly in Pascal, so some
     1408;;; code still refers to callbacks from foreign code as "pascal-callable
     1409;;; functions".
     1410
     1411; %Pascal-Functions% Entry
     1412(def-accessor-macros %svref
     1413  pfe.routine-descriptor
     1414  pfe.proc-info
     1415  pfe.lisp-function
     1416  pfe.sym
     1417  pfe.without-interrupts
     1418  pfe.trace-p)
     1419
     1420(defmacro %cons-pfe (routine-descriptor proc-info lisp-function sym without-interrupts)
     1421  `(vector ,routine-descriptor ,proc-info ,lisp-function ,sym ,without-interrupts nil))
     1422
     1423
    14071424(def-accessors %svref
    14081425    ()                                  ; 'xp-structure
Note: See TracChangeset for help on using the changeset viewer.