Changeset 14381


Ignore:
Timestamp:
Oct 29, 2010, 3:53:56 PM (9 years ago)
Author:
rme
Message:

Merge trunk changes r14361 through r14380.

Location:
release/1.6/source
Files:
32 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/1.6/source

  • release/1.6/source/cocoa-ide/cocoa-editor.lisp

    r14249 r14381  
    570570;;; This runs on the main thread; it synchronizes the "real" NSMutableAttributedString
    571571;;; with the hemlock string and informs the textstorage of the insertion.
    572 (objc:defmethod (#/noteHemlockInsertionAtPosition:length: :void) ((self hemlock-text-storage)
     572(objc:defmethod (#/noteHemlockInsertionAtPosition:length:extra: :void) ((self hemlock-text-storage)
    573573                                                                  (pos :<NSI>nteger)
    574574                                                                  (n :<NSI>nteger)
     
    601601    (textstorage-note-insertion-at-position self pos n)))
    602602
    603 (objc:defmethod (#/noteHemlockDeletionAtPosition:length: :void) ((self hemlock-text-storage)
    604                                                                  (pos :<NSI>nteger)
    605                                                                  (n :<NSI>nteger)
    606                                                                  (extra :<NSI>nteger))
     603(objc:defmethod (#/noteHemlockDeletionAtPosition:length:extra: :void) ((self hemlock-text-storage)
     604                                                                       (pos :<NSI>nteger)
     605                                                                       (n :<NSI>nteger)
     606                                                                       (extra :<NSI>nteger))
    607607  (declare (ignorable extra))
    608608  #+debug
     
    628628      (update-line-cache-for-index display pos))))
    629629
    630 (objc:defmethod (#/noteHemlockModificationAtPosition:length: :void) ((self hemlock-text-storage)
    631                                                                      (pos :<NSI>nteger)
    632                                                                      (n :<NSI>nteger)
    633                                                                      (extra :<NSI>nteger))
     630(objc:defmethod (#/noteHemlockModificationAtPosition:length:extra: :void) ((self hemlock-text-storage)
     631                                                                           (pos :<NSI>nteger)
     632                                                                           (n :<NSI>nteger)
     633                                                                           (extra :<NSI>nteger))
    634634  (declare (ignorable extra))
    635635  #+debug
     
    650650         pos n deleted-string)))))
    651651
    652 (objc:defmethod (#/noteHemlockAttrChangeAtPosition:length: :void) ((self hemlock-text-storage)
    653                                                                    (pos :<NSI>nteger)
    654                                                                    (n :<NSI>nteger)
    655                                                                    (fontnum :<NSI>nteger))
     652(objc:defmethod (#/noteHemlockAttrChangeAtPosition:length:fontNum: :void) ((self hemlock-text-storage)
     653                                                                           (pos :<NSI>nteger)
     654                                                                           (n :<NSI>nteger)
     655                                                                           (fontnum :<NSI>nteger))
    656656  (ns:with-ns-range (range pos n)
    657657    (#/setAttributes:range: (#/mirror self) (#/objectAtIndex: (#/styles self) fontnum) range)
     
    665665                                                     (#/instanceMethodSignatureForSelector:
    666666                                                      hemlock-text-storage
    667                                             (@selector #/noteHemlockInsertionAtPosition:length:))))))
     667                                            (@selector #/noteHemlockInsertionAtPosition:length:extra:))))))
    668668
    669669(defstatic *buffer-change-invocation-lock* (make-lock))
     
    23872387           (pos (hi:mark-absolute-position (hi::region-start region)))
    23882388           (n (- (hi:mark-absolute-position (hi::region-end region)) pos)))
    2389       (perform-edit-change-notification textstorage
    2390                                         (@selector #/noteHemlockAttrChangeAtPosition:length:)
    2391                                         pos
    2392                                         n
    2393                                         font))))
     2389      (if (eq *current-process* *cocoa-event-process*)
     2390        (#/noteHemlockAttrChangeAtPosition:length:fontNum: textstorage
     2391                                                           pos
     2392                                                           n
     2393                                                           font)
     2394        (perform-edit-change-notification textstorage
     2395                                          (@selector #/noteHemlockAttrChangeAtPosition:length:fontNum:)
     2396                                          pos
     2397                                          n
     2398                                          font)))))
    23942399
    23952400(defun buffer-active-font-attributes (buffer)
     
    24152420            ;; For :right-inserting and :temporary marks, they should be left back.
    24162421            (decf pos n))
    2417           (perform-edit-change-notification textstorage
    2418                                             (@selector #/noteHemlockInsertionAtPosition:length:)
    2419                                             pos
    2420                                             n))))))
     2422          (if (eq *current-process* *cocoa-event-process*)
     2423            (#/noteHemlockInsertionAtPosition:length:extra: textstorage
     2424                                                            pos
     2425                                                            n
     2426                                                            0)
     2427            (perform-edit-change-notification textstorage
     2428                                              (@selector #/noteHemlockInsertionAtPosition:length:extra:)
     2429                                              pos
     2430                                              n)))))))
    24212431
    24222432(defun hemlock-ext:buffer-note-modification (buffer mark n)
     
    24252435           (textstorage (if document (slot-value document 'textstorage))))
    24262436      (when textstorage
    2427             (perform-edit-change-notification textstorage
    2428                                               (@selector #/noteHemlockModificationAtPosition:length:)
    2429                                               (hi:mark-absolute-position mark)
    2430                                               n)))))
     2437        (if (eq *current-process* *cocoa-event-process*)
     2438          (#/noteHemlockModificationAtPosition:length:extra: textstorage
     2439                                                             (hi:mark-absolute-position mark)
     2440                                                             n
     2441                                                             0)
     2442          (perform-edit-change-notification textstorage
     2443                                            (@selector #/noteHemlockModificationAtPosition:length:extra:)
     2444                                            (hi:mark-absolute-position mark)
     2445                                            n))))))
    24312446 
    24322447
     
    24372452      (when textstorage
    24382453        (let* ((pos (hi:mark-absolute-position mark)))
    2439           (perform-edit-change-notification textstorage
    2440                                             (@selector #/noteHemlockDeletionAtPosition:length:)
    2441                                             pos
    2442                                             (abs n)))))))
     2454          (if (eq *current-process* *cocoa-event-process*)
     2455            (#/noteHemlockDeletionAtPosition:length:extra: textstorage
     2456                                                           pos
     2457                                                           (abs n)
     2458                                                           0)
     2459            (perform-edit-change-notification textstorage
     2460                                              (@selector #/noteHemlockDeletionAtPosition:length:extra:)
     2461                                              pos
     2462                                              (abs n))))))))
    24432463
    24442464
  • release/1.6/source/cocoa-ide/cocoa-window.lisp

    r14311 r14381  
    122122
    123123
    124 (defloadvar *default-ns-application-proxy-class-name*
     124(defvar *default-ns-application-proxy-class-name*
    125125    "LispApplicationDelegate")
    126126
     
    198198  (flet ((cocoa-startup ()
    199199           ;; Start up a thread to run periodic tasks.
    200            (process-run-function "housekeeping" #'ccl::housekeeping-loop)
    201            (with-autorelease-pool
    202              (enable-foreground)
    203              (or *NSApp* (setq *NSApp* (init-cocoa-application)))
    204              #-cocotron
    205              (let* ((icon (#/imageNamed: ns:ns-image #@"NSApplicationIcon")))
    206                (unless (%null-ptr-p icon)
    207                  (#/setApplicationIconImage: *NSApp* icon)))
    208              (setf (ccl::application-ui-object *application*) *NSApp*)
    209              (when application-proxy-class-name
    210                (let* ((classptr (ccl::%objc-class-classptr
    211                                  (ccl::load-objc-class-descriptor application-proxy-class-name)))
    212                       (instance (#/init (#/alloc classptr))))
    213 
    214                  (#/setDelegate: *NSApp* instance))))
    215            (run-event-loop)))
     200           (ccl::with-standard-initial-bindings
     201               (process-run-function "housekeeping" #'ccl::housekeeping-loop)
     202               (with-autorelease-pool
     203                   (enable-foreground)
     204                 (or *NSApp* (setq *NSApp* (init-cocoa-application)))
     205                 #-cocotron
     206                 (let* ((icon (#/imageNamed: ns:ns-image #@"NSApplicationIcon")))
     207                   (unless (%null-ptr-p icon)
     208                     (#/setApplicationIconImage: *NSApp* icon)))
     209                 (setf (ccl::application-ui-object *application*) *NSApp*)
     210                 (when application-proxy-class-name
     211                   (let* ((classptr (ccl::%objc-class-classptr
     212                                     (ccl::load-objc-class-descriptor application-proxy-class-name)))
     213                          (instance (#/init (#/alloc classptr))))
     214                     
     215                     (#/setDelegate: *NSApp* instance))))
     216               (run-event-loop))))
    216217    (process-interrupt *cocoa-event-process* #'(lambda ()
    217                                                 (%set-toplevel
    218                                                   #'cocoa-startup)
    219                                                 (toplevel)))))
     218                                                (%set-toplevel
     219                                                  #'cocoa-startup)
     220                                                (toplevel)))))
    220221
    221222(defparameter *font-attribute-names*
     
    424425                              (height 0)
    425426                              &allow-other-keys)
     427  (declare (ignorable with-frame))
    426428  (unless with-frame-p
    427429    (setq initargs (cons :with-frame
  • release/1.6/source/compiler/X86/X8664/x8664-vinsns.lisp

    r14338 r14381  
    633633  ((:and (:pred /= intval 0)
    634634         (:pred >= intval  -2147483648)
    635          (:pred <= intval 2147483647))
    636    (movq (:$l intval) (:%q dest)))
     635         (:pred <= intval #xffffffff))
     636   ((:pred > intval 0)
     637    (movl (:$l intval) (:%l dest)))
     638   ((:pred < intval 0)
     639    (movq (:$l intval) (:%q dest))))
    637640  ((:or (:pred < intval  -2147483648)
    638         (:pred > intval 2147483647))
     641        (:pred > intval #xffffffff))
    639642   (movq (:$q (:apply logand #xffffffffffffffff intval)) (:%q dest))))
    640643
     
    644647  ((:pred = intval 0)
    645648   (xorl (:%l dest) (:%l dest)))
    646   ((:and (:pred /= intval 0)
    647          (:pred >= intval  -2147483648)
    648          (:pred <= intval 2147483647))
    649    (movq (:$l intval) (:%q dest)))
    650   ((:or (:pred < intval  -2147483648)
    651         (:pred > intval 2147483647))
     649  ((:and (:pred > intval 0)
     650         (:pred <= intval #xffffffff))
     651   (movl (:$l intval) (:%l dest)))
     652  ((:pred > intval #xffffffff)
    652653   (movq (:$q (:apply logand #xffffffffffffffff intval)) (:%q dest))))
    653654
  • release/1.6/source/compiler/X86/x862.lisp

    r14348 r14381  
    15541554            (if (and (= (hard-regspec-class vreg) hard-reg-class-gpr)
    15551555                     (member (get-regspec-mode vreg)
    1556                              '(hard-reg-class-gpr-mode-u32
    1557                                hard-reg-class-gpr-mode-s32
    1558                                hard-reg-class-gpr-mode-address))
     1556                             '(#.hard-reg-class-gpr-mode-u32
     1557                               #.hard-reg-class-gpr-mode-s32
     1558                               #.hard-reg-class-gpr-mode-address))
    15591559                     (or (typep form '(unsigned-byte 32))
    15601560                         (typep form '(signed-byte 32))))
     
    15681568                  (x862-store-immediate seg form target)))))
    15691569           (:x8664
    1570             (if (and (typep form '(unsigned-byte 32))
    1571                      (= (hard-regspec-class vreg) hard-reg-class-gpr)
    1572                      (= (get-regspec-mode vreg)
    1573                         hard-reg-class-gpr-mode-u32))
    1574               (x862-lri seg vreg form)
    1575               (ensuring-node-target
    1576                   (target vreg)
    1577                 (if (characterp form)
    1578                   (! load-character-constant target (char-code form))
    1579                   (x862-store-immediate seg form target)))))))
     1570            (let* ((mode (if (= (hard-regspec-class vreg) hard-reg-class-gpr)
     1571                           (get-regspec-mode vreg))))
     1572           
     1573              (if (and (eql mode hard-reg-class-gpr-mode-s64)
     1574                       (typep form '(signed-byte 64)))
     1575                (x862-lri seg vreg form)
     1576                (if (and (or (eql mode hard-reg-class-gpr-mode-u64)
     1577                                 (eql mode hard-reg-class-gpr-mode-address))
     1578                             (typep form '(unsigned-byte 64)))
     1579                  (x862-lriu seg vreg form)
     1580                  (ensuring-node-target
     1581                      (target vreg)
     1582                    (if (characterp form)
     1583                      (! load-character-constant target (char-code form))
     1584                      (x862-store-immediate seg form target)))))))))
    15801585        (if (and (listp form) *load-time-eval-token* (eq (car form) *load-time-eval-token*))
    15811586          (x862-store-immediate seg form ($ *x862-temp0*))))
  • release/1.6/source/compiler/nx-basic.lisp

    r14351 r14381  
    641641    (:undefined-function . "Undefined function ~S") ;; (deferred)
    642642    (:undefined-type . "Undefined type ~S")         ;; (deferred)
    643     (:unknown-type-in-declaration . "Unknown or invalid type ~S, declaration ignored")
     643    (:unknown-type-in-declaration . "Unknown type ~S, declaration ignored")
    644644    (:bad-declaration . "Unknown or invalid declaration ~S")
    645645    (:invalid-type . report-invalid-type-compiler-warning)
  • release/1.6/source/compiler/nx.lisp

    r14348 r14381  
    221221    (:environment-mismatch . invalid-arguments)
    222222    (:ftype-mismatch . invalid-arguments)
     223    (:unknown-type-in-declaration . style-warning)
    223224    (:ignore . style-warning)
    224225    (:result-ignored . style-warning)
  • release/1.6/source/compiler/nx0.lisp

    r14348 r14381  
    717717    (parse-unknown-type (c)
    718718      (when (and whine *compiler-warn-on-undefined-type-references*)
    719         (nx1-whine :undefined-type typespec))
     719        (nx1-whine (if (keywordp whine) whine :undefined-type) typespec))
    720720      (values nil (parse-unknown-type-specifier c)))
    721721    ;; catch any errors due to destructuring in type-expand
     
    864864(defnxdecl ftype (pending decl env &aux whined)
    865865  (destructuring-bind (type &rest fnames) (%cdr decl)
    866     (let ((ctype (specifier-type-if-known type env)))
    867       (if (null ctype)
    868         (nx1-whine :unknown-type-in-declaration type)
    869         (if (types-disjoint-p ctype (specifier-type 'function))
    870           (nx-bad-decls decl)
    871           (dolist (s fnames)
    872             (if (or (symbolp s) (setf-function-name-p s))
    873               (nx-new-fdecl pending s 'ftype type)
    874               (unless (shiftf whined t) (nx-bad-decls decl)))))))))
     866    (let ((ctype (specifier-type-if-known type env :whine :unknown-type-in-declaration)))
     867      (when ctype
     868        (if (types-disjoint-p ctype (specifier-type 'function))
     869          (nx-bad-decls decl)
     870          (dolist (s fnames)
     871            (if (or (symbolp s) (setf-function-name-p s))
     872              (nx-new-fdecl pending s 'ftype type)
     873              (unless (shiftf whined t) (nx-bad-decls decl)))))))))
    875874
    876875(defnxdecl settable (pending decl env)
     
    894893
    895894(defun nx-process-type-decl (pending decl type vars env &aux whined)
    896   (if (specifier-type-if-known type env)
     895  (when (specifier-type-if-known type env :whine :unknown-type-in-declaration)
    897896    (dolist (sym vars)
    898897      (if (symbolp sym)
    899898        (nx-new-vdecl pending sym 'type type)
    900         (unless (shiftf whined t) (nx-bad-decls decl))))
    901     (nx1-whine :unknown-type-in-declaration type)))
     899        (unless (shiftf whined t) (nx-bad-decls decl))))))
    902900
    903901(defnxdecl global-function-name (pending decl env)
     
    27412739         (use-naturalop (nx-binary-natural-op-p arg-1 arg-2 env)))
    27422740    (if (or use-fixop use-naturalop intop)
    2743       (make-acode (if use-fixop fixop (if use-naturalop naturalop intop))
    2744                   (nx1-form arg-1)
    2745                   (nx1-form arg-2))
     2741      (make-acode (%nx1-operator typed-form)
     2742                  (if use-fixop *nx-target-fixnum-type*
     2743                    (if use-naturalop *nx-target-natural-type* 'integer))
     2744                  (make-acode (if use-fixop fixop (if use-naturalop naturalop intop))
     2745                              (nx1-form arg-1)
     2746                              (nx1-form arg-2)))
    27462747      (nx1-treat-as-call whole))))
    27472748
  • release/1.6/source/compiler/nx1.lisp

    r14348 r14381  
    475475                      (%nx1-operator %natural-logxor)))
    476476
    477 (defnx1 nx1-logand-2 ((logand-2)) (&whole w &environment env arg-1 arg-2)
    478   (nx-binary-boole-op w
    479                       env
    480                       arg-1
    481                       arg-2
    482                       (%nx1-operator %ilogand2)
    483                       (%nx1-operator logand2)
    484                       (%nx1-operator %natural-logand)))
     477(defnx1 nx1-logand-2 ((logand-2)) (&environment env arg-1 arg-2)
     478  (let* ((nat1 (nx-form-typep arg-1 *nx-target-natural-type* env))
     479         (nat2 (nx-form-typep arg-2 *nx-target-natural-type* env)))
     480    (cond ((and (nx-form-typep arg-1 *nx-target-fixnum-type* env)
     481                (nx-form-typep arg-2 *nx-target-fixnum-type* env))
     482           (make-acode (%nx1-operator typed-form)
     483                       *nx-target-fixnum-type*
     484                       (make-acode (%nx1-operator %ilogand2)
     485                                   (nx1-form arg-1 env)
     486                                   (nx1-form arg-2 env))))
     487          ((and nat1 (typep arg-2 'integer))
     488           (make-acode (%nx1-operator typed-form)
     489                       *nx-target-natural-type*
     490                       (make-acode (%nx1-operator %natural-logand)
     491                                   (nx1-form arg-1 env)
     492                                   (nx1-form (logand arg-2
     493                                                     (1- (ash 1 (target-word-size-case
     494                                                                 (32 32)
     495                                                                 (64 64)))))
     496                                             env))))
     497          ((and nat2 (typep arg-1 'integer))
     498           (make-acode (%nx1-operator typed-form)
     499                       *nx-target-natural-type*
     500                       (make-acode (%nx1-operator %natural-logand)
     501                                   (nx1-form arg-2 env)
     502                                   (nx1-form (logand arg-1
     503                                                     (1- (ash 1 (target-word-size-case
     504                                                                 (32 32)
     505                                                                 (64 64)))))
     506                                             env))))
     507          ((and nat1 nat2)
     508           (make-acode (%nx1-operator typed-form)
     509                       *nx-target-natural-type*
     510                       (make-acode (%nx1-operator %natural-logand)
     511                                   (nx1-form arg-1 env)
     512                                   (nx1-form arg-2 env))))
     513          (t
     514           (make-acode (%nx1-operator typed-form)
     515                       'integer
     516                       (make-acode (%nx1-operator logand2)
     517                                   (nx1-form arg-1 env)
     518                                   (nx1-form arg-2 env)))))))
     519
    485520
    486521(defnx1 nx1-require ((require-simple-vector)
  • release/1.6/source/compiler/optimizers.lisp

    r14348 r14381  
    25042504
    25052505
     2506(define-compiler-macro concatenate (&whole w type &rest sequences)
     2507  (if (and (quoted-form-p type)
     2508           (ignore-errors (subtypep (cadr type) 'string)))
     2509    `(concat-to-string ,@sequences)
     2510    w))
     2511
    25062512(provide "OPTIMIZERS")
  • release/1.6/source/level-0/l0-float.lisp

    r14224 r14381  
    819819
    820820
     821(defun positive-realpart-p (n)
     822  (> (realpart n) 0))
    821823
    822824(defun expt (b e)
     
    826828         (if (minusp e) (/ 1 (%integer-power b (- e))) (%integer-power b e)))
    827829        ((zerop b)
    828          (if (plusp (realpart e)) b (report-bad-arg e '(number (0) *))))
     830         (if (plusp (realpart e)) b (report-bad-arg e '(satisfies positive-realpart-p))))
    829831        ((and (realp b) (plusp b) (realp e))
    830832         (if (or (typep b 'double-float)
  • release/1.6/source/level-1/l1-application.lisp

    r13067 r14381  
    298298             :class 'tty-listener
    299299             :process initial-listener-process))))
    300   (%set-toplevel #'housekeeping-loop)
     300  (%set-toplevel (lambda ()
     301                   (with-standard-initial-bindings
     302                       (housekeeping-loop))))
    301303  (toplevel))
    302304
  • release/1.6/source/level-1/l1-boot-2.lisp

    r14288 r14381  
    176176
    177177;;; Things bound by WITH-STANDARD-IO-SYNTAX (and not otherwise thread-local)
    178 (def-standard-initial-binding *print-array*)
    179 (def-standard-initial-binding *print-base*)
    180 (def-standard-initial-binding *print-case*)
    181 (def-standard-initial-binding *print-circle*)
    182 (def-standard-initial-binding *print-escape*)
    183 (def-standard-initial-binding *print-gensym*)
    184 (def-standard-initial-binding *print-length*)
    185 (def-standard-initial-binding *print-level*)
    186 (def-standard-initial-binding *print-lines*)
    187 (def-standard-initial-binding *print-miser-width*)
    188 (def-standard-initial-binding *print-pprint-dispatch*)
    189 (def-standard-initial-binding *print-pretty*)
    190 (def-standard-initial-binding *print-radix*)
    191 (def-standard-initial-binding *print-readably*)
    192 (def-standard-initial-binding *print-right-margin*)
    193178(def-standard-initial-binding *read-base*)
    194179(def-standard-initial-binding *read-default-float-format*)
    195180(def-standard-initial-binding *read-eval*)
    196181(def-standard-initial-binding *read-suppress*)
    197 ;;; ccl extensions (see l1-io.lisp)
    198 (def-standard-initial-binding *print-abbreviate-quote*)
    199 (def-standard-initial-binding *print-structure*)
    200 (def-standard-initial-binding *print-simple-vector*)
    201 (def-standard-initial-binding *print-simple-bit-vector*)
    202 (def-standard-initial-binding *print-string-length*)
     182
    203183
    204184
  • release/1.6/source/level-1/l1-clos-boot.lisp

    r14262 r14381  
    31993199           (setq old-wrapper (gf.instance.class-wrapper instance)))
    32003200         (unless old-wrapper
    3201            (report-bad-arg instance '(or standard-instance funcallable-standard-object))))
     3201           (report-bad-arg instance '(or standard-object funcallable-standard-object))))
    32023202       (when (eql 0 (%wrapper-instance-slots old-wrapper)) ; is it really obsolete?
    32033203         (let* ((class (%wrapper-class old-wrapper))
  • release/1.6/source/level-1/l1-files.lisp

    r14353 r14381  
    12451245            (*readtable* *readtable*))
    12461246        (load-from-stream file-name print))
     1247      (return-from %load file-name))
     1248    (when (and (stringp file-name)
     1249               (eql (length "http://") (string-lessp "http://" file-name)))
     1250      (when verbose
     1251        (format t "~&;Loading from URL ~S..." file-name)
     1252        (force-output))
     1253      (let* ((vec (if if-does-not-exist
     1254                    (snarf-url file-name)
     1255                    (handler-case (snarf-url file-name)
     1256                      (error () (return-from %load nil)))))
     1257             (*package* *package*)
     1258             (*readtable* *readtable*)
     1259             (*loading-file-source-file* file-name)
     1260             (*loading-files* (cons file-name (specialv *loading-files*))))
     1261        (with-input-from-vector (stream vec :external-format external-format)
     1262          (load-from-stream stream print)))
    12471263      (return-from %load file-name))
    12481264    (unless (streamp file-name)
  • release/1.6/source/level-1/l1-init.lisp

    r13529 r14381  
    174174(defparameter %toplevel-catch% ':toplevel)
    175175
    176 (defvar *read-default-float-format* 'single-float)
    177 
    178 (defvar *read-suppress* nil
    179   "Suppress most interpreting in the reader when T.")
    180 
    181 (defvar *read-base* 10.
    182   "the radix that Lisp reads numbers in")
    183176
    184177
  • release/1.6/source/level-1/l1-io.lisp

    r14119 r14381  
    144144
    145145;; coral extensions
    146 (defvar *print-abbreviate-quote* t
     146(def-standard-initial-binding *print-abbreviate-quote* t
    147147  "Non-NIL means that the normal lisp printer --
    148148not just the pretty-printer -- should print
     
    150150This variable is not part of standard Common Lisp.")
    151151
    152 (defvar *print-structure* t
     152(def-standard-initial-binding *print-structure* t
    153153  "Non-NIL means that lisp structures should be printed using
    154154\"#S(...)\" syntax.  if nil, structures are printed using \"#<...>\".
     
    156156
    157157;; things Richard Mlynarik likes.
    158 (defvar *print-simple-vector* nil
     158(def-standard-initial-binding *print-simple-vector* nil
    159159  "Non-NIL means that simple-vectors whose length is less than
    160160the value of this variable are printed even if *PRINT-ARRAY* is false.
    161161this variable is not part of standard Common Lisp.")
    162162
    163 (defvar *print-simple-bit-vector* nil
     163(def-standard-initial-binding *print-simple-bit-vector* nil
    164164  "Non-NIL means that simple-bit-vectors whose length is less than
    165165the value of this variable are printed even if *PRINT-ARRAY* is false.
    166166This variable is not part of standard Common Lisp.")
    167167
    168 (defvar *print-string-length* nil
     168(def-standard-initial-binding *print-string-length* nil
    169169  "Non-NIL means that strings longer than this are printed
    170170using abbreviated #<string ...> syntax.
    171171This variable is not part of standard Common Lisp.")
    172172
    173 (defvar *print-escape* t
     173(def-standard-initial-binding *print-escape* t
    174174  "Non-NIL means that the lisp printer should -attempt- to output
    175175expressions `readably.'  When NIL the attempts to produce output
     
    177177are represented by the characters of their namestring.)")
    178178
    179 (defvar *print-pretty* nil
     179(def-standard-initial-binding *print-pretty* nil
    180180  "Non-NIL means that the lisp printer should insert extra
    181181indentation and newlines to make output more readable and `prettier.'")
    182182
    183 (defvar *print-base* 10.
     183(def-standard-initial-binding *print-base* 10.
    184184  "The output base for integers and rationals.
    185185Must be an integer between 2 and 36.")
    186186
    187 (defvar *print-radix* nil
     187(def-standard-initial-binding *print-radix* nil
    188188  "Non-NIL means that the lisp printer will explicitly indicate
    189189the output radix (see *PRINT-BASE*) which is used to print
    190190integers and rational numbers.")
    191191
    192 (defvar *print-level* nil
     192(def-standard-initial-binding *print-level* nil
    193193  "Specifies the depth at which printing of lisp expressions
    194194should be truncated.  NIL means that no such truncation should occur.
     
    197197See also *PRINT-LENGTH*")
    198198
    199 (defvar *print-length* nil
     199(def-standard-initial-binding *print-length* nil
    200200  "Specifies the length at which printing of lisp expressions
    201201should be truncated.  NIL means that no such truncation should occur.
     
    204204See also *PRINT-LEVEL*")
    205205
    206 (defvar *print-circle* nil
     206(def-standard-initial-binding *print-circle* nil
    207207  "Non-NIL means that the lisp printer should attempt to detect
    208208circular structures, indicating them by using \"#n=\" and \"#n#\" syntax.
     
    210210output circular structure may cause unbounded output.")
    211211
    212 (defvar *print-case* ':upcase
     212(def-standard-initial-binding *print-case* ':upcase
    213213  "Specifies the alphabetic case in which symbols should
    214214be printed.  Possible values include :UPCASE, :DOWNCASE and :CAPITALIZE") ; and :StuDLy
    215215
    216 (defvar *print-array* t
     216(def-standard-initial-binding *print-array* t
    217217  "Non-NIL means that arrays should be printed using \"#(...)\" or
    218218\"=#nA(...)\" syntax to show their contents.
     
    221221and *PRINT-SIMPLE-BIT-VECTOR*")
    222222
    223 (defvar *print-gensym* t
     223(def-standard-initial-binding *print-gensym* t
    224224  "Non-NIL means that symbols with no home package should be
    225225printed using \"#:\" syntax.  NIL means no prefix is printed.")
    226226
    227 (defvar *print-readably* nil
     227(def-standard-initial-binding *print-readably* nil
    228228  "Non-NIL means that attempts to print unreadable objects
    229229   signal PRINT-NOT-READABLE errors.  NIL doesn't.")
    230230
    231 (defvar *PRINT-RIGHT-MARGIN* nil
     231(def-standard-initial-binding *PRINT-RIGHT-MARGIN* nil
    232232  "+#/NIL the right margin for pretty printing")
    233233
    234 (defvar *PRINT-MISER-WIDTH* 40.
     234(def-standard-initial-binding *PRINT-MISER-WIDTH* 40.
    235235  "+#/NIL miser format starts when there is less than this width left")
    236236
    237 (defvar *PRINT-LINES* nil
     237(def-standard-initial-binding *PRINT-LINES* nil
    238238  "+#/NIL truncates printing after # lines")
    239239
    240 (defvar *DEFAULT-RIGHT-MARGIN* 70
     240(def-standard-initial-binding *DEFAULT-RIGHT-MARGIN* 70
    241241  "Controls default line length;  Must be a non-negative integer")
    242242
    243 (defvar *PRINT-PPRINT-DISPATCH* nil) ; We have to support this.
     243(def-standard-initial-binding *PRINT-PPRINT-DISPATCH* nil) ; We have to support this.
    244244
    245245(defvar *xp-current-object* nil)  ; from xp
  • release/1.6/source/level-1/l1-lisp-threads.lisp

    r14119 r14381  
    852852    (if (= i n)
    853853      (return p))))
     854
     855(defun nth-function-frame (n start-frame context)
     856  (declare (fixnum n))
     857  (do* ((p start-frame (parent-frame p context))
     858        (i -1)
     859        (q (last-frame-ptr context)))
     860       ((or (null p) (eq p q) (%stack< q p context)))
     861    (declare (fixnum i))
     862    (when (function-frame-p p context)
     863      (incf i)
     864      (if (= i n)
     865        (return p)))))
    854866
    855867;;; True if the object is in one of the heap areas
  • release/1.6/source/level-1/l1-processes.lisp

    r14154 r14381  
    371371          (let* ((*current-process* process))
    372372            (add-to-all-processes process)
    373             (multiple-value-bind (syms values)
    374                 (initial-bindings (process-initial-bindings process))
    375               (progv syms values
    376                 (setq *whostate* "Active")
    377                 (run-process-initial-form process initial-form)))))
     373            (with-initial-bindings (process-initial-bindings process)
     374              (setq *whostate* "Active")
     375              (run-process-initial-form process initial-form))))
    378376      process
    379377      initial-form)
  • release/1.6/source/level-1/l1-reader.lisp

    r13978 r14381  
    21832183;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    21842184
    2185 (defvar *read-eval* t "When nil, #. signals an error.")
     2185(def-standard-initial-binding *read-eval* t "When nil, #. signals an error.")
     2186(def-standard-initial-binding *read-default-float-format* 'single-float)
     2187
     2188(def-standard-initial-binding *read-suppress* nil
     2189  "Suppress most interpreting in the reader when T.")
     2190
     2191(def-standard-initial-binding *read-base* 10.
     2192  "the radix that Lisp reads numbers in")
     2193
    21862194(defvar %read-objects% nil)
    21872195(defvar %keep-whitespace% nil)
  • release/1.6/source/level-1/l1-readloop-lds.lisp

    r14351 r14381  
    102102(define-toplevel-command :break r () "list restarts" (list-restarts))
    103103
    104 (define-toplevel-command :break set (n frame value) "Set <n>th item of frame <frame> to <value>"
    105   (let* ((frame-sp (nth-raw-frame frame *break-frame* nil)))
    106     (if frame-sp
    107         (toplevel-print (list (set-nth-value-in-frame frame-sp n nil value)))
    108         (format *debug-io* "No frame with number ~D~%" frame))))
    109104
    110105(define-toplevel-command :break nframes ()
    111106  "print the number of stack frames accessible from this break loop"
    112107  (do* ((p *break-frame* (parent-frame p nil))
    113         (i 0 (1+ i))
     108        (i 0 )
    114109        (last (last-frame-ptr)))
    115       ((eql p last) (toplevel-print (list i)))))
     110      ((eql p last) (toplevel-print (list i)))
     111    (declare (fixnum i))
     112    (when (function-frame-p p nil)
     113      (incf i))))
    116114
    117115(define-toplevel-command :global ? () "help"
     
    149147
    150148(define-toplevel-command :break return-from-frame (i &rest values) "Return VALUES from the I'th stack frame"
    151   (let* ((frame-sp (nth-raw-frame  i *break-frame* nil)))
     149  (let* ((frame-sp (nth-function-frame  i *break-frame* nil)))
    152150    (if frame-sp
    153151      (apply #'return-from-frame frame-sp values))))
    154152
    155153(define-toplevel-command :break apply-in-frame (i function &rest args) "Applies FUNCTION to ARGS in the execution context of the Ith stack frame"
    156   (let* ((frame-sp (nth-raw-frame  i *break-frame* nil)))
     154  (let* ((frame-sp (nth-function-frame  i *break-frame* nil)))
    157155    (if frame-sp
    158156      (apply-in-frame frame-sp function args))))
     
    167165
    168166(define-toplevel-command :break v (n frame-number) "Return value <n> in frame <frame-number>"
    169   (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
     167  (let* ((frame-sp (nth-function-frame frame-number *break-frame* nil)))
    170168    (if frame-sp
    171169      (toplevel-print (list (nth-value-in-frame frame-sp n nil))))))
    172170
    173171(define-toplevel-command :break arg (name frame-number) "Return value of argument named <name> in frame <frame-number>"
    174   (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
     172  (let* ((frame-sp (nth-function-frame frame-number *break-frame* nil)))
    175173    (when frame-sp
    176174      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
     
    184182
    185183(define-toplevel-command :break set-arg (name frame-number new) "Set value of argument named <name> in frame <frame-number> to value <new>."
    186   (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
     184  (let* ((frame-sp (nth-function-frame frame-number *break-frame* nil)))
    187185    (when frame-sp
    188186      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
     
    194192(define-toplevel-command :break local (name frame-number) "Return value of local denoted by <name> in frame <frame-number> <name> can either be a symbol - in which case the most recent
    195193binding of that symbol is used - or an integer index into the frame's set of local bindings."
    196   (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
     194  (let* ((frame-sp (nth-function-frame frame-number *break-frame* nil)))
    197195    (when frame-sp
    198196      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
     
    206204
    207205(define-toplevel-command :break set-local (name frame-number new) "Set value of argument denoted <name> (see :LOCAL) in frame <frame-number> to value <new>."
    208   (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
     206  (let* ((frame-sp (nth-function-frame frame-number *break-frame* nil)))
    209207    (when frame-sp
    210208      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
     
    225223(define-toplevel-command :break function (frame-number)
    226224  "Returns the function invoked in backtrace frame <frame-number>.  This may be useful for, e.g., disassembly"
    227   (let* ((cfp (nth-raw-frame frame-number *break-frame* nil)))
     225  (let* ((cfp (nth-function-frame frame-number *break-frame* nil)))
    228226    (when (and cfp (not (catch-csp-p cfp nil)))
    229227      (let* ((function (cfp-lfun cfp)))
  • release/1.6/source/level-1/l1-sockets.lisp

    r14153 r14381  
    15191519(defmethod stream-io-error ((stream socket) errno where)
    15201520  (socket-error stream where errno))
     1521
     1522
     1523;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1524
     1525(defun snarf-url (url &key max-redirects (user-agent "CCL") &aux conn)
     1526  "GET the contents of the url as a (VECTOR (UNSIGNED-BYTE 8))"
     1527  (labels ((is-prefix (prefix string) (eql (length prefix) (string-lessp prefix string)))
     1528           (header (prefix lines)
     1529             (let ((line (find prefix lines :test #'is-prefix)))
     1530               (and line (string-trim ccl::wsp (subseq line (length prefix))))))
     1531           (header-value (prefix lines)
     1532             (let ((line (find prefix lines :test #'is-prefix)))
     1533               (and line (parse-integer line :start (length prefix)))))
     1534           (split-url (string)
     1535             (if (is-prefix "/" string)
     1536               (list nil 80 string)
     1537               (if (not (is-prefix "http://" string))
     1538                 (error "Unknown scheme in ~s" string)
     1539                 (let* ((start (length "http://"))
     1540                        (end (length string))
     1541                        (ppos (or (position #\/ string :start start) end))
     1542                        (hend (or (position #\: string :start start :end ppos) ppos)))
     1543                   (list (subseq string start hend)
     1544                         (if (< hend ppos) (parse-integer string :start (1+ hend) :end ppos) 80)
     1545                         (if (< ppos end) (subseq string ppos) "/"))))))
     1546           (read-header (conn)
     1547             (loop as lines = (loop for line = (read-line conn nil)
     1548                                    until (= 0 (length line)) ; eof or empty line
     1549                                    collect line)
     1550                   as status = (let ((status-line (pop lines)))
     1551                                 (or (parse-integer status-line
     1552                                                    :start (position #\Space status-line)
     1553                                                    :junk-allowed t)
     1554                                     0))
     1555                   while (= status 100)
     1556                   finally (return (values lines status)))))
     1557    (unwind-protect
     1558       (loop with original-url = url
     1559             with redirects = (or max-redirects 20)
     1560             with (host port path) = (split-url original-url)
     1561             do (setq conn (make-socket :remote-host host
     1562                                        :remote-port port
     1563                                        :external-format '(:character-encoding :us-ascii
     1564                                                           :line-termination :crlf)))
     1565             do (format conn "GET ~a HTTP/1.1~%Host: ~a:~d~%Connection: close~%User-Agent: ~a~2%"
     1566                        path host port user-agent)
     1567             do (finish-output conn)
     1568             do (multiple-value-bind (header-lines status) (read-header conn)
     1569                  (when (= status 200)
     1570                    (let ((encoding (header "transfer-encoding:" header-lines)))
     1571                      ;; Here would recognize chunked encoding if cared about that...
     1572                      (when (and encoding (not (string-equal encoding "identity")))
     1573                        (error "Unsupported encoding ~s" encoding)))
     1574                    (return
     1575                      (let* ((count (header-value "content-length:" header-lines)))
     1576                        (if count
     1577                            (let ((vec (make-array count :element-type '(unsigned-byte 8))))
     1578                              (loop for i from 0 below count
     1579                                    do (setf (aref vec i) (read-byte conn)))
     1580                              vec)
     1581                            (let ((vec (make-array 1000
     1582                                                   :element-type '(unsigned-byte 8)
     1583                                                   :fill-pointer 0
     1584                                                   :adjustable t)))
     1585                              (loop for byte = (read-byte conn nil) while byte
     1586                                    do (vector-push-extend byte vec))
     1587                              (subseq vec 0 (length vec)))))))
     1588                  (unless (and (<= 300 status 399) (<= 0 (decf redirects)))
     1589                    (if (<= 300 status 399)
     1590                        (error "Too many redirects")
     1591                        (error "Unknown response ~s" status)))
     1592                  (let* ((new (or (header "location:" header-lines)
     1593                                  (error "Missing Location: header"))))
     1594                    (destructuring-bind (new-host new-port new-path) (split-url new)
     1595                      (when new-host
     1596                        (setq host new-host port new-port))
     1597                      (setq path new-path))
     1598                    (close conn)
     1599                    (setq conn nil)))
     1600      (when conn (close conn))))))
  • release/1.6/source/level-1/l1-streams.lisp

    r14255 r14381  
    64306430              (setf (fill-pointer displaced) newpos)))
    64316431          newpos)
    6432         (report-bad-arg newpos `(integer 0 `(,(- (the fixnum (io-buffer-limit outbuf)) origin)))))
     6432        (report-bad-arg newpos `(integer 0 (,(- (the fixnum (io-buffer-limit outbuf)) origin)))))
    64336433      (the fixnum (- (the fixnum (io-buffer-idx outbuf)) origin)))))
    64346434
     
    65856585          (setf (io-buffer-idx inbuf) (the fixnum (+ origin (the fixnum newpos))))
    65866586          newpos)
    6587         (report-bad-arg newpos `(integer 0 `(,(- (the fixnum (io-buffer-limit inbuf)) origin)))))
     6587        (report-bad-arg newpos `(integer 0 (,(- (the fixnum (io-buffer-limit inbuf)) origin)))))
    65886588      (the fixnum (- (the fixnum (io-buffer-idx inbuf)) origin)))))
    65896589
  • release/1.6/source/level-1/l1-unicode.lisp

    r13067 r14381  
    47984798        (array-data-and-offset vector)
    47994799      (unless (= (typecode array) target::subtag-u8-vector)
    4800         (report-bad-arg vector '(array (unsgigned-byte 8) (*))))
     4800        (report-bad-arg vector '(array (unsigned-byte 8) (*))))
    48014801      (setq vector array
    48024802            start (+ start offset)
  • release/1.6/source/lib/encapsulate.lisp

    r13067 r14381  
    718718       ,@(and dynamic-extent-arglist '((declare (dynamic-extent arglist))))
    719719       (declare (ftype function ,def))
     720       (declare (ignorable arglist))
    720721       (let ()
    721722         ,(ecase
  • release/1.6/source/lib/hash.lisp

    r13067 r14381  
    313313        (unlock-rwlock lock)))))
    314314
    315 
    316 
    317              
    318 
    319 #+not-yet
    320 (progn
    321 ;;;;;;;;;;;;;
    322 ;;
    323 ;; Replacement for population
    324 ;;
    325 (def-accessors (weak-table) %svref
    326   nil                                   ; 'weak-table
    327   weak-table.vector                     ; a $v_nhash vector
    328   weak-table.index                      ; index for next entry
    329   weak-table.grow-threshold             ; number of entries left in vector
    330   )
    331 
    332 (defun make-weak-table (&optional (size 20))
    333   (%istruct 'weak-table
    334             (%cons-nhash-vector
    335              size (+ (ash 1 $nhash_weak_bit)))
    336             0
    337             size))
    338 
    339 (defun weak-table-p (weak-table)
    340   (istruct-typep weak-table 'weak-table))
    341 
    342 (setf (type-predicate 'weak-table) 'weak-table-p)
    343 
    344 (defun weak-table-count (weak-table)
    345   (setq weak-table (require-type weak-table 'weak-table))
    346   (- (weak-table.index weak-table)
    347      (nhash.vector.weak-deletions-count (weak-table.vector weak-table))))
    348 
    349 (defun weak-table-push (key weak-table &optional value)
    350   (setq weak-table (require-type weak-table 'weak-table))
    351   (let ((thresh (weak-table.grow-threshold weak-table))
    352         (vector (weak-table.vector weak-table))
    353         (index (weak-table.index weak-table)))
    354     (declare (fixnum thresh index))
    355     (if (> thresh 0)
    356       (progn
    357         (lap-inline (index)
    358           (:variable vector key value)
    359           (move.l (varg vector) atemp0)
    360           (lea (atemp0 arg_z.l $nhash_data) atemp0)
    361           (move.l (varg key) atemp0@+)
    362           (move.l (varg value) @atemp0))
    363         (setf (weak-table.index weak-table) (the fixnum (1+ index))
    364               (weak-table.grow-threshold weak-table) (the fixnum (1- thresh)))
    365         value)
    366       (let ((deletions (nhash.vector.weak-deletions-count vector)))
    367         (declare (fixnum deletions))
    368         (if (> deletions 0)
    369           ; GC deleted some entries, we can compact the table
    370           (progn
    371             (lap-inline (index)
    372               (:variable vector)
    373               (getint arg_z)            ; length
    374               (move.l (varg vector) atemp0)
    375               (lea (atemp0 $nhash_data) atemp0)
    376               (move.l atemp0 atemp1)
    377               (move.l ($ $undefined) da)
    378               ; Find the first deleted entry
    379               (dbfloop.l arg_z
    380                 (if# (ne (cmp.l @atemp0 da))
    381                   (add.l ($ 1) arg_z)
    382                   (bra @move))
    383                 (add.w ($ 8) atemp0))
    384               ; copy the rest of the table up
    385               @move
    386               (dbfloop.l arg_z
    387                 (move.l atemp0@+ db)
    388                 (if# (eq (cmp.l db da))
    389                   (add.w ($ 4) atemp0)
    390                  else#
    391                   (move.l db atemp1@+)
    392                   (move.l atemp0@+ atemp1@+)))
    393               ; Write over the newly emptied part of the table
    394               (while# (ne (cmp.l atemp0 atemp1))
    395                 (move.l da @atemp1)
    396                 (add.l ($ 8) atemp1)))
    397             (setf (nhash.vector.weak-deletions-count vector) 0
    398                   (weak-table.index weak-table) (the fixnum (- index deletions))
    399                   (weak-table.grow-threshold weak-table) (the fixnum (+ thresh deletions)))
    400             (weak-table-push key weak-table value))
    401           ; table is full.  Grow it by a factor of 1.5
    402           (let* ((new-size (+ index (the fixnum (ash (the fixnum (1+ index)) -1))))
    403                  (new-vector (%cons-nhash-vector new-size (ash 1 $nhash_weak_bit))))
    404             (declare (fixnum new-size))
    405             (lap-inline (index)
    406               (:variable vector new-vector count)
    407               (move.l (varg vector) atemp0)
    408               (move.l (varg new-vector) atemp1)
    409               (lea (atemp0 $nhash_data) atemp0)
    410               (lea (atemp1 $nhash_data) atemp1)
    411               (getint arg_z)            ; table length
    412               (dbfloop.l arg_z
    413                 (move.l atemp0@+ atemp1@+)
    414                 (move.l atemp0@+ atemp1@+)))
    415             (setf (weak-table.vector weak-table) new-vector
    416                   (weak-table.grow-threshold weak-table) (the fixnum (- new-size index)))
    417             ; It's possible that GC deleted some entries while consing the new vector
    418             (setf (nhash.vector.weak-deletions-count new-vector)
    419                   (nhash.vector.weak-deletions-count vector))
    420             (weak-table-push key weak-table value)))))))
    421 
    422 ; function gets two args: key & value
    423 (defun map-weak-table (function weak-table)
    424   (setq weak-table (require-type weak-table 'weak-table))
    425   (let* ((vector (weak-table.vector weak-table))
    426          (index (weak-table.index weak-table))
    427          (flags (nhash.vector.flags vector)))
    428     (unwind-protect
    429       (progn
    430         (setf (nhash.vector.flags vector) 0)    ; disable deletion by GC
    431         (lap-inline ()
    432           (:variable function vector index)
    433           (while# (gt (move.l (varg index) da))
    434             (sub.l '1 da)
    435             (move.l da (varg index))
    436             (move.l (varg vector) atemp0)
    437             (move.l (atemp0 da.l $nhash_data) arg_y)
    438             (if# (ne (cmp.w ($ $undefined) arg_y))
    439               (move.l (atemp0 da.l (+ $nhash_data 4)) arg_z)
    440               (set_nargs 2)
    441               (move.l (varg function) atemp0)
    442               (jsr_subprim $sp-funcall))))
    443         nil)
    444       (setf (nhash.vector.flags vector) flags))))
    445 
    446 ; function gets one arg, the key
    447 (defun map-weak-table-keys (function weak-table)
    448   (flet ((f (key value)
    449            (declare (ignore value))
    450            (funcall function key)))
    451     (declare (dynamic-extent #'f))
    452     (map-weak-table #'f weak-table)))
    453    
    454 ) ; #+not-yet
    455 
    456315; end
  • release/1.6/source/lib/macros.lisp

    r14351 r14381  
    264264          ,@(if ret `((progn (setq ,varsym nil) ,ret))))))))
    265265
    266 (defmacro report-bad-arg (&rest args)
    267   `(values (%badarg ,@args)))
     266(defmacro report-bad-arg (&whole w thing typespec &environment env)
     267  (when (quoted-form-p typespec)
     268    (unless (ignore-errors (specifier-type-if-known (cadr typespec) env))
     269      (warn "Unknown type specifier ~s in ~s." (cadr typespec) w)))
     270  `(values (%badarg ,thing ,typespec)))
    268271
    269272(defmacro %cons-restart (name action report interactive test)
     
    38543857(defmacro int-errno-ffcall (entry &rest args)
    38553858  `(int-errno-call (ff-call ,entry ,@args)))
     3859
     3860(defmacro with-initial-bindings (bindings &body body)
     3861  (let* ((syms (gensym))
     3862         (values (gensym)))
     3863    `(multiple-value-bind (,syms ,values)
     3864        (initial-bindings ,bindings)
     3865      (progv ,syms ,values ,@body))))
     3866
     3867(defmacro with-standard-initial-bindings (&body body)
     3868  `(with-initial-bindings (standard-initial-bindings) ,@body))
     3869
  • release/1.6/source/lib/sequences.lisp

    r14119 r14381  
    485485          (list
    486486           (dolist (elt seq)
    487              (setf (schar result out) elt))))))))
     487             (setf (schar result out) elt)
     488             (incf out))))))))
    488489
    489490;This one doesn't choke on circular lists, doesn't cons as much, and is
  • release/1.6/source/lisp-kernel/arm-exceptions.c

    r14354 r14381  
    187187    }
    188188    if (IS_SET_ALLOCPTR_HEADER_RD(instr)) {
    189       header_of(cur_allocptr) == xpGPR(xp,RD_field(instr));
     189      header_of(cur_allocptr) = xpGPR(xp,RD_field(instr));
    190190    } else if (IS_SET_ALLOCPTR_RESULT_RD(instr)) {
    191191      xpGPR(xp,RD_field(instr)) = cur_allocptr;
  • release/1.6/source/lisp-kernel/arm-gc.c

    r14269 r14381  
    10081008
    10091009  int r;
    1010   /* registers >= fn should be tagged and marked as roots.
    1011      the PC, and LR should be treated as "pc_locatives".
     1010  /* registers between arg_z and Rfn should be tagged and marked as
     1011     roots.  the PC, and LR should be treated as "pc_locatives".
    10121012
    10131013     In general, marking a locative is more expensive than marking
     
    12961296  int r;
    12971297
    1298   /* registers >= fn should be tagged and forwarded as roots.
     1298  /* registers between arg_z and Rfn should be tagged and forwarded as roots.
    12991299     the PC and LR should be treated as "locatives".
    13001300     */
  • release/1.6/source/objc-bridge/objc-support.lisp

    r14266 r14381  
    108108
    109109
    110 (defvar *class-init-keywords* (make-hash-table))
     110(defvar *class-init-keywords* (make-hash-table :test #'eq))
    111111
    112112(defun process-init-message (message-info)
  • release/1.6/source/tools/asdf.lisp

    r14333 r14381  
    7272  (defvar *asdf-version* nil)
    7373  (defvar *upgraded-p* nil)
    74   (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
    75           (subseq "VERSION:2.009" (1+ (length "VERSION")))) ; same as 2.134
     74  (let* ((asdf-version "2.010") ;; same as 2.146
    7675         (existing-asdf (fboundp 'find-system))
    7776         (existing-version *asdf-version*)
     
    7978    (unless (and existing-asdf already-there)
    8079      (when existing-asdf
    81         (format *trace-output*
     80        (format *error-output*
    8281                "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
    8382                existing-version asdf-version))
     
    171170                   :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
    172171                   :fmakunbound ',(append fmakunbound))))
    173           (unlink-package :asdf-utilities)
    174172          (pkgdcl
    175173           :asdf
     174           :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
    176175           :use (:common-lisp)
    177176           :redefined-functions
     
    306305            #:component-name-to-pathname-components
    307306            #:split-name-type
     307            #:subdirectories
    308308            #:truenamize
    309309            #:while-collecting)))
     
    534534         (defaults (pathname defaults))
    535535         (directory (pathname-directory specified))
    536          #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory))
     536         (directory
     537          (cond
     538            #-(or sbcl cmu)
     539            ((stringp directory) `(:absolute ,directory) directory)
     540            #+gcl
     541            ((and (consp directory) (stringp (first directory)))
     542             `(:absolute ,@directory))
     543            ((or (null directory)
     544                 (and (consp directory) (member (first directory) '(:absolute :relative))))
     545             directory)
     546            (t
     547             (error "Unrecognized directory component ~S in pathname ~S" directory specified))))
    537548         (name (or (pathname-name specified) (pathname-name defaults)))
    538549         (type (or (pathname-type specified) (pathname-type defaults)))
     
    543554               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
    544555      (multiple-value-bind (host device directory unspecific-handler)
    545           (#-gcl ecase #+gcl case (first directory)
     556          (ecase (first directory)
    546557            ((nil)
    547558             (values (pathname-host defaults)
     
    560571                         (append (pathname-directory defaults) (cdr directory))
    561572                         directory)
    562                      (unspecific-handler defaults)))
    563             #+gcl
    564             (t
    565              (assert (stringp (first directory)))
    566              (values (pathname-host defaults)
    567                      (pathname-device defaults)
    568                      (append (pathname-directory defaults) directory)
    569573                     (unspecific-handler defaults))))
    570574        (make-pathname :host host :device device :directory directory
     
    621625          (values name type)))))
    622626
    623 (defun* component-name-to-pathname-components (s &optional force-directory)
     627(defun* component-name-to-pathname-components (s &key force-directory force-relative)
    624628  "Splits the path string S, returning three values:
    625629A flag that is either :absolute or :relative, indicating
     
    638642pathnames."
    639643  (check-type s string)
     644  (when (find #\: s)
     645    (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s))
    640646  (let* ((components (split-string s :separator "/"))
    641647         (last-comp (car (last components))))
     
    643649        (if (equal (first components) "")
    644650            (if (equal (first-char s) #\/)
    645                 (values :absolute (cdr components))
     651                (progn
     652                  (when force-relative
     653                    (error "absolute pathname designator not allowed: ~S" s))
     654                  (values :absolute (cdr components)))
    646655                (values :relative nil))
    647656          (values :relative components))
     
    687696Note that this does _not_ check to see that PATHNAME points to an
    688697actually-existing directory."
    689   (flet ((check-one (x)
    690            (member x '(nil :unspecific "") :test 'equal)))
    691     (and (check-one (pathname-name pathname))
    692          (check-one (pathname-type pathname))
    693          t)))
     698  (when pathname
     699    (let ((pathname (pathname pathname)))
     700      (flet ((check-one (x)
     701               (member x '(nil :unspecific "") :test 'equal)))
     702        (and (not (wild-pathname-p pathname))
     703             (check-one (pathname-name pathname))
     704             (check-one (pathname-type pathname))
     705             t)))))
    694706
    695707(defun* ensure-directory-pathname (pathspec)
     
    701713    (error "Invalid pathname designator ~S" pathspec))
    702714   ((wild-pathname-p pathspec)
    703     (error "Can't reliably convert wild pathnames."))
     715    (error "Can't reliably convert wild pathname ~S" pathspec))
    704716   ((directory-pathname-p pathspec)
    705717    pathspec)
     
    774786   (pathname (unless (wild-pathname-p p)
    775787               #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
    776                #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(,it p))
     788               #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p)))
    777789               '(ignore-errors (truename p)))))))
    778790
     
    840852                         root-namestring)))
    841853    (multiple-value-bind (relative path filename)
    842         (component-name-to-pathname-components root-string t)
     854        (component-name-to-pathname-components root-string :force-directory t)
    843855      (declare (ignore relative filename))
    844856      (let ((new-base
     
    922934         "Component name: designator for a string composed of portable pathname characters")
    923935   (version :accessor component-version :initarg :version)
    924    (in-order-to :initform nil :initarg :in-order-to
    925                 :accessor component-in-order-to)
    926936   ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
    927937   ;; POIU is a parallel (multi-process build) extension of ASDF.  See
    928938   ;; http://www.cliki.net/poiu
    929939   (load-dependencies :accessor component-load-dependencies :initform nil)
    930    ;; XXX crap name, but it's an official API name!
     940   ;; In the ASDF object model, dependencies exist between *actions*
     941   ;; (an action is a pair of operation and component). They are represented
     942   ;; alists of operations to dependencies (other actions) in each component.
     943   ;; There are two kinds of dependencies, each stored in its own slot:
     944   ;; in-order-to and do-first dependencies. These two kinds are related to
     945   ;; the fact that some actions modify the filesystem,
     946   ;; whereas other actions modify the current image, and
     947   ;; this implies a difference in how to interpret timestamps.
     948   ;; in-order-to dependencies will trigger re-performing the action
     949   ;; when the timestamp of some dependency
     950   ;; makes the timestamp of current action out-of-date;
     951   ;; do-first dependencies do not trigger such re-performing.
     952   ;; Therefore, a FASL must be recompiled if it is obsoleted
     953   ;; by any of its FASL dependencies (in-order-to); but
     954   ;; it needn't be recompiled just because one of these dependencies
     955   ;; hasn't yet been loaded in the current image (do-first).
     956   ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
     957   (in-order-to :initform nil :initarg :in-order-to
     958                :accessor component-in-order-to)
    931959   (do-first :initform nil :initarg :do-first
    932960             :accessor component-do-first)
     
    10611089            :accessor system-license :initarg :license)
    10621090   (source-file :reader system-source-file :initarg :source-file
    1063                 :writer %set-system-source-file)))
     1091                :writer %set-system-source-file)
     1092   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
    10641093
    10651094;;;; -------------------------------------------------------------------------
     
    12851314        (cons (get-universal-time) system)))
    12861315
    1287 (defun* find-system-fallback (requested fallback &optional source-file)
     1316(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
    12881317  (setf fallback (coerce-name fallback)
    12891318        source-file (or source-file *compile-file-truename* *load-truename*)
     
    12921321    (let* ((registered (cdr (gethash fallback *defined-systems*)))
    12931322           (system (or registered
    1294                        (make-instance
    1295                         'system :name fallback
    1296                         :source-file source-file))))
     1323                       (apply 'make-instance 'system
     1324                              :name fallback :source-file source-file keys))))
    12971325      (unless registered
    12981326        (register-system fallback system))
     
    13001328
    13011329(defun* sysdef-find-asdf (name)
    1302   (find-system-fallback name "asdf"))
     1330  (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
    13031331
    13041332
     
    13711399    (string
    13721400     (multiple-value-bind (relative path filename)
    1373          (component-name-to-pathname-components name (eq type :directory))
     1401         (component-name-to-pathname-components name :force-directory (eq type :directory)
     1402                                                :force-relative t)
    13741403       (multiple-value-bind (name type)
    13751404           (cond
     
    16011630
    16021631(defun* do-one-dep (operation c collect required-op required-c required-v)
    1603   ;; this function is a thin, error-handling wrapper around
    1604   ;; %do-one-dep.  Returns a partial plan per that function.
     1632  ;; this function is a thin, error-handling wrapper around %do-one-dep.
     1633  ;; Collects a partial plan per that function.
    16051634  (loop
    16061635    (restart-case
     
    16131642        :test
    16141643        (lambda (c)
    1615           #|
    1616           (print (list :c1 c (typep c 'missing-dependency)))
    1617           (when (typep c 'missing-dependency)
    1618           (print (list :c2 (missing-requires c) required-c
    1619           (equalp (missing-requires c)
    1620           required-c))))
    1621           |#
    16221644          (or (null c)
    16231645              (and (typep c 'missing-dependency)
     
    18331855        (get-universal-time)))
    18341856
    1835 (declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys)
     1857(declaim (ftype (function ((or pathname string)
     1858                           &rest t &key (:output-file t) &allow-other-keys)
    18361859                          (values t t t))
    18371860                compile-file*))
     
    21532176                            defsystem-depends-on &allow-other-keys)
    21542177      options
    2155     (let ((component-options (remove-keys '(:defsystem-depends-on :class) options)))
     2178    (let ((component-options (remove-keys '(:class) options)))
    21562179      `(progn
    21572180         ;; system must be registered before we parse the body, otherwise
     
    24582481
    24592482(defparameter *implementation-features*
    2460   '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
    2461     :corman :cormanlisp :armedbear :gcl :ecl :scl))
     2483  '((:acl :allegro)
     2484    (:lw :lispworks)
     2485    (:digitool) ; before clozure, so it won't get preempted by ccl
     2486    (:ccl :clozure)
     2487    (:corman :cormanlisp)
     2488    (:abcl :armedbear)
     2489    :sbcl :cmu :clisp :gcl :ecl :scl))
    24622490
    24632491(defparameter *os-features*
    2464   '((:windows :mswindows :win32 :mingw32)
     2492  '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
    24652493    (:solaris :sunos)
    2466     :linux ;; for GCL at least, must appear before :bsd.
    2467     :macosx :darwin :apple
     2494    (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
     2495    (:macosx :darwin :darwin-target :apple)
    24682496    :freebsd :netbsd :openbsd :bsd
    24692497    :unix))
    24702498
    24712499(defparameter *architecture-features*
    2472   '((:x86-64 :amd64 :x86_64 :x8664-target)
    2473     (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
    2474     :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc
    2475     :java-1.4 :java-1.5 :java-1.6 :java-1.7))
    2476 
     2500  '((:amd64 :x86-64 :x86_64 :x8664-target)
     2501    (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
     2502    :hppa64
     2503    :hppa
     2504    (:ppc64 :ppc64-target)
     2505    (:ppc32 :ppc32-target :ppc :powerpc)
     2506    :sparc64
     2507    (:sparc32 :sparc)
     2508    (:arm :arm-target)
     2509    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
    24772510
    24782511(defun* lisp-version-string ()
     
    24932526    #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    24942527    #+clisp (subseq s 0 (position #\space s))
    2495     #+clozure (format nil "~d.~d-fasl~d"
     2528    #+clozure (format nil "~d.~d-f~d" ; shorten for windows
    24962529                      ccl::*openmcl-major-version*
    24972530                      ccl::*openmcl-minor-version*
     
    26892722  (setf *output-translations* '())
    26902723  (values))
    2691 
    2692 (defparameter *wild-asd*
    2693   (make-pathname :directory '(:relative :wild-inferiors)
    2694                  :name :wild :type "asd" :version :newest))
    26952724
    26962725(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
     
    28732902    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
    28742903    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
    2875     ;; If we want to enable the user cache by default, here would be the place:
     2904    ;; We enable the user cache by default, and here is the place we do:
    28762905    :enable-user-cache))
    28772906
     
    30523081    (delete-file x)))
    30533082
    3054 (defun* compile-file* (input-file &rest keys &key &allow-other-keys)
    3055   (let* ((output-file (apply 'compile-file-pathname* input-file keys))
     3083(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
     3084  (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
    30563085         (tmp-file (tmpize-pathname output-file))
    30573086         (status :error))
     
    31033132     (map-all-source-files (or #+(or ecl clisp) t nil))
    31043133     (source-to-target-mappings nil))
    3105   (when (and (null map-all-source-files) #-(or ecl clisp) nil)
     3134  #+(or ecl clisp)
     3135  (when (null map-all-source-files)
    31063136    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
    31073137  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
     
    32073237;; Using ack 1.2 exclusions
    32083238(defvar *default-source-registry-exclusions*
    3209   '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
     3239  '(".bzr" ".cdv"
     3240    ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
    32103241    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    32113242    "_sgbak" "autom4te.cache" "cover_db" "_build"
     
    32343265  (setf *source-registry* '())
    32353266  (values))
     3267
     3268(defparameter *wild-asd*
     3269  (make-pathname :directory nil :name :wild :type "asd" :version :newest))
     3270
     3271(defun directory-has-asd-files-p (directory)
     3272  (and (ignore-errors
     3273         (directory (merge-pathnames* *wild-asd* directory)
     3274                    #+sbcl #+sbcl :resolve-symlinks nil
     3275                    #+ccl #+ccl :follow-links nil
     3276                    #+clisp #+clisp :circle t))
     3277       t))
     3278
     3279(defun subdirectories (directory)
     3280  (let* ((directory (ensure-directory-pathname directory))
     3281         #-cormanlisp
     3282         (wild (merge-pathnames*
     3283                #-(or abcl allegro lispworks scl)
     3284                (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
     3285                #+(or abcl allegro lispworks scl) "*.*"
     3286                directory))
     3287         (dirs
     3288          #-cormanlisp
     3289          (ignore-errors
     3290            (directory wild .
     3291              #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
     3292                    #+ccl '(:follow-links nil :directories t :files nil)
     3293                    #+clisp '(:circle t :if-does-not-exist :ignore)
     3294                    #+(or cmu scl) '(:follow-links nil :truenamep nil)
     3295                    #+digitool '(:directories t)
     3296                    #+sbcl '(:resolve-symlinks nil))))
     3297          #+cormanlisp (cl::directory-subdirs directory))
     3298         #+(or abcl allegro lispworks scl)
     3299         (dirs (remove-if-not #+abcl #'extensions:probe-directory
     3300                              #+allegro #'excl:probe-directory
     3301                              #+lispworks #'lw:file-directory-p
     3302                              #-(or abcl allegro lispworks) #'directory-pathname-p
     3303                              dirs)))
     3304    dirs))
     3305
     3306(defun collect-sub*directories (directory collectp recursep collector)
     3307  (when (funcall collectp directory)
     3308    (funcall collector directory))
     3309  (dolist (subdir (subdirectories directory))
     3310    (when (funcall recursep subdir)
     3311      (collect-sub*directories subdir collectp recursep collector))))
     3312
     3313(defun collect-sub*directories-with-asd
     3314    (directory &key
     3315     (exclude *default-source-registry-exclusions*)
     3316     collect)
     3317  (collect-sub*directories
     3318   directory
     3319   #'directory-has-asd-files-p
     3320   #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
     3321   collect))
    32363322
    32373323(defun* validate-source-registry-directive (directive)
     
    32983384  (if (not recurse)
    32993385      (funcall collect directory)
    3300       (let* ((files
    3301               (handler-case
    3302                   (directory (merge-pathnames* *wild-asd* directory)
    3303                              #+sbcl #+sbcl :resolve-symlinks nil
    3304                              #+clisp #+clisp :circle t)
    3305                 (error (c)
    3306                   (warn "Error while scanning system definitions under directory ~S:~%~A"
    3307                         directory c)
    3308                   nil)))
    3309              (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
    3310                                       :test #'equal :from-end t)))
    3311         (loop
    3312           :for dir :in dirs
    3313           :unless (loop :for x :in exclude
    3314                     :thereis (find x (pathname-directory dir) :test #'equal))
    3315           :do (funcall collect dir)))))
     3386      (collect-sub*directories-with-asd
     3387       directory :exclude exclude :collect collect)))
    33163388
    33173389(defparameter *default-source-registries*
Note: See TracChangeset for help on using the changeset viewer.