diff options
Diffstat (limited to 'Sacla')
| -rw-r--r-- | Sacla/core.lisp | 636 | ||||
| -rw-r--r-- | Sacla/do.lisp | 7 | ||||
| -rw-r--r-- | Sacla/share.lisp | 6 |
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* "") |