- cmucl-cvs - mailman3.common-lisp.net

[cmucl-cvs] CMUCL commit: src/lisp (lisp.h)
by Raymond Toy 10 Oct '10

10 Oct '10

Date: Sunday, October 10, 2010 @ 10:54:52 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Modified: lisp.h Use lowtag_Bits -1 instead a hard-wired 2. --------+ lisp.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) Index: src/lisp/lisp.h diff -u src/lisp/lisp.h:1.11 src/lisp/lisp.h:1.12 --- src/lisp/lisp.h:1.11 Wed Nov 12 10:04:24 2008 +++ src/lisp/lisp.h Sun Oct 10 10:54:52 2010 @@ -1,4 +1,4 @@ -/* $Header: /project/cmucl/cvsroot/src/lisp/lisp.h,v 1.11 2008-11-12 15:04:24 rtoy Rel $ */ +/* $Header: /project/cmucl/cvsroot/src/lisp/lisp.h,v 1.12 2010-10-10 14:54:52 rtoy Exp $ */ #ifndef _LISP_H_ #define _LISP_H_ @@ -28,8 +28,8 @@ typedef u32 lispobj; #endif -#define make_fixnum(n) ((lispobj)((n)<<2)) -#define fixnum_value(n) (((long)n)>>2) +#define make_fixnum(n) ((lispobj)((n)<<(lowtag_Bits-1))) +#define fixnum_value(n) (((long)n)>>(lowtag_Bits-1)) #define boolean int #ifndef TRUE

1 0

[cmucl-cvs] CMUCL commit: src/lisp (print.c)
by Raymond Toy 10 Oct '10

10 Oct '10

Date: Sunday, October 10, 2010 @ 10:11:47 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Modified: print.c Fix typos introduced in last commit. ---------+ print.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) Index: src/lisp/print.c diff -u src/lisp/print.c:1.27 src/lisp/print.c:1.28 --- src/lisp/print.c:1.27 Sun Oct 10 09:02:10 2010 +++ src/lisp/print.c Sun Oct 10 10:11:47 2010 @@ -1,4 +1,4 @@ -/* $Header: /project/cmucl/cvsroot/src/lisp/print.c,v 1.27 2010-10-10 13:02:10 rtoy Exp $ */ +/* $Header: /project/cmucl/cvsroot/src/lisp/print.c,v 1.28 2010-10-10 14:11:47 rtoy Exp $ */ #include <stdio.h> #include <string.h> @@ -385,7 +385,7 @@ #else { char *charptr = (char *) vector->data; - int len = (int) (vector->length >> (logtag_Bits - 1); + int len = (int) (vector->length >> (lowtag_Bits - 1)); while (len-- > 0) { if ((charptr[0] == 0)

1 0

[cmucl-cvs] CMUCL commit: src/lisp (print.c)
by Raymond Toy 10 Oct '10

10 Oct '10

Date: Sunday, October 10, 2010 @ 09:02:10 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Modified: print.c Use lowtag_Bits - 1 instead of a bare 2 when converting a fixnum object to its value. ---------+ print.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) Index: src/lisp/print.c diff -u src/lisp/print.c:1.26 src/lisp/print.c:1.27 --- src/lisp/print.c:1.26 Sun Oct 10 08:52:58 2010 +++ src/lisp/print.c Sun Oct 10 09:02:10 2010 @@ -1,4 +1,4 @@ -/* $Header: /project/cmucl/cvsroot/src/lisp/print.c,v 1.26 2010-10-10 12:52:58 rtoy Exp $ */ +/* $Header: /project/cmucl/cvsroot/src/lisp/print.c,v 1.27 2010-10-10 13:02:10 rtoy Exp $ */ #include <stdio.h> #include <string.h> @@ -385,7 +385,7 @@ #else { char *charptr = (char *) vector->data; - int len = (int) (vector->length >> 2); + int len = (int) (vector->length >> (logtag_Bits - 1); while (len-- > 0) { if ((charptr[0] == 0) @@ -412,7 +412,7 @@ #else /* FIXME: Unicode hack! */ { - int len = (((struct vector *) ptr)->length) >> 2; + int len = (((struct vector *) ptr)->length) >> (lowtag_Bits - 1); unsigned short int *wcharptr = (unsigned short int *) vector->data; while (len-- > 0) { @@ -523,7 +523,7 @@ } header = *ptr++; - length = (*ptr) >> 2; + length = (*ptr) >> (lowtag_Bits - 1); count = header >> 8; type = TypeOf(header);

