[Cmucl-cvs] [git] CMU Common Lisp branch master updated. 20f-65-g6a513c6
Raymond Toy
rtoy at common-lisp.net
Sun Nov 2 16:52:33 UTC 2014
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CMU Common Lisp".
The branch, master has been updated
via 6a513c6066055f8ffc16c73601275c295bc91896 (commit)
via 1caa05146ddbeb7dd780516a8f6e54de1cf5183e (commit)
via d5fb9d56c6a9d977325334a78f69b6fb40929d0c (commit)
from 7fc49a853e8823351d405f99a10dfcfe32d025f0 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 6a513c6066055f8ffc16c73601275c295bc91896
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Sun Nov 2 08:52:24 2014 -0800
Update notes from logs.
diff --git a/src/general-info/release-21a.txt b/src/general-info/release-21a.txt
index c3e5838..c7fc0cc 100644
--- a/src/general-info/release-21a.txt
+++ b/src/general-info/release-21a.txt
@@ -41,6 +41,7 @@ New in this release:
* Motifd text callback fixed.
* Support for 64-bit time_t on NetBSD added. This allows cmucl to
run on more recent versions of NetBSD.
+ * The empty package LOOP has been removed.
* Trac Tickets:
* Ticket #54 fixed.
commit 1caa05146ddbeb7dd780516a8f6e54de1cf5183e
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Sun Nov 2 08:51:43 2014 -0800
Remove src/code/old-loop.lisp.
It's not used anymore; ansi-loop.lisp is CMUCL's loop implementation.
diff --git a/src/code/old-loop.lisp b/src/code/old-loop.lisp
deleted file mode 100644
index cb492ec..0000000
--- a/src/code/old-loop.lisp
+++ /dev/null
@@ -1,828 +0,0 @@
-;;; -*- Package: LOOP -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public domain.
-;;;
-(ext:file-comment
- "$Header: src/code/old-loop.lisp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Loop facility, written by William Lott.
-;;;
-(in-package "LOOP")
-(intl:textdomain "cmucl")
-
-(in-package "LISP")
-(export '(loop loop-finish))
-
-(in-package "LOOP")
-
-
-;;;; Specials used during the parse.
-
-;;; These specials hold the different parts of the result as we are generating
-;;; them.
-;;;
-(defvar *loop-name*)
-(defvar *outside-bindings*)
-(defvar *prologue*)
-(defvar *inside-bindings*)
-(defvar *body-forms*)
-(defvar *iteration-forms*)
-(defvar *epilogue*)
-(defvar *result-var*)
-(defvar *return-value*)
-(defvar *default-return-value*)
-(defvar *accumulation-variables*)
-
-;;; This special holds the remaining stuff we need to parse.
-;;;
-(defvar *remaining-stuff*)
-
-;;; This special holds a value that is EQ only to itself.
-;;;
-(defvar *magic-cookie* (list '<magic-cookie>))
-
-
-;;;; Utility functions/macros used by the parser.
-
-(proclaim '(inline maybe-car maybe-cdr))
-
-(defun maybe-car (thing)
- (if (consp thing) (car thing) thing))
-
-(defun maybe-cdr (thing)
- (if (consp thing) (cdr thing) thing))
-
-
-(defmacro loop-keyword-p (thing keyword &rest more-keywords)
- `(let ((thing ,thing))
- (and (symbolp thing)
- (let ((name (symbol-name thing)))
- (or ,@(mapcar #'(lambda (keyword)
- `(string= name ,keyword))
- (cons keyword more-keywords)))))))
-
-(defun preposition-p (prep)
- (when (loop-keyword-p (car *remaining-stuff*) prep)
- (pop *remaining-stuff*)
- t))
-
-
-(defun splice-in-subform (form subform)
- (if (eq form *magic-cookie*)
- subform
- (labels ((sub-splice-in-subform (form path)
- (cond ((atom form)
- nil)
- ((member form path)
- nil)
- ((eq (car form) *magic-cookie*)
- (setf (car form) subform)
- t)
- (t
- (let ((new-path (cons form path)))
- (or (sub-splice-in-subform (car form) new-path)
- (sub-splice-in-subform (cdr form) new-path)))))))
- (if (sub-splice-in-subform form nil)
- form
- (error "Couldn't find the magic cookie in:~% ~S~%Loop is broken."
- form)))))
-
-(defmacro queue-var (where name type &key
- (initer nil initer-p) (stepper nil stepper-p))
- `(push (list ,name ,type ,initer-p ,initer ,stepper-p ,stepper)
- ,where))
-
-(defvar *default-values* '(nil 0 0.0)
- "The different possible default values. When we need a default value, we
- use the first value in this list that is typep the desired type.")
-
-(defun pick-default-value (var type)
- (if (consp var)
- (cons (pick-default-value (car var) (maybe-car type))
- (pick-default-value (cdr var) (maybe-cdr type)))
- (dolist (default *default-values*
- (error "Cannot default variables of type ~S ~
- (for variable ~S)."
- type var))
- (when (typep default type)
- (return default)))))
-
-(defun only-simple-types (type-spec)
- (if (atom type-spec)
- (member type-spec '(fixnum float t nil))
- (and (only-simple-types (car type-spec))
- (only-simple-types (cdr type-spec)))))
-
-
-(defun build-let-expression (vars)
- (if (null vars)
- (values *magic-cookie* *magic-cookie*)
- (let ((inside nil)
- (outside nil)
- (steppers nil)
- (sub-lets nil))
- (dolist (var vars)
- (labels
- ((process (name type initial-p initial stepper-p stepper)
- (cond ((atom name)
- (cond ((not stepper-p)
- (push (list type name initial) outside))
- ((not initial-p)
- (push (list type name stepper) inside))
- (t
- (push (list type name initial) outside)
- (setf steppers
- (nconc steppers (list name stepper))))))
- ((and (car name) (cdr name))
- (let ((temp (gensym (format nil "TEMP-FOR-~A-" name))))
- (process temp 'list initial-p initial
- stepper-p stepper)
- (push (if stepper-p
- (list (car name)
- (maybe-car type)
- nil nil
- t `(car ,temp))
- (list (car name)
- (maybe-car type)
- t `(car ,temp)
- nil nil))
- sub-lets)
- (push (if stepper-p
- (list (cdr name)
- (maybe-cdr type)
- nil nil
- t `(cdr ,temp))
- (list (car name)
- (maybe-cdr type)
- t `(cdr ,temp)
- nil nil))
- sub-lets)))
- ((car name)
- (process (car name)
- (maybe-car type)
- initial-p `(car ,initial)
- stepper-p `(car ,stepper)))
- ((cdr name)
- (process (cdr name)
- (maybe-cdr type)
- initial-p `(cdr ,initial)
- stepper-p `(cdr ,stepper))))))
- (process (first var) (second var) (third var)
- (fourth var) (fifth var) (sixth var))))
- (when steppers
- (push (cons 'psetq steppers)
- *iteration-forms*))
- (multiple-value-bind
- (sub-outside sub-inside)
- (build-let-expression sub-lets)
- (values (build-bindings outside sub-outside)
- (build-bindings inside sub-inside))))))
-
-(defun build-bindings (vars guts)
- (if (null vars)
- guts
- `(let ,(mapcar #'cdr vars)
- (declare ,@(mapcar #'build-declare vars))
- ,guts)))
-
-(defun build-declare (var)
- `(type ,(car var) ,(cadr var)))
-
-
-
-;;;; LOOP itself.
-
-(defmacro loop (&rest stuff)
- "General iteration facility. See the manual for details, 'cause it's
- very confusing."
- (if (some #'atom stuff)
- (parse-loop stuff)
- (let ((repeat (gensym "REPEAT-"))
- (out-of-here (gensym "OUT-OF-HERE-")))
- `(block nil
- (tagbody
- ,repeat
- (macrolet ((loop-finish () `(go ,out-of-here)))
- , at stuff)
- (go ,repeat)
- ,out-of-here)))))
-
-
-
-;;;; The parser.
-
-;;; Top level parser. Bind the specials, and call the other parsers.
-;;;
-(defun parse-loop (stuff)
- (let* ((*prologue* nil)
- (*outside-bindings* *magic-cookie*)
- (*inside-bindings* *magic-cookie*)
- (*body-forms* nil)
- (*iteration-forms* nil)
- (*epilogue* nil)
- (*result-var* nil)
- (*return-value* nil)
- (*default-return-value* nil)
- (*accumulation-variables* nil)
- (*remaining-stuff* stuff)
- (name (parse-named)))
- (loop
- (when (null *remaining-stuff*)
- (return))
- (let ((clause (pop *remaining-stuff*)))
- (cond ((not (symbolp clause))
- (error "Invalid clause, ~S, must be a symbol." clause))
- ((loop-keyword-p clause "INITIALLY")
- (setf *prologue* (nconc *prologue* (parse-expr-list))))
- ((loop-keyword-p clause "FINALLY")
- (parse-finally))
- ((loop-keyword-p clause "WITH")
- (parse-with))
- ((loop-keyword-p clause "FOR" "AS")
- (parse-for-as))
- ((loop-keyword-p clause "REPEAT")
- (parse-repeat))
- (t
- (push clause *remaining-stuff*)
- (return)))))
- (loop
- (when (null *remaining-stuff*)
- (return))
- (let ((clause (pop *remaining-stuff*)))
- (cond ((not (symbolp clause))
- (error "Invalid clause, ~S, must be a symbol." clause))
- ((loop-keyword-p clause "INITIALLY")
- (setf *prologue* (nconc *prologue* (parse-expr-list))))
- ((loop-keyword-p clause "FINALLY")
- (parse-finally))
- ((loop-keyword-p clause "WHILE")
- (setf *body-forms*
- (nconc *body-forms*
- `((unless ,(pop *remaining-stuff*)
- (loop-finish))))))
- ((loop-keyword-p clause "UNTIL")
- (setf *body-forms*
- (nconc *body-forms*
- `((when ,(pop *remaining-stuff*) (loop-finish))))))
- ((loop-keyword-p clause "ALWAYS")
- (setf *body-forms*
- (nconc *body-forms*
- `((unless ,(pop *remaining-stuff*)
- (return-from ,name nil)))))
- (setf *default-return-value* t))
- ((loop-keyword-p clause "NEVER")
- (setf *body-forms*
- (nconc *body-forms*
- `((when ,(pop *remaining-stuff*)
- (return-from ,name nil)))))
- (setf *default-return-value* t))
- ((loop-keyword-p clause "THEREIS")
- (setf *body-forms*
- (nconc *body-forms*
- (let ((temp (gensym "THEREIS-")))
- `((let ((,temp ,(pop *remaining-stuff*)))
- (when ,temp
- (return-from ,name ,temp))))))))
- (t
- (push clause *remaining-stuff*)
- (or (maybe-parse-unconditional)
- (maybe-parse-conditional)
- (maybe-parse-accumulation)
- (error "Unknown clause, ~S" clause))))))
- (let ((again-tag (gensym "AGAIN-"))
- (end-tag (gensym "THIS-IS-THE-END-")))
- `(block ,name
- ,(splice-in-subform
- *outside-bindings*
- `(macrolet ((loop-finish () '(go ,end-tag)))
- (tagbody
- ,@*prologue*
- ,again-tag
- ,(splice-in-subform
- *inside-bindings*
- `(progn
- ,@*body-forms*
- ,@(nreverse *iteration-forms*)))
- (go ,again-tag)
- ,end-tag
- ,@*epilogue*
- (return-from ,name
- ,(or *return-value*
- *default-return-value*
- *result-var*)))))))))
-
-(defun parse-named ()
- (when (loop-keyword-p (car *remaining-stuff*) "NAMED")
- (pop *remaining-stuff*)
- (if (symbolp (car *remaining-stuff*))
- (pop *remaining-stuff*)
- (error "Loop name ~S is not a symbol." (car *remaining-stuff*)))))
-
-
-(defun parse-expr-list ()
- (let ((results nil))
- (loop
- (when (atom (car *remaining-stuff*))
- (return (nreverse results)))
- (push (pop *remaining-stuff*) results))))
-
-(defun parse-finally ()
- (let ((sub-clause (pop *remaining-stuff*)))
- (if (loop-keyword-p sub-clause "RETURN")
- (cond ((not (null *return-value*))
- (error "Cannot specify two FINALLY RETURN clauses."))
- ((null *remaining-stuff*)
- (error "FINALLY RETURN must be followed with an expression."))
- (t
- (setf *return-value* (pop *remaining-stuff*))))
- (progn
- (unless (loop-keyword-p sub-clause "DO" "DOING")
- (push sub-clause *remaining-stuff*))
- (setf *epilogue* (nconc *epilogue* (parse-expr-list)))))))
-
-(defun parse-with ()
- (let ((vars nil))
- (loop
- (multiple-value-bind (var type) (parse-var-and-type-spec)
- (let ((initial
- (if (loop-keyword-p (car *remaining-stuff*) "=")
- (progn
- (pop *remaining-stuff*)
- (pop *remaining-stuff*))
- (list 'quote
- (pick-default-value var type)))))
- (queue-var vars var type :initer initial)))
- (if (loop-keyword-p (car *remaining-stuff*) "AND")
- (pop *remaining-stuff*)
- (return)))
- (multiple-value-bind
- (outside inside)
- (build-let-expression vars)
- (setf *outside-bindings*
- (splice-in-subform *outside-bindings* outside))
- (setf *inside-bindings*
- (splice-in-subform *inside-bindings* inside)))))
-
-(defun parse-var-and-type-spec ()
- (values (pop *remaining-stuff*)
- (parse-type-spec t)))
-
-(defun parse-type-spec (default)
- (cond ((preposition-p "OF-TYPE")
- (pop *remaining-stuff*))
- ((and *remaining-stuff*
- (only-simple-types (car *remaining-stuff*)))
- (pop *remaining-stuff*))
- (t
- default)))
-
-
-
-;;;; FOR/AS stuff.
-
-;;; These specials hold the vars that need to be bound for this FOR/AS clause
-;;; and all of the FOR/AS clauses connected with AND. All the *for-as-vars*
-;;; are bound in parallel followed by the *for-as-sub-vars*.
-;;;
-(defvar *for-as-vars*)
-(defvar *for-as-sub-vars*)
-
-;;; These specials hold any extra termination tests. *for-as-term-tests* are
-;;; processed after the *for-as-vars* are bound, but before the
-;;; *for-as-sub-vars*. *for-as-sub-term-tests* are processed after the
-;;; *for-as-sub-vars*.
-
-(defvar *for-as-term-tests*)
-(defvar *for-as-sub-term-tests*)
-
-
-(defun parse-for-as ()
- (let ((*for-as-vars* nil)
- (*for-as-term-tests* nil)
- (*for-as-sub-vars* nil)
- (*for-as-sub-term-tests* nil))
- (loop
- (multiple-value-bind (name type) (parse-var-and-type-spec)
- (let ((sub-clause (pop *remaining-stuff*)))
- (cond ((loop-keyword-p sub-clause "FROM" "DOWNFROM" "UPFROM"
- "TO" "DOWNTO" "UPTO" "BELOW" "ABOVE")
- (parse-arithmetic-for-as sub-clause name type))
- ((loop-keyword-p sub-clause "IN")
- (parse-in-for-as name type))
- ((loop-keyword-p sub-clause "ON")
- (parse-on-for-as name type))
- ((loop-keyword-p sub-clause "=")
- (parse-equals-for-as name type))
- ((loop-keyword-p sub-clause "ACROSS")
- (parse-across-for-as name type))
- ((loop-keyword-p sub-clause "BEING")
- (parse-being-for-as name type))
- (t
- (error "Invalid FOR/AS subclause: ~S" sub-clause)))))
- (if (loop-keyword-p (car *remaining-stuff*) "AND")
- (pop *remaining-stuff*)
- (return)))
- (multiple-value-bind
- (outside inside)
- (build-let-expression *for-as-vars*)
- (multiple-value-bind
- (sub-outside sub-inside)
- (build-let-expression *for-as-sub-vars*)
- (setf *outside-bindings*
- (splice-in-subform *outside-bindings*
- (splice-in-subform outside sub-outside)))
- (let ((inside-body
- (if *for-as-term-tests*
- `(if (or ,@(nreverse *for-as-term-tests*))
- (loop-finish)
- ,*magic-cookie*)
- *magic-cookie*))
- (sub-inside-body
- (if *for-as-sub-term-tests*
- `(if (or ,@(nreverse *for-as-sub-term-tests*))
- (loop-finish)
- ,*magic-cookie*)
- *magic-cookie*)))
- (setf *inside-bindings*
- (splice-in-subform
- *inside-bindings*
- (splice-in-subform
- inside
- (splice-in-subform
- inside-body
- (splice-in-subform
- sub-inside
- sub-inside-body))))))))))
-
-(defun parse-arithmetic-for-as (sub-clause name type)
- (unless (atom name)
- (error "Cannot destructure arithmetic FOR/AS variables: ~S" name))
- (let (start stop (inc 1) dir exclusive-p)
- (cond ((loop-keyword-p sub-clause "FROM")
- (setf start (pop *remaining-stuff*)))
- ((loop-keyword-p sub-clause "DOWNFROM")
- (setf start (pop *remaining-stuff*))
- (setf dir :down))
- ((loop-keyword-p sub-clause "UPFROM")
- (setf start (pop *remaining-stuff*))
- (setf dir :up))
- (t
- (push sub-clause *remaining-stuff*)))
- (cond ((preposition-p "TO")
- (setf stop (pop *remaining-stuff*)))
- ((preposition-p "DOWNTO")
- (setf stop (pop *remaining-stuff*))
- (if (eq dir :up)
- (error "Can't mix UPFROM and DOWNTO in ~S." name)
- (setf dir :down)))
- ((preposition-p "UPTO")
- (setf stop (pop *remaining-stuff*))
- (if (eq dir :down)
- (error "Can't mix DOWNFROM and UPTO in ~S." name)
- (setf dir :up)))
- ((preposition-p "ABOVE")
- (setf stop (pop *remaining-stuff*))
- (setf exclusive-p t)
- (if (eq dir :up)
- (error "Can't mix UPFROM and ABOVE in ~S." name)
- (setf dir :down)))
- ((preposition-p "BELOW")
- (setf stop (pop *remaining-stuff*))
- (setf exclusive-p t)
- (if (eq dir :down)
- (error "Can't mix DOWNFROM and BELOW in ~S." name)
- (setf dir :up))))
- (when (preposition-p "BY")
- (setf inc (pop *remaining-stuff*)))
- (when (and (eq dir :down) (null start))
- (error "No default starting value for decremental stepping."))
- (let ((temp (gensym "TEMP-AMOUNT-")))
- (queue-var *for-as-sub-vars* temp type :initer inc)
- (queue-var *for-as-sub-vars* name type
- :initer (or start 0)
- :stepper `(,(if (eq dir :down) '- '+) ,name ,temp))
- (when stop
- (let ((stop-var (gensym "STOP-VAR-")))
- (queue-var *for-as-sub-vars* stop-var type :initer stop)
- (push (list (if (eq dir :down)
- (if exclusive-p '<= '<)
- (if exclusive-p '>= '>))
- name stop-var)
- *for-as-sub-term-tests*))))))
-
-(defun parse-in-for-as (name type)
- (let* ((temp (gensym "LIST-"))
- (initer (pop *remaining-stuff*))
- (stepper (if (preposition-p "BY")
- `(funcall ,(pop *remaining-stuff*) ,temp)
- `(cdr ,temp))))
- (queue-var *for-as-vars* temp 'list :initer initer :stepper stepper)
- (queue-var *for-as-sub-vars* name type :stepper `(car ,temp))
- (push `(null ,temp) *for-as-sub-term-tests*)))
-
-(defun parse-on-for-as (name type)
- (let* ((temp (if (atom name) name (gensym "LIST-")))
- (initer (pop *remaining-stuff*))
- (stepper (if (preposition-p "BY")
- `(funcall ,(pop *remaining-stuff*) ,temp)
- `(cdr ,temp))))
- (cond ((atom name)
- (queue-var *for-as-sub-vars* name type
- :initer initer :stepper stepper)
- (push `(endp ,name) *for-as-sub-term-tests*))
- (t
- (queue-var *for-as-vars* temp type
- :initer initer :stepper stepper)
- (queue-var *for-as-sub-vars* name type :stepper temp)
- (push `(endp ,temp) *for-as-term-tests*)))))
-
-(defun parse-equals-for-as (name type)
- (let ((initer (pop *remaining-stuff*)))
- (if (preposition-p "THEN")
- (queue-var *for-as-sub-vars* name type
- :initer initer :stepper (pop *remaining-stuff*))
- (queue-var *for-as-vars* name type :stepper initer))))
-
-(defun parse-across-for-as (name type)
- (let* ((temp (gensym "VECTOR-"))
- (length (gensym "LENGTH-"))
- (index (gensym "INDEX-")))
- (queue-var *for-as-vars* temp `(vector ,type)
- :initer (pop *remaining-stuff*))
- (queue-var *for-as-sub-vars* length 'fixnum
- :initer `(length ,temp))
- (queue-var *for-as-vars* index 'fixnum :initer 0 :stepper `(1+ ,index))
- (queue-var *for-as-sub-vars* name type :stepper `(aref ,temp ,index))
- (push `(>= ,index ,length) *for-as-term-tests*)))
-
-(defun parse-being-for-as (name type)
- (let ((clause (pop *remaining-stuff*)))
- (unless (loop-keyword-p clause "EACH" "THE")
- (error "BEING must be followed by either EACH or THE, not ~S"
- clause)))
- (let ((clause (pop *remaining-stuff*)))
- (cond ((loop-keyword-p clause "HASH-KEY" "HASH-KEYS"
- "HASH-VALUE" "HASH-VALUES")
- (let ((prep (pop *remaining-stuff*)))
- (unless (loop-keyword-p prep "IN" "OF")
- (error "~A must be followed by either IN or OF, not ~S"
- (symbol-name clause) prep)))
- (let ((table (pop *remaining-stuff*))
- (iterator (gensym (format nil "~A-ITERATOR-" name)))
- (exists-temp (gensym (format nil "~A-EXISTS-TEMP-" name)))
- (key-temp (gensym (format nil "~A-KEY-TEMP-" name)))
- (value-temp (gensym (format nil "~A-VALUE-TEMP-" name))))
- (setf *outside-bindings*
- (splice-in-subform
- *outside-bindings*
- `(with-hash-table-iterator (,iterator ,table)
- ,*magic-cookie*)))
- (multiple-value-bind
- (using using-type)
- (when (preposition-p "USING")
- ;; ### This is wrong.
- (parse-var-and-type-spec))
- (multiple-value-bind
- (key-var key-type value-var value-type)
- (if (loop-keyword-p clause "HASH-KEY" "HASH-KEYS")
- (values name type using using-type)
- (values using using-type name type))
- (setf *inside-bindings*
- (splice-in-subform
- *inside-bindings*
- `(multiple-value-bind
- (,exists-temp ,key-temp ,value-temp)
- (,iterator)
- ,@(unless (and key-var value-var)
- `((declare (ignore ,@(if (null key-var)
- (list key-temp))
- ,@(if (null value-var)
- (list value-temp))))))
- ,*magic-cookie*)))
- (push `(not ,exists-temp) *for-as-term-tests*)
- (when key-var
- (queue-var *for-as-sub-vars* key-var key-type
- :stepper key-temp))
- (when value-var
- (queue-var *for-as-sub-vars* value-var value-type
- :stepper value-temp))))))
- ((loop-keyword-p clause "SYMBOL" "PRESENT-SYMBOL" "EXTERNAL-SYMBOL"
- "SYMBOLS" "PRESENT-SYMBOLS" "EXTERNAL-SYMBOLS")
- (let ((package
- (if (or (preposition-p "IN")
- (preposition-p "OF"))
- (pop *remaining-stuff*)
- '*package*))
- (iterator (gensym (format nil "~A-ITERATOR-" name)))
- (exists-temp (gensym (format nil "~A-EXISTS-TEMP-" name)))
- (symbol-temp (gensym (format nil "~A-SYMBOL-TEMP-" name))))
- (setf *outside-bindings*
- (splice-in-subform
- *outside-bindings*
- `(with-package-iterator
- (,iterator
- ,package
- ,@(cond ((loop-keyword-p clause "SYMBOL" "SYMBOLS")
- '(:internal :external :inherited))
- ((loop-keyword-p clause "PRESENT-SYMBOL"
- "PRESENT-SYMBOLS")
- '(:internal))
- ((loop-keyword-p clause "EXTERNAL-SYMBOL"
- "EXTERNAL-SYMBOLS")
- '(:external))
- (t
- (error "Don't know how to deal with ~A? ~
- Bug in LOOP?" clause))))
- ,*magic-cookie*)))
- (setf *inside-bindings*
- (splice-in-subform
- *inside-bindings*
- `(multiple-value-bind
- (,exists-temp ,symbol-temp)
- (,iterator)
- ,*magic-cookie*)))
- (push `(not ,exists-temp) *for-as-term-tests*)
- (queue-var *for-as-sub-vars* name type :stepper symbol-temp)))
- (t
- (error
- "Unknown sub-clause, ~A, for BEING. Must be one of:~% ~
- HASH-KEY HASH-KEYS HASH-VALUE HASH-VALUES SYMBOL SYMBOLS~% ~
- PRESENT-SYMBOL PRESENT-SYMBOLS EXTERNAL-SYMBOL EXTERNAL-SYMBOLS"
- (symbol-name clause))))))
-
-
-
-;;;;
-
-(defun parse-repeat ()
- (let ((temp (gensym "REPEAT-")))
- (setf *outside-bindings*
- (splice-in-subform *outside-bindings*
- `(let ((,temp ,(pop *remaining-stuff*)))
- ,*magic-cookie*)))
- (setf *inside-bindings*
- (splice-in-subform *inside-bindings*
- `(if (minusp (decf ,temp))
- (loop-finish)
- ,*magic-cookie*)))))
-
-
-(defun maybe-parse-unconditional ()
- (cond ((loop-keyword-p (car *remaining-stuff*) "DO" "DOING")
- (pop *remaining-stuff*)
- (setf *body-forms* (nconc *body-forms* (parse-expr-list)))
- t)
- ((loop-keyword-p (car *remaining-stuff*) "RETURN")
- (pop *remaining-stuff*)
- (setf *body-forms*
- (nconc *body-forms* `((return ,(pop *remaining-stuff*)))))
- t)))
-
-
-(defun maybe-parse-conditional ()
- (let ((clause (pop *remaining-stuff*)))
- (cond ((loop-keyword-p clause "IF" "WHEN")
- (parse-conditional (pop *remaining-stuff*))
- t)
- ((loop-keyword-p clause "UNLESS")
- (parse-conditional `(not ,(pop *remaining-stuff*)))
- t)
- (t
- (push clause *remaining-stuff*)
- nil))))
-
-(defun parse-conditional (condition)
- (let ((clauses (parse-and-clauses))
- (else-clauses (when (preposition-p "ELSE")
- (parse-and-clauses))))
- (setf *body-forms*
- (nconc *body-forms*
- `((if ,condition
- (progn
- , at clauses)
- (progn
- , at else-clauses)))))
- (preposition-p "END")))
-
-(defun parse-and-clauses ()
- (let ((*body-forms* nil))
- (loop
- (or (maybe-parse-unconditional)
- (maybe-parse-conditional)
- (maybe-parse-accumulation)
- (error "Invalid clause for inside a conditional: ~S"
- (car *remaining-stuff*)))
- (unless (preposition-p "AND")
- (return *body-forms*)))))
-
-
-;;;; Assumulation stuff
-
-(defun maybe-parse-accumulation ()
- (when (loop-keyword-p (car *remaining-stuff*)
- "COLLECT" "COLLECTING"
- "APPEND" "APPENDING" "NCONC" "NCONCING"
- "COUNT" "COUNTING" "SUM" "SUMMING"
- "MAXIMIZE" "MAXIMIZING" "MINIMIZE" "MINIMIZING")
- (parse-accumulation)
- t))
-
-(defun parse-accumulation ()
- (let* ((clause (pop *remaining-stuff*))
- (expr (pop *remaining-stuff*))
- (var (if (preposition-p "INTO")
- (pop *remaining-stuff*)
- (or *result-var*
- (setf *result-var*
- (gensym (concatenate 'simple-string
- (string clause)
- "-"))))))
- (info (assoc var *accumulation-variables*))
- (type nil)
- (initial nil))
- (cond ((loop-keyword-p clause "COLLECT" "COLLECTING" "APPEND" "APPENDING"
- "NCONC" "NCONCING")
- (setf initial nil)
- (setf type 'list)
- (let ((aux-var
- (or (caddr info)
- (let ((aux-var (gensym "LAST-")))
- (setf *outside-bindings*
- (splice-in-subform *outside-bindings*
- `(let ((,var nil)
- (,aux-var nil))
- (declare (type list
- ,var
- ,aux-var))
- ,*magic-cookie*)))
- (if (null info)
- (push (setf info (list var 'list aux-var))
- *accumulation-variables*)
- (setf (cddr info) (list aux-var)))
- aux-var)))
- (value
- (cond ((loop-keyword-p clause "COLLECT" "COLLECTING")
- `(list ,expr))
- ((loop-keyword-p clause "APPEND" "APPENDING")
- `(copy-list ,expr))
- ((loop-keyword-p clause "NCONC" "NCONCING")
- expr)
- (t
- (error "Bug in loop?")))))
- (setf *body-forms*
- (nconc *body-forms*
- `((cond ((null ,var)
- (setf ,var ,value)
- (setf ,aux-var (last ,var)))
- (t
- (nconc ,aux-var ,value)
- (setf ,aux-var (last ,aux-var)))))))))
- ((loop-keyword-p clause "COUNT" "COUNTING")
- (setf type (parse-type-spec 'unsigned-byte))
- (setf initial 0)
- (setf *body-forms*
- (nconc *body-forms*
- `((when ,expr (incf ,var))))))
- ((loop-keyword-p clause "SUM" "SUMMING")
- (setf type (parse-type-spec 'number))
- (setf initial 0)
- (setf *body-forms*
- (nconc *body-forms*
- `((incf ,var ,expr)))))
- ((loop-keyword-p clause "MAXIMIZE" "MAXIMIZING")
- (setf type `(or null ,(parse-type-spec 'number)))
- (setf initial nil)
- (setf *body-forms*
- (nconc *body-forms*
- (let ((temp (gensym "MAX-TEMP-")))
- `((let ((,temp ,expr))
- (when (or (null ,var)
- (> ,temp ,var))
- (setf ,var ,temp))))))))
- ((loop-keyword-p clause "MINIMIZE" "MINIMIZING")
- (setf type `(or null ,(parse-type-spec 'number)))
- (setf initial nil)
- (setf *body-forms*
- (nconc *body-forms*
- (let ((temp (gensym "MIN-TEMP-")))
- `((let ((,temp ,expr))
- (when (or (null ,var)
- (< ,temp ,var))
- (setf ,var ,temp))))))))
- (t
- (error "Invalid accumulation clause: ~S" clause)))
- (cond (info
- (unless (equal type (cadr info))
- (error "Attempt to use ~S for both types ~S and ~S."
- var type (cadr info))))
- (t
- (push (list var type) *accumulation-variables*)
- (setf *outside-bindings*
- (splice-in-subform *outside-bindings*
- `(let ((,var ,initial))
- (declare (type ,type ,var))
- ,*magic-cookie*)))))))
commit d5fb9d56c6a9d977325334a78f69b6fb40929d0c
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Sun Nov 2 08:44:35 2014 -0800
Remove the LOOP package. There are no symbols in it anyway.
Apparently this is from old-loop.lisp, which isn't used anymore.
diff --git a/src/code/exports.lisp b/src/code/exports.lisp
index d3c8fa7..455894c 100644
--- a/src/code/exports.lisp
+++ b/src/code/exports.lisp
@@ -94,9 +94,6 @@
(if (find-package "EXTENSIONS")
(rename-package "EXTENSIONS" "EXTENSIONS" '("EXT"))
(make-package "EXTENSIONS" :nicknames '("EXT") :use nil))
-(if (find-package "LOOP")
- (rename-package "LOOP" "LOOP" 'nil)
- (make-package "LOOP" :nicknames 'nil :use nil))
(if (find-package "DEBUG-INTERNALS")
(rename-package "DEBUG-INTERNALS" "DEBUG-INTERNALS" '("DI"))
(make-package "DEBUG-INTERNALS" :nicknames '("DI") :use nil))
@@ -151,7 +148,6 @@
(use-package '("LISP") "DISASSEM")
(use-package '("EXTENSIONS" "LISP" "SYSTEM") "DEBUG")
(use-package '("C-CALL" "ALIEN" "COMMON-LISP" "SYSTEM") "EXTENSIONS")
-(use-package '("LISP") "LOOP")
(use-package '("LISP" "SYSTEM" "EXTENSIONS" "KERNEL") "DEBUG-INTERNALS")
(use-package
'("ALIEN-INTERNALS" "ALIEN" "COMMON-LISP" "EXTENSIONS" "KERNEL"
@@ -1608,7 +1604,6 @@
"LIST-ALL-EXTERNAL-FORMATS"
"DESCRIBE-EXTERNAL-FORMAT"))
-(defpackage "LOOP")
(dolist
(name
'("DEBUG-SOURCE" "DEBUG-SOURCE-COMPILED" "DEBUG-SOURCE-CREATED"
-----------------------------------------------------------------------
Summary of changes:
src/code/exports.lisp | 5 -
src/code/old-loop.lisp | 828 ---------------------------------------
src/general-info/release-21a.txt | 1 +
3 files changed, 1 insertion(+), 833 deletions(-)
delete mode 100644 src/code/old-loop.lisp
hooks/post-receive
--
CMU Common Lisp
More information about the cmucl-cvs
mailing list