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

[cmucl-cvs] CMUCL commit: cross-sol-x86-branch src/code (float-trap.lisp)
by Raymond Toy 20 Dec '10

20 Dec '10

Date: Monday, December 20, 2010 @ 17:08:45 Author: rtoy Path: /project/cmucl/cvsroot/src/code Tag: cross-sol-x86-branch Modified: float-trap.lisp It looks like the sigcontext on solaris/x86 doesn't store the entire x87 state, so just signal a general arithemtic error instead of an error about a SIGFPE but no exceptions. -----------------+ float-trap.lisp | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) Index: src/code/float-trap.lisp diff -u src/code/float-trap.lisp:1.38 src/code/float-trap.lisp:1.38.8.1 --- src/code/float-trap.lisp:1.38 Tue Apr 20 13:57:44 2010 +++ src/code/float-trap.lisp Mon Dec 20 17:08:45 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/float-trap.lisp,v 1.38 2010-04-20 17:57:44 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/float-trap.lisp,v 1.38.8.1 2010-12-20 22:08:45 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -290,6 +290,13 @@ :operation fop :operands operands)) (t + ;; It looks like the sigcontext on Solaris/x86 doesn't + ;; actually save the status word of the FPU. The + ;; operands also seem to be missing. Signal a general + ;; arithmetic error. + #+solaris + (error 'arithmetic-error :operands operands) + #-solaris (error (intl:gettext "SIGFPE with no exceptions currently enabled?"))))))) ;;; WITH-FLOAT-TRAPS-MASKED -- Public

1 0

[cmucl-cvs] CMUCL commit: cross-sol-x86-branch src/lisp (solaris-os.c)
by Raymond Toy 20 Dec '10

20 Dec '10

Date: Monday, December 20, 2010 @ 10:12:26 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Tag: cross-sol-x86-branch Modified: solaris-os.c Add implementation of os_sigcontext_fpu_reg. Tested to work with SSE2. X87 not yet tested. --------------+ solaris-os.c | 34 +++++++++++++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) Index: src/lisp/solaris-os.c diff -u src/lisp/solaris-os.c:1.26.4.4 src/lisp/solaris-os.c:1.26.4.5 --- src/lisp/solaris-os.c:1.26.4.4 Sun Dec 19 23:17:28 2010 +++ src/lisp/solaris-os.c Mon Dec 20 10:12:26 2010 @@ -1,5 +1,5 @@ /* - * $Header: /project/cmucl/cvsroot/src/lisp/solaris-os.c,v 1.26.4.4 2010-12-20 04:17:28 rtoy Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/solaris-os.c,v 1.26.4.5 2010-12-20 15:12:26 rtoy Exp $ * * OS-dependent routines. This file (along with os.h) exports an * OS-independent interface to the operating system VM facilities. @@ -541,6 +541,38 @@ return (unsigned long *) &scp->uc_mcontext.gregs[EIP]; } + +unsigned char * +os_sigcontext_fpu_reg(ucontext_t *scp, int offset) +{ + fpregset_t *fpregs = &scp->uc_mcontext.fpregs; + unsigned char *reg = NULL; + + if (offset < 8) { + unsigned char *fpustate; + unsigned char *stregs; + + /* + * Not sure this is right. There is no structure defined for + * the x87 fpu state in /usr/include/sys/regset.h + */ + + /* Point to the fpchip_state */ + fpustate = (unsigned char*) &fpregs->fp_reg_set.fpchip_state.state[0]; + /* Skip to where the x87 fp registers are */ + stregs = fpustate + 24; + + reg = stregs + 16*offset; + } +#ifdef FEATURE_SSE2 + else { + reg = &fpregs->fp_reg_set.fpchip_state.xmm[offset - 8]; + } +#endif + + return reg; +} + unsigned int os_sigcontext_fpu_modes(ucontext_t *scp) {

1 0

[cmucl-cvs] CMUCL commit: cross-sol-x86-branch src/lisp (gencgc.c)
by Raymond Toy 20 Dec '10

20 Dec '10

