X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fboot.lisp;h=821c4825e424d62ef061be5c32e0bd1f74c59c43;hb=d19b5d61e75a24cb5ee6b53630d9ec01106bd641;hp=ada5db94b6f1dc9350f5d63d526dca7a1cb7a37c;hpb=208c73a2f0efe2a798ac6ea959687c613dc7d5e8;p=jscl.git
diff --git a/src/boot.lisp b/src/boot.lisp
index ada5db9..821c482 100644
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -3,18 +3,18 @@
;; Copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
-;; This program is free software: you can redistribute it and/or
+;; JSCL is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
-;; This program is distributed in the hope that it will be useful, but
+;; JSCL is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see .
+;; along with JSCL. If not, see .
;;; This code is executed when JSCL compiles this file itself. The
;;; compiler provides compilation of some special forms, as well as
@@ -22,22 +22,23 @@
;;; Lisp world from scratch. This code has to define enough language
;;; to the compiler to be able to run.
-(eval-when-compile
- (%compile-defmacro 'defmacro
- '(function
- (lambda (name args &rest body)
- `(eval-when-compile
- (%compile-defmacro ',name
- '(function
- (lambda ,(mapcar #'(lambda (x)
- (if (eq x '&body)
- '&rest
- x))
- args)
- ,@body))))))))
+(/debug "loading boot.lisp!")
+
+(eval-when (:compile-toplevel)
+ (let ((defmacro-macroexpander
+ '#'(lambda (form)
+ (destructuring-bind (name args &body body)
+ form
+ (let ((whole (gensym)))
+ `(eval-when (:compile-toplevel :execute)
+ (%compile-defmacro ',name
+ '#'(lambda (,whole)
+ (destructuring-bind ,args ,whole
+ ,@body)))))))))
+ (%compile-defmacro 'defmacro defmacro-macroexpander)))
(defmacro declaim (&rest decls)
- `(eval-when-compile
+ `(eval-when (:compile-toplevel :execute)
,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
(defmacro defconstant (name value &optional docstring)
@@ -45,7 +46,7 @@
(declaim (special ,name))
(declaim (constant ,name))
(setq ,name ,value)
- ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
+ ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
',name))
(defconstant t 't)
@@ -61,17 +62,17 @@
(defmacro unless (condition &body body)
`(if ,condition nil (progn ,@body)))
-(defmacro defvar (name value &optional docstring)
+(defmacro defvar (name &optional (value nil value-p) docstring)
`(progn
(declaim (special ,name))
- (unless (boundp ',name) (setq ,name ,value))
- ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
+ ,@(when value-p `((unless (boundp ',name) (setq ,name ,value))))
+ ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
',name))
(defmacro defparameter (name value &optional docstring)
`(progn
(setq ,name ,value)
- ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
+ ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
',name))
(defmacro defun (name args &rest body)
@@ -88,113 +89,84 @@
(defvar *gensym-counter* 0)
(defun gensym (&optional (prefix "G"))
(setq *gensym-counter* (+ *gensym-counter* 1))
- (make-symbol (concat-two prefix (integer-to-string *gensym-counter*))))
+ (make-symbol (concat prefix (integer-to-string *gensym-counter*))))
(defun boundp (x)
(boundp x))
-;; Basic functions
-(defun = (x y) (= x y))
-(defun * (x y) (* x y))
-(defun / (x y) (/ x y))
-(defun 1+ (x) (+ x 1))
-(defun 1- (x) (- x 1))
-(defun zerop (x) (= x 0))
-
-(defun truncate (x &optional (y 1))
- (floor (/ x y)))
+(defun fboundp (x)
+ (fboundp x))
+(defun eq (x y) (eq x y))
(defun eql (x y) (eq x y))
(defun not (x) (if x nil t))
;; Basic macros
-(defmacro incf (place &optional (delta 1))
- (multiple-value-bind (dummies vals newval setter getter)
- (get-setf-expansion place)
- (let ((d (gensym)))
- `(let* (,@(mapcar #'list dummies vals)
- (,d ,delta)
- (,(car newval) (+ ,getter ,d))
- ,@(cdr newval))
- ,setter))))
-
-(defmacro decf (place &optional (delta 1))
- (multiple-value-bind (dummies vals newval setter getter)
- (get-setf-expansion place)
- (let ((d (gensym)))
- `(let* (,@(mapcar #'list dummies vals)
- (,d ,delta)
- (,(car newval) (- ,getter ,d))
- ,@(cdr newval))
- ,setter))))
-
-(defmacro push (x place)
- (multiple-value-bind (dummies vals newval setter getter)
- (get-setf-expansion place)
- (let ((g (gensym)))
- `(let* ((,g ,x)
- ,@(mapcar #'list dummies vals)
- (,(car newval) (cons ,g ,getter))
- ,@(cdr newval))
- ,setter))))
-
-(defmacro dolist (iter &body body)
- (let ((var (first iter))
- (g!list (gensym)))
+(defmacro dolist ((var list &optional result) &body body)
+ (let ((g!list (gensym)))
+ (unless (symbolp var) (error "`~S' is not a symbol." var))
`(block nil
- (let ((,g!list ,(second iter))
+ (let ((,g!list ,list)
(,var nil))
(%while ,g!list
(setq ,var (car ,g!list))
(tagbody ,@body)
(setq ,g!list (cdr ,g!list)))
- ,(third iter)))))
+ ,result))))
-(defmacro dotimes (iter &body body)
- (let ((g!to (gensym))
- (var (first iter))
- (to (second iter))
- (result (third iter)))
+(defmacro dotimes ((var count &optional result) &body body)
+ (let ((g!count (gensym)))
+ (unless (symbolp var) (error "`~S' is not a symbol." var))
`(block nil
(let ((,var 0)
- (,g!to ,to))
- (%while (< ,var ,g!to)
+ (,g!count ,count))
+ (%while (< ,var ,g!count)
(tagbody ,@body)
(incf ,var))
,result))))
(defmacro cond (&rest clausules)
- (if (null clausules)
- nil
- (if (eq (caar clausules) t)
- `(progn ,@(cdar clausules))
- (let ((test-symbol (gensym)))
- `(let ((,test-symbol ,(caar clausules)))
- (if ,test-symbol
- ,(if (null (cdar clausules))
- test-symbol
- `(progn ,@(cdar clausules)))
- (cond ,@(cdr clausules))))))))
+ (unless (null clausules)
+ (destructuring-bind (condition &body body)
+ (first clausules)
+ (cond
+ ((eq condition t)
+ `(progn ,@body))
+ ((null body)
+ (let ((test-symbol (gensym)))
+ `(let ((,test-symbol ,condition))
+ (if ,test-symbol
+ ,test-symbol
+ (cond ,@(rest clausules))))))
+ (t
+ `(if ,condition
+ (progn ,@body)
+ (cond ,@(rest clausules))))))))
(defmacro case (form &rest clausules)
(let ((!form (gensym)))
`(let ((,!form ,form))
(cond
,@(mapcar (lambda (clausule)
- (if (eq (car clausule) t)
+ (destructuring-bind (keys &body body)
clausule
- `((eql ,!form ',(car clausule))
- ,@(cdr clausule))))
+ (if (or (eq keys 't) (eq keys 'otherwise))
+ `(t nil ,@body)
+ (let ((keys (if (listp keys) keys (list keys))))
+ `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
+ nil ,@body)))))
clausules)))))
(defmacro ecase (form &rest clausules)
- `(case ,form
- ,@(append
- clausules
- `((t
- (error "ECASE expression failed."))))))
+ (let ((g!form (gensym)))
+ `(let ((,g!form ,form))
+ (case ,g!form
+ ,@(append
+ clausules
+ `((t
+ (error "ECASE expression failed for the object `~S'." ,g!form))))))))
(defmacro and (&rest forms)
(cond
@@ -227,40 +199,12 @@
(defmacro prog2 (form1 result &body body)
`(prog1 (progn ,form1 ,result) ,@body))
-
-
-;;; Go on growing the Lisp language in Ecmalisp, with more high level
-;;; utilities as well as correct versions of other constructions.
-
-(defun + (&rest args)
- (let ((r 0))
- (dolist (x args r)
- (incf r x))))
-
-(defun - (x &rest others)
- (if (null others)
- (- x)
- (let ((r x))
- (dolist (y others r)
- (decf r y)))))
-
-(defun append-two (list1 list2)
- (if (null list1)
- list2
- (cons (car list1)
- (append (cdr list1) list2))))
-
-(defun append (&rest lists)
- (!reduce #'append-two lists))
-
-(defun revappend (list1 list2)
- (while list1
- (push (car list1) list2)
- (setq list1 (cdr list1)))
- list2)
-
-(defun reverse (list)
- (revappend list '()))
+(defmacro prog (inits &rest body )
+ (multiple-value-bind (forms decls docstring) (parse-body body)
+ `(block nil
+ (let ,inits
+ ,@decls
+ (tagbody ,@forms)))))
(defmacro psetq (&rest pairs)
(let (;; For each pair, we store here a list of the form
@@ -279,11 +223,13 @@
(setq assignments (reverse assignments))
;;
`(let ,(mapcar #'cdr assignments)
- (setq ,@(!reduce #'append (mapcar #'butlast assignments))))))
+ (setq ,@(!reduce #'append (mapcar #'butlast assignments) nil)))))
(defmacro do (varlist endlist &body body)
`(block nil
- (let ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+ (let ,(mapcar (lambda (x) (if (symbolp x)
+ (list x nil)
+ (list (first x) (second x)))) varlist)
(while t
(when ,(car endlist)
(return (progn ,@(cdr endlist))))
@@ -291,13 +237,16 @@
(psetq
,@(apply #'append
(mapcar (lambda (v)
- (and (consp (cddr v))
+ (and (listp v)
+ (consp (cddr v))
(list (first v) (third v))))
varlist)))))))
(defmacro do* (varlist endlist &body body)
`(block nil
- (let* ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+ (let* ,(mapcar (lambda (x1) (if (symbolp x1)
+ (list x1 nil)
+ (list (first x1) (second x1)))) varlist)
(while t
(when ,(car endlist)
(return (progn ,@(cdr endlist))))
@@ -305,29 +254,11 @@
(setq
,@(apply #'append
(mapcar (lambda (v)
- (and (consp (cddr v))
+ (and (listp v)
+ (consp (cddr v))
(list (first v) (third v))))
varlist)))))))
-(defun list-length (list)
- (let ((l 0))
- (while (not (null list))
- (incf l)
- (setq list (cdr list)))
- l))
-
-(defun length (seq)
- (cond
- ((stringp seq)
- (string-length seq))
- ((arrayp seq)
- (oget seq "length"))
- ((listp seq)
- (list-length seq))))
-
-(defun concat-two (s1 s2)
- (concat-two s1 s2))
-
(defmacro with-collect (&body body)
(let ((head (gensym))
(tail (gensym)))
@@ -346,120 +277,42 @@
(defun identity (x) x)
+(defun complement (x)
+ (lambda (&rest args)
+ (not (apply x args))))
+
(defun constantly (x)
(lambda (&rest args)
x))
-(defun code-char (x) x)
-(defun char-code (x) x)
-(defun char= (x y) (= x y))
+(defun code-char (x)
+ (code-char x))
-(defun integerp (x)
- (and (numberp x) (= (floor x) x)))
+(defun char-code (x)
+ (char-code x))
-(defun floatp (x)
- (and (numberp x) (not (integerp x))))
+(defun char= (x y)
+ (eql x y))
-(defun plusp (x) (< 0 x))
-(defun minusp (x) (< x 0))
+(defun char< (x y)
+ (< (char-code x) (char-code y)))
(defun atom (x)
(not (consp x)))
-(defun find (item list &key key (test #'eql))
- (dolist (x list)
- (when (funcall test (funcall key x) item)
- (return x))))
-
-(defun remove (x list)
- (cond
- ((null list)
- nil)
- ((eql x (car list))
- (remove x (cdr list)))
- (t
- (cons (car list) (remove x (cdr list))))))
-
-(defun remove-if (func list)
- (cond
- ((null list)
- nil)
- ((funcall func (car list))
- (remove-if func (cdr list)))
- (t
- ;;
- (cons (car list) (remove-if func (cdr list))))))
-
-(defun remove-if-not (func list)
- (cond
- ((null list)
- nil)
- ((funcall func (car list))
- (cons (car list) (remove-if-not func (cdr list))))
- (t
- (remove-if-not func (cdr list)))))
+(defun alpha-char-p (x)
+ (or (<= (char-code #\a) (char-code x) (char-code #\z))
+ (<= (char-code #\A) (char-code x) (char-code #\Z))))
(defun digit-char-p (x)
- (if (and (<= #\0 x) (<= x #\9))
- (- x #\0)
+ (if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
+ (- (char-code x) (char-code #\0))
nil))
(defun digit-char (weight)
(and (<= 0 weight 9)
(char "0123456789" weight)))
-(defun subseq (seq a &optional b)
- (cond
- ((stringp seq)
- (if b
- (slice seq a b)
- (slice seq a)))
- (t
- (error "Unsupported argument."))))
-
-(defmacro do-sequence (iteration &body body)
- (let ((seq (gensym))
- (index (gensym)))
- `(let ((,seq ,(second iteration)))
- (cond
- ;; Strings
- ((stringp ,seq)
- (let ((,index 0))
- (dotimes (,index (length ,seq))
- (let ((,(first iteration)
- (char ,seq ,index)))
- ,@body))))
- ;; Lists
- ((listp ,seq)
- (dolist (,(first iteration) ,seq)
- ,@body))
- (t
- (error "type-error!"))))))
-
-(defun some (function seq)
- (do-sequence (elt seq)
- (when (funcall function elt)
- (return-from some t))))
-
-(defun every (function seq)
- (do-sequence (elt seq)
- (unless (funcall function elt)
- (return-from every nil)))
- t)
-
-(defun position (elt sequence)
- (let ((pos 0))
- (do-sequence (x seq)
- (when (eq elt x)
- (return))
- (incf pos))
- pos))
-
-(defun string (x)
- (cond ((stringp x) x)
- ((symbolp x) (symbol-name x))
- (t (char-to-string x))))
-
(defun equal (x y)
(cond
((eql x y) t)
@@ -467,19 +320,10 @@
(and (consp y)
(equal (car x) (car y))
(equal (cdr x) (cdr y))))
- ((arrayp x)
- (and (arrayp y)
- (let ((n (length x)))
- (when (= (length y) n)
- (dotimes (i n)
- (unless (equal (aref x i) (aref y i))
- (return-from equal nil)))
- t))))
+ ((stringp x)
+ (and (stringp y) (string= x y)))
(t nil)))
-(defun string= (s1 s2)
- (equal s1 s2))
-
(defun fdefinition (x)
(cond
((functionp x)
@@ -487,23 +331,12 @@
((symbolp x)
(symbol-function x))
(t
- (error "Invalid function"))))
+ (error "Invalid function `~S'." x))))
(defun disassemble (function)
(write-line (lambda-code (fdefinition function)))
nil)
-(defun documentation (x type)
- "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
- (ecase type
- (function
- (let ((func (fdefinition x)))
- (oget func "docstring")))
- (variable
- (unless (symbolp x)
- (error "Wrong argument type! it should be a symbol"))
- (oget x "vardoc"))))
-
(defmacro multiple-value-bind (variables value-from &body body)
`(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
,@body)
@@ -515,29 +348,31 @@
;;; Generalized references (SETF)
-(defvar *setf-expanders* nil)
-
-(defun get-setf-expansion (place)
- (if (symbolp place)
- (let ((value (gensym)))
- (values nil
- nil
- `(,value)
- `(setq ,place ,value)
- place))
- (let ((place (ls-macroexpand-1 place)))
- (let* ((access-fn (car place))
- (expander (cdr (assoc access-fn *setf-expanders*))))
- (when (null expander)
- (error "Unknown generalized reference."))
- (apply expander (cdr place))))))
+(eval-when(:compile-toplevel :load-toplevel :execute)
+ (defvar *setf-expanders* nil)
+ (defun !get-setf-expansion (place)
+ (if (symbolp place)
+ (let ((value (gensym)))
+ (values nil
+ nil
+ `(,value)
+ `(setq ,place ,value)
+ place))
+ (let ((place (!macroexpand-1 place)))
+ (let* ((access-fn (car place))
+ (expander (cdr (assoc access-fn *setf-expanders*))))
+ (when (null expander)
+ (error "Unknown generalized reference."))
+ (apply expander (cdr place)))))))
+(fset 'get-setf-expansion (fdefinition '!get-setf-expansion))
(defmacro define-setf-expander (access-fn lambda-list &body body)
(unless (symbolp access-fn)
- (error "ACCESS-FN must be a symbol."))
- `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
- *setf-expanders*)
- ',access-fn))
+ (error "ACCESS-FN `~S' must be a symbol." access-fn))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (push (cons ',access-fn (lambda ,lambda-list ,@body))
+ *setf-expanders*)
+ ',access-fn))
(defmacro setf (&rest pairs)
(cond
@@ -546,16 +381,17 @@
((null (cdr pairs))
(error "Odd number of arguments to setf."))
((null (cddr pairs))
- (let ((place (ls-macroexpand-1 (first pairs)))
+ (let ((place (!macroexpand-1 (first pairs)))
(value (second pairs)))
- (multiple-value-bind (vars vals store-vars writer-form)
- (get-setf-expansion place)
+ (multiple-value-bind (vars vals store-vars writer-form reader-form)
+ (!get-setf-expansion place)
;; TODO: Optimize the expansion a little bit to avoid let*
;; or multiple-value-bind when unnecesary.
`(let* ,(mapcar #'list vars vals)
(multiple-value-bind ,store-vars
,value
- ,writer-form)))))
+ ,writer-form
+ ,reader-form)))))
(t
`(progn
,@(do ((pairs pairs (cddr pairs))
@@ -563,32 +399,103 @@
((null pairs)
(reverse result)))))))
+(defmacro incf (place &optional (delta 1))
+ (multiple-value-bind (dummies vals newval setter getter)
+ (!get-setf-expansion place)
+ (let ((d (gensym)))
+ `(let* (,@(mapcar #'list dummies vals)
+ (,d ,delta)
+ (,(car newval) (+ ,getter ,d))
+ ,@(cdr newval))
+ ,setter))))
+
+(defmacro decf (place &optional (delta 1))
+ (multiple-value-bind (dummies vals newval setter getter)
+ (!get-setf-expansion place)
+ (let ((d (gensym)))
+ `(let* (,@(mapcar #'list dummies vals)
+ (,d ,delta)
+ (,(car newval) (- ,getter ,d))
+ ,@(cdr newval))
+ ,setter))))
+
+(defmacro push (x place)
+ (multiple-value-bind (dummies vals newval setter getter)
+ (!get-setf-expansion place)
+ (let ((g (gensym)))
+ `(let* ((,g ,x)
+ ,@(mapcar #'list dummies vals)
+ (,(car newval) (cons ,g ,getter))
+ ,@(cdr newval))
+ ,setter))))
+
+(defmacro pop (place)
+ (multiple-value-bind (dummies vals newval setter getter)
+ (!get-setf-expansion place)
+ (let ((head (gensym)))
+ `(let* (,@(mapcar #'list dummies vals)
+ (,head ,getter)
+ (,(car newval) (cdr ,head))
+ ,@(cdr newval))
+ ,setter
+ (car ,head)))))
+
+(defmacro pushnew (x place &rest keys &key key test test-not)
+ (declare (ignore key test test-not))
+ (multiple-value-bind (dummies vals newval setter getter)
+ (!get-setf-expansion place)
+ (let ((g (gensym))
+ (v (gensym)))
+ `(let* ((,g ,x)
+ ,@(mapcar #'list dummies vals)
+ ,@(cdr newval)
+ (,v ,getter))
+ (if (member ,g ,v ,@keys)
+ ,v
+ (let ((,(car newval) (cons ,g ,getter)))
+ ,setter))))))
+
+
+
;; Incorrect typecase, but used in NCONC.
(defmacro typecase (x &rest clausules)
(let ((value (gensym)))
`(let ((,value ,x))
(cond
,@(mapcar (lambda (c)
- (if (eq (car c) t)
- `((t ,@(rest c)))
+ (if (find (car c) '(t otherwise))
+ `(t ,@(rest c))
`((,(ecase (car c)
(integer 'integerp)
(cons 'consp)
+ (list 'listp)
+ (vector 'vectorp)
+ (character 'characterp)
+ (sequence 'sequencep)
(symbol 'symbolp)
+ (function 'functionp)
+ (float 'floatp)
(array 'arrayp)
(string 'stringp)
(atom 'atom)
- (null 'null))
+ (null 'null)
+ (package 'packagep))
,value)
,@(or (rest c)
(list nil)))))
clausules)))))
+(defmacro etypecase (x &rest clausules)
+ (let ((g!x (gensym)))
+ `(let ((,g!x ,x))
+ (typecase ,g!x
+ ,@clausules
+ (t (error "~S fell through etypecase expression." ,g!x))))))
+
(defun notany (fn seq)
(not (some fn seq)))
-
-(defconstant internal-time-units-per-second 1000)
+(defconstant internal-time-units-per-second 1000)
(defun get-internal-real-time ()
(get-internal-real-time))
@@ -599,11 +506,16 @@
(defun get-universal-time ()
(+ (get-unix-time) 2208988800))
-(defun concat (&rest strs)
- (!reduce #'concat-two strs :initial-value ""))
-
(defun values-list (list)
(values-array (list-to-vector list)))
(defun values (&rest args)
(values-list args))
+
+(defun error (fmt &rest args)
+ (%throw (apply #'format nil fmt args)))
+
+(defmacro nth-value (n form)
+ `(multiple-value-call (lambda (&rest values)
+ (nth ,n values))
+ ,form))