;;; -*- Mode: Lisp; -*-
;;; ---------------------------------------------------------------------------
;;;     Title: Initialization File for ulisp
;;;   Created: Somewhen in 2013
;;;    Author: Gilbert Baumann <gilbert@amethyst.local>
;;; ---------------------------------------------------------------------------
;;;  (c) copyright 2013-2020 by Gilbert Baumann

;; THIS IS NOT FREE SOFTWARE AND NOT FOR REDISTRIBUTION.

;; ### BLOCKs in DOxyz

(putd 'list #'(lambda x x))

(putd 'defmacro
      (cons 'macro
            #'(lambda (form env)
                ((lambda (name params body)
                   (list 'putd
                         (list 'quote name)
                         (list 'cons
                               ''macro
                               (list 'function
                                     (list 'lambda '(-form- -env-)
                                           (list 'apply
                                                 (list 'function
                                                       (cons 'lambda
                                                             (cons params body)))
                                                 '(cdr -form-)))))))
                 (car (cdr form))
                 (car (cdr (cdr form)))
                 (cdr (cdr (cdr form)))))))

(defmacro defun (name params . body)
  (list 'putd (list 'quote name)
        (list 'function
              (cons 'lambda (cons params body)))))

(defmacro defvar (name init)            ;### doc
  `(progn
     (if (not (boundp ',name))
         (setq ,name ,init))
     ',name))

(defmacro lambda (params . body)
  `(function (lambda ,params ,@body)))

(defun funcall (fun . args)
  (apply fun args))

;;;;

(defun caar (x) (car (car x)))
(defun cadr (x) (car (cdr x)))
(defun cdar (x) (cdr (car x)))
(defun cddr (x) (cdr (cdr x)))

(defun caaar (x) (car (car (car x))))
(defun caadr (x) (car (car (cdr x))))
(defun cadar (x) (car (cdr (car x))))
(defun caddr (x) (car (cdr (cdr x))))
(defun cdaar (x) (cdr (car (car x))))
(defun cdadr (x) (cdr (car (cdr x))))
(defun cddar (x) (cdr (cdr (car x))))
(defun cdddr (x) (cdr (cdr (cdr x))))

(defun caaaar (x) (car (car (car (car x)))))
(defun caaadr (x) (car (car (car (cdr x)))))
(defun caadar (x) (car (car (cdr (car x)))))
(defun caaddr (x) (car (car (cdr (cdr x)))))
(defun cadaar (x) (car (cdr (car (car x)))))
(defun cadadr (x) (car (cdr (car (cdr x)))))
(defun caddar (x) (car (cdr (cdr (car x)))))
(defun cadddr (x) (car (cdr (cdr (cdr x)))))
(defun cdaaar (x) (cdr (car (car (car x)))))
(defun cdaadr (x) (cdr (car (car (cdr x)))))
(defun cdadar (x) (cdr (car (cdr (car x)))))
(defun cdaddr (x) (cdr (car (cdr (cdr x)))))
(defun cddaar (x) (cdr (cdr (car (car x)))))
(defun cddadr (x) (cdr (cdr (car (cdr x)))))
(defun cdddar (x) (cdr (cdr (cdr (car x)))))
(defun cddddr (x) (cdr (cdr (cdr (cdr x)))))

;;;; Backquote

(defmacro backquote (form)
  (backquote-1 form))

(defun backquote-1 (form)
  (if (atom form)
      (list 'quote form)
      (if (eq (car form) 'comma)
          (cadr form)
          (if (if (consp (car form)) (eq (caar form) 'comma-at) nil)
              (if (cdr form)
                  (list 'append (cadar form)
                        (backquote-1 (cdr form)))
                  (cadar form))
              ((lambda (ca cd)
                 (if (if (consp ca)
                         (if (eq (car ca) 'quote)
                             (if (consp cd)
                                 (eq (car cd) 'quote))))
                     (list 'quote (cons (cadr ca) (cadr cd)))
                     (list 'cons ca cd)))
               (backquote-1 (car form))
               (backquote-1 (cdr form)))))))

;;;; LET

(defun mapcar (fun list)
  (if (null list)
      nil
      (cons (funcall fun (car list)) (mapcar fun (cdr list)))))

(defmacro let (bindings . body)
  `((lambda ,(mapcar #'(lambda (x)
                         (if (consp x) (car x) x))
                     bindings)
      ,@body)
    ,@(mapcar #'(lambda (x)
                  (if (consp x) (cadr x) nil))
              bindings)))

(defmacro let* (bindings . body)
  (if (null bindings)
      `(progn ,@body)
      `((lambda (,(if (consp (car bindings))
                      (caar bindings)
                      (car bindings)))
          (let* ,(cdr bindings) ,@body))
        ,(if (consp (car bindings))
             (cadar bindings)
             nil))))

;;;;

(defmacro cond clauses
  (if (null clauses)
      nil
      (let ((test (caar clauses))
            (body (cdar clauses)))
        (if (null body)
            (let ((g (gensym)))
              `(let ((,g ,test))
                 (if ,g ,g (cond ,@(cdr clauses)))))
            `(if ,test
                 (progn ,@body)
                 (cond ,@(cdr clauses)))))))

(defmacro and more
  (cond ((null more) 't)
        ((null (cdr more)) (car more))
        (t
         `(if ,(car more)
              (and ,@(cdr more))
              nil))))

(defmacro or more
  (cond ((null more) 'nil)
        ((null (cdr more)) (car more))
        (t
         (let ((g (gensym)))
           `(let ((,g ,(car more)))
              (if ,g ,g (or ,@(cdr more))))))))

(defmacro when (test . body)
  `(cond (,test ,@body)))

(defmacro unless (test . body)
  `(cond ((not ,test) ,@body)))

(defmacro case (key . clauses)
  (let ((g (gensym)))
    `(let ((,g ,key))
       (cond ,@(mapcar (lambda (clause)
                         (let ((key (car clause))
                               (action (cdr clause)))
                           (cons (cond ((or (eq 't key)
                                            (eq 'otherwise key))
                                        't)
                                       ((listp key)
                                        `(or ,@(mapcar (lambda (k)
                                                         `(eql ,g ',k))
                                                       key)))
                                       (t
                                        `(eql ,g ',key)))
                                 (or action '(nil)))))
                       clauses)))))

(defmacro prog1 (first . more)
  (let ((g (gensym)))
    `(let ((,g ,first))
       ,@more
       ,g)))

(defmacro prog2 (first second . more)
  (let ((g (gensym)))
    `(progn
       ,first
       (let ((,g ,second))
         ,@more
         ,g))))

(defmacro prog (bindings . body)
  `(block nil
     (let ,bindings
       (tagbody
          ,@body))))

(defmacro prog* (bindings . body)
  `(block nil
     (let* ,bindings
       (tagbody
          ,@body))))

(defmacro return (value)
  `(return-from nil ,value))

;;;;

(defun explode (object)
  (let ((s (cons nil nil)))
    (prin1 object s)
    (car s)))

(defun explodec (object)
  (let ((s (cons nil nil)))
    (princ object s)
    (car s)))

(defun implode (chars)
  (read (list chars)))

(defvar *gensym-counter* 1)

(defun gensym ()                  ;### prefix?
  (setq *gensym-counter* (plus *gensym-counter* 1))
  (make-symbol (cons 71 (explode (difference *gensym-counter* 1)))))

;;;; -- Iteration -----------------------------------------------------------------------------

(defmacro do* (bindings test+res . body)
  (do-aux 'let* 'setq bindings test+res body))

(defmacro do (bindings test+res . body)
  (do-aux 'let 'psetq bindings test+res body))

(defun do-aux (let-sym setq-sym bindings test+res body)
  (let ((loop (gensym))
        (exit (gensym))
        aux)
    (setq aux (lambda (q)
                (if (null q)
                    nil
                    (cons (caar q) (cons (caddar q) (funcall aux (cdr q)))))))
    `(,let-sym ,(mapcar (lambda (x)
                      (list (car x) (cadr x)))
                    bindings)
       (tagbody
          ,loop
          (if ,(car test+res)
              (go ,exit))
          ,@body
          (,setq-sym ,@(funcall aux bindings))
          (go ,loop)
          ,exit)
       ,@(cdr test+res))))

(defmacro dolist (var-list-res . body)
  (let ((var (car var-list-res))
        (lst (cadr var-list-res))
        (res (caddr var-list-res))
        (g (gensym)))
    `(do* ((,g ,lst (cdr ,g)))
          ((null ,g)
           (let ((,var nil)) ,res))
       (let ((,var (car ,g)))
         (tagbody
            ,@body)))))

(defmacro dotimes (var-end-res . body) 
  (let ((var (car var-end-res))
        (end (cadr var-end-res))
        (res (caddr var-end-res))
        (g (gensym)))
    `(let ((,g ,end))
       (do* ((,var 0 (+ ,var 1)))
            ((eql ,var ,g)
             ,res)
         ,@body))))

(defun append lists
  (cond ((null lists) nil)
        ((null (cdr lists)) (car lists))
        ((null (car lists)) (apply #'append (cdr lists)))
        (t (cons (caar lists) (apply #'append (cons (cdar lists) (cdr lists)))))))

;;;; ------------------------------------------------------------------------------------------

(defun reverse (lst)
  (let ((res nil))
    (dolist (k lst res)
      (push k res))))

(defun nconc lists
  (let (res tail)
    (dolist (q lists res)
      (when q
        (if tail
            (rplacd tail q)
            (setq res (setq tail q)))
        (do () ((atom (cdr tail))) (setq tail (cdr tail)))))))

(defun my-append lists
  (let ((head nil)
        (tail nil))
    (do ((q lists (cdr q)))
        ((null (cdr q))
         (cond ((null tail) (car q))
               (t
                (rplacd tail (car q))
                head)))
      (dolist (k (car q))
        (let ((n (cons k nil)))
          (if (null tail)
              (setq head n tail n))
          (rplacd tail n)
          (setq tail n))))))

(defun last (x)
  (do* ((q x (cdr q)))
       ((atom (cdr q)) q)))

(defun nth (n list)
  (car (nthcdr n list)))

(defun nthcdr (n list)
  (do* ((q list (cdr q))
        (n n (1- n)))
       ((or (<= n 0) (atom q))
        q)))

(defun length (list)
  (do* ((n 0 (+ n 1))
        (q list (cdr q)))
       ((null q) n)))

(defun equal (x y)
  (cond ((eql x y) t)
        ((atom x) nil)
        ((atom y) nil)
        ((equal (car x) (car y))
         (equal (cdr x) (cdr y)))))

;;;; -- Numbers -------------------------------------------------------------------------------

(defun zerop (x) (= x 0))
(defun minusp (x) (< x 0))
(defun plusp (x) (> x 0))
(defun evenp (x) (= 0 (rem x 2)))
(defun oddp (x) (= 1 (rema x 2)))

(defun 1+ (x) (+ x 1))
(defun 1- (x) (- x 1))

(defun abs (x) (if (lessp x 0) (difference 0 x) x)) ;### DIFFERENCE, LESSP?

(defun min (first . more)
  (dolist (x more first)
    (when (< x first)
      (setq first x))))

(defun max (first . more)
  (dolist (x more first)
    (when (> x first)
      (setq first x))))

;; The following looks worse as it is, we later define compiler
;; macros.

(defun + numbers
  (let ((res 0))
    (dolist (x numbers res)
      (setq res (plus res x)))))

(defun * numbers
  (let ((res 1))
    (dolist (x numbers res)
      (setq res (times res x)))))

(defun - (first . numbers)
  (if numbers
      (dolist (x numbers first)
        (setq first (difference first x)))
      (difference 0 first)))

(defun / (first . numbers)
  (if numbers
      (dolist (x numbers first)
        (setq first (quotient first x)))
      (quotient 1 first)))

(defun < (x y)
  (lessp x y))

(defun > (x y)
  (lessp y x))

(defun >= (x y)
  (not (lessp x y)))

(defun <= (x y)
  (not (lessp y x)))

(defun = (x y)
  (equ x y))

(defun /= (x y)
  (not (equ x y)))

(defun ash (number count)
  (* number (expt 2 count)))

;;;; ------------------------------------------------------------------------------------------

(defun type-of (object)
  (cond ((numberp object)
         (if (integerp object)
             'integer
             'number))                  ;Hmm
        ((symbolp object)
         'symbol)
        ((consp object)
         'cons)
        (t
         'atom)))                       ;should not happen

;;;; ------------------------------------------------------------------------------------------

(defmacro push (x y)
  ;; xxx
  `(setq ,y (cons ,x ,y)))

(defmacro setf more
  ;; ### Check length of arguments to place
  ;; We could optimize a bit, but that will be task of the compiler
  (let ((res nil)
        (q more)
        (g (gensym)))
    (tagbody
     10
       (when (null q)
         (go 99))
       (apply (lambda (place value . rest)
                (push
                 (cond ((symbolp place)
                        `(setq ,place ,value))
                       (t
                        (case (car place)
                          ((car)
                           `(car (rplaca ,(cadr place) ,value)))
                          ((cdr)
                           `(cdr (rplacd ,(cadr place) ,value)))
                          ((symbol-value)
                           `(set ,(cadr place) ,value))
                          ((symbol-plist)
                           `(set-symbol-plist ,(cadr place) ,value))
                          ((symbol-function)
                           `(let ((,g ,value))
                              (putd ,(cadr place) ,g)
                              ,g))
                          ((get)
                           `(let ((,g ,value))
                              (put ,(cadr place) ,(caddr place) ,g)
                              ,g))
                          ((nth)
                           `(car (rplaca (nthcdr ,(cadr place) ,(caddr place)) ,value)))
                          (otherwise
                           (error "Bad place for SETF" place)) )))
                 res)
                (setq q rest))
              q)
       (go 10)
     99)
    `(progn ,@(reverse res))))

;;;; ------------------------------------------------------------------------------------------

(defun read-line args
  (let ((stream (car args)))
    (let ((res nil))
      (do* ((c (read-char stream) (read-char stream)))
           ((or (= c 10) (= c -1))
            (if (and (= c -1) (null res))
                nil
                (make-symbol (reverse res))))
        (push c res)))))

;;;; -- PLISTs and symbol properties ----------------------------------------------------------

(defun plist-member (key plist)
  (do* ((q plist (cddr q)))
       ((or (null q) (eq (car q) key))
        q)))

(defun get (sym prop)                   ;### default
  (cadr (plist-member prop (symbol-plist sym))))

(defun put (sym prop value)
  (let ((q (plist-member prop (symbol-plist sym))))
    (cond ((null q)
           (setf (symbol-plist sym)
                 (cons prop (cons value (symbol-plist sym)))))
          (t
           (rplaca (cdr q) value)))
    value))

(defun remprop (sym prop)
  (do* ((tail nil (cdr q))
        (q (symbol-plist sym) (cddr q)))
       ((or (null q)
            (eq (car q) prop))
        (when q
          (if tail
              (rplacd tail (cddr q))
              (setf (symbol-plist sym) (cddr q)))
          t))))

(defun getf (plist key &optional default)
  (let ((q (plist-member key plist)))
    (if q (cadr q) default)))

;; (SETF GETF)? REMF?

;;;; ------------------------------------------------------------------------------------------

(defun load (filename)
  ;; Add .LISP, if needed
  (let ((q (explodec filename)))
    (unless (member #\. q)
      (setq filename (symcat filename '.lisp))))
  ;;
  (princ ";; Loading ")
  (princ filename)
  (terpri)
  ;;
  (let ((input (openi filename)))
    (unless input
      (error "Cannot open file" filename))
    (do ((q (read input input) (read input input)))
        ((eq q input) t)
      (prin1 (eval q))
      (terpri))
    (close input)))

(defun symcat (x y)
  (make-symbol (append (explodec x) (explodec y))))

(defun member-eql (item list)
  (do ((q list (cdr q)))
      ((or (null q) (eql item (car q)))
       q)))

(defun member-eq (item list)
  (do ((q list (cdr q)))
      ((or (null q) (eq item (car q)))
       q)))

;;;; ------------------------------------------------------------------------------------------

(defmacro psetq rest
  (let (setq-body bindings)
    (do* ((q rest (cddr q)))
         ((null q))
      (let ((g (gensym)))
        (push (car q) setq-body)
        (push g setq-body)
        (push (list g (cadr q)) bindings)))
    `(let ,(reverse bindings) (setq ,@(reverse setq-body)))))

;;;; ------------------------------------------------------------------------------------------

(defun complement (fun)
  (lambda x (not (apply fun x))))

(defun member (item list . keys)
  (let ((test (make-tester keys)))
    (do ((q list (cdr q)))
        ((or (null q) (funcall test item (car q)))
         q))))

(defun make-tester (keys)
  (let ((test (getf keys :test))
        (test-not (getf keys :test-not))
        (key (getf keys :key)))
    (cond ((and test test-not)
           (error "Bot :TEST and :TEST-NOT given" keys))
          (test-not
           (setq test (complement test-not)))
          ((null test)
           (setq test #'eql)))
    (when key
      (setq test
            (let ((test test))
              (lambda (x y)
                ;; (print (list 'y y 'key key))
                (funcall test x (funcall key y))))))
    test))

(defun assoc (item alist . keys)
  (let ((key (getf keys :key)))
    (setq key
          (cond ((null key)
                 #'car)
                (t
                 (let ((key key))
                   #'(lambda (x)
                       (car (funcall key x)))))))
    (car (apply #'member
                (cons item
                      (cons alist
                            (cons :key
                                  (cons key keys))))))))

(defun remove (item list . keys)
  (let ((test (make-tester keys))
        (head nil)
        (tail nil))
    (dolist (k list head)
      (unless (funcall test item k)
        (cond ((null tail)
               (setq head (setq tail (cons k nil))))
              (t
               (setq tail (cdr (rplacd tail (cons k nil))))))))))

(defun delete (item list . keys)
  (let ((test (make-tester keys))
        (head nil)
        (tail nil))
    (do ((q list (cdr q)))
        ((null q)
         (when tail (rplacd tail nil))
         head)
      (unless (funcall test item (car q))
        (cond ((null tail)
               (setq head (setq tail q)))
              (t
               (setq tail (cdr (rplacd tail q)))))))))

(defun subst (new old tree . keys)
  (subst-aux new old (make-tester keys) tree))

(defun subst-aux (new old test tree)
  (cond ((funcall test old tree)
         new)
        ((atom tree) tree)
        (t
         (cons (subst-aux new old test (car tree))
               (subst-aux new old test (cdr tree))))))

(defun sublis (alist tree . keys)
  (sublis-aux alist (make-tester keys) tree))

(defun sublis-aux (alist test tree)
  (let ((it (assoc tree alist :test test)))
    (cond ((not (null it))
           (cdr it))
        ((atom tree) tree)
        (t
         (cons (sublis-aux alist test (car tree))
               (sublis-aux alist test (cdr tree)))))))

;;;; -- Minimal Compilation -------------------------------------------------------------------

;; The driver calls EVAL to evaluate the forms read. So we could
;; redefne EVAL. Currently all we do is full macro expansion and
;; perhaps reporting undefined functions.

;;; Environments

;; In our lexical environments, we have information about the meaning
;; of symbols in value and function space. The environment is an alist
;; mapping either (:VAR x) or (:FUN x) to a meaning.

;; :FUN <sym>   (MACRO <fun>)
;; :FUN <sym>   (FUNCTION <sym>)

;; :VAR <sym>   (LEXICAL <sym>)     ### alpha?

;; :TAG <atom>  (LEXICAL <atom>)     ### alpha?

;; :BLOCK <sym> (LEXICAL <sym>)     ### alpha?

;;;

;; FLET, LABELS, BLOCK, RETURN-FROM, MACROLET, SYMBOL-MACROLET

(defun env-lookup (kind name env)
  (cdr (assoc (list kind name) env :test #'equal)))

(defun env-cons (kind name value env)
  (cons (cons (list kind name) value) env))

;;

(defun macro-function (form &optional env)
  (let ((q (env-lookup :fun form env)))
    (cond ((and q (eq (car q) 'macro))
           (cadr q))
          ((not (null q)) nil)
          ((not (fboundp form)) nil)
          (t
           (let ((fun (symbol-function form)))
             (if (and (consp fun) (eq (car fun) 'macro))
                 (cdr fun)
                 nil))))))

(defun macroexpand (form &optional env)
  (let ((expansion (macroexpand-1 form env)))
    (if (eq expansion form)
        form
        (macroexpand expansion env))))

(defun macroexpand-1 (form &optional env)
  (cond ((atom form) form)
        ((and (symbolp (car form))
              (setq fun (macro-function (car form) env)))
         (funcall fun form env))
        (t
         form)))

(defun macroexpand-all (form &optional env)
  (setq form (macroexpand form env))
  (cond ((atom form) form)
        (t
         (case (car form)
           ((quote) form)
           ((tagbody)
            (expand-tagbody form env))
           ((progn)
            (cond ((null (cdr form)) nil)
                  ((null (cddr form))
                   (macroexpand-all (cadr form) env))
                  (t
                   (cons (car form) (mapcar (lambda (x) (macroexpand-all x env)) (cdr form))))))
           ((if)
            (cond ((and (consp (cadr form))
                        (member (car (cadr form)) '(not null)))
                   (macroexpand-all
                    `(if ,(cadr (cadr form))
                         ,(cadddr form)
                         ,(caddr form))
                    env))
                  ((eq 't (cadr form))
                   (macroexpand-all
                    (caddr form) env))
                  (t
                   (cons (car form) (mapcar (lambda (x) (macroexpand-all x env)) (cdr form))))))       
           ((progn
              if
              setq)                     ;###
            (cons (car form) (mapcar (lambda (x) (macroexpand-all x env)) (cdr form))))
           ((tabody)
            (cons (car form)
                  (mapcar (lambda (x)
                            (cond ((atom x) x)
                                  (t
                                   (setq x (macroexpand-all x env))
                                   (if (atom x)
                                       `(progn ,x)
                                       x))))
                          (cdr form))))
           ((block return-from)
            `(,(car form) ,(cadr form)
               ,@(mapcar (lambda (x) (macroexpand-all x env)) (cddr form))))
           ((function)
            `(function ,(macroexpand-fun (cadr form) env)))
           ((go)
            form)
           (otherwise
            (cons (macroexpand-fun (car form) env)
                  (mapcar (lambda (x) (macroexpand-all x env)) (cdr form)))) ) )))

(defun macroexpand-fun (fun &optional env)
  (cond ((symbolp fun) fun)
        ((and (consp fun) (eq (car fun) 'lambda))
         `(lambda ,(cadr fun)
            ,@(mapcar (lambda (x) (macroexpand-all x env)) (cddr fun))))
        (t
         (error "Bad function" fun))))

;;; TAGBODY

;; A body which expands to an atom could be discarded. Atoms cannot
;; have side effects and TAGBODY yields no value. Second: When there
;; are no tags, a TAGBODY is not even needed.

(defun expand-tagbody (form env)
  (let ((tag-seen-p nil) (res nil))
    (dolist (form (cdr form))
      (cond ((atom form)
             (setq tag-seen-p t)
             (push form res))
            (t
             (let ((form (macroexpand-all form env)))
               (unless (atom form)
                 (push form res))))))
    (if tag-seen-p
        `(tagbody ,@(reverse res))
        `(progn ,@(reverse res) nil))))

;; Here is a little trick to find out, if we are booted.

(defun cold-probe ()
  (cold-probe-macro))

(defmacro cold-probe-macro ()
  nil)

(defun expand-all-functions ()
  (princ ";; Compiling all functions ...") (terpri)
  (dolist (k (progn 'reverse (oblist)))
    (let ((fun (and (fboundp k) (symbol-function k))))
      (when (and (consp fun) (eq (car fun) 'closure))
        (prin1 k) (princ ", ")
        (putd k `(,(car fun) ,(cadr fun)
                   ,@(cdr (macroexpand-fun (cons 'lambda (cddr fun)))))))
      ;; ### cut and pase
      (when (and (consp fun) (eq (car fun) 'macro))
        (let ((fun (cdr fun)))
          (when (and (consp fun) (eq (car fun) 'closure))
            (prin1 k) (princ ", ")
            (putd k (cons 'macro
                          `(,(car fun) ,(cadr fun)
                             ,@(cdr (macroexpand-fun (cons 'lambda (cddr fun))))))))))))
  (terpri))

(defun funlist ()
  (let ((res nil))
    (dolist (k (oblist) res)
      (let ((fun (and (fboundp k) (symbol-function k))))
        (when (and (consp fun)
                   (member (car fun) '(closure macro subr fsubr)))
          (push k res))))))

(when (cadddr #'cold-probe)
  (expand-all-functions))

;; Install EVAL
(let ((eval #'eval))
  (putd 'eval (lambda (form)
                (funcall eval (macroexpand-all form)))))

;;;; ------------------------------------------------------------------------------------------

(defun mapcar (fun first . lists)
  (let (args head tail donep)
    (setq lists (cons first lists))
    (dolist (k lists) (push nil args))
    (do* () (donep head)
      (do* ((q lists (cdr q))
            (a args (cdr a)))
           ((null q))
        (when (null (car q))
          (setq donep t))
        (rplaca a (caar q))
        (rplaca q (cdar q)))
      (unless donep
        (let ((val (apply fun args)))
          (if tail
              (setq tail (cdr (rplacd tail (cons val nil))))
              (setq head (setq tail (cons val nil)))))))))

(defun mapc (fun first . lists)
  ;; ### could we reduce the cut'n paste?
  (let (args donep)
    (setq lists (cons first lists))
    (dolist (k lists) (push nil args))
    (do* () (donep first)
      (do* ((q lists (cdr q))
            (a args (cdr a)))
           ((null q))
        (when (null (car q))
          (setq donep t))
        (rplaca a (caar q))
        (rplaca q (cdar q)))
      (unless donep
        (apply fun args)))))

(defun maplist (fun first . lists)
  (let (args head tail donep)
    (setq lists (cons first lists))
    (dolist (k lists) (push nil args))
    (do* () (donep head)
      (do* ((q lists (cdr q))
            (a args (cdr a)))
           ((null q))
        (when (null (car q))
          (setq donep t))
        (rplaca a (car q))
        (rplaca q (cdar q)))
      (unless donep
        (let ((val (apply fun args)))
          (if tail
              (setq tail (cdr (rplacd tail (cons val nil))))
              (setq head (setq tail (cons val nil)))))))))

(defun mapl (fun first . lists)
  ;; ### could we reduce the cut'n paste?
  (let (args donep)
    (setq lists (cons first lists))
    (dolist (k lists) (push nil args))
    (do* () (donep first)
      (do* ((q lists (cdr q))
            (a args (cdr a)))
           ((null q))
        (when (null (car q))
          (setq donep t))
        (rplaca a (car q))
        (rplaca q (cdar q)))
      (unless donep
        (apply fun args)))))

;; mapcan, mapcon?

(defun compile-file-pathname (filename)
  (ensure-filename-extension filename '".fasl"))

(defun load-file-pathname (filename)
  (let ((q (explodec filename)))
    (unless (member #\. q)
      (setq filename (symcat filename '".lisp"))))
  filename)

(defun ensure-filename-extension (filename extension)
  ;; Don't look!
  (let ((q (explodec filename))
        p)
    (setq q (reverse q))
    (setq p (or (cdr (member #\. q))
                q))
    (make-symbol
     (reverse (append (reverse (explodec extension)) p)))))

(defun compile-file (filename)
  ;; ### This is a bit fake because of the GENSYM, which when read
  ;; ### back are interned.
  ;;
  ;; Heh, in a real compiler also the lexicals would go away. 
  (setq filename (load-file-pathname filename))
  (let ((output-filename (compile-file-pathname filename)))
    (let ((input (openi filename)))
      (when (null input)
        (error "Cannot open file" filename))
      (let ((output (openo output-filename)))
        (do ((x (read input input) (read input input)))
            ((eq x input))
          (prin1 (macroexpand-all x) output)
          (terpri output))
        (close input)
        (close output)
        output-filename))))

(gc)
(room)

;; All done