1 0

[cmucl-cvs] CMUCL commit: src/lisp (print.c)
by Raymond Toy 10 Oct '10

10 Oct '10

Date: Sunday, October 10, 2010 @ 08:52:58 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Modified: print.c In brief_otherptr, the name slot of a symbol was not printing out the name correctly for unicode strings. It stopped after the first 0 byte, which basically means either nothing or a single byte is printed. Just dump out the entire UTF-16 octets in native byte order. ---------+ print.c | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) Index: src/lisp/print.c diff -u src/lisp/print.c:1.25 src/lisp/print.c:1.26 --- src/lisp/print.c:1.25 Thu Jun 11 12:04:01 2009 +++ src/lisp/print.c Sun Oct 10 08:52:58 2010 @@ -1,4 +1,4 @@ -/* $Header: /project/cmucl/cvsroot/src/lisp/print.c,v 1.25 2009-06-11 16:04:01 rtoy Rel $ */ +/* $Header: /project/cmucl/cvsroot/src/lisp/print.c,v 1.26 2010-10-10 12:52:58 rtoy Exp $ */ #include <stdio.h> #include <string.h> @@ -376,11 +376,28 @@ case type_SymbolHeader: symbol = (struct symbol *) ptr; vector = (struct vector *) PTR(symbol->name); +#ifndef UNICODE for (charptr = (char *) vector->data; *charptr != '\0'; charptr++) { if (*charptr == '"') putchar('\\'); putchar(*charptr); } +#else + { + char *charptr = (char *) vector->data; + int len = (int) (vector->length >> 2); + + while (len-- > 0) { + if ((charptr[0] == 0) + && (charptr[1] = '"')) { + putchar('\\'); + } + /* Just dump out the UTF-16 data */ + putchar(*charptr++); + putchar(*charptr++); + } + } +#endif break; case type_SimpleString:

1 0

[cmucl-cvs] CMUCL commit: src/contrib/asdf (asdf.lisp)
by Raymond Toy 06 Oct '10

06 Oct '10

