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

[Git][cmucl/cmucl][master] Fix #6, removing unused errorp argument for case-body
by Raymond Toy 24 Jun '15

24 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 78c91b67 by Raymond Toy at 2015-06-24T16:45:27Z Fix #6, removing unused errorp argument for case-body This requires using boot-2015-06-1 to make the change. Regenerated cmucl.pot too. - - - - - 3 changed files: - + src/bootfiles/20f/boot-2015-06-1.lisp - src/code/macros.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/bootfiles/20f/boot-2015-06-1.lisp ===================================== --- /dev/null +++ b/src/bootfiles/20f/boot-2015-06-1.lisp @@ -0,0 +1,156 @@ +;; Fix #6. +;; +;; Use this to bootstrap the change using the snapshot-2015-06 binary. +(in-package "KERNEL") +(export '(invalid-case)) +(in-package "CONDITIONS") + +(ext:without-package-locks +(define-condition invalid-case (reference-condition error) + ((name :initarg :name + :reader invalid-case-name) + (format :initarg :format-control + :reader invalid-case-format) + (args :initarg :format-arguments + :reader invalid-case-format-args)) + (:report (lambda (condition stream) + (format stream "~A: " (invalid-case-name condition)) + (apply #'format stream (invalid-case-format condition) (invalid-case-format-args condition)) + (print-references (reference-condition-references condition) stream)))) +) + +(in-package "LISP") + +(ext:without-package-locks +(defun case-body (name keyform cases multi-p test proceedp &optional allow-otherwise) + (let ((keyform-value (gensym)) + (clauses ()) + (keys ())) + (do* ((case-list cases (cdr case-list)) + (case (first case-list) (first case-list))) + ((null case-list)) + (cond ((atom case) + (error (intl:gettext "~S -- Bad clause in ~S.") case name)) + ((and (not allow-otherwise) + (memq (car case) '(t otherwise))) + (cond ((null (cdr case-list)) + ;; The CLHS says OTHERWISE clause is an OTHERWISE clause + ;; only if it's the last case. Otherwise, it's just a + ;; normal clause. + (push `(t nil ,@(rest case)) clauses)) + ((and (eq name 'case)) + (let ((key (first case))) + (error 'kernel:invalid-case + :name name + :format-control (intl:gettext + "~<~A is a key designator only in the final otherwise-clause. ~ + Use (~A) to use it as a normal-clause or move the clause to the ~ + correct position.~:@>") + :format-arguments (list (list key key)) + :references (list '(:ansi-cl :section (5 3)) + (list :ansi-cl :macro name))))) + ((eq (first case) t) + ;; The key T is normal clause, because it's not + ;; the last clause. + (push (first case) keys) + (push `((,test ,keyform-value + ',(first case)) nil ,@(rest case)) clauses)))) + ((and multi-p (listp (first case))) + (setf keys (append (first case) keys)) + (push `((or ,@(mapcar #'(lambda (key) + `(,test ,keyform-value ',key)) + (first case))) + nil ,@(rest case)) + clauses)) + (t + (when (and allow-otherwise + (memq (car case) '(t otherwise))) + (warn 'kernel:simple-style-warning + :format-control (intl:gettext "Bad style to use ~S in ~S") + :format-arguments (list (car case) name))) + (push (first case) keys) + (push `((,test ,keyform-value + ',(first case)) nil ,@(rest case)) clauses)))) + (case-body-aux name keyform keyform-value clauses keys proceedp + allow-otherwise + `(,(if multi-p 'member 'or) ,@keys)))) + +;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled all the +;;; cases. Note: it is not necessary that the resulting code signal +;;; case-failure conditions, but that's what KMP's prototype code did. We call +;;; CASE-BODY-ERROR, because of how closures are compiled. RESTART-CASE has +;;; forms with closures that the compiler causes to be generated at the top of +;;; any function using the case macros, regardless of whether they are needed. +;;; +(defun case-body-aux (name keyform keyform-value clauses keys + proceedp allow-otherwise expected-type) + (if proceedp + (let ((block (gensym)) + (again (gensym))) + `(let ((,keyform-value ,keyform)) + (block ,block + (tagbody + ,again + (return-from + ,block + (cond ,@(nreverse clauses) + (t + (setf ,keyform-value + (setf ,keyform + (case-body-error + ',name ',keyform ,keyform-value + ',expected-type ',keys))) + (go ,again)))))))) + `(let ((,keyform-value ,keyform)) + ,keyform-value ; prevent warnings when key not used eg (case key (t)) + (cond + ,@(nreverse clauses) + ,@(if allow-otherwise + `((t (error 'conditions::case-failure + :name ',name + :datum ,keyform-value + :expected-type ',expected-type + :possibilities ',keys)))))))) + +(defmacro case (keyform &body cases) + "CASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value + of Keyform. If a singleton key is T or Otherwise then the clause is + a default clause." + (case-body 'case keyform cases t 'eql nil)) + +(defmacro ccase (keyform &body cases) + "CCASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value of + Keyform. If none of the keys matches then a correctable error is + signalled." + (case-body 'ccase keyform cases t 'eql t t)) + +(defmacro ecase (keyform &body cases) + "ECASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value of + Keyform. If none of the keys matches then an error is signalled." + (case-body 'ecase keyform cases t 'eql nil t)) + +(defmacro typecase (keyform &body cases) + "TYPECASE Keyform {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform + and Type is true. If a singleton key is T or Otherwise then the + clause is a default clause." + (case-body 'typecase keyform cases nil 'typep nil)) + +(defmacro ctypecase (keyform &body cases) + "CTYPECASE Keyform {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform and Type + is true. If no form is satisfied then a correctable error is signalled." + (case-body 'ctypecase keyform cases nil 'typep t t)) + +(defmacro etypecase (keyform &body cases) + "ETYPECASE Keyform {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform and Type + is true. If no form is satisfied then an error is signalled." + (case-body 'etypecase keyform cases nil 'typep nil t)) + + +) + ===================================== src/code/macros.lisp ===================================== --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -1347,7 +1347,7 @@ ;;; generate an ERROR form. (This is for CCASE and ECASE which allow ;;; using T and OTHERWISE as regular keys.) ;;; -(defun case-body (name keyform cases multi-p test errorp proceedp &optional allow-otherwise) +(defun case-body (name keyform cases multi-p test proceedp &optional allow-otherwise) (let ((keyform-value (gensym)) (clauses ()) (keys ())) @@ -1362,9 +1362,7 @@ ;; The CLHS says OTHERWISE clause is an OTHERWISE clause ;; only if it's the last case. Otherwise, it's just a ;; normal clause. - (if errorp - (error (intl:gettext "No default clause allowed in ~S: ~S") name case) - (push `(t nil ,@(rest case)) clauses))) + (push `(t nil ,@(rest case)) clauses)) ((and (eq name 'case)) (let ((key (first case))) (error 'kernel:invalid-case @@ -1398,7 +1396,7 @@ (push (first case) keys) (push `((,test ,keyform-value ',(first case)) nil ,@(rest case)) clauses)))) - (case-body-aux name keyform keyform-value clauses keys errorp proceedp + (case-body-aux name keyform keyform-value clauses keys proceedp allow-otherwise `(,(if multi-p 'member 'or) ,@keys)))) @@ -1410,7 +1408,7 @@ ;;; any function using the case macros, regardless of whether they are needed. ;;; (defun case-body-aux (name keyform keyform-value clauses keys - errorp proceedp allow-otherwise expected-type) + proceedp allow-otherwise expected-type) (if proceedp (let ((block (gensym)) (again (gensym))) @@ -1432,7 +1430,7 @@ ,keyform-value ; prevent warnings when key not used eg (case key (t)) (cond ,@(nreverse clauses) - ,@(if (or errorp allow-otherwise) + ,@(if allow-otherwise `((t (error 'conditions::case-failure :name ',name :datum ,keyform-value @@ -1460,39 +1458,39 @@ Evaluates the Forms in the first clause with a Key EQL to the value of Keyform. If a singleton key is T or Otherwise then the clause is a default clause." - (case-body 'case keyform cases t 'eql nil nil)) + (case-body 'case keyform cases t 'eql nil)) (defmacro ccase (keyform &body cases) "CCASE Keyform {({(Key*) | Key} Form*)}* Evaluates the Forms in the first clause with a Key EQL to the value of Keyform. If none of the keys matches then a correctable error is signalled." - (case-body 'ccase keyform cases t 'eql nil t t)) + (case-body 'ccase keyform cases t 'eql t t)) (defmacro ecase (keyform &body cases) "ECASE Keyform {({(Key*) | Key} Form*)}* Evaluates the Forms in the first clause with a Key EQL to the value of Keyform. If none of the keys matches then an error is signalled." - (case-body 'ecase keyform cases t 'eql nil nil t)) + (case-body 'ecase keyform cases t 'eql nil t)) (defmacro typecase (keyform &body cases) "TYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If a singleton key is T or Otherwise then the clause is a default clause." - (case-body 'typecase keyform cases nil 'typep nil nil)) + (case-body 'typecase keyform cases nil 'typep nil)) (defmacro ctypecase (keyform &body cases) "CTYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If no form is satisfied then a correctable error is signalled." - (case-body 'ctypecase keyform cases nil 'typep nil t t)) + (case-body 'ctypecase keyform cases nil 'typep t t)) (defmacro etypecase (keyform &body cases) "ETYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If no form is satisfied then an error is signalled." - (case-body 'etypecase keyform cases nil 'typep nil nil t)) + (case-body 'etypecase keyform cases nil 'typep nil t)) ;;;; ASSERT and CHECK-TYPE. ===================================== src/i18n/locale/cmucl.pot ===================================== --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -14689,10 +14689,6 @@ msgid "~S -- Bad clause in ~S." msgstr "" #: src/code/macros.lisp -msgid "No default clause allowed in ~S: ~S" -msgstr "" - -#: src/code/macros.lisp msgid "" "~<~A is a key designator only in the final otherwise-clause. ~\n" " Use (~A) to use it as a " View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/78c91b67208bc2e80428f9d3f…

