April 2008 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS movitz
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29457 Modified Files: compiler-types.lisp Log Message: Complex type. --- /project/movitz/cvsroot/movitz/compiler-types.lisp 2006/11/08 08:57:05 1.26 +++ /project/movitz/cvsroot/movitz/compiler-types.lisp 2008/04/27 19:14:54 1.27 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.26 2006/11/08 08:57:05 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.27 2008/04/27 19:14:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -233,15 +233,19 @@ ;;; (defparameter *tb-bitmap* - '(hash-table character function cons keyword symbol vector array integer ratio :tail) + '(hash-table character function cons keyword symbol vector array integer ratio complex :tail) "The union of these types must be t.") (defun basic-typep (x type) (ecase type (hash-table (and (typep x 'movitz-struct) - (eq (movitz-read 'muerte.cl:hash-table) - (slot-value x 'name)))) + (eq (muerte::movitz-find-class 'muerte.cl:hash-table) + (slot-value x 'class)))) + (complex + (and (typep x 'movitz-struct) + (eq (muerte::movitz-find-class 'muerte.cl:complex) + (slot-value x 'class)))) (character (typep x 'movitz-character)) (function @@ -366,7 +370,7 @@ (or (type-code-p 'integer code) (and integer-range (numscope-memberp integer-range (movitz-bignum-value x))))) - (t (dolist (bt '(symbol character function cons hash-table vector ratio) + (t (dolist (bt '(symbol character function cons hash-table vector ratio complex) (error "Cant decide typep for ~S." x)) (when (basic-typep x bt) (return (type-code-p bt code))))))

1 0