Date: Wednesday, October 6, 2010 @ 19:26:55 Author: rtoy Path: /project/cmucl/cvsroot/src/contrib/asdf Modified: asdf.lisp Update to revision 2.009. -----------+ asdf.lisp | 231 ++++++++++++++++++++++++++++++++---------------------------- 1 file changed, 124 insertions(+), 107 deletions(-) Index: src/contrib/asdf/asdf.lisp diff -u src/contrib/asdf/asdf.lisp:1.8 src/contrib/asdf/asdf.lisp:1.9 --- src/contrib/asdf/asdf.lisp:1.8 Fri Sep 17 19:25:58 2010 +++ src/contrib/asdf/asdf.lisp Wed Oct 6 19:26:55 2010 @@ -47,7 +47,7 @@ #+xcvb (module ()) -(cl:in-package :cl) +(cl:in-package :cl-user) (eval-when (:compile-toplevel :load-toplevel :execute) ;;; make package if it doesn't exist yet. @@ -55,7 +55,7 @@ (unless (find-package :asdf) (make-package :asdf :use '(:cl))) ;;; Implementation-dependent tweaks - ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults. + ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults. #+allegro (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* @@ -72,7 +72,7 @@ (defvar *asdf-version* nil) (defvar *upgraded-p* nil) (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate - (subseq "VERSION:2.008" (1+ (length "VERSION")))) ; same as 2.128 + (subseq "VERSION:2.009" (1+ (length "VERSION")))) ; same as 2.134 (existing-asdf (fboundp 'find-system)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -82,36 +82,30 @@ "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" existing-version asdf-version)) (labels - ((rename-away (package) - (loop :with name = (package-name package) - :for i :from 1 :for new = (format nil "~A.~D" name i) - :unless (find-package new) :do - (rename-package-name package name new))) - (rename-package-name (package old new) - (let* ((old-names (cons (package-name package) - (package-nicknames package))) - (new-names (subst new old old-names :test 'equal)) - (new-name (car new-names)) - (new-nicknames (cdr new-names))) - (rename-package package new-name new-nicknames))) + ((unlink-package (package) + (let ((u (find-package package))) + (when u + (ensure-unintern u + (loop :for s :being :each :present-symbol :in u :collect s)) + (loop :for p :in (package-used-by-list u) :do + (unuse-package u p)) + (delete-package u)))) (ensure-exists (name nicknames use) - (let* ((previous - (remove-duplicates - (remove-if - #'null - (mapcar #'find-package (cons name nicknames))) - :from-end t))) - (cond - (previous - ;; do away with packages with conflicting (nick)names - (map () #'rename-away (cdr previous)) - ;; reuse previous package with same name - (let ((p (car previous))) + (let ((previous + (remove-duplicates + (mapcar #'find-package (cons name nicknames)) + :from-end t))) + ;; do away with packages with conflicting (nick)names + (map () #'unlink-package (cdr previous)) + ;; reuse previous package with same name + (let ((p (car previous))) + (cond + (p (rename-package p name nicknames) (ensure-use p use) - p)) - (t - (make-package name :nicknames nicknames :use use))))) + p) + (t + (make-package name :nicknames nicknames :use use)))))) (find-sym (symbol package) (find-symbol (string symbol) package)) (intern* (symbol package) @@ -176,9 +170,7 @@ :shadow ',shadow :unintern ',(append #-(or gcl ecl) redefined-functions unintern) :fmakunbound ',(append fmakunbound)))) - (let ((u (find-package :asdf-utilities))) - (when u - (ensure-unintern u (loop :for s :being :each :present-symbol :in u :collect s)))) + (unlink-package :asdf-utilities) (pkgdcl :asdf :use (:common-lisp) @@ -186,7 +178,7 @@ (#:perform #:explain #:output-files #:operation-done-p #:perform-with-restarts #:component-relative-pathname #:system-source-file #:operate #:find-component #:find-system - #:apply-output-translations #:translate-pathname*) + #:apply-output-translations #:translate-pathname* #:resolve-location) :unintern (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector) @@ -331,12 +323,19 @@ (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))) (when (find-class 'module nil) (eval - '(defmethod update-instance-for-redefined-class :after - ((m module) added deleted plist &key) - (declare (ignorable deleted plist)) - (format *trace-output* "Updating ~A~%" m) - (when (member 'components-by-name added) - (compute-module-components-by-name m)))))) + '(progn + (defmethod update-instance-for-redefined-class :after + ((m module) added deleted plist &key) + (declare (ignorable deleted plist)) + (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m)) + (when (member 'components-by-name added) + (compute-module-components-by-name m))) + (defmethod update-instance-for-redefined-class :after + ((s system) added deleted plist &key) + (declare (ignorable deleted plist)) + (when *asdf-verbose* (format *trace-output* "Updating ~A~%" s)) + (when (member 'source-file added) + (%set-system-source-file (probe-asd (component-name s) (component-pathname s)) s))))))) ;;;; ------------------------------------------------------------------------- ;;;; User-visible parameters @@ -970,15 +969,13 @@ ;;;; methods: components (defmethod print-object ((c missing-component) s) - (format s "~@<component ~S not found~ - ~@[ in ~A~]~@:>" + (format s "~@<component ~S not found~@[ in ~A~]~@:>" (missing-requires c) (when (missing-parent c) (component-name (missing-parent c))))) (defmethod print-object ((c missing-component-of-version) s) - (format s "~@<component ~S does not match version ~A~ - ~@[ in ~A~]~@:>" + (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>" (missing-requires c) (missing-version c) (when (missing-parent c) @@ -1202,8 +1199,7 @@ (let* ((*print-circle* nil) (message (format nil - "~@<While searching for system ~S: ~S evaluated ~ -to ~S which is not a directory.~@:>" + "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>" system dir defaults))) (error message)) (remove-entry-from-registry () @@ -1288,17 +1284,22 @@ (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) -(defun* sysdef-find-asdf (system) - (let ((name (coerce-name system))) - (when (equal name "asdf") - (let* ((registered (cdr (gethash name *defined-systems*))) - (asdf (or registered +(defun* find-system-fallback (requested fallback &optional source-file) + (setf fallback (coerce-name fallback) + source-file (or source-file *compile-file-truename* *load-truename*) + requested (coerce-name requested)) + (when (equal requested fallback) + (let* ((registered (cdr (gethash fallback *defined-systems*))) + (system (or registered (make-instance - 'system :name "asdf" - :source-file (or *compile-file-truename* *load-truename*))))) - (unless registered - (register-system "asdf" asdf)) - (throw 'find-system asdf))))) + 'system :name fallback + :source-file source-file)))) + (unless registered + (register-system fallback system)) + (throw 'find-system system)))) + +(defun* sysdef-find-asdf (name) + (find-system-fallback name "asdf")) ;;;; ------------------------------------------------------------------------- @@ -1784,8 +1785,7 @@ (defmethod perform ((operation operation) (c source-file)) (sysdef-error - "~@<required method PERFORM not implemented ~ - for operation ~A, component ~A~@:>" + "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>" (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) @@ -1898,11 +1898,11 @@ (defclass load-op (basic-load-op) ()) (defmethod perform ((o load-op) (c cl-source-file)) - #-ecl (mapcar #'load (input-files o c)) - #+ecl (loop :for i :in (input-files o c) - :unless (string= (pathname-type i) "fas") - :collect (let ((output (compile-file-pathname (lispize-pathname i)))) - (load output)))) + (map () #'load + #-ecl (input-files o c) + #+ecl (loop :for i :in (input-files o c) + :unless (string= (pathname-type i) "fas") + :collect (compile-file-pathname (lispize-pathname i))))) (defmethod perform-with-restarts (operation component) (perform operation component)) @@ -2065,8 +2065,7 @@ (accept () :report (lambda (s) - (format s "~@<Continue, treating ~A as ~ - having been successful.~@:>" + (format s "~@<Continue, treating ~A as having been successful.~@:>" (operation-description op component))) (setf (gethash (type-of op) (component-operation-times component)) @@ -2109,21 +2108,24 @@ "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'load-op system args)) + (apply #'operate 'load-op system args) + t) (defun* compile-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'compile-op system args)) + (apply #'operate 'compile-op system args) + t) (defun* test-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'test-op system args)) + (apply #'operate 'test-op system args) + t) ;;;; ------------------------------------------------------------------------- ;;;; Defsystem @@ -2542,8 +2544,7 @@ "No architecture feature found in ~a." *architecture-features*)) (version (maybe-warn (lisp-version-string) - "Don't know how to get Lisp ~ - implementation version."))) + "Don't know how to get Lisp implementation version."))) (substitute-if #\_ (lambda (x) (find x " /:\\(){}[]$#`'\"")) (format nil "~(~@{~a~^-~}~)" lisp version os arch))))) @@ -2692,19 +2693,24 @@ (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type "asd" :version :newest)) -(declaim (ftype (function (t &optional boolean) (values (or null pathname) &optional)) +(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)) + (values (or null pathname) &optional)) resolve-location)) -(defun* resolve-relative-location-component (super x &optional wildenp) +(defun* resolve-relative-location-component (super x &key directory wilden) (let* ((r (etypecase x (pathname x) (string x) (cons - (let ((car (resolve-relative-location-component super (car x) nil))) + (return-from resolve-relative-location-component (if (null (cdr x)) - car - (let ((cdr (resolve-relative-location-component - (merge-pathnames* car super) (cdr x) wildenp))) + (resolve-relative-location-component + super (car x) :directory directory :wilden wilden) + (let* ((car (resolve-relative-location-component + super (car x) :directory t :wilden nil)) + (cdr (resolve-relative-location-component + (merge-pathnames* car super) (cdr x) + :directory directory :wilden wilden))) (merge-pathnames* cdr car))))) ((eql :default-directory) (relativize-pathname-directory (default-directory))) @@ -2712,49 +2718,55 @@ ((eql :implementation-type) (string-downcase (implementation-type))) #-(and (or win32 windows mswindows mingw32) (not cygwin)) ((eql :uid) (princ-to-string (get-uid))))) - (d (if (pathnamep x) r (ensure-directory-pathname r))) - (s (if (and wildenp (not (pathnamep x))) - (wilden d) - d))) + (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r))) + (s (if (or (pathnamep x) (not wilden)) d (wilden d)))) (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) (error "pathname ~S is not relative to ~S" s super)) (merge-pathnames* s super))) -(defun* resolve-absolute-location-component (x wildenp) +(defun* resolve-absolute-location-component (x &key directory wilden) (let* ((r (etypecase x (pathname x) - (string (ensure-directory-pathname x)) + (string (if directory (ensure-directory-pathname x) (parse-namestring x))) (cons - (let ((car (resolve-absolute-location-component (car x) nil))) + (return-from resolve-absolute-location-component (if (null (cdr x)) - car - (let ((cdr (resolve-relative-location-component - car (cdr x) wildenp))) - (merge-pathnames* cdr car))))) + (resolve-absolute-location-component + (car x) :directory directory :wilden wilden) + (let* ((car (resolve-absolute-location-component + (car x) :directory t :wilden nil)) + (cdr (resolve-relative-location-component + car (cdr x) :directory directory :wilden wilden))) + (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ? ((eql :root) ;; special magic! we encode such paths as relative pathnames, ;; but it means "relative to the root of the source pathname's host and device". (return-from resolve-absolute-location-component - (make-pathname :directory '(:relative)))) + (let ((p (make-pathname :directory '(:relative)))) + (if wilden (wilden p) p)))) ((eql :home) (user-homedir)) - ((eql :user-cache) (resolve-location *user-cache* nil)) - ((eql :system-cache) (resolve-location *system-cache* nil)) + ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) + ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil)) ((eql :default-directory) (default-directory)))) - (s (if (and wildenp (not (pathnamep x))) + (s (if (and wilden (not (pathnamep x))) (wilden r) r))) (unless (absolute-pathname-p s) (error "Not an absolute pathname ~S" s)) s)) -(defun* resolve-location (x &optional wildenp) +(defun* resolve-location (x &key directory wilden) (if (atom x) - (resolve-absolute-location-component x wildenp) - (loop :with path = (resolve-absolute-location-component (car x) nil) + (resolve-absolute-location-component x :directory directory :wilden wilden) + (loop :with path = (resolve-absolute-location-component + (car x) :directory (and (or directory (cdr x)) t) + :wilden (and wilden (null (cdr x)))) :for (component . morep) :on (cdr x) + :for dir = (and (or morep directory) t) + :for wild = (and wilden (not morep)) :do (setf path (resolve-relative-location-component - path component (and wildenp (not morep)))) + path component :directory dir :wilden wild)) :finally (return path)))) (defun* location-designator-p (x) @@ -2775,7 +2787,7 @@ (unless (or (member directive '(:inherit-configuration :ignore-inherited-configuration - :enable-user-cache :disable-cache)) + :enable-user-cache :disable-cache nil)) (and (consp directive) (or (and (length=n-p directive 2) (or (and (eq (first directive) :include) @@ -2852,9 +2864,9 @@ `(:output-translations ;; Some implementations have precompiled ASDF systems, ;; so we must disable translations for implementation paths. - #+sbcl (,(getenv "SBCL_HOME") ()) + #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ()))) #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system - #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system + #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system ;; All-import, here is where we want user stuff to be: :inherit-configuration ;; These are for convenience, and can be overridden by the user: @@ -2920,7 +2932,7 @@ (process-output-translations-directive '(t t) :collect collect)) ((:inherit-configuration) (inherit-output-translations inherit :collect collect)) - ((:ignore-inherited-configuration) + ((:ignore-inherited-configuration nil) nil)) (let ((src (first directive)) (dst (second directive))) @@ -2929,7 +2941,7 @@ (process-output-translations (pathname dst) :inherit nil :collect collect)) (when src (let ((trusrc (or (eql src t) - (let ((loc (resolve-location src t))) + (let ((loc (resolve-location src :directory t :wilden t))) (if (absolute-pathname-p loc) (truenamize loc) loc))))) (cond ((location-function-p dst) @@ -2942,7 +2954,7 @@ (funcall collect (list trusrc t))) (t (let* ((trudst (make-pathname - :defaults (if dst (resolve-location dst t) trusrc))) + :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc))) (wilddst (make-pathname :name :wild :type :wild :version :wild :defaults trudst))) @@ -3088,8 +3100,10 @@ (merge-pathnames* (make-pathname :directory '(:relative ".fasls")) (user-homedir))) (include-per-user-information nil) - (map-all-source-files nil) + (map-all-source-files (or #+(or ecl clisp) t nil)) (source-to-target-mappings nil)) + (when (and (null map-all-source-files) #-(or ecl clisp) nil) + (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP")) (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors))) (mapped-files (make-pathname @@ -3116,6 +3130,8 @@ ;;;; Jesse Hager: The Windows Shortcut File Format. ;;;; http://www.wotsit.org/list.asp?fc=13 +#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) +(progn (defparameter *link-initial-dword* 76) (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) @@ -3182,7 +3198,7 @@ (read-sequence buffer s) (map 'string #'code-char buffer))))))) (end-of-file () - nil)))) + nil))))) ;;;; ----------------------------------------------------------------- ;;;; Source Registry Configuration, by Francois-Rene Rideau @@ -3225,7 +3241,7 @@ (case kw ((:include :directory :tree) (and (length=n-p rest 1) - (typep (car rest) '(or pathname string null)))) + (location-designator-p (first rest)))) ((:exclude :also-exclude) (every #'stringp rest)) (null rest)))) @@ -3389,15 +3405,16 @@ (ecase kw ((:include) (destructuring-bind (pathname) rest - (process-source-registry (pathname pathname) :inherit nil :register register))) + (process-source-registry (resolve-location pathname) :inherit nil :register register))) ((:directory) (destructuring-bind (pathname) rest (when pathname - (funcall register (ensure-directory-pathname pathname))))) + (funcall register (resolve-location pathname :directory t))))) ((:tree) (destructuring-bind (pathname) rest (when pathname - (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*)))) + (funcall register (resolve-location pathname :directory t) + :recurse t :exclude *source-registry-exclusions*)))) ((:exclude) (setf *source-registry-exclusions* rest)) ((:also-exclude)

