summaryrefslogtreecommitdiff
path: root/Sacla/core.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'Sacla/core.lisp')
-rw-r--r--Sacla/core.lisp726
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