From: Douglas <dt...@us...> - 2011-11-10 12:47:19
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "Maxima, A Computer Algebra System". The branch, master has been updated via c7a77a1381b0fc4fedcd5d5f7d2be5adf9ec729d (commit) from 2c908019e696320c206bacaacc689da19fdf92a5 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit c7a77a1381b0fc4fedcd5d5f7d2be5adf9ec729d Author: Douglas Crosher <dt...@us...> Date: Thu Nov 10 23:42:18 2011 +1100 Improved support for CL implementations which have a mode or version in which the standard CL symbols are lower case rather than upper case. Update the 'intl package to support the Scieneer CL. diff --git a/src/clmacs.lisp b/src/clmacs.lisp index 858a8f1..bbbf6cf 100644 --- a/src/clmacs.lisp +++ b/src/clmacs.lisp @@ -70,6 +70,60 @@ `(member ,(intern (string item) (find-package 'keyword)) *features*)) ((equal option 'gctime) 0))) +#+(or scl allegro) +(defun string<$ (str1 str2) + "Compare string, but flip the case for maxima variable names to maintain + the same order irrespective of the lisp case mode." + (declare (string str1 str2)) + (cond (#+scl (eq ext:*case-mode* :lower) + #+allegro (eq excl:*current-case-mode* :case-sensitive-lower) + (let ((str1l (length str1)) + (str2l (length str2))) + (cond ((and (> str1l 1) (char= (aref str1 0) #\$) + (> str2l 1) (char= (aref str2 0) #\$)) + (flet ((case-flip (str) + (let ((some-upper nil) + (some-lower nil)) + (dotimes (i (length str)) + (let ((ch (schar str i))) + (when (lower-case-p ch) + (setf some-lower t)) + (when (upper-case-p ch) + (setf some-upper t)))) + (cond ((and some-upper some-lower) + nil) + (some-upper + :downcase) + (some-lower + :upcase))))) + (let ((flip1 (case-flip str1)) + (flip2 (case-flip str2))) + (do ((index 1 (1+ index))) + ((or (>= index str1l) (>= index str2l)) + (if (= index str1l) index nil)) + (let ((ch1 (aref str1 index)) + (ch2 (aref str2 index))) + (cond ((and (eq flip1 :downcase) (both-case-p ch1)) + (setf ch1 (char-downcase ch1))) + ((and (eq flip1 :upcase) (both-case-p ch1)) + (setf ch1 (char-upcase ch1)))) + (cond ((and (eq flip2 :downcase) (both-case-p ch2)) + (setf ch2 (char-downcase ch2))) + ((and (eq flip2 :upcase) (both-case-p ch2)) + (setf ch2 (char-upcase ch2)))) + (unless (char= ch1 ch2) + (return (if (char< ch1 ch2) + index + nil)))))))) + (t + (string< str1 str2))))) + (t + (string< str1 str2)))) +;;; +#-(or scl allegro) +(defun string<$ (str1 str2) + (string< str1 str2)) + ;;numbers<strings<symbols<lists<? (defun alphalessp (x y) (cond ((numberp x) @@ -85,7 +139,7 @@ (let ((nx (symbol-name x)) (ny (symbol-name y))) (declare (string nx ny)) - (cond ((string< nx ny) + (cond ((string<$ nx ny) t) ((string= nx ny) (cond ((eq nx ny) nil) diff --git a/src/intl.lisp b/src/intl.lisp index 28ea38e..24a9e6f 100644 --- a/src/intl.lisp +++ b/src/intl.lisp @@ -106,7 +106,7 @@ while (or (alphanumericp c) (eql c #\-)) finally (setf (domain-entry-encoding domain) (intern (nstring-upcase (subseq header charset i)) - "KEYWORD")))))) + :keyword)))))) domain) (defun parse-plurals (domain) @@ -132,38 +132,38 @@ do (incf pos)) (case (char string (1- (incf pos))) (#\n 'n) - (#\? 'IF) - (#\: 'THEN) - (#\( 'LPAR) - (#\) 'RPAR) - (#\^ 'LOGXOR) - (#\+ 'ADD) - (#\- 'SUB) - (#\* 'MUL) - (#\/ 'FLOOR) - (#\% 'MOD) - (#\~ 'LOGNOT32) - (#\; 'END) + (#\? 'if) + (#\: 'then) + (#\( 'lpar) + (#\) 'rpar) + (#\^ 'logxor) + (#\+ 'add) + (#\- 'sub) + (#\* 'mul) + (#\/ 'floor) + (#\% 'mod) + (#\~ 'lognot32) + (#\; 'end) (#\| (if (char= (char string pos) #\|) - (progn (incf pos) 'COR) - 'LOGIOR)) + (progn (incf pos) 'cor) + 'logior)) (#\& (if (char= (char string pos) #\&) - (progn (incf pos) 'CAND) - 'LOGAND)) + (progn (incf pos) 'cand) + 'logand)) (#\= (if (char= (char string pos) #\=) - (progn (incf pos) 'CMP=) + (progn (incf pos) 'cmp=) (error _"Encountered illegal token: ="))) (#\! (if (char= (char string pos) #\=) - (progn (incf pos) 'CMP/=) - 'NOT)) + (progn (incf pos) 'cmp/=) + 'not)) (#\< (case (char string pos) - (#\= (incf pos) 'CMP<=) - (#\< (incf pos) 'SHL) - (otherwise 'CMP<))) + (#\= (incf pos) 'cmp<=) + (#\< (incf pos) 'shl) + (otherwise 'cmp<))) (#\> (case (char string pos) - (#\= (incf pos) 'CMP>=) - (#\> (incf pos) 'SHR) - (otherwise 'CMP>))) + (#\= (incf pos) 'cmp>=) + (#\> (incf pos) 'shr) + (otherwise 'cmp>))) (otherwise (let ((n (digit-char-p (char string (1- pos))))) (if n (loop for nx = (digit-char-p (char string pos)) @@ -174,9 +174,9 @@ (char string (1- pos)))))))) (conditional (tok &aux tree) (multiple-value-setq (tree tok) (logical-or tok)) - (when (eql tok 'IF) + (when (eql tok 'if) (multiple-value-bind (right next) (logical-or (next)) - (unless (eql next 'THEN) + (unless (eql next 'then) (error _"Expected : in ?: construct")) (multiple-value-bind (else next) (conditional (next)) (setq tree (list tok (list 'zerop tree) else right) @@ -184,99 +184,99 @@ (values tree tok)) (logical-or (tok &aux tree) (multiple-value-setq (tree tok) (logical-and tok)) - (loop while (eql tok 'COR) do + (loop while (eql tok 'cor) do (multiple-value-bind (right next) (logical-and (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (logical-and (tok &aux tree) (multiple-value-setq (tree tok) (inclusive-or tok)) - (loop while (eql tok 'CAND) do + (loop while (eql tok 'cand) do (multiple-value-bind (right next) (inclusive-or (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (inclusive-or (tok &aux tree) (multiple-value-setq (tree tok) (exclusive-or tok)) - (loop while (eql tok 'LOGIOR) do + (loop while (eql tok 'logior) do (multiple-value-bind (right next) (exclusive-or (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (exclusive-or (tok &aux tree) (multiple-value-setq (tree tok) (bitwise-and tok)) - (loop while (eql tok 'LOGXOR) do + (loop while (eql tok 'logxor) do (multiple-value-bind (right next) (bitwise-and (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (bitwise-and (tok &aux tree) (multiple-value-setq (tree tok) (equality tok)) - (loop while (eql tok 'LOGAND) do + (loop while (eql tok 'logand) do (multiple-value-bind (right next) (equality (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (equality (tok &aux tree) (multiple-value-setq (tree tok) (relational tok)) - (loop while (member tok '(CMP= CMP/=)) do + (loop while (member tok '(cmp= cmp/=)) do (multiple-value-bind (right next) (relational (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (relational (tok &aux tree) (multiple-value-setq (tree tok) (shift tok)) - (loop while (member tok '(CMP< CMP> CMP<= CMP>=)) do + (loop while (member tok '(cmp< cmp> cmp<= cmp>=)) do (multiple-value-bind (right next) (shift (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (shift (tok &aux tree) (multiple-value-setq (tree tok) (additive tok)) - (loop while (member tok '(SHL SHR)) do + (loop while (member tok '(shl shr)) do (multiple-value-bind (right next) (additive (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (additive (tok &aux tree) (multiple-value-setq (tree tok) (multiplicative tok)) - (loop while (member tok '(ADD SUB)) do + (loop while (member tok '(add sub)) do (multiple-value-bind (right next) (multiplicative (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (multiplicative (tok &aux tree) (multiple-value-setq (tree tok) (unary tok)) - (loop while (member tok '(MUL FLOOR MOD)) do + (loop while (member tok '(mul floor mod)) do (multiple-value-bind (right next) (unary (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (unary (tok &aux tree) - (cond ((eq tok 'LPAR) + (cond ((eq tok 'lpar) (multiple-value-setq (tree tok) (conditional (next))) - (unless (eq tok 'RPAR) + (unless (eq tok 'rpar) (error _"Expected close-paren.")) (values tree (next))) ((numberp tok) (values tok (next))) ((eql tok 'n) (values tok (next))) - ((eql tok 'ADD) + ((eql tok 'add) (unary (next))) - ((eql tok 'SUB) + ((eql tok 'sub) (multiple-value-setq (tree tok) (unary (next))) (values (list '- tree) tok)) - ((eql tok 'LOGNOT32) + ((eql tok 'lognot32) (multiple-value-setq (tree tok) (unary (next))) - (values (list 'LOGNOT32 tree) tok)) - ((eql tok 'NOT) + (values (list 'lognot32 tree) tok)) + ((eql tok 'not) (multiple-value-setq (tree tok) (unary (next))) - (values (list 'CNOT tree) tok)) + (values (list 'cnot tree) tok)) (t (error _"Unexpected token: ~S." tok))))) (multiple-value-bind (tree end) (conditional (next)) - (unless (eq end 'END) + (unless (eq end 'end) (error _"Expecting end of expression. ~S." end)) (let (#-gcl (*compile-print* nil)) @@ -348,6 +348,8 @@ (declare (ignorable encoding)) #+(and CMU Unicode) (ext:string-to-octets string :external-format encoding) + #+scl + (ext:make-bytes-from-string string encoding) #+Allegro (excl:string-to-octets string :external-format encoding :null-terminate nil) #+SBCL @@ -356,7 +358,7 @@ #+CLISP (ext:convert-string-to-bytes string (ext:make-encoding :charset (symbol-name encoding))) ;;@@ add other implementations - #-(or (and CMU Unicode) Allegro SBCL CLISP #|others|#) + #-(or (and CMU Unicode) Allegro SBCL CLISP scl #|others|#) (map-into (make-array (length string) :element-type '(unsigned-byte 8)) #'char-code string)) @@ -365,6 +367,8 @@ (declare (ignorable encoding)) #+(and CMU Unicode) (ext:octets-to-string octets :external-format encoding) + #+scl + (ext:make-string-from-bytes octets encoding) #+Allegro (excl:octets-to-string octets :external-format encoding :end (length octets)) #+SBCL @@ -372,7 +376,7 @@ #+CLISP ;;@@ Not sure if encoding keyword is OK here (ext:convert-string-from-bytes octets (ext:make-encoding :charset (symbol-name encoding))) ;;@@ add other implementations - #-(or (and CMU Unicode) Allegro SBCL CLISP #|others|#) + #-(or (and CMU Unicode) Allegro SBCL CLISP scl #|others|#) (map-into (make-string (length octets)) #'code-char octets)) (defun octets= (a b &key (start1 0) (end1 (length a)) @@ -485,8 +489,8 @@ (declaim (inline getenv) (ftype (function (string) (or null string)) getenv)) (defun getenv (var) - (let ((val #+(or CMU SCL) (cdr (assoc (intern var "KEYWORD") - ext:*environment-list*)) + (let ((val #+CMU (cdr (assoc (intern var "KEYWORD") ext:*environment-list*)) + #+scl (cdr (assoc var ext:*environment-list* :test 'string=)) #+SBCL (sb-ext:posix-getenv var) #+Allegro (system:getenv var) #+LispWorks (hcl:getenv var) diff --git a/src/intpol.lisp b/src/intpol.lisp index 58f0cb8..aaab5ea 100644 --- a/src/intpol.lisp +++ b/src/intpol.lisp @@ -33,7 +33,7 @@ Perhaps you meant to enter `~a'.~%" (print-invert-case (implode (mstring `(($find_root) ,@(cdr form)))))) '$done) -(in-package "BIGFLOAT") +(in-package :bigfloat) ;; Define FIND-ROOT-SUBR and INTERPOLATE-CHECK in the BIGFLOAT package ;; so we don't have to write BIGFLOAT::foo for all of the arithmetic @@ -123,7 +123,7 @@ Perhaps you meant to enter `~a'.~%" (> (abs (- b c)) (* (to relerr) fc)) (> (abs (- c a)) (* (to relerr) fc))))) -(in-package "MAXIMA") +(in-package :maxima) (defun %find-root (name fun-or-expr args) ;; Extract the keyword arguments from args, if any. (let (non-keyword keywords) ----------------------------------------------------------------------- Summary of changes: src/clmacs.lisp | 56 ++++++++++++++++++++++++++++- src/intl.lisp | 106 ++++++++++++++++++++++++++++-------------------------- src/intpol.lisp | 4 +- 3 files changed, 112 insertions(+), 54 deletions(-) hooks/post-receive -- Maxima, A Computer Algebra System |