1 0

[cmucl-cvs] CMUCL commit: src/tools (make-dist.sh)
by Raymond Toy 30 Sep '10

30 Sep '10

Date: Thursday, September 30, 2010 @ 17:21:41 Author: rtoy Path: /project/cmucl/cvsroot/src/tools Modified: make-dist.sh o Document the -S option better. o Describe how arch and os are derived if they're not specified on the command line. --------------+ make-dist.sh | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) Index: src/tools/make-dist.sh diff -u src/tools/make-dist.sh:1.16 src/tools/make-dist.sh:1.17 --- src/tools/make-dist.sh:1.16 Mon Feb 1 10:04:51 2010 +++ src/tools/make-dist.sh Thu Sep 30 17:21:41 2010 @@ -9,7 +9,7 @@ # you extracted the two tarballs and the source distribution into that # directory. # -# $Header: /project/cmucl/cvsroot/src/tools/make-dist.sh,v 1.16 2010-02-01 15:04:51 rtoy Rel $ +# $Header: /project/cmucl/cvsroot/src/tools/make-dist.sh,v 1.17 2010-09-30 21:21:41 rtoy Exp $ usage() { echo "make-dist.sh: [-hbg] [-G group] [-O owner] [-I destdir] [-M mandir] dir version [arch os]" @@ -22,6 +22,8 @@ echo " -M mandir Install manpages in this subdirectory. Default is man/man1" echo " -S Create a source distribution (requires GNU tar)" echo " The compressed tar file is named cmucl-src-<VERSION>.tar.<ext>" + echo " If -I is also given, the -S means that the sources are " + echo " installed in the <destdir>/src" echo " dir Directory where the build is located" echo " version Version (usually date and/or other version info)" echo " arch Architecture (x86, sparc, etc.)" @@ -38,6 +40,9 @@ echo "<arch>, and <os> are given values, and <c> is gz or bz2 depending" echo "on the selected compression method." echo "" + echo "If arch and os are not given, the script will attempt to figure an" + echo "appropriate value for arch and os from the running system." + echo "" echo "Creating a source distribution requires GNU tar. If 'tar' is not GNU" echo "tar, use the environment variable 'GTAR' to specify GNU tar. You can" echo "use 'GTAR=gtar make-dist.sh -S ...' in this case."

