Changeset 14049
- Timestamp:
- Jul 27, 2010, 12:59:48 AM (9 years ago)
- Location:
- branches/qres/ccl
- Files:
-
- 1 deleted
- 29 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
branches/qres/ccl
- Property svn:mergeinfo changed
-
branches/qres/ccl/compiler/nx0.lisp
r13502 r14049 1922 1922 1923 1923 (defun nx1-combination (form env) 1924 (destructuring-bind (sym &rest args) 1925 form 1924 (destructuring-bind (sym &rest args) form 1926 1925 (if (symbolp sym) 1927 1926 (let* ((*nx-sfname* sym) special) … … 1932 1931 )) 1933 1932 (< (safety-optimize-quantity env) 3)) 1934 ; (not (nx-lexical-finfo sym env))1933 ;;(not (nx-lexical-finfo sym env)) 1935 1934 (not (nx-declared-notinline-p sym *nx-lexical-environment*))) 1936 1935 (funcall special form env) ; pass environment arg ... … … 1939 1938 (if (lambda-expression-p sym) 1940 1939 (nx1-lambda-bind (%cadr sym) args (%cddr sym)) 1941 1940 (nx-error "In the form ~S, ~S is not a symbol or lambda expression." form sym))))) 1942 1941 1943 1942 (defun nx1-treat-as-call (args) -
branches/qres/ccl/compiler/nxenv.lisp
r13070 r14049 26 26 (require 'lispequ) 27 27 ) 28 29 #-bootstrapped30 (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))))35 28 36 29 #+ppc-target (require "PPCENV") … … 387 380 388 381 (defmacro %nx1-default-operator () 389 #-bccl 390 `(nx1-default-operator) 391 #+bccl 392 `(gethash *nx-sfname* *nx1-operators*)) 382 `(nx1-default-operator)) 393 383 394 384 (defmacro defnx1 (name sym arglist &body forms) … … 441 431 442 432 (defconstant $eaclosedbit 24) 443 444 #+what?445 (progn446 ;;; condition codes :447 ;;; These are 68K condition code values, but the frontend uses them and448 ;;; both backends need to understand them.449 ;;; They're really backend-specific; it wouldn't hurt to have the frontend450 ;;; 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 463 433 464 434 (defmacro %temp-push (value place &environment env) -
branches/qres/ccl/level-0/l0-float.lisp
r13070 r14049 840 840 (%single-float-expt (%short-float b) (%short-float e)) 841 841 )) 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))))) 842 846 (t (exp (* e (log b)))))) 843 847 -
branches/qres/ccl/level-0/l0-numbers.lisp
r13546 r14049 1157 1157 (number-case divisor 1158 1158 (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))) 1160 1163 (double-float (truncate-rat-dfloat number divisor)) 1161 1164 (short-float (truncate-rat-sfloat number divisor)) … … 1164 1167 (values q (- number (* q divisor))))))) 1165 1168 (bignum (number-case divisor 1166 (fixnum (if (eq divisor 1) (values number 0) 1169 (fixnum (if (eq divisor 1) 1170 (values number 0) 1167 1171 (if (eq divisor target::target-most-negative-fixnum);; << aargh 1168 1172 (with-small-bignum-buffers ((bd divisor)) -
branches/qres/ccl/level-1/l1-clos-boot.lisp
r13364 r14049 902 902 903 903 (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)))919 904 920 905 (defun methods-congruent-p (m1 m2) -
branches/qres/ccl/level-1/l1-files.lisp
r13502 r14049 532 532 (require-type reference-host '(or null string)) 533 533 (multiple-value-bind (sstr start end) (get-pathname-sstring string start end) 534 #-windows-target535 534 (if (and (> end start) 536 535 (eql (schar sstr start) #\~)) -
branches/qres/ccl/level-1/l1-io.lisp
r13070 r14049 1559 1559 (if name 1560 1560 (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) 1566 1563 (if (standard-generic-function-p lfun) 1567 1564 (prin1 (class-name (class-of lfun)) stream) -
branches/qres/ccl/level-1/l1-pathnames.lisp
r13565 r14049 682 682 (return-from full-pathname nil) 683 683 (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))) 692 698 693 699 -
branches/qres/ccl/level-1/l1-processes.lisp
r13139 r14049 639 639 (with-standard-abort-handling "Exit Lisp" 640 640 (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*))) 654 658 (%set-toplevel thunk) 655 659 (toplevel))) … … 745 749 (t default)))) 746 750 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 2350 2350 2351 2351 (defun %token-package (token colonpos seenbeforecolon stream) 2352 (declare (ignorable stream)) 2352 2353 (if colonpos 2353 2354 (if (and (eql colonpos 0) (not seenbeforecolon)) … … 2355 2356 (let* ((string (token.string token))) 2356 2357 (or (%find-pkg string colonpos) 2358 (subseq string 0 colonpos) 2359 #+nomore 2357 2360 (signal-reader-error stream "Reference to unknown package ~s." (subseq string 0 colonpos))))) 2358 2361 *package*)) … … 2460 2463 (progn ; Muck with readtable case of extended token. 2461 2464 (%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*))) 2463 2466 (if (or double-colon (eq pkg *keyword-package*)) 2464 2467 (without-interrupts -
branches/qres/ccl/level-1/l1-readloop-lds.lisp
r13565 r14049 576 576 (format *error-output* "~&~A" 577 577 (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~%")) 579 581 (force-output *error-output*))) 580 582 ; returns NIL -
branches/qres/ccl/level-1/l1-sockets.lisp
r13503 r14049 453 453 (defmethod socket-type ((stream udp-socket)) :datagram) 454 454 (defmethod socket-connect ((stream udp-socket)) nil) 455 (defmethod socket-format ((stream udp-socket)) :binary) 455 456 456 457 (defgeneric socket-os-fd (socket) … … 949 950 #+x8664-target (and (>= subtype x8664::min-8-bit-ivector-subtag) 950 951 (<= 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)) 953 953 (array (signed-byte 8)))))) 954 954 (values buf offset)) … … 1010 1010 :element-type 1011 1011 (ecase (socket-format socket) 1012 ((:text) 'base-char) 1013 ((:binary :bivalent) '(unsigned-byte 8)))) 1012 ((:binary) '(unsigned-byte 8)))) 1014 1013 vec-offset 0)) 1015 1014 (%copy-ptr-to-ivector bufptr 0 vec vec-offset ret-size)) … … 1441 1440 (let* ((socket (#_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_IP))) 1442 1441 (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))))))) 1478 1480 (#_closesocket socket)))) 1479 1481 -
branches/qres/ccl/level-1/l1-streams.lisp
r13510 r14049 341 341 "This is meant to be shadowed by particular kinds of streams, 342 342 esp those associated with windows." 343 80)343 *default-right-margin*) 344 344 345 345 (defmethod interactive-stream-p ((x t)) … … 3842 3842 (synonym-method stream-clear-output) 3843 3843 (synonym-method stream-line-column) 3844 (synonym-method stream-line-length) 3844 3845 (synonym-method stream-set-column new) 3845 3846 (synonym-method stream-advance-to-column new) … … 3936 3937 (two-way-output-method stream-clear-output) 3937 3938 (two-way-output-method stream-line-column) 3939 (two-way-output-method stream-line-length) 3938 3940 (two-way-output-method stream-set-column new) 3939 3941 (two-way-output-method stream-advance-to-column new) … … 6154 6156 (declare ((simple-array (unsigned-byte 8) (*)) data) 6155 6157 (fixnum offset)) 6156 (%copy-ivector-to-ivector new 0 dataoffset len)6158 (%copy-ivector-to-ivector data 0 new offset len) 6157 6159 (setf (vector-output-stream-ioblock-displacement ioblock) 0) 6158 6160 (unless (= 0 offset) … … 6176 6178 (declare (fixnum len newlen) 6177 6179 ((simple-array (unsigned-byte 8) (*)) old new)) 6178 (%copy-ivector-to-ivector new 0 old0 len)6180 (%copy-ivector-to-ivector old 0 new 0 len) 6179 6181 (setf (io-buffer-buffer outbuf) new 6180 6182 (io-buffer-size outbuf) newlen … … 6218 6220 6219 6221 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) 6221 6230 (declare (fixnum len)) 6222 6231 (unless (and (typep s 'basic-stream) … … 6277 6286 (incf idx)))))))) 6278 6287 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) 6280 6292 (declare (fixnum len)) 6281 6293 (unless (and (typep s 'basic-stream) … … 6329 6341 (aref value #+little-endian-target n #+big-endian-target (the fixnum (logxor n 3))))) 6330 6342 (incf idx)))))))) 6343 6344 (defmethod signed-integer-to-binary (value len (s vector-output-stream)) 6345 (%signed-integer-to-binary value len s)) 6331 6346 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))) 6333 6351 6334 6352 … … 6468 6486 6469 6487 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) 6472 6498 (declare (fixnum count)) 6473 6499 (unless (and (typep s 'basic-stream) … … 6491 6517 result))) 6492 6518 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) 6494 6533 (declare (fixnum count)) 6495 6534 (unless (and (typep s 'basic-stream) … … 6512 6551 result))) 6513 6552 6553 (defmethod psi-stream ((s vector-input-stream) count) 6554 (%psi-stream s count)) 6555 6514 6556 (defmethod stream-position ((s vector-input-stream) &optional newpos) 6515 6557 (let* ((ioblock (basic-stream-ioblock s)) -
branches/qres/ccl/level-1/l1-symhash.lisp
r13138 r14049 19 19 20 20 (declaim (special %all-packages%)) 21 (declaim (list %all-package %))21 (declaim (list %all-packages%)) 22 22 (declaim (type package *package*)) 23 23 -
branches/qres/ccl/level-1/l1-utils.lisp
r13507 r14049 742 742 ;;;;;FUNCTION BINDING Functions 743 743 744 ;;; A symbol's entrypoint contains:745 ;;; 1) something tagged as $t_lfun if the symbol is746 ;;; not fbound as a macro or special form;747 ;;; 2) a cons, otherwise, where the cdr is a fixnum748 ;;; whose value happens to be the same bit-pattern749 ;;; 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 defined754 ;;; on a special form.755 756 757 758 759 744 (defun symbol-function (name) 760 745 "Return the definition of NAME, even if it is a macro or a special form. … … 764 749 765 750 (%fhave 'fdefinition #'symbol-function) 766 767 768 (defun kernel-function-p (f)769 (declare (ignore f))770 nil)771 751 772 752 (defun %make-function (name fn env) … … 834 814 835 815 (defstatic *pathname-escape-character* 836 #+windows-target #\ '816 #+windows-target #\> 837 817 #-windows-target #\\ 838 818 "Not CL. A Coral addition for compatibility between CL spec and the shell.") 839 819 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)))) 893 833 894 834 (%fhave 'type-of #'%type-of) -
branches/qres/ccl/lib/ccl-export-syms.lisp
r13558 r14049 726 726 *vector-output-stream-default-initial-allocation* 727 727 external-process-creation-failure 728 object-direct-size 728 729 729 730 ) "CCL" -
branches/qres/ccl/lib/compile-ccl.lisp
r13528 r14049 550 550 (setq allow-constant-redefinition t)))) 551 551 (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)) 553 554 (unwind-protect 554 555 (progn … … 668 669 (multiple-value-bind (status exit-code) 669 670 (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)) 671 672 (when verbose (format t "~&;'svn update' complete.")) 672 673 (if (not (and (eq status :exited) … … 685 686 (flet ((svn-revert (string) 686 687 (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))) 688 689 (when (and (eq status :exited) (eql exit-code 0)) 689 690 (setq conflicts (delete string conflicts :test #'string=)) … … 750 751 (when update 751 752 (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)) 755 756 (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) 760 765 (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)))))))) 767 772 (cwd "ccl:tests;ansi-tests;") 768 773 (run-program "make" '("-k" "clean")) … … 797 802 798 803 (defun test-ccl (&key force (update t) verbose (catch-errors t) (ansi t) (ccl t) 799 optimization-settings )804 optimization-settings exit) 800 805 (with-preserved-working-directory () 801 806 (let* ((*package* (find-package "CL-USER"))) … … 812 817 (map nil #'delete-file 813 818 (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 1231 1231 "Arglist unknown"))) 1232 1232 (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)) 1233 1235 (when doc (list (list (substitute #\space #\newline doc) "Documentation" :colon))) 1234 1236 (when sn (list (list sn "Source Location" :colon)))))) … … 1279 1281 (let* ((value (ccl::nth-immediate o (1+ (- nclosed n)))) 1280 1282 (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)))) 1282 1284 n)) 1283 1285 (cellp (ccl::closed-over-value-p value))) … … 1328 1330 (if (< (decf n) 0) 1329 1331 (values nil "Disassembly:" :comment) 1330 (let ((line ( svref (disasm-info f) n)))1332 (let ((line (aref (disasm-info f) n))) 1331 1333 (if (consp line) 1332 1334 (destructuring-bind (object label instr) line … … 1336 1338 (defun disassembly-line-n-inspector (f n) 1337 1339 (unless (< (decf n) 0) 1338 (let ((line ( svref (disasm-info f) n)))1340 (let ((line (aref (disasm-info f) n))) 1339 1341 (and (consp line) 1340 1342 (car line) … … 1344 1346 (if (< (decf n) 0) 1345 1347 (values "Disassembly:" nil) 1346 (let ((line ( svref (disasm-info f) n)))1348 (let ((line (aref (disasm-info f) n))) 1347 1349 (if (consp line) 1348 1350 (destructuring-bind (object label instr) line … … 1601 1603 1602 1604 (defmethod compute-frame-info ((f error-frame) n) 1603 (let* ((frame ( svref (addresses f) n))1605 (let* ((frame (aref (addresses f) n)) 1604 1606 (context (context f)) 1605 1607 (marker (unavailable-value-marker f))) … … 1665 1667 1666 1668 (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))) 1668 1670 (ccl::cfp-lfun frame))) 1669 1671 -
branches/qres/ccl/lib/lists.lisp
r13070 r14049 22 22 (require 'level-2)) 23 23 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))) 104 40 105 41 (defun tree-equal (x y &key (test (function eql)) test-not) -
branches/qres/ccl/lib/misc.lisp
r13547 r14049 422 422 (info #>task_events_info)) 423 423 (#_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))) 427 429 #+windows-target 428 430 ;; Um, don't know how to determine this, or anything like it. … … 1199 1201 (* 100.0 (/ physsize total-psize))))) 1200 1202 (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%~%" 1202 1204 "Total" 1203 1205 (1+ max-name) … … 1206 1208 (/ total-psize div) 1207 1209 100.0d0) 1208 (format stream "~&~a~vt~11d~16d~16d~11,2f% "1210 (format stream "~&~a~vt~11d~16d~16d~11,2f%~%" 1209 1211 "Total" 1210 1212 (1+ max-name) … … 1218 1220 ;; one and we don't have any left over 1219 1221 (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))) 1220 1245 1221 1246 (defun initialize-static-cons () -
branches/qres/ccl/lib/nfcomp.lisp
r13685 r14049 1454 1454 (defun fasl-dump-block (gnames goffsets forms hash) 1455 1455 (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))1458 1456 (fasl-out-word FASL-VERSION) ; Word 0 1459 1457 (fasl-out-long 0) -
branches/qres/ccl/lib/streams.lisp
r13508 r14049 131 131 132 132 (defun line-length (stream) 133 (or (stream-line-length stream) 80))133 (or (stream-line-length stream) *default-right-margin*)) 134 134 135 135 (defun write-byte (byte stream) -
branches/qres/ccl/lisp-kernel/gc-common.c
r13294 r14049 1276 1276 pkg = 0, 1277 1277 itabvec = 0; 1278 BytePtr oldfree = a->active ;1278 BytePtr oldfree = a->active, last_zeroed_addr; 1279 1279 TCR *other_tcr; 1280 1280 natural static_dnodes; … … 1585 1585 } 1586 1586 1587 zero_memory_range(a->active, oldfree);1588 1587 1589 1588 resize_dynamic_heap(a->active, 1590 1589 (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); 1591 1597 1592 1598 /* -
branches/qres/ccl/lisp-kernel/lisp-debug.c
r13867 r14049 300 300 dsisr & (1<<27) ? "protected" : "unmapped", 301 301 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 */ 303 308 #else 304 309 fprintf(dbgout, "received signal %d; faulting address: %p\n", -
branches/qres/ccl/lisp-kernel/pmcl-kernel.c
r14048 r14049 444 444 { 445 445 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; 450 451 } 451 452 } -
branches/qres/ccl/lisp-kernel/thread_manager.c
r13502 r14049 100 100 (!((where < (pc)lisp_global(HEAP_END)) && 101 101 (where >= (pc)lisp_global(HEAP_START))) && 102 (!((where < (pc)(managed_static_area->active)) && 103 (where >= (pc)(readonly_area->low)))) && 102 104 !((where < spentry_end) && (where >= spentry_start)) && 103 105 !((where < subprims_end) && (where >= subprims_start)) && … … 1948 1950 *pcontext = * (CONTEXT *)(pcontext->Rcx); 1949 1951 #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 } 1951 1957 #endif 1952 1958 } else { … … 1971 1977 } 1972 1978 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; 1973 1984 } 1974 1985 … … 2017 2028 if (!((where < (pc)lisp_global(HEAP_END)) && 2018 2029 (where >= (pc)lisp_global(HEAP_START))) && 2030 (!((where < (pc)(managed_static_area->active)) && 2031 (where >= (pc)(readonly_area->low)))) && 2019 2032 !((where < spentry_end) && (where >= spentry_start)) && 2020 2033 !((where < subprims_end) && (where >= subprims_start)) && -
branches/qres/ccl/lisp-kernel/windows-calls.c
r13070 r14049 718 718 } 719 719 720 #ifdef WIN_64721 722 720 /* Make sure that the lisp calls these functions, when they do something */ 723 721 /* This code is taken from the 32-bit mingw library and is in the … … 871 869 } 872 870 873 #endif874 871 875 872 typedef struct { -
branches/qres/ccl/lisp-kernel/x86-exceptions.c
r13867 r14049 473 473 xpPC(xp) += skip; 474 474 } 475 476 #ifndef SIGTRAP 477 #define SIGTRAP 5 478 #endif 475 479 476 480 /* … … 3287 3291 case EXC_ARITHMETIC: 3288 3292 signum = SIGFPE; 3293 if (code == EXC_I386_DIV) 3294 code = FPE_INTDIV; 3289 3295 break; 3290 3296
Note: See TracChangeset
for help on using the changeset viewer.