Add Sacla to the repository.

1 files changed, 726 insertions, 0 deletions

diff --git a/Sacla/core.lisp b/Sacla/core.lisp
new file mode 100644
index 0000000..509f0ab
--- /dev/null
+++ b/Sacla/core.lisp
@@ -0,0 +1,726 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: core.lisp,v 1.30 2004/05/26 07:57:52 yuji Exp $
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;; 
+;;  * Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;  * Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in
+;;    the documentation and/or other materials provided with the
+;;    distribution.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (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)
+  )
+
+
+;; 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.")
+
+(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.")
+
+(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.")
+
+(defmacro defparameter (name initial-value 
+			&optional (documentation nil documentation-p))
+  `(progn (declaim (special ,name))
+    (setf (symbol-value ',name) ,initial-value)
+    ,(when documentation-p
+	   `(setf (documentation ',name 'variable) ',documentation))
+    ',name))
+
+(defmacro defvar (name &optional
+		  (initial-value nil initial-value-p)
+		  (documentation nil documentation-p))
+  `(progn (declaim (special ,name))
+    ,(when initial-value-p
+	   `(unless (boundp ',name)
+	     (setf (symbol-value ',name) ,initial-value)))
+    ,(when documentation-p
+	   `(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)))
+      (and (characterp x) (characterp y) (char= x y))))
+
+(defun equalp (x y)
+  (cond
+   ((eq x y) t)
+   ((characterp x) (and (characterp y) (char-equal x y)))
+   ((numberp x) (and (numberp y) (= x y)))
+   ((consp x) (and (consp y) (equalp (car x) (car y)) (equalp (cdr x) (cdr y))))
+   ((arrayp x) (and (arrayp y)
+		    (equal (array-dimensions x) (array-dimensions y))
+		    (dotimes (i (array-total-size x) t)
+		      (unless (equalp (row-major-aref x i) (row-major-aref y i))
+			(return nil)))))
+   ((hash-table-p x) (and (hash-table-p y)
+			  (= (hash-table-count x) (hash-table-count y))
+			  (eq (hash-table-test x) (hash-table-test y))
+			  (with-hash-table-iterator (get x)
+			    (loop
+			     (multiple-value-bind (entry-returned key x-value)
+				 (get)
+			       (unless entry-returned
+				 (return t))
+			       (multiple-value-bind (y-value present-p)
+				   (gethash key y)
+				 (unless (and present-p (equalp x-value y-value))
+				   (return nil))))))))
+   ((typep x 'structure-object) (and (typep x 'structure-object)
+				     (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