1 0

[cmucl-cvs] CMUCL commit: cmucl-www/cmucl-www/www/doc (arch.html)
by Raymond Toy 30 Sep '10

30 Sep '10

Date: Thursday, September 30, 2010 @ 10:25:29 Author: rtoy Path: /project/cmucl/cvsroot/cmucl-www/cmucl-www/www/doc Modified: arch.html Correct some links. -----------+ arch.html | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) Index: cmucl-www/cmucl-www/www/doc/arch.html diff -u cmucl-www/cmucl-www/www/doc/arch.html:1.1.1.1 cmucl-www/cmucl-www/www/doc/arch.html:1.2 --- cmucl-www/cmucl-www/www/doc/arch.html:1.1.1.1 Wed Apr 7 11:15:07 2004 +++ cmucl-www/cmucl-www/www/doc/arch.html Thu Sep 30 10:25:29 2010 @@ -57,7 +57,7 @@ but are in order. <ul> -<li> <a href = "http://www.sparc.com/standards.html">Sparc +<li> <a href = "http://www.sparc.com/specificationsDocuments.html">Sparc International</a> have Architecture Manuals and Application Binary Interface specifications available for download. </li> @@ -65,7 +65,7 @@ Whitepapers on the SPARC</a> from Sun microelectronics. </li> <li> Information on the <a href = - "http://docs.sun.com:80/ab2/@LegacyPageView?Ab2Lang=C&Ab2Enc=iso-8859-1&toc=…"> + "http://docs.sun.com/source/817-5073/ncg_sparc.html#pgfId-3241"> SPARC FPU units</a> and their implementation of IEEE exceptions. </li> <li> An introduction to SPARC <a href =

