Changeset 10938


Ignore:
Timestamp:
Oct 2, 2008, 3:17:40 AM (11 years ago)
Author:
gz
Message:

Extend the mechanism used for keeping track of definitions (previously used only for inlining and undefined function warnings) to make it work across compilation units rather than just per file and make it also keep track of method definitions. Make it use a hash table since now the set of definitions can get quite large. Use it to detect and issue warnings about duplicate function or method definitions inside a compilation unit.

One side-effect of above changes is that compile-time inlining information is kept across the whole compilation unit rather than being per-file only.

Fixes in defstruct, to make sure predicate def gets noted, and to make accessor defs only get noted once.

Add (and export) a new CCL:WITHOUT-DUPLICATE-DEFINITION-WARNINGS macro that can be wrapped around intentional duplicate definitions to avoid the warning.

New NLAMBDA macro, which is to LAMBDA as NFUNCTION is to FUNCTION. Not exported.

Wrap with-compilation-unit around compile-ccl and xcompile-ccl.

Remove a half-dozen or so unintentional duplicate definitions in ccl, and work around the intentional ones by either using fset instead of defun at the first definition or wrapping the second one in without-duplicate-definition-warnings.

In file compiler, do not use the file's lexical environment for compile-time evaluation!

Make report-compiler-warning show the file position, when known, for warnings in anonymous lambdas.

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

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/X86/x86-lap.lisp

    r9620 r10938  
    299299
    300300
    301 (defstruct (frag-list (:include ccl::dll-header)))
     301(defstruct (frag-list (:include ccl::dll-header) (:constructor nil)))
    302302
    303303;;; ccl::dll-header-last is unit-time
  • branches/working-0711/ccl/compiler/X86/x862.lisp

    r10009 r10938  
    28532853
    28542854 
    2855 (defun x862-long-constant-p (form)
    2856   (setq form (acode-unwrapped-form-value form))
    2857   (or (acode-fixnum-form-p form)
    2858       (and (acode-p form)
    2859            (eq (acode-operator form) (%nx1-operator immediate))
    2860            (setq form (%cadr form))
    2861            (if (integerp form)
    2862              form))))
    2863 
    2864 
    28652855(defun x86-side-effect-free-form-p (form)
    28662856  (when (consp (setq form (acode-unwrapped-form-value form)))
  • branches/working-0711/ccl/compiler/nx-basic.lisp

    r9911 r10938  
    510510    (:lambda . "Suspicious lambda-list: ~s")
    511511    (:result-ignored . "Function result ignored in call to ~s")
     512    (:duplicate-definition . report-compile-time-duplicate-definition)
    512513    (:program-error . "~a")))
    513514
     515(defun report-compile-time-duplicate-definition (condition stream)
     516  (destructuring-bind (name old-file new-file &optional from to) (compiler-warning-args condition)
     517    (format stream
     518            "Duplicate definitions of ~s~:[~*~;~:* (as a ~a and a ~a)~]~:[~;, in this file~:[~; and in ~s~]~]"
     519            name from to
     520            (and old-file new-file)
     521            (and old-file new-file)
     522            old-file)))
    514523
    515524(defun report-compiler-warning (condition stream)
    516525  (let* ((warning-type (compiler-warning-warning-type condition))
    517          (format-string (cdr (assq warning-type *compiler-warning-formats*))))
     526         (format-string (cdr (assq warning-type *compiler-warning-formats*)))
     527         (name (reverse (compiler-warning-function-name condition))))
    518528    (format stream "In ")
    519     (print-nested-name (reverse (compiler-warning-function-name condition)) stream)
     529    (print-nested-name name stream)
     530    (when (every #'null name)
     531      (let ((position (compiler-warning-stream-position condition)))
     532        (when position (format stream " at position ~s" position))))
    520533    (format stream ": ")
    521534    (if (typep format-string 'string)
  • branches/working-0711/ccl/compiler/nx0.lisp

    r10244 r10938  
    11031103                       containing-env (afunc-environment afunc)
    11041104                       lambda-form (afunc-lambdaform afunc)))
    1105         (let* ((defenv (definition-environment env)))
    1106           (if (cdr (setq info (if defenv (cdr (assq sym (defenv.defined defenv))))))
    1107             (setq lambda-form (cdr info)
     1105        (setq info (cdr (retrieve-environment-function-info sym env)))
     1106        (if (def-info.lambda info)
     1107            (setq lambda-form (def-info.lambda info)
    11081108                  token sym
    1109                   containing-env (new-lexical-environment defenv))
     1109                  containing-env (new-lexical-environment (definition-environment env)))
    11101110            (unless info
    11111111              (if (cdr (setq info (assq sym *nx-globally-inline*)))
    11121112                (setq lambda-form (%cdr info)
    11131113                      token sym
    1114                       containing-env (new-lexical-environment (new-definition-environment nil)))))))))
     1114                      containing-env (new-lexical-environment (new-definition-environment nil))))))))
    11151115    (values lambda-form (nx-closed-environment env containing-env) token)))
    11161116
     
    21292129                         (case deftype
    21302130                           (:global-mismatch (innermost-lfun-bits-keyvect def))
    2131                            (:environment-mismatch (values (caadr def) (cdadr def)))
     2131                           (:environment-mismatch
     2132                              (values (def-info.lfbits (cdr def)) (def-info.keyvect (cdr def))))
    21322133                           (t (let* ((lambda-form (afunc-lambdaform def)))
    21332134                                (if (lambda-expression-p lambda-form)
    21342135                                  (encode-lambda-list (cadr lambda-form))))))
    21352136      (when bits
    2136         (unless (typep bits 'fixnum) (bug "Bad bits!"))
     2137        (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
    21372138        (let* ((nargs (length arglist))
    21382139               (minargs (if spread-p (1- nargs) nargs))
  • branches/working-0711/ccl/compiler/nxenv.lisp

    r9629 r10938  
    2929#+x8664-target (require "X8664ENV")
    3030
    31 #-BOOTSTRAPPED (unless (boundp '$lfbits-info-bit) (set '$lfbits-info-bit 2))
    32 
    33 
    34 
    35 ;
    36 
     31
     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)))
    3739
    3840
  • branches/working-0711/ccl/level-1/l1-application.lisp

    r10394 r10938  
    303303  #+clozure-common-lisp '("home:ccl-init" "home:openmcl-init") ;; transitional kludge
    304304  #-clozure-common-lisp "home:openmcl-init")
    305 
    306 (defmethod application-error ((a application) condition error-pointer)
    307   (declare (ignore condition error-pointer))
    308   (quit))
  • branches/working-0711/ccl/level-1/l1-callbacks.lisp

    r8884 r10938  
    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.
  • branches/working-0711/ccl/level-1/l1-clos-boot.lisp

    r10000 r10938  
    170170
    171171
    172 (defun %slot-definition-class (slotd)
    173   (standard-slot-definition.class slotd))
    174 
    175172(defun %slot-definition-location (slotd)
    176173  (standard-effective-slot-definition.location slotd))
     
    274271
    275272;;; This becomes (apply #'make-instance <method-class> &rest args).
    276 (defun %make-method-instance (class &key
    277                                     qualifiers
    278                                     specializers
    279                                     function                               
    280                                     name
    281                                     lambda-list
    282                                     &allow-other-keys)
    283   (let* ((method
    284           (%instance-vector (%class-own-wrapper class)
    285                             qualifiers
    286                             specializers
    287                             function
    288                             nil
    289                             name
    290                             lambda-list)))
    291     (when function
    292       (let* ((inner (closure-function function)))
    293         (unless (eq inner function)
    294           (copy-method-function-bits inner function)))
    295       (lfun-name function method))
    296     method))
     273(fset '%make-method-instance
     274      (nlambda bootstrapping-%make-method-instance (class &key
     275                                                          qualifiers
     276                                                          specializers
     277                                                          function
     278                                                          name
     279                                                          lambda-list
     280                                                          &allow-other-keys)
     281        (let* ((method
     282                (%instance-vector (%class-own-wrapper class)
     283                                  qualifiers
     284                                  specializers
     285                                  function
     286                                  nil
     287                                  name
     288                                  lambda-list)))
     289          (when function
     290            (let* ((inner (closure-function function)))
     291              (unless (eq inner function)
     292                (copy-method-function-bits inner function)))
     293            (lfun-name function method))
     294          method)))
    297295 
    298296       
     
    867865
    868866;; Redefined in l1-clos.lisp
    869 (defun maybe-remove-make-instance-optimization (gfn method)
    870   (declare (ignore gfn method))
    871   nil)
     867(fset 'maybe-remove-make-instance-optimization
     868      (nlambda bootstrapping-maybe-remove-make-instance-optimization (gfn method)
     869        (declare (ignore gfn method))
     870        nil))
    872871
    873872(defun %add-standard-method-to-standard-gf (gfn method)
     
    13231322
    13241323
    1325 (defun set-find-class (name class)
    1326   (clear-type-cache)
    1327   (let* ((cell (find-class-cell name t))
    1328          (old-class (class-cell-class cell)))
    1329     (when class
    1330       (if (eq name (%class.name class))
    1331         (setf (info-type-kind name) :instance)))
    1332     (setf (class-cell-class cell) class)
    1333     (update-class-proper-names name old-class class)
    1334     class))
     1324(fset 'set-find-class (nfunction bootstrapping-set-find-class ; redefined below
     1325                                 (lambda (name class)
     1326                                   (clear-type-cache)
     1327                                   (let* ((cell (find-class-cell name t))
     1328                                          (old-class (class-cell-class cell)))
     1329                                     (when class
     1330                                       (if (eq name (%class.name class))
     1331                                         (setf (info-type-kind name) :instance)))
     1332                                     (setf (class-cell-class cell) class)
     1333                                     (update-class-proper-names name old-class class)
     1334                                     class))))
    13351335
    13361336
    13371337;;; bootstrapping definition. real one is in "sysutils.lisp"
    1338 
    1339 (defun built-in-type-p (name)
    1340   (or (type-predicate name)
    1341       (memq name '(signed-byte unsigned-byte mod
    1342                    values satisfies member and or not))
    1343       (typep (find-class name nil) 'built-in-class)))
     1338(fset 'built-in-type-p (nfunction boostrapping-built-in-typep-p
     1339                                  (lambda (name)
     1340                                    (or (type-predicate name)
     1341                                        (memq name '(signed-byte unsigned-byte mod
     1342                                                     values satisfies member and or not))
     1343                                        (typep (find-class name nil) 'built-in-class)))))
    13441344
    13451345
     
    24812481;;; Bootstrapping version of union
    24822482(unless (fboundp 'union)
    2483 (defun union (l1 l2)
    2484   (dolist (e l1)
    2485     (unless (memq e l2)
    2486       (push e l2)))
    2487   l2)
     2483  (fset 'union (nlambda bootstrapping-union (l1 l2)
     2484                 (dolist (e l1)
     2485                   (unless (memq e l2)
     2486                     (push e l2)))
     2487                 l2))
    24882488)
    24892489
  • branches/working-0711/ccl/level-1/l1-clos.lisp

    r10666 r10938  
    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
     
    11891190
    11901191
    1191 ;;; Fake method-combination
     1192;;; Fake method-combination, redefined in lib;method-combination.
    11921193(defclass method-combination (metaobject)
    1193   ((name :accessor method-combination-name :initarg :name)))
     1194  ((name :initarg :name)))
    11941195
    11951196
  • branches/working-0711/ccl/level-1/l1-dcode.lisp

    r9847 r10938  
    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
  • branches/working-0711/ccl/level-1/l1-files.lisp

    r9117 r10938  
    237237
    238238
    239 (defun pathname-host (thing)  ; redefined later in this file
    240   (declare (ignore thing))
    241   :unspecific)
    242 
    243 (defun pathname-version (thing)  ; redefined later in this file
    244   (declare (ignore thing))
    245   nil)
     239(fset 'pathname-host (nfunction bootstrapping-pathname-host   ; redefined later in this file
     240                                (lambda (thing)
     241                                  (declare (ignore thing))
     242                                  :unspecific)))
     243
     244(fset 'pathname-version (nfunction bootstrapping-pathname-version   ; redefined later in this file
     245                                   (lambda (thing)
     246                                     (declare (ignore thing))
     247                                     nil)))
    246248
    247249(defmethod print-object ((pathname pathname) stream)
  • branches/working-0711/ccl/level-1/l1-format.lisp

    r9578 r10938  
    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)
  • branches/working-0711/ccl/level-1/l1-pathnames.lisp

    r10400 r10938  
    430430                    (when (null (cdr dir))
    431431                      (setq dir (car dir))
    432                       (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors)))))
    433     (cond ((eq path wild) t)
    434           ((only-wild wild)
    435            t)
    436           (t (let ((result t))
    437                (block nil
    438                  (while (and path wild)
    439                    (let ((pathstr (car path))
    440                          (wildstr (car wild)))
    441                      (case wildstr
    442                        (:wild (setq wildstr "*"))
    443                        (:wild-inferiors (setq wildstr "**")))
    444                      (case pathstr
    445                        (:wild (setq pathstr "*"))
    446                        (:wild-inferiors (setq pathstr "**")))
    447                      (when (not
    448                             (cond ((string= wildstr "**")
    449                                    (setq result (%pathname-match-dir1 path (cdr wild)))
    450                                    (return-from nil))
    451                                   ((%path-str*= pathstr wildstr))))
    452                        (setq result nil)
    453                        (return-from nil))
    454                      (setq wild (cdr wild) path (cdr path))))
    455                  (when (and (or path wild)(not (only-wild wild)))
    456                    (setq result nil)))
    457                result)))))
    458 
    459 (defun %pathname-match-dir0 (path wild)
    460   (flet ((only-wild (dir)
    461                     (when (null (cdr dir))
    462                       (setq dir (car dir))
    463432                      (when (consp dir) (setq dir (cadr dir)))
    464433                      (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors)))))
  • branches/working-0711/ccl/level-1/l1-readloop.lisp

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

    r9949 r10938  
    42854285  (%string-push-extend char (string-stream-ioblock-string ioblock)))
    42864286
    4287 (defmethod stream-force-output ((stream string-output-stream)) nil)
    4288 
    42894287(defun fill-pointer-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
    42904288  (let* ((end (+ start-char num-chars))
  • branches/working-0711/ccl/level-1/l1-typesys.lisp

    r10357 r10938  
    34323432                                     '(args-ctype values-ctype function-ctype))))
    34333433
    3434 (defun function-ctype-p (x) (istruct-typep x 'function-ctype))
    34353434(defun valuec-ctype-p (x) (istruct-typep x 'values-ctype))
    34363435
  • branches/working-0711/ccl/level-1/l1-utils.lisp

    r10607 r10938  
    4343;;; to avoid clutter - done
    4444
    45 (defun physical-pathname-p (file)(declare (ignore file)) nil) ; redefined later
     45(fset 'physical-pathname-p (lambda (file) (declare (ignore file)) nil)) ; redefined later
    4646
    4747
    4848;(%defvar *enqueued-window-title* nil)
    49 
    50 (defun booted-probe-file (file)
    51   (declare (ignore file))
    52   nil)
    53 
    54 (queue-fixup
    55  (defun booted-probe-file (file)
    56    (probe-file file)))
    5749
    5850(defun inherit-from-p (ob parent)
  • branches/working-0711/ccl/level-1/sysutils.lisp

    r9861 r10938  
    529529(defparameter *outstanding-deferred-warnings* nil)
    530530
    531 
    532 (defun %defer-warnings (override &optional flags)
    533   (%istruct 'deferred-warnings (unless override *outstanding-deferred-warnings*) nil nil flags))
     531(defun call-with-compilation-unit (thunk &key override)
     532  (let* ((*outstanding-deferred-warnings* (%defer-warnings override)))
     533    (multiple-value-prog1 (funcall thunk)
     534      (report-deferred-warnings))))
     535
     536(defun %defer-warnings (override &optional flags &aux (parent *outstanding-deferred-warnings*))
     537  (%istruct 'deferred-warnings
     538            (unless override parent)
     539            nil
     540            (if (or override (not parent))
     541              (make-hash-table :test #'eq)
     542              (deferred-warnings.defs parent))
     543            flags))
    534544
    535545(defun report-deferred-warnings ()
    536546  (let* ((current *outstanding-deferred-warnings*)
    537547         (parent (deferred-warnings.parent current))
    538          (defs (deferred-warnings.defs current))
    539548         (warnings (deferred-warnings.warnings current))
    540549         (any nil)
     
    542551    (if parent
    543552      (setf (deferred-warnings.warnings parent) (append warnings (deferred-warnings.warnings parent))
    544             (deferred-warnings.defs parent) (append defs (deferred-warnings.defs parent))
    545553            parent t)
    546554      (let* ((file nil)
     555             (defs (deferred-warnings.defs current))
    547556             (init t))
    548557        (flet ((signal-warning (w)
     
    554563                   (def nil))
    555564              (when (if (typep w 'undefined-function-reference)
    556                       (not (setq def (or (assq wfname defs)
     565                      (not (setq def (or (gethash wfname defs)
    557566                                         (let* ((global (fboundp wfname)))
    558567                                           (if (typep global 'function)
    559568                                             global))))))
    560569                (signal-warning w))
    561               ;; Check args in call to forward-referenenced function.
     570              ;; Check args in call to forward-referenced function.
    562571              (if (or (typep def 'function)
    563572                      (and (consp def)
    564                            (consp (cdr def))
    565                            (cadr def)))
     573                           (def-info.lfbits (cdr def))))
    566574                (when (cdr args)
    567575                  (destructuring-bind (arglist spread-p)
     
    579587                                (compiler-warning-stream-position w))
    580588                          (signal-warning w2))))))
    581                 (if (and (consp def)
    582                          (consp (cdr def))
    583                          (eq (cddr def) 'macro))
     589                (if (def-info.macro-p (cdr def))
    584590                  (let* ((w2 (make-condition
    585591                              'macro-used-before-definition
  • branches/working-0711/ccl/level-1/x86-trap-support.lisp

    r8021 r10938  
    152152(defun (setf indexed-gpr-macptr) (new xp igpr)
    153153  (setf (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))) new))
    154 (defun indexed-gpr-macptr (xp igpr)
    155   (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))))
    156154(defun encoded-gpr-macptr (xp gpr)
    157155  (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
  • branches/working-0711/ccl/lib/ccl-export-syms.lisp

    r9928 r10938  
    107107     unignore
    108108     *warn-if-redefine-kernel*
     109     without-duplicate-definition-warnings
    109110     require-type
    110111     dovector
  • branches/working-0711/ccl/lib/compile-ccl.lisp

    r10403 r10938  
    300300
    301301(defun compile-ccl (&optional force-compile)
     302 (with-compilation-unit ()
    302303  (update-modules 'nxenv force-compile)
    303304  (update-modules *compiler-modules* force-compile)
     
    313314    (require-modules other-lib)
    314315    (require-update-modules *code-modules* force-compile))
    315   (compile-modules *aux-modules* force-compile))
     316  (compile-modules *aux-modules* force-compile)))
    316317
    317318
     
    343344
    344345(defun xcompile-ccl (&optional force)
     346 (with-compilation-unit ()
    345347  (compile-modules 'nxenv force)
    346348  (compile-modules *compiler-modules* force)
     
    352354  (compile-modules (target-other-lib-modules) force)
    353355  (compile-modules *code-modules* force)
    354   (compile-modules *aux-modules* force))
     356  (compile-modules *aux-modules* force)))
    355357
    356358(defun require-update-modules (modules &optional force-compile)
     
    361363    (update-modules module force-compile))))
    362364
    363 (defun compile-level-1 (&optional force-compile)
    364   (compile-modules (target-level-1-modules (backend-name *host-backend*))
    365                    force-compile))
    366 
    367 
    368 
    369  
    370365
    371366(defun target-xcompile-ccl (target &optional force)
  • branches/working-0711/ccl/lib/defstruct-lds.lisp

    r9578 r10938  
    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
  • branches/working-0711/ccl/lib/defstruct.lisp

    r9578 r10938  
    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))
     
    128131
    129132;;; return stuff for defstruct to compile
    130 (defun %defstruct-compile (sd refnames)
     133(defun %defstruct-compile (sd refnames env)
    131134  (let ((stuff))   
    132135    (dolist (slot (sd-slots sd))
     
    140143                (warn "Accessor ~s at different position than in included structure"
    141144                      accessor)))
    142             (let ((fn (slot-accessor-fn slot accessor)))
     145            (let ((fn (slot-accessor-fn slot accessor env)))
    143146              (push
    144147               `(progn
    145                   ,fn
     148                  ,.fn
    146149                  (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot))
    147150                  (record-source-file ',accessor 'structure-accessor))
    148151               stuff))))))
    149     `(progn ,@(nreverse stuff))))
     152    (nreverse stuff)))
    150153
    151154
     
    182185;;; the same.
    183186
    184 (defparameter *defstruct-share-accessor-functions* t)
    185 
    186 (defun slot-accessor-fn (slot name &aux (ref (ssd-reftype slot))
    187                               (offset (ssd-offset slot)))
    188     (cond ((eq ref $defstruct-nth)
    189            (if (and  (%i< offset 10) *defstruct-share-accessor-functions*)
    190              `(fset ',name
     187
     188(defparameter *defstruct-share-accessor-functions* t)   ;; TODO: isn't it time to get rid of this?
     189
     190(defun slot-accessor-fn (slot name env &aux (ref (ssd-reftype slot)) (offset (ssd-offset slot)))
     191  (cond ((eq ref $defstruct-nth)
     192         (if (and  (%i< offset 10) *defstruct-share-accessor-functions*)
     193           `((eval-when (:compile-toplevel)
     194               (record-function-info ',name ',*one-arg-defun-def-info* ,env))
     195              (fset ',name
    191196                    ,(symbol-function
    192197                      (%svref '#(first second third fourth fifth
    193                                        sixth seventh eighth ninth tenth) offset)))
    194              `(defun ,name (x)  (nth ,offset x))))
    195           ((eq ref $defstruct-struct)
    196            (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
    197              `(fset ',name , (%svref *struct-ref-vector* offset))
    198              `(defun ,name (x)  (struct-ref x ,offset))))
    199           ((or (eq ref target::subtag-simple-vector)
    200                (eq ref $defstruct-simple-vector))
    201            (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
    202              `(fset ',name ,(%svref *svref-vector* offset))
    203              `(defun ,name (x)  (svref x ,offset))))
    204           (t `(defun ,name (x) (uvref x ,offset)))))
     198                                 sixth seventh eighth ninth tenth) offset))))
     199           `((defun ,name (x)  (nth ,offset x)))))
     200        ((eq ref $defstruct-struct)
     201         (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
     202           `((eval-when (:compile-toplevel)
     203               (record-function-info ',name ',*one-arg-defun-def-info* ,env))               
     204             (fset ',name , (%svref *struct-ref-vector* offset)))
     205           `((defun ,name (x)  (struct-ref x ,offset)))))
     206        ((or (eq ref target::subtag-simple-vector)
     207             (eq ref $defstruct-simple-vector))
     208         (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
     209           `((eval-when (:compile-toplevel)
     210               (record-function-info ',name ',*one-arg-defun-def-info* ,env))
     211             (fset ',name ,(%svref *svref-vector* offset)))
     212           `((defun ,name (x)  (svref x ,offset)))))
     213        (t `((defun ,name (x) (uvref x ,offset))))))
    205214
    206215(defun defstruct-reftype (type)
     
    210219
    211220(defun defstruct-slot-defs (sd refnames env)
     221  (declare (ignore env))
    212222  (let ((ref (defstruct-reftype (sd-type sd))) name defs)
    213223    (dolist (slot (sd-slots sd))
     
    218228          (push name defs))))
    219229    (setq defs (nreverse defs))
    220     (let* ((info (list (cons (dpb 1 $lfbits-numreq 0) nil))))
    221       `(progn
    222         (eval-when (:compile-toplevel)
    223           ,@(mapcar #'(lambda (name) `(record-function-info ',name ',info ,env)) defs))
    224         (declaim (inline ,@defs))))))
     230    `((declaim (inline ,@defs)))))
    225231
    226232;;;Used by setf and whatever...
  • branches/working-0711/ccl/lib/format.lisp

    r9578 r10938  
    391391; in l1-format
    392392(def-standard-initial-binding *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
  • branches/working-0711/ccl/lib/macros.lisp

    r10776 r10938  
    639639      (%define-symbol-macro ',name ',expansion))))
    640640
    641 (defun record-function-info (name info env)
    642   (let* ((definition-env (definition-environment env)))
    643     (if definition-env
    644       (let* ((already (assq name (defenv.defined definition-env))))
    645         (if already
    646           (if info (%rplacd already info))
    647           (push (cons name info) (defenv.defined definition-env)))
    648         info))))
    649 
    650641;; ---- allow inlining setf functions
    651642(defmacro defun (spec args &body body &environment env &aux global-name inline-spec)
     
    676667                   doc)))
    677668      `(progn
    678          (eval-when (:compile-toplevel)
    679            (note-function-info ',spec ',lambda-expression ,env))
    680669         (%defun (nfunction ,spec ,lambda-expression) ',info)
    681670         ',spec))))
     
    775764           as ,var = (%svref ,lfv ,i)
    776765           ,@loop-body)))
    777 
    778 ; %Pascal-Functions% Entry
    779 ; Used by "l1;ppc-callback-support" & "lib;dumplisp"
    780 (def-accessor-macros %svref
    781   pfe.routine-descriptor
    782   pfe.proc-info
    783   pfe.lisp-function
    784   pfe.sym
    785   pfe.without-interrupts
    786   pfe.trace-p)
    787766
    788767(defmacro cond (&rest args &aux clause)
     
    980959  `(function (lambda ,paramlist ,@body)))
    981960
     961; This isn't
     962(defmacro nlambda (name (&rest arglist) &body body)
     963  `(nfunction ,name (lambda ,arglist ,@body)))
    982964
    983965(defmacro when (test &body body)
     
    14871469        OVERRIDE true causes that form to grab any enclosed warnings, even if
    14881470        it is enclosed by another WITH-COMPILATION-UNIT."
    1489   `(let* ((*outstanding-deferred-warnings* (%defer-warnings ,override)))
    1490      (multiple-value-prog1 (progn ,@body) (report-deferred-warnings))))
     1471  `(flet ((with-compilation-unit-body ()
     1472            ,@body))
     1473     (declare (dynamic-extent #'with-compilation-unit-body))
     1474     (call-with-compilation-unit #'with-compilation-unit-body :override ,override)))
    14911475
    14921476; Yow! Another Done Fun.
     
    17261710      (parse-defmethod name args env)
    17271711    `(progn
    1728       (eval-when (:compile-toplevel)
    1729         (record-function-info ',(maybe-setf-function-name name)
    1730                               ',(list (list (encode-gf-lambda-list
    1731                                              lambda-list)))
    1732                               ,env))
    1733       (compiler-let ((*nx-method-warning-name*
    1734                       (list ',name
    1735                             ,@(mapcar #'(lambda (x) `',x) qualifiers)
    1736                             ',specializers)))
    1737         (ensure-method ',name ,specializers-form
    1738                        :function ,function-form
    1739                        :qualifiers ',qualifiers
    1740                        :lambda-list ',lambda-list
    1741                        ,@(if documentation `(:documentation ,documentation)))))))
     1712       (eval-when (:compile-toplevel)
     1713         (record-function-info ',(maybe-setf-function-name name)
     1714                               ',(%cons-def-info 'defmethod (encode-gf-lambda-list lambda-list) nil nil
     1715                                                 specializers qualifiers)
     1716                               ,env))
     1717       (compiler-let ((*nx-method-warning-name* '(,name ,@qualifiers ,specializers)))
     1718         (ensure-method ',name ,specializers-form
     1719                        :function ,function-form
     1720                        :qualifiers ',qualifiers
     1721                        :lambda-list ',lambda-list
     1722                        ,@(if documentation `(:documentation ,documentation)))))))
    17421723
    17431724
     
    19041885                      (readers nil)
    19051886                      (writers nil)
    1906                       (reader-info (list (cons (dpb 1 $lfbits-numreq 0) nil)))
    1907                       (writer-info (list (cons (dpb 2 $lfbits-numreq 0) nil))))
     1887                      (reader-info (%cons-def-info 'defmethod (dpb 1 $lfbits-numreq 0) nil nil (list class-name)))
     1888                      (writer-info (%cons-def-info 'defmethod (dpb 2 $lfbits-numreq 0) nil nil (list t class-name))))
    19081889                 (when (memq slot-name slot-names)
    19091890                   (SIGNAL-PROGRAM-error "Multiple slots named ~S in DEFCLASS ~S" slot-name class-name))
     
    20131994         (eval-when (:compile-toplevel)
    20141995           (record-function-info ',(maybe-setf-function-name function-name)
    2015                                  ',(list (list (encode-gf-lambda-list lambda-list)))
     1996                                 ',(%cons-def-info 'defgeneric (encode-gf-lambda-list lambda-list))
    20161997                                 ,env))
    20171998         (let ((,gf (%defgeneric
     
    28462827       (funcall-with-error-reentry-detection ,thunk))))
    28472828
     2829(defmacro without-duplicate-definition-warnings (&body body)
     2830  `(compiler-let ((*compiler-warn-on-duplicate-definitions* nil))
     2831     ,@body))
     2832
     2833
    28482834#+ppc-target
    28492835(defmacro scan-for-instr (mask opcode fn pc-index &optional (tries *trap-lookup-tries*))
  • branches/working-0711/ccl/lib/method-combination.lisp

    r8867 r10938  
    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)
  • branches/working-0711/ccl/lib/misc.lisp

    r9928 r10938  
    113113(defmethod documentation (thing doc-id)
    114114  (%get-documentation thing doc-id))
    115 
    116 (defun set-documentation (thing doc-id new)
    117   (setf (documentation thing doc-id) new))
    118115
    119116(defmethod (setf documentation) (new thing doc-id)
  • branches/working-0711/ccl/lib/nfcomp.lisp

    r10776 r10938  
    223223          (let* ((*outstanding-deferred-warnings* (%defer-warnings nil)))
    224224            (rplacd (defenv.type defenv) *outstanding-deferred-warnings*)
     225            (setf (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*))
     226
    225227            (setq forms (fcomp-file src orig-src lexenv))
     228
    226229            (setf (deferred-warnings.warnings *outstanding-deferred-warnings*)
    227                   (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*))
    228                   (deferred-warnings.defs *outstanding-deferred-warnings*)
    229                   (append (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*)))
     230                  (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*)))
    230231            (when *compile-verbose* (fresh-line))
    231232            (multiple-value-bind (any harsh) (report-deferred-warnings)
     
    276277
    277278(defun %compile-time-eval (form env)
     279  (declare (ignore env))
    278280  (let* ((*target-backend* *host-backend*))
    279281    ;; The HANDLER-BIND here is supposed to note WARNINGs that're
     
    291293      (funcall (compile-named-function
    292294                `(lambda () ,form)
    293                 :env env
     295                ;; Do not depend on, or extend, the compile-time environment!
     296                ;;  :env env
    294297                :policy *compile-time-evaluation-policy*)))))
    295298
     
    449452        (loop
    450453          (let* ((*fcomp-stream-position* (file-position *fcomp-stream*))
     454                 (*nx-warnings* nil) ;; catch any warnings from :compile-toplevel forms
    451455                 form)
    452456            (unless (eq read-package *package*)
     
    474478            (fcomp-output-source-being-compiled env)
    475479            (fcomp-form form env processing-mode)
     480            (fcomp-signal-or-defer-warnings *nx-warnings* env)
    476481            (setq *fcomp-previous-position* *fcomp-stream-position*))))
    477482      (when *compile-code-coverage*
     
    760765                   (compile-named-function lambda-expression :name name :env env))
    761766            (defenv.functions definition-env))
    762       (record-function-info name (list (cons nil 'macro)) env))
     767      (record-function-info name (%cons-def-info 'defmacro) env))
    763768    name))
    764769
     
    835840        (setq doc nil)))
    836841    (record-form-source-equivalent form fn)
     842    (when (and (consp fn) (eq (%car fn) 'nfunction))
     843      (note-function-info (cadr fn) (caddr fn) env))
    837844    (if (and (constantp doc)
    838845             (setq fn (fcomp-function-arg fn env form)))
  • branches/working-0711/ccl/lib/pprint.lisp

    r10245 r10938  
    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
  • branches/working-0711/ccl/lib/sequences.lisp

    r9926 r10938  
    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.
  • branches/working-0711/ccl/library/lispequ.lisp

    r10776 r10938  
    270270(def-accessors (logical-pathname) %svref
    271271  ()                                    ; 'logical-pathname
    272   %pathname-directory
    273   %pathname-name
    274   %pathname-type 
     272  nil                                   ; %pathname-directory
     273  nil                                   ; %pathname-name
     274  nil                                   ; %pathname-type 
    275275  %logical-pathname-host
    276276  %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.