1 0

[Git][cmucl/cmucl][master] Check for function names correctly
by Raymond Toy 24 Jun '15

24 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 89074ab3 by Raymond Toy at 2015-06-24T06:50:04Z Check for function names correctly Fix #7 The change to use extended names like (flet frob) broke the detection of local names for get-setf-expansion. Fix it. This reverts behavior back to what 18a used to do. A test for this is also added. - - - - - 2 changed files: - src/code/macros.lisp - tests/issues.lisp Changes: ===================================== src/code/macros.lisp ===================================== --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -667,7 +667,7 @@ ((and environment (let ((name (car form))) (dolist (x (c::lexenv-functions environment) nil) - (when (and (eq (car x) name) + (when (and (eq (nth-value 1 (valid-function-name-p (car x))) name) (not (c::defined-function-p (cdr x)))) (return t))))) (expand-or-get-setf-inverse form environment)) ===================================== tests/issues.lisp ===================================== --- a/tests/issues.lisp +++ b/tests/issues.lisp @@ -73,4 +73,23 @@ (assert-prints "SQUARE compiler macro present: No. 8" - (test/present))) \ No newline at end of file + (test/present))) + +(defmacro xpop (place &environment env) + (multiple-value-bind (dummies vals new setter getter) + (get-setf-expansion place env) + `(let* (,@(mapcar #'list dummies vals) (,(car new) ,getter)) + (if ,(cdr new) (error "Can't expand this.")) + (prog1 (car ,(car new)) + (setq ,(car new) (cdr ,(car new))) + ,setter)))) + +(defsetf frob (x) (value) + `(setf (car ,x) ,value)) + +(define-test issue.7 + (:tag :issues) + (assert-error 'error + (let ((z (list 1 2))) + (flet ((frob (x) (cdr x))) + (xpop (frob z)))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/89074ab386b5ce7d228326194…