Date: Monday, December 20, 2010 @ 08:53:40 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Tag: cross-sol-x86-branch Modified: gencgc.c Oops. We should check that closure->function is not zero. ----------+ gencgc.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) Index: src/lisp/gencgc.c diff -u src/lisp/gencgc.c:1.110.6.3 src/lisp/gencgc.c:1.110.6.4 --- src/lisp/gencgc.c:1.110.6.3 Mon Dec 20 08:25:22 2010 +++ src/lisp/gencgc.c Mon Dec 20 08:53:40 2010 @@ -7,7 +7,7 @@ * * Douglas Crosher, 1996, 1997, 1998, 1999. * - * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.110.6.3 2010-12-20 13:25:22 rtoy Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.110.6.4 2010-12-20 13:53:40 rtoy Exp $ * */ @@ -3462,7 +3462,7 @@ * (Previously, we'd get a segfault scavenging the object at * address -RAW_ADDR_OFFSET. */ - if (fun) { + if (closure->function) { scavenge(&fun, 1); /* * The function may have moved so update the raw address. But don't

1 0

[cmucl-cvs] CMUCL commit: cross-sol-x86-branch src/pcl (cmucl-documentation.lisp)
by Raymond Toy 20 Dec '10

20 Dec '10

Date: Monday, December 20, 2010 @ 08:40:22 Author: rtoy Path: /project/cmucl/cvsroot/src/pcl Tag: cross-sol-x86-branch Modified: cmucl-documentation.lisp Merge fix from HEAD branch. --------------------------+ cmucl-documentation.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) Index: src/pcl/cmucl-documentation.lisp diff -u src/pcl/cmucl-documentation.lisp:1.17 src/pcl/cmucl-documentation.lisp:1.17.8.1 --- src/pcl/cmucl-documentation.lisp:1.17 Fri Mar 19 11:19:03 2010 +++ src/pcl/cmucl-documentation.lisp Mon Dec 20 08:40:22 2010 @@ -4,7 +4,7 @@ ;;; the public domain, and is provided 'as is'. (file-comment - "$Header: /project/cmucl/cvsroot/src/pcl/cmucl-documentation.lisp,v 1.17 2010-03-19 15:19:03 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/pcl/cmucl-documentation.lisp,v 1.17.8.1 2010-12-20 13:40:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -222,7 +222,7 @@ `(defmethod documentation :around ((x t) (doc-type (eql ',dt))) (let ((doc (call-next-method)) (domain (info ,dt :textdomain x))) - (or (intl:dgettext domain doc) + (or (and doc (intl:dgettext domain doc)) doc))))) (frob function) (frob setf)

1 0

[cmucl-cvs] CMUCL commit: cross-sol-x86-branch src/code (intl.lisp)
by Raymond Toy 20 Dec '10

20 Dec '10

Date: Monday, December 20, 2010 @ 08:40:10 Author: rtoy Path: /project/cmucl/cvsroot/src/code Tag: cross-sol-x86-branch Modified: intl.lisp Merge fix from HEAD branch. -----------+ intl.lisp | 74 ++++++++++++++++++++++++++++++------------------------------ 1 file changed, 37 insertions(+), 37 deletions(-) Index: src/code/intl.lisp diff -u src/code/intl.lisp:1.10 src/code/intl.lisp:1.10.2.1 --- src/code/intl.lisp:1.10 Sun Dec 12 19:19:38 2010 +++ src/code/intl.lisp Mon Dec 20 08:40:10 2010 @@ -1,6 +1,6 @@ ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*- -;;; $Revision: 1.10 $ +;;; $Revision: 1.10.2.1 $ ;;; Copyright 1999-2010 Paul Foley (mycroft(a)actrix.gen.nz) ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining @@ -23,7 +23,7 @@ ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;;; DAMAGE. -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/intl.lisp,v 1.10 2010-12-13 00:19:38 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/intl.lisp,v 1.10.2.1 2010-12-20 13:40:10 rtoy Exp $") (in-package "INTL") @@ -468,42 +468,42 @@ (defun domain-lookup-plural (singular plural domain) (declare (type string singular plural) (type domain-entry domain) #+(or)(optimize (speed 3) (space 2) (safety 0))) - (or (if (null (domain-entry-encoding domain)) nil) - (gethash (cons singular plural) (domain-entry-hash domain)) - (let* ((octets (let* ((a (string-to-octets singular - (domain-entry-encoding domain))) - (b (string-to-octets plural - (domain-entry-encoding domain))) - (c (make-array (+ (length a) (length b) 1) - :element-type '(unsigned-byte 8)))) - (declare (type (simple-array (unsigned-byte 8) (*)) - a b c)) - (replace c a) - (setf (aref c (length a)) 0) - (replace c b :start1 (+ (length a) 1)) - c)) - (length (length octets)) - (pos (gethash length (domain-entry-hash domain)))) - (declare (type (simple-array (unsigned-byte 8) (*)) octets) - (type list pos)) - (multiple-value-bind (tmp entry) (search-domain octets domain pos) - (declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp)) - (when tmp - (prog1 - (setf (gethash (cons (copy-seq singular) (copy-seq plural)) - (domain-entry-hash domain)) - (loop for i = 0 then (1+ j) + (when (domain-entry-encoding domain) + (or (gethash (cons singular plural) (domain-entry-hash domain)) + (let* ((octets (let* ((a (string-to-octets singular + (domain-entry-encoding domain))) + (b (string-to-octets plural + (domain-entry-encoding domain))) + (c (make-array (+ (length a) (length b) 1) + :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8) (*)) + a b c)) + (replace c a) + (setf (aref c (length a)) 0) + (replace c b :start1 (+ (length a) 1)) + c)) + (length (length octets)) + (pos (gethash length (domain-entry-hash domain)))) + (declare (type (simple-array (unsigned-byte 8) (*)) octets) + (type list pos)) + (multiple-value-bind (tmp entry) (search-domain octets domain pos) + (declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp)) + (when tmp + (prog1 + (setf (gethash (cons (copy-seq singular) (copy-seq plural)) + (domain-entry-hash domain)) + (loop for i = 0 then (1+ j) as j = (position 0 tmp :start i) - collect (octets-to-string (subseq tmp i j) - (domain-entry-encoding domain)) - while j)) - (let ((temp (delete entry pos :test #'eq))) - (if temp - (setf (gethash length (domain-entry-hash domain)) temp) - (remhash length (domain-entry-hash domain)))) - (when (null (domain-entry-plurals domain)) - (setf (domain-entry-plurals domain) - (parse-plurals domain))))))))) + collect (octets-to-string (subseq tmp i j) + (domain-entry-encoding domain)) + while j)) + (let ((temp (delete entry pos :test #'eq))) + (if temp + (setf (gethash length (domain-entry-hash domain)) temp) + (remhash length (domain-entry-hash domain)))) + (when (null (domain-entry-plurals domain)) + (setf (domain-entry-plurals domain) + (parse-plurals domain)))))))))) (declaim (inline getenv) (ftype (function (string) (or null string)) getenv))

1 0

[cmucl-cvs] CMUCL commit: cross-sol-x86-branch src/lisp (gencgc.c)
by Raymond Toy 20 Dec '10

20 Dec '10

Date: Monday, December 20, 2010 @ 08:25:23 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Tag: cross-sol-x86-branch Modified: gencgc.c Fix typo (missing paren). ----------+ gencgc.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) Index: src/lisp/gencgc.c diff -u src/lisp/gencgc.c:1.110.6.2 src/lisp/gencgc.c:1.110.6.3 --- src/lisp/gencgc.c:1.110.6.2 Sun Dec 19 23:12:57 2010 +++ src/lisp/gencgc.c Mon Dec 20 08:25:22 2010 @@ -7,7 +7,7 @@ * * Douglas Crosher, 1996, 1997, 1998, 1999. * - * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.110.6.2 2010-12-20 04:12:57 rtoy Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.110.6.3 2010-12-20 13:25:22 rtoy Exp $ * */ @@ -3444,7 +3444,7 @@ closure = (struct closure *) where; fun = closure->function - RAW_ADDR_OFFSET; -#if !(defined(x86) && defined(SOLARIS) +#if !(defined(i386) && defined(SOLARIS)) scavenge(&fun, 1); /* The function may have moved so update the raw address. But don't write unnecessarily. */

