From 0f383318a079bd0c7bb23c909f30771b1c20b29c Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Thu, 31 Jul 2008 09:33:25 +0200 Subject: Add Sacla to the repository. --- Sacla/core.lisp | 726 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 726 insertions(+) create mode 100644 Sacla/core.lisp (limited to 'Sacla/core.lisp') 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 +;; 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 -- cgit v1.2.3