[movitz-cvs] CVS movitz
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27877 Modified Files: compiler.lisp Log Message: Remove bad peephole optimized heuristic. Improved movitz-eql. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/21 19:45:36 1.204 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/27 19:07:33 1.205 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.204 2008/04/21 19:45:36 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.205 2008/04/27 19:07:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -236,28 +236,32 @@ ;; The ability to provide funobj's identity is important when a ;; function must be referenced before it can be compiled, e.g. for ;; mutually recursive (lexically bound) functions. - (with-retries-until-true (retry-pass1 "Retry first-pass compilation of ~S." name) - ;; First-pass is mostly functional, so it can safely be restarted. - (multiple-value-bind (required-vars optional-vars rest-var key-vars aux-vars allow-p min max edx-var) - (decode-normal-lambda-list lambda-list) - (declare (ignore aux-vars allow-p min max)) - ;; There are several main branches through the function - ;; compiler, and this is where we decide which one to take. - (funcall (cond - ((let ((sub-form (cddr form))) - (and (consp (car sub-form)) - (eq 'muerte::numargs-case (caar sub-form)))) - 'make-compiled-function-pass1-numarg-case) - ((and (= 1 (length required-vars)) ; (x &optional y) - (= 1 (length optional-vars)) - (movitz-constantp (nth-value 1 (decode-optional-formal (first optional-vars))) - env) - (null key-vars) - (not rest-var) - (not edx-var)) - 'make-compiled-function-pass1-1req1opt) - (t 'make-compiled-function-pass1)) - name lambda-list declarations form env top-level-p funobj)))) + (multiple-value-bind (required-vars optional-vars rest-var key-vars aux-vars allow-p min max edx-var) + (decode-normal-lambda-list lambda-list) + (declare (ignore aux-vars allow-p min max)) + ;; There are several main branches through the function + ;; compiler, and this is where we decide which one to take. + (funcall (cond + ((let ((sub-form (cddr form))) + (and (consp (car sub-form)) + (eq 'muerte::numargs-case (caar sub-form)))) + 'make-compiled-function-pass1-numarg-case) + ((and (= 1 (length required-vars)) ; (x &optional y) + (= 1 (length optional-vars)) + (movitz-constantp (nth-value 1 (decode-optional-formal (first optional-vars))) + env) + (null key-vars) + (not rest-var) + (not edx-var)) + 'make-compiled-function-pass1-1req1opt) + (t 'make-compiled-function-pass1)) + name + lambda-list + declarations + form + env + top-level-p + funobj))) (defun ensure-pass1-funobj (funobj class &rest init-args) "If funobj is nil, return a fresh funobj of class. @@ -1880,14 +1884,14 @@ (case (instruction-is next-load) (:movl (let ((pos (position next-load pc))) - (setq p (nconc (subseq pc 0 pos) - (if (or (eq register (twop-dst next-load)) - (find-if (lambda (m) - (and (eq (twop-dst next-load) (cdr m)) - (= (car m) (stack-frame-operand place)))) - map)) - nil - (list `(:movl ,register ,(twop-dst next-load))))) + (setq p (append (subseq pc 0 pos) + (if (or (eq register (twop-dst next-load)) + (find-if (lambda (m) + (and (eq (twop-dst next-load) (cdr m)) + (= (car m) (stack-frame-operand place)))) + map)) + nil + (list `(:movl ,register ,(twop-dst next-load))))) next-pc (nthcdr (1+ pos) pc)) (explain nil "preserved load/store .. load ~S of place ~S because ~S." next-load place reason))) @@ -2141,14 +2145,6 @@ (setq p `((:call (:edi ,(global-constant-offset newf)))) next-pc (nthcdr 2 pc)) (explain nil "Changed [~S ~S] to ~S" i i2 newf))) - ((and (equal i '(:movl :eax :ebx)) - (global-funcall-p i2 '(fast-car-ebx fast-cdr-ebx))) - (let ((newf (ecase (global-funcall-p i2 '(fast-car-ebx fast-cdr-ebx)) - (fast-car-ebx 'fast-car) - (fast-cdr-ebx 'fast-cdr)))) - (setq p `((:call (:edi ,(global-constant-offset newf)))) - next-pc (nthcdr 2 pc)) - (explain nil "Changed [~S ~S] to ~S" i i2 newf))) #+ignore ((and (global-funcall-p i '(fast-cdr)) (global-funcall-p i2 '(fast-cdr)) @@ -4426,6 +4422,10 @@ ((eql 1 location-1) (decf stack-setup-size) '((:pushl :ebx))) + ((eql 2 location-1) + (decf stack-setup-size 2) + `((:pushl :edi) + (:pushl :ebx))) (t (ecase location-1 ((nil :ebx) nil) (:edx '((:movl :ebx :edx))) @@ -4490,7 +4490,7 @@ (append (cond ;; normalize arg-count in ecx.. ((and max-args (= min-args max-args)) - (error "huh?")) + (error "huh? max: ~S, min: ~S" max-args min-args)) ((and max-args (<= 0 min-args max-args #x7f)) `((:andl #x7f :ecx))) ((>= min-args #x80) @@ -6967,7 +6967,9 @@ (make-store-lexical destination loc0 nil funobj frame-map)) ((integerp loc0) (make-load-lexical term0 destination funobj nil frame-map)) - (t (break "Unknown Y zero-add: ~S" instruction)))) + ((type-specifier-singleton type0) + (make-load-lexical term0 destination funobj nil frame-map)) + (t (break "Unknown Y zero-add: ~S for ~S/~S => ~S" instruction term0 loc0 destination)))) ((and (movitz-subtypep type0 'fixnum) (movitz-subtypep type1 'fixnum) (movitz-subtypep result-type 'fixnum)) @@ -7203,6 +7205,29 @@ ;;;;;;; +(defun movitz-eql (x y) + "Emulate EQL on movitz-objects." + (etypecase x + (movitz-immediate-object + (and (typep y 'movitz-immediate-object) + (eql (movitz-immediate-value x) + (movitz-immediate-value y)))) + ((or movitz-symbol movitz-null movitz-cons movitz-basic-vector) + (eq x y)) + (movitz-struct + (cond + ((not (typep y 'movitz-struct)) + nil) + ((eq (movitz-struct-class x) + (muerte::movitz-find-class 'muerte.cl:complex)) + (and (eq (movitz-struct-class x) + (muerte::movitz-find-class 'muerte.cl:complex)) + (movitz-eql (first (movitz-struct-slot-values x)) + (first (movitz-struct-slot-values y))) + (movitz-eql (second (movitz-struct-slot-values x)) + (second (movitz-struct-slot-values y))))) + (t (error "movitz-eql unknown movitz-struct: ~S" x)))))) + (define-find-read-bindings :eql (x y mode) (declare (ignore mode)) (list x y)) @@ -7239,11 +7264,8 @@ (make-load-lexical y :ebx funobj nil frame-map))))) (cond ((and x-singleton y-singleton) - (let ((eql (etypecase (car x-singleton) - (movitz-immediate-object - (and (typep (car y-singleton) 'movitz-immediate-object) - (eql (movitz-immediate-value (car x-singleton)) - (movitz-immediate-value (car y-singleton)))))))) + (let ((eql (movitz-eql (car x-singleton) + (car y-singleton)))) (case (operator return-mode) (:boolean-branch-on-false (when (not eql)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv18531 Modified Files: eval.lisp Log Message: Fix parse-docstring-declarations-and-body. Fix bug in decode-keyword-formal. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/27 08:38:01 1.33 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/27 16:14:10 1.34 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.33 2008/04/27 08:38:01 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.34 2008/04/27 16:14:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -149,11 +149,6 @@ ((multiple-value-prog1) (multiple-value-prog1 (eval-form (cadr form) env) (eval-progn (cddr form) env))) - ((destructuring-bind) - (eval-progn (cdddr form) - (make-destructuring-env (cadr form) - (eval-form (caddr form) env) - env))) ((catch) (catch (eval-form (second form) env) (eval-progn (cddr form) env))) @@ -234,6 +229,26 @@ (dolist (d (cdar p)) (push d declarations)))) +(defun parse-docstring-declarations-and-body (forms &optional (declare-symbol 'muerte.cl::declare)) + "From the list of FORMS, return first the non-declarations forms, second the declarations, ~ + and third the documentation string." + (let ((docstring nil)) + (do (declarations docstring) + ((endp forms) + (values nil + declarations + docstring)) + (cond + ((typep (car forms) + '(cons (eql declare))) + (setf declarations (append declarations (cdr (pop forms))))) + ((and (stringp (car forms)) + (cdr forms)) + (setf docstring (pop forms))) + (t (return (values forms + declarations + docstring))))))) + (defun parse-docstring-declarations-and-body (forms &optional (declare 'declare)) "From the list of FORMS, return first the list of non-declaration forms, ~ second the list of declaration-specifiers, third any docstring." @@ -241,9 +256,9 @@ (if (or (not (cdr forms)) (not (stringp (car forms)))) (parse-declarations-and-body forms) - (multiple-value-call #'values - (parse-declarations-and-body (cdr forms)) - (car forms)))) + (multiple-value-call #'values + (parse-declarations-and-body (cdr forms)) + (car forms)))) (defun compute-function-block-name (function-name) (cond @@ -290,7 +305,9 @@ Return the variable, keyword, init-fom, and supplied-p-parameter." (cond ((symbolp formal) - (values formal formal nil nil)) + (values formal + (intern (symbol-name formal) :keyword) + nil nil)) ((symbolp (car formal)) (values (car formal) (intern (symbol-name (car formal)) :keyword) @@ -302,8 +319,8 @@ (caddr formal))))) (defun make-destructuring-env (pattern values env &key (recursive-p t) - (environment-p nil) - (whole-p t)) + (environment-p nil) + (whole-p t)) (let (env-var) (when (and whole-p (eq '&whole (car pattern))) (push (cons (cadr pattern) values) @@ -381,12 +398,12 @@ (push (cons (cdr pp) values) env)) finally - (when (and values (member state '(requireds optionals))) - (simple-program-error "Too many arguments."))) + (when (and values (member state '(requireds optionals))) + (simple-program-error "Too many arguments."))) (if (and environment-p env-var) (cons (cons env-var env) env) - env))) + env))) (defun eval-let (var-specs declarations-and-body env) (let (special-vars @@ -579,7 +596,8 @@ (values (if (not name) function (setf (symbol-function name) function)) - t nil))) + nil + nil))) (defun macroexpand-1 (form &optional env) (if (atom form)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14842 Modified Files: lists.lisp Log Message: add set-exclusive-or --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/04/27 09:28:40 1.28 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/04/27 09:36:39 1.29 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.28 2008/04/27 09:28:40 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.29 2008/04/27 09:36:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -659,6 +659,33 @@ :test (if test-not (complement test-not) test))) + +(defun set-exclusive-or (list-1 list-2 &key (key 'identity) (test 'eql) test-not) + (union (set-difference list-1 list-2 + :key key + :test test + :test-not test-not) + (set-difference list-2 list-1 + :key key + :test test + :test-not test-not) + :key key + :test test + :test-not test-not)) + +(defun nset-exclusive-or (list-1 list-2 &key (key 'identity) (test 'eql) test-not) + (nunion (nset-difference list-1 list-2 + :key key + :test test + :test-not test-not) + (nset-difference list-2 list-1 + :key key + :test test + :test-not test-not) + :key key + :test test + :test-not test-not)) + (defun subsetp (list-1 list-2 &key (key 'identity) (test 'eql) test-not) "=> generalized-boolean"

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14216 Modified Files: lists.lisp Log Message: Fix assoc-if, add rassoc-if, member-if, and mapcon. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/04/19 12:44:02 1.27 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/04/27 09:28:40 1.28 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.27 2008/04/19 12:44:02 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.28 2008/04/27 09:28:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -82,6 +82,40 @@ (when (test item (key (car a))) (return a)))))))) +(defun assoc-if (predicate alist &key (key 'identity)) + "=> entry" + (numargs-case + (2 (predicate alist) + (with-funcallable (predicate) + (dolist (a alist) + (when a + (when (predicate (car a)) + (return a)))))) + (t (predicate alist &key (key 'identity)) + (with-funcallable (key) + (with-funcallable (predicate) + (dolist (a alist) + (when a + (when (predicate (key (car a))) + (return a))))))))) + +(defun assoc-if-not (predicate alist &key (key 'identity)) + "=> entry" + (numargs-case + (2 (predicate alist) + (with-funcallable (predicate) + (dolist (a alist) + (when a + (when (not (predicate (car a))) + (return a)))))) + (t (predicate alist &key (key 'identity)) + (with-funcallable (key) + (with-funcallable (predicate) + (dolist (a alist) + (when a + (when (not (predicate (key (car a)))) + (return a))))))))) + (defun rassoc (item alist &key (test 'eql) (key 'identity)) (numargs-case (2 (item alist) @@ -95,6 +129,24 @@ (when (test item (key (cdr a))) (return a)))))))) +(defun rassoc-if (predicate alist &key (key 'identity)) + "=> entry" + (numargs-case + (2 (predicate alist) + (with-funcallable (predicate) + (dolist (a alist) + (when a + (when (predicate (cdr a)) + (return a)))))) + (t (predicate alist &key (key 'identity)) + (with-funcallable (key) + (with-funcallable (predicate) + (dolist (a alist) + (when a + (when (predicate (key (cdr a))) + (return a))))))))) + + (defun list-length (x) (do ((n 0 (+ n 2)) ;Counter. (fast x (cddr fast)) ;Fast pointer: leaps by 2. @@ -128,6 +180,38 @@ (when (test (key item) (key (car p))) (return p))))))))) +(defun member-if (predicate list &key key) + (numargs-case + (2 (predicate list) + (with-funcallable (predicate) + (do ((p list (cdr p))) + ((endp p) nil) + (when (predicate (car p)) + (return p))))) + (t (predicate list &key (key 'identity)) + (with-funcallable (predicate) + (with-funcallable (key) + (do ((p list (cdr p))) + ((endp p) nil) + (when (predicate (key (car p))) + (return p)))))))) + +(defun member-if-not (predicate list &key key) + (numargs-case + (2 (predicate list) + (with-funcallable (predicate) + (do ((p list (cdr p))) + ((endp p) nil) + (when (not (predicate (car p))) + (return p))))) + (t (predicate list &key (key 'identity)) + (with-funcallable (predicate) + (with-funcallable (key) + (do ((p list (cdr p))) + ((endp p) nil) + (when (not (predicate (key (car p)))) + (return p)))))))) + (defun last (list &optional (n 1)) ;; from the hyperspec.. (check-type n integer) ; (integer 0)) @@ -320,8 +404,6 @@ (setf more-lists (map-into more-lists #'cdr more-lists)))))) - - (defun mapcan (function first-list &rest more-lists) (numargs-case (2 (function first-list) @@ -362,6 +444,48 @@ (setf more-lists (map-into more-lists #'cdr more-lists)))))) +(defun mapcon (function first-list &rest more-lists) + (numargs-case + (2 (function first-list) + (do ((result nil) + (tail nil) + (p first-list (cdr p))) + ((endp p) result) + (let ((m (funcall function p))) + (if tail + (setf (cdr tail) m) + (setf result m)) + (setf tail (last m))))) + (3 (function first-list second-list) + (do ((result nil) + (tail nil) + (p first-list (cdr p)) + (q second-list (cdr q))) + ((or (endp p) + (endp q)) + result) + (let ((m (funcall function p q))) + (if tail + (setf (cdr tail) m) + (setf result m)) + (setf tail (last m))))) + (t (function first-list &rest more-lists) + (declare (dynamic-extent more-lists)) + (do ((result nil) + (tail nil)) + ((or (endp first-list) + (some #'endp more-lists)) + result) + (let ((m (apply function first-list more-lists))) + (if tail + (setf (cdr tail) m) + (setf result m)) + (setf tail (last m))) + (setf first-list + (cdr first-list)) + (setf more-lists + (map-into more-lists #'cdr more-lists)))))) + (defun mapc (function first-list &rest more-lists) (numargs-case (2 (function first-list)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv10677 Modified Files: hash-tables.lisp Log Message: Add hash-table-size. --- /project/movitz/cvsroot/movitz/losp/muerte/hash-tables.lisp 2008/04/17 19:34:08 1.14 +++ /project/movitz/cvsroot/movitz/losp/muerte/hash-tables.lisp 2008/04/27 09:10:04 1.15 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Feb 19 19:09:05 2001 ;;;; -;;;; $Id: hash-tables.lisp,v 1.14 2008/04/17 19:34:08 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.15 2008/04/27 09:10:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -50,6 +50,10 @@ :sxhash sxhash :count 0))) +(defun hash-table-size (hash-table) + (values (truncate (length (hash-table-bucket hash-table)) + 2))) + (defun hash-table-iterator (bucket index) (when index (let ((index (check-the (index 2) index)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3266 Modified Files: eval.lisp Log Message: Rename parse-foo-formal to decode-foo-formal. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/21 19:40:05 1.32 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/27 08:38:01 1.33 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.32 2008/04/21 19:40:05 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.33 2008/04/27 08:38:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -214,7 +214,7 @@ (push x r))))) (ignore-env-var (when (not env-var) - (gensym)))) + (gensym "ignore-env-")))) (values destructuring-lambda-list whole-var (or env-var @@ -276,9 +276,7 @@ :whole-p nil))))) name) - - -(defun parse-optional-formal (formal) +(defun decode-optional-formal (formal) "3.4.1.2 Specifiers for optional parameters. Parse {var | (var [init-form [supplied-p-parameter]])} Return the variable, init-form, and suplied-p-parameter." @@ -286,7 +284,7 @@ (symbol (values formal nil nil)) (cons (values (first formal) (second formal) (third formal))))) -(defun parse-keyword-formal (formal) +(defun decode-keyword-formal (formal) "3.4.1.4 Specifiers for keyword parameters. Parse {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])} Return the variable, keyword, init-fom, and supplied-p-parameter." @@ -345,7 +343,7 @@ env)) (&optional (multiple-value-bind (var init-form supplied-p-parameter) - (parse-optional-formal p) + (decode-optional-formal p) (when supplied-p-parameter (push (cons supplied-p-parameter (not (null values))) @@ -359,7 +357,7 @@ env)) (&key (multiple-value-bind (var key init-form supplied-p-parameter) - (parse-keyword-formal p) + (decode-keyword-formal p) (let* ((x (member key values :test #'eq)) (present-p (not (null x))) (value (if present-p

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv2766 Modified Files: variables.lisp Log Message: Add the - variable. --- /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2008/04/21 19:44:13 1.13 +++ /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2008/04/27 08:34:48 1.14 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 5 21:53:34 2003 ;;;; -;;;; $Id: variables.lisp,v 1.13 2008/04/21 19:44:13 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.14 2008/04/27 08:34:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -30,6 +30,7 @@ (defvar // nil) (defvar /// nil) +(defvar - nil) (defvar + nil) (defvar ++ nil) (defvar +++ nil)

1 0

[movitz-cvs] CVS movitz/losp/lib
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/lib In directory clnet:/tmp/cvs-serv2734 Modified Files: repl.lisp Log Message: Add the - variable. --- /project/movitz/cvsroot/movitz/losp/lib/repl.lisp 2005/10/31 09:19:15 1.17 +++ /project/movitz/cvsroot/movitz/losp/lib/repl.lisp 2008/04/27 08:34:46 1.18 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Mar 19 14:58:12 2003 ;;;; -;;;; $Id: repl.lisp,v 1.17 2005/10/31 09:19:15 ffjeld Exp $ +;;;; $Id: repl.lisp,v 1.18 2008/04/27 08:34:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -98,8 +98,9 @@ (restart (invoke-restart-interactively restart)) ((not (keywordp form)) - (multiple-value-call #'process-expresion - form previous-package t (eval form))) + (let ((- form)) + (multiple-value-call #'process-expresion + form previous-package t (eval form)))) (t (multiple-value-call #'process-expresion form previous-package nil (apply 'muerte.toplevel:invoke-toplevel-command

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 23 Apr '08

23 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv2540 Modified Files: packages.lisp Log Message: do-symbols &co have implicit tagbodys, not implicit progns. --- /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp 2008/04/21 19:41:52 1.15 +++ /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp 2008/04/23 18:47:46 1.16 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.15 2008/04/21 19:41:52 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.16 2008/04/23 18:47:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -173,31 +173,33 @@ (return ,result-form)) (let ((,package-hash-var (package-object-external-symbols ,package-var))) (tagbody ,loop-tag - (with-hash-table-iterator (,next-symbol ,package-hash-var) - (tagbody ,loop-tag - (multiple-value-bind (,more-symbols-var ,dummy ,symbol-var) - (,next-symbol) - (declare (ignore ,dummy)) - (unless ,more-symbols-var (go ,end-tag)) - (let ((,var ,symbol-var)) - ,@declarations-and-body)) - (go ,loop-tag) - ,end-tag)) - (let ((internals (package-object-internal-symbols ,package-var))) - (unless (eq ,package-hash-var internals) - (setf ,package-hash-var internals) - (go ,loop-tag)))))))))) + (with-hash-table-iterator (,next-symbol ,package-hash-var) + (tagbody ,loop-tag + (multiple-value-bind (,more-symbols-var ,dummy ,symbol-var) + (,next-symbol) + (declare (ignore ,dummy)) + (unless ,more-symbols-var (go ,end-tag)) + (prog ((,var ,symbol-var)) + ,@declarations-and-body)) + (go ,loop-tag) + ,end-tag)) + (let ((internals (package-object-internal-symbols ,package-var))) + (unless (eq ,package-hash-var internals) + (setf ,package-hash-var internals) + (go ,loop-tag)))))))))) (defmacro do-external-symbols - ((var &optional (package *package*) result-form) &body declarations-and-body) + ((var &optional (package '*package*) result-form) &body declarations-and-body) (let ((next-var (gensym)) (more-var (gensym)) (key-var (gensym))) `(with-hash-table-iterator (,next-var (package-object-external-symbols (assert-package ,package))) (do () (nil) (multiple-value-bind (,more-var ,key-var ,var) (,next-var) - (unless ,more-var (return ,result-form)) - (let () ,@declarations-and-body)))))) + (unless ,more-var + (return ,result-form)) + (prog () + ,@declarations-and-body)))))) (defmacro do-symbols ((var &optional (package '*package*) result-form) &body declarations-and-body) (let ((state-var (gensym)) @@ -215,35 +217,40 @@ (1 (package-object-internal-symbols ,package-object-var)) (t (let ((x (pop ,use-list-var))) (and x (package-object-external-symbols x))))))) - ((not ,hash-table-var) ,result-form) + ((not ,hash-table-var) ,result-form) (declare (index ,state-var)) (with-hash-table-iterator (,next-var ,hash-table-var) (do () (nil) (multiple-value-bind (,more-var ,key-var ,var) (,next-var) (declare (ignore ,key-var)) (if ,more-var - (let () ,@declarations-and-body) - (return)))))))) + (prog () + ,@declarations-and-body) + (return)))))))) (defun apropos (string &optional package) (flet ((apropos-symbol (symbol string) (when (search string (symbol-name symbol) :test #'char-equal) (cond - ((keywordp symbol) - (format t "~&~W == keyword~%" symbol)) - ((fboundp symbol) - (format t "~&~W == function ~:A~%" - symbol (funobj-lambda-list (symbol-function symbol)))) - ((boundp symbol) - (format t "~&~W == variable ~S~%" - symbol (symbol-value symbol))) - (t (format t "~&~W~%" symbol)))))) + ((keywordp symbol) + (format t "~&~W == keyword~%" symbol)) + ((fboundp symbol) + (format t "~&~W == function ~:A~%" + symbol (funobj-lambda-list (symbol-function symbol)))) + ((boundp symbol) + (format t "~&~W == variable ~S~%" + symbol (symbol-value symbol))) + (t (format t "~&~W~%" symbol)))))) (let ((string (string string))) (if package (do-symbols (symbol package) (apropos-symbol symbol string)) - (do-all-symbols (symbol) - (apropos-symbol symbol string))))) + (do-all-symbols (symbol) + (apropos-symbol symbol string))))) (values)) - +(defmacro with-package-iterator ((name package-list-form &rest symbol-types) &body body) + `(macrolet ((,name () + '(warn "with-package-iterator not implemented." + (values nil nil nil nil)))) + ,@body)) \ No newline at end of file

1 0