1 0

[cmucl-cvs] CMUCL commit: cross-sol-x86-branch src/lisp (solaris-os.c)
by Raymond Toy 20 Dec '10

20 Dec '10

Date: Sunday, December 19, 2010 @ 23:17:28 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Tag: cross-sol-x86-branch Modified: solaris-os.c o #include internals.h before including gencgc.h to get rid of a #warning about struct code being used. o Ifdef out fprintf's. o Add implementation of os_sigcontext_fpu_modes. This needs testing! --------------+ solaris-os.c | 43 +++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 41 insertions(+), 2 deletions(-) Index: src/lisp/solaris-os.c diff -u src/lisp/solaris-os.c:1.26.4.3 src/lisp/solaris-os.c:1.26.4.4 --- src/lisp/solaris-os.c:1.26.4.3 Sat Dec 18 11:19:39 2010 +++ src/lisp/solaris-os.c Sun Dec 19 23:17:28 2010 @@ -1,5 +1,5 @@ /* - * $Header: /project/cmucl/cvsroot/src/lisp/solaris-os.c,v 1.26.4.3 2010-12-18 16:19:39 rtoy Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/solaris-os.c,v 1.26.4.4 2010-12-20 04:17:28 rtoy Exp $ * * OS-dependent routines. This file (along with os.h) exports an * OS-independent interface to the operating system VM facilities. @@ -32,6 +32,8 @@ #if defined(GENCGC) #include "lisp.h" +/* Need struct code defined to get rid of warning from gencgc.h */ +#include "internals.h" #include "gencgc.h" #endif @@ -506,8 +508,9 @@ unsigned long * os_sigcontext_reg(ucontext_t *scp, int index) { +#if 0 fprintf(stderr, "os_sigcontext_reg index = %d\n", index); - +#endif switch (index) { case 0: return (unsigned long *) &scp->uc_mcontext.gregs[EAX]; @@ -532,8 +535,44 @@ unsigned long * os_sigcontext_pc(ucontext_t *scp) { +#if 0 fprintf(stderr, "os_sigcontext_pc = %p\n", scp->uc_mcontext.gregs[EIP]); +#endif return (unsigned long *) &scp->uc_mcontext.gregs[EIP]; } +unsigned int +os_sigcontext_fpu_modes(ucontext_t *scp) +{ + unsigned int modes; + unsigned short cw, sw; + fpregset_t *fpr; + unsigned int state; + + fpr = &scp->uc_mcontext.fpregs; + + state = fpr->fp_reg_set.fpchip_state.state[0]; + + cw = state & 0xffff; + sw = (state >> 16) & 0xffff; + + modes = ((cw & 0x3f) << 7) | (sw & 0x3f); + +#ifdef FEATURE_SSE2 + /* + * Add in the SSE2 part, if we're running the sse2 core. + */ + if (fpu_mode == SSE2) { + unsigned long mxcsr; + + mxcsr = fpr->fp_reg_set.fpchip_state.mxcsr; + DPRINTF(0, (stderr, "SSE2 modes = %08lx\n", mxcsr)); + + modes |= mxcsr; + } +#endif + + modes ^= (0x3f << 7); + return modes; +} #endif

