Ignore:
Timestamp:
Jul 27, 2010, 12:59:48 AM (9 years ago)
Author:
gz
Message:

Misc tweaks and fixes from trunk (r13550,r13560,r13568,r13569,r13581,r13583,r13633-13636,r13647,r13648,r13657-r13659,r13675,r13678,r13688,r13743,r13744,r13769,r13773,r13782,r13813,r13814,r13869,r13870,r13873,r13901,r13930,r13943,r13946,r13954,r13961,r13974,r13975,r13978,r13990,r14010,r14012,r14020,r14028-r14030)

Location:
branches/qres/ccl
Files:
1 deleted
8 edited

Legend:

Unmodified
Added
Removed
  • branches/qres/ccl

  • branches/qres/ccl/lib/ccl-export-syms.lisp

    r13558 r14049  
    726726     *vector-output-stream-default-initial-allocation*   
    727727     external-process-creation-failure
     728     object-direct-size
    728729
    729730     ) "CCL"
  • branches/qres/ccl/lib/compile-ccl.lisp

    r13528 r14049  
    550550        (setq allow-constant-redefinition t))))
    551551    (let* ((cd (current-directory))
    552            (*cerror-on-constant-redefinition* (not allow-constant-redefinition )))
     552           (*cerror-on-constant-redefinition* (not allow-constant-redefinition ))
     553           (*warn-if-redefine-kernel* nil))
    553554      (unwind-protect
    554555           (progn
     
    668669        (multiple-value-bind (status exit-code)
    669670            (external-process-status
    670              (run-program "svn" '("update" "--non-interactive") :output out :error t))
     671             (run-program *svn-program* '("update" "--non-interactive") :output out :error t))
    671672          (when verbose (format t "~&;'svn update' complete."))
    672673          (if (not (and (eq status :exited)
     
    685686              (flet ((svn-revert (string)
    686687                       (multiple-value-bind (status exit-code)
    687                            (external-process-status (run-program "svn" `("revert" ,string)))
     688                           (external-process-status (run-program *svn-program* `("revert" ,string)))
    688689                         (when (and (eq status :exited) (eql exit-code 0))
    689690                           (setq conflicts (delete string conflicts :test #'string=))
     
    750751      (when update
    751752        (cwd "ccl:tests;")
    752         (run-program "svn" '("update")))
    753       (let* ((svn (probe-file "ccl:.svn;entries"))
    754              (repo (and svn (svn-repository)))
     753        (run-program *svn-program* '("update")))
     754      (let* ((repo (svn-repository))
     755             (url (format nil "~a/trunk/tests" repo))
    755756             (s (make-string-output-stream)))
    756         (when repo
    757           (format t "~&Checking out test suite into ccl:tests;~%")
    758           (cwd "ccl:")
    759           (multiple-value-bind (status exit-code)
     757        (if (null repo)
     758          (error "Can't determine svn repository.  ccl directory is ~s"
     759                 (ccl-directory))
     760          (progn
     761            (format t "~&Using ~a to check out test suite from ~a ~
     762                       into ccl:tests;~%" *svn-program* url)
     763            (cwd "ccl:")
     764            (multiple-value-bind (status exit-code)
    760765              (external-process-status
    761                (run-program "svn" (list "checkout" (format nil "~a/trunk/tests" repo) "tests")
    762                             :output s
    763                             :error s))
    764             (unless (and (eq status :exited)
    765                          (eql exit-code 0))
    766               (error "Failed to check out test suite: ~%~a" (get-output-stream-string s)))))))
     766               (run-program *svn-program* (list "checkout" url "tests")
     767                            :output s :error s))
     768              (unless (and (eq status :exited)
     769                           (eql exit-code 0))
     770                (error "Failed to check out test suite: ~%~a"
     771                       (get-output-stream-string s))))))))
    767772    (cwd "ccl:tests;ansi-tests;")
    768773    (run-program "make" '("-k" "clean"))
     
    797802
    798803(defun test-ccl (&key force (update t) verbose (catch-errors t) (ansi t) (ccl t)
    799                       optimization-settings)
     804                      optimization-settings exit)
    800805  (with-preserved-working-directory ()
    801806    (let* ((*package* (find-package "CL-USER")))
     
    812817          (map nil #'delete-file
    813818               (directory (merge-pathnames *.fasl-pathname* "ccl:tests;ansi-tests;temp*"))))
    814         (symbol-value failed)))))
     819        (let ((failed-tests (symbol-value failed)))
     820          (when exit
     821            (quit (if failed-tests 1 0)))
     822          failed-tests)))))
     823
  • branches/qres/ccl/lib/describe.lisp

    r13070 r14049  
    12311231                                              "Arglist unknown")))
    12321232                                 (list arglist label (if type :colon '(:comment (:plain)))))))
     1233                       (list (list (ccl::lfun-bits o) "Bits" :colon))
     1234                       (list (list (ccl::%lfun-info o) "Plist" :colon))
    12331235                       (when doc (list (list (substitute #\space #\newline doc) "Documentation" :colon)))
    12341236                       (when sn (list (list sn "Source Location" :colon))))))
     
    12791281             (let* ((value (ccl::nth-immediate o (1+ (- nclosed n))))
    12801282                    (map (car (ccl::function-symbol-map (ccl::closure-function o))))
    1281                     (label (or (and map (svref map (+ n (- (length map) nclosed))))
     1283                    (label (or (and map (aref map (+ n (- (length map) nclosed))))
    12821284                               n))
    12831285                    (cellp (ccl::closed-over-value-p value)))
     
    13281330  (if (< (decf n) 0)
    13291331    (values nil "Disassembly:" :comment)
    1330     (let ((line (svref (disasm-info f) n)))
     1332    (let ((line (aref (disasm-info f) n)))
    13311333      (if (consp line)
    13321334        (destructuring-bind (object label instr) line
     
    13361338(defun disassembly-line-n-inspector (f n)
    13371339  (unless (< (decf n) 0)
    1338     (let ((line (svref (disasm-info f) n)))
     1340    (let ((line (aref (disasm-info f) n)))
    13391341      (and (consp line)
    13401342           (car line)
     
    13441346  (if (< (decf n) 0)
    13451347    (values "Disassembly:" nil)
    1346     (let ((line (svref (disasm-info f) n)))
     1348    (let ((line (aref (disasm-info f) n)))
    13471349      (if (consp line)
    13481350        (destructuring-bind (object label instr) line
     
    16011603
    16021604(defmethod compute-frame-info ((f error-frame) n)
    1603   (let* ((frame (svref (addresses f) n))
     1605  (let* ((frame (aref (addresses f) n))
    16041606         (context (context f))
    16051607         (marker (unavailable-value-marker f)))
     
    16651667
    16661668(defmethod line-n ((f stack-inspector) n)
    1667   (let* ((frame (svref (addresses (inspector-object f)) n)))
     1669  (let* ((frame (aref (addresses (inspector-object f)) n)))
    16681670    (ccl::cfp-lfun frame)))
    16691671
  • branches/qres/ccl/lib/lists.lisp

    r13070 r14049  
    2222  (require 'level-2))
    2323
    24 
    25 
    26 ;;; These functions perform basic list operations:
    27 
    28 #|
    29 (defun caar (list) (car (car list)))
    30 (defun cadr (list) (car (cdr list)))
    31 (defun cdar (list) (cdr (car list)))
    32 (defun cddr (list) (cdr (cdr list)))
    33 
    34 (defun caaar (list) (car (caar list)))
    35 (defun caadr (list) (car (cadr list)))
    36 (defun cadar (list) (car (cdar list)))
    37 (defun caddr (list) (car (cddr list)))
    38 (defun cdaar (list) (cdr (caar list)))
    39 (defun cdadr (list) (cdr (cadr list)))
    40 (defun cddar (list) (cdr (cdar list)))
    41 (defun cdddr (list) (cdr (cddr list)))
    42 |#
    43 
    44 
    45 (defun caaaar (list)
    46   "Return the car of the caaar of a list."
    47   (car (caaar list)))
    48 
    49 (defun caaadr (list)
    50   "Return the car of the caadr of a list."
    51   (car (caadr list)))
    52 
    53 (defun caadar (list)
    54   "Return the car of the cadar of a list."
    55   (car (cadar list)))
    56 
    57 (defun caaddr (list)
    58   "Return the car of the caddr of a list."
    59   (car (caddr list)))
    60 
    61 (defun cadaar (list)
    62   "Return the car of the cdaar of a list."
    63   (car (cdaar list)))
    64 
    65 (defun cadadr (list)
    66   "Return the car of the cdadr of a list."
    67   (car (cdadr list)))
    68 
    69 (defun caddar (list)
    70   "Return the car of the cddar of a list."
    71   (car (cddar list)))
    72 
    73 (defun cdaaar (list)
    74   "Return the cdr of the caaar of a list."
    75   (cdr (caaar list)))
    76 
    77 (defun cdaadr (list)
    78   "Return the cdr of the caadr of a list."
    79   (cdr (caadr list)))
    80 
    81 (defun cdadar (list)
    82   "Return the cdr of the cadar of a list."
    83   (cdr (cadar list)))
    84 
    85 (defun cdaddr (list)
    86   "Return the cdr of the caddr of a list."
    87   (cdr (caddr list)))
    88 
    89 (defun cddaar (list)
    90   "Return the cdr of the cdaar of a list."
    91   (cdr (cdaar list)))
    92 
    93 (defun cddadr (list)
    94   "Return the cdr of the cdadr of a list."
    95   (cdr (cdadr list)))
    96 
    97 (defun cdddar (list)
    98   "Return the cdr of the cddar of a list."
    99   (cdr (cddar list)))
    100 
    101 (defun cddddr (list)
    102   "Return the cdr of the cdddr of a list."
    103   (cdr (cdddr list)))
     24(defun caaaar (list) (car (caaar list)))
     25(defun caaadr (list) (car (caadr list)))
     26(defun caadar (list) (car (cadar list)))
     27(defun caaddr (list) (car (caddr list)))
     28(defun cadaar (list) (car (cdaar list)))
     29(defun cadadr (list) (car (cdadr list)))
     30(defun caddar (list) (car (cddar list)))
     31(defun cadddr (list) (car (cdddr list)))
     32(defun cdaaar (list) (cdr (caaar list)))
     33(defun cdaadr (list) (cdr (caadr list)))
     34(defun cdadar (list) (cdr (cadar list)))
     35(defun cdaddr (list) (cdr (caddr list)))
     36(defun cddaar (list) (cdr (cdaar list)))
     37(defun cddadr (list) (cdr (cdadr list)))
     38(defun cdddar (list) (cdr (cddar list)))
     39(defun cddddr (list) (cdr (cdddr list)))
    10440
    10541(defun tree-equal (x y &key (test (function eql)) test-not)
  • branches/qres/ccl/lib/misc.lisp

    r13547 r14049  
    422422         (info #>task_events_info))
    423423    (#_task_info (#_mach_task_self) #$TASK_EVENTS_INFO info count)
    424     (values (pref info #>task_events_info.cow_faults)
    425             (pref info #>task_events_info.faults)
    426             (pref info #>task_events_info.pageins)))
     424    (let* ((faults (pref info #>task_events_info.faults))
     425           (pageins (pref info #>task_events_info.pageins)))
     426      (values (- faults pageins)
     427              pageins
     428              0)))
    427429  #+windows-target
    428430  ;; Um, don't know how to determine this, or anything like it.
     
    11991201                         (* 100.0 (/ physsize total-psize)))))
    12001202      (if unit
    1201         (format stream "~&~a~vt~11d~16,2f~16,2f~11,2f%"
     1203        (format stream "~&~a~vt~11d~16,2f~16,2f~11,2f%~%"
    12021204                "Total"
    12031205                (1+ max-name)
     
    12061208                (/ total-psize div)
    12071209                100.0d0)
    1208         (format stream "~&~a~vt~11d~16d~16d~11,2f%"
     1210        (format stream "~&~a~vt~11d~16d~16d~11,2f%~%"
    12091211                "Total"
    12101212                (1+ max-name)
     
    12181220;; one and we don't have any left over
    12191221(defparameter *static-cons-chunk* 1048576)
     1222
     1223(defun object-direct-size (thing)
     1224  "Returns the size of THING (in bytes), including any headers and
     1225   alignment overhead.  Does not descend an object's components."
     1226  (cond ((consp thing) #+64-bit-target 16 #+32-bit-target 8)
     1227        #+x8664-target ((symbolp thing)
     1228                        (object-direct-size (%symptr->symvector thing)))
     1229        #+x8664-target ((functionp thing)
     1230                        (object-direct-size (function-to-function-vector thing)))
     1231        ((uvectorp thing)
     1232         (let* ((typecode (ccl::typecode thing))
     1233                (element-count (ccl::uvsize thing))
     1234                (sizeof-content-in-octets
     1235                 ;; Call the architecture-specific backend function.
     1236                 (funcall (arch::target-array-data-size-function
     1237                           (backend-target-arch *host-backend*))
     1238                          typecode element-count)))
     1239           (logandc2 (+ sizeof-content-in-octets
     1240                           #+64-bit-target (+ 8 15)
     1241                           #+32-bit-target (+ 4 7))
     1242                     #+64-bit-target 15
     1243                     #+32-bit-target 7)))
     1244        (t 0)))
    12201245
    12211246(defun initialize-static-cons ()
  • branches/qres/ccl/lib/nfcomp.lisp

    r13685 r14049  
    14541454(defun fasl-dump-block (gnames goffsets forms hash)
    14551455  (let ((etab-size (hash-table-count hash)))
    1456     (when (> etab-size 65535)
    1457       (error "Too many multiply-referenced objects in fasl file.~%Limit is ~d. Were ~d." 65535 etab-size))
    14581456    (fasl-out-word FASL-VERSION)          ; Word 0
    14591457    (fasl-out-long  0)
  • branches/qres/ccl/lib/streams.lisp

    r13508 r14049  
    131131
    132132(defun line-length (stream)
    133   (or (stream-line-length stream) 80))
     133  (or (stream-line-length stream) *default-right-margin*))
    134134
    135135(defun write-byte (byte stream)
Note: See TracChangeset for help on using the changeset viewer.