movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

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

27 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv576 Modified Files: special-operators-cl.lisp Log Message: Fix eval-when for :compile-toplevel, must actually be top-level. --- /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2007/04/11 22:09:39 1.53 +++ /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2008/04/27 19:23:14 1.54 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.53 2007/04/11 22:09:39 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.54 2008/04/27 19:23:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -992,7 +992,8 @@ :top-level-p top-level-p :form body) (compiler-values ())) - (when (member :compile-toplevel situations) + (when (and (member :compile-toplevel situations) + top-level-p) (with-compilation-unit () (dolist (toplevel-form (translate-program body :muerte.cl :cl :when :eval

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-serv32667 Modified Files: parse.lisp Log Message: Fix bug in decode-normal-lambda-list. --- /project/movitz/cvsroot/movitz/parse.lisp 2008/04/21 21:09:47 1.9 +++ /project/movitz/cvsroot/movitz/parse.lisp 2008/04/27 19:22:42 1.10 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:49:17 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: parse.lisp,v 1.9 2008/04/21 21:09:47 ffjeld Exp $ +;;;; $Id: parse.lisp,v 1.10 2008/04/27 19:22:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -23,9 +23,7 @@ (defun parse-declarations-and-body (forms &optional (declare-symbol 'muerte.cl::declare)) "From the list of FORMS, return first the list of non-declaration forms, ~ second the list of declaration-specifiers." - (loop for declaration-form = (when (declare-form-p (car forms) declare-symbol) - (pop forms)) - if (declare-form-p (car forms) declare-symbol) + (loop if (declare-form-p (car forms) declare-symbol) append (cdr (pop forms)) into declarations else return (values forms declarations))) @@ -45,7 +43,7 @@ (pop lambda-list) (pop lambda-list))) (env-var nil) - (operator-var (gensym)) + (operator-var (gensym "operator-")) (destructuring-lambda-list (do ((l lambda-list) (r nil)) @@ -58,7 +56,7 @@ (push x r))))) (ignore-env-var (when (not env-var) - (gensym)))) + (gensym "ignore-env-")))) (values destructuring-lambda-list whole-var (or env-var @@ -208,14 +206,14 @@ (auxes (nreverse (getf results (aux))))) (when (> (length rests) 1) (error "There can only be one &REST formal parameter.")) - (let ((maxargs (and (null rests) ; max num. of arguments, or nil. - (null keys) - (not allow-other-keys-p) - (+ (length requireds) - (length optionals)))) - (minargs (length requireds)) - (keys-p (not (eq :missing - (getf results (key) :missing))))) + (let* ((keys-p (not (eq :missing ; &key present? + (getf results (key) :missing)))) + (maxargs (and (null rests) ; max num. of arguments, or nil. + (not keys-p) + (not allow-other-keys-p) + (+ (length requireds) + (length optionals)))) + (minargs (length requireds))) (return (values requireds optionals (first rests) @@ -223,14 +221,14 @@ auxes allow-other-keys-p minargs - (unless keys-p - maxargs) + maxargs edx-var (cond - ((or (eql maxargs minargs) - (eq :no-key (getf results (key) :no-key))) + ((or (not keys-p) + (eql maxargs minargs)) nil) - ((assert (not maxargs))) + ((assert (not maxargs) () + "Weird maxargs ~S for ~S." maxargs lambda-list)) ((evenp (+ (length requireds) (length optionals))) :even) (t :odd))

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-serv30486 Modified Files: packages.lisp Log Message: more muerte symbols. --- /project/movitz/cvsroot/movitz/packages.lisp 2008/04/21 19:46:02 1.60 +++ /project/movitz/cvsroot/movitz/packages.lisp 2008/04/27 19:20:06 1.61 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.60 2008/04/21 19:46:02 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.61 2008/04/27 19:20:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1236,6 +1236,10 @@ #:parse-docstring-declarations-and-body #:parse-macro-lambda-list #:compute-function-block-name + #:movitz-macroexpand + #:movitz-macroexpand-1 + #:decode-optional-formal + #:decode-keyword-formal #:movitz-accessor #:%object-lispval @@ -1395,6 +1399,10 @@ muerte::parse-macro-lambda-list muerte::unfold-circular-list muerte::compute-function-block-name + muerte::movitz-macroexpand + muerte::movitz-macroexpand-1 + muerte::decode-optional-formal + muerte::decode-keyword-formal ))

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-serv30109 Modified Files: image.lisp Log Message: indent. --- /project/movitz/cvsroot/movitz/image.lisp 2008/04/21 19:45:51 1.123 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/04/27 19:18:16 1.124 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.123 2008/04/21 19:45:51 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.124 2008/04/27 19:18:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1240,15 +1240,13 @@ 'package) (movitz-read (ensure-package (string :common-lisp) :muerte.common-lisp))) (loop for symbol being the hash-key of (image-oblist *image*) - as lisp-package = (symbol-package symbol) - as package-name = (and lisp-package - (movitz-package-name (package-name lisp-package) symbol)) -;;; do (when (string= symbol :method) -;;; (warn "XXXX ~S ~S ~S" symbol lisp-package package-name)) - when package-name - do (let* ((movitz-package (ensure-package package-name lisp-package symbol))) - (setf (movitz-symbol-package (movitz-read symbol)) - (movitz-read movitz-package)))) + as lisp-package = (symbol-package symbol) + as package-name = (and lisp-package + (movitz-package-name (package-name lisp-package) symbol)) + when package-name + do (let* ((movitz-package (ensure-package package-name lisp-package symbol))) + (setf (movitz-symbol-package (movitz-read symbol)) + (movitz-read movitz-package)))) movitz-packages))))

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-serv29953 Modified Files: eval.lisp Log Message: Don't coerce to function. --- /project/movitz/cvsroot/movitz/eval.lisp 2007/03/11 21:18:40 1.12 +++ /project/movitz/cvsroot/movitz/eval.lisp 2008/04/27 19:17:17 1.13 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 2 17:45:05 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: eval.lisp,v 1.12 2007/03/11 21:18:40 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.13 2008/04/27 19:17:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -76,10 +76,17 @@ ((muerte.cl:quote) t) ((muerte.cl:not) (movitz-constantp (second form))) - ((muerte.cl:+ muerte.cl:- muerte.cl:* muerte.cl:coerce) + ((muerte.cl:+ muerte.cl:- muerte.cl:*) (every (lambda (sub-form) (movitz-constantp sub-form env)) - (cdr form))))) + (cdr form))) + ((muerte.cl:coerce) + (and (= 3 (length form)) + (every (lambda (sub-form) + (movitz-constantp sub-form env)) + (cdr form)) + (not (member (movitz-eval (third form) env) + '(muerte.cl:function))))))) (and compiler-macro-function (not (movitz-env-get (car form) 'notinline nil env)) (not (eq form compiler-macro-expansion))

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-serv29743 Modified Files: environment.lisp Log Message: indent. --- /project/movitz/cvsroot/movitz/environment.lisp 2008/03/15 20:44:53 1.23 +++ /project/movitz/cvsroot/movitz/environment.lisp 2008/04/27 19:16:16 1.24 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.23 2008/03/15 20:44:53 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.24 2008/04/27 19:16:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -332,28 +332,28 @@ (let ((expander (movitz-macro-function (car movitz-form) env))) (if (not expander) (values movitz-form nil) - (values (translate-program (funcall *movitz-macroexpand-hook* expander movitz-form env) - :muerte.cl :cl) - t)))) + (values (translate-program (funcall *movitz-macroexpand-hook* expander movitz-form env) + :muerte.cl :cl) + t)))) (symbol (let ((binding (movitz-binding movitz-form env))) (if (not (typep binding 'symbol-macro-binding)) (values movitz-form nil) - (values (translate-program (funcall *movitz-macroexpand-hook* - (macro-binding-expander binding) - movitz-form env) - :muerte.cl :cl) - t)))) + (values (translate-program (funcall *movitz-macroexpand-hook* + (macro-binding-expander binding) + movitz-form env) + :muerte.cl :cl) + t)))) (t (values movitz-form nil))))) (defun movitz-macroexpand (form &optional env) (let ((global-expanded-p nil)) (loop while - (multiple-value-bind (expansion expanded-p) - (movitz-macroexpand-1 form env) - (when expanded-p - (setf form expansion) - (setf global-expanded-p expanded-p)))) + (multiple-value-bind (expansion expanded-p) + (movitz-macroexpand-1 form env) + (when expanded-p + (setf form expansion) + (setf global-expanded-p expanded-p)))) (values form global-expanded-p))) (define-symbol-macro *movitz-global-environment*

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-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

← Newer
1
2
3
4
5
6
7
8
...
260
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs