Distributed under LGPL 2.1 or Apache 2.0

Source code - http://github.com/billsix/bug

Dedication

For Mom and Dad. Thanks for everything.

Preface

This is a book about compiler design for people who have no interest in studying compiler design. …Umm, then who wants to read this book? Let me try this again… This book is the study of source code which is discarded by the compiler, having no representation in the generated machine code. …Ummm, still not right… This book is about viewing a compiler not only as a means of translating source code into machine code, but also viewing it as an interpreter capable of any general purpose computation. …Closer, but who cares?… I think I got it now. This is a book about "Testing at Compile-Time"!

What do I mean by that? Let’s say you’re looking at source code with which you are unfamiliar, such as the following:

(define permutations
  (lambda (l)
    (if (null? l)
        '()
        (let permutations ((l l))
          (if (null? (cdr l))
              (list l)
              (flatmap (lambda (x) (map (lambda (y) (cons x y))
                                        (permutations (remove x l))))
                       l))))))

What does the code do? How did the author intend for it to be used? In trying to answer those questions, fans of statically-typed programming languages might lament the lack of types, as types help them to reason about programs and help them to deduce where to look to find more information. In trying to answer those questions, fans of dynamically-typed languages might argue "Look at the tests!", as tests ensure the code functions in a user-specified way and they serve as a form of documentation. But where are those tests? Probably in some other file whose file-system path is similar to the current file’s path (e.g., src/com/BigCorp/HugeProject/Foo.java is tested by test/com/BigCorp/HugeProject/FooTest.java). You’d have to find the file, open the file, look through it while ignoring tests which are for other methods. Frankly, it’s too much work and it interrupts the flow of coding, at least for me.

But how else would a programmer organize tests? Well in this book, which is the implementation of a library called "libbug", tests may be specified immediately after the procedure’s definition. Should any test fail the compiler will exit in error, like a type error in a statically-typed language.

(unit-test
(satisfies?
 permutations
 '(
   (() ())
   ((1) ((1)))
   ((1 2) ((1 2)
           (2 1)))
   ((1 2 3) ((1 2 3)
             (1 3 2)
             (2 1 3)
             (2 3 1)
             (3 1 2)
             (3 2 1)))
   )))

Why does the collocation of tests with definitions matter? Towards answering the questions "what does the code do?" and "how did the author intend for it to be used?", there is neither searching through files nor guessing how the code was originally intended to be used. The fact that the tests are collocated with the procedure definition means that the reader can inspect the tests without switching between files, perhaps before looking at the procedure’s definition. And the reader may not even read the procedure at all if the tests gave him enough information to use it successfully. Should he want to understand the procedure, he can mentally apply the procedure to the tests to understand it.

Wait a second. If those tests are defined in the source code itself, won’t they be in the executable? And won’t they run every time I execute the program? That would be unacceptable as it would both increase the size of the binary and slow down the program at start up. Fortunately the answer to both questions is no, because in chapter [buglang] I show how to specify that certain code should be interpreted by the compiler instead of being compiled. Lisp implementations such as Gambit are particularly well suited for this style of programming because unevaluated Lisp code is specified using a data structure of Lisp; because the compiler is an interpreter capable of being augmented. Upon finishing compilation, the compiler has become the very program it is compiling.

1. Introduction

Libbug is Bill’s Utilities for Gambit Scheme: a "standard library" of procedures which augments Scheme’s small set of built-in procedures. Libbug provides procedures for list processing, streams, control structures, general-purpose evaluation at compile-time, and a compile-time test framework written in only 7 lines of code! Programs written using libbug optionally may be programmed in a relatively unobstructive "literate programming" style, so that a program can be read linearly in a book form.

1.1. Prerequisites

The reader is assumed to be somewhat familiar with Scheme, with Common Lisp-style macros, and with recursive design. If the book proves too difficult for you, read "Simply Scheme"
[available on-line for no cost]
or "The Little Schemer". Since libbug uses Gambit Scheme’s Common Lisp-style macros, the author recommends reading "On Lisp" <[onlisp]>
[available on-line for no cost]
. The other books listed in the bibliography, all of which inspired ideas for this book, are recommended reading but are not necessary to understand the contents of this book.

1.2. Order of Parts

This book is a "literate program", meaning that the source code of libbug is embedded within this book, and that the book is intended to be able to be read linearly. As such, new procedures defined are dependent upon procedures either defined in standard Gambit Scheme or which have already been defined earlier in libbug. In writing the book, however, it became quite apparent that the foundation upon which libbug is constructed is by far the most difficult material. Reading the book in the order which the compiler compiles the source would cause the reader to quickly get lost in the "how", before understanding "why".

As such, the ordering of the book was rearranged in an effort to keep the reader engaged and curious. The book begins with "Part 1, The Implementation of Libbug" and ends with "Part 2, Foundations Of Libbug". The Gambit compiler, however, compiles Part 2 first, then Part 1.

1.3. Conventions

Code which is part of libbug will be outlined and will have line numbers on the left.

    1: ;; This is part of libbug.

Example code which is not part of libbug will not be outlined nor will it have line numbers.

(+ 1 ("This is NOT part of libbug"))

Some examples within this book show interaction with "gsi". Such examples will look like the following:

> (+ 1 2)
3

The line on which the user entered text begins with a ">". The result of evaluating that line appears on the subsequent line. In this case, 1 added to 2 evaluates to 3.

1.4. Getting the Source Code And Building

The Scheme source code is located at http://github.com/billsix/bug. The Scheme files produce the libbug library, as well as this book. Currently the code works on various distributions of Linux, on FreeBSD, and on Mac OS X. The build currently does not work on Windows.

The prerequisites for building libbug are a C compiler
[such as GCC]
, Autoconf, Automake, and Gambit Scheme
[http://gambitscheme.org]
version 4.8 or newer.

To compile the book and library, execute the following on the command line:

$ ./autogen.sh
$ ./configure --prefix=$BUG_HOME --enable-html
$ make
$ make install

The argument to "prefix" is the location into which libbug will be installed when "make install" is executed. "$BUG_HOME" is an environment variable that I have not defined, so the reader should substitute "$BUG_HOME" with an actual filesystem path.
"--enable-html" means to build this book as a HTML via asciidoc. To disable the creation of the html, substitute "--enable-html=no".

After installing libbug, you should set the following environment variables.

export PATH=$BUG_HOME/bin:$PATH
export PKG_CONFIG_PATH=$BUG_HOME/lib/pkgconfig/
export LD_LIBRARY_PATH=$BUG_HOME/lib:$LD_LIBRARY_PATH
export LIBRARY_PATH=$BUG_HOME/lib:$LIBRARY_PATH

1.5. Creating Your Own Project

$ bug-create-project testProject 1.0 "Jane Doe <jane@doe.com>"
$ cd testProject/
$ source env.sh
$ ./autogen.sh
$ ./configure --prefix=$BUILD_DIR
....
....
$ make
.....
"FIRST 10 PRIMES"
(2 3 5 7 11 13 17 19 23 29)
....
....
$ make install
....
$ cd $BUILD_DIR
$ ./bin/testProject
"FIRST 10 PRIMES"
(2 3 5 7 11 13 17 19 23 29)

Of particular note is that a "FIRST 10 PRIMES", and the 10 values, were printed during the compilation of the source code in the "make" phase.

1.6. Comparison of Compile-Time Computations in Other Languages

What exactly is computation at compile-time? An introduction to the topic is provided in Appendix [appendix1] demonstrated in languages of more widespread use (C and C++), along with a comparison of their expressive power.

The Implementation of Libbug

1. Introductory Procedures

This chapter begins the definition of libbug’s standard library of Scheme procedures and macros
[The code within chapters [beginninglibbug] through [endinglibbug] (inclusive) is found in "src/main.bug.scm".]
, along with tests which are run as part of the compilation process. If any test fails, the compiler will exit in error, much like a type error in a statically-typed language.

To gain such functionality libbug cannot be defined using Gambit Scheme’s "define", "define-macro", and "define-structure", since they only define variables and procedures for use at run-time
[well… that statement is not true for "define-macro", but it makes for a simpler explanation upon first reading]
. Instead, definitions within libbug use "libbug-private#define", "libbug-private#define-macro", and "libbug-private##define-structure"
[Per convention within libbug, procedures namespaced to "libbug-private" are not compiled into the library; such procedures are meant for private use within the implementation of libbug.]
, which are implemented in Chapter [buglang]. How they are implemented is not relevant yet, since the use of these procedure-defining procedures will be explained incrementally.

    1: (include "bug-language.scm")
    2: (##namespace ("libbug-private#" define define-macro define-structure))

On line 1, the code which makes computation at compile-time possible is imported. That code is defined in Chapter [buglang].
On line 2, Gambit’s "##namespace" procedure is invoked, ensuring that all unnamespaced uses of "define", "define-macro", and "define-structure" will use libbug’s version of those procedures instead of Gambit’s.
On line 3, all unnamespaced uses of "if" will use libbug’s version.

1.1. noop

The first definition is "noop" (meaning "no operation"), a procedure which takes zero arguments and which evaluates to the symbol 'noop.

    1: (define noop
    2:   (lambda () 'noop))

On line 1, the libbug-private#define macro
[defined in section [libbugdefine]]
is invoked.
On line 1, the variable name "noop".
On line 2, the lambda literal to be stored into the variable. Libbug includes a Scheme preprocessor "bug-gscpp", which expands lambda literals into lambdas. In this case, "bug-gscpp" expands

['noop]

into

(lambda () 'noop)

    1: (unit-test
    2:  (equal? (noop) 'noop))

On line 1, an invocation of "unit-test". In this case, "unit-test" takes one parameter, which is a test to be run at compile-time.
On line 2, an expression which evaluates to a boolean. This is a test which will be evaluated at compile-time. Should the test fail, the compilation of libbug will fail and neither the shared library nor the document which you are currently reading will be created. Tests are not present in the created library.

"noop" does not look useful at first glance, but it is used when a procedure of zero arguments is required but the resulting value of it is not. For instance, "noop" is used as a default "exception-handler" for many procedures within libbug.

1.2. identity

"identity" is a procedure of one argument which evaluates to its argument. <[calculi]>

    1: (define identity
    2:   (lambda (x) x))

"unit-test" can take more than one test as parameters.

    1: (unit-test
    2:  (equal? "foo" (identity "foo"))
    3:  (equal? identity (identity identity)))

1.3. all?

Like regular Scheme’s "and", but takes a list instead of a variable number of arguments, and all elements of the list are evaluated before "all?" is applied.

    1: (define all?
    2:   (lambda (l)
    3:     (if (null? l)
    4:         #t
    5:         (if (car l)
    6:             (all? (cdr l))
    7:             #f))))

    1: (unit-test
    2:  (all? '())
    3:  (all? '(1))
    4:  (all? '(#t))
    5:  (all? '(#t #t))
    6:  (not (all? '(#f)))
    7:  (not (all? '(#t #t #t #f))))

Tests in libbug are defined for two purposes. Firstly, to ensure that the expected behavior of a procedure does not change when the source code has changed. Secondly, as a form of documentation. Libbug is unique
[as far as the author knows]
in that the tests are collocated with the procedure definitions. The reader is encouraged to read the tests for a procedure before reading the implementation; since in many cases, the tests are designed specifically to guide the reader through the implementation.

1.4. satisfies?

When writing multiple tests, why explicitly invoke the procedure repeatedly with varying inputs and outputs, as was done for "all?"? Instead, provide the procedure and a list of input/output pairs
[Within libbug, a parameter named "f" usually means the parameter is a procedure.]
.

    1: (define satisfies?
    2:   (lambda (f list-of-pairs)
    3:     (all? (map (lambda (pair) (equal? (f (car pair))
    4:                                       (cadr pair)))
    5:                list-of-pairs))))

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (x) (+ x 1))
    4:   '(
    5:     (0 1)
    6:     (1 2)
    7:     (2 3)
    8:     ))
    9:  (satisfies?
   10:   all?
   11:   '(
   12:     (() #t)
   13:     ((1) #t)
   14:     ((#t) #t)
   15:     ((#t #t) #t)
   16:     ((#f) #f)
   17:     ((#t #t #t #f) #f)))
   18:  )

1.5. while

Programmers who are new to the Scheme language may be surprised that the language provides no built-in syntax for looping, such as "for" or "while". A better question is why don’t other languages provide primitives from which you can create those looping constructs yourself? "Take the red pill."
[Within libbug, a parameter named "pred?" or "p?" usually means the parameter is a predicate, meaning a procedure which returns true or false.]

    1: (define while
    2:   (lambda (pred? body)
    3:     (let while ((val 'noop))
    4:       (if (pred?)
    5:           (while (body))
    6:           val))))

    1: (unit-test
    2:  (let ((a 0))
    3:    (and (equal? (while (lambda () (< a 5))
    4:                        (lambda () (set! a (+ a 1))))
    5:                 #!void)
    6:         (equal? a 5)))
    7:  (let ((a 0))
    8:    (and (equal? (while (lambda () (< a 5))
    9:                        (lambda () (set! a (+ a 1))
   10:                                'foo))
   11:                 'foo)
   12:         (equal? a 5))))

1.6. numeric-if

A conditional expression for numbers, based on their sign. "numeric-if" uses Gambit’s keyword syntax. "ifPositive", "ifZero", and "ifNegative" are optional arguments, each with their default value as the value in the "noop" variable.

    1: (define numeric-if
    2:   (lambda (n #!key (ifPositive noop) (ifZero noop) (ifNegative noop))
    3:     (if (> n 0)
    4:         (ifPositive)
    5:         (if (= n 0)
    6:             (ifZero)
    7:             (ifNegative)))))

<[onlisp]>

Keyword arguments are optionally passed to the procedure, and use the following syntax.

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (n)
    4:     (numeric-if n
    5:                 ifPositive: (lambda () 'pos)
    6:                 ifZero: (lambda () 'zero)
    7:                 ifNegative: (lambda () 'neg)))
    8:   '(
    9:     (5 pos)
   10:     (0 zero)
   11:     (-5 neg)
   12:     ))
   13:  (satisfies?
   14:   (lambda (n)
   15:     (numeric-if n
   16:                 ifZero: (lambda () 'zero)))
   17:   '(
   18:     (5 noop)
   19:     (0 zero)
   20:     (-5 noop)
   21:     ))
   22:  )

1.7. atom?

    1: (define atom?
    2:   (lambda (x)
    3:     (or (number? x)
    4:         (symbol? x)
    5:         (boolean? x)
    6:         (string? x)
    7:         (char? x))))

[Within libbug, a parameter named "x" usually means the parameter can be of any type.]

    1: (unit-test
    2:  (satisfies?
    3:   atom?
    4:   '(
    5:     (1 #t)
    6:     (1/3 #t)
    7:     (a #t)
    8:     (#t #t)
    9:     (#f #t)
   10:     ("string" #t)
   11:     (#\c #t)
   12:     ((make-vector 3) #f)
   13:     (() #f)
   14:     ((a) #f)
   15:     ))
   16:  )

1.8. complement

    1: (define complement
    2:   (lambda (f)
    3:     (lambda (#!rest args)
    4:       (not (apply f args)))))

<[onlisp]>

    1: (unit-test
    2:  (satisfies?
    3:   pair?
    4:   '(
    5:     (1 #f)
    6:     ((1 2) #t)
    7:     ))
    8:  (satisfies?
    9:   (complement pair?)
   10:   '(
   11:     (1 #t)
   12:     ((1 2) #f)
   13:     ))
   14:  )

2. Lists

2.1. copy

Creates a shallow copy of the list
[meaning the list structure itself is copied, but not the data to which each node points.]

[Within libbug, a parameter named "l" usually means the parameter is a list.]
.

    1: (define copy
    2:   (lambda (l)
    3:     (map identity l)))

    1: (unit-test
    2:  (let ((a '(1 2 3 4 5)))
    3:    (and (equal? a (copy a))
    4:         (not (eq? a (copy a)))))
    5:  )

For a thorough description of "equal?" vs "eq?", see <[schemeprogramanguage]>.

2.2. proper?

Tests that the last element of the list is the sentinel value "'()". Will not terminate on a circular list.

    1: (define proper?
    2:   (lambda (l)
    3:     (if (null? l)
    4:         #t
    5:         (if (pair? l)
    6:             (proper? (cdr l))
    7:             #f))))

    1: (unit-test
    2:  (satisfies?
    3:   proper?
    4:   '(
    5:     (() #t)
    6:     ((4) #t)
    7:     ((1 2) #t)
    8:     (4 #f)
    9:     ((1 2 . 5) #f)
   10:     )))

2.3. first

    1: (define first
    2:   (lambda (l #!key (onNull noop))
    3:     (if (null? l)
    4:         (onNull)
    5:         (car l))))

<[ss]>

    1: (unit-test
    2:  (satisfies?
    3:   first
    4:   '(
    5:     (() noop)
    6:     ((1 2 3) 1)
    7:     ))
    8:  (satisfies?
    9:   (lambda (l) (first l onNull: (lambda () 5)))
   10:   '(
   11:     (() 5)
   12:     ((1 2 3) 1)
   13:     )))

2.4. but-first

    1: (define but-first
    2:   (lambda (l #!key (onNull noop))
    3:     (if (null? l)
    4:         (onNull)
    5:         (cdr l))))

<[ss]>

    1: (unit-test
    2:  (satisfies?
    3:   but-first
    4:   '(
    5:     (() noop)
    6:     ((1 2 3) (2 3))
    7:     ))
    8:  (satisfies?
    9:   (lambda (l) (but-first l onNull: (lambda () 5)))
   10:   '(
   11:     (() 5)
   12:     ((1 2 3) (2 3))
   13:     )))

2.5. last

    1: (define last
    2:   (lambda (l #!key (onNull noop))
    3:     (if (null? l)
    4:         (onNull)
    5:         (let last ((l l))
    6:           (if (null? (cdr l))
    7:               (car l)
    8:               (last (cdr l)))))))

<[ss]>

    1: (unit-test
    2:  (satisfies?
    3:   last
    4:   '(
    5:     (() noop)
    6:     ((1) 1)
    7:     ((2 1) 1)
    8:     ))
    9:  (satisfies?
   10:   (lambda (l) (last l onNull: (lambda () 5)))
   11:   '(
   12:     (() 5)
   13:     ((2 1) 1)
   14:     )))

2.6. but-last

    1: (define but-last
    2:   (lambda (l #!key (onNull noop))
    3:     (if (null? l)
    4:         (onNull)
    5:         (let but-last ((l l))
    6:           (if (null? (cdr l))
    7:               '()
    8:               (cons (car l)
    9:                     (but-last (cdr l))))))))

<[ss]>

    1: (unit-test
    2:  (satisfies?
    3:   but-last
    4:   '(
    5:     (() noop)
    6:     ((1) ())
    7:     ((2 1) (2))
    8:     ((3 2 1) (3 2))
    9:     ))
   10:  (satisfies?
   11:   (lambda (l) (but-last l onNull: (lambda () 5)))
   12:   '(
   13:     (() 5)
   14:     ((3 2 1) (3 2))
   15:     ))
   16:  )

2.7. filter

    1: (define filter
    2:   (lambda (p? l)
    3:     (let filter ((l l))
    4:       (if (null? l)
    5:           '()
    6:           (let ((first (car l)))
    7:             (if (p? first)
    8:                 (cons first (filter (cdr l)))
    9:                 (filter (cdr l))))))))

<[ss]>
[Simply Scheme has an excellent discussion on section on Higher-Order Functions and their combinations <[ss]>]
. <[sicp]>.

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (l) (filter (lambda (x) (not (= 4 x)))
    4:                       l))
    5:   '(
    6:     (() ())
    7:     ((4) ())
    8:     ((1 4) (1))
    9:     ((4 1 4) (1))
   10:     ((2 4 1 4) (2 1))
   11:     )))

2.8. remove

    1: (define remove
    2:   (lambda (x l)
    3:     (filter (lambda (y) (not (equal? x y)))
    4:             l)))

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (l) (remove 5 l))
    4:   '(
    5:     ((1 5 2 5 3 5 4 5 5) (1 2 3 4))
    6:     )))

2.9. fold-left

Reduce the list to a scalar by applying the reducing procedure repeatedly, starting from the "left" side of the list
[Within libbug, a parameter named "acc" usually means the parameter is an accumulated value.]
.

    1: (define fold-left
    2:   (lambda (f acc l)
    3:     (let fold-left ((acc acc) (l l))
    4:       (if (null? l)
    5:           acc
    6:           (fold-left (f acc
    7:                         (car l))
    8:                      (cdr l))))))

<[sicp]>

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (l) (fold-left + 5 l))
    4:   '(
    5:     (() 5)
    6:     ((1) 6)
    7:     ((1 2) 8)
    8:     ((1 2 3 4 5 6) 26)
    9:     ))

Understanding the first test may give the reader false confidence in understanding "fold-left". To understand how "fold-left" really works, understand how it works with non-commutative procedures, such as "-".

    1:  (satisfies?
    2:   (lambda (l) (fold-left - 5 l))
    3:   '(
    4:     (() 5)
    5:     ((1) 4)
    6:     ((1 2) 2)
    7:     ((1 2 3 4 5 6) -16))))

2.10. sum

    1: (define sum
    2:   (lambda (l)
    3:     (fold-left + 0 l)))

    1: (unit-test
    2:  (satisfies?
    3:   sum
    4:   '(( (1)    1)
    5:     ( (1 2)  3)
    6:     ( (1 2 3) 6)))
    7:  )

2.11. fold-right

Reduces the list to a scalar by applying the reducing procedure repeatedly, starting from the "right" side of the list

    1: (define fold-right
    2:   (lambda (f acc l)
    3:     (let fold-right ((l l))
    4:       (if (null? l)
    5:           acc
    6:           (f (car l)
    7:              (fold-right (cdr l)))))))

<[sicp]>

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (l) (fold-right + 5 l))
    4:   '(
    5:     (() 5)
    6:     ((1) 6)
    7:     ((1 2) 8)
    8:     ((1 2 3 4 5 6) 26)
    9:     ))
   10:  (satisfies?
   11:   (lambda (l) (fold-right - 5 l))
   12:   '(
   13:     (() 5)
   14:     ((1) -4)
   15:     ((1 2) 4)
   16:     ((1 2 3 4 5 6) 2)))
   17:  )

2.12. scan-left

Like "fold-left", but every intermediate value of "fold-left"s accumulator is an element in the resulting list of "scan-left".

    1: (define scan-left
    2:   (lambda (f acc l)
    3:     (let ((acc-list (list acc)))
    4:       (let scan-left ((acc acc)
    5:                       (l l)
    6:                       (last-cell acc-list))
    7:         (if (null? l)
    8:             acc-list
    9:             (let ((newacc (f acc
   10:                              (car l))))
   11:               (scan-left newacc
   12:                          (cdr l)
   13:                          (begin
   14:                            (set-cdr! last-cell (list newacc))
   15:                            (cdr last-cell)))))))))

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (l) (scan-left + 5 l))
    4:   '(
    5:     (() (5))
    6:     ((1) (5 6))
    7:     ((1 2) (5 6 8))
    8:     ((1 2 3 4 5 6) (5 6 8 11 15 20 26))
    9:     ))
   10:  (satisfies?
   11:   (lambda (l) (scan-left - 5 l))
   12:   '(
   13:     (() (5))
   14:     ((1) (5 4))
   15:     ((1 2) (5 4 2))
   16:     ((1 2 3 4 5 6) (5 4 2 -1 -5 -10 -16))))
   17:  (satisfies?
   18:   (lambda (l) (scan-left * 1 l))
   19:   '(
   20:     (() (1))
   21:     ((2) (1 2))
   22:     ((2 3) (1 2 6))
   23:     ((2 3 4) (1 2 6 24))
   24:     ((2 3 4 5 ) (1 2 6 24 120))
   25:     ))
   26:  )

2.13. append!

Like Scheme’s "append", but recycles the last cons cell, so it is a more efficient computation at the expense of mutating the input.

    1: (define append!
    2:   (lambda (#!rest ls)
    3:     (let ((append! (lambda (second-list first-list)
    4:                      (if (null? first-list)
    5:                          second-list
    6:                          (let ((head first-list))
    7:                            (let append! ((first-list first-list))
    8:                              (if (null? (cdr first-list))
    9:                                  (set-cdr! first-list second-list)
   10:                                  (append! (cdr first-list))))
   11:                            head)))))
   12:       (fold-left append! '() (reverse ls)))))

    1: (unit-test
    2:  (equal? (append! '()
    3:                   '(5))
    4:          '(5))
    5:  (equal? (append! '(1 2 3)
    6:                   '(5))
    7:          '(1 2 3 5))
    8:  (let ((a '(1 2 3))
    9:        (b '(4 5 6)))
   10:    (append! a b '(7))
   11:    (equal? a '(1 2 3 4 5 6 7)))
   12:  (let ((a '(1 2 3))
   13:        (b '(4 5 6)))
   14:    (append! a b '(7) '(8))
   15:    (equal? a '(1 2 3 4 5 6 7 8)))
   16:  )

2.14. flatmap

    1: (define flatmap
    2:   (lambda (f l)
    3:     (fold-left append! '() (map f l))))

<[sicp]>

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (l) (flatmap (lambda (x) (list x
    4:                                          (+ x 1)
    5:                                          (+ x 2)))
    6:                        l))
    7:   '(
    8:     ((10 20) (10 11 12 20 21 22))
    9:     ))
   10:  )

Mutating cons cells which were created in this procedure still respects referential-transparency from the caller’s point of view.

2.15. take

    1: (define take
    2:   (lambda (n l)
    3:     (if (or (null? l)
    4:             (<= n 0))
    5:         '()
    6:         (cons (car l)
    7:               (take (- n 1)
    8:                     (cdr l))))))

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (n) (take n '(a b)))
    4:   '(
    5:     (-1 ())
    6:     (0 ())
    7:     (1 (a))
    8:     (2 (a b))
    9:     (3 (a b))
   10:     )))

2.16. take-while

    1: (define take-while
    2:   (lambda (p? l)
    3:     (let ((not-p? (complement p?)))
    4:       (let take-while ((l l))
    5:         (if (or (null? l)
    6:                 (not-p? (car l)))
    7:             '()
    8:             (cons (car l)
    9:                   (take-while (cdr l))))))))

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (x) (take-while (lambda (y) (not (equal? x y)))
    4:                           '(a b c)))
    5:   '(
    6:     (a ())
    7:     (b (a))
    8:     (c (a b))
    9:     (d (a b c))
   10:     )))

2.17. drop

    1: (define drop
    2:   (lambda (n l)
    3:     (if (or (null? l)
    4:             (<= n 0))
    5:         l
    6:         (drop (- n 1)
    7:               (cdr l)))))

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (n) (drop n '(a b)))
    4:   '(
    5:     (-1 (a b))
    6:     (0 (a b))
    7:     (1 (b))
    8:     (2 ())
    9:     (3 ())
   10:     )))

2.18. drop-while

    1: (define drop-while
    2:   (lambda (p? l)
    3:     (let ((not-p? (complement p?)))
    4:       (let drop-while ((l l))
    5:         (if (or (null? l)
    6:                 (not-p? (car l)))
    7:             l
    8:             (drop-while (cdr l)))))))

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (x) (drop-while (lambda (y) (not (equal? x y)))
    4:                           '(a b c)))
    5:   '(
    6:     (a (a b c))
    7:     (b (b c))
    8:     (c (c))
    9:     (d ())
   10:     (e ())
   11:     )))

2.19. enumerate-interval

    1: (define enumerate-interval
    2:   (lambda (low high #!key (step 1))
    3:     (let enumerate-interval ((low low))
    4:       (if (> low high)
    5:           '()
    6:           (cons low
    7:                 (enumerate-interval (+ low step)))))))

    1: (unit-test
    2:  (equal? (enumerate-interval 1 10)
    3:          '(1 2 3 4 5 6 7 8 9 10))
    4:  (equal? (enumerate-interval 1 10 step: 2)
    5:          '(1 3 5 7 9)))

2.20. any?

    1: (define any?
    2:   (lambda (l)
    3:     (if (null? l)
    4:         #f
    5:         (if (car l)
    6:             #t
    7:             (any? (cdr l))))))

    1: (unit-test
    2:  (satisfies?
    3:   any?
    4:   '(
    5:     (() #f)
    6:     ((1) #t)
    7:     ((#t) #t)
    8:     ((#t #t) #t)
    9:     ((#f) #f)
   10:     ((#t #t #t #f) #t)))
   11:  )

2.21. zip

    1: (define zip
    2:   (lambda (#!rest lsts)
    3:     (let zip ((lsts lsts))
    4:       (if (any? (map null? lsts))
    5:           '()
    6:           (cons (map car lsts)
    7:                 (zip (map cdr lsts)))))))

    1: (unit-test
    2:  (equal? (zip '() '())
    3:          '())
    4:  (equal? (zip '(1) '(4))
    5:          '((1 4)))
    6:  (equal? (zip '(1 2) '(4 5))
    7:          '((1 4)
    8:            (2 5)))
    9:  (equal? (zip '(1 2 3) '(4 5 6))
   10:          '((1 4)
   11:            (2 5)
   12:            (3 6)))
   13:  (equal? (zip '(1) '())
   14:          '())
   15:  (equal? (zip '() '(1))
   16:          '())
   17:  )

    1: (unit-test
    2:  (equal? (zip '() '() '())
    3:          '())
    4:  (equal? (zip '(1 2 3)
    5:               '(4 5 6)
    6:               '(7 8 9))
    7:          '((1 4 7)
    8:            (2 5 8)
    9:            (3 6 9)))
   10:  )

    1: (unit-test
    2:  (equal? (zip '() '() '() '())
    3:          '())
    4:  (equal? (zip '(1 2 3)
    5:               '(4 5 6)
    6:               '(7 8 9)
    7:               '(10 11 12))
    8:          '((1 4 7 10)
    9:            (2 5 8 11)
   10:            (3 6 9 12)))
   11:  )

2.22. zip-with

    1: (define zip-with
    2:   (lambda (f #!rest lsts)
    3:     (let zip ((lsts lsts))
    4:       (if (any? (map null? lsts))
    5:           '()
    6:           (cons (apply f (map car lsts))
    7:                 (zip (map cdr lsts)))))))

    1: (unit-test
    2:  (equal? (zip-with +
    3:                    '()
    4:                    '())
    5:          '())
    6:  (equal? (zip-with +
    7:                    '(1)
    8:                    '(4))
    9:          '(5))
   10:  (equal? (zip-with +
   11:                    '(1 2)
   12:                    '(4 5))
   13:          '(5 7))
   14:  (equal? (zip-with +
   15:                    '(1 2 3)
   16:                    '(4 5 6))
   17:          '(5 7 9))
   18:  (equal? (zip-with +
   19:                    '(1)
   20:                    '())
   21:          '())
   22:  (equal? (zip-with +
   23:                    '()
   24:                    '(1))
   25:          '())
   26:  )

    1: (unit-test
    2:  (equal? (zip-with +
    3:                    '()
    4:                    '()
    5:                    '())
    6:          '())
    7:  (equal? (zip-with +
    8:                    '(1 2 3)
    9:                    '(4 5 6)
   10:                    '(7 8 9))
   11:          '(12 15 18))
   12:  )

    1: (unit-test
    2:  (equal? (zip-with +
    3:                    '()
    4:                    '()
    5:                    '()
    6:                    '())
    7:          '())
    8:  (equal? (zip-with +
    9:                    '(1 2 3)
   10:                    '(4 5 6)
   11:                    '(7 8 9)
   12:                    '(10 11 12))
   13:          '(22 26 30))
   14:  )

2.23. permutations

    1: (define permutations
    2:   (lambda (l)
    3:     (if (null? l)
    4:         '()
    5:         (let permutations ((l l))
    6:           (if (null? (cdr l))
    7:               (list l)
    8:               (flatmap (lambda (x) (map (lambda (y) (cons x y))
    9:                                         (permutations (remove x l))))
   10:                        l))))))

    1: (unit-test
    2:  (satisfies?
    3:   permutations
    4:   '(
    5:     (() ())
    6:     ((1) ((1)))
    7:     ((1 2) ((1 2)
    8:             (2 1)))
    9:     ((1 2 3) ((1 2 3)
   10:               (1 3 2)
   11:               (2 1 3)
   12:               (2 3 1)
   13:               (3 1 2)
   14:               (3 2 1)))
   15:     )))

Inspired by <[sicp]>, although I think they have a slight mistake in their code. Given their definition (permutations '()) evaluates to '(()), instead of '().

2.24. cartesian-product

    1: (define cartesian-product
    2:   (lambda (lol)
    3:     (##define cp
    4:       (lambda (lol)
    5:         (cond
    6:          ((null? (cdr lol))
    7:           (map list (car lol)))
    8:          (#t
    9:           (flatmap (lambda (x) (map (lambda (y) (cons x y))
   10:                                     (cp (cdr lol))))
   11:                    (car lol))))))
   12:     (cond ((null? lol) '())
   13:           (#t (cp lol)))))

    1: (unit-test
    2:  (equal? (cartesian-product '())
    3:          '())
    4:  (equal? (cartesian-product '((1 2 3)))
    5:          '((1) (2) (3)))
    6:  (equal? (cartesian-product '((1 2 3)
    7:                               (4 5 6)))
    8:          '((1 4)
    9:            (1 5)
   10:            (1 6)
   11:            (2 4)
   12:            (2 5)
   13:            (2 6)
   14:            (3 4)
   15:            (3 5)
   16:            (3 6)))

    1:  (equal? (cartesian-product '((1 2 3)
    2:                               (4 5 6)
    3:                               (7 8 9)))
    4:          '((1 4 7)
    5:            (1 4 8)
    6:            (1 4 9)
    7:            (1 5 7)
    8:            (1 5 8)
    9:            (1 5 9)
   10:            (1 6 7)
   11:            (1 6 8)
   12:            (1 6 9)
   13:            (2 4 7)
   14:            (2 4 8)
   15:            (2 4 9)
   16:            (2 5 7)
   17:            (2 5 8)
   18:            (2 5 9)
   19:            (2 6 7)
   20:            (2 6 8)
   21:            (2 6 9)
   22:            (3 4 7)
   23:            (3 4 8)
   24:            (3 4 9)
   25:            (3 5 7)
   26:            (3 5 8)
   27:            (3 5 9)
   28:            (3 6 7)
   29:            (3 6 8)
   30:            (3 6 9)))
   31:  )

2.25. ref-of

The inverse of list-ref.

    1: (define ref-of
    2:   (lambda (l x #!key (onMissing noop))
    3:     (if (null? l)
    4:         (onMissing)
    5:         (let ref-of ((l l)
    6:                      (index 0))
    7:           (if (equal? (car l) x)
    8:               index
    9:               (if (null? (cdr l))
   10:                   (onMissing)
   11:                   (ref-of (cdr l) (+ index 1))))))))

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (x) (ref-of '(a b c d e f g) x))
    4:   '(
    5:     (z noop)
    6:     (a 0)
    7:     (b 1)
    8:     (g 6)
    9:     ))
   10:  )

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (x) (ref-of '(a b c d e f g)
    4:                       x
    5:                       onMissing: (lambda () 'missing)))
    6:   '(
    7:     (z missing)
    8:     (a 0)
    9:     ))
   10:  )

    1: (unit-test
    2:  (let ((l '(a b c d e f g)))
    3:    (satisfies?
    4:     (lambda (x) (list-ref l (ref-of l x)))
    5:     '(
    6:       (a a)
    7:       (b b)
    8:       (g g)
    9:       )))
   10:  )

2.26. list-set!

    1: ;; TODO - handle case where index is too large
    2: ;; N.B this is called list-sef! instead of list-ref-set!
    3: ;;  to facilitate use by setf!, as setf! drops the -ref suffix
    4: (define list-set!
    5:   (lambda (l index val)
    6:     (if (equal? 0 index)
    7:         (set-car! l val)
    8:         (list-set! (cdr l) (- index 1) val))))

    1: (unit-test
    2:  (let ((foo '(bar baz quux)))
    3:    (list-set! foo 0 'blah)
    4:    (equal? foo '(blah baz quux)))
    5:  (let ((foo '(bar baz quux)))
    6:    (list-set! foo 1 'blah)
    7:    (equal? foo '(bar blah quux))
    8:    )
    9:  )

2.27. partition

Partitions the input list into two lists, with the criterion being whether or not the application of the procedure "p?" to each element of the input list evaluated to true or false.

    1: (define partition
    2:   (lambda (l p?)
    3:     (let partition ((l l)
    4:                     (trueList '())
    5:                     (falseList '()))
    6:       (if (null? l)
    7:           (list trueList falseList)
    8:           (let ((head (car l)))
    9:             (if (p? head)
   10:                 (partition (cdr l)
   11:                            (cons head trueList)
   12:                            falseList)
   13:                 (partition (cdr l)
   14:                            trueList
   15:                            (cons head falseList))))))))

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (l) (partition l (lambda (x) (<= x 3))))
    4:   '(
    5:     (() (()
    6:          ()))
    7:     ((3 2 5 4 1) ((1 2 3)
    8:                   (4 5)))
    9:     )))

In section [dbind], "destructuring-bind" allows for a more convenient syntax when using "partition".

> (destructuring-bind (trueList falseList)
                     (partition '(3 2 5 4 1)
                                (lambda (x) (<= x 3)))
                     trueList)
(1 2 3)
> (destructuring-bind (trueList falseList)
                     (partition '(3 2 5 4 1)
                                (lambda (x) (<= x 3)))
                     falseList)
(4 5)

2.28. sort

    1: (define sort
    2:   (lambda (l comparison?)
    3:     (let sort ((l l))
    4:       (if (null? l)
    5:           '()
    6:           (let* ((current-node (car l))
    7:                  (p (partition (cdr l)
    8:                                (lambda (x) (comparison? x current-node)))))
    9:             (append! (sort (car p))
   10:                      (cons current-node
   11:                            (sort (cadr p)))))))))

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (l) (sort l <))
    4:   '(
    5:     (() ())
    6:     ((1 3 2 5 4 0) (0 1 2 3 4 5))
    7:     )))

2.29. reverse!

Reverses the list more efficiently by mutating cons cells

    1: (define reverse!
    2:   (lambda (l)
    3:     (if (null? l)
    4:         '()
    5:         (let reverse! ((current-cons-cell l)
    6:                        (reversed-list '()))
    7:           (if (null? (cdr current-cons-cell))
    8:               (begin
    9:                 (set-cdr! current-cons-cell reversed-list)
   10:                 current-cons-cell)
   11:               (let ((rest (cdr current-cons-cell)))
   12:                 (set-cdr! current-cons-cell reversed-list)
   13:                 (reverse! rest current-cons-cell)))))))

    1: (unit-test
    2:  (satisfies?
    3:   reverse!
    4:   '(
    5:     (() ())
    6:     ((1) (1))
    7:     ((2 1) (1 2))
    8:     ((3 2 1) (1 2 3))
    9:     ))
   10:  (let ((x '(1 2 3)))
   11:    (let ((y (reverse! x)))
   12:      (and (equal? y '(3 2 1))
   13:           (equal? x '(1)))))
   14:  )

3. Lifting

From the Haskell wiki
[https://wiki.haskell.org/Lifting]
"lifting is a concept which allows you to transform a function into a corresponding function within another (usually more general) setting".

3.1. string-lift-list

Strings are sequences of characters, just as lists are sequences of arbitrary Scheme objects. "string-lift-list" allows the creation of a context in which strings may be treated as lists(
[Within libbug, a parameter named "s" usually means the parameter is of type string.]
.

    1: (define string-lift-list
    2:   (lambda (f)
    3:     (lambda (#!rest s)
    4:       (list->string
    5:        (apply f
    6:               (map string->list s))))))
    7:

3.2. string-reverse

    1: (define string-reverse
    2:   (string-lift-list reverse!))
    3:

    1: (unit-test
    2:  (satisfies?
    3:   string-reverse
    4:   '(
    5:     ("" "")
    6:     ("foo" "oof")
    7:     ("bar" "rab")
    8:     ))
    9:  )

3.3. string-take

    1: (define string-take
    2:   (lambda (n s)
    3:     (let ((string-take-n (string-lift-list (lambda (l) (take n l)))))
    4:       (string-take-n s))))
    5:

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (s) (string-take 2 s))
    4:   '(
    5:     ("" "")
    6:     ("foo" "fo")
    7:     ))
    8:  )

3.4. string-drop

    1: (define string-drop
    2:   (lambda (n s)
    3:     (let ((string-drop-n (string-lift-list (lambda (l) (drop n l)))))
    4:       (string-drop-n s))))
    5:

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (s) (string-drop 2 s))
    4:   '(
    5:     ("" "")
    6:     ("foo" "o")
    7:     ("foobar" "obar")
    8:     ))
    9:  )

3.5. character-lift-integer

Characters are stored as integer values in computers, but in Scheme they are not treated as numbers. "character-lift-integer" allows the creation of a context in which the characters may be treated as integers.

    1: (define character-lift-integer
    2:   (lambda (f)
    3:     (lambda (#!rest c)
    4:       (integer->char
    5:        (apply f
    6:               (map char->integer c))))))
    7:

    1: (unit-test
    2:  (satisfies?
    3:   (character-lift-integer (lambda (i) (+ i 1)))
    4:   '(
    5:     (#\a #\b)
    6:     (#\b #\c)
    7:     (#\c #\d)
    8:     )))

3.6. string-map

    1: (define string-map
    2:   (lambda (f s)
    3:     (let ((string-map-f (string-lift-list (lambda (l) (map f l)))))
    4:       (string-map-f s))))
    5:

The "Caesar Cipher". <[crypto]>.

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (s)
    4:     (string-map (lambda (c) (let ((transform-char
    5:                                    (character-lift-integer
    6:                                     (lambda (base-char c)
    7:                                       (+ base-char
    8:                                          (modulo (+ (- c base-char)
    9:                                                     3)
   10:                                                  26))))))
   11:                               (transform-char #\a c)))
   12:                 s))
   13:   '(
   14:     ("" "")
   15:     ("abc" "def")
   16:     ("nop" "qrs")
   17:     ("xyz" "abc")
   18:     ))
   19:  )

3.7. symbol-lift-list

Symbols are sequences of characters, just as lists are sequences of arbitrary Scheme objects. "symbol-lift-list" allows the creation of a context in which the symbols may be treated as lists.

    1: (define symbol-lift-list
    2:   (lambda (f)
    3:     (lambda (#!rest sym)
    4:       (string->symbol
    5:        (apply (string-lift-list f)
    6:               (map symbol->string sym))))))
    7:

    1: (unit-test
    2:  (satisfies?
    3:   (symbol-lift-list reverse)
    4:   '(
    5:     (foo oof)
    6:     (bar rab)
    7:     ))
    8:  (equal? ((symbol-lift-list append!) 'foo 'bar)
    9:          'foobar)
   10:  )

4. Macros

Although many concepts first implemented in Lisp (conditional expressions, garbage collection, procedures as first-class objects) have been appropriated into mainstream languages, the one feature of Lisp which remains difficult for other languages to copy is also Lisp’s best: macros. A Lisp macro is procedure for application at compile-time which takes unevaluated Lisp code as a parameter and transforms it into a new form of unevaluated code before further evaluation. Essentially, they are a facility by which a programmer may augment the compiler with new functionality while the compiler is compiling.

Transforming unevaluated code into new code introduces a few problems of which the macro writer must be aware. First, if the macro needs to create a new variable within the expanded code, the new variable must have a name, which will be generated during macro-expansion. This new name inserted into the generated code may clash with a variable name in the input form; resulting in expanded code which does not function correctly. Second, if unevaluated code which causes side-effects is inserted more than once into the generated code, the expanded code will likely have unintended side-effects from the caller of the macro’s point of view.

The first problem is solved using "gensym"s. The second problem is solved using "once-only".

For a much fuller explanation of the aforementioned problems, the author recommends reading "On Lisp" by Paul Graham <[onlisp]>.

4.1. compose

    1: (define-macro compose
    2:   (lambda (#!rest fs)
    3:     (if (null? fs)
    4:         'identity
    5:         (let* ((last-fn-is-lambda-literal
    6:                 (and (list? (last fs))
    7:                      (not (null? (last fs)))
    8:                      (equal? 'lambda
    9:                              (car (last fs)))))
   10:                (args (if last-fn-is-lambda-literal
   11:                          (cadr (last fs))
   12:                          (gensym))))
   13:           `(lambda ,(if last-fn-is-lambda-literal
   14:                         args
   15:                         `(#!rest ,args))
   16:              ,(let compose ((fs fs))
   17:                 (if (null? (cdr fs))
   18:                     (if last-fn-is-lambda-literal
   19:                         `(begin ,@(cddar fs))
   20:                         `(apply ,(car fs)
   21:                                 ,args))
   22:                     `(,(car fs)
   23:                       ,(compose (cdr fs))))))))))

<[onlisp]>

On line 1, the "libbug-private#define-macro" macro
[defined in section [libbugdefinemacro]]
is invoked. Besides defining the macro, "libbug-private#define-macro" also exports the namespace definition and the macro definitions to external files, for consumption by programs which link against libbug.

    1: (unit-test
    2:  (equal? (macroexpand-1 (compose))
    3:          'identity)
    4:  (equal? ((eval (macroexpand-1 (compose))) 5)
    5:          5)
    6:  (equal? ((compose) 5)
    7:          5)
    8:  )

Macro-expansions occur during compile-time, so how should a programmer test the resulting form? Libbug provides "macroexpand-1" which treats the macro as a procedure which transforms lists into lists, and as such is able to be tested
["macroexpand-1" expands the unevaluated code passed to the macro into a new unevaluated form, which would have been compiled by the compiler if "macroexpand-1" had been absent. But, how should "gensym" evaluate, since by definition it creates symbols which cannot be typed by the programmer into a program? During the expansion of "macroexpand-1", "gensym" is overridden by a procedure which expands into typable symbols like "gensymed-var1", "gensymed-var2", etc. Each call during a macro-expansion generates a new, unique symbol. Although the generated symbol may clash with symbols in the expanded code, this does not break "gensym" for run-time evaluation, since run-time "gensym" remains not overridden. Although testing code within libbug "eval"s code generated from "macroexpand-1", the author advises against doing such in compiled code. ]
.

    1: (unit-test
    2:  (equal? (macroexpand-1 (compose (lambda (x) (* x 2))))
    3:          '(lambda (x) (begin (* x 2))))
    4:  (equal? ((eval (macroexpand-1 (compose (lambda (x) (* x 2)))))
    5:           5)
    6:          10)
    7:  (equal? ((compose (lambda (x) (* x 2)))
    8:           5)
    9:          10)
   10:  )
   11: (unit-test
   12:  (equal? (macroexpand-1 (compose (lambda (x) (+ x 1))
   13:                                  (lambda (y) (* y 2))))
   14:          '(lambda (y)
   15:             ((lambda (x) (+ x 1))
   16:              (begin (* y 2)))))
   17:  (equal? ((compose (lambda (x) (+ x 1))
   18:                    (lambda (y) (* y 2)))
   19:           5)
   20:          11)
   21:  )
   22: (unit-test
   23:  (equal? (macroexpand-1 (compose (lambda (x) (/ x 13))
   24:                                  (lambda (y) (+ y 1))
   25:                                  (lambda (z) (* z 2))))
   26:          '(lambda (z)
   27:             ((lambda (x) (/ x 13))
   28:              ((lambda (y) (+ y 1))
   29:               (begin (* z 2))))))
   30:  (equal? ((compose (lambda (x) (/ x 13))
   31:                    (lambda (y) (+ y 1))
   32:                    (lambda (z) (* z 2)))
   33:           5)
   34:          11/13)
   35:  )
   36: (unit-test
   37:  (equal? (macroexpand-1 (compose not +))
   38:          '(lambda (#!rest gensymed-var1)
   39:             (not (apply + gensymed-var1))))
   40:  (equal? ((compose not +) 1 2)
   41:          #f)
   42:  )
   43:

4.2. aif

    1: (define-macro aif
    2:   (lambda (bool ifTrue #!rest ifFalse)
    3:     `(let ((bug#it ,bool))
    4:        (if bug#it
    5:            ,ifTrue
    6:            ,@(if (not (null? ifFalse))
    7:                  ifFalse
    8:                  (list #f))))))

Although variable capture <[onlisp]> is generally avoided, there are instances in which variable capture is desirable <[onlisp]>. Within libbug, variables intended for capture are fully qualified with a namespace to ensure that the variable is captured.

<[onlisp]>

    1: (unit-test
    2:  (equal? (macroexpand-1 (aif (+ 5 10)
    3:                              (* 2 bug#it)))
    4:          '(let ((bug#it (+ 5 10)))
    5:             (if bug#it
    6:                 (* 2 bug#it)
    7:                 #f)))
    8:  (equal? (aif (+ 5 10)
    9:               (* 2 bug#it))
   10:          30)
   11:  (equal? (aif #f
   12:               (* 2 bug#it))
   13:          #f)
   14:  (equal? (aif #f
   15:               (* 2 bug#it))
   16:          #f)
   17:  (equal? (macroexpand-1 (aif #f
   18:                              (* 2 bug#it)
   19:                              5))
   20:          '(let ((bug#it #f))
   21:             (if bug#it
   22:                 (* 2 bug#it)
   23:                 5)))
   24:  (equal? (aif #f
   25:               (* 2 bug#it)
   26:               5)
   27:          5)
   28:  )

4.3. with-gensyms

"with-gensyms" is a macro to be invoked from other macros. It is a utility to minimize repetitive calls to "gensym".

    1: (define-macro with-gensyms
    2:   (lambda (symbols #!rest body)
    3:     `(let ,(map (lambda (symbol) `(,symbol (gensym)))
    4:                 symbols)
    5:        ,@body)))

<[onlisp]>

    1: (unit-test
    2:  (equal? (macroexpand-1 (with-gensyms (foo bar baz)
    3:                                       `(begin
    4:                                          (pp ,foo)
    5:                                          (pp ,bar)
    6:                                          (pp ,baz))))
    7:          '(let ((foo (gensym))
    8:                 (bar (gensym))
    9:                 (baz (gensym)))
   10:             `(begin
   11:                (pp ,foo)
   12:                (pp ,bar)
   13:                (pp ,baz))))
   14:  )

4.4. once-only

Sometimes macros need to put two or more copies of an argument into the generated code. But that can cause that form to be evaluated multiple times, possibly with side-effects, which is seldom expected by the caller.

> (define-macro double (lambda (x) `(+ ,x ,x)))
> (double 5)
10

The caller of "double" should reasonably expect the argument to "double" only to be evaluated once only, because that’s how Scheme usually works.

> (define foo 5)
> (double (begin (set! foo (+ foo 1))
                foo))
13

"once-only" allows a macro-writer to ensure that a variable is evaluated only once in the generated code.

> (define-macro double (lambda (x) (once-only (x) `(+ ,x ,x))))
> (define foo 5)
> (double (begin (set! foo (+ foo 1))
                foo))
12

Like "with-gensyms", "once-only" is a macro to be used by other macros. Code which generates code which generates code. Unlike "with-gensyms", which wraps its argument with a new context to be used for later macro-expansions, "once-only" needs to defer binding the variable to a "gensym"-ed variable until the second macro-expansion. As such, it is the most difficult macro is this book.

    1: (define-macro once-only
    2:   (lambda (symbols #!rest body)
    3:     (let ((gensyms (map (lambda (s) (gensym))
    4:                         symbols)))
    5:       `(list 'let
    6:              (append ,@(map (lambda (g s) `(if (atom? ,s)
    7:                                                '()
    8:                                                (list (list (quote ,g)
    9:                                                            ,s))))
   10:                             gensyms
   11:                             symbols))
   12:              ,(append (list 'let
   13:                             (map (lambda (s g) (list s
   14:                                                      `(if (atom? ,s)
   15:                                                           ,s
   16:                                                           (quote ,g))))
   17:                                  symbols
   18:                                  gensyms))
   19:                       body)))))

<[paip]>

"atom"s are handled as a special case to minimize the creation of "gensym"ed variables since evaluation of "atom"s causes no side effects, thus causes no problems from multiple evaluation.

4.4.1. First Macro-expansion

    1: (unit-test
    2:  (equal? (macroexpand-1 (once-only (x y) `(+ ,x ,y ,x)))
    3:          `(list 'let
    4:                 (append (if (atom? x)
    5:                             '()
    6:                             (list (list 'gensymed-var1 x)))
    7:                         (if (atom? y)
    8:                             '()
    9:                             (list (list 'gensymed-var2 y))))
   10:                 (let ((x (if (atom? x)
   11:                              x
   12:                              'gensymed-var1))
   13:                       (y (if (atom? y)
   14:                              y
   15:                              'gensymed-var2)))
   16:                   `(+ ,x ,y ,x)))))

4.4.2. The Second Macro-expansion

    1: (unit-test
    2:  (equal? (eval `(let ((x 5)
    3:                       (y 6))
    4:                   ,(macroexpand-1
    5:                     (once-only (x y)
    6:                                `(+ ,x ,y ,x)))))
    7:          `(let () (+ 5 6 5)))
    8:  (equal? (eval `(let ((x '(car foo))
    9:                       (y 6))
   10:                   ,(macroexpand-1
   11:                     (once-only (x y)
   12:                                `(+ ,x ,y ,x)))))
   13:          '(let ((gensymed-var1 (car foo)))
   14:             (+ gensymed-var1 6 gensymed-var1)))
   15:  (equal? (eval `(let ((x '(car foo))
   16:                       (y '(baz)))
   17:                   ,(macroexpand-1
   18:                     (once-only (x y)
   19:                                `(+ ,x ,y ,x)))))
   20:          '(let ((gensymed-var1 (car foo))
   21:                 (gensymed-var2 (baz)))
   22:             (+ gensymed-var1 gensymed-var2 gensymed-var1)))
   23:  )
   24:

4.4.3. The Evaluation of the twice-expanded Code

    1: (unit-test
    2:  (equal? (eval (eval `(let ((x 5)
    3:                             (y 6))
    4:                         ,(macroexpand-1
    5:                           (once-only (x y)
    6:                                      `(+ ,x ,y ,x))))))
    7:          16)
    8:  )

5. Generalized Assignment

;;

5.1. setf!

"Rather than thinking about two distinct functions that respectively access and update a storage location somehow deduced from their arguments, we can instead simply think of a call to the access function with given arguments as a name for the storage location." <[cl]>

Create a macro named "setf!" which invokes the appropriate "setting" procedure, based on the given "accessing" procedure
[The implementation is inspired by <[setf]>.]
.

    1: (define-macro setf!
    2:   (lambda (exp val)
    3:     (if (not (pair? exp))
    4:         `(set! ,exp ,val)
    5:         (case (car exp)
    6:           ((car)  `(set-car! ,@(cdr exp) ,val))
    7:           ((cdr)  `(set-cdr! ,@(cdr exp) ,val))
    8:           ((caar) `(setf! (car (car ,@(cdr exp))) ,val))
    9:           ((cadr) `(setf! (car (cdr ,@(cdr exp))) ,val))
   10:           ((cdar) `(setf! (cdr (car ,@(cdr exp))) ,val))
   11:           ((cddr) `(setf! (cdr (cdr ,@(cdr exp))) ,val))
   12:           ((caaar) `(setf! (car (caar ,@(cdr exp))) ,val))
   13:           ((caadr) `(setf! (car (cadr ,@(cdr exp))) ,val))
   14:           ((cadar) `(setf! (car (cdar ,@(cdr exp))) ,val))
   15:           ((caddr) `(setf! (car (cddr ,@(cdr exp))) ,val))
   16:           ((cdaar) `(setf! (cdr (caar ,@(cdr exp))) ,val))
   17:           ((cdadr) `(setf! (cdr (cadr ,@(cdr exp))) ,val))
   18:           ((cddar) `(setf! (cdr (cdar ,@(cdr exp))) ,val))
   19:           ((cdddr) `(setf! (cdr (cddr ,@(cdr exp))) ,val))
   20:           ((caaaar) `(setf! (car (caaar ,@(cdr exp))) ,val))
   21:           ((caaadr) `(setf! (car (caadr ,@(cdr exp))) ,val))
   22:           ((caadar) `(setf! (car (cadar ,@(cdr exp))) ,val))
   23:           ((caaddr) `(setf! (car (caddr ,@(cdr exp))) ,val))
   24:           ((cadaar) `(setf! (car (cdaar ,@(cdr exp))) ,val))
   25:           ((cadadr) `(setf! (car (cdadr ,@(cdr exp))) ,val))
   26:           ((caddar) `(setf! (car (cddar ,@(cdr exp))) ,val))
   27:           ((cadddr) `(setf! (car (cdddr ,@(cdr exp))) ,val))
   28:           ((cdaaar) `(setf! (cdr (caaar ,@(cdr exp))) ,val))
   29:           ((cdaadr) `(setf! (cdr (caadr ,@(cdr exp))) ,val))
   30:           ((cdadar) `(setf! (cdr (cadar ,@(cdr exp))) ,val))
   31:           ((cdaddr) `(setf! (cdr (caddr ,@(cdr exp))) ,val))
   32:           ((cddaar) `(setf! (cdr (cdaar ,@(cdr exp))) ,val))
   33:           ((cddadr) `(setf! (cdr (cdadr ,@(cdr exp))) ,val))
   34:           ((cdddar) `(setf! (cdr (cddar ,@(cdr exp))) ,val))
   35:           ((cddddr) `(setf! (cdr (cdddr ,@(cdr exp))) ,val))
   36:           (else `(,(let ((append-set!
   37:                           (symbol-lift-list
   38:                            (lambda (l -set! -ref)
   39:                              (append!
   40:                               (if (equal? (reverse -ref)
   41:                                           (take 4 (reverse l)))
   42:                                   (reverse (drop 4
   43:                                                  (reverse l)))
   44:                                   l)
   45:                               -set!)))))
   46:                      (append-set! (car exp)
   47:                                   '-set!
   48:                                   '-ref))
   49:                   ,@(cdr exp)
   50:                   ,val))))))

5.1.1. Updating a Variable Directly

    1: (unit-test
    2:  (equal? (macroexpand-1
    3:           (setf! foo 10))
    4:          '(set! foo 10))
    5:  (let ((a 5))
    6:    (setf! a 10)
    7:    (equal? a 10))
    8:  )

Updating Car, Cdr, … Through Cddddr

Test updating "car".

    1: (unit-test
    2:  (equal? (macroexpand-1
    3:           (setf! (car foo) 10))
    4:          '(set-car! foo 10))
    5:  (let ((foo '(1 2)))
    6:    (setf! (car foo) 10)
    7:    (equal? (car foo) 10))
    8:  )

Test updating "cdr".

    1: (unit-test
    2:  (equal? (macroexpand-1
    3:           (setf! (cdr foo) 10))
    4:          '(set-cdr! foo 10))
    5:  (let ((foo '(1 2)))
    6:    (setf! (cdr foo) 10)
    7:    (equal? (cdr foo) 10))
    8:  (let ((foo '(bar baz quux)))
    9:    (setf! (list-ref foo 2) 'blah)
   10:    (equal? foo '(bar baz blah)))
   11:  )

Testing all of the "car" through "cddddr" procedures would be quite repetitive. Instead, create a list which has an element at each of those accessor procedures, and test each.

    1: (unit-test
    2:  (eval
    3:   `(and
    4:     ,@(map (lambda (x) `(let ((foo '((((the-caaaar)
    5:                                        the-cadaar)
    6:                                       (the-caadar)
    7:                                       ())
    8:                                      ((the-caaadr) the-cadadr)
    9:                                      (the-caaddr)
   10:                                      ()
   11:                                      )))
   12:                           (setf! (,x foo) 10)
   13:                           (equal? (,x foo) 10)))
   14:            '(car
   15:              cdr
   16:              caar cadr
   17:              cdar cddr
   18:              caaar caadr cadar caddr
   19:              cdaar cdadr cddar cdddr
   20:              caaaar caaadr caadar caaddr
   21:              cadaar cadadr caddar cadddr
   22:              cdaaar cdaadr cdadar cdaddr
   23:              cddaar cddadr cdddar cddddr
   24:              ))))
   25:  )

Suffixed By -set!

Test updating procedures where the updating procedure is the name of the getting procedure, suffixed by -set!.

    1: (at-compile-time
    2:  (##define-structure foo bar))
    3:
    4: (unit-test
    5:  (equal? (macroexpand-1
    6:           (setf! (foo-bar f) 10))
    7:          '(foo-bar-set! f 10))
    8:  (begin
    9:    (let ((f (make-foo 1)))
   10:      (setf! (foo-bar f) 10)
   11:      (equal? (make-foo 10)
   12:              f)))
   13:  )

-ref Replaced By -set!

Test updating procedures where the updating procedure is the name of the getting procedure, with the "-ref" suffix removed, replaced with "-set".

    1: (unit-test
    2:  (equal? (macroexpand-1
    3:           (setf! (string-ref s 0) #\q))
    4:          '(string-set! s 0 #\q))
    5:  (let ((s "foobar"))
    6:    (setf! (string-ref s 0) #\q)
    7:    (equal? s "qoobar"))
    8:  (equal? (macroexpand-1
    9:           (setf! (vector-ref v 2) 4))
   10:          '(vector-set! v 2 4))
   11:  (let ((v (vector 1 2 '() "")))
   12:    (setf! (vector-ref v 2) 4)
   13:    (equal? v
   14:            (vector 1 2 4 "")))
   15:  )

5.2. mutate!

Like "setf!", "mutate!" takes a generalized variable as input, but it additionally takes a procedure to be applied to the value of the generalized variable; the result of the application will be stored back into the generalized variable
["mutate!" is used in similar contexts as Common Lisp’s "define-modify-macro" would be, but it is more general, as it allows the new procedure to remain anonymous, as compared to making a new name like "toggle" <[onlisp]>.]
.

    1: (define-macro mutate!
    2:   (lambda (exp f)
    3:     (if (symbol? exp)
    4:         `(setf! ,exp (,f ,exp))
    5:         (let* ((atom-or-binding (map (lambda (x) (if (atom? x)
    6:                                                      x
    7:                                                      (list (gensym) x)))
    8:                                      (cdr exp)))
    9:                (args-of-generalized-var (map (lambda (x) (if (atom? x)
   10:                                                              x
   11:                                                              (car x)))
   12:                                              atom-or-binding)))
   13:           `(let ,(filter (complement atom?) atom-or-binding)
   14:              (setf! (,(car exp) ,@args-of-generalized-var)
   15:                     (,f (,(car exp) ,@args-of-generalized-var))))))))

    1: (unit-test
    2:  (equal? (macroexpand-1 (mutate! foo not))
    3:          '(setf! foo (not foo)))
    4:  (let ((foo #t))
    5:    (and
    6:     (begin
    7:       (mutate! foo not)
    8:       (equal? foo #f))
    9:     (begin
   10:       (mutate! foo not)
   11:       (equal? foo #t))))
   12:  )

    1: (unit-test
    2:  (equal? (macroexpand-1 (mutate! (vector-ref foo 0) (lambda (n) (+ n 1))))
    3:          '(let ()
    4:             (setf! (vector-ref foo 0)
    5:                    ((lambda (n) (+ n 1)) (vector-ref foo 0)))))
    6:  (let ((foo (vector 0 0 0)))
    7:    (mutate! (vector-ref foo 0) (lambda (n) (+ n 1)))
    8:    (equal? foo
    9:            (vector 1 0 0)))
   10:  (let ((foo (vector 0 0 0)))
   11:    (mutate! (vector-ref foo 2) (lambda (n) (+ n 1)))
   12:    (equal? foo
   13:            (vector 0 0 1)))
   14:  )

    1: (unit-test
    2:  (equal? (macroexpand-1
    3:           (mutate! (vector-ref foo (begin
    4:                                      (setf! index (+ 1 index))
    5:                                      index))
    6:                    (lambda (n) (+ n 1))))
    7:          '(let ((gensymed-var1 (begin
    8:                                  (setf! index (+ 1 index))
    9:                                  index)))
   10:             (setf! (vector-ref foo gensymed-var1)
   11:                    ((lambda (n) (+ n 1)) (vector-ref foo gensymed-var1)))))
   12:  (let ((foo (vector 0 0 0))
   13:        (index 1))
   14:    (mutate! (vector-ref foo (begin
   15:                               (setf! index (+ 1 index))
   16:                               index))
   17:             (lambda (n) (+ n 1)))
   18:    (and (equal? foo
   19:                 (vector 0 0 1))
   20:         (equal? index
   21:                 2)))
   22:  )

5.3. destructuring-bind

"destructuring-bind" is a generalization of "let", in which multiple variables may be bound to values based on their positions within a (possibly nested) list. Look at the tests at the end of the section for an example.

"destructuring-bind" is a complicated macro which can be decomposed into a regular procedure named "tree-of-accessors", and the macro "destructuring-bind"
[This poses a small problem. "tree-of-accessors" is not macroexpanded as it a not a macro, therefore it does not have access to the compile-time "gensym" procedure which allows macro-expansions to be tested. To allow "tree-of-accessors" to be tested independently, as well as part of "destructuring-bind", "tree-of-accessors" takes a procedure named "gensym" as an argument, defaulting to whatever value "gensym" is by default in the environment.]
.

    1: (define tree-of-accessors
    2:   (lambda (pat lst #!key (gensym gensym) (n 0))
    3:     (let tree-of-accessors ((pat pat)
    4:                             (lst lst)
    5:                             (n n))
    6:       (cond ((null? pat)                '())
    7:             ((symbol? pat)              `((,pat (drop ,n ,lst))))
    8:             ((equal? (car pat) '#!rest) `((,(cadr pat) (drop ,n
    9:                                                              ,lst))))
   10:             (else
   11:              (cons (let ((p (car pat)))
   12:                      (if (symbol? p)
   13:                          `(,p (list-ref ,lst ,n))
   14:                          (let ((var (gensym)))
   15:                            (cons `(,var (list-ref ,lst ,n))
   16:                                  (tree-of-accessors p
   17:                                                     var
   18:                                                     0)))))
   19:                    (tree-of-accessors (cdr pat)
   20:                                       lst
   21:                                       (+ 1 n))))))))

    1: (unit-test
    2:  (equal? (tree-of-accessors '() 'gensym-for-list)
    3:          '())
    4:  (equal? (tree-of-accessors 'a 'gensym-for-list)
    5:          '((a (drop 0 gensym-for-list))))
    6:  (equal? (tree-of-accessors '(#!rest d) 'gensym-for-list)
    7:          '((d (drop 0 gensym-for-list))))
    8:  (equal? (tree-of-accessors '(a) 'gensym-for-list)
    9:          '((a (list-ref gensym-for-list 0))))
   10:  (equal? (tree-of-accessors '(a . b) 'gensym-for-list)
   11:          '((a (list-ref gensym-for-list 0))
   12:            (b (drop 1 gensym-for-list))))
   13:  )

    1: (unit-test
    2:  (equal? (tree-of-accessors '(a (b c))
    3:                             'gensym-for-list
    4:                             gensym: (lambda () 'gensymed-var1))
    5:          '((a (list-ref gensym-for-list 0))
    6:            ((gensymed-var1 (list-ref gensym-for-list 1))
    7:             (b (list-ref gensymed-var1 0))
    8:             (c (list-ref gensymed-var1 1)))))
    9:  )

Although a call to "tree-of-accessors" by a macro could be a victim of the multiple-evaluation problem that macros may have, the only caller of "tree-of-accessors" is "destructuring-bind", which passes a "gensymed" symbol to "tree-of-accessors". Therefore "destructuring-bind" does not fall victim to unintended multiple evaluations
[Although the author would like to inline "tree-of-accessors" into the definition of "destructuring-bind", thus making it safe, he could not determine how to write tests for a nested definition.]
.

    1: (define-macro destructuring-bind
    2:   (lambda (pat lst #!rest body)
    3:     (let ((glst (gensym)))
    4:       `(let ((,glst ,lst))
    5:          ,(let create-nested-lets ((bindings
    6:                                     (tree-of-accessors pat
    7:                                                        glst
    8:                                                        gensym: gensym)))
    9:             (if (null? bindings)
   10:                 `(begin ,@body)
   11:                 `(let ,(map (lambda (b) (if (pair? (car b))
   12:                                             (car b)
   13:                                             b))
   14:                             bindings)
   15:                    ,(create-nested-lets (flatmap (lambda (b) (if (pair? (car b))
   16:                                                                  (cdr b)
   17:                                                                  '()))
   18:                                                  bindings)))))))))

<[onlisp]>

    1: (unit-test
    2:  (equal? (macroexpand-1
    3:           (destructuring-bind (a (b . c) #!rest d)
    4:                               '(1 (2 3) 4 5)
    5:                               (list a b c d)))
    6:          '(let ((gensymed-var1 '(1 (2 3) 4 5)))
    7:             (let ((a (list-ref gensymed-var1 0))
    8:                   (gensymed-var2 (list-ref gensymed-var1 1))
    9:                   (d (drop 2 gensymed-var1)))
   10:               (let ((b (list-ref gensymed-var2 0))
   11:                     (c (drop 1 gensymed-var2)))
   12:                 (begin (list a b c d))))))
   13:  (equal? (destructuring-bind (a (b . c) #!rest d)
   14:                              '(1 (2 3) 4 5)
   15:                              (list a b c d))
   16:          '(1 2 (3) (4 5)))
   17:  (equal? (destructuring-bind (trueList falseList)
   18:                              (partition '(3 2 5 4 1)
   19:                                         (lambda (x) (<= x 3)))
   20:                              trueList)
   21:          '(1 2 3))
   22:  (equal? (destructuring-bind (trueList falseList)
   23:                              (partition '(3 2 5 4 1)
   24:                                         (lambda (x) (<= x 3)))
   25:                              falseList)
   26:          '(4 5))
   27:  )

6. Coroutines

https://en.wikipedia.org/wiki/Coroutine

https://en.wikipedia.org/wiki/Generator_(computer_science)

6.1. end-of-generator

    1: (define end-of-generator
    2:   (lambda ()
    3:     'end-of-generator))

6.2. end-of-generator?

    1: (define end-of-generator?
    2:   (lambda (x) (equal? x (end-of-generator))))

6.3. __make-generator_\_

    1: (define __make-generator__
    2:   ;; f is a function which takes one argument, the yield procedure,
    3:   ;; which this procedure, __make-generator__, provides
    4:   (lambda (f)
    5:     ;; each instance of a generator needs two continuations.
    6:     ;; one for the generator instance, and one for the callee
    7:     ;; of the generator instance.
    8:
    9:     ;; so the definition of yield needs to have references
   10:     ;; to each of those continuations.
   11:     ;; create reference to them in  yield's environment
   12:     ;; even though they will not be bound to useful values
   13:     ;; until after yield is defined.
   14:     (##define return-to-callee-continuation 'ignore)
   15:     (##define continue-with-generator-continuation 'ignore)
   16:
   17:     ;; define the implementation "yield" for this generator
   18:     (##define yield-defined-for-this-generator-instance
   19:       ;; when yield is appied within the generator, it must
   20:       ;; return the value to the callee, but must also remember
   21:       ;; where to resume the next time the generator is applied.
   22:       ;;
   23:       ;; though, just like parameter passing in machine code,
   24:       ;; in which values must be passed on the stack/registers
   25:       ;; before control is transferred from the caller to the callee,
   26:       ;; the continuation of the generator must first be captured before
   27:       ;; invoking the callee's continuation with the yielded value.
   28:       (lambda (value-to-be-yielded)
   29:         (call/cc (lambda (yields-continuation)
   30:                    (setf! continue-with-generator-continuation yields-continuation)
   31:                    (return-to-callee-continuation value-to-be-yielded)))))
   32:
   33:
   34:     (set! continue-with-generator-continuation
   35:           (lambda (#!rest send)
   36:             ;; switch back and forth between the two routines
   37:             (f yield-defined-for-this-generator-instance)
   38:             ;; all instances of yield have been called, inform the callee
   39:             ;; that the generator is done
   40:             (return-to-callee-continuation (end-of-generator))))
   41:     ;; this is the code that is invoked every time the generator is applied.
   42:     ;; if the yield expression is defined in a context in which the evaluation
   43:     ;; of yield must evaluate to a value, then pass that value to "send".
   44:     (lambda (#!rest send)
   45:       ;; get the callee's continuation, for use when "yield" is applied
   46:       ;; within the generator
   47:       (call/cc (lambda (callees-continuation)
   48:                  ;; set the callee's continuation into "yield"'s enviroment,
   49:                  ;; so that it may be called from within yield.
   50:                  (setf! return-to-callee-continuation callees-continuation)
   51:                  ;; evaluate f up until the point that yield is invoked.
   52:
   53:                  ;; when that occurs, both return-to-callee-continuation
   54:                  ;; and continue-with-generator-continuation will be
   55:                  ;; defined correctly.
   56:                  (apply continue-with-generator-continuation send))))))

    1: (unit-test
    2:  (let ((g (__make-generator__
    3:            (lambda (yield)
    4:                (yield 'yield-value-one)
    5:                (yield 'yield-value-two)
    6:                (yield 'yield-value-three)))))
    7:    (and (equal? 'yield-value-one (g))
    8:         (equal? 'yield-value-two (g))
    9:         (equal? 'yield-value-three (g))
   10:         (end-of-generator? (g)))))

Yield may be used in a context in which a value is expected. Unlike Python, which distinguishes between these two cases by using either "next" or "send", in this library, the generator is just a regular procedure which takes 0 or 1 parameters.

    1: (unit-test
    2:  (let ((g (__make-generator__
    3:            (lambda (yield)
    4:              (let ((time 0))
    5:                (setf! time (+ time (yield 'yield-value-one)))
    6:                (yield 'yield-value-two)
    7:                (setf! time (+ time (yield 'yield-value-three)))
    8:                (yield time))))))
    9:    (and (equal? 'yield-value-one (g)) ;; just like python, nothing to send on first use
   10:         (equal? 'yield-value-two (g 10)) ;; send 10 to be the value of "(yield 'yield-value-one)"
   11:         (equal? 'yield-value-three (g)) ;;
   12:         (equal? 20 (g 10)) ;; send 10 to be the value of "(yield 'yield-value-three)"
   13:         (end-of-generator? (g))))) ;; end of the generator
   14:  ;; the generators are independent
   15:  (let ((g (__make-generator__
   16:            (lambda (yield)
   17:              (let ((time 0))
   18:                (setf! time (+ time (yield 'yield-value-one)))
   19:                (yield 'yield-value-two)
   20:                (setf! time (+ time (yield 'yield-value-three)))
   21:                (yield time)))))
   22:        (g2 (__make-generator__
   23:             (lambda (yield)
   24:               (let ((time 0))
   25:                 (setf! time (+ time (yield 'one)))
   26:                 (yield 'two)
   27:                 (setf! time (+ time (yield 'three)))
   28:                 (yield time))))))
   29:    (and (equal? 'yield-value-one (g))
   30:         (equal? 'one (g2))
   31:         (equal? 'yield-value-two (g 10))
   32:         (equal? 'two (g2 1))
   33:         (equal? 'yield-value-three (g))
   34:         (equal? 'three (g2))
   35:         (equal? 20 (g 10))
   36:         (equal? 2 (g2 1))
   37:         (end-of-generator? (g))
   38:         (end-of-generator? (g2))
   39:         ))

6.4. generator

    1: (define-macro generator
    2:   (lambda (#!rest body)
    3:     `(__make-generator__
    4:       (lambda (yield)
    5:         ,@body))))

    1: (unit-test
    2:  (begin
    3:    (let ((g (generator
    4:              (let ((time 0))
    5:                (setf! time (+ time (yield 'yield-value-one)))
    6:                (setf! time (+ time (yield 'yield-value-two)))
    7:                (setf! time (+ time (yield 'yield-value-three)))
    8:                (yield time)))))
    9:      (and (equal? 'yield-value-one (g)) ;; just like python, nothing to send on first use
   10:           (equal? 'yield-value-two (g 10)) ;; send 10 to be the value of "(yield 'yield-value-one)"
   11:           (equal? 'yield-value-three (g 10)) ;; send 10 to be the value of "(yield 'yield-value-two)"
   12:           (equal? 30 (g 10)) ;; send 10 to be the value of "(yield 'yield-value-three)"
   13:           (end-of-generator? (g 10)) ;; end of the generator)
   14:           ))))

6.5. yield-from

    1: (define-macro yield-from
    2:   (lambda (g)
    3:     (with-gensyms
    4:      (v loop)
    5:      `(let ,loop ((,v (,g)))
    6:            (if (not (end-of-generator? ,v))
    7:                (begin
    8:                  (yield ,v)
    9:                  (,loop (,g)))
   10:                 'noop)))))

    1: (unit-test
    2:  (begin
    3:    (let* ((g (generator
    4:                (yield 1)
    5:                (yield 2)
    6:                (yield 3)))
    7:           (g2 (generator
    8:                (yield 'a)
    9:                (yield 'b)
   10:                (yield 'c)))
   11:           (g3 (generator
   12:                (yield-from g)
   13:                (yield-from g2))))
   14:      (and (equal? 1 (g3))
   15:           (equal? 2 (g3))
   16:           (equal? 3 (g3))
   17:           (equal? 'a (g3))
   18:           (equal? 'b (g3))
   19:           (equal? 'c (g3))
   20:           (end-of-generator? (g3))
   21:           ))))

6.6. list→stream

Converts a list into a stream.

    1: (define list->stream
    2:   (lambda (l)
    3:     (generator
    4:      (let loop ((l l))
    5:        (if (not (null? l))
    6:            (begin
    7:              (yield (car l))
    8:              (loop (cdr l)))
    9:            'noop)))))

    1: (unit-test
    2:    (let ((g (list->stream '(1 2 3))))
    3:      (and (equal? 1 (g))
    4:           (equal? 2 (g))
    5:           (equal? 3 (g))
    6:           (end-of-generator? (g)))))

6.7. stream→list

Converts a stream into a list.

    1: (define stream->list
    2:   (lambda (s)
    3:     (let ((next (s)))
    4:       (if (end-of-generator? next)
    5:           '()
    6:           (cons next (stream->list s))))))

    1: (unit-test
    2:  (equal? (stream->list
    3:           (list->stream '(1 2 3)))
    4:          '(1 2 3))
    5:  )

6.8. integers-from

Creates an infinite
[bounded by memory constraints of course. Scheme isn’t a Turing machine.]
stream of integers.

    1: (define integers-from
    2:   (lambda (n)
    3:     (generator
    4:      (let loop ((n n))
    5:        (yield n)
    6:        (loop (+ n 1))))))

<[sicp]>.

    1: (unit-test
    2:  (and
    3:    (let ((g (integers-from 0)))
    4:      (and (equal? 0 (g))
    5:           (equal? 1 (g))
    6:           (equal? 2 (g))
    7:           (equal? 3 (g))))
    8:    (let ((g (integers-from 5)))
    9:      (and (equal? 5 (g))
   10:           (equal? 6 (g))
   11:           (equal? 7 (g))
   12:           (equal? 8 (g))))))

6.9. stream-map

The analogous procedure of "map".

    1: (define stream-map
    2:   (lambda (f #!rest list-of-streams)
    3:     (generator
    4:      (let stream-map ()
    5:        (let ((the-values (map (lambda (g) (apply g '()))
    6:                               list-of-streams)))
    7:          (if (any? (map end-of-generator? the-values))
    8:              (end-of-generator)
    9:              (begin
   10:                (yield (apply f the-values))
   11:                (stream-map))))))))

    1: (unit-test
    2:  (equal? (stream->list
    3:           (stream-map (lambda (x) (+ x 1))
    4:                       (list->stream '(1 2 3 4 5))))
    5:          '(2 3 4 5 6))
    6:  (equal? (stream->list
    7:           (stream-map (lambda (x y) (+ x y))
    8:                       (list->stream '(1 2 3 4 5))
    9:                       (list->stream '(1 1 1 1 1))))
   10:          '(2 3 4 5 6))
   11:  )
   12:

6.10. stream-filter

The analogous procedure of filter.

    1: (define stream-filter
    2:   (lambda (p? s)
    3:     (generator
    4:      (let stream-filter ()
    5:        (let ((the-value (s)))
    6:          (if (end-of-generator? the-value)
    7:              (end-of-generator)
    8:              (begin
    9:                (if (p? the-value)
   10:                    (yield the-value)
   11:                    'noop)
   12:                (stream-filter))))))))

    1: (unit-test
    2:  (equal?  (stream->list
    3:            (stream-filter (lambda (x) (not (= 4 x)))
    4:                           (list->stream '(1 4 2 4))))
    5:           '(1 2))
    6:  )

6.11. stream-take

    1: (define stream-take
    2:   (lambda (n s)
    3:     (generator
    4:      (let stream-take ((n n))
    5:        (let ((the-value (s)))
    6:          (if (or (end-of-generator? the-value)
    7:                  (<= n 0))
    8:              (end-of-generator)
    9:              (begin
   10:                (yield the-value)
   11:                (stream-take (- n 1)))))))))

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (n) (stream->list
    4:                (stream-take n (integers-from 0))))
    5:   '(
    6:     (0 ())
    7:     (1 (0))
    8:     (2 (0 1))
    9:     (6 (0 1 2 3 4 5))
   10:     )))

6.12. primes

    1: (define primes
    2:   (lambda ()
    3:     (generator
    4:      (let sieve-of-eratosthenes ((s (integers-from 2)))
    5:        (let ((prime (s)))
    6:          (yield prime)
    7:          (yield-from (sieve-of-eratosthenes
    8:                       (stream-filter (lambda (n)
    9:                                        (not (equal? 0
   10:                                                     (modulo n prime))))
   11:                                      s))))))))

<[sicp]>.

    1: (unit-test
    2:  (equal? (stream->list
    3:           (stream-take
    4:            10
    5:            (primes)))
    6:          '(2 3 5 7 11 13 17 19 23 29))
    7:  )

6.13. stream-drop

    1: (define stream-drop
    2:   (lambda (n s)
    3:     (let stream-drop ((n n))
    4:       (if (<= n 0)
    5:           s
    6:           (begin
    7:             (s)
    8:             (stream-drop (- n 1)))))))

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (n)
    4:     (stream->list
    5:      (stream-drop n (list->stream '(a b)))))
    6:   '(
    7:     (-1 (a b))
    8:     (0 (a b))
    9:     (1 (b))
   10:     (2 ())
   11:     (3 ())
   12:     ))
   13:  (equal? (stream->list
   14:           (stream-take 10 (stream-drop 10
   15:                                        (primes))))
   16:          '(31 37 41 43 47 53 59 61 67 71))
   17:  )

6.14. stream-drop-while

    1: (define stream-drop-while
    2:   (lambda (p? s)
    3:     (let ((not-p? (complement p?)))
    4:       (generator
    5:        (let stream-drop-while ()
    6:          (let ((the-value (s)))
    7:            (if (or (end-of-generator? the-value)
    8:                    (not-p? the-value))
    9:                (begin
   10:                  (yield the-value)
   11:                  (yield-from s))
   12:                (stream-drop-while))))))))

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (x)
    4:     (stream->list
    5:      (stream-drop-while (lambda (y) (not (equal? x y)))
    6:                         (list->stream
    7:                          '(a b c)))))
    8:   '(
    9:     (a (a b c))
   10:     (b (b c))
   11:     (c (c))
   12:     (d ())
   13:     (e ())
   14:     )))

6.15. stream-enumerate-interval

    1: (define stream-enumerate-interval
    2:   (lambda (low high #!key (step 1))
    3:     (generator
    4:      (let stream-enumerate-interval ((low low))
    5:        (if (> low high)
    6:            (end-of-generator)
    7:            (begin
    8:              (yield low)
    9:              (stream-enumerate-interval (+ low step))))))))

    1: (unit-test
    2:  (equal? (stream->list
    3:           (stream-enumerate-interval 1 10))
    4:          '(1 2 3 4 5 6 7 8 9 10))
    5:  (equal? (stream->list
    6:           (stream-enumerate-interval 1 10 step: 2))
    7:          '(1 3 5 7 9)))

6.16. stream-take-while

    1: (define stream-take-while
    2:   (lambda (p? s)
    3:     (let ((not-p? (complement p?)))
    4:       (generator
    5:        (let stream-take-while ()
    6:          (let ((the-value (s)))
    7:            (if (or (end-of-generator? the-value)
    8:                    (not-p? the-value))
    9:                (end-of-generator)
   10:                (begin
   11:                  (yield the-value)
   12:                  (stream-take-while)))))))))

    1: (unit-test
    2:  (satisfies?
    3:   (lambda (s)
    4:     (stream->list
    5:      (stream-take-while (lambda (n) (< n 10))
    6:                         s)))
    7:   `((,(integers-from 0)               (0 1 2 3 4 5 6 7 8 9))
    8:     (,(stream-enumerate-interval 1 4) (1 2 3 4))))
    9:  )

6.17. The End of Compilation

At the beginning of the book, in chapter [beginninglibbug], "bug-language.scm" was imported, so that "libbug-private#define", and "libbug-private#define-macro" could be used. This chapter is the end of the file "main.bug.scm". However, as will be shown in the next chapter, "bug-languge.scm" opened files for writing during compile-time, and they must be closed, accomplished by executing "at-end-of-compilation".

;;[[call-end-of-compilation

    1: (at-compile-time
    2:  (at-end-of-compilation))

Foundations Of Libbug

1. Computation At Compile-Time

This chapter
[The contents of which is found in "src/bug-language.bug.scm''.]
, which was evaluated before the previous chapters, provides the foundation for computation at compile-time. Although the most prevalent code in the previous chapters which executed at compile-time was for testing, many other computations occurred during compile-time transparently to the reader. These other computations produced output files for namespace mappings and for macro definitions, to be used by other programs which link against libbug.

1.1. at-compile-time

"at-compile-time" is a macro which "eval"s the form during macro-expansion, but evaluates to the symbol "noop", thus not affecting run-time <[evalduringmacroexpansion]>. "Eval"ing during macro-expansion is how the compiler may be augmented with new procedures, thus treating the compiler as an interpreter.

    1: (##namespace ("bug#" at-compile-time))
    2: (##define-macro at-compile-time
    3:   (lambda (#!rest forms)
    4:     (eval `(begin
    5:              ,@forms))
    6:     '(quote noop)))

On lines 4-5, the unevaluated code which is passed to "at-compile-time" is evaluated during macro-expansion, thus at compile-time. The macro-expansion expands into "$quote noop$", so the form will not evaluate at run-time.

1.2. at-both-times

"at-both-times", like "at-compile-time", "eval"s the forms in the compile-time environment, but also in the run-time environment.

    1: (##namespace ("bug#" at-both-times))
    2: (##define-macro at-both-times
    3:   (lambda (#!rest forms)
    4:     (eval `(begin
    5:              ,@forms))
    6:     `(begin
    7:        ,@forms)))

On lines 4-5, evaluation in the compile-time environment
On lines 6-7, evaluation in the run-time environment. The forms are returned unaltered to Gambit’s compiler, thus ensuring that they are defined in the run-time environment.

1.3. at-compile-time-expand

"at-compile-time-expand" allows any procedure to act as a macro.

    1: (##namespace ("bug#" at-compile-time-expand))
    2: (##define-macro at-compile-time-expand
    3:   (lambda (#!rest forms)
    4:     (eval `(begin
    5:              ,@forms))))

This allows the programmer to create "anonymous" macros.

> ((at-compile-time-expand
    (if #t
        'car
        'cdr))
  '(1 2))
1
> ((at-compile-time-expand
    (if #f
        'car
        'cdr))
  '(1 2))
(2)

1.4. Create Files for Linking Against Libbug

Libbug is a collection of procedures and macros. Building libbug results in a dynamic library and a "loadable" library (a .o1 file, for loading in the Gambit interpreter). But programs which link against libug will require libbug’s macro definitions and namespace declarations, both of which are not compiled into the library. Rather than manually copying all of them to external files, why not generate them during compile-time?

At compile time, open one file for the namespaces ("libbug#.scm") and one for the macros ("libbug-macros.scm"). These files will be pure Gambit scheme code, no libbug syntax enhancements.

    1: (at-compile-time

[All of the code through section [endOfLinkAgainstLibbug] is done at compile-time. The author chose to use subsection numbers to indicate scope for code which spans multiple pages.]

1.4.1. Create File for Namespaces

The previous three macros are currently namespaced within libbug, but external projects which link against libbug may need these namespace mappings as well. Towards that goal, open a file during compile-time and write the namespace mappings to the file.

    1:  (##define libbug-headers-file
    2:    (open-output-file '(path: "libbug#.scm" append: #f)))
    3:  (display
    4:   ";;;Copyright 2014-2018 - William Emerison Six
    5:    ;;; All rights reserved
    6:    ;;; Distributed under LGPL 2.1 or Apache 2.0
    7:    (##namespace (\"bug#\" at-compile-time))
    8:    (##namespace (\"bug#\" at-both-times))
    9:    (##namespace (\"bug#\" at-compile-time-expand))
   10:    "
   11:   libbug-headers-file)

1.4.2. Create File for Macro Definitions

The previous three macros are available within libbug, but not to programs which link against libbug. To rectify that, open a file during compile-time, and write the macro definitions to the file.

    1:  (##include "config.scm")
    2:  (##define bug-configuration#libbugsharp
    3:    (string-append bug-configuration#prefix "/include/libbug/libbug#.scm"))
    4:
    5:  (##define libbug-macros-file
    6:    (open-output-file '(path: "libbug-macros.scm" append: #f)))
    7:  (display
    8:   (string-append
    9:    ";;;Copyright 2014-2018 - William Emerison Six
   10:     ;;; All rights reserved
   11:     ;;; Distributed under LGPL 2.1 or Apache 2.0
   12:     (##include \"~~lib/gambit#.scm\")
   13:     (##include \"" bug-configuration#libbugsharp "\")
   14:     (##define-macro at-compile-time
   15:       (lambda (#!rest forms)
   16:        (eval `(begin
   17:                 ,@forms))
   18:        '(quote noop)))
   19:     (at-compile-time (##include \"" bug-configuration#libbugsharp "\"))
   20:     (##define-macro at-both-times
   21:       (lambda (#!rest forms)
   22:        (eval `(begin
   23:                 ,@forms))
   24:        `(begin
   25:           ,@forms)))
   26:     (##define-macro at-compile-time-expand
   27:       (lambda (#!rest forms)
   28:        (eval `(begin
   29:                 ,@forms))))
   30:    ")
   31:   libbug-macros-file)

On line 1-3, include the "config.scm" file which was preprocessed by Autoconf, so that the installation directory of libbug is known at compile-time.
On line 13, "libbug#.scm" is imported, so that the generated macros are namespaced correctly in external projects which import libbug. In the previous section, this file is created at compile-time. Remember that when "libbug-macros.scm" will be imported by an external project, "libbug#.scm" will exist with all of the namespaces defined in libbug
[Marty: "Well Doc, we can scratch that idea. I mean we can’t wait around a year and a half for this thing to get finished." Doc Brown: "Marty it’s perfect, you’re just not thinking fourth-dimensionally. Don’t you see, the bridge will exist in 1985." -Back to the Future 3]
.

1.4.3. Close Files At Compile-Time

Create a procedure to be invoked at the end of compilation, to close the compile-time generated files. Also, the namespace within the generated macro file is reset to the default namespace
[This procedure is called in section [call-end-of-compilation]]
.

    1:  (define at-end-of-compilation
    2:    (lambda ()
    3:      (display
    4:       "
    5:      (##namespace (\"\"))"
    6:       libbug-macros-file)
    7:      (force-output libbug-headers-file)
    8:      (close-output-port libbug-headers-file)
    9:      (force-output libbug-macros-file)
   10:      (close-output-port libbug-macros-file))))

1.5. libbug-private#write-and-eval

Now that those files are open, namespaces will be written to "libbug#.scm" and macro definitions to "libbug-macros.scm". However, the code shouldn’t have be to duplicated for each context, as was done for the previous three macros.

Create a macro named "write-and-eval" which will write the unevaluated form plus a newline to the file, and then return the form so that the compiler actually evaluate it
[any procedure which is namespaced to "libbug-private" is not exported to the namespace file nor the macro file]
.

    1: (##define-macro libbug-private#write-and-eval
    2:   (lambda (port form)
    3:     (eval `(begin
    4:              (write ',form ,port)
    5:              (newline ,port)))
    6:     form))

"write-and-eval" writes the form to a file, and evaluates the form only in the run-time context. For namespaces in libbug, namespaces should be valid at compile-time too.

1.6. libbug-private#namespace

Namespaces for procedures in libbug need to be available at compile-time, run-time, and in the namespace file for inclusion in projects which link to libbug.

    1: (##define-macro libbug-private#namespace
    2:   (lambda (#!rest to-namespace)
    3:     (begin
    4:       (eval `(##namespace ("bug#" ,@to-namespace)))
    5:       `(begin
    6:          (libbug-private#write-and-eval
    7:           libbug-headers-file
    8:           (##namespace ("bug#" ,@to-namespace)))))))

1.7. unit-test

Given that the reader now knows how to evaluate at compile-time, implementing a macro to execute tests at compile-time is trivial.

Make a macro called "unit-test", which takes an unevaluated list of tests.
"eval" the tests at compile-time. If any test evaluates to false, force the compiler to exit in error, producing an appropriate error message. If all of the tests pass, the Gambit compiler continues compiling subsequent definitions.

    1: (libbug-private#namespace unit-test)
    2: (libbug-private#write-and-eval
    3:  libbug-macros-file
    4:  (##define-macro unit-test
    5:    (lambda (#!rest tests)
    6:      (eval
    7:       `(if (and ,@tests)
    8:            ''noop
    9:            (begin (for-each pp '("Test Failed" ,@tests))
   10:                   (error "Tests Failed")))))))

1.8. libbug-private#define

"libbug-private#define" is the main procedure-defining procedure used throughout libbug. "libbug-private#define" takes a variable name and a value to be stored in the variable.

    1: (##define-macro
    2:   libbug-private#define
    3:   (lambda (name body)
    4:     `(begin
    5:        (libbug-private#namespace ,name)
    6:        (at-both-times
    7:         (##define ,name ,body)))))

"libbug-private#define" defines the procedure/data both at both compile-time and run-time, and exports the namespace mapping to the appropriate file. "libbug-private#define" itself is not exported to the macros file.

On line 6-7, the definition occurs at both compile-time and run-time, ensuring that the procedure is available for evaluation of tests during compile-time.

1.9. libbug-private#define-macro

Like "libbug-private#define" is built upon "define", "libbug-private#define-macro" is built upon "define-macro". "libbug-private#define-macro" ensures that the macro is available both at run-time and at compile-time. Macros do not get compiled into libraries however, so for other projects to use them they must be exported to file.

The steps will be as follows:

Write the macro to file
Write the macro-expander to file
Define the macro-expander within libbug
Define the macro.

    1: (##define-macro libbug-private#define-macro
    2:   (lambda (name lambda-value)

1.9.1. Write the Macro to File

    1:     (write
    2:      `(at-both-times

Macro Definition

The macro definition written to file will be imported as text by other projects which may have different namespace mappings than libbug. To ensure that the macro works correctly in other contexts, the appropriate namespace mappings must be loaded for the definition of this macro definition.

    1:        (##define-macro
    2:          ,name
    3:          (lambda ,(cadr lambda-value)
    4:            ,(list 'quasiquote
    5:                   `(##let ()
    6:                      (##include "~~lib/gambit#.scm")
    7:                      (##include ,bug-configuration#libbugsharp)
    8:                      ,(if (and (pair? (caddr lambda-value))
    9:                                (equal? 'quasiquote
   10:                                        (caaddr lambda-value)))
   11:                           (car (cdaddr lambda-value))
   12:                           (append (list 'unquote)
   13:                                   (cddr lambda-value)))))))

On line 3, the lambda value written to file shall have the same argument list as the argument list passed to "libbug-private#define-macro"

   > (cadr '(lambda (foo bar) (quasiquote 5)))
   (foo bar)

On line 4, the unevaluated form in argument "lambda-value" may or may not be quasiquoted. Either way, write a quasiquoted form to the file. In the case that the "lambda-value" argument was not actually intended to be quasiquoted, unquote the lambda’s body (which is done on line 12-13), thereby negating the quasi-quoting from line 4.
On lines 4-5, rather than nesting quasiquotes, use the technique of replacing a would-be nested quasiquote with ",(list 'quasiquote `(…)". This makes the code more readable <[paip]>. Should the reader be interested in learning more about nested quasiquotes, Appendix C of <[cl]> is a great reference.
On lines 5-7, ensure that the currently unevaluated form will be evaluated using libbug’s namespaces. Line 5 create a bounded context for namespace mapping. Line 6 sets standard Gambit namespace mappings, line 7 sets libbug’s mappings.
On line 8-10, check to see if the unevaluated form is quasiquoted.

   > (caaddr '(lambda (foo bar) (quasiquote 5)))
   quasiquote

On line 11, since it is quasiquoted, grab the content of the list minus the quasiquoting.

   > (car (cdaddr '(lambda (foo bar) (quasiquote 5))))
   5

Remember that this value gets wrapped in a quasiquote from line 5

   > (list 'quasiquote (car (cdaddr '(lambda (foo bar)
                                        (quasiquote 5)))))
   `5

On line 12-13, since this is not a quasiquoted form, just grab the form, and "unquote" it.

   > (append (list 'unquote) (cddr '(lambda (foo bar) (+ 5 5))))
   ,(+ 5 5)

Remember, this value gets wrapped in a quasiquote from line 4

   > (list 'quasiquote (append (list 'unquote)
                               (cddr '(lambda (foo bar)
                                            (+ 5 5)))))
   `,(+ 5 5)
   > (eval (list 'quasiquote (append (list 'unquote)
                                     (cddr '(lambda (foo bar)
                                               (+ 5 5)))))
   10

Define a Macro-Expander

In order to be able to test the macro-expansions effectively, a programmer needs to be able to access the code generated from the macro as a data structure. For each macro defined, create a new macro with the same name suffixed with "-expand", whose body is the same procedure as "lambda-value"s body, but the result of evaluating that body is "quoted". In this new procedure’s local environment, define "gensym" so that tests may be written
["##gensym" by definition creates a unique symbol which the programmer can not directly input, making testing of the macro-expansion impossible. Thus, the problem is solved by locally defining a new "gensym" procedure.]
.

    1:        (##define-macro
    2:          ,(string->symbol (string-append (symbol->string name)
    3:                                          "-expand"))
    4:          (lambda ,(cadr lambda-value)
    5:            (let ((gensym (let ((gensym-count 0))
    6:                            (set! gensym-count
    7:                                  (+ 1 gensym-count))
    8:                            (string->symbol
    9:                             (string-append
   10:                              "gensymed-var"
   11:                              (number->string gensym-count))))))
   12:              (list 'quote ,@(cddr lambda-value))))))

Finish writing the macro to file which was started in section [writemacrotofile].

    1:      libbug-macros-file)
    2:     (newline libbug-macros-file)

1.9.2. Define Macro and Run Tests Within Libbug

The macro has been exported to a file for use by projects which link against libbug, but it must also be defined during compilation.

    1:     `(begin

Namespace the procedure and the expander.

    1:        (libbug-private#namespace ,name)
    2:        (libbug-private#namespace ,(string->symbol
    3:                                    (string-append (symbol->string name)
    4:                                                   "-expand")))

Create the expander similarly to the previous section.

    1:        (at-both-times
    2:         (##define-macro
    3:           ,(string->symbol
    4:             (string-append (symbol->string name)
    5:                            "-expand"))
    6:           (lambda ,(cadr lambda-value)
    7:             (let ((gensym (let ((gensym-count 0))
    8:                             (lambda ()
    9:                               (set! gensym-count
   10:                                     (+ 1 gensym-count))
   11:                               (string->symbol
   12:                                (string-append
   13:                                 "gensymed-var"
   14:                                 (number->string gensym-count)))))))
   15:               (list 'quote ,@(cddr lambda-value))))))

Define the macro.

    1:        (at-both-times
    2:         (##define-macro
    3:           ,name
    4:           ,lambda-value)))))
    5:

1.10. macroexpand-1

"macroexpand-1" is syntactic sugar which allows the programmer to test macro-expansion by writing

(equal? (macroexpand-1 (aif (+ 5 10)
                           (* 2 bug#it)))
      '(let ((bug#it (+ 5 10)))
         (if bug#it
             (* 2 bug#it)
             #f)))

instead of

(equal? (aif-expand (+ 5 10)
                   (* 2 bug#it)))
      '(let ((bug#it (+ 5 10)))
         (if bug#it
             (* 2 bug#it)
             #f)))

    1: (libbug-private#define-macro
    2:  macroexpand-1
    3:  (lambda (form)
    4:    (let* ((m (car form))
    5:           (the-expander (string->symbol
    6:                          (string-append (symbol->string m)
    7:                                         "-expand"))))
    8:      `(,the-expander ,@(cdr form)))))

1.11. libbug-private#define-structure

Like ``\#\#define-structure'', but additionally writes the namespaces
to file.

 \begin{code}
(##define-macro
  libbug-private#define-structure
  (lambda (name #!rest members)
    `(begin
       (libbug-private#namespace
        ,(string->symbol
          (string-append "make-"
                         (symbol->string name)))
        ,(string->symbol
          (string-append (symbol->string name)
                         "?"))
        ,@(map (lambda (m)
                 (string->symbol
                  (string-append (symbol->string name)
                                 "-"
                                 (symbol->string m))))
               members)
        ,@(map (lambda (m)
                 (string->symbol
                  (string-append (symbol->string name)
                                 "-"
                                 (symbol->string m)
                                 "-set!")))
               members))
       (at-both-times
        (##namespace (""
                      define
                      define-structure
                      ))
        (define-structure ,name ,@members)
        (##namespace ("libbug-private#"
                      define
                      ))
        (##namespace ("bug#"
                      define-structure
                      ))))))

//Copyright 2014-2018 - William Emerison Six
//All rights reserved
//Distributed under LGPL 2.1 or Apache 2.0

[appendix]
== Compile-Time Language
[[appendix1]]
This appendixfootnote:[Examples in the appendix will have boxes
and line numbers around the code, but they are not part of libbug.]
provides a quick tour of computer language which is interpreted
by the compiler but which is absent in the generated machine
code.  Examples are provided in
well-known languages to illustrate that
most compilers are also interpreters for a subset of the language.  This
appendix provides a baseline demonstration of compile-time computation
so that the reader may contrast these languages' capabilities with libbug's.
But first, let's discuss what is meant by the words "language","compiler", and
"interpreter".

In "Introduction to Automata Theory, Languages, and Computation", Hopcroft,
Motwani, and Ullman define language as "A set of strings all of which are chosen
from some &#931;^*^, where &#931; is a particular alphabet, is called
a language" <<<hmu2001>>>.

Plainly, that means that an "alphabet" is a set of characters (for instance, ASCII), and
that a computer "language" is defined as all of the possible sequences of characters
from that alphabet which are able to be compiled successfully.

An "interpreter" is a computer program which takes an instance of a specific
computer language as input,
and immediately executes the instructions.  A "compiler" is a computer program
which also takes an instance of a specific computer language as input,
but rather than immediately executing the input language, instead the compiler
translates the input language
into another computer language (typically machine code), which is then output to a file
for interpretationfootnote:[the Central Processing Unit (CPU) can be viewed as an
interpreter which takes machine code as its input] at a later time.

In practice though, the distinction is not binary.  Most compilers do not exclusively
translate from an input language
to an output language; instead, they also interpret a subset of the input
language as part of the compilation process.  So what
types of computations can be performed by this subset of language, and how do
they vary in expressive power?

=== C
Consider the following C code:

[source,C,linenums]

#include <stdio.h> #define square(x) x) * (x int fact(unsigned int n); int main(int argc, char* argv[]){ #ifdef DEBUG printf("Debug - argc = %d\n", argc); #endif printf("%d\n",square(fact(argc))); return 0; } int fact(unsigned int n){ return n == 0 ? 1 : n * fact(n-1); }

- On line 1, the #include preprocessor command
is language to be interpreted by the compiler,
instructing the compiler to
read the file "stdio.h"
from the filesystem and to splice the content
into the current C file.  The #include command
itself has no representation in the generated machine code, although the contents
of the included file may.

- Line 2 defines a C macro. A C macro is a procedure definition which
is to be interpreted by the compiler instead of being translated
into the output language.
A C macro takes a text
string as input and transforms it into a new text string as output.
This expansion happens before the compiler does anything
else.  For example, using GCC as a compiler, if you run the C preprocessor
"cpp" on the above C code, you'll see that

[source,C,linenums]

printf("%d\n",square(fact(argc)));

expands into

[source,C,linenums]

printf("%d\n",((fact(argc)) * (fact(argc))));

before compilation.


-Line 3 defines a procedure prototype so that
the compiler knows the argument types and the return type for a procedure not
yet defined called "fact".
It is language interpreted by the compiler to determine the types for the procedure
call to "fact" on line 8.

-Lines 4 through 10 are a procedure definition which will be
translated into instructions in the generated machine code.  Line 5 however, is language
to be interpreted by the compiler, referencing a variable which is defined
only during compile-time, to detemine whether or not line 6 should be
compiled.

=== C&#43;&#43;

C&#43;&#43; inherits C's macros, but with the additional introduction
of templates, its compile-time language
incidentally became Turing complete;  meaning that
anything that can be
calculated by a computer can be calculated using template expansion
at compile-time.  That's great!  So how does a programmer use this new
expressive power?

The following is an example of calculating the factorial of
3; using C&#43;&#43; procedures for run-time calulation, and C&#43;&#43;'s templates for compile-time
calculation.

[source,cpp,linenums]

#include <iostream>
template <unsigned int n>
struct factorial {
    enum { value = n * factorial<n - 1>::value };
};
template <>
struct factorial {
    enum { value = 1 };
};
int fact(unsigned int n){
  return n == 0
    ? 1
    : n * fact(n-1);
}
int main(int argc, char* argv[]){
  std::cout << factorial::value << std::endl;
  std::cout << fact(3) << std::endl;
  return 0;
}

-Lines 10-14 are the run-time calculation of "fact", identical
to the previous version in C.


-Lines 2-9 are the
template code for the compile-time calculation of "factorial".  Notice
that the language constructs used are drastically different than the
run-time constructs.


-On line 16, "factorial::value" is
language to be interpreted
by the compiler via template expansions.  Template expansions
conditionally match patterns based on types (or values in the case
of integers).  For iteration, templates expand recursively instead of using loops.
In this case,  "factorial::value" expands to
"3 * factorial<3 - 1>::value".  The compiler
does the subtraction during compile-time,
so "factorial::value" expands to
"3 * factorial::value".
This recursion terminates on "factorial::value"
on line 7footnote:[Even though
the base case of "factorial" is lexically specified
after the more general
case of "factorial< n>", templates expand the most
specific case first.  So the compiler will terminate.].

-On line 17, a run-time call to "fact", defined on line 10, is declared.

==== Disassembling the Object File
The drastic difference in the generated code can be observed by using "objdump -D".

[source,txt,linenums]

400850: be 06 00 00 00   mov    $0x6,%esi
400855: bf c0 0d 60 00   mov    $0x600dc0,%edi
40085a: e8 41 fe ff ff   callq  4006a0 <_ZNSolsEi@plt>
.......
.......
.......
40086c: bf 03 00 00 00   mov    $0x3,%edi
400871: e8 a0 ff ff ff   callq  400816 <_Z4facti>
400876: 89 c6            mov    %eax,%esi
400878: bf c0 0d 60 00   mov    $0x600dc0,%edi
40087d: e8 1e fe ff ff   callq  4006a0 <_ZNSolsEi@plt>

- The instructions at memory locations 400850 through 40085a correspond to the
printing of the compile-time expanded call to factorial::value.
The immediate value 6 is loaded into the "esi" register; then the following
two lines call the printing routinefootnote:[at least I assume, because
I don't completely understand how C&#43;&#43; name-mangling works].


- The instructions at locations 40086c through 40087d correspond to the
printing of the run-time calculation to "fact(3)".  The immediate value 3
is loaded into the "edi" register, fact is invoked, the result of
calling fact is moved from the "eax" register to the "esi" register, and then
printing routine is called.

The compile-time computation worked as expected!

=== libbug
Like C&#43;&#43;'s compile-time language, libbug's is Turing complete.  But libbug's compile-time
language is the exact same language as the run-time language!

[source,Scheme,linenums]

(at-both-times
 (define fact
   (lambda (n)
     (if (= n 0)
         1
         (* n (fact (- n 1)))))))

(pp (at-compile-time-expand (fact 3)))
(pp (fact 3))

- On line 1, the "at-both-times" macro is invoked, taking the unevaluated
definition of "fact" as
as argument, interpreting it at compile-time, and compiling it for use at runtime.


- On lines 2-5, the definition of the "fact".

- On line 7, "at-compile-time-expand" is a macro which takes unevaluated code,
evaluates it to a new form which is then compiled by the compiler.  At compile-time the code
will expand to "(pp 6)".

- On line 8, the run-time calculation of "(fact 3)".

==== Inspecting the Gambit VM Bytecode
By compiling the Scheme source to the "gvm" intermediate
representation, the previously stated behavior can be verified.

[source,txt,linenums]

  r1 = '6
  r0 = #4
  jump/safe fs=4 global[pp] nargs=1
#4 fs=4 return-point
  r1 = '3
  r0 = #5
  jump/safe fs=4 global[fact] nargs=1
#5 fs=4 return-point
  r0 = frame[1]
  jump/poll fs=4 #6
#6 fs=4
  jump/safe fs=0 global[pp] nargs=1

- Lines 1-4 correspond to "(pp (at-compile-time-expand (fact 3)))".  The precomputed
value of "(fact 3)" is 6, which is directly stored into a GVM register, and
then the "pp" routine is called to print it.

- Lines 5-12 correspond to "(pp (fact 3))".  3 is stored in a GVM register, "fact"
is called, the result of which is passed to "pp".


=== Comparison of Power
Although the compile-time languages both of C&#43;&#43; and of libbug are Turing complete,
they vary in actual real-world programming power.  The language used
for compile-time calculation of "fact" in C&#43;&#43; is a drastically different language than
the one used for run-time.  Although not fully demonstrated in this book,
C&#43;&#43; template metaprogramming relies exclusively on recursion for repetition (it has no
looping construct), it has no mutable state, and it lacks the ability to do input/output
(I/O) footnote:[For the masochist who wants to know more about the C&#43;&#43;'s compile-time language, I recommend <<<ctm>>>]

In contrast, the compile-time
language in libbug is the exact same language as the one that the compiler
is compiling, complete with state and I/O!  How can that power be used?
This book is the beginning of an answer.

[appendix]
== Acknowledgments

Thanks to Dr. Marc Feeley, for Gambit Scheme, for his mailing list postings
which inspired the foundations of this book, and for reviewing this
book.  Thanks to Adam from the Gambit mailing lists for reviewing the book,
as well as his suggestion for naming convention standards.

Thanks to Dr. John McCarthy for Lisp.

Thanks to Dr. Gerald Sussman and Dr. Guy Steele Jr for Scheme.

Thanks to Dr. Paul Graham for "On Lisp", not only for the excellent macros,
but also for demonstrating why writing well matters.

Thanks to Dr. Donald Knuth for TeX, and thanks to all contributors to
LaTeX.

Thanks to Dr. Alan Kay for Smalltalk, the first language I loved.  Lisp may be the best high-level language, but Smalltalk is the best high-level environment.

And most importantly, thanks to my wife Teresa, for everything.

[appendix]
== Related Work

- Jonathan Blow. https://www.youtube.com/watch?v=UTqZNujQOlA
- "Compile-time Unit Testing",
Aron Barath and Zoltan Porkolab, Eotvos Lorand University,
http://ceur-ws.org/Vol-1375/SQAMIA2015\_Paper1.pdf



[bibliography]
Bibliography

[sicp] Abelon, Harold, Gerald Jay Sussman, and Julie Sussman. Structure and Interpretation of Computer Programs, The MIT Press, Massachusetts, Second Edition, 1996.
[ctm] Abrahams, David and Aleksey Gurtovoy C++ Template Metaprogramming, Addison Wesley 2004.
[calculi] Church, Alonzo The Calculi of Lambda-Conversion, Princeton University Press, New Jersey, Second Printing, 1951.
[schemeprogramminglanguage] Dybvig, R. Kent. The Scheme Programming Language, The MIT Press, Massachusetts, Third Edition, 2003.
[evalduringmacroexpansion] Feeley, Marc. https://mercure.iro.umontreal.ca/pipermail/gambit-list/2012-April/005917.html, 2012
[littleschemer] Friedman, Daniel P., and Matthias Felleisen The Scheme Programming Language, The MIT Press, Massachusetts, Fourth Edition, 1996.
[onlisp] Graham, Paul. On Lisp, Prentice Hall, New Jersey, 1994.
[ansicl] Graham, Paul. ANSI Common Lisp, Prentice Hall, New Jersey, 1996.
[ss] Harvey, Brian and Matthew Wright. Simply Scheme - Introducing Computer Science, The MIT Press, Massachusetts, Second Edition, 2001.
[hmu2001] Hopcroft, John E., Rajeev Motwani, and Jeffrey D. Ullman. Introduction to Automata Theory, Languages, and Computation, Addison Wesley, Massachusetts, Second Edition, 2001.
[setf] Kiselyov, Oleg. http://okmij.org/ftp/Scheme/setf.txt , 1998.
[taocp] Knuth, Donald E. The Art Of Computer Programming, Volume 1, Addison Wesley, Massachusetts, Third Edition, 1997.
[paip] Norvig, Peter Paradigms of Artificial Intelligence Programming: Case Studies in Common Lisp, San Francisco, CA 1992.
[tapl] Pierce, Benjamin C. Types and Programming Languages, The MIT Press Cambridge, Massachusetts 2002.
[crypto] Stallings, William Cryptography and Network Security, Pearson Education, Upper Saddle River, New Jersey, Third Edition, 2002.
[cl] Steele Jr, Guy L. Common Lisp the Language, Digital Press, 1990.

Computation at Compile-Time

Dedication

Preface

1. Introduction

1.1. Prerequisites

1.2. Order of Parts

1.3. Conventions

1.4. Getting the Source Code And Building

1.5. Creating Your Own Project

1.6. Comparison of Compile-Time Computations in Other Languages

The Implementation of Libbug

1. Introductory Procedures

1.1. noop

1.2. identity

1.3. all?

1.4. satisfies?

1.5. while

1.6. numeric-if

1.7. atom?

1.8. complement

2. Lists

2.1. copy

2.2. proper?

2.3. first

2.4. but-first

2.5. last

2.6. but-last

2.7. filter

2.8. remove

2.9. fold-left

2.10. sum

2.11. fold-right

2.12. scan-left

2.13. append!

2.14. flatmap

2.15. take

2.16. take-while

2.17. drop

2.18. drop-while

2.19. enumerate-interval

2.20. any?

2.21. zip

2.22. zip-with

2.23. permutations

2.24. cartesian-product

2.25. ref-of

2.26. list-set!

2.27. partition

2.28. sort

2.29. reverse!

3. Lifting

3.1. string-lift-list

3.2. string-reverse

3.3. string-take

3.4. string-drop

3.5. character-lift-integer

3.6. string-map

3.7. symbol-lift-list

4. Macros

4.1. compose

4.2. aif

4.3. with-gensyms

4.4. once-only

4.4.1. First Macro-expansion

4.4.2. The Second Macro-expansion

4.4.3. The Evaluation of the twice-expanded Code

5. Generalized Assignment

5.1. setf!

5.1.1. Updating a Variable Directly

Updating Car, Cdr, … Through Cddddr

Suffixed By -set!

-ref Replaced By -set!

5.2. mutate!

5.3. destructuring-bind

6. Coroutines

6.1. end-of-generator

6.2. end-of-generator?

6.3. __make-generator_\_

6.4. generator

6.5. yield-from