Ignore:
Timestamp:
Apr 20, 2008, 7:41:46 AM (13 years ago)
Author:
gb
Message:

synch with trunk

Location:
release/1.2/source/lib
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/1.2/source/lib/compile-ccl.lisp

    r9051 r9200  
    600600         (cwd ,wd)))))
    601601
    602 (defun ensure-tests-loaded (&key force full)
     602(defun ensure-tests-loaded (&key force update)
    603603  (unless (and (find-package "REGRESSION-TEST") (not force))
    604604    (if (probe-file "ccl:tests;ansi-tests;")
    605       (when full
     605      (when update
    606606        (cwd "ccl:tests;")
    607607        (run-program "svn" '("update")))
    608608      (let* ((svn (probe-file "ccl:.svn;entries"))
    609              (repo (and svn
    610                         (with-open-file (s svn)
    611                           (loop as line =  (read-line s nil) while line
    612                              do (when (search "://" line)
    613                                   (setq line (read-line s))
    614                                   (return (and (search "://" line) line)))))))
     609             (repo (and svn (svn-repository)))
    615610             (s (make-string-output-stream)))
    616611        (when repo
     
    631626    ;; it without making the test suite non-portable across platforms...
    632627    (handler-bind ((warning (lambda (c)
    633                               (when (and (typep c 'compiler-warning)
    634                                          (eq (compiler-warning-warning-type c) :program-error)
    635                                          (typep (car (compiler-warning-args c)) 'simple-warning)
    636                                          (or
    637                                           (string-equal
    638                                            (simple-condition-format-control (car (compiler-warning-args c)))
    639                                            "Clause ~S ignored in ~S form - shadowed by ~S .")
    640                                           ;; Might as well ignore these as well, they're intentional.
    641                                           (string-equal
    642                                            (simple-condition-format-control (car (compiler-warning-args c)))
    643                                            "Duplicate keyform ~s in ~s statement.")))
     628                              (when (let ((w (or (and (typep c 'compiler-warning)
     629                                                      (eq (compiler-warning-warning-type c) :program-error)
     630                                                      (car (compiler-warning-args c)))
     631                                                 c)))
     632                                      (and (typep w 'simple-warning)
     633                                           (or
     634                                            (string-equal
     635                                             (simple-condition-format-control w)
     636                                             "Clause ~S ignored in ~S form - shadowed by ~S .")
     637                                            ;; Might as well ignore these as well, they're intentional.
     638                                            (string-equal
     639                                             (simple-condition-format-control w)
     640                                             "Duplicate keyform ~s in ~s statement."))))
    644641                                (muffle-warning c)))))
    645642      ;; This loads the infrastructure
    646643      (load "ccl:tests;ansi-tests;gclload1.lsp")
    647644      ;; This loads the actual tests
    648       (load "ccl:tests;ansi-tests;gclload2.lsp"))))
    649 
    650 (defun test-ccl (&key force full verbose (catch-errors t))
     645      (load "ccl:tests;ansi-tests;gclload2.lsp")
     646      ;; And our own tests
     647      (load "ccl:tests;ansi-tests;ccl.lsp"))))
     648
     649(defun test-ccl (&key force (update t) verbose (catch-errors t))
    651650  (with-preserved-working-directory ()
    652     (ensure-tests-loaded :force force :full full)
     651    (ensure-tests-loaded :force force :update update)
    653652    (cwd "ccl:tests;ansi-tests;")
    654653    (let ((do-tests (find-symbol "DO-TESTS" "REGRESSION-TEST"))
  • release/1.2/source/lib/macros.lisp

    r9049 r9200  
    543543                         (default-setf form value env))))))))))
    544544          ((oddp temp)
    545            (error "Odd number of args to SETF : ~s." args))
     545           (signal-program-error "Odd number of args to SETF : ~s." args))
    546546          (t (do* ((a args (cddr a)) (l nil))
    547547                  ((null a) `(progn ,@(nreverse l)))
     
    869869         otherwise-seen-p)
    870870    (flet ((bad-clause (c)
    871              (error "Invalid clause ~S in ~S form." c construct)))
     871             (signal-program-error "Invalid clause ~S in ~S form." c construct)))
    872872      (dolist (clause clauses)
    873873        (if (atom clause)
    874874            (bad-clause clause))
    875875        (if otherwise-seen-p
    876             (error "OTHERWISE must be final clause in ~S form." construct))
     876            (signal-program-error "OTHERWISE must be final clause in ~S form." construct))
    877877        (destructuring-bind (typespec &body consequents) clause
    878878          (when (eq construct 'typecase)
     
    994994       (when (nth-value 1 (macroexpand-1 sym env))
    995995         (return `(psetf ,@pairs))))
    996      (error "Uneven number of args in the call ~S" call))))
     996     (signal-program-error "Uneven number of args in the call ~S" call))))
    997997
    998998; generates body for psetq.
     
    16771677(defun with-specs-aux (name spec-list original-body)
    16781678  (multiple-value-bind (body decls) (parse-body original-body nil)
    1679     (when decls (error "declarations not allowed in ~s" original-body))
     1679    (when decls (signal-program-error "declarations not allowed in ~s" original-body))
    16801680    (setq body (cons 'progn body))
    16811681    (dolist (spec (reverse spec-list))
     
    20982098      (unless (and (consp option)
    20992099                   (consp (%cdr option)))
    2100         (error "Invalid option ~s ." option))
     2100        (signal-program-error "Invalid option ~s ." option))
    21012101      (ecase (%car option)
    21022102        (:default-initargs
     
    21082108        (:documentation
    21092109         (unless (null (%cddr option))
    2110            (error "Invalid option ~s ." option))
     2110           (signal-program-error "Invalid option ~s ." option))
    21112111         (if docp
    21122112           (setq duplicate t)
     
    21142114        (:report
    21152115         (unless (null (%cddr option))
    2116            (error "Invalid option ~s ." option))
     2116           (signal-program-error "Invalid option ~s ." option))
    21172117         (if reporter
    21182118           (setq duplicate t)
     
    21232123               (if (stringp reporter)
    21242124                 (setq reporter `(function (lambda (c s) (declare (ignore c)) (write-string ,reporter s))))
    2125                  (error "~a expression is not a string, symbol, or lambda expression ." (%car option))))
     2125                 (signal-program-error "~a expression is not a string, symbol, or lambda expression ." (%car option))))
    21262126             (setq reporter `((defmethod report-condition ((c ,name) s)
    21272127                                (funcall ,reporter c s))))))))
    2128       (if duplicate (error "Duplicate option ~s ." option)))
     2128      (if duplicate (signal-program-error "Duplicate option ~s ." option)))
    21292129    `(progn
    21302130       (defclass ,name ,(or supers '(condition)) ,slots ,@classopts)
     
    27592759                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
    27602760             (setq var (car slot-entry) slot-name (cadr slot-entry)))
    2761             (t (error "Malformed slot-entry: ~a to with-slot-values.~@
    2762                        Should be a symbol or a list of two symbols."
    2763                       slot-entry)))
     2761            (t (signal-program-error "Malformed slot-entry: ~a to with-slot-values.~@
     2762                                      Should be a symbol or a list of two symbols."
     2763                                     slot-entry)))
    27642764      (push `(,var (slot-value ,instance ',slot-name)) bindings))
    27652765    `(let ((,instance ,instance-form))
     
    27802780                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
    27812781             (setq var (car slot-entry) slot-name (cadr slot-entry)))
    2782             (t (error "Malformed slot-entry: ~a to with-slots.~@
    2783                        Should be a symbol or a list of two symbols."
    2784                       slot-entry)))
     2782            (t (signal-program-error "Malformed slot-entry: ~a to with-slots.~@
     2783                                      Should be a symbol or a list of two symbols."
     2784                                     slot-entry)))
    27852785      (push `(,var (slot-value ,instance ',slot-name)) bindings))
    27862786    `(let ((,instance ,instance-form))
     
    28012801                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
    28022802             (setq var (car slot-entry) reader (cadr slot-entry)))
    2803             (t (error "Malformed slot-entry: ~a to with-accessors.~@
    2804                        Should be a list of two symbols."
    2805                       slot-entry)))
     2803            (t (signal-program-error "Malformed slot-entry: ~a to with-accessors.~@
     2804                                     Should be a list of two symbols."
     2805                                     slot-entry)))
    28062806      (push `(,var (,reader ,instance)) bindings))
    28072807    `(let ((,instance ,instance-form))
     
    29392939                           `((setf ,(%foreign-access-form name ftype 0 nil)
    29402940                              ,(car inits)))))
    2941               (error "Unexpected or malformed initialization forms: ~s in field type: ~s"
    2942                      inits record-name))))))))
     2941              (signal-program-error "Unexpected or malformed initialization forms: ~s in field type: ~s"
     2942                                    inits record-name))))))))
    29432943
    29442944(defun %foreign-record-field-forms (ptr record-type record-name inits)
    29452945  (unless (evenp (length inits))
    2946     (error "Unexpected or malformed initialization forms: ~s in field type: ~s"
    2947                      inits record-name))
     2946    (signal-program-error "Unexpected or malformed initialization forms: ~s in field type: ~s"
     2947                          inits record-name))
    29482948  (let* ((result ()))
    29492949    (do* ()
     
    29762976         (bytes (if bits
    29772977                  (ceiling bits 8)
    2978                   (error "Unknown size for foreign type ~S."
    2979                          (unparse-foreign-type ftype))))
     2978                  (signal-program-error "Unknown size for foreign type ~S."
     2979                                        (unparse-foreign-type ftype))))
    29802980         (p (gensym))
    29812981         (bzero (read-from-string "#_bzero")))   
     
    31543154          (%symbol-binding-address ',place)
    31553155          (%atomic-incf-node ,delta ,base ,offset)))
    3156       (error "~S is not a special variable"  place))))
     3156      (signal-program-error "~S is not a special variable"  place))))
    31573157   
    31583158(defmacro atomic-incf (place)
     
    31733173    (unless (and (listp x)
    31743174                 (= (length x) 2))
    3175       (error "Malformed iterate variable spec: ~S." x)))
     3175      (signal-program-error "Malformed iterate variable spec: ~S." x)))
    31763176
    31773177  `(labels ((,name ,(mapcar #'first binds) ,@body))
     
    32113211      (let ((spec (first specs)))
    32123212        (when (/= (length spec) 2)
    3213           (error "Malformed Once-Only binding spec: ~S." spec))
     3213          (signal-program-error "Malformed ~s binding spec: ~S." 'once-only spec))
    32143214        (let ((name (first spec))
    32153215              (exp-temp (gensym)))
     
    32723272    (dolist (spec collections)
    32733273      (unless (<= 1 (length spec) 3)
    3274         (error "Malformed collection specifier: ~S." spec))
     3274        (signal-program-error "Malformed collection specifier: ~S." spec))
    32753275      (let ((n-value (gensym))
    32763276            (name (first spec))
     
    33333333                 (if (and (consp (%cdr p)) (null (%cddr p)))
    33343334                   (values (require-global-symbol (%car p) env) (%cadr p))
    3335                    (error "Invalid variable initialization form : ~s")))))
     3335                   (signal-program-error "Invalid variable initialization form : ~s")))))
    33363336        (declare (inline pair-name-value))
    33373337        (dolist (v vars)
     
    33703370          (ccl::%symbol-binding-address ',place)
    33713371          (ccl::%store-node-conditional ,offset ,base ,old-value ,new-value)))
    3372       (error "~s is not a special variable ." place))
     3372      (signal-program-error "~s is not a special variable ." place))
    33733373    (let* ((sym (car place))
    33743374           (struct-transform (or (ccl::environment-structref-info sym env)
     
    33823382            (ccl::store-gvector-conditional ,(caddr place)
    33833383             ,v ,old-value ,new-value)))
    3384         (error "Don't know how to do conditional store to ~s" place)))))
     3384        (signal-program-error "Don't know how to do conditional store to ~s" place)))))
    33853385
    33863386(defmacro step (form)
  • release/1.2/source/lib/nfcomp.lisp

    r8995 r9200  
    907907  (let* ((*fasdump-hash* (make-hash-table :size (length forms)          ; Crude estimate
    908908                                          :rehash-threshold 0.9
    909                                           :test 'eq))
     909                                          :test 'eq
     910                                          :shared nil))
    910911         (*make-load-form-hash* (make-hash-table :test 'eq))
    911912         (*fasdump-read-package* nil)
  • release/1.2/source/lib/pprint.lisp

    r6923 r9200  
    15631563  (cond ((vectorp array) (pretty-vector xp array))
    15641564        ((zerop (array-rank array))
    1565          (write-string++ "#0A " xp 0 4)
     1565         (write-string++ "#0A" xp 0 3)
    15661566         (write+ (aref array) xp))
    15671567        (T (pretty-non-vector xp array))))
Note: See TracChangeset for help on using the changeset viewer.