1 0

[cmucl/cmucl][master] Add brief documentat on the test names.
by Raymond Toy 22 Jun '15

22 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 94409c5e by Raymond Toy at 2015-06-22T23:09:02Z Add brief documentat on the test names. I always forget how to run one set of tests. Add some hints. - - - - - 1 changed file: - tests/run-tests.lisp Changes: ===================================== tests/run-tests.lisp ===================================== --- a/tests/run-tests.lisp +++ b/tests/run-tests.lisp @@ -10,6 +10,10 @@ ;;;; ;;;; lisp -noinit -load tests/run-tests.lisp -eval '(progn (cmucl-test-runner:load-test-files) (cmucl-test-runner:run-test <list>))' ;;;; +;;;; where <list> is a list of the test names such as "ISSUES-TESTS", +;;;; "IRRAT-TESTS", etc. The test names are basically the file name +;;;; with a suffix of "-TESTS". +;;;; ;;;; Note that you cannot run these tests from a binary created during ;;;; a build process. You must run ;;;; View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/94409c5eb240820fd9274725b…

1 0

[cmucl/cmucl][master] Lookup names correctly in COMPILER-MACRO-FUNCTION.
by Raymond Toy 22 Jun '15

22 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: e6999217 by Raymond Toy at 2015-06-22T23:08:08Z Lookup names correctly in COMPILER-MACRO-FUNCTION. Fix #3. The lookup for the names was not handling things like (FLET SQUARE TEST/PRESENT) correctly. Use VALID-FUNCTION-NAME to get the function name instead of a plain EQUAL test. - - - - - 2 changed files: - src/code/eval.lisp - tests/issues.lisp Changes: ===================================== src/code/eval.lisp ===================================== --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -448,7 +448,8 @@ set with SETF." (let ((found (and env (cdr (assoc name (c::lexenv-functions env) - :test #'equal))))) + :key #'(lambda (e) + (nth-value 1 (valid-function-name-p e)))))))) (unless (eq (cond ((c::defined-function-p found) (c::defined-function-inlinep found)) (found :notinline) ===================================== tests/issues.lisp ===================================== --- a/tests/issues.lisp +++ b/tests/issues.lisp @@ -38,3 +38,39 @@ t) (t () nil)))) + +;; Functions for testing issue-3 +(defun sqr (x) + (expt x 2)) + +(define-compiler-macro sqr (x) + `(expt ,x 2)) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defmacro with-square-check (&body body &environment env) + (let ((text (if (compiler-macro-function 'sqr env) + "Yes" + "No"))) + `(progn + (format t "SQUARE compiler macro present: ~A.~%" ,text) + ,@body)))) + + +(defun test/absent () + (with-square-check + (sqr 2))) + +(defun test/present () + (flet ((sqr (x) + (print (expt x 3)))) + (with-square-check + (sqr 2)))) + +(define-test issue.3 + (:tag :issues) + (assert-prints "SQUARE compiler macro present: Yes." + (test/absent)) + (assert-prints "SQUARE compiler macro present: No. + +8" + (test/present))) \ No newline at end of file View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/e69992175ccdcd7f895cff997…

1 0

[cmucl/cmucl][master] Fix #4: ELT signals error on invalid index on lists
by Raymond Toy 14 Jun '15

