Ignore:
Timestamp:
Feb 15, 2013, 7:24:29 AM (6 years ago)
Author:
gb
Message:

Propagate recent trunk changes.

Location:
release/1.9/source/level-1
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/1.9/source/level-1

  • release/1.9/source/level-1/l1-error-signal.lisp

    r14844 r15706  
    5454  ;;; The compiler (finally !) won't tail-apply error.  But we kind of
    5555  ;;; expect it to ...
    56   (let* ((err-typ (max (ash err-num -16) 0))
    57          (err-num (%word-to-int err-num))
    58          (format-string (%rsc-string err-num)))
    59     (%err-disp-common err-num err-typ format-string errargs frame-ptr)))
     56  (if (eql err-num $XARRLIMIT)
     57    (%error (make-condition 'vector-size-limitation
     58                            :subtag (cadr errargs)
     59                            :element-count (car errargs))
     60            nil
     61            frame-ptr)
     62    (let* ((err-typ (max (ash err-num -16) 0))
     63           (err-num (%word-to-int err-num))
     64           (format-string (%rsc-string err-num)))
     65      (%err-disp-common err-num err-typ format-string errargs frame-ptr))))
    6066
    6167(defparameter *foreign-error-condition-recognizers* ())
  • release/1.9/source/level-1/l1-error-system.lisp

    r15311 r15706  
    190190  ()
    191191  (:report (lambda (c s) (declare (ignore c)) (format s "Attempt to heap-allocate a lisp object when heap allocation is disabled."))))
    192  
     192
     193(define-condition vector-size-limitation (storage-condition)
     194  ((subtag :initarg :subtag)
     195   (element-count :initarg :element-count))
     196  (:report (lambda (c s)
     197             (let* ((subtag (slot-value c 'subtag))
     198                    (element-count (slot-value c 'element-count))
     199                    (typename (if (eql subtag target::subtag-bignum)
     200                                'bignum
     201                                (if (eql subtag target::subtag-simple-vector)
     202                                  'simple-vector
     203                                  (if (eql subtag target::subtag-simple-base-string)
     204                                    'string
     205                                    (if (> subtag target::subtag-simple-vector)
     206                                      `(simple-array ,(element-subtype-type subtag) (*))
     207                                      `(ccl::uvector ,subtag))))))
     208                    (qualifier (if (eql subtag target::subtag-bignum)
     209                                 "32-bit "
     210                                 "")))
     211               (format s "Cannot allocate a ~s with ~d elements.~&Objects of type ~s can can have at most ~&~d ~aelements in this implementation."
     212                       typename
     213                       element-count
     214                       (copy-tree typename)
     215                       (1- target::array-total-size-limit)
     216                       qualifier)))))
    193217
    194218(define-condition type-error (error)
  • release/1.9/source/level-1/linux-files.lisp

    r15684 r15706  
    10741074;;; Foreign (unix) processes.
    10751075
    1076 (defun call-with-string-vector (function strings)
    1077   (let ((bufsize (reduce #'+ strings
    1078                          :key #'(lambda (s) (1+ (length (string s))))))
    1079         (argvsize (ash (1+ (length strings)) target::word-shift))
    1080         (bufpos 0)
    1081         (argvpos 0))
     1076(defun call-with-string-vector (function strings encoding)
     1077  (let* ((encoding (if (typep encoding 'character-encoding)
     1078                     encoding
     1079                     (get-character-encoding encoding)))
     1080         (bufsize (reduce #'+ strings
     1081                          :key #'(lambda (s)
     1082                                   (let* ((string (string s)))
     1083                                     (cstring-encoded-length-in-bytes encoding
     1084                                                                      string
     1085                                                                      0
     1086                                                                      (length string))))))
     1087         (argvsize (ash (1+ (length strings)) target::word-shift))
     1088         (bufpos 0)
     1089         (argvpos 0))       
    10821090    (%stack-block ((buf bufsize) (argv argvsize))
    10831091      (flet ((init (s)
    1084              (multiple-value-bind (sstr start end) (get-sstring s)
    1085                (declare (fixnum start end))
    1086                (let ((len (- end start)))
    1087                  (declare (fixnum len))
    1088                  (do* ((i 0 (1+ i))
    1089                        (start start (1+ start))
    1090                        (bufpos bufpos (1+ bufpos)))
    1091                       ((= i len))
    1092                    (setf (%get-unsigned-byte buf bufpos)
    1093                          (logand #xff (%scharcode sstr start))))
    1094                  (setf (%get-byte buf (%i+ bufpos len)) 0)
    1095                  (setf (%get-ptr argv argvpos) (%inc-ptr buf bufpos))
    1096                  (setq bufpos (%i+ bufpos len 1))
    1097                  (setq argvpos (%i+ argvpos target::node-size))))))
     1092               (multiple-value-bind (sstr start end) (get-sstring s)
     1093                 (declare (fixnum start end))
     1094                 (let* ((len (- (encode-string-to-memory encoding buf bufpos sstr start end) bufpos)))
     1095                   (declare (fixnum len))
     1096                   (setf (%get-byte buf (%i+ bufpos len)) 0)
     1097                   (setf (%get-ptr argv argvpos) (%inc-ptr buf bufpos))
     1098                   (setq bufpos (%i+ bufpos len 1))
     1099                   (setq argvpos (%i+ argvpos target::node-size))))))
    10981100        (declare (dynamic-extent #'init))
    10991101        (map nil #'init strings))
     
    11011103      (funcall function argv))))
    11021104
    1103 (defmacro with-string-vector ((var strings) &body body)
    1104   `(call-with-string-vector #'(lambda (,var) ,@body) ,strings))
     1105(defmacro with-string-vector ((var strings &optional encoding) &body body)
     1106  `(call-with-string-vector #'(lambda (,var) ,@body) ,strings ,encoding))
    11051107
    11061108(defloadvar *max-os-open-files* #-windows-target (#_getdtablesize) #+windows-target 32)
     
    14531455    (unless (every #'(lambda (a) (typep a 'simple-string)) args)
    14541456      (error "Program args must all be simple strings : ~s" args))
     1457    (setq external-format (normalize-external-format t external-format))
    14551458    (dolist (pair env)
    14561459      (destructuring-bind (var . val) pair
     
    15151518                   #'run-external-process proc in-fd out-fd error-fd argv env)
    15161519                  (wait-on-semaphore (external-process-signal proc)))
    1517               args))
     1520              args
     1521              (external-format-character-encoding external-format)))
    15181522        (dolist (fd close-in-parent) (fd-close fd))
    15191523        (unless (external-process-pid proc)
Note: See TracChangeset for help on using the changeset viewer.