(cdr list)
:initial-value (funcall func initial-value (car list)))))
+(defmacro with-collect (&body body)
+ (let ((head (gensym))
+ (tail (gensym)))
+ `(let* ((,head (cons 'sentinel nil))
+ (,tail ,head))
+ (flet ((collect (x)
+ (rplacd ,tail (cons x nil))
+ (setq ,tail (cdr ,tail))
+ x))
+ ,@body)
+ (cdr ,head))))
+
;;; Go on growing the Lisp language in Ecmalisp, with more high
;;; level utilities as well as correct versions of other
;;; constructions.
(defun concat-two (s1 s2)
(concat-two s1 s2))
- (defmacro with-collect (&body body)
- (let ((head (gensym))
- (tail (gensym)))
- `(let* ((,head (cons 'sentinel nil))
- (,tail ,head))
- (flet ((collect (x)
- (rplacd ,tail (cons x nil))
- (setq ,tail (cdr ,tail))
- x))
- ,@body)
- (cdr ,head))))
-
- ;; A very simple defstruct built on lists. It supports just slot with
- ;; an optional default initform, and it will create a constructor,
- ;; predicate and accessors for you.
- (defmacro defstruct (name &rest slots)
- (unless (symbolp name)
- (error "It is not a full defstruct implementation."))
- (let* ((name-string (symbol-name name))
- (slot-descriptions
- (mapcar (lambda (sd)
- (cond
- ((symbolp sd)
- (list sd))
- ((and (listp sd) (car sd) (cddr sd))
- sd)
- (t
- (error "Bad slot accessor."))))
- slots))
- (predicate (intern (concat name-string "P"))))
- `(progn
- ;; Constructor
- (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
- (list ',name ,@(mapcar #'car slot-descriptions)))
- ;; Predicate
- (defun ,predicate (x)
- (and (consp x) (eq (car x) ',name)))
- ;; Copier
- (defun ,(intern (concat "COPY-" name-string)) (x)
- (copy-list x))
- ;; Slot accessors
- ,@(with-collect
- (let ((index 1))
- (dolist (slot slot-descriptions)
- (let* ((name (car slot))
- (accessor-name (intern (concat name-string "-" (string name)))))
- (collect
- `(defun ,accessor-name (x)
- (unless (,predicate x)
- (error ,(concat "The object is not a type " name-string)))
- (nth ,index x)))
- ;; TODO: Implement this with a higher level
- ;; abstraction like defsetf or (defun (setf ..))
- (collect
- `(define-setf-expander ,accessor-name (x)
- (let ((object (gensym))
- (new-value (gensym)))
- (values (list object)
- (list x)
- (list new-value)
- `(progn
- (rplaca (nthcdr ,',index ,object) ,new-value)
- ,new-value)
- `(,',accessor-name ,object)))))
- (incf index)))))
- ',name)))
-
(defun map1 (func list)
(with-collect
(while list
(return list))
(setq list (cdr list))))
+ (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)
(defvar *newline* (string (code-char 10)))
+#+ecmalisp
(defun concat (&rest strs)
(!reduce #'concat-two strs :initial-value ""))
+#+common-lisp
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun concat (&rest strs)
+ (apply #'concatenate 'string strs)))
(defmacro concatf (variable &body form)
`(setq ,variable (concat ,variable (progn ,@form))))
(defun !parse-integer (string junk-allow)
(block nil
(let ((value 0)
- (index 0)
- (size (length string))
- (sign 1))
- (when (zerop size) (return (values nil 0)))
+ (index 0)
+ (size (length string))
+ (sign 1))
+ ;; Leading whitespace
+ (while (and (< index size)
+ (whitespacep (char string index)))
+ (incf index))
+ (unless (< index size) (return (values nil 0)))
;; Optional sign
(case (char string 0)
- (#\+ (incf index))
- (#\- (setq sign -1)
- (incf index)))
+ (#\+ (incf index))
+ (#\- (setq sign -1)
+ (incf index)))
;; First digit
(unless (and (< index size)
- (setq value (digit-char-p (char string index))))
- (return (values nil index)))
+ (setq value (digit-char-p (char string index))))
+ (return (values nil index)))
(incf index)
;; Other digits
(while (< index size)
- (let ((digit (digit-char-p (char string index))))
- (unless digit (return))
- (setq value (+ (* value 10) digit))
- (incf index)))
+ (let ((digit (digit-char-p (char string index))))
+ (unless digit (return))
+ (setq value (+ (* value 10) digit))
+ (incf index)))
+ ;; Trailing whitespace
+ (do ((i index (1+ i)))
+ ((or (= i size) (not (whitespacep (char string i))))
+ (and (= i size) (setq index i))))
(if (or junk-allow
- (= index size)
- (char= (char string index) #\space))
- (values (* sign value) index)
- (values nil index)))))
+ (= index size))
+ (values (* sign value) index)
+ (values nil index)))))
#+ecmalisp
(defun parse-integer (string)
;;; function call.
(defvar *multiple-value-p* nil)
-(defun make-binding (name type value &optional declarations)
- (list name type value declarations))
-
-(defun binding-name (b) (first b))
-(defun binding-type (b) (second b))
-(defun binding-value (b) (third b))
-(defun binding-declarations (b) (fourth b))
-
-(defun set-binding-value (b value)
- (rplaca (cddr b) value))
-
-(defun set-binding-declarations (b value)
- (rplaca (cdddr b) value))
-
-(defun push-binding-declaration (decl b)
- (set-binding-declarations b (cons decl (binding-declarations b))))
-
-
-(defun make-lexenv ()
- (list nil nil nil nil))
+;; A very simple defstruct built on lists. It supports just slot with
+;; an optional default initform, and it will create a constructor,
+;; predicate and accessors for you.
+(defmacro def!struct (name &rest slots)
+ (unless (symbolp name)
+ (error "It is not a full defstruct implementation."))
+ (let* ((name-string (symbol-name name))
+ (slot-descriptions
+ (mapcar (lambda (sd)
+ (cond
+ ((symbolp sd)
+ (list sd))
+ ((and (listp sd) (car sd) (cddr sd))
+ sd)
+ (t
+ (error "Bad slot accessor."))))
+ slots))
+ (predicate (intern (concat name-string "-P"))))
+ `(progn
+ ;; Constructor
+ (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
+ (list ',name ,@(mapcar #'car slot-descriptions)))
+ ;; Predicate
+ (defun ,predicate (x)
+ (and (consp x) (eq (car x) ',name)))
+ ;; Copier
+ (defun ,(intern (concat "COPY-" name-string)) (x)
+ (copy-list x))
+ ;; Slot accessors
+ ,@(with-collect
+ (let ((index 1))
+ (dolist (slot slot-descriptions)
+ (let* ((name (car slot))
+ (accessor-name (intern (concat name-string "-" (string name)))))
+ (collect
+ `(defun ,accessor-name (x)
+ (unless (,predicate x)
+ (error ,(concat "The object is not a type " name-string)))
+ (nth ,index x)))
+ ;; TODO: Implement this with a higher level
+ ;; abstraction like defsetf or (defun (setf ..))
+ (collect
+ `(define-setf-expander ,accessor-name (x)
+ (let ((object (gensym))
+ (new-value (gensym)))
+ (values (list object)
+ (list x)
+ (list new-value)
+ `(progn
+ (rplaca (nthcdr ,',index ,object) ,new-value)
+ ,new-value)
+ `(,',accessor-name ,object)))))
+ (incf index)))))
+ ',name)))
+
+(def!struct binding
+ name
+ type
+ value
+ declarations)
+
+(def!struct lexenv
+ variable
+ function
+ block
+ gotag)
-(defun copy-lexenv (lexenv)
- (copy-list lexenv))
+(defun lookup-in-lexenv (name lexenv namespace)
+ (find name (ecase namespace
+ (variable (lexenv-variable lexenv))
+ (function (lexenv-function lexenv))
+ (block (lexenv-block lexenv))
+ (gotag (lexenv-gotag lexenv)))
+ :key #'binding-name))
(defun push-to-lexenv (binding lexenv namespace)
(ecase namespace
- (variable (rplaca lexenv (cons binding (car lexenv))))
- (function (rplaca (cdr lexenv) (cons binding (cadr lexenv))))
- (block (rplaca (cddr lexenv) (cons binding (caddr lexenv))))
- (gotag (rplaca (cdddr lexenv) (cons binding (cadddr lexenv))))))
+ (variable (push binding (lexenv-variable lexenv)))
+ (function (push binding (lexenv-function lexenv)))
+ (block (push binding (lexenv-block lexenv)))
+ (gotag (push binding (lexenv-gotag lexenv)))))
(defun extend-lexenv (bindings lexenv namespace)
(let ((env (copy-lexenv lexenv)))
(dolist (binding (reverse bindings) env)
(push-to-lexenv binding env namespace))))
-(defun lookup-in-lexenv (name lexenv namespace)
- (assoc name (ecase namespace
- (variable (first lexenv))
- (function (second lexenv))
- (block (third lexenv))
- (gotag (fourth lexenv)))))
(defvar *environment* (make-lexenv))
(defun extend-local-env (args)
(let ((new (copy-lexenv *environment*)))
(dolist (symbol args new)
- (let ((b (make-binding symbol 'variable (gvarname symbol))))
+ (let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol))))
(push-to-lexenv b new 'variable)))))
;;; Toplevel compilations
(defun %compile-defmacro (name lambda)
(toplevel-compilation (ls-compile `',name))
- (push-to-lexenv (make-binding name 'macro lambda) *environment* 'function)
+ (push-to-lexenv (make-binding :name name :type 'macro :value lambda) *environment* 'function)
name)
(defun global-binding (name type namespace)
(or (lookup-in-lexenv name *environment* namespace)
- (let ((b (make-binding name type nil)))
+ (let ((b (make-binding :name name :type type :value nil)))
(push-to-lexenv b *environment* namespace)
b)))
(special
(dolist (name (cdr decl))
(let ((b (global-binding name 'variable 'variable)))
- (push-binding-declaration 'special b))))
+ (push 'special (binding-declarations b)))))
(notinline
(dolist (name (cdr decl))
(let ((b (global-binding name 'function 'function)))
- (push-binding-declaration 'notinline b))))
+ (push 'notinline (binding-declarations b)))))
(constant
(dolist (name (cdr decl))
(let ((b (global-binding name 'variable 'variable)))
- (push-binding-declaration 'constant b))))))
+ (push 'constant (binding-declarations b)))))))
#+ecmalisp
(fset 'proclaim #'!proclaim)
(defun setq-pair (var val)
(let ((b (lookup-in-lexenv var *environment* 'variable)))
- (if (and (eq (binding-type b) 'variable)
+ (if (and (binding-p b)
+ (eq (binding-type b) 'variable)
(not (member 'special (binding-declarations b)))
(not (member 'constant (binding-declarations b))))
(code (binding-value b) " = " (ls-compile val))
(defun make-function-binding (fname)
- (make-binding fname 'function (gvarname fname)))
+ (make-binding :name fname :type 'function :value (gvarname fname)))
(defun compile-function-definition (list)
(compile-lambda (car list) (cdr list)))
(defun translate-function (name)
(let ((b (lookup-in-lexenv name *environment* 'function)))
- (binding-value b)))
+ (and b (binding-value b))))
(define-compilation flet (definitions &rest body)
(let* ((fnames (mapcar #'car definitions))
(if (special-variable-p var)
(code (ls-compile `(setq ,var ,value)) ";" *newline*)
(let* ((v (gvarname var))
- (b (make-binding var 'variable v)))
+ (b (make-binding :name var :type 'variable :value v)))
(prog1 (code "var " v " = " (ls-compile value) ";" *newline*)
(push-to-lexenv b *environment* 'variable))))))
(define-compilation block (name &rest body)
(let* ((tr (incf *block-counter*))
- (b (make-binding name 'block tr)))
+ (b (make-binding :name name :type 'block :value tr)))
(when *multiple-value-p*
- (push-binding-declaration 'multiple-value b))
+ (push 'multiple-value (binding-declarations b)))
(let* ((*environment* (extend-lexenv (list b) *environment* 'block))
(cbody (ls-compile-block body t)))
(if (member 'used (binding-declarations b))
(multiple-value-p (member 'multiple-value (binding-declarations b))))
(when (null b)
(error (concat "Unknown block `" (symbol-name name) "'.")))
- (push-binding-declaration 'used b)
+ (push 'used (binding-declarations b))
(js!selfcall
(when multiple-value-p (code "var values = mv;" *newline*))
"throw ({"
(let ((bindings
(mapcar (lambda (label)
(let ((tagidx (integer-to-string (incf *go-tag-counter*))))
- (make-binding label 'gotag (list tbidx tagidx))))
+ (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
(remove-if-not #'go-tag-p body))))
(extend-lexenv bindings *environment* 'gotag)))
(defun macro (x)
(and (symbolp x)
(let ((b (lookup-in-lexenv x *environment* 'function)))
- (and (eq (binding-type b) 'macro)
- b))))
+ (if (and b (eq (binding-type b) 'macro))
+ b
+ nil))))
(defun ls-macroexpand-1 (form)
(let ((macro-binding (macro (car form))))
;; us replace the list representation version of the
;; function with the compiled one.
;;
- #+ecmalisp (set-binding-value macro-binding compiled)
+ #+ecmalisp (setf (binding-value macro-binding) compiled)
(setq expander compiled)))
(apply expander (cdr form)))
form)))
((and b (not (member 'special (binding-declarations b))))
(binding-value b))
((or (keywordp sexp)
- (member 'constant (binding-declarations b)))
+ (and b (member 'constant (binding-declarations b))))
(code (ls-compile `',sexp) ".value"))
(t
(ls-compile `(symbol-value ',sexp))))))
projects / jscl.git / blobdiff