summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Andreas Benkard <matthias@benkard.de>2008-08-03 13:26:22 +0200
committerMatthias Andreas Benkard <matthias@benkard.de>2008-08-03 13:26:22 +0200
commit7c9daef5037fef49b3bd522cd4a78cdeda0c2055 (patch)
tree37c46e241b608a7ee8fa725df09864742e43e1a6
parentbf7021f60ed3bdc3f1a3f281fa57a1566141a67d (diff)
Add EQL, DO, DO*, DOTIMES, and DOLIST from Sacla.
-rw-r--r--Sacla/core.lisp636
-rw-r--r--Sacla/do.lisp7
-rw-r--r--Sacla/share.lisp6
-rw-r--r--init.lisp6
4 files changed, 20 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* "")
diff --git a/init.lisp b/init.lisp
index cb527fc..34aa545 100644
--- a/init.lisp
+++ b/init.lisp
@@ -28,10 +28,16 @@
(load "sharpsign.lisp")
(load "control-flow.lisp")
(load "types.lisp")
+(load "numbers.lisp")
(load "list-functions-2.lisp")
+(load "Sacla/share.lisp")
+(load "Sacla/do.lisp")
+
(load "evaluation.lisp")
+(load "Sacla/share-2.lisp")
+
(setq *system-initialised-p* t)
(in-package #:common-lisp-user)