Changeset 14049


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
29 edited
1 copied

Legend:

Unmodified
Added
Removed

  • branches/qres/ccl

  • branches/qres/ccl/compiler/nx0.lisp

    r13502 r14049  
    19221922
    19231923(defun nx1-combination (form env)
    1924   (destructuring-bind (sym &rest args)
    1925                       form
     1924  (destructuring-bind (sym &rest args) form
    19261925    (if (symbolp sym)
    19271926      (let* ((*nx-sfname* sym) special)
    … …  
    19321931                                 ))
    19331932                     (< (safety-optimize-quantity env) 3))
    1934                  ;(not (nx-lexical-finfo sym env))
     1933                 ;;(not (nx-lexical-finfo sym env))
    19351934                 (not (nx-declared-notinline-p sym *nx-lexical-environment*)))
    19361935          (funcall special form env) ; pass environment arg ...
    … …  
    19391938      (if (lambda-expression-p sym)
    19401939        (nx1-lambda-bind (%cadr sym) args (%cddr sym))
    1941       (nx-error "In the form ~S, ~S is not a symbol or lambda expression." form sym)))))
     1940        (nx-error "In the form ~S, ~S is not a symbol or lambda expression." form sym)))))
    19421941
    19431942(defun nx1-treat-as-call (args)

  • branches/qres/ccl/compiler/nxenv.lisp

    r13070 r14049  
    2626  (require 'lispequ)
    2727)
    28 
    29 #-bootstrapped
    30 (eval-when (:compile-toplevel :load-toplevel :execute)
    31   (when (and (macro-function 'var-decls)
    32              (not (macro-function 'var-ref-forms)))
    33     (setf (macro-function 'var-ref-forms)
    34           (macro-function 'var-decls))))
    3528
    3629#+ppc-target (require "PPCENV")
    … …  
    387380
    388381(defmacro %nx1-default-operator ()
    389  #-bccl
    390  `(nx1-default-operator)
    391  #+bccl
    392  `(gethash *nx-sfname* *nx1-operators*))
     382  `(nx1-default-operator))
    393383
    394384(defmacro defnx1 (name sym arglist &body forms)
    … …  
    441431
    442432(defconstant $eaclosedbit 24)
    443 
    444 #+what?
    445 (progn
    446 ;;; condition codes :
    447 ;;; These are 68K condition code values, but the frontend uses them and
    448 ;;; both backends need to understand them.
    449 ;;; They're really backend-specific; it wouldn't hurt to have the frontend
    450 ;;; use a more "neutral" representation.
    451 (defconstant $ccT 0)
    452 (defconstant $ccEQ 7)
    453 (defconstant $ccNE 6)
    454 (defconstant $ccVC 8)
    455 (defconstant $ccMI 11)
    456 (defconstant $ccPL 10)
    457 (defconstant $ccGE 12)
    458 (defconstant $ccLT 13)
    459 (defconstant $ccGT 14)
    460 (defconstant $ccLE 15)
    461 )
    462 
    463433
    464434(defmacro %temp-push (value place &environment env)

  • branches/qres/ccl/level-0/l0-float.lisp

    r13070 r14049  
    840840           (%single-float-expt (%short-float b) (%short-float e))
    841841           ))
     842        ((typep (realpart e) 'double-float)
     843         ;; Avoid intermediate single-float result from LOG
     844         (let ((promoted-base (* 1d0 b)))
     845           (exp (* e (log promoted-base)))))
    842846        (t (exp (* e (log b))))))
    843847

  • branches/qres/ccl/level-0/l0-numbers.lisp

    r13546 r14049  
    11571157       (number-case divisor
    11581158         (fixnum (if (eq divisor 1) (values number 0) (%fixnum-truncate number divisor)))
    1159          (bignum (values 0 number))
     1159         (bignum (if (eq number target::target-most-negative-fixnum)
     1160                   (with-small-bignum-buffers ((bn number))
     1161                     (bignum-truncate bn divisor))
     1162                   (values 0 number)))
    11601163         (double-float (truncate-rat-dfloat number divisor))
    11611164         (short-float (truncate-rat-sfloat number divisor))
    … …  
    11641167                  (values q (- number (* q divisor)))))))
    11651168      (bignum (number-case divisor
    1166                 (fixnum (if (eq divisor 1) (values number 0)
     1169                (fixnum (if (eq divisor 1)
     1170                          (values number 0)
    11671171                          (if (eq divisor target::target-most-negative-fixnum);; << aargh
    11681172                            (with-small-bignum-buffers ((bd divisor))

  • branches/qres/ccl/level-1/l1-clos-boot.lisp

    r13364 r14049  
    902902
    903903(defstatic *standard-kernel-method-class* nil)
    904 
    905 (defun redefine-kernel-method (method)
    906   (when (and *warn-if-redefine-kernel*
    907              (or (let ((class *standard-kernel-method-class*))
    908                    (and class (typep method class)))
    909                  (and (standard-method-p method)
    910                       (kernel-function-p (%method-function method)))))
    911     (cerror "Replace the definition of ~S."
    912             "The method ~S is predefined in Clozure CL." method)))
    913 
    914 ;;; Called by the expansion of generic-labels.  Which doesn't exist.
    915 (defun %add-methods (gf &rest methods)
    916   (declare (dynamic-extent methods))
    917   (dolist (m methods)
    918     (add-method gf m)))
    919904
    920905(defun methods-congruent-p (m1 m2)

  • branches/qres/ccl/level-1/l1-files.lisp

    r13502 r14049  
    532532  (require-type reference-host '(or null string))
    533533  (multiple-value-bind (sstr start end) (get-pathname-sstring string start end)
    534     #-windows-target
    535534    (if (and (> end start)
    536535             (eql (schar sstr start) #\~))

  • branches/qres/ccl/level-1/l1-io.lisp

    r13070 r14049  
    15591559      (if name
    15601560        (prin1 name stream)
    1561         (let* ((fnaddr (%address-of lfun))
    1562                (kernel-function-p (kernel-function-p lfun)))
    1563           (%write-string (if kernel-function-p
    1564                            "Internal " "Anonymous ")
    1565                          stream)
     1561        (let* ((fnaddr (%address-of lfun)))
     1562          (%write-string "Anonymous " stream)
    15661563          (if (standard-generic-function-p lfun)
    15671564            (prin1 (class-name (class-of lfun)) stream)

  • branches/qres/ccl/level-1/l1-pathnames.lisp

    r13565 r14049  
    682682                                      (return-from full-pathname nil)
    683683                                      (error condition)))))
    684          (dir (%pathname-directory path)))
    685     (if (eq (car dir) :absolute)
    686       path
    687       (cons-pathname (absolute-directory-list dir)
    688                        (%pathname-name path)
    689                        (%pathname-type path)
    690                        (pathname-host path)
    691                        (pathname-version path)))))
     684         (dir (%pathname-directory path))
     685         (device #+windows-target
     686                 (or (pathname-device path)
     687                     (pathname-device (mac-default-directory)))
     688                 #-windows-target
     689                 nil))
     690    (cons-pathname (if (eq (car dir) :absolute)
     691                     dir
     692                     (absolute-directory-list dir))
     693                   (%pathname-name path)
     694                   (%pathname-type path)
     695                   (pathname-host path)
     696                   (pathname-version path)
     697                   device)))
    692698
    693699

  • branches/qres/ccl/level-1/l1-processes.lisp

    r13139 r14049  
    639639    (with-standard-abort-handling "Exit Lisp"
    640640      (prepare-to-quit)
    641       ;; We may have abruptly terminated a thread
    642       ;; which owned the output lock on *STDOUT*.
    643       ;; Don't block waiting on that lock if so.
    644       (let* ((s *stdout*)
    645              (lock (ioblock-outbuf-lock (basic-stream-ioblock s)))
    646              (locked (make-lock-acquisition)))
    647         (declare (dynamic-extent locked))
    648         (when (or (null lock) (%try-recursive-lock-object lock locked))
    649           (unwind-protect
    650                (progn
    651                  (fresh-line s)
    652                  (finish-output s)))
    653           (when (lock-acquisition.status locked) (release-lock lock)))))
     641      ;; We may have abruptly terminated a thread which owned the
     642      ;; output lock on a stream we want to flush.  Don't block
     643      ;; waiting on the lock if so.
     644      (flet ((flush-stream (s)
     645               (let* ((lock (ioblock-outbuf-lock (basic-stream-ioblock s)))
     646                      (locked (make-lock-acquisition)))
     647                 (declare (dynamic-extent locked))
     648                 (when (or (null lock)
     649                           (%try-recursive-lock-object lock locked))
     650                   (unwind-protect
     651                        (progn
     652                          (fresh-line s)
     653                          (finish-output s))
     654                     (when (lock-acquisition.status locked)
     655                       (release-lock lock)))))))
     656        (flush-stream *stdout*)
     657        (flush-stream *stderr*)))
    654658    (%set-toplevel thunk)
    655659    (toplevel)))
    … …  
    745749          (t default))))
    746750
    747 
     751(defun call-in-initial-process (f)
     752  (let* ((process *initial-process*)
     753         (return-values nil)
     754         (done (make-semaphore)))
     755    (process-interrupt process
     756                       #'(lambda ()
     757                           (unwind-protect
     758                                (progn
     759                                  (setq return-values
     760                                        (multiple-value-list (funcall f))))
     761                             (signal-semaphore done))))
     762    (wait-on-semaphore done)
     763    (apply #'values return-values)))
     764

  • branches/qres/ccl/level-1/l1-reader.lisp

    r13527 r14049  
    23502350
    23512351(defun %token-package (token colonpos seenbeforecolon stream)
     2352  (declare (ignorable stream))
    23522353  (if colonpos
    23532354    (if (and (eql colonpos 0) (not seenbeforecolon))
    … …  
    23552356      (let* ((string (token.string token)))
    23562357        (or (%find-pkg string colonpos)
     2358            (subseq string 0 colonpos)
     2359            #+nomore
    23572360            (signal-reader-error stream "Reference to unknown package ~s." (subseq string 0 colonpos)))))
    23582361    *package*))
    … …  
    24602463                  (progn                  ; Muck with readtable case of extended token.
    24612464                    (%casify-token tb (unless (atom escapes) escapes))
    2462                     (let* ((pkg (or explicit-package *package*)))
     2465                    (let* ((pkg (if explicit-package (pkg-arg explicit-package) *package*)))
    24632466                      (if (or double-colon (eq pkg *keyword-package*))
    24642467                        (without-interrupts

  • branches/qres/ccl/level-1/l1-readloop-lds.lisp

    r13565 r14049  
    576576      (format *error-output* "~&~A"
    577577              (get-output-stream-string s)))
    578     (format *error-output* ", in process ~a(~d).~%" (process-name *current-process*) (process-serial-number *current-process*))
     578    (if *current-process*
     579      (format *error-output* ", in process ~a(~d).~%" (process-name *current-process*) (process-serial-number *current-process*))
     580      (format *error-output* ", in an uninitialized process~%"))
    579581  (force-output *error-output*)))
    580582                                        ; returns NIL

  • branches/qres/ccl/level-1/l1-sockets.lisp

    r13503 r14049  
    453453(defmethod socket-type ((stream udp-socket)) :datagram)
    454454(defmethod socket-connect ((stream udp-socket)) nil)
     455(defmethod socket-format ((stream udp-socket)) :binary)
    455456
    456457(defgeneric socket-os-fd (socket)
    … …  
    949950            #+x8664-target (and (>= subtype x8664::min-8-bit-ivector-subtag)
    950951                                (<= subtype x8664::max-8-bit-ivector-subtag))
    951       (report-bad-arg buf `(or (array character)
    952                                (array (unsigned-byte 8))
     952      (report-bad-arg buf '(or (array (unsigned-byte 8))
    953953                               (array (signed-byte 8))))))
    954954  (values buf offset))
    … …  
    10101010                                :element-type
    10111011                                (ecase (socket-format socket)
    1012                                   ((:text) 'base-char)
    1013                                   ((:binary :bivalent) '(unsigned-byte 8))))
     1012                                  ((:binary) '(unsigned-byte 8))))
    10141013                vec-offset 0))
    10151014        (%copy-ptr-to-ivector bufptr 0 vec vec-offset ret-size))
    … …  
    14411440  (let* ((socket (#_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_IP)))
    14421441    (unwind-protect
    1443     (rlet ((realoutlen #>DWORD 0))
    1444       (do* ((reservedlen (* 4 (record-length #>INTERFACE_INFO))
    1445                          (* 2 reservedlen)))
    1446            ()
    1447         (%stack-block ((buf reservedlen))
    1448           (unless (eql 0 (#_WSAIoctl
    1449                           socket
    1450                           #$SIO_GET_INTERFACE_LIST
    1451                           (%null-ptr)
    1452                           0
    1453                           buf
    1454                           reservedlen
    1455                           realoutlen
    1456                           (%null-ptr)
    1457                           (%null-ptr)))
    1458             (return))
    1459           (let* ((noutbytes (pref realoutlen #>DWORD)))
    1460             (when (< noutbytes reservedlen)
    1461               (let* ((interfaces nil))
    1462                 (do* ((offset 0 (+ offset (record-length #>INTERFACE_INFO)))
    1463                       (nameidx 0 (1+ nameidx)))
    1464                      ((>= offset noutbytes))
    1465                   (with-macptrs ((p (%inc-ptr buf offset)))
    1466                     (push (make-ip-interface
    1467                            :name (format nil "ip~d" nameidx)
    1468                            :addr (ntohl
    1469                                   (pref (pref p #>INTERFACE_INFO.iiAddress)
    1470                                         #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr))
    1471                            :netmask (ntohl
    1472                                      (pref (pref p #>INTERFACE_INFO.iiNetmask)
    1473                                         #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr))
    1474                            :flags (pref p #>INTERFACE_INFO.iiFlags)
    1475                            :address-family #$AF_INET)
    1476                           interfaces)))
    1477                 (return interfaces)))))))
     1442         (rlet ((realoutlen #>DWORD 0))
     1443           (do* ((reservedlen (* 4 (record-length #>INTERFACE_INFO))
     1444                              (* 2 reservedlen)))
     1445                ()
     1446             (%stack-block ((buf reservedlen))
     1447               (if (eql 0  (#_WSAIoctl
     1448                            socket
     1449                            #$SIO_GET_INTERFACE_LIST
     1450                            (%null-ptr)
     1451                            0
     1452                            buf
     1453                            reservedlen
     1454                            realoutlen
     1455                            (%null-ptr)
     1456                            (%null-ptr)))
     1457               (let* ((noutbytes (pref realoutlen #>DWORD)))
     1458                 (when (< noutbytes reservedlen)
     1459                   (let* ((interfaces nil))
     1460
     1461                     (do* ((offset 0 (+ offset (record-length #>INTERFACE_INFO)))
     1462                           (nameidx 0 (1+ nameidx)))
     1463                          ((>= offset noutbytes))
     1464                       (with-macptrs ((p (%inc-ptr buf offset)))
     1465                         (push (make-ip-interface
     1466                                :name (format nil "ip~d" nameidx)
     1467                                :addr (ntohl
     1468                                       (pref (pref p #>INTERFACE_INFO.iiAddress)
     1469                                             #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr))
     1470                                :netmask (ntohl
     1471                                          (pref (pref p #>INTERFACE_INFO.iiNetmask)
     1472                                                #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr))
     1473                                :flags (pref p #>INTERFACE_INFO.iiFlags)
     1474                                :address-family #$AF_INET)
     1475                               interfaces)))
     1476                     (return interfaces))))
     1477               (let* ((err (#_WSAGetLastError)))
     1478                 (unless (eql err #$WSAEFAULT)
     1479                   (return)))))))
    14781480      (#_closesocket socket))))
    14791481

  • branches/qres/ccl/level-1/l1-streams.lisp

    r13510 r14049  
    341341  "This is meant to be shadowed by particular kinds of streams,
    342342   esp those associated with windows."
    343   80)
     343  *default-right-margin*)
    344344
    345345(defmethod interactive-stream-p ((x t))
    … …  
    38423842           (synonym-method stream-clear-output)
    38433843           (synonym-method stream-line-column)
     3844           (synonym-method stream-line-length)
    38443845           (synonym-method stream-set-column new)
    38453846           (synonym-method stream-advance-to-column new)
    … …  
    39363937  (two-way-output-method stream-clear-output)
    39373938  (two-way-output-method stream-line-column)
     3939  (two-way-output-method stream-line-length)
    39383940  (two-way-output-method stream-set-column new)
    39393941  (two-way-output-method stream-advance-to-column new)
    … …  
    61546156                 (declare ((simple-array (unsigned-byte 8) (*)) data)
    61556157                          (fixnum offset))
    6156                  (%copy-ivector-to-ivector new 0 data offset len)
     6158                 (%copy-ivector-to-ivector data 0 new offset len)
    61576159                 (setf (vector-output-stream-ioblock-displacement ioblock) 0)
    61586160                 (unless (= 0 offset)
    … …  
    61766178             (declare (fixnum len newlen)
    61776179                      ((simple-array (unsigned-byte 8) (*)) old new))
    6178              (%copy-ivector-to-ivector new 0 old 0 len)
     6180             (%copy-ivector-to-ivector old 0 new 0 len)
    61796181             (setf (io-buffer-buffer outbuf) new
    61806182                   (io-buffer-size outbuf) newlen
    … …  
    62186220
    62196221
    6220 (defun unsigned-integer-to-binary (value len s)
     6222(defmethod unsigned-integer-to-binary (value len (s binary-output-stream))
     6223  (unless (typep value 'unsigned-byte)
     6224    (report-bad-arg value 'unsigned-byte))
     6225  (do* ((shift (ash (1- len) 3) (- shift 8)))
     6226       ((< shift 0) value)
     6227    (write-byte (logand #xff (ash value (- shift))) s)))
     6228
     6229(defun %unsigned-integer-to-binary (value len s)
    62216230  (declare (fixnum len))
    62226231  (unless (and (typep s 'basic-stream)
    … …  
    62776286             (incf idx))))))))
    62786287
    6279 (defun signed-integer-to-binary (value len s)
     6288(defmethod unsigned-integer-to-binary (value len (s vector-output-stream))
     6289  (%unsigned-integer-to-binary value len s))
     6290
     6291(defun %signed-integer-to-binary (value len s)
    62806292  (declare (fixnum len))
    62816293  (unless (and (typep s 'basic-stream)
    … …  
    63296341                     (aref value #+little-endian-target n #+big-endian-target (the fixnum (logxor n 3)))))
    63306342             (incf idx))))))))
     6343
     6344(defmethod signed-integer-to-binary (value len (s vector-output-stream))
     6345  (%signed-integer-to-binary value len s))
    63316346     
    6332              
     6347(defmethod signed-integer-to-binary (value len (s binary-output-stream))
     6348  (do* ((shift (ash (1- len) 3) (- shift 8)))
     6349       ((< shift 0) value)
     6350    (write-byte (logand #xff (ash value (- shift))) s)))             
    63336351               
    63346352
    … …  
    64686486
    64696487
    6470 
    6471 (defun pui-stream (s count)
     6488(defmethod pui-stream ((s binary-input-stream) count)
     6489  "Parse unsigned integer from a stream."
     6490  (declare (fixnum count)               ; any integer that cannot be expressed in fixnum bytes is probably (ahem) too long to worry about
     6491           (optimize (speed 3) (safety 1) (debug 1)))
     6492  (let ((n 0))
     6493    (dotimes (i count n)
     6494      (declare (fixnum i))
     6495      (setq n (+ (the fixnum (read-byte s)) (the integer (ash n 8)))))))
     6496
     6497(defun %pui-stream (s count)
    64726498  (declare (fixnum count))
    64736499  (unless (and (typep s 'basic-stream)
    … …  
    64916517      result)))
    64926518
    6493 (defun psi-stream (s count)
     6519(defmethod pui-stream ((s vector-input-stream) count)
     6520  (%pui-stream s count))
     6521
     6522(defmethod psi-stream ((s binary-input-stream) count)
     6523  (declare (fixnum count))
     6524  (if (zerop count)
     6525    0
     6526    (let* ((n (read-byte s)))
     6527      (if (>= n 128)
     6528        (setq n (- n 256)))
     6529      (dotimes (i (the fixnum (1- count)) n)
     6530        (setq n (logior (read-byte s) (ash n 8)))))))
     6531
     6532(defun %psi-stream (s count)
    64946533  (declare (fixnum count))
    64956534  (unless (and (typep s 'basic-stream)
    … …  
    65126551      result)))
    65136552
     6553(defmethod psi-stream ((s vector-input-stream) count)
     6554  (%psi-stream s count))
     6555
    65146556(defmethod stream-position ((s vector-input-stream) &optional newpos)
    65156557  (let* ((ioblock (basic-stream-ioblock s))

  • branches/qres/ccl/level-1/l1-symhash.lisp

    r13138 r14049  
    1919
    2020(declaim (special %all-packages%))
    21 (declaim (list %all-package%))
     21(declaim (list %all-packages%))
    2222(declaim (type package *package*))
    2323

  • branches/qres/ccl/level-1/l1-utils.lisp

    r13507 r14049  
    742742;;;;;FUNCTION BINDING Functions
    743743
    744 ;;; A symbol's entrypoint contains:
    745 ;;;  1) something tagged as $t_lfun if the symbol is
    746 ;;;     not fbound as a macro or special form;
    747 ;;;  2) a cons, otherwise, where the cdr is a fixnum
    748 ;;;     whose value happens to be the same bit-pattern
    749 ;;;     as a "jsr_subprim $sp-apply-macro" instruction.
    750 ;;;     The car of this cons is either:
    751 ;;;     a) a function -> macro-function;
    752 ;;;     b) a symbol: special form not redefined as a macro.
    753 ;;;     c) a cons whose car is a function -> macro function defined
    754 ;;;        on a special form.
    755 
    756 
    757 
    758 
    759744(defun symbol-function (name)
    760745  "Return the definition of NAME, even if it is a macro or a special form.
    … …  
    764749
    765750(%fhave 'fdefinition #'symbol-function)
    766 
    767 
    768 (defun kernel-function-p (f)
    769   (declare (ignore f))
    770   nil)
    771751
    772752(defun %make-function (name fn env)
    … …  
    834814
    835815(defstatic *pathname-escape-character*
    836   #+windows-target #\'
     816  #+windows-target #\>
    837817  #-windows-target #\\
    838818  "Not CL.  A Coral addition for compatibility between CL spec and the shell.")
    839819
    840 
    841 (defun caar (x)
    842   "Return the car of the 1st sublist."
    843  (car (car x)))
    844 
    845 (defun cadr (x)
    846   "Return the 2nd object in a list."
    847  (car (cdr x)))
    848 
    849 (defun cdar (x)
    850   "Return the cdr of the 1st sublist."
    851  (cdr (car x)))
    852 
    853 (defun cddr (x)
    854   "Return all but the 1st two objects of a list."
    855 
    856  (cdr (cdr x)))
    857 
    858 (defun caaar (x)
    859   "Return the 1st object in the caar of a list."
    860  (car (car (car x))))
    861 
    862 (defun caadr (x)
    863   "Return the 1st object in the cadr of a list."
    864  (car (car (cdr x))))
    865 
    866 (defun cadar (x)
    867   "Return the car of the cdar of a list."
    868  (car (cdr (car x))))
    869 
    870 (defun caddr (x)
    871   "Return the 1st object in the cddr of a list."
    872  (car (cdr (cdr x))))
    873 
    874 (defun cdaar (x)
    875   "Return the cdr of the caar of a list."
    876  (cdr (car (car x))))
    877 
    878 (defun cdadr (x)
    879   "Return the cdr of the cadr of a list."
    880  (cdr (car (cdr x))))
    881 
    882 (defun cddar (x)
    883   "Return the cdr of the cdar of a list."
    884  (cdr (cdr (car x))))
    885 
    886 (defun cdddr (x)
    887   "Return the cdr of the cddr of a list."
    888  (cdr (cdr (cdr x))))
    889 
    890 (defun cadddr (x)
    891   "Return the car of the cdddr of a list."
    892  (car (cdr (cdr (cdr x)))))
     820(defun caar (x) (car (car x)))
     821(defun cadr (x) (car (cdr x)))
     822(defun cdar (x) (cdr (car x)))
     823(defun cddr (x) (cdr (cdr x)))
     824
     825(defun caaar (x) (car (car (car x))))
     826(defun caadr (x) (car (car (cdr x))))
     827(defun cadar (x) (car (cdr (car x))))
     828(defun caddr (x) (car (cdr (cdr x))))
     829(defun cdaar (x) (cdr (car (car x))))
     830(defun cdadr (x) (cdr (car (cdr x))))
     831(defun cddar (x) (cdr (cdr (car x))))
     832(defun cdddr (x) (cdr (cdr (cdr x))))
    893833
    894834(%fhave 'type-of #'%type-of)

  • 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)

  • branches/qres/ccl/lisp-kernel/gc-common.c

    r13294 r14049  
    12761276    pkg = 0,
    12771277    itabvec = 0;
    1278   BytePtr oldfree = a->active;
     1278  BytePtr oldfree = a->active, last_zeroed_addr;
    12791279  TCR *other_tcr;
    12801280  natural static_dnodes;
    … …  
    15851585    }
    15861586
    1587     zero_memory_range(a->active, oldfree);
    15881587
    15891588    resize_dynamic_heap(a->active,
    15901589                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
     1590
     1591    if (oldfree < a->high) {
     1592      last_zeroed_addr = oldfree;
     1593    } else {
     1594      last_zeroed_addr = a->high;
     1595    }
     1596    zero_memory_range(a->active, last_zeroed_addr);
    15911597
    15921598    /*

  • branches/qres/ccl/lisp-kernel/lisp-debug.c

    r13867 r14049  
    300300          dsisr & (1<<27) ? "protected" : "unmapped",
    301301          addr);
    302 #elif defined(WINDOWS)
     302#elif defined(WINDOWS) || defined(FREEBSD)
     303  /*
     304   * It's not surprising that Windows doesn't have this signal stuff.
     305   * It is somewhat surprising that FreeBSD 6.x lacks the si_code
     306   * constants.  (Subsequent FreeBSD versions define them, though.)
     307   */
    303308#else
    304309  fprintf(dbgout, "received signal %d; faulting address: %p\n",

  • branches/qres/ccl/lisp-kernel/pmcl-kernel.c

    r14048 r14049  
    444444{
    445445  if (len != 0) {
    446     if (CommitMemory(start, len)) {
    447       if (touch_all_pages(start, len)) {
    448         return true;
    449       }
     446    if (!CommitMemory(start, len)) {
     447      return false;
     448    }
     449    if (!touch_all_pages(start, len)) {
     450      return false;
    450451    }
    451452  }

  • branches/qres/ccl/lisp-kernel/thread_manager.c

    r13502 r14049  
    100100      (!((where < (pc)lisp_global(HEAP_END)) &&
    101101         (where >= (pc)lisp_global(HEAP_START))) &&
     102       (!((where < (pc)(managed_static_area->active)) &&
     103         (where >= (pc)(readonly_area->low)))) &&
    102104       !((where < spentry_end) && (where >= spentry_start)) &&
    103105       !((where < subprims_end) && (where >= subprims_start)) &&
    … …  
    19481950    *pcontext = * (CONTEXT *)(pcontext->Rcx);
    19491951#else
    1950     *pcontext = * (CONTEXT *)(pcontext->Ecx);
     1952    if (where == restore_windows_context_start) {
     1953      *pcontext = * (CONTEXT *)((pcontext->Esp)+4);
     1954    } else {
     1955      *pcontext = * (CONTEXT *)(pcontext->Ecx);
     1956    }
    19511957#endif
    19521958  } else {
    … …  
    19711977  }
    19721978  tcr->pending_exception_context = NULL;
     1979  /* We basically never return from an exception unless we
     1980     were executing lisp code when the exception returned.
     1981     If that ever changes, we need to know what valence
     1982     would have been restored here.*/
     1983  tcr->valence = TCR_STATE_LISP;
    19731984}
    19741985
    … …  
    20172028        if (!((where < (pc)lisp_global(HEAP_END)) &&
    20182029              (where >= (pc)lisp_global(HEAP_START))) &&
     2030            (!((where < (pc)(managed_static_area->active)) &&
     2031              (where >= (pc)(readonly_area->low)))) &&
    20192032            !((where < spentry_end) && (where >= spentry_start)) &&
    20202033            !((where < subprims_end) && (where >= subprims_start)) &&

  • branches/qres/ccl/lisp-kernel/windows-calls.c

    r13070 r14049  
    718718}
    719719
    720 #ifdef WIN_64
    721 
    722720/* Make sure that the lisp calls these functions, when they do something */
    723721/* This code is taken from the 32-bit mingw library and is in the
    … …  
    871869}
    872870
    873 #endif
    874871
    875872typedef struct {

  • branches/qres/ccl/lisp-kernel/x86-exceptions.c

    r13867 r14049  
    473473  xpPC(xp) += skip;
    474474}
     475
     476#ifndef SIGTRAP
     477#define SIGTRAP 5
     478#endif
    475479
    476480/*
    … …  
    32873291      case EXC_ARITHMETIC:
    32883292        signum = SIGFPE;
     3293        if (code == EXC_I386_DIV)
     3294          code = FPE_INTDIV;
    32893295        break;
    32903296       
Note: See TracChangeset for help on using the changeset viewer.