1 0

[cmucl-cvs] CMUCL commit: cmucl-www/cmucl-www/www/doc (index.html)
by Raymond Toy 30 Sep '10

30 Sep '10

Date: Thursday, September 30, 2010 @ 10:14:33 Author: rtoy Path: /project/cmucl/cvsroot/cmucl-www/cmucl-www/www/doc Modified: index.html o Update links to Kent Pitman's pages. o Update link to Evolution of Lisp, and add link to pdf file. ------------+ index.html | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) Index: cmucl-www/cmucl-www/www/doc/index.html diff -u cmucl-www/cmucl-www/www/doc/index.html:1.6 cmucl-www/cmucl-www/www/doc/index.html:1.7 --- cmucl-www/cmucl-www/www/doc/index.html:1.6 Mon Sep 27 17:10:56 2010 +++ cmucl-www/cmucl-www/www/doc/index.html Thu Sep 30 10:14:32 2010 @@ -166,8 +166,9 @@ especially for people more used to other object-oriented programming languages. </li> -<li> <a href = "http://citeseer.nj.nec.com/steele93evolution.html"> The - Evolution of Lisp</a> by Guy L. Steele and Richard Gabriel is a paper +<li> <a href = "http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.49.7238"> The + Evolution of Lisp</a> by Guy L. Steele and Richard Gabriel is a + <a href="http://www.dreamsongs.com/Files/HOPL2-Uncut.pdf">paper</a> which describes the history of the Lisp programming language. </li> <li> The paper <a href = "http://www.naggum.no/worse-is-better.html">Lisp: @@ -177,9 +178,9 @@ "http://www.dreamsongs.com/WorseIsBetter.html">other talks on the same subject</a>. </li> -<li> <a href = "http://world.std.com/~pitman/publications.html">Papers by +<li> <a href = "http://www.nhplace.com/kent/publications.html">Papers by Kent Pitman</a>, as well as his <a href = - "http://world.std.com/~pitman/PS/About-PS.html">Parenthetically + "http://www.nhplace.com/kent/PS/About-PS.html">Parenthetically Speaking</a> articles. </li> <li> <a href = "http://psg.com/~dlamkins/sl/cover.html">Successful

