Add EQL, DO, DO*, DOTIMES, and DOLIST from Sacla.

3 files changed, 14 insertions, 635 deletions

diff --git a/Sacla/core.lisp b/Sacla/core.lisp
index 509f0ab..71b68bd 100644
--- a/Sacla/core.lisp
+++ b/Sacla/core.lisp
@@ -26,171 +26,27 @@
 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
-;;; primitives
-;;(defun alloc-pointers (n)
-;;  (alloc-pointers n))
-
-
 ;;; objects
-
-;; cons
-(defstruct (cons (:constructor cons (car cdr))
-                 (:conc-name "") (:predicate consp) (:copier nil))
-  (car)
-  (cdr)
-  )
-
-(defun rplaca (cons object)
-  "Replace the car of CONS with OBJECT."
-  (setf (car cons) object)
-  cons)
-
-(defun rplacd (cons object)
-  "Replace the cdr of CONS with OBJECT."
-  (setf (cdr cons) object)
-  cons)
-
-
-;; symbol
-(defstruct (symbol (:constructor make-symbol (name)) (:predicate symbolp) (:copier nil))
-  (name "" (:type string))
-  (%value 'unbound)
-  (function nil)
-  (package nil)
-  (plist nil (:type list))
-  )
-
-(defconstant unbound
-  'nil
-  "Represent variable's unbound state as a symbol itself.")
-
-(defconstant nil
-  'nil
-  "Represent both boolean (and generalized boolean) false and the empty list.")
-
-(defconstant t
-  't
-  "The boolean representing true, and the canonical generalized boolean representing true.")
-
-(defun boundp (symbol)
-  (not (eq (symbol-%value symbol) 'unbound)))
-
-(defun makunbound (symbol)
-  (setf (symbol-%value symbol) 'unbound))
-
-(defun symbol-value (symbol)
-  (if (boundp symbol)
-      (symbol-%value symbol)
-      (error 'unbound-variable :name symbol)))
-
-(defsetf symbol-value (symbol) (new-value)
-  (setf (symbol-%value symbol) new-value))
-
-(defun set (symbol value)
-  (setf (symbol-value symbol) value))
-
-(defvar *gensym-counter* 0)
-(defun gensym (&optional (x "G"))
-  (gensym x))
-
-
 ;; function
-(defstruct (function (:predicate functionp))
-  (lambda-expression)
-  )
-;; functionp,,, are defined here
-
 (defun fdefinition (function-name)
   (etypecase function-name
     (symbol (symbol-function function-name))
     (setf-function-name )))
 
-(defsetf fdefinition (function-name) (new-function)
-  )
-
-(defun fboundp (name)
-  )
-
-(defun fmakunbound (name)
-  )
-
-(defun function-lambda-expression (function)
-  )
-
-(defun compiled-function-p (object)
-  )
-
-(defmacro function (name)
-  )
-
-
-
-;;; special operators
-(defmacro quote (object)
-  )
-
-(defmacro eval-when (situations &body body)
-  )
-
-(defmacro if (test-form then-form &optional else-form)
-  )
-
-(defmacro load-time-value (form &optional read-only-p)
-  )
-
-(defmacro locally (&rest declarations-and-forms)
-  )
-
-(defmacro symbol-macrolet ((symbol-expansions) &body body)
-  )
-
-(defmacro the (value-type form)
-  )
+;; (defsetf fdefinition (function-name) (new-function)
+;;   ;;FIXME
+;;   )
 
 
 ;; data and control flow
-(defun apply (function arg &rest more-args)
-  )
-
-(defmacro defun (function-name lambda-list &body body)
-  )
-
-(defmacro flet (functions &body body)
-  )
-
-(defmacro labels (functions &body body)
-  )
-
-(defmacro macrolet (macros &body body)
-  )
-
-(defun funcall (function &rest args)
-  (when (and (symbolp function)
-	     (or (not (fboundp function))
-		 (do ((x '(block catch eval-when flet function go if labels let
-		           let* load-time-value locally macrolet
-			   multiple-value-call multiple-value-prog1 progn progv
-			   quote return-from setq symbol-macrolet tagbody the
-			   throw unwind-protect)
-			 (cdr x)))
-		     ((null x) nil)
-		   (when (eq function (car x))
-		     (return t)))
-		 (macro-function function)))
-    (error 'undefined-function :name function))
-  (apply function args))
-
 (defconstant call-arguments-limit
-  50
-  "An integer not smaller than 50 and at least as great as the value of lambda-parameters-limit, the exact magnitude of which is implementation-dependent.")
+  50)
 
 (defconstant lambda-parameters-limit
-  50
-  "A positive integer that is the upper exclusive bound on the number of parameter names that can appear in a single lambda list.")
+  50)
 
 (defconstant lambda-list-keywords
-  '(&allow-other-keys &aux &body &environment &key &optional &rest &whole)
-  "a list, the elements of which are implementation-dependent, but which must contain at least the symbols &allow-other-keys, &aux, &body, &environment, &key, &optional, &rest, and &whole.")
+  '(&allow-other-keys &aux &body &environment &key &optional &rest &whole))
 
 (defmacro defparameter (name initial-value 
 			&optional (documentation nil documentation-p))
@@ -211,49 +67,6 @@
 	   `(setf (documentation ',name 'variable) ',documentation))
     ',name))
 
-
-(defmacro defconstant (name initial-value &optional documentation)
-  )
-
-(defmacro destructuring-bind (lambda-list expression &body body)
-  )
-
-(defmacro let (vars &body body)
-  )
-
-(defmacro let* (vars &body body)
-  )
-
-(defmacro progv (symbols values &body body)
-  )
-
-(defmacro setq (&rest pairs)
-  )
-
-(defmacro block (name &body body)
-  )
-
-(defmacro catch (tag &body body)
-  )
-
-(defmacro go (tag)
-  )
-
-(defmacro return-from (name &optional result)
-  )
-
-(defmacro tagbody (&body body)
-  )
-
-(defmacro throw (tag result-form)
-  )
-
-(defmacro unwind-protect (protected-form &rest cleanup-forms)
-  )
-
-(defun eq (x y)
-  )
-
 (defun eql (x y)
   (or (eq x y)
       (and (numberp x) (numberp y) (= x y) (eq (type-of x) (type-of y)))
@@ -287,440 +100,3 @@
 				     (eq (class-of x) (class-of y))
 				     ))
    (t nil)))
-
-
-(defun values (&rest object)
-  )
-
-(defmacro multiple-value-call (function-form &body body)
-  )
-
-(defmacro multiple-value-prog1 (first-form &rest forms)
-  )
-
-(defconstant multiple-values-limit most-positive-fixnum "")
-
-(defmacro progn (&rest forms)
-  )
-
-(defmacro define-modify-macro (name lambda-list function &optional documentation)
-  )
-
-(defmacro defsetf (access-fn &rest rest)
-  )
-
-(defmacro define-setf-expander (access-fn lambda-list &body body)
-  )
-
-(defun get-setf-expansion (place &optional environment)
-  )
-
-
-;; eval
-(defun compile (name &optional definition)
-  (compile name definition))
-
-(defun eval (form)
-  )
-
-(defun compiler-macro-function (name &optional environment)
-  )
-
-(defsetf compiler-macro-function (name &optional environment) (new-function)
-  )
-
-(defmacro define-compiler-macro (name lambda-list &body body)
-  )
-
-(defmacro defmacro (name lambda-list &body body)
-  )
-
-(defun macro-function (symbol &optional environment)
-  )
-
-(defsetf macro-function (symbol &optional environment) (new-function)
-  )
-
-(defun macroexpand-1 (form &optional env)
-  )
-
-(defmacro define-symbol-macro (symbol expansion)
-  )
-
-(defvar *macroexpand-hook* #'funcall
-  "")
-
-(defun proclaim (declaration-specifier)
-  )
-
-(defmacro declaim (&rest declaration-specifiers)
-  )
-
-(defun constantp (form &optional environment)
-  )
-
-
-;; array
-(defun arrayp (object)
-  (arrayp object))
-
-(defun make-array (dimensions &key (element-type t)
-			      initial-element initial-contents adjustable
-			      fill-pointer displaced-to displaced-index-offset)
-  )
-
-(defun adjust-array (array new-dimensions &key
-			   (element-type (array-element-type array))
-			   initial-element initial-contents
-			   fill-pointer displaced-to displaced-index-offset)
-  )
-
-
-(defun adjustable-array-p (array)
-  (adjustable-array-p array))
-
-(defun array-dimensions (array)
-  (array-dimensions array))
-
-(defun array-element-type (array)
-  (array-element-type array))
-
-(defun array-has-fill-pointer-p (array)
-  (array-has-fill-pointer-p array))
-
-(defun array-displacement (array)
-  (array-displacement array))
-
-(defun fill-pointer (vector)
-  (fill-pointer vector))
-
-(defsetf fill-pointer (vector) (value)
-  `(setf (fill-pointer ,vector) ,value))
-
-(defun row-major-aref (array index)
-  (row-major-aref array index))
-
-(defsetf row-major-aref (array index) (value)
-  `(setf (row-major-aref ,array ,index) ,value))
-
-(defun upgraded-array-element-type (typespec &optional environment)
-  (upgraded-array-element-type typespec environment))
-
-(defconst array-dimension-limit 1024
-  "")
-
-(defconst array-rank-limit 8
-  "")
-
-(defconst array-total-size-limit 1024
-  "")
-
-(defun simple-vector-p (object)
-  ""
-  (simple-vector-p object))
-
-(defun svref (simple-vector index)
-  ""
-  (svref simple-vector index))
-
-(defsetf svref (simple-vector index) (value)
-  `(setf (svref ,simple-vector ,index) ,value))
-
-(defun bit (bit-array &rest subscripts)
-  (apply #'bit bit-array subscripts))
-
-(defsetf bit (bit-array &rest subscripts) (value)
-  `(setf (apply #'bit ,bit-array ,subscripts) ,value))
-
-(defun sbit (bit-array &rest subscripts)
-  (apply #'sbit bit-array subscripts))
-
-(defsetf sbit (bit-array &rest subscripts) (value)
-  `(setf (apply #'sbit ,bit-array ,subscripts) ,value))
-
-
-(defun bit-and (bit-array1 bit-array2 &optional opt-arg)
-  (bit-and bit-array1 bit-array2 opt-arg))
-
-(defun bit-ior (bit-array1 bit-array2 &optional opt-arg)
-  (bit-ior bit-array1 bit-array2 opt-arg))
-
-(defun bit-xor (bit-array1 bit-array2 &optional opt-arg)
-  (bit-xor bit-array1 bit-array2 opt-arg))
-
-(defun bit-not (bit-array &optional opt-arg)
-  (bit-not bit-array opt-arg))
-
-
-;; string
-(defun char (string index)
-  (char string index))
-
-(defsetf char (string index) (value)
-  `(setf (char ,string ,index) ,value))
-
-(defun schar (string index)
-  (schar string index))
-
-(defsetf schar (string index) (value)
-  `(setf (schar ,string ,index) ,value))
-
-
-;; character
-(defconst char-code-limit 256
-  "")
-
-(defun char= (character &rest more-characters)
-  (apply #'char= character more-characters))
-
-(defun char< (character &rest more-characters)
-  (apply #'char< character more-characters))
-
-(defun characterp (object)
-  (characterp object))
-
-(defun alpha-char-p (character)
-  (alpha-char-p character))
-
-(defun alphanumericp (character)
-  (alphanumericp character))
-
-(defun graphic-char-p (character)
-  (graphic-char-p character))
-
-(defun char-upcase (character)
-  (char-upcase character))
-
-(defun char-downcase (character)
-  (char-downcase character))
-
-(defun upper-case-p (character)
-  (upper-case-p character))
-
-(defun lower-case-p (character)
-  (lower-case-p character))
-
-(defun both-case-p (character)
-  (both-case-p character))
-
-(defun char-code (character)
-  (char-code character))
-
-(defun char-int (character)
-  (char-int character))
-
-(defun char-name (character)
-  (char-name character))
-
-(defun name-char (name)
-  (name-char name))
-
-
-;; sequence
-(defun make-sequence (result-type size &key initial-element)
-  "Return a sequence of the type RESULT-TYPE and of length SIZE."
-  )
-
-
-;; hash-table
-
-;; (defun hash-table-p (object)
-;;   )
-;; 
-;; (defun make-hash-table (&key test size rehash-size rehash-threshold)
-;;   )
-
-;; (defun hash-table-count (hash-table)
-;;   )
-;; 
-;; (defun hash-table-size (hash-table)
-;;   )
-;; 
-;; (defun hash-table-rehash-size (hash-table)
-;;   )
-;; 
-;; (defun hash-table-rehash-threshold (hash-table)
-;;   )
-;; 
-;; (defun hash-table-test (hash-table)
-;;   )
-
-;; (defun gethash (key hash-table &optional default)
-;;   )
-;; 
-;; (defsetf gethash (key hash-table &optional default) (value)
-;;   `(setf (gethash ,key ,hash-table ,default) ,value))
-
-;; (defun remhash (key hash-table)
-;;   )
-
-;; (defmacro with-hash-table-iterator ((name hash-table) &body body)
-;;   )
-
-;; (defun clrhash (hash-table)
-;;   )
-
-(defun sxhash (object)
-  (rem (equal-hash) most-positive-fixnum))
-
-
-;; stream
-(defun streamp (object)
-  )
-
-(defun input-stream-p (stream)
-  )
-
-(defun output-stream-p (stream)
-  )
-
-(defun interactive-stream-p (stream)
-  )
-
-(defun open-stream-p (stream)
-  )
-
-(defun stream-element-type (stream)
-  )
-
-(defun read-byte (stream &optional eof-error-p eof-value)
-  )
-
-(defun write-byte (byte stream)
-  )
-
-(defun peek-char (&optional peek-type input-stream eof-error-p eof-value
-			    recursive-p)
-  )
-
-(defun read-char (&optional input-stream eof-error-p eof-value recursive-p)
-  )
-
-(defun read-char-no-hang (&optional input-stream eof-error-p eof-value
-				    recursive-p)
-  )
-
-(defun unread-char (character &optional input-stream)
-  )
-
-(defun write-char (character &optional output-stream)
-  )
-
-(defun fresh-line (&optional output-stream)
-  )
-
-(defun file-length (stream)
-  )
-
-(defun file-position (stream &optional position)
-  )
-
-(defun file-string-length (stream object)
-  )
-
-(defun open (filespec &key direction element-type
-		      if-exists if-does-not-exist external-format)
-  )
-
-(defun stream-external-format (stream)
-  )
-
-(defun close (stream &key abort)
-  )
-
-(defun listen (&optional input-stream)
-  )
-
-(defun clear-input (&optional input-stream)
-  )
-
-(defun finish-output (&optional output-stream)
-  )
-
-(defun force-output (&optional output-stream)
-  )
-
-(defun clear-output (&optional output-stream)
-  )
-
-(defun y-or-n-p (&optional control &rest arguments)
-  )
-
-(defun yes-or-no-p (&optional control &rest arguments)
-  )
-
-(defun make-synonym-stream (symbol)
-  )
-
-(defun synonym-stream-symbol (synonym-stream)
-  )
-
-(defun make-broadcast-stream (&rest streams)
-  )
-
-(defun broadcast-stream-streams (broadcast-stream)
-  )
-
-(defun make-two-way-stream (input-stream output-stream)
-  )
-
-(defun two-way-stream-input-stream (two-way-stream)
-  )
-
-(defun two-way-stream-output-stream (two-way-stream)
-  )
-
-(defun make-echo-stream (input-stream output-stream)
-  )
-
-(defun echo-stream-input-stream (echo-stream)
-  )
-
-(defun echo-stream-output-stream (echo-stream)
-  )
-
-(defun make-concatenated-stream (&rest input-streams)
-  )
-
-(defun concatenated-stream-streams (concatenated-stream)
-  )
-
-
-(defun make-string-input-stream (string &optional start end)
-  )
-
-(defun make-string-output-stream (&key element-type)
-  )
-
-(defun get-output-stream-string (string-output-stream)
-  )
-
-
-(defun stream-error-stream (condition)
-  )
-
-(defvar *DEBUG-IO*)
-(defvar *ERROR-OUTPUT*)
-(defvar *QUERY-IO*)
-(defvar *STANDARD-INPUT*)
-(defvar *STANDARD-OUTPUT*)
-(defvar *TRACE-OUTPUT*)
-(defvar *TERMINAL-IO*)
-
-(defmacro with-input-from-string ((var string &key index (start 0) end)
-				  &body body)
-  (multiple-value-bind (decls forms) (declarations-and-forms body)
-    `(let ((,var (make-string-input-stream ,string ,start ,end)))
-       ,@decls
-       (unwind-protect
-	   (progn ,@forms)
-	 (close ,var)
-	 ,@(when index
-	     `((setf ,index (string-input-stream-current-position ,var))))))))
-
-
-(defmacro with-output-to-string ((var &optional string-form &key element-type)
-				 &body body))
-
-
-;;; package
diff --git a/Sacla/do.lisp b/Sacla/do.lisp
index 6b7d3fd..77afbf7 100644
--- a/Sacla/do.lisp
+++ b/Sacla/do.lisp
@@ -35,7 +35,9 @@
 	(setq-operator (if parallel-p 'psetq 'setq)))
     (multiple-value-bind (declarations forms) (declarations-and-forms body)
       `(block nil
-	(,let-operator (,@(mapcar #'(lambda (x) (if (atom x) x (subseq x 0 2)))
+	(,let-operator (,@(mapcar #'(lambda (x) (if (atom x)
+                                                    x
+                                                    (list (first x) (second x))))
 				  var-init-step-list))
 	 ,@declarations
 	 (tagbody
@@ -43,7 +45,8 @@
 	    (when ,test-form (return (progn ,@result-forms)))
 	    ,@forms
 	    (,setq-operator ,@(mapcan #'(lambda (x)
-					  (when (and (consp x) (= (length x) 3))
+					  (when (and (consp x)
+                                                     (= (length x) 3))
 					    `(,(first x) ,(third x))))
 				      var-init-step-list))
 	    (go ,top)))))))
diff --git a/Sacla/share.lisp b/Sacla/share.lisp
index b054699..6fa3af8 100644
--- a/Sacla/share.lisp
+++ b/Sacla/share.lisp
@@ -156,10 +156,10 @@
 (defun mapappend (function &rest lists)
   (apply #'append (apply #'mapcar function lists)))
 
-(define-condition simple-program-error (simple-condition program-error) ())
+;; (define-condition simple-program-error (simple-condition program-error) ())
 
-(define-modify-macro appendf (&rest args)
-   append "Append onto list")
+;; (define-modify-macro appendf (&rest args)
+;;    append "Append onto list")
 
 
 ;; (defvar *message-prefix* "")