MICRO COMMON LISP

T3X SOURCE CODE   |   LISP SOURCE CODE

This is the high-level part of the source code of the MICRO COMMON LISP interpreter, written mostly in standard Common LISP.

;; MICRO COMMON LISP functions and macros
;; Nils M Holm, 2019, 2020, 2025
;; In the public domain

; This file adds lots of Common LISP functions to the
; minimal interpreter core. After LOADing the file,
; an image can be created by running (SUSPEND 'MCLISP).

; There is no DEFUN or DEFMACRO at this point, so the
; first step in boostraping the rest of the LISP system
; is to implement these macros.

; Until DEFUN is available FSETQ and LAMBDA are used to
; define functions. Because MICRO COMMON LISP does not
; have a SETF form, it uses FSETQ instead, which can be
; defined like this in Common LISP:
;
; (defmacro fsetq (n x)
;   `(setf (symbol-function ',n) ,x))

; Using the &REST keyword, LIST is easy. LIST is very
; nice to have when defining macros.

(fsetq list (lambda (&rest x) x))

; DEFMACRO and DEFUN are good to have early on, and they
; are not too hard to do, even without quasiquotation.
; Note how the definition of DEFMACRO is exactly what
; DEFMACRO expands to.

; The early versions of DEFUN and DEFMACRO have a few
; shortcomings that will be fixed later: they bind local
; symbols, if local symbols are present and they do not
; return the correct values. This will be fixed later.

; Note that MICRO COMMON LISP macro expansion functions
; expect different arguments than those of Common LISP.

(fsetq defmacro
  (cons 'macro
        (lambda (n v x &rest xs)
          (list 'fsetq
                n
                (list 'cons
                      ''macro
                      (cons 'lambda (cons v (cons x xs))))))))

; DEFUN is similar to DEFMACRO, but we can now use
; DEFMACRO to define it.

; Both DEFUN and DEFMACRO will later be redefined using
; quasiquotation.

(defmacro defun (n v x &rest xs)
  (list 'fsetq
        n
        (cons 'lambda (cons v (cons x xs)))))

; NULL is simple, NOT is really the same as NULL.

(defun null (x) (eq x nil))
(fsetq not #'null)

; We only define accessors for nested Conses up to a
; nesting level of three. More is rarely needed in
; simple programs.

(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))))

; Reversing and appending a list in one go is
; naturally tail-recursive: take from A and
; cons to B until A is empty:
;
;                          A           B
;                       -------  -------------
; .------ (A B C)       (A B C)        (1 2 3)
; |                       (B C)      (A 1 2 3)
; '-----> (1 2 3)           (C)    (B A 1 2 3)
;                            ()  (C B A 1 2 3)

(defun revappend (a b)
  (if (null a)
      b
      (revappend (cdr a)
                 (cons (car a) b))))

; Using REVAPPEND, REVERSE is easy.

(defun reverse (a)
  (revappend a nil))

; Using REVAPPEND and REVERSE, APPEND is easy.
; A more efficient, variable-argument version of
; APPEND will be defined later, when more
; convenient control mechanisms are available.

(defun append (a b)
  (revappend (reverse a) b))

; Here comes the COND macro.
;
; There is no quasiquotation yet, so expressions
; are built using LIST and CONS.
;
; COND Expression          Expands to
; --------------------     --------------------
; (COND)                   NIL
; (COND (X) ...)           (IFNOT X (COND ...))
; (COND (T X ...) ...)     (PROGN X ...)
; (COND (X Y ...) ...)     (IF X (PROGN Y ...)
;                                (COND ...))

; IFNOT can be implemented like this in Common LISP:
;
; (defmacro ifnot (p a)
;   (let ((g (gensym)))
;     `(let ((,g ,p))
;        (if ,g ,g ,a))))

(defmacro cond (&rest cs)
  (if (null cs)
      nil
      (if (null (cdar cs))
          (list 'ifnot (caar cs)
                       (cons 'cond (cdr cs)))
          (if (eq 't (caar cs))
              (cons 'progn (cdar cs))
              (list 'if (caar cs)
                        (cons 'progn (cdar cs))
                        (cons 'cond (cdr cs)))))))

; Using COND the AND macro is easy.
; Still no QUASIQUOTE, though.
;
; (AND)        expands to  T
; (AND X)      expands to  X
; (AND X ...)  expands to  (IF X (AND ...) NIL)

(defmacro and (&rest xs)
  (cond ((null xs))
        ((null (cdr xs)) (car xs))
        (t (list 'if (car xs)
                     (cons 'and (cdr xs))
                     nil))))

; The above is sufficient to implement QUASIQUOTE.
; These abbreviations are used:
;
;  'X  ==  (QUOTE X)
;  `X  ==  (QUASIQUOTE X)
;  ,X  ==  (UNQUOTE X)
; ,@X  ==  (UNQUOTE-SPLICE X)
;
; Each of the following rules corresponds to one
; clause of the COND in QUASIQUOTE:
;
;         `X  ==  'X
;       `NIL  ==  NIL
;        `,X  ==  X
;  `(,X ...)  ==  (CONS X `(...))
; `(,@X ...)  ==  (APPEND X `(...))
;   `(X ...)  ==  (CONS `X `(...))
;
; The case (QUASIQUOTE NIL) == NIL is an optimization.
; It saves a few nodes in the final image.

(defmacro quasiquote (x)
  (cond ((null x) x)
        ((atom x)
          (list 'quote x))
        ((eq 'unquote (car x))
          (cadr x))
        ((and (not (atom (car x)))
              (eq 'unquote (caar x)))
          (list 'cons (cadar x)
                      (list 'quasiquote (cdr x))))
        ((and (not (atom (car x)))
              (eq 'unquote-splice (caar x)))
          (list 'append (cadar x)
                        (list 'quasiquote (cdr x))))
        (t (list 'cons (list 'quasiquote (car x))
                       (list 'quasiquote (cdr x))))))

; This is what DEFMACRO and DEFUN look like with
; quasiquotation. These versions return the correct
; values and make sure that their symbols are bound
; in the global environment (by adding the T parameter
; to FSETQ).

(defmacro defmacro (n v x &rest xs)
  `(progn (fsetq ,n (cons 'macro (lambda ,v ,x . ,xs)) t)
          ',n))

(defmacro defun (n v x &rest xs)
  `(progn (fsetq ,n (lambda ,v ,x . ,xs) t)
          ',n))

; DEFPARAMETER is also nice to have. In MCL it is
; pretty much syntactic sugar for SETQ.

(defmacro defparameter (v a)
  `(progn (setq ,v ,a) ',v))

; The OR macro is superficially simple.
;
; (OR)    expands to  NIL and
; (OR X)  expands to  X
;
; It might be tempting to expand
;
; (OR X ...)  to  (IF X X (OR ...))
;
; but then any effects of X will be duplicated. E.g.
;
; (OR (PRINT 'FOO) NIL)  will print FOO twice.
;
; This is often solved by introducing a local variable:
;
; (LET ((G X)) (IF G G (OR ...)))  where G is a GENSYM.
;
; However, MICRO COMMON LISP has the IFNOT form, which
; simplifies things, and so
;
; (OR X ...)  expands to  (IFNOT X (OR ...))

(defmacro or (&rest xs)
  (cond ((null xs) nil)
        ((null (cdr xs)) (car xs))
        (t `(ifnot ,(car xs)
                   (or . ,(cdr xs))))))

; For more complex definitions, some local binding
; constructs like LET or LABELS would be desirable.

; The transformation performed by the LET macro is
; simple enough:
;
; (LET ((V1 A1) ...) BODY)
;   ==
; ((LAMBDA (V1 ...) BODY) A1 ...)

; The LAMBDA expression is easy to construct with
; quasiquotation, but first the list of bindings
; ((V1 A1) ...) has to be deconstructed into two
; lists (V1 ...) and (A1 ...).
;
; This is easy enough using MAPCAR, but defining
; MAPCAR, at least a tail-recursive version, would
; require LABELS, and LABELS is even harder to
; define than LET.

; Of course we could first define a recursive MAPCAR
; function and then build LET on top of it and later
; redefine MAPCAR to be tail-recursive, like this:

; (defun mapcar (f a)
;   (cond ((null a) nil)
;         (t (cons (funcall f (car a))
;                  (mapcar f (cdr a))))))
; 
; (defmacro let (bs x &rest xs)
;   ((lambda (vs as)
;      `((lambda ,vs ,x . ,xs) . ,as))
;    (mapcar #'car bs)
;    (mapcar #'cadr bs)))

; However, this implementation would not expand in
; constant space. Every binding in LET would use
; additional storage in MAPCAR. Of course we could
; redefine LET later, when there is a tail-recursive
; version of LET. We could even use the old LET to
; define the new LET.

; Or we could just define a local, tail-recursive
; SPLIT function and use that to split up the list
; of bindings. It would look like this:
;
; (defun split (bs vs as)
;   (if (null bs)
;       (list vs as)
;       (split (cdr bs)
;              (cons (caar bs) vs)
;              (cons (cadar bs) as)))))
;
; and work like this:
;
; (SPLIT '((A 1) (B 2)))  =>  ((A B) (1 2))

; However, there is no LABELS, so how do we create
; a local function? How would LABELS do it? Let's
; cheat a little bit and see:
;
; (MACROEXPAND-1 '(LABELS ((F (X) X)) BODY))
;   =>  (LET ((F NIL))
;         (FSETQ F (LAMBDA (X) X))
;         BODY)
;
; So LABELS creates a local variable and then changes
; its function binding to the desired function. The
; LET can easily be transformed to LAMBDA.

; One last issue is that the SPLIT function returns a
; list of lists (S), while we want two separate lists.
; Of course we could use
;
; `((LAMBDA ,(CAR S) ,X . ,XS) . ,(CADR S))
;
; but there is a more elegant solution. See the code!

; Note: in the actual source code the SPLIT function is
; named S, in order to squeeze out a few more free nodes.

(defmacro let (bs x &rest xs)
  ((lambda (split)
     (fsetq split
       (lambda (bs vs as)
         (if (null bs)
             (list vs as)
             (split (cdr bs)
                    (cons (caar bs) vs)
                    (cons (cadar bs) as)))))
     (apply (lambda (vs as)
              `((lambda ,vs ,x . ,xs) . ,as))
            (split bs nil nil)))
   nil))

; The next problem is that a definition of LABELS would
; really benefit from MAPCAR, but MAPCAR would be much
; easier with LABELS. LABELS uses MAPCAR a lot and LET
; makes a preliminary version of MAPCAR almost readable.

; A full MAPCAR would accept any number of list arguments,
; but this is MICRO COMMON LISP, so a version with either
; one or two lists will do. Internally it has a one-list
; and a two-list mapping function, M1 and M2. Both are
; defined with LET and FSETQ, like in the expanded LABELS
; above.

; A more readable version or MAPCAR and MAPLIST will be
; defined later.

(defun mapcar (f a &rest b)
  (if (null b)
      (let ((m1 nil))
        (fsetq m1
          (lambda (a)
            (if (null a)
                nil
                (cons (funcall f (car a))
                      (m1 (cdr a))))))
        (m1 a))
      (let ((m2 nil))
        (fsetq m2
          (lambda (a b)
            (if (null a)
                nil
                (cons (funcall f (car a) (car b))
                      (m2 (cdr a) (cdr b))))))
        (m2 a (car b)))))

; Using MAPCAR, LABELS is easy. Its transformation is:
;
; (LABELS ((F1 (A1 ...) X1 ...) ...) BODY)
;   ==
; (LET ((F1 NIL) ...)
;   (FSETQ F1 (LAMBDA (A1 ...) X1 ...))
;   ...
;   BODY)
;
; So it has to extract the function names Fi, the function
; bodies ((Ai ...) Xi ...), and then create the LET binding
; list ((Fi NIL) ...) and the function definitions
; (FSETQ Fi (LAMBDA (Ai ...) Xi ...)), and finally put it
; all together. The term "body" for the ((Ai ...) Xi ...)
; part is wrong, of course, because it also includes the
; argument list of the function.

; The LABELS function will store the function names in NS,
; the partial functions in FS, the LET bindings in VS, and
; the function definitions in DS.
;
; In the actual source code the variables are named
; differently, in order to squeeze out a few more free nodes.

(defmacro labels (bs x &rest xs)
  (let ((ns (mapcar #'car bs))
        (fs (mapcar #'cdr bs)))
    (let ((vs (mapcar (lambda (n)
                        (list n nil))
                      ns))
          (ds (mapcar (lambda (n f)
                        `(fsetq ,n (lambda . ,f)))
                      ns fs)))
      `(let ,vs ,@ds ,x . ,xs))))

; With LET, LET* is almost trivial. It expands
; as follows:
;
; (LET* ((V1 A1) (V2 A2) ...) BODY)
;   ==
; (LET ((V1 A1))
;   (LET* ((V2 A2) ...)
;     BODY))
;
; and
;
; (LET* () BODY)  ==  (LET () BODY)

(defmacro let* (bs x &rest xs)
  (if (null bs)
      `(let () ,x . ,xs)
      `(let (,(car bs))
         (let* ,(cdr bs) ,x . ,xs))))

; For a tail-recursive version of MAPCAR, NREVERSE
; is useful, and NREVERSE is to NRECONC as REVERSE
; is to REVAPPEND.

; So how do you reverse and concenate one lists to
; another in situ in a tail-recursive function?
; Think about it!

;           Here is an explanation of
;          (NRECONC '(A B C) '(1 2 3)):
;
;                         A-------  B-------- X----
; (let ((x (cdr a)))    ; (A B C)   (1 2 3)   (B C)
;   (rplacd a b)        ; (A 1 2 3) (1 2 3)   (B C)
;   (nreconc x a))))    ; (B C)     (A 1 2 3) -/-

(defun nreconc (a b)
  (if (null a)
      b
      (let ((x (cdr a)))
        (rplacd a b)
        (nreconc x a))))

; Using NRECONC, NREVERSE is easy:

(defun nreverse (a)
  (nreconc a nil))

; The only difference between MAPCAR and MAPLIST is the part
; of the list argument to which the function is applied. MAPCAR
; applies it to the CAR of the list and MAPLIST to the list
; itself.

; So the following higher-order MAP function implements both,
; depending on its argument G. When CAR is passed to MAP, it
; returns a function implementing MAPCAR, and when the identity
; function (LAMBDA (X) X) is passed to it, it returns a function
; that implements MAPLIST.

; In fact by adding two more arguments to MAP, MAPCAN and MAPCON
; could also be implemented, but this is MICRO COMMON LISP, so
; MAPCAN and MAPCON are kept as a separate extension (SRC/MAPCAN).

; MAP is called F in the actual source code, again to squeeze
; out a few nodes.

(defun map (g)
  (lambda (f a &rest b)
    (labels
      ((m1 (a r)
         (cond ((null a) (nreverse r))
               (t (m1 (cdr a)
                      (cons (funcall f (funcall g a)) r)))))
       (m2 (a b r)
         (cond ((null a) (nreverse r))
               ((null b) (nreverse r))
               (t (m2 (cdr a)
                      (cdr b)
                      (cons (funcall f (funcall g a)
                                       (funcall g b)) r))))))
    (if (null b)
        (m1 a nil)
        (m2 a (car b) nil)))))

(fsetq mapcar  (map #'car))
(fsetq maplist (map (lambda (x) x)))

; Once MAPCAR and MAPLIST are there,
; MAP is no longer needed.

(fsetq map nil)

; Things are getting routine at this point.
; Here is REMOVE-IF-NOT:

(defun remove-if-not (f a)
  (labels
    ((g (a r)
       (cond ((null a) (nreverse r))
             ((funcall f (car a))
               (g (cdr a)
                  (cons (car a) r)))
             (t (g (cdr a) r)))))
    (g a nil)))

; EQUAL is easy when there are only conses and symbols.

(defun equal (a b)
  (or (eq a b)
      (and (not (atom a))
           (not (atom b))
           (equal (car a) (car b))
           (equal (cdr a) (cdr b)))))

; Nothing special about MEMBER and ASSOC.

(defun member (x a)
  (cond ((null a) nil)
        ((equal x (car a)) a)
        (t (member x (cdr a)))))

(defun assoc (x a)
  (cond ((null a) nil)
        ((equal x (caar a)) (car a))
        (t (assoc x (cdr a)))))

; DO comes in handy when defining variable-argument
; functions like APPEND and NCONC. It expands as
; follows (G is a GENSYM):
;
; (DO ((V1 A1 S1) ...) (TEST FINAL) BODY)
;   ==
; (LABELS ((G (V1 ...))
;            (COND (TEST FINAL)
;                  (T BODY
;                     (G S1 ...))))
;   (G A1 ...))

(defmacro do (bs ts &rest xs)
  (let ((vs (mapcar #'car bs))
        (as (mapcar #'cadr bs))
        (ss (mapcar #'caddr bs))
        (g  (gensym)))
    `(labels ((,g ,vs
                (cond ,ts
                      (t ,@xs (,g . ,ss)))))
       (,g . ,as))))

; APPEND and NCONC differ only by one single
; REVERSE vs NREVERSE, so a higher-order function
; can be used to generate them, just like MAPCAR
; and MAPLIST, above.

; CAT is called F in the real source code.

(defun cat (g)
  (lambda (&rest ls)
    (do ((ls (reverse ls) (cdr ls))
         (r nil (nreconc (funcall g (car ls)) r)))
        ((null ls) r))))

(fsetq append (cat #'reverse))
(fsetq nconc  (cat #'nreverse))
(fsetq cat nil)

; PRINT is easy.

(defun print (x)
  (terpri)
  (princ x)
  (princ " ")
  x)

; MACROEXPAND-1 uses only Common LISP functions,
; but the macro functions of MICRO COMMON LISP
; and Common LISP are not compatible.
; MICRO COMMON LISP macro expanders expect exactly
; the arguments passed to DEFMACRO, i.e. the
; function bound by FSETQ in DEFMACRO is exactly
; the macro expander.

(defun macroexpand-1 (x)   
  (let ((f (macro-function (car x))))
    (if f
        (apply f (cdr x))
        x)))