Changeset 9706


Ignore:
Timestamp:
Jun 9, 2008, 1:18:19 AM (11 years ago)
Author:
gb
Message:

Decl changes from working-0711.

Location:
branches/working-0711-perf/ccl/level-1
Files:
12 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711-perf/ccl/level-1/l1-clos-boot.lisp

    r9574 r9706  
    15001500      (dolist (class cpl)
    15011501        (let* ((ordinal (instance.hash class)))
    1502           (declare (fixnum ordinale))
     1502          (declare (fixnum ordinal))
    15031503          (when (> ordinal max)
    15041504            (setq max ordinal))))
     
    26402640
    26412641(defmethod initialize-instance ((instance standard-object) &rest initargs)
    2642   (declare (dynamic-extent ini targs))
     2642  (declare (dynamic-extent initargs))
    26432643  (apply 'shared-initialize instance t initargs))
    26442644
     
    29172917  (let* ((wrapper (instance-class-wrapper instance))
    29182918         (class (%wrapper-class wrapper))
    2919          (slotd (funcall (%wrapper-slot-id->slotd wrapper) slot-id)))
     2919         (slotd (funcall (%wrapper-slot-id->slotd wrapper) instance slot-id)))
    29202920    (if slotd
    29212921      (%maybe-std-slot-boundp-using-class class instance slotd)
     
    33393339         (new-object (allocate-instance new-class)))
    33403340    (declare (fixnum num-new-instance-slots)
    3341              (simple-vector new-instance-slots old-instance-slots))
     3341             (simple-vector new-instance-slots-vector old-instance-slots-vector))
    33423342    ;; Retain local slots shared between the new class and the old.
    33433343    (do* ((new-pos 0 (1+ new-pos))
    33443344          (new-slot-location 1 (1+ new-slot-location)))
    33453345         ((= new-pos num-new-instance-slots))
    3346       (declare (fixnum new-pos new-slot-vector-pos))
     3346      (declare (fixnum new-pos new-slot-location))
    33473347      (let* ((old-pos (position (svref new-instance-slots-vector new-pos)
    33483348                                old-instance-slots-vector :test #'eq)))
  • branches/working-0711-perf/ccl/level-1/l1-clos.lisp

    r9575 r9706  
    20692069      ;;; Let %%1st-arg-dcode deal with it.
    20702070      (%%1st-arg-dcode dt args))))
     2071(register-dcode-proto #'%%1st-arg-eql-method-hack-dcode *gf-proto*)
    20712072
    20722073(defun %%1st-two-arg-eql-method-hack-dcode (dt arg1 arg2)
     
    20752076      (funcall mf arg1 arg2)
    20762077      (%%1st-two-arg-dcode dt arg1 arg2))))
    2077 (register-dcode-proto #'reader-variable-location-dcode *gf-proto-two-arg*)
     2078(register-dcode-proto #'%%1st-two-arg-eql-method-hack-dcode *gf-proto-two-arg*)
    20782079
    20792080(defun %%one-arg-eql-method-hack-dcode (dt arg)
  • branches/working-0711-perf/ccl/level-1/l1-error-system.lisp

    r9513 r9706  
    6060                       (print-not-readable-stream c))))))
    6161
    62 (define-condition simple-warning (simple-condition warning))
     62(define-condition simple-warning (simple-condition warning) ())
    6363
    6464(define-condition compiler-warning (warning)
     
    7171  (:report report-compiler-warning))
    7272
    73 (define-condition style-warning (compiler-warning))
    74 (define-condition undefined-function-reference (style-warning))
    75 (define-condition macro-used-before-definition (compiler-warning))
    76 (define-condition invalid-arguments (style-warning))
    77 (define-condition invalid-arguments-global (style-warning))
    78 
    79 (define-condition simple-error (simple-condition error))
    80 
    81 (define-condition simple-storage-condition (simple-condition storage-condition))
    82 (define-condition stack-overflow-condition (simple-storage-condition))
     73(define-condition style-warning (compiler-warning) ())
     74(define-condition undefined-function-reference (style-warning) ())
     75(define-condition macro-used-before-definition (compiler-warning) ())
     76(define-condition invalid-arguments (style-warning) ())
     77(define-condition invalid-arguments-global (style-warning) ())
     78
     79(define-condition simple-error (simple-condition error) ())
     80
     81(define-condition simple-storage-condition (simple-condition storage-condition) ())
     82(define-condition stack-overflow-condition (simple-storage-condition) ())
    8383
    8484(define-condition invalid-memory-access (storage-condition)
     
    175175                     (type-error-expected-type c)))))
    176176
    177 (define-condition simple-type-error (simple-condition type-error))
    178 
    179 
    180 
    181 (define-condition program-error (error))
     177(define-condition simple-type-error (simple-condition type-error) ())
     178
     179
     180
     181(define-condition program-error (error) ())
    182182(define-condition simple-program-error (simple-condition program-error)
    183183  ((context :initarg :context :reader simple-program-error-context :initform nil)))
     
    190190                             :format-arguments args))))
    191191
    192 (define-condition simple-destructuring-error (simple-program-error))
     192(define-condition simple-destructuring-error (simple-program-error) ())
    193193
    194194(define-condition wrong-number-of-arguments (program-error)
     
    198198  (:report report-argument-mismatch))
    199199       
    200 (define-condition too-many-arguments (wrong-number-of-arguments))
    201 
    202 (define-condition too-few-arguments (wrong-number-of-arguments))
     200(define-condition too-many-arguments (wrong-number-of-arguments) ())
     201
     202(define-condition too-few-arguments (wrong-number-of-arguments) ())
    203203
    204204(defun report-argument-mismatch (c s)
     
    241241             (format nil "~a" c)))))
    242242
    243 (define-condition control-error (error))
     243(define-condition control-error (error) ())
    244244
    245245(define-condition cant-throw-error (control-error)
     
    478478                         operands))))))
    479479
    480 (define-condition division-by-zero (arithmetic-error))
     480(define-condition division-by-zero (arithmetic-error) ())
    481481 
    482 (define-condition floating-point-underflow (arithmetic-error))
    483 (define-condition floating-point-overflow (arithmetic-error))
    484 (define-condition floating-point-inexact (arithmetic-error))
    485 (define-condition floating-point-invalid-operation (arithmetic-error))
     482(define-condition floating-point-underflow (arithmetic-error) ())
     483(define-condition floating-point-overflow (arithmetic-error) ())
     484(define-condition floating-point-inexact (arithmetic-error) ())
     485(define-condition floating-point-invalid-operation (arithmetic-error) ())
    486486
    487487(define-condition compiler-bug (simple-error)
  • branches/working-0711-perf/ccl/level-1/l1-io.lisp

    r9485 r9706  
    718718(defun print-a-float (float stream &optional exp-p nanning)
    719719  (let ((strlen 0) (exponent-char (float-exponent-char float)))
    720     (declare (fixnum exp strlen))
     720    (declare (fixnum strlen))
    721721    (setq stream (%real-print-stream stream))
    722722    (if (and (not nanning)(nan-or-infinity-p float))
     
    724724      (multiple-value-bind (string before-pt #|after-pt|#)
    725725                           (flonum-to-string float)
    726         (declare (fixnum before-pt after-pt))
     726        (declare (fixnum before-pt #|after-pt|#))
    727727        (setq strlen (length string))
    728728        (when (minusp (float-sign float))
     
    966966        (i 0 (1+ i)))
    967967       ((= i limit))
    968     (declare (type fixnum last)) (declare (type fixnum limit) (type fixnum i))
     968    (declare (type fixnum limit) (type fixnum i))
    969969    (let* ((char (char string i))
    970970           (needs-escape? (%char-needs-escape-p char #\\ delim)))
     
    10531053                           (return nil))
    10541054                         (setq sofar c-case))))))))
    1055         (declare (dynamic-extent slashify? single-case-p))
     1055        (declare (dynamic-extent #'slashify? #'single-case-p))
    10561056        (block alice
    10571057          (let ((len (length name))
  • branches/working-0711-perf/ccl/level-1/l1-lisp-threads.lisp

    r9514 r9706  
    341341  ;; When a thread dies, it should try to clear its interrupt-pending
    342342  ;; flag.
    343   (or (not (eql 0 (%fixnum-ref tcr target::tcr.interrupt-pending)))
    344       (with-macptrs (tcrp)
    345         (%setf-macptr-to-object tcrp tcr)
    346         (ff-call
    347          (%kernel-import target::kernel-import-raise-thread-interrupt)
    348          :address tcrp
    349          :signed-fullword))))
     343  (if (eql 0 (%fixnum-ref tcr target::tcr.interrupt-pending))
     344    (%%tcr-interrupt tcr)
     345    0))
    350346
    351347
  • branches/working-0711-perf/ccl/level-1/l1-processes.lisp

    r9181 r9706  
    166166                          (allocation-quantum (default-allocation-quantum)))
    167167  "Create and return a new process."
    168   (declare (ignore flavor))
    169168  (let* ((p (make-instance
    170169             class
  • branches/working-0711-perf/ccl/level-1/l1-reader.lisp

    r9426 r9706  
    3232(defmethod print-object ((ref package-ref) stream)
    3333  (print-unreadable-object (ref stream :type t :identity t)
    34     (format stream "for ~s" (package-ref.name ref))))
     34    (format stream "for ~s [~s]" (package-ref.name ref) (package-ref.pkg ref))))
    3535
    3636;;; Maps character names to characters
     
    24102410        (let* ((string (token.string tb))
    24112411               (len (token.opos tb)))
    2412           (declare (fixnum len ndots nondots))
     2412          (declare (fixnum len))
    24132413          (if (not nondots)
    24142414            (if (= len 1)
     
    29992999  code-coverage
    30003000  ;; The actual form - useful during debugging, perhaps remove later.
    3001   form
     3001  #+debug form
    30023002  ;; For the outermost source form, a string (the text of the form).
    30033003  ;; For an inner source form, the source-note of the outer source form.
     
    30263026          (when end   (list :end  (source-note-end-pos note)))
    30273027          (when text (list :%text (%fast-compact (source-note-text note))))
    3028           (when form  (list :form (source-note-form note)))
     3028          (when form  #+debug (list :form (source-note-form note)))
    30293029          (when parent-note (list :parent-note (source-note-parent-note note)))
    30303030          (when file-name (list :file-name (source-note-file-name note)))))
     
    30533053  (print-unreadable-object (note stream :type t :identity t)
    30543054    (let ((text (and (source-note-p note) (ignore-errors (source-note-text note)))))
    3055       (when (and (null text) (code-note-form note))
    3056         (setq text (ignore-errors
    3057                     (let ((*print-circle* t))
    3058                       (format nil "~s" (code-note-form note))))))
     3055      #+debug (when (and (null text) (code-note-form note))
     3056                (setq text (ignore-errors
     3057                             (let ((*print-circle* t))
     3058                               (format nil "~s" (code-note-form note))))))
    30593059      (when (> (length text) 20)
    30603060        (let ((end (position #\Newline text :start 20)))
     
    31303130            (form (read-internal stream nil eofval nil)))
    31313131       (values form (and (neq form eofval)
    3132                          (%make-source-note :form form
     3132                         (%make-source-note #+debug :form #+debug form
    31333133                                            :file-name file-name
    31343134                                            :start-pos (+ (or start-offset 0) start)
     
    31403140      (destructuring-bind (map file-name stream-offset) (cdr recording)
    31413141        (let* ((prev (gethash form map))
    3142                (note (%make-source-note :form form
     3142               (note (%make-source-note #+debug :form #+debug form
    31433143                                        :file-name file-name
    31443144                                        :start-pos (+ stream-offset start-pos)
  • branches/working-0711-perf/ccl/level-1/l1-readloop-lds.lisp

    r9357 r9706  
    4545(define-toplevel-command
    4646    :global y (&optional p) "Yield control of terminal-input to process
    47 whose name or ID matches <p>, or to any process if <p> is null"
     47   whose name or ID matches <p>, or to any process if <p> is null"
    4848    (%%yield-terminal-to (if p (find-process p))))      ;may be nil
    4949
     
    117117
    118118(define-toplevel-command :global ? () "help"
     119  (format t "~&The following toplevel commands are available:")
     120  (when *default-integer-command*
     121    (format t "~& <n>  ~8Tthe same as (~s <n>)" (car *default-integer-command*)))
    119122  (dolist (g *active-toplevel-commands*)
    120123    (dolist (c (cdr g))
     
    124127        (if args
    125128          (format t "~& (~S~{ ~A~}) ~8T~A" command args doc)
    126           (format t "~& ~S  ~8T~A" command doc))))))
     129          (format t "~& ~S  ~8T~A" command doc)))))
     130  (format t "~&Any other form is evaluated and its results are printed out."))
    127131
    128132
     
    242246(%use-toplevel-commands :global)
    243247
     248(defparameter *toplevel-commands-dwim* t "If true, tries to interpret otherwise-erroneous toplevel
     249expressions as commands")
     250
     251(defvar *default-integer-command* nil
     252  "If non-nil, should be (keyword  min max)), causing integers between min and max to be
     253  interpreted as (keyword integer)")
     254
    244255(defun check-toplevel-command (form)
     256  (when (and *default-integer-command*
     257             (integerp form)
     258             (<= (cadr *default-integer-command*) form (caddr *default-integer-command*)))
     259    (setq form `(,(car *default-integer-command*) ,form)))
    245260  (let* ((cmd (if (consp form) (car form) form))
    246261         (args (if (consp form) (cdr form))))
    247     (if (keywordp cmd)
     262    (when (or (keywordp cmd)
     263              (and *toplevel-commands-dwim*
     264                   (non-nil-symbol-p cmd)
     265                   (not (if (consp form) (fboundp cmd) (boundp cmd)))
     266                   ;; Use find-symbol so don't make unneeded keywords.
     267                   (setq cmd (find-symbol (symbol-name cmd) :keyword))))
     268      (when (eq cmd :help) (setq cmd :?))
    248269      (dolist (g *active-toplevel-commands*)
    249         (when
    250             (let* ((pair (assoc cmd (cdr g))))
    251               (if pair
    252                 (progn (apply (cadr pair) args)
    253                        t)))
    254           (return t))))))
     270        (let* ((pair (assoc cmd (cdr g))))
     271          (when pair
     272            (apply (cadr pair) args)
     273            (return t)))))))
    255274
    256275(defparameter *quit-on-eof* nil)
     
    545564(defvar *break-frame* nil "frame-pointer arg to break-loop")
    546565(defvar *break-loop-when-uninterruptable* t)
     566(defvar *show-restarts-on-break* #+ccl-0711 t #-ccl-0711 nil)
    547567
    548568(defvar *error-reentry-count* 0)
     
    591611           (*backtrace-contexts* (cons context *backtrace-contexts*)))
    592612      (with-toplevel-commands :break
    593         (if *continuablep*
    594           (let* ((*print-circle* *error-print-circle*)
    595                  (*print-level* *backtrace-print-level*)
    596                  (*print-length* *backtrace-print-length*)
     613        (if *show-restarts-on-break*
     614          (let ((*print-circle* *error-print-circle*)
     615                (*print-level* *backtrace-print-level*)
     616                (*print-length* *backtrace-print-length*)
    597617                                        ;(*print-pretty* nil)
    598                  (*print-array* nil))
    599             (format t "~&> Type :GO to continue, :POP to abort, :R for a list of available restarts.")
    600             (format t "~&> If continued: ~A~%" continue))
    601           (format t "~&> Type :POP to abort, :R for a list of available restarts.~%"))
     618                (*print-array* nil))
     619            (format t "~&> Type :POP to abort, or :C <n> to invoke one of the following restarts:")
     620            (let* ((r (apply #'vector (compute-restarts *break-condition*))))
     621              (dotimes (i (length r) (terpri))
     622                (format t "~&~d. ~a" i (svref r i)))))
     623          (if *continuablep*
     624            (let* ((*print-circle* *error-print-circle*)
     625                   (*print-level* *backtrace-print-level*)
     626                   (*print-length* *backtrace-print-length*)
     627                                        ;(*print-pretty* nil)
     628                   (*print-array* nil))
     629              (format t "~&> Type :GO to continue, :POP to abort, :R for a list of available restarts.")
     630              (format t "~&> If continued: ~A~%" continue))
     631            (format t "~&> Type :POP to abort, :R for a list of available restarts.~%")))
    602632        (format t "~&> Type :? for other options.")
    603633        (terpri)
  • branches/working-0711-perf/ccl/level-1/l1-readloop.lisp

    r9516 r9706  
    312312                `(,(first form)
    313313                   ,(mapcar (lambda (binding)
    314                               (list (first binding) (macroexpand-all (second binding) env)))
     314                             
     315                              (if (listp binding)
     316                                (list (first binding) (macroexpand-all (second binding) env))
     317                                binding))
    315318                            bindings)
    316319                   ,@decls
  • branches/working-0711-perf/ccl/level-1/l1-streams.lisp

    r9485 r9706  
    512512             (count (io-buffer-count inbuf)))
    513513        (unless (= count 0)
    514           (let* ((start (max (- idx (* 5 size)) 0))
    515                  (end (min (+ idx (* 5 size)) count))
     514          (let* ((start (max (- idx (* 10 size)) 0))
     515                 (end (min (+ idx (* 10 size)) count))
    516516                 (string (make-string (funcall (character-encoding-length-of-vector-encoding-function encoding) buffer start end))))
    517517            (funcall (character-encoding-vector-decode-function encoding)
     
    23772377        (rcf (ioblock-read-char-when-locked-function ioblock)))
    23782378       ((= i end) end)
    2379     (declare (fixnum i need))
     2379    (declare (fixnum i))
    23802380    (let* ((ch (funcall rcf ioblock)))
    23812381      (if (eq ch :eof)
     
    26462646;;; strings.
    26472647(defun %ioblock-write-simple-string-with-newline-translation (ioblock string start-pos num-chars)
    2648   (declare (fixnum start-char num-chars) (simple-string string))
     2648  (declare (fixnum start-pos num-chars) (simple-string string))
    26492649  (let* ((col (ioblock-charpos ioblock))
    26502650         (wcf (ioblock-write-char-when-locked-function ioblock)))
     
    37963796
    37973797(macrolet ((synonym-method (name &rest args)
    3798             (let* ((stream (make-symbol "STREAM")))
    3799               `(defmethod ,name ((,stream synonym-stream) ,@args)
    3800                 (,name (symbol-value (synonym-stream-symbol ,stream)) ,@args)))))
    3801            (synonym-method stream-read-char)
    3802            (synonym-method stream-read-byte)
    3803            (synonym-method stream-unread-char c)
    3804            (synonym-method stream-read-char-no-hang)
    3805            (synonym-method stream-peek-char)
    3806            (synonym-method stream-listen)
    3807            (synonym-method stream-eofp)
    3808            (synonym-method stream-clear-input)
    3809            (synonym-method stream-read-line)
    3810            (synonym-method stream-read-list l c)
    3811            (synonym-method stream-read-vector v start end)
    3812            (synonym-method stream-write-char c)
    3813            ;(synonym-method stream-write-string str &optional (start 0) end)
    3814            (synonym-method stream-write-byte b)
    3815            (synonym-method stream-clear-output)
    3816            (synonym-method stream-line-column)
    3817            (synonym-method stream-set-column new)
    3818            (synonym-method stream-advance-to-column new)
    3819            (synonym-method stream-start-line-p)
    3820            (synonym-method stream-fresh-line)
    3821            (synonym-method stream-terpri)
    3822            (synonym-method stream-force-output)
    3823            (synonym-method stream-finish-output)
    3824            (synonym-method stream-write-list l c)
    3825            (synonym-method stream-write-vector v start end)
    3826            (synonym-method stream-element-type)
    3827            (synonym-method input-stream-p)
    3828            (synonym-method output-stream-p)
    3829            (synonym-method interactive-stream-p)
    3830            (synonym-method stream-direction)
    3831            (synonym-method stream-device direction)
    3832            (synonym-method stream-surrounding-characters)
    3833            (synonym-method stream-input-timeout)
    3834            (synonym-method stream-output-timeout)
    3835            (synonym-method stream-deadline))
     3798             (let* ((stream (make-symbol "STREAM"))
     3799                    (gf-name (if (atom name) name (car name)))
     3800                    (func-name (if (atom name) name (cdr name))))
     3801               `(defmethod ,gf-name ((,stream synonym-stream) ,@args)
     3802                 ,(if (and args (consp name))
     3803                      `(,func-name ,@args (symbol-value (synonym-stream-symbol ,stream)))
     3804                      `(,func-name (symbol-value (synonym-stream-symbol ,stream)) ,@args))))))
     3805  (synonym-method (stream-read-char . read-char))
     3806  (synonym-method (stream-read-byte . read-byte))
     3807  (synonym-method (stream-unread-char . unread-char) c)
     3808  (synonym-method stream-read-char-no-hang)
     3809  (synonym-method stream-peek-char)
     3810  (synonym-method stream-listen)
     3811  (synonym-method stream-eofp)
     3812  (synonym-method stream-clear-input)
     3813  (synonym-method (stream-read-line . read-line))
     3814  (synonym-method stream-read-list l c)
     3815  (synonym-method stream-read-vector v start end)
     3816  (synonym-method (stream-write-char . write-char) c)
     3817  ;;(synonym-method stream-write-string str &optional (start 0) end)
     3818  (synonym-method (stream-write-byte . write-byte) b)
     3819  (synonym-method stream-clear-output)
     3820  (synonym-method stream-line-column)
     3821  (synonym-method stream-set-column new)
     3822  (synonym-method stream-advance-to-column new)
     3823  (synonym-method stream-start-line-p)
     3824  (synonym-method stream-fresh-line)
     3825  (synonym-method stream-terpri)
     3826  (synonym-method stream-force-output)
     3827  (synonym-method stream-finish-output)
     3828  (synonym-method stream-write-list l c)
     3829  (synonym-method stream-write-vector v start end)
     3830  (synonym-method stream-element-type)
     3831  (synonym-method input-stream-p)
     3832  (synonym-method output-stream-p)
     3833  (synonym-method interactive-stream-p)
     3834  (synonym-method stream-direction)
     3835  (synonym-method stream-device direction)
     3836  (synonym-method stream-surrounding-characters)
     3837  (synonym-method stream-input-timeout)
     3838  (synonym-method stream-output-timeout)
     3839  (synonym-method stream-deadline))
     3840
     3841
    38363842
    38373843(defmethod (setf input-stream-timeout) (new (s synonym-stream))
     
    38803886
    38813887(macrolet ((two-way-input-method (name &rest args)
    3882              (let* ((stream (make-symbol "STREAM")))
    3883                `(defmethod ,name ((,stream two-way-stream) ,@args)
    3884                  (,name (two-way-stream-input-stream ,stream) ,@args))))
     3888             (let* ((stream (make-symbol "STREAM"))
     3889                    (gf-name (if (atom name) name (car name)))
     3890                    (func-name (if (atom name) name (cdr name))))
     3891               `(defmethod ,gf-name ((,stream two-way-stream) ,@args)
     3892                 ,(if (and (consp args) name)
     3893                      `(,func-name ,@args (two-way-stream-input-stream ,stream))
     3894                      `(,func-name (two-way-stream-input-stream ,stream) ,@args)))))
    38853895           (two-way-output-method (name &rest args)
    3886              (let* ((stream (make-symbol "STREAM")))
    3887                `(defmethod ,name ((,stream two-way-stream) ,@args)
    3888                  (,name (two-way-stream-output-stream ,stream) ,@args)))))
    3889   (two-way-input-method stream-read-char)
    3890   (two-way-input-method stream-read-byte)
    3891   (two-way-input-method stream-unread-char c)
     3896             (let* ((stream (make-symbol "STREAM"))
     3897                    (gf-name (if (atom name) name (car name)))
     3898                    (func-name (if (atom name) name (cdr name))))
     3899               `(defmethod ,gf-name ((,stream two-way-stream) ,@args)
     3900                 ,(if (and (consp args) name)
     3901                      `(,func-name ,@args (two-way-stream-output-stream ,stream))
     3902                      `(,func-name  (two-way-stream-output-stream ,stream) ,@args))))))
     3903  (two-way-input-method (stream-read-char . read-char))
     3904  (two-way-input-method (stream-read-byte . read-byte))
     3905  (two-way-input-method (stream-unread-char . unread-char) c)
    38923906  (two-way-input-method stream-read-char-no-hang)
    38933907  (two-way-input-method stream-peek-char)
     
    38953909  (two-way-input-method stream-eofp)
    38963910  (two-way-input-method stream-clear-input)
    3897   (two-way-input-method stream-read-line)
     3911  (two-way-input-method (stream-read-line . read-line))
    38983912  (two-way-input-method stream-read-list l c)
    38993913  (two-way-input-method stream-read-vector v start end)
    39003914  (two-way-input-method stream-surrounding-characters)
    39013915  (two-way-input-method stream-input-timeout)
    3902   (two-way-output-method stream-write-char c)
    3903   (two-way-output-method stream-write-byte b)
     3916  (two-way-output-method (stream-write-char . write-char) c)
     3917  (two-way-output-method (stream-write-byte . write-byte) b)
    39043918  (two-way-output-method stream-clear-output)
    39053919  (two-way-output-method stream-line-column)
     
    41414155    ((streams :initarg :streams :reader broadcast-stream-streams)))
    41424156
     4157
     4158;;; It probably isn't worth trying to avoid GF calls here.
    41434159(macrolet ((broadcast-method
    41444160               (op (stream &rest others )
     
    41664182             (broadcast-method stream-write-list (s l c))
    41674183             (broadcast-method stream-write-vector (s v start end)))
     4184
     4185
    41684186
    41694187(defun last-broadcast-stream (s)
     
    45474565             (end (string-input-stream-ioblock-end ioblock))
    45484566             (string (string-stream-ioblock-string ioblock)))
    4549         (subseq string (max (- idx 5) start) (min (+ idx 5) end))))))
     4567        (subseq string (max (- idx 10) start) (min (+ idx 10) end))))))
    45504568   
    45514569
  • branches/working-0711-perf/ccl/level-1/l1-symhash.lisp

    r9428 r9706  
    448448             (ivec (car itab))
    449449             (icount&limit (cdr itab)))
    450         (declare (type cons etab itab icount&limit))
     450        (declare (type cons itab icount&limit))
    451451        (setf (svref evec external-offset) (package-deleted-marker))
    452452        (setf (svref ivec internal-offset) (%symbol->symptr foundsym))
  • branches/working-0711-perf/ccl/level-1/l1-unicode.lisp

    r9576 r9706  
    7777  octets-in-string-function              ;(STRING START END)
    7878
    79   ;; Returns the number of (full) characters encoded in VECTOR, and the index
    80   ;; of the first octet not used to encode them. (The second value may be less than END).
     79  ;; Returns the number of (full) characters encoded in VECTOR, and
     80  ;; the index the index of the first octet not used to encode
     81  ;; them. (The second value may be less than END.
    8182  length-of-vector-encoding-function    ;(VECTOR START END)
    8283
     
    113114(defconstant byte-order-mark #\u+feff)
    114115(defconstant byte-order-mark-char-code (char-code byte-order-mark))
    115 (defconstant swapped-byte-order-mark #\u+fffe)
    116 (defconstant swapped-byte-order-mark-char-code (char-code swapped-byte-order-mark))
     116(defconstant swapped-byte-order-mark-char-code #xfffe)
    117117
    118118
     
    179179  (if (>= end start)
    180180    (values (- end start) end)
    181     (values 0 0)))
     181    (values 0 start)))
    182182
    183183(defun 8-bit-fixed-width-length-of-memory-encoding (pointer noctets start)
    184184  (declare (ignore pointer start))
    185   noctets)
     185  (values noctets noctets))
    186186
    187187(define-character-encoding :iso-8859-1
     
    29892989                                    (or (>= 1st-unit #xe1)
    29902990                                        (>= s1 #xa0)))
    2991                              (code-char (the fixnum
     2991                             (or (code-char (the fixnum
    29922992                                          (logior (the fixnum
    29932993                                                    (ash (the fixnum (logand 1st-unit #xf))
     
    29992999                                                            6))
    30003000                                                     (the fixnum (logand s2 #x3f)))))))
     3001                                 #\Replacement_Character)
    30013002                             #\Replacement_Character)
    30023003                           (if (< 1st-unit #xf8)
     
    30633064                   (setf (aref vector (the fixnum (+ idx 2)))
    30643065                         (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
    3065                    (setf (aref vector (the fixnum (+ idx 3))) (logand #x3f code))
     3066                   (setf (aref vector (the fixnum (+ idx 3)))
     3067                         (logior #x80 (logand #x3f code)))
    30663068                   (incf idx 4)))))))
    30673069    :vector-decode-function
     
    31413143             (nchars 0))
    31423144            ((>= i end)
    3143              (if (= i end) (values nchars i)))
     3145             (values nchars i))
    31443146         (declare (fixnum i))
    31453147         (let* ((code (aref vector i))
    3146                 (nexti (+ i (cond ((< code #x80) 1)
     3148                (nexti (+ i (cond ((< code #xc2) 1)
    31473149                                  ((< code #xe0) 2)
    31483150                                  ((< code #xf0) 3)
    3149                                   (t 4)))))
     3151                                  ((< code #xf8) 4)
     3152                                  (t 1)))))
    31503153           (declare (type (unsigned-byte 8) code))
    31513154           (if (> nexti end)
     
    33323335             (index idx))
    33333336            ((= index end) index)
    3334          (declare (fixnum i len index))
     3337         (declare (fixnum i end index))
    33353338         (let* ((1st-unit (%native-u8-ref-u16 vector index)))
    33363339           (declare (type (unsigned-byte 16) 1st-unit))
     
    33763379             (index idx))
    33773380            ((>= index end) index)
    3378          (declare (fixnum i index p))
     3381         (declare (fixnum i index end))
    33793382         (let* ((1st-unit (%get-unsigned-word pointer index)))
    33803383           (declare (type (unsigned-byte 16) 1st-unit))
     
    34963499           (index idx))
    34973500          ((= index end) index)
    3498        (declare (fixnum i len index))
     3501       (declare (fixnum i end index))
    34993502       (let* ((1st-unit (%reversed-u8-ref-u16 vector index)))
    35003503         (declare (type (unsigned-byte 16) 1st-unit))
     
    35403543           (index idx))
    35413544          ((>= index end) index)
    3542        (declare (fixnum i index p))
     3545       (declare (fixnum i index end))
    35433546       (let* ((1st-unit (%swap-u16 (%get-unsigned-word pointer index))))
    35443547         (declare (type (unsigned-byte 16) 1st-unit))
     
    36383641     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
    36393642              (fixnum idx))
     3643     (setf (%native-u8-ref-u16 vector idx) byte-order-mark-char-code)
     3644     (incf idx 2)
    36403645     (do* ((i start (1+ i)))
    36413646            ((>= i end) idx)
     
    36623667     (declare (type (simple-array (unsigned-byte 16) (*)) vector)
    36633668              (type index idx))
    3664      (let* ((swap (if (>= noctets 2)
     3669     (let* ((origin idx)
     3670            (swap (if (>= noctets 2)
    36653671                    (case (%native-u8-ref-u16 vector idx)
    36663672                      (#.byte-order-mark-char-code
     
    36703676                      (t #+little-endian-target t)))))
    36713677       (do* ((i 0 (1+ i))
    3672              (end (+ idx noctets))
     3678             (end (+ origin noctets))
    36733679             (index idx))
    36743680            ((= index end) index)
    3675          (declare (fixnum i len index))
     3681         (declare (fixnum i end index))
    36763682         (let* ((1st-unit (if swap
    36773683                            (%reversed-u8-ref-u16 vector index)
     
    36983704   (lambda (string pointer idx start end)
    36993705     (declare (fixnum idx))
     3706     ;; Output a BOM.
     3707     (setf (%get-unsigned-word pointer idx) byte-order-mark-char-code)
     3708     (incf idx 2)
    37003709     (do* ((i start (1+ i)))
    37013710          ((>= i end) idx)
     
    37033712              (highbits (- code #x10000)))
    37043713         (declare (type (mod #x110000) code)
    3705                   (fixnum p highbits))
     3714                  (fixnum highbits))
    37063715         (cond ((< highbits 0)
    3707                 (setf (%get-unsigned-word pointer idx) #+big-endian-target code #+little-endian-target (%swap-u16 code))
     3716                (setf (%get-unsigned-word pointer idx) code)
    37083717                (incf idx 2))
    37093718               (t
    3710                 (let* ((w1 (logior #xd800 (the fixnum (ash highbits -10))))
    3711                        (w2 (logior #xdc00 (the fixnum (logand highbits #x3ff)))))
    3712                   (declare (type (unsigned-byte 16) w1 w2))
    3713                 (setf (%get-unsigned-word pointer idx)
    3714                       #+big-endian-target w1 #+little-endian-target (%swap-u16 w1))
     3719                (setf (%get-unsigned-word pointer idx) (logior #xd800 (the fixnum (ash highbits -10))))
    37153720                (setf (%get-unsigned-word pointer (the fixnum (+ idx 2)))
    3716                       #+big-endian-target w2
    3717                       #+little-endian-target (%swap-u16 w2))
    3718                 (incf idx 4))))))))
     3721                      (logior #xdc00 (the fixnum (logand highbits #x3ff))))
     3722                (incf idx 4)))))))
    37193723  :memory-decode-function
    37203724  (nfunction
    37213725   utf-16-memory-decode
    37223726   (lambda (pointer noctets idx string)
    3723      (declare (fixnum nunits idx))
     3727     (declare (fixnum noctets idx))
    37243728     (let* ((swap (when (> noctets 1)
    37253729                    (case (%get-unsigned-word pointer idx)
     
    37373741             (index idx ))
    37383742            ((>= index end) index)
    3739          (declare (fixnum i index p))
     3743         (declare (fixnum i index end))
    37403744         (let* ((1st-unit (%get-unsigned-word pointer index)))
    37413745           (declare (type (unsigned-byte 16) 1st-unit))
     
    37563760             (setf (schar string i) (or char #\Replacement_Character))))))))
    37573761  :octets-in-string-function
    3758   #'utf-16-octets-in-string
     3762  (nfunction
     3763   utf-16-bom-octets-in-string
     3764   (lambda (string start end)
     3765     (+ 2 (utf-16-octets-in-string string start end))))
    37593766  :length-of-vector-encoding-function
    37603767  (nfunction
     
    37623769   (lambda (vector start end)
    37633770     (declare (type (simple-array (unsigned-byte 16) (*)) vector))
    3764      (let* ((swap (when (> end start)
     3771     (let* ((swap (when (>= end (+ start 2))
    37653772                    (case (%native-u8-ref-u16 vector start)
    37663773                      (#.byte-order-mark-char-code
     
    37753782             (nchars 0))
    37763783            ((> j end)
    3777              (if (= i end) (values nchars i)))
     3784             (values nchars i))
    37783785         (let* ((code (if swap
    37793786                        (%reversed-u8-ref-u16 vector i)
     
    37923799   utf-16-length-of-memory-encoding
    37933800   (lambda (pointer noctets start)
    3794      (let* ((swap (when (>= noctets 2)
     3801     (declare (fixnum noctets start))
     3802     (when (oddp noctets)
     3803       (setq noctets (1- noctets)))
     3804     (let* ((origin start)
     3805            (swap (when (>= noctets 2)
    37953806                    (case (%get-unsigned-word pointer (+ start start))
    37963807                      (#.byte-order-mark-char-code
    37973808                       (incf start 2)
    3798                        (decf noctets 2)
    37993809                       nil)
    38003810                      (#.swapped-byte-order-mark-char-code
    38013811                       (incf start 2)
    3802                        (decf noctets 2)
    38033812                       t)
    38043813                      (t #+little-endian-target t)))))
     3814       (declare (fixnum origin))
    38053815       (do* ((i start)
    38063816             (j (+ i 2) (+ i 2))
    3807              (end (+ start noctets))
     3817             (end (+ origin noctets))
    38083818             (nchars 0 (1+ nchars)))
    3809             ((> j end) (values nchars i))
     3819            ((> j end) (values nchars (- i origin)))
     3820         (declare (fixnum (i j end nchars)))
    38103821         (let* ((code (%get-unsigned-word pointer i)))
    38113822           (declare (type (unsigned-byte 16) code))
    38123823           (if swap (setq code (%swap-u16 code)))
    3813            (incf i
    3814                  (if (or (< code #xd800)
    3815                          (>= code #xdc00))
    3816                    2
    3817                    4)))))))
     3824           (let* ((nexti (+ i (if (or (< code #xd800)
     3825                                      (>= code #xdc00))
     3826                                2
     3827                                4))))
     3828             (declare (fixnum nexti))
     3829             (if (> nexti end)
     3830               (return (values nchars (- i origin)))
     3831               (setq i nexti))))))))
    38183832  :decode-literal-code-unit-limit #xd800
    38193833  :encode-literal-char-code-limit #x10000 
     
    38473861    (* 2 (- end start))
    38483862    0))
     3863
     3864(defun ucs-2-length-of-vector-encoding (vector start end)
     3865  (declare (ignore vector))
     3866  (let* ((noctets (max (- end start) 0)))
     3867    (values (ash noctets -1) (+ start (logandc2 noctets 1)))))
     3868
     3869(defun ucs-2-length-of-memory-encoding (pointer noctets start)
     3870  (declare (ignore pointer start))
     3871  (values (ash noctets -1) (logandc2 noctets 1)))
     3872
    38493873
    38503874
     
    38953919           (index idx (+ 2 index)))
    38963920          ((>= index end) index)
    3897        (declare (fixnum i len index))
     3921       (declare (fixnum i end index))
    38983922       (setf (schar string i)
    38993923             (or (code-char (%native-u8-ref-u16 vector index))
     
    39283952  #'ucs-2-octets-in-string
    39293953  :length-of-vector-encoding-function
    3930   (nfunction
    3931    native-ucs-2-length-of-vector-encoding
    3932    (lambda (vector start end)
    3933      (declare (ignore vector))
    3934      (do* ((i start (1+ i))
    3935            (j (+ i 2) (+ i 2))
    3936            (nchars 0 (1+ nchars)))
    3937           ((> j end) (values nchars i)))))
     3954  #'ucs-2-length-of-vector-encoding
    39383955  :length-of-memory-encoding-function
    3939   (nfunction
    3940    native-ucs-2-length-of-memory-encoding
    3941    (lambda (pointer noctets start)
    3942      (declare (ignore pointer))
    3943      (values (floor noctets 2) (+ start noctets))))
     3956  #'ucs-2-length-of-memory-encoding
    39443957  :decode-literal-code-unit-limit #x10000
    39453958  :encode-literal-char-code-limit #x10000 
     
    39944007           (index idx (+ 2 index)))
    39954008          ((>= index end) index)
    3996        (declare (fixnum i len index))
     4009       (declare (fixnum i end index))
    39974010       (setf (schar string i)
    39984011             (or (code-char (%reversed-u8-ref-u16 vector index))
     
    40274040  #'ucs-2-octets-in-string
    40284041  :length-of-vector-encoding-function
    4029   (nfunction
    4030    reversed-ucs-2-length-of-vector-encoding
    4031    (lambda (vector start end)
    4032      (declare (ignore vector))
    4033      (do* ((i start (1+ i))
    4034            (j (+ i 2) (+ i 2))
    4035            (nchars 0 (1+ nchars)))
    4036           ((> j end) (values nchars i)))))
     4042  #'ucs-2-length-of-vector-encoding
    40374043  :length-of-memory-encoding-function
    4038   (nfunction
    4039    reversed-ucs-2-length-of-memory-encoding
    4040    (lambda (pointer noctets start)
    4041      (declare (ignore pointer))
    4042      (values (floor noctets 2) (+ start noctets))))
     4044  #'ucs-2-length-of-memory-encoding
    40434045  :decode-literal-code-unit-limit #x10000
    40444046  :encode-literal-char-code-limit #x10000
     
    40664068     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
    40674069              (fixnum idx))
     4070     (setf (%native-u8-ref-u16 vector idx) byte-order-mark-char-code)
     4071     (incf idx 2)
    40684072     (do* ((i start (1+ i)))
    40694073          ((>= i end) idx)
     
    40944098             (index idx (1+ index)))
    40954099            ((>= index end) index)
    4096          (declare (fixnum i len index))
     4100         (declare (fixnum i end index))
    40974101         (let* ((1st-unit (if swap
    40984102                            (%reversed-u8-ref-u16 vector index)
     
    41054109   (lambda (string pointer idx start end)
    41064110     (declare (fixnum idx))
     4111     (setf (%get-unsigned-word pointer idx) byte-order-mark-char-code)
     4112     (incf idx 2)
    41074113     (do* ((i start (1+ i)))
    41084114          ((>= i end) idx)
     
    41394145         (setf (schar string i) (or (code-char 1st-unit) #\Replacement_Character)))))))
    41404146  :octets-in-string-function
    4141   #'ucs-2-octets-in-string
     4147  (nfunction
     4148   ucs-2-bom-octets-in-string
     4149   (lambda (string start end)
     4150     (+ 2 (ucs-2-octets-in-string string start end))))
    41424151  :length-of-vector-encoding-function
    41434152  (nfunction
    41444153   ucs-2-length-of-vector-encoding
    41454154   (lambda (vector start end)
    4146      (declare (ignore vector))
    4147      (do* ((i start (1+ i))
    4148            (j (+ i 2) (+ i 2))
     4155     (declare (fixnum start end))
     4156     (when (>= end (+ start 2))
     4157       (let* ((maybe-bom (%native-u8-ref-u16 vector start)))
     4158         (declare (type (unsigned-byte 16) maybe-bom))
     4159         (when (or (= maybe-bom byte-order-mark-char-code)
     4160                   (= maybe-bom swapped-byte-order-mark-char-code))
     4161           (incf start 2))))
     4162     (do* ((i start j)
     4163           (j (+ i 2) (+ j 2))
    41494164           (nchars 0 (1+ nchars)))
    41504165          ((> j end) (values nchars i)))))
     
    41534168   ucs-2-length-of-memory-encoding
    41544169   (lambda (pointer noctets start)
    4155      (when (> noctets 1)
    4156        (case (%get-unsigned-word pointer )
    4157          (#.byte-order-mark-char-code
    4158           (incf start 2)
    4159           (decf noctets 2))
    4160          (#.swapped-byte-order-mark-char-code
    4161           (incf start 2)
    4162           (decf noctets 2))))
    4163      (values (floor noctets 2) (+ start noctets))))
     4170     (let* ((skip
     4171             (when (> noctets 1)
     4172               (case (%get-unsigned-word pointer start)
     4173                 (#.byte-order-mark-char-code
     4174                  2)
     4175                 (#.swapped-byte-order-mark-char-code
     4176                  2)))))
     4177     (values (ash (- noctets skip) -1) (logandc2 noctets 1)))))
    41644178  :decode-literal-code-unit-limit #x10000
    41654179  :encode-literal-char-code-limit #x10000 
     
    42994313           (index idx (+ 4 index)))
    43004314          ((>= index end) index)
    4301        (declare (fixnum i len index))
     4315       (declare (fixnum i end index))
    43024316       (let* ((code (%native-u8-ref-u32 vector index)))
    43034317         (declare (type (unsigned-byte 32) code))
     
    43384352   (lambda (vector start end)
    43394353     (declare (ignore vector))
    4340      (do* ((i start (1+ i))
    4341            (j (+ i 4) (+ i 4))
     4354     (do* ((i start j)
     4355           (j (+ i 4) (+ j 4))
    43424356           (nchars 0 (1+ nchars)))
    43434357          ((> j end) (values nchars i)))))
     
    43474361   (lambda (pointer noctets start)
    43484362     (declare (ignore pointer))
    4349      (values (floor noctets 4) (+ start noctets))))
     4363     (values (ash noctets -2) (+ start (logandc2 noctets 3)))))
    43504364  :decode-literal-code-unit-limit #x110000
    43514365  :encode-literal-char-code-limit #x110000
     
    43964410           (index idx (+ 4 index)))
    43974411          ((>= index end) index)
    4398        (declare (fixnum i len index))
     4412       (declare (fixnum i end index))
    43994413       (let* ((code (%reversed-u8-ref-u32 vector index)))
    44004414         (declare (type (unsigned-byte 32) code))
     
    44364450   (lambda (vector start end)
    44374451     (declare (ignore vector))
    4438      (do* ((i start (1+ i))
    4439            (j (+ i 4) (+ i 4))
     4452     (do* ((i start j)
     4453           (j (+ i 4) (+ j 4))
    44404454           (nchars 0 (1+ nchars)))
    44414455          ((> j end) (values nchars i)))))
     
    44454459   (lambda (pointer noctets start)
    44464460     (declare (ignore pointer))
    4447      (values (floor noctets 4) (+ start noctets))))
     4461     (values (ash noctets -2) (+ start (logandc2 noctets 3)))))
    44484462  :decode-literal-code-unit-limit #x110000
    44494463  :encode-literal-char-code-limit #x110000
     
    44544468    "A 32-bit, fixed-length encoding in which all Unicode characters can be encoded in a single 32-bit word.  The endianness of the encoded data is indicated by the endianness of a byte-order-mark character (#\u+feff) prepended to the data; in the absence of such a character on input, input data is assumed to be in big-endian order.  Output is written in native byte order with a leading byte-order mark."
    44554469   
    4456   :aliases '(:utf-4)
     4470  :aliases '(:ucs-4)
    44574471  :max-units-per-char 1
    44584472  :code-unit-size 32
     
    44684482     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
    44694483              (fixnum idx))
     4484     (setf (%native-u8-ref-u32 vector idx) byte-order-mark-char-code)
     4485     (incf idx 4)
    44704486     (do* ((i start (1+ i)))
    44714487          ((>= i end) idx)
     
    44944510             (index idx (1+ index)))
    44954511            ((>= index end) index)
    4496          (declare (fixnum i len index))
     4512         (declare (fixnum i end index))
    44974513         (let* ((1st-unit (if swap
    44984514                            (%reversed-u8-ref-u32 vector index)
     
    45074523   (lambda (string pointer idx start end)
    45084524     (declare (fixnum idx))
    4509 
     4525     (setf (%get-unsigned-long pointer idx) byte-order-mark-char-code)
     4526     (incf idx 4)
    45104527     (do* ((i start (1+ i)))
    45114528          ((>= i end) idx)
     
    45414558                                    #\Replacement_Character)))))))
    45424559  :octets-in-string-function
    4543   #'ucs-4-octets-in-string
     4560  (nfunction
     4561   utf-32-bom-octets-in-string
     4562   (lambda (string start end)
     4563     (+ 4 (ucs-4-octets-in-string string start end))))
    45444564  :length-of-vector-encoding-function
    45454565  (nfunction
    45464566   utf-32-length-of-vector-encoding
    45474567   (lambda (vector start end)
    4548      (declare (ignore vector))
    4549      (do* ((i start (1+ i))
    4550            (j (+ i 2) (+ i 2))
     4568     (when (>= end (+ start 4))
     4569       (let* ((maybe-bom (%native-u8-ref-u32 vector start)))
     4570         (declare (type (unsigned-byte 32) maybe-bom))
     4571         (when (or (= maybe-bom byte-order-mark-char-code)
     4572                   (= maybe-bom swapped-byte-order-mark-char-code))
     4573           (incf start 4))))
     4574     (do* ((i start j)
     4575           (j (+ i 4) (+ J 4))
    45514576           (nchars 0 (1+ nchars)))
    45524577          ((> j end) (values nchars i)))))
     
    45554580   utf-32-length-of-memory-encoding
    45564581   (lambda (pointer noctets start)
    4557      (when (> noctets 1)
     4582     (when (> noctets 3)
    45584583       (case (%get-unsigned-long pointer )
    45594584         (#.byte-order-mark-char-code
     
    45634588          (incf start 4)
    45644589          (decf noctets 4))))
    4565      (values (floor noctets 4) (+ start noctets))))
     4590     (values (ash noctets -2) (+ start (logandc2 noctets 3)))))
    45664591  :decode-literal-code-unit-limit #x110000
    45674592  :encode-literal-char-code-limit #x110000 
     
    46044629(defvar *cr-newline-string* (make-string 1 :initial-element #\Return))
    46054630(defvar *crlf-newline-string* (make-array 2 :element-type 'character :initial-contents '(#\Return #\Linefeed)))
    4606 (defvar *nul-string (make-string 1 :initial-element #\Nul))
     4631(defvar *nul-string* (make-string 1 :initial-element #\Nul))
    46074632
    46084633(defun string-size-in-octets (string &key
Note: See TracChangeset for help on using the changeset viewer.