(let ((value (gensym)))
`(let ((,value ,form))
,@body
- ,value))))
+ ,value)))
+
+ (defmacro prog2 (form1 result &body body)
+ `(prog1 (progn ,form1 ,result) ,@body))
+
+
+
+)
;;; This couple of helper functions will be defined in both Common
;;; Lisp and in Ecmalisp.
(defun append (&rest lists)
(!reduce #'append-two lists '()))
- (defun reverse-aux (list acc)
- (if (null list)
- acc
- (reverse-aux (cdr list) (cons (car list) acc))))
+ (defun revappend (list1 list2)
+ (while list1
+ (push (car list1) list2)
+ (setq list1 (cdr list1)))
+ list2)
(defun reverse (list)
- (reverse-aux list '()))
+ (revappend list '()))
(defun list-length (list)
(let ((l 0))
(defun listp (x)
(or (consp x) (null x)))
+ (defun nthcdr (n list)
+ (while (and (plusp n) list)
+ (setq n (1- n))
+ (setq list (cdr list)))
+ list)
+
(defun nth (n list)
- (cond
- ((null list) list)
- ((zerop n) (car list))
- (t (nth (1- n) (cdr list)))))
+ (car (nthcdr n list)))
(defun last (x)
- (if (consp (cdr x))
- (last (cdr x))
- x))
+ (while (consp (cdr x))
+ (setq x (cdr x)))
+ x)
(defun butlast (x)
(and (consp (cdr x))
(cons (car x) (butlast (cdr x)))))
(defun member (x list)
- (cond
- ((null list)
- nil)
- ((eql x (car list))
- list)
- (t
- (member x (cdr list)))))
+ (while list
+ (when (eql x (car list))
+ (return list))
+ (setq list (cdr list))))
(defun remove (x list)
(cond
""
(concat (car list) separator (join-trailing (cdr list) separator))))
-;;; Like CONCAT, but prefix each line with four spaces.
+
+;;; Like CONCAT, but prefix each line with four spaces. Two versions
+;;; of this function are available, because the Ecmalisp version is
+;;; very slow and bootstraping was annoying.
+
+#+ecmalisp
(defun indent (&rest string)
(let ((input (join string)))
(let ((output "")
(index 0)
(size (length input)))
- (when (plusp size)
- (setq output " "))
+ (when (plusp (length input)) (concatf output " "))
(while (< index size)
- (setq output
- (concat output
- (if (and (char= (char input index) #\newline)
- (< index (1- size))
- (not (char= (char input (1+ index)) #\newline)))
- (concat (string #\newline) " ")
- (subseq input index (1+ index)))))
+ (let ((str
+ (if (and (char= (char input index) #\newline)
+ (< index (1- size))
+ (not (char= (char input (1+ index)) #\newline)))
+ (concat (string #\newline) " ")
+ (string (char input index)))))
+ (concatf output str))
(incf index))
output)))
+#+common-lisp
+(defun indent (&rest string)
+ (with-output-to-string (*standard-output*)
+ (with-input-from-string (input (join string))
+ (loop
+ for line = (read-line input nil)
+ while line
+ do (write-string " ")
+ do (write-line line)))))
+
+
(defun integer-to-string (x)
(cond
((zerop x)
(defvar *environment* (make-lexenv))
(defun clear-undeclared-global-bindings ()
- (let ((variables (first *environment*))
- (functions (second *environment*)))
- (setq *environment* (list variables functions (third *environment*)))))
+ (setq *environment*
+ (mapcar (lambda (namespace)
+ (remove-if-not #'binding-declared namespace))
+ *environment*)))
(defvar *variable-counter* 0)
(binding (make-binding symbol 'variable (gvarname symbol) nil)))
(push-to-lexenv binding *environment* 'variable)
(push (lambda ()
- (unless (lookup-in-lexenv symbol *environment* 'variable)
- (error (concat "Undefined variable `" name "'"))))
+ (let ((b (lookup-in-lexenv symbol *environment* 'variable)))
+ (unless (binding-declared b)
+ (error (concat "Undefined variable `" name "'")))))
*compilation-unit-checks*)
binding)))
nil)))
(push-to-lexenv binding *environment* 'function)
(push (lambda ()
- (unless (binding-declared (lookup-in-lexenv symbol *environment* 'function))
- (error (concat "Undefined function `" name "'"))))
+ (let ((b (lookup-in-lexenv symbol *environment* 'function)))
+ (unless (binding-declared b)
+ (error (concat "Undefined function `" name "'")))))
*compilation-unit-checks*)
binding)))