14 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 1ca0a557 by Raymond Toy at 2015-06-14T08:31:14Z Fix #4: ELT signals error on invalid index on lists code/seq.lisp: o Define internal LIST-ELT* function that executes ELT on lists, signaling an error if the index is invalid. compiler/seqtran.lisp: o Change the deftransform for ELT to use LIST-ELT* instead of NTH. tests/issues.lisp: o Add test for this issue. - - - - - 3 changed files: - src/code/seq.lisp - src/compiler/seqtran.lisp - tests/issues.lisp Changes: ===================================== src/code/seq.lisp ===================================== --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -138,6 +138,16 @@ (t (make-sequence-of-type (result-type-or-lose type) length)))) +(defun list-elt* (sequence index) + (declare (type list sequence)) + (do ((count index (1- count)) + (list sequence (cdr list))) + ((= count 0) + (if (endp list) + (signal-index-too-large-error sequence index) + (car list))) + (declare (type (integer 0) count)))) + (defun elt (sequence index) "Returns the element of SEQUENCE specified by INDEX." (etypecase sequence ===================================== src/compiler/seqtran.lisp ===================================== --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -107,8 +107,8 @@ (deftransform elt ((s i) ((simple-array * (*)) *) * :when :both) '(aref s i)) -(deftransform elt ((s i) (list *) * :when :both :policy (< safety 3)) - '(nth i s)) +(deftransform elt ((s i) (list *) * :when :both) + '(lisp::list-elt* s i)) (deftransform %setelt ((s i v) ((simple-array * (*)) * *) * :when :both) '(%aset s i v)) ===================================== tests/issues.lisp ===================================== --- a/tests/issues.lisp +++ b/tests/issues.lisp @@ -23,3 +23,18 @@ (assert-equal '(square x) (funcall (compiler-macro-function 'square) '(funcall #'square x) nil))) + +(define-test issue.5 + (:tag :issues) + (assert-true + (handler-case + (let ((f (compile nil '(lambda (list) + (declare (type list list) + (optimize (speed 1) (safety 1) (compilation-speed 1) (space 1) (debug 1))) + (elt list 3))))) + (funcall f (list 0 1 2))) + ;; ELT should signal an error in this case. + (lisp::index-too-large-error () + t) + (t () + nil)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/1ca0a5571183b014a50fad56b…

1 0

[cmucl/cmucl][master] Regenerated.
by Raymond Toy 14 Jun '15

14 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: b096e8dd by Raymond Toy at 2015-06-13T23:23:25Z Regenerated. - - - - - 1 changed file: - src/i18n/locale/cmucl.pot Changes: ===================================== src/i18n/locale/cmucl.pot ===================================== --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -14693,7 +14693,11 @@ msgid "No default clause allowed in ~S: ~S" msgstr "" #: src/code/macros.lisp -msgid "T and OTHERWISE may not be used as key designators for ~A" +msgid "" +"~<~A is a key designator only in the final otherwise-clause. ~\n" +" Use (~A) to use it as a " +"normal-clause or move the clause to the ~\n" +" correct position.~:@>" msgstr "" #: src/code/macros.lisp View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/b096e8dd9d0bd437945dd520b…

1 0

[cmucl/cmucl][master] Increase *ERROR-PRINT-LINES* to a 10.
by Raymond Toy 14 Jun '15

14 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 39c24612 by Raymond Toy at 2015-06-13T23:22:58Z Increase *ERROR-PRINT-LINES* to a 10. Five is a bit small, especially when printing out the message from issue #5. - - - - - 1 changed file: - src/compiler/ir1util.lisp Changes: ===================================== src/compiler/ir1util.lisp ===================================== --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1665,7 +1665,7 @@ "The value for *Print-Level* when printing compiler error messages.") (defvar *error-print-length* 5 "The value for *Print-Length* when printing compiler error messages.") -(defvar *error-print-lines* 5 +(defvar *error-print-lines* 10 "The value for *Print-Lines* when printing compiler error messages.") (defvar *enclosing-source-cutoff* 1 View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/39c246129881b43be8214737f…

1 0

[cmucl/cmucl][master] Fix #5: Give better error message
by Raymond Toy 14 Jun '15

14 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: e791b596 by Raymond Toy at 2015-06-13T23:21:13Z Fix #5: Give better error message Give a better error message when using T clause in case error.lisp: o Add new invalid-case condition to handle errors from case expressions. macros.lisp: o Use new invalid-case condition to signal the invalid usage of T in CASE expressions. o Replace old message with better, more informative, message. Include xref to ANSI CL spec. exports.lisp: o Export INVALID-CASE from KERNEL package. - - - - - 3 changed files: - src/code/error.lisp - src/code/exports.lisp - src/code/macros.lisp Changes: ===================================== src/code/error.lisp ===================================== --- a/src/code/error.lisp +++ b/src/code/error.lisp @@ -25,6 +25,7 @@ simple-file-error simple-program-error simple-parse-error simple-style-warning simple-undefined-function constant-modified + invalid-case #+stack-checking stack-overflow #+heap-overflow-check heap-overflow)) @@ -1115,7 +1116,20 @@ (constant-modified-function-name c)) (print-references (reference-condition-references c) s))) (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3))))) - + +;; For errors in CASE and friends. +(define-condition invalid-case (reference-condition error) + ((name :initarg :name + :reader invalid-case-name) + (format :initarg :format-control + :reader invalid-case-format) + (args :initarg :format-arguments + :reader invalid-case-format-args)) + (:report (lambda (condition stream) + (format stream "~A: " (invalid-case-name condition)) + (apply #'format stream (invalid-case-format condition) (invalid-case-format-args condition)) + (print-references (reference-condition-references condition) stream)))) + (define-condition arithmetic-error (error) ((operation :reader arithmetic-error-operation :initarg :operation :initform nil) ===================================== src/code/exports.lisp ===================================== --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -2538,7 +2538,8 @@ "SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-P" "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-ERROR" - "DD-PI")) + "DD-PI" + "INVALID-CASE")) (dolist (name ===================================== src/code/macros.lisp ===================================== --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -1366,7 +1366,16 @@ (error (intl:gettext "No default clause allowed in ~S: ~S") name case) (push `(t nil ,@(rest case)) clauses))) ((and (eq name 'case)) - (error (intl:gettext "T and OTHERWISE may not be used as key designators for ~A") name)) + (let ((key (first case))) + (error 'kernel:invalid-case + :name name + :format-control (intl:gettext + "~<~A is a key designator only in the final otherwise-clause. ~ + Use (~A) to use it as a normal-clause or move the clause to the ~ + correct position.~:@>") + :format-arguments (list (list key key)) + :references (list '(:ansi-cl :section (5 3)) + (list :ansi-cl :macro name))))) ((eq (first case) t) ;; The key T is normal clause, because it's not ;; the last clause. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/e791b596f0471f9027a95e8d5…