1 0

[cmucl-cvs] CMUCL commit: cmucl-www/cmucl-www/www/include (dtd.inc)
by Raymond Toy 30 Sep '10

30 Sep '10

Date: Wednesday, September 29, 2010 @ 20:38:50 Author: rtoy Path: /project/cmucl/cvsroot/cmucl-www/cmucl-www/www/include Modified: dtd.inc Update system identifier to the new recommended link. ---------+ dtd.inc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) Index: cmucl-www/cmucl-www/www/include/dtd.inc diff -u cmucl-www/cmucl-www/www/include/dtd.inc:1.1.1.1 cmucl-www/cmucl-www/www/include/dtd.inc:1.2 --- cmucl-www/cmucl-www/www/include/dtd.inc:1.1.1.1 Wed Apr 7 11:15:07 2004 +++ cmucl-www/cmucl-www/www/include/dtd.inc Wed Sep 29 20:38:50 2010 @@ -1,5 +1,5 @@ <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" -"http://www.w3.org/TR/REC-html40/loose.dtd"> +"http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd">

1 0

[cmucl-cvs] CMUCL commit: cmucl-www/cmucl-www/www (index.html)
by Raymond Toy 30 Sep '10

30 Sep '10

Date: Wednesday, September 29, 2010 @ 20:35:56 Author: rtoy Path: /project/cmucl/cvsroot/cmucl-www/cmucl-www/www Modified: index.html Fix some incorrect html. ------------+ index.html | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) Index: cmucl-www/cmucl-www/www/index.html diff -u cmucl-www/cmucl-www/www/index.html:1.15 cmucl-www/cmucl-www/www/index.html:1.16 --- cmucl-www/cmucl-www/www/index.html:1.15 Mon Sep 27 19:43:51 2010 +++ cmucl-www/cmucl-www/www/index.html Wed Sep 29 20:35:56 2010 @@ -68,7 +68,7 @@ Also see <a href="news/index.html">News</a> for older news. <dl> -<dt>CMUCL 20b released</dt> +<dt>CMUCL 20b released</dt> <dd> CMUCL 20b has been released, For information on the changes between 20b and 20a, we refer the reader to the <a href="news/release-20b.txt">20b release

1 0