1 0

[cmucl-cvs] CMUCL commit: cross-sol-x86-branch src/lisp (gencgc.c)
by Raymond Toy 20 Dec '10

20 Dec '10

Date: Sunday, December 19, 2010 @ 23:12:58 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Tag: cross-sol-x86-branch Modified: gencgc.c o Turn GC_ASSERTIONS for now. o Turn off other verbose checking and debugging. o In scav_closure_header, check if the closure function is zero and skip scavenging it if so. Only do this for solaris/x86; it doesn't seem to be a problem on other OSes. But leave some of the debugging stuff around but disabled for now, just in case. ----------+ gencgc.c | 55 ++++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 44 insertions(+), 11 deletions(-) Index: src/lisp/gencgc.c diff -u src/lisp/gencgc.c:1.110.6.1 src/lisp/gencgc.c:1.110.6.2 --- src/lisp/gencgc.c:1.110.6.1 Wed Dec 15 07:53:45 2010 +++ src/lisp/gencgc.c Sun Dec 19 23:12:57 2010 @@ -7,7 +7,7 @@ * * Douglas Crosher, 1996, 1997, 1998, 1999. * - * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.110.6.1 2010-12-15 12:53:45 rtoy Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.110.6.2 2010-12-20 04:12:57 rtoy Exp $ * */ @@ -150,8 +150,7 @@ /* Define for activating assertions. */ -#define GC_ASSERTIONS 1 -#if defined(DARWIN) +#if defined(x86) && defined(SOLARIS) #define GC_ASSERTIONS 1 #endif @@ -241,7 +240,7 @@ * The verbose level. All non-error messages are disabled at level 0; * and only a few rare messages are printed at level 1. */ -unsigned gencgc_verbose = 1; +unsigned gencgc_verbose = 0; unsigned counters_verbose = 0; /* @@ -267,7 +266,7 @@ * makes GC very, very slow, so don't enable this unless you really * need it!) */ -boolean pre_verify_gen_0 = TRUE; +boolean pre_verify_gen_0 = FALSE; /* * Enable checking for bad pointers after gc_free_heap called from purify. @@ -275,7 +274,7 @@ #if 0 && defined(DARWIN) boolean verify_after_free_heap = TRUE; #else -boolean verify_after_free_heap = TRUE; +boolean verify_after_free_heap = FALSE; #endif /* @@ -288,7 +287,7 @@ * Enable the checking of code objects for fixup errors after they are * transported. (Only used for x86.) */ -boolean check_code_fixups = TRUE; +boolean check_code_fixups = FALSE; /* * To enable unmapping of a page and re-mmaping it to have it zero filled. @@ -308,8 +307,8 @@ boolean gencgc_zero_check = TRUE; boolean gencgc_enable_verify_zero_fill = TRUE; #else -boolean gencgc_zero_check = TRUE; -boolean gencgc_enable_verify_zero_fill = TRUE; +boolean gencgc_zero_check = FALSE; +boolean gencgc_enable_verify_zero_fill = FALSE; #endif /* @@ -319,7 +318,7 @@ #if 0 && defined(DARWIN) boolean gencgc_zero_check_during_free_heap = TRUE; #else -boolean gencgc_zero_check_during_free_heap = TRUE; +boolean gencgc_zero_check_during_free_heap = FALSE; #endif /* @@ -3445,12 +3444,46 @@ closure = (struct closure *) where; fun = closure->function - RAW_ADDR_OFFSET; +#if !(defined(x86) && defined(SOLARIS) scavenge(&fun, 1); /* The function may have moved so update the raw address. But don't write unnecessarily. */ if (closure->function != fun + RAW_ADDR_OFFSET) closure->function = fun + RAW_ADDR_OFFSET; - +#else + /* + * For some reason, on solaris/x86, we get closures (actually, it + * appears to be funcallable instances where the closure function + * is zero. I don't know why, but they are. They don't seem to + * be created anywhere and it doesn't seem to be caused by GC + * transport. + * + * Anyway, we check for zero and skip scavenging if so. + * (Previously, we'd get a segfault scavenging the object at + * address -RAW_ADDR_OFFSET. + */ + if (fun) { + scavenge(&fun, 1); + /* + * The function may have moved so update the raw address. But don't + * write unnecessarily. + */ + if (closure->function != fun + RAW_ADDR_OFFSET) { +#if 0 + fprintf(stderr, "closure header 0x%04x moved from %p to %p\n", + closure->header, (void*) closure->function, (void*) (fun + RAW_ADDR_OFFSET)); +#endif + closure->function = fun + RAW_ADDR_OFFSET; + } + } +#if 0 + else { + fprintf(stderr, "Weird closure!\n"); + fprintf(stderr, " where = %p, object = 0x%04x\n", where, object); + fprintf(stderr, " closure->function = %p, fun = %p\n", closure->function, fun); + } +#endif +#endif return 2; }

1 0

[cmucl-cvs] CMUCL commit: src/code (intl.lisp)
by Raymond Toy 19 Dec '10

19 Dec '10

Date: Saturday, December 18, 2010 @ 22:01:48 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: intl.lisp Oops. If the domain-entry-encoding is NIL, we just want to return NIL. (From Paul Foley.) -----------+ intl.lisp | 74 ++++++++++++++++++++++++++++++------------------------------ 1 file changed, 37 insertions(+), 37 deletions(-) Index: src/code/intl.lisp diff -u src/code/intl.lisp:1.10 src/code/intl.lisp:1.11 --- src/code/intl.lisp:1.10 Sun Dec 12 19:19:38 2010 +++ src/code/intl.lisp Sat Dec 18 22:01:47 2010 @@ -1,6 +1,6 @@ ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*- -;;; $Revision: 1.10 $ +;;; $Revision: 1.11 $ ;;; Copyright 1999-2010 Paul Foley (mycroft(a)actrix.gen.nz) ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining @@ -23,7 +23,7 @@ ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;;; DAMAGE. -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/intl.lisp,v 1.10 2010-12-13 00:19:38 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/intl.lisp,v 1.11 2010-12-19 03:01:47 rtoy Exp $") (in-package "INTL") @@ -468,42 +468,42 @@ (defun domain-lookup-plural (singular plural domain) (declare (type string singular plural) (type domain-entry domain) #+(or)(optimize (speed 3) (space 2) (safety 0))) - (or (if (null (domain-entry-encoding domain)) nil) - (gethash (cons singular plural) (domain-entry-hash domain)) - (let* ((octets (let* ((a (string-to-octets singular - (domain-entry-encoding domain))) - (b (string-to-octets plural - (domain-entry-encoding domain))) - (c (make-array (+ (length a) (length b) 1) - :element-type '(unsigned-byte 8)))) - (declare (type (simple-array (unsigned-byte 8) (*)) - a b c)) - (replace c a) - (setf (aref c (length a)) 0) - (replace c b :start1 (+ (length a) 1)) - c)) - (length (length octets)) - (pos (gethash length (domain-entry-hash domain)))) - (declare (type (simple-array (unsigned-byte 8) (*)) octets) - (type list pos)) - (multiple-value-bind (tmp entry) (search-domain octets domain pos) - (declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp)) - (when tmp - (prog1 - (setf (gethash (cons (copy-seq singular) (copy-seq plural)) - (domain-entry-hash domain)) - (loop for i = 0 then (1+ j) + (when (domain-entry-encoding domain) + (or (gethash (cons singular plural) (domain-entry-hash domain)) + (let* ((octets (let* ((a (string-to-octets singular + (domain-entry-encoding domain))) + (b (string-to-octets plural + (domain-entry-encoding domain))) + (c (make-array (+ (length a) (length b) 1) + :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8) (*)) + a b c)) + (replace c a) + (setf (aref c (length a)) 0) + (replace c b :start1 (+ (length a) 1)) + c)) + (length (length octets)) + (pos (gethash length (domain-entry-hash domain)))) + (declare (type (simple-array (unsigned-byte 8) (*)) octets) + (type list pos)) + (multiple-value-bind (tmp entry) (search-domain octets domain pos) + (declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp)) + (when tmp + (prog1 + (setf (gethash (cons (copy-seq singular) (copy-seq plural)) + (domain-entry-hash domain)) + (loop for i = 0 then (1+ j) as j = (position 0 tmp :start i) - collect (octets-to-string (subseq tmp i j) - (domain-entry-encoding domain)) - while j)) - (let ((temp (delete entry pos :test #'eq))) - (if temp - (setf (gethash length (domain-entry-hash domain)) temp) - (remhash length (domain-entry-hash domain)))) - (when (null (domain-entry-plurals domain)) - (setf (domain-entry-plurals domain) - (parse-plurals domain))))))))) + collect (octets-to-string (subseq tmp i j) + (domain-entry-encoding domain)) + while j)) + (let ((temp (delete entry pos :test #'eq))) + (if temp + (setf (gethash length (domain-entry-hash domain)) temp) + (remhash length (domain-entry-hash domain)))) + (when (null (domain-entry-plurals domain)) + (setf (domain-entry-plurals domain) + (parse-plurals domain)))))))))) (declaim (inline getenv) (ftype (function (string) (or null string)) getenv))

1 0

[cmucl-cvs] CMUCL commit: cross-sol-x86-branch src/tools (make-dist.sh)
by Raymond Toy 18 Dec '10

18 Dec '10

Date: Saturday, December 18, 2010 @ 11:20:05 Author: rtoy Path: /project/cmucl/cvsroot/src/tools Tag: cross-sol-x86-branch Modified: make-dist.sh Support solaris/x86. --------------+ make-dist.sh | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) Index: src/tools/make-dist.sh diff -u src/tools/make-dist.sh:1.17 src/tools/make-dist.sh:1.17.4.1 --- src/tools/make-dist.sh:1.17 Thu Sep 30 17:21:41 2010 +++ src/tools/make-dist.sh Sat Dec 18 11:20:05 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.17 2010-09-30 21:21:41 rtoy Exp $ +# $Header: /project/cmucl/cvsroot/src/tools/make-dist.sh,v 1.17.4.1 2010-12-18 16:20:05 rtoy Exp $ usage() { echo "make-dist.sh: [-hbg] [-G group] [-O owner] [-I destdir] [-M mandir] dir version [arch os]" @@ -52,11 +52,16 @@ def_arch_os () { case `uname -s` in SunOS) - ARCH=sparcv9 + case `uname -m` in + sun*) + ARCH=sparcv9 ;; + i*) + ARCH=x86 ;; + esac uname_r=`uname -r` case $uname_r in - 5.*) rel=`echo $uname_r | sed 's/5\.//'`;; - *) rel=$uname_r;; + 5.*) rel=`echo $uname_r | sed 's/5\.//'`;; + *) rel=$uname_r;; esac OS=solaris$rel ;;

1 0