1 0

[cmucl/cmucl][master] Regenerated.
by Raymond Toy 14 Jun '15

14 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 83ce6c9e by Raymond Toy at 2015-06-13T18:30:41Z Regenerated. - - - - - 1 changed file: - src/i18n/locale/cmucl-unix.pot Changes: ===================================== src/i18n/locale/cmucl-unix.pot ===================================== --- a/src/i18n/locale/cmucl-unix.pot +++ b/src/i18n/locale/cmucl-unix.pot @@ -1236,3 +1236,50 @@ msgid "" " and its children." msgstr "" +#: src/code/unix.lisp +msgid "" +"Get the value of the environment variable named Name. If no such\n" +" variable exists, Nil is returned." +msgstr "" + +#: src/code/unix.lisp +msgid "" +"Adds the environment variable named Name to the environment with\n" +" the given Value if Name does not already exist. If Name does exist,\n" +" the value is changed to Value if Overwrite is non-zero. Otherwise,\n" +" the value is not changed." +msgstr "" + +#: src/code/unix.lisp +msgid "" +"Adds or changes the environment. Name-value must be a string of\n" +" the form \"name=value\". If the name does not exist, it is added.\n" +" If name does exist, the value is updated to the given value." +msgstr "" + +#: src/code/unix.lisp +msgid "Removes the variable Name from the environment" +msgstr "" + +#: src/code/unix.lisp +msgid "" +"Executes the Unix execve system call. If the system call suceeds, lisp\n" +" will no longer be running in this process. If the system call fails " +"this\n" +" function returns two values: NIL and an error code. Arg-list should be " +"a\n" +" list of simple-strings which are passed as arguments to the exec'ed " +"program.\n" +" Environment should be an a-list mapping symbols to simple-strings which " +"this\n" +" function bashes together to form the environment for the exec'ed " +"program." +msgstr "" + +#: src/code/unix.lisp +msgid "" +"Executes the unix fork system call. Returns 0 in the child and the pid\n" +" of the child in the parent if it works, or NIL and an error number if it\n" +" doesn't work." +msgstr "" + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/83ce6c9e7cd6b3fed407255d8…

1 0

[cmucl/cmucl][master] Move more unix support to core for asdf and slime.
by Raymond Toy 12 Jun '15

12 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 1a20bb57 by Raymond Toy at 2015-06-11T21:28:39Z Move more unix support to core for asdf and slime. o The upcoming version of asdf wants to use unix-getenv, so add that to the core, removing from the unix contrib. o Slime wants to use unix-execve and unix-fork, so import that and the necessary support routines in to the core from the unix contrib. - - - - - 4 changed files: - src/code/exports.lisp - src/code/unix.lisp - src/contrib/unix/unix-glibc2.lisp - src/contrib/unix/unix.lisp Changes: ===================================== src/code/exports.lisp ===================================== --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -357,6 +357,15 @@ "FIONREAD" "TERMINAL-SPEEDS" ) + (:export + ;; For asdf + "UNIX-GETENV" + "UNIX-SETENV" + "UNIX-PUTENV" + "UNIX-UNSETENV" + ;; For slime + "UNIX-EXECVE" + "UNIX-FORK") #-(or linux solaris) (:export "TCHARS" "LTCHARS" ===================================== src/code/unix.lisp ===================================== --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -2517,3 +2517,150 @@ (cast (slot names 'machine) c-string)) #+freebsd 256 (addr names)))) + +;;; For asdf. Well, only getenv, but might as well make it symmetric. + +;; Environment manipulation; man getenv(3) +(def-alien-routine ("getenv" unix-getenv) c-call:c-string + (name c-call:c-string) + _N"Get the value of the environment variable named Name. If no such + variable exists, Nil is returned.") + +;; This doesn't exist in Solaris 8 but does exist in Solaris 10. +(def-alien-routine ("setenv" unix-setenv) c-call:int + (name c-call:c-string) + (value c-call:c-string) + (overwrite c-call:int) + _N"Adds the environment variable named Name to the environment with + the given Value if Name does not already exist. If Name does exist, + the value is changed to Value if Overwrite is non-zero. Otherwise, + the value is not changed.") + + +(def-alien-routine ("putenv" unix-putenv) c-call:int + (name-value c-call:c-string) + _N"Adds or changes the environment. Name-value must be a string of + the form \"name=value\". If the name does not exist, it is added. + If name does exist, the value is updated to the given value.") + +(def-alien-routine ("unsetenv" unix-unsetenv) c-call:int + (name c-call:c-string) + _N"Removes the variable Name from the environment") + + +;;; For slime, which wants to use unix-execve. + +(defmacro round-bytes-to-words (n) + `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3))) + +;;; +;;; STRING-LIST-TO-C-STRVEC -- Internal +;;; +;;; STRING-LIST-TO-C-STRVEC is a function which takes a list of +;;; simple-strings and constructs a C-style string vector (strvec) -- +;;; a null-terminated array of pointers to null-terminated strings. +;;; This function returns two values: a sap and a byte count. When the +;;; memory is no longer needed it should be deallocated with +;;; vm_deallocate. +;;; +(defun string-list-to-c-strvec (string-list) + ;; + ;; Make a pass over string-list to calculate the amount of memory + ;; needed to hold the strvec. + (let ((string-bytes 0) + (vec-bytes (* 4 (1+ (length string-list))))) + (declare (fixnum string-bytes vec-bytes)) + (dolist (s string-list) + (check-type s simple-string) + (incf string-bytes (round-bytes-to-words (1+ (length s))))) + ;; + ;; Now allocate the memory and fill it in. + (let* ((total-bytes (+ string-bytes vec-bytes)) + (vec-sap (system:allocate-system-memory total-bytes)) + (string-sap (sap+ vec-sap vec-bytes)) + (i 0)) + (declare (type (and unsigned-byte fixnum) total-bytes i) + (type system:system-area-pointer vec-sap string-sap)) + (dolist (s string-list) + (declare (simple-string s)) + (let ((n (length s))) + ;; + ;; Blast the string into place + #-unicode + (kernel:copy-to-system-area (the simple-string s) + (* vm:vector-data-offset vm:word-bits) + string-sap 0 + (* (1+ n) vm:byte-bits)) + #+unicode + (progn + ;; FIXME: Do we need to apply some kind of transformation + ;; to convert Lisp unicode strings to C strings? Utf-8? + (dotimes (k n) + (setf (sap-ref-8 string-sap k) + (logand #xff (char-code (aref s k))))) + (setf (sap-ref-8 string-sap n) 0)) + ;; + ;; Blast the pointer to the string into place + (setf (sap-ref-sap vec-sap i) string-sap) + (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n)))) + (incf i 4))) + ;; Blast in last null pointer + (setf (sap-ref-sap vec-sap i) (int-sap 0)) + (values vec-sap total-bytes)))) + +(defun sub-unix-execve (program arg-list env-list) + (let ((argv nil) + (argv-bytes 0) + (envp nil) + (envp-bytes 0) + result error-code) + (unwind-protect + (progn + ;; Blast the stuff into the proper format + (multiple-value-setq + (argv argv-bytes) + (string-list-to-c-strvec arg-list)) + (multiple-value-setq + (envp envp-bytes) + (string-list-to-c-strvec env-list)) + ;; + ;; Now do the system call + (multiple-value-setq + (result error-code) + (int-syscall ("execve" + c-string system-area-pointer system-area-pointer) + program argv envp))) + ;; + ;; Deallocate memory + (when argv + (system:deallocate-system-memory argv argv-bytes)) + (when envp + (system:deallocate-system-memory envp envp-bytes))) + (values result error-code))) + +;;;; UNIX-EXECVE +(defun unix-execve (program &optional arg-list + (environment *environment-list*)) + _N"Executes the Unix execve system call. If the system call suceeds, lisp + will no longer be running in this process. If the system call fails this + function returns two values: NIL and an error code. Arg-list should be a + list of simple-strings which are passed as arguments to the exec'ed program. + Environment should be an a-list mapping symbols to simple-strings which this + function bashes together to form the environment for the exec'ed program." + (check-type program simple-string) + (let ((env-list (let ((envlist nil)) + (dolist (cons environment) + (push (if (cdr cons) + (concatenate 'simple-string + (string (car cons)) "=" + (cdr cons)) + (car cons)) + envlist)) + envlist))) + (sub-unix-execve (%name->file program) arg-list env-list))) + +(defun unix-fork () + _N"Executes the unix fork system call. Returns 0 in the child and the pid + of the child in the parent if it works, or NIL and an error number if it + doesn't work." + (int-syscall ("fork"))) ===================================== src/contrib/unix/unix-glibc2.lisp ===================================== --- a/src/contrib/unix/unix-glibc2.lisp +++ b/src/contrib/unix/unix-glibc2.lisp @@ -1129,61 +1129,6 @@ length LEN and type TYPE." ;;; unistd.h -(defun sub-unix-execve (program arg-list env-list) - (let ((argv nil) - (argv-bytes 0) - (envp nil) - (envp-bytes 0) - result error-code) - (unwind-protect - (progn - ;; Blast the stuff into the proper format - (multiple-value-setq - (argv argv-bytes) - (string-list-to-c-strvec arg-list)) - (multiple-value-setq - (envp envp-bytes) - (string-list-to-c-strvec env-list)) - ;; - ;; Now do the system call - (multiple-value-setq - (result error-code) - (int-syscall ("execve" - c-string system-area-pointer system-area-pointer) - program argv envp))) - ;; - ;; Deallocate memory - (when argv - (system:deallocate-system-memory argv argv-bytes)) - (when envp - (system:deallocate-system-memory envp envp-bytes))) - (values result error-code))) - -;;;; UNIX-EXECVE - -(defun unix-execve (program &optional arg-list - (environment *environment-list*)) - _N"Executes the Unix execve system call. If the system call suceeds, lisp - will no longer be running in this process. If the system call fails this - function returns two values: NIL and an error code. Arg-list should be a - list of simple-strings which are passed as arguments to the exec'ed program. - Environment should be an a-list mapping symbols to simple-strings which this - function bashes together to form the environment for the exec'ed program." - (check-type program simple-string) - (let ((env-list (let ((envlist nil)) - (dolist (cons environment) - (push (if (cdr cons) - (concatenate 'simple-string - (string (car cons)) "=" - (cdr cons)) - (car cons)) - envlist)) - envlist))) - (sub-unix-execve (%name->file program) arg-list env-list))) - - -(defmacro round-bytes-to-words (n) - `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3))) (defun unix-chown (path uid gid) _N"Given a file path, an integer user-id, and an integer group-id, @@ -1328,37 +1273,6 @@ length LEN and type TYPE." returned if the call fails." (void-syscall ("setregid" int int) rgid egid)) -(defun unix-fork () - _N"Executes the unix fork system call. Returns 0 in the child and the pid - of the child in the parent if it works, or NIL and an error number if it - doesn't work." - (int-syscall ("fork"))) - -;; Environment maninpulation; man getenv(3) -(def-alien-routine ("getenv" unix-getenv) c-call:c-string - (name c-call:c-string) - _N"Get the value of the environment variable named Name. If no such - variable exists, Nil is returned.") - -(def-alien-routine ("setenv" unix-setenv) c-call:int - (name c-call:c-string) - (value c-call:c-string) - (overwrite c-call:int) - _N"Adds the environment variable named Name to the environment with - the given Value if Name does not already exist. If Name does exist, - the value is changed to Value if Overwrite is non-zero. Otherwise, - the value is not changed.") - -(def-alien-routine ("putenv" unix-putenv) c-call:int - (name c-call:c-string) - _N"Adds or changes the environment. Name-value must be a string of - the form \"name=value\". If the name does not exist, it is added. - If name does exist, the value is updated to the given value.") - -(def-alien-routine ("unsetenv" unix-unsetenv) c-call:int - (name c-call:c-string) - _N"Removes the variable Name from the environment") - ;;; Unix-link creates a hard link from name2 to name1. (defun unix-link (name1 name2) @@ -1888,61 +1802,6 @@ in at a time in poll.") (export '(unix-file-kind unix-maybe-prepend-current-directory unix-resolve-links unix-simplify-pathname)) -;;; -;;; STRING-LIST-TO-C-STRVEC -- Internal -;;; -;;; STRING-LIST-TO-C-STRVEC is a function which takes a list of -;;; simple-strings and constructs a C-style string vector (strvec) -- -;;; a null-terminated array of pointers to null-terminated strings. -;;; This function returns two values: a sap and a byte count. When the -;;; memory is no longer needed it should be deallocated with -;;; vm_deallocate. -;;; -(defun string-list-to-c-strvec (string-list) - ;; - ;; Make a pass over string-list to calculate the amount of memory - ;; needed to hold the strvec. - (let ((string-bytes 0) - (vec-bytes (* 4 (1+ (length string-list))))) - (declare (fixnum string-bytes vec-bytes)) - (dolist (s string-list) - (check-type s simple-string) - (incf string-bytes (round-bytes-to-words (1+ (length s))))) - ;; - ;; Now allocate the memory and fill it in. - (let* ((total-bytes (+ string-bytes vec-bytes)) - (vec-sap (system:allocate-system-memory total-bytes)) - (string-sap (sap+ vec-sap vec-bytes)) - (i 0)) - (declare (type (and unsigned-byte fixnum) total-bytes i) - (type system:system-area-pointer vec-sap string-sap)) - (dolist (s string-list) - (declare (simple-string s)) - (let ((n (length s))) - ;; - ;; Blast the string into place - #-unicode - (kernel:copy-to-system-area (the simple-string s) - (* vm:vector-data-offset vm:word-bits) - string-sap 0 - (* (1+ n) vm:byte-bits)) - #+unicode - (progn - ;; FIXME: Do we need to apply some kind of transformation - ;; to convert Lisp unicode strings to C strings? Utf-8? - (dotimes (k n) - (setf (sap-ref-8 string-sap k) - (logand #xff (char-code (aref s k))))) - (setf (sap-ref-8 string-sap n) 0)) - ;; - ;; Blast the pointer to the string into place - (setf (sap-ref-sap vec-sap i) string-sap) - (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n)))) - (incf i 4))) - ;; Blast in last null pointer - (setf (sap-ref-sap vec-sap i) (int-sap 0)) - (values vec-sap total-bytes)))) - ;;; Stuff not yet found in the header files... ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ===================================== src/contrib/unix/unix.lisp ===================================== --- a/src/contrib/unix/unix.lisp +++ b/src/contrib/unix/unix.lisp @@ -634,159 +634,12 @@ group leader. NIL and an error number are returned upon failure." (void-syscall ("setpgid" int int) pid pgrp)) -(defun unix-fork () - _N"Executes the unix fork system call. Returns 0 in the child and the pid - of the child in the parent if it works, or NIL and an error number if it - doesn't work." - (int-syscall ("fork"))) - -;; Environment manipulation; man getenv(3) -(def-alien-routine ("getenv" unix-getenv) c-call:c-string - (name c-call:c-string) - _N"Get the value of the environment variable named Name. If no such - variable exists, Nil is returned.") - -;; This doesn't exist in Solaris 8 but does exist in Solaris 10. -(def-alien-routine ("setenv" unix-setenv) c-call:int - (name c-call:c-string) - (value c-call:c-string) - (overwrite c-call:int) - _N"Adds the environment variable named Name to the environment with - the given Value if Name does not already exist. If Name does exist, - the value is changed to Value if Overwrite is non-zero. Otherwise, - the value is not changed.") - - -(def-alien-routine ("putenv" unix-putenv) c-call:int - (name-value c-call:c-string) - _N"Adds or changes the environment. Name-value must be a string of - the form \"name=value\". If the name does not exist, it is added. - If name does exist, the value is updated to the given value.") - -;; This doesn't exist in Solaris 8 but does exist in Solaris 10. -(def-alien-routine ("unsetenv" unix-unsetenv) c-call:int - (name c-call:c-string) - _N"Removes the variable Name from the environment") - ;;;; Support routines for dealing with unix pathnames. (export '(unix-file-kind unix-maybe-prepend-current-directory unix-resolve-links unix-simplify-pathname)) - -;;;; UNIX-EXECVE - -(defun unix-execve (program &optional arg-list - (environment *environment-list*)) - _N"Executes the Unix execve system call. If the system call suceeds, lisp - will no longer be running in this process. If the system call fails this - function returns two values: NIL and an error code. Arg-list should be a - list of simple-strings which are passed as arguments to the exec'ed program. - Environment should be an a-list mapping symbols to simple-strings which this - function bashes together to form the environment for the exec'ed program." - (check-type program simple-string) - (let ((env-list (let ((envlist nil)) - (dolist (cons environment) - (push (if (cdr cons) - (concatenate 'simple-string - (string (car cons)) "=" - (cdr cons)) - (car cons)) - envlist)) - envlist))) - (sub-unix-execve (%name->file program) arg-list env-list))) - - -(defmacro round-bytes-to-words (n) - `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3))) - -;;; -;;; STRING-LIST-TO-C-STRVEC -- Internal -;;; -;;; STRING-LIST-TO-C-STRVEC is a function which takes a list of -;;; simple-strings and constructs a C-style string vector (strvec) -- -;;; a null-terminated array of pointers to null-terminated strings. -;;; This function returns two values: a sap and a byte count. When the -;;; memory is no longer needed it should be deallocated with -;;; vm_deallocate. -;;; -(defun string-list-to-c-strvec (string-list) - ;; - ;; Make a pass over string-list to calculate the amount of memory - ;; needed to hold the strvec. - (let ((string-bytes 0) - (vec-bytes (* 4 (1+ (length string-list))))) - (declare (fixnum string-bytes vec-bytes)) - (dolist (s string-list) - (check-type s simple-string) - (incf string-bytes (round-bytes-to-words (1+ (length s))))) - ;; - ;; Now allocate the memory and fill it in. - (let* ((total-bytes (+ string-bytes vec-bytes)) - (vec-sap (system:allocate-system-memory total-bytes)) - (string-sap (sap+ vec-sap vec-bytes)) - (i 0)) - (declare (type (and unsigned-byte fixnum) total-bytes i) - (type system:system-area-pointer vec-sap string-sap)) - (dolist (s string-list) - (declare (simple-string s)) - (let ((n (length s))) - ;; - ;; Blast the string into place - #-unicode - (kernel:copy-to-system-area (the simple-string s) - (* vm:vector-data-offset vm:word-bits) - string-sap 0 - (* (1+ n) vm:byte-bits)) - #+unicode - (progn - ;; FIXME: Do we need to apply some kind of transformation - ;; to convert Lisp unicode strings to C strings? Utf-8? - (dotimes (k n) - (setf (sap-ref-8 string-sap k) - (logand #xff (char-code (aref s k))))) - (setf (sap-ref-8 string-sap n) 0)) - - ;; - ;; Blast the pointer to the string into place - (setf (sap-ref-sap vec-sap i) string-sap) - (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n)))) - (incf i 4))) - ;; Blast in last null pointer - (setf (sap-ref-sap vec-sap i) (int-sap 0)) - (values vec-sap total-bytes)))) - -(defun sub-unix-execve (program arg-list env-list) - (let ((argv nil) - (argv-bytes 0) - (envp nil) - (envp-bytes 0) - result error-code) - (unwind-protect - (progn - ;; Blast the stuff into the proper format - (multiple-value-setq - (argv argv-bytes) - (string-list-to-c-strvec arg-list)) - (multiple-value-setq - (envp envp-bytes) - (string-list-to-c-strvec env-list)) - ;; - ;; Now do the system call - (multiple-value-setq - (result error-code) - (int-syscall ("execve" - c-string system-area-pointer system-area-pointer) - program argv envp))) - ;; - ;; Deallocate memory - (when argv - (system:deallocate-system-memory argv argv-bytes)) - (when envp - (system:deallocate-system-memory envp envp-bytes))) - (values result error-code))) - ;;; View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/1a20bb5731c5774c29f25ef3d…

1 0