Dossier - scheme-dossier

Scheme: From Theory to Practice

A Comprehensive Guide to Modern Scheme Programming

Table of Contents

Part I: Foundations and Theory

Chapter 1: Introduction to Scheme and Lisp
Chapter 2: S-Expressions and the Symbolic Foundation
Chapter 3: Core Language Semantics
Chapter 4: Data Types and Structures

Part II: Practical Programming in Scheme

Chapter 5: Functions, Recursion, and Higher-Order Programming
Chapter 6: Macros and Metaprogramming
Chapter 7: Modules, Libraries, and SRFIs
Chapter 8: Error Handling and Debugging

Part III: Scheme Implementations Deep Dive

Chapter 9: Survey of Modern Scheme Implementations
Chapter 10: Foreign Function Interfaces (FFI)
Chapter 11: Development Environment Setup

Part IV: Real-World Applications

Chapter 12: Text Processing and Parsing
Chapter 13: Build Tools and Software Engineering
Chapter 14: Scripting and Automation
Chapter 15: Web Programming with Scheme
Chapter 16: Network Programming
Chapter 17: Systems Programming with Scheme

Part V: Comparative Analysis

Chapter 18: Scheme vs. Common Lisp
Chapter 19: Scheme in the Broader Language Landscape

Part VI: Advanced Topics

Chapter 20: Concurrency and Parallelism
Chapter 21: Virtual Machines and Compilation
Chapter 22: Implementing Scheme in Java
Chapter 23: Implementing Scheme in D
Chapter 24: The Future of Scheme

Appendices

Appendix A: Quick Reference Guide
Appendix B: Resources and Further Reading
Appendix C: Complete Code Listings

Index

This book aims to be the definitive modern guide to Scheme, bridging theory and practice, and demonstrating Scheme’s versatility across domains. Each chapter includes hands-on examples, exercises, and real-world projects.

Ready to begin? Let me know which chapter you’d like me to generate first!

Chapter 1: Introduction to Scheme and Lisp

1.1 The Lisp Family Tree

In the beginning, there was LISP. Born in 1958 at the Massachusetts Institute of Technology under the guidance of John McCarthy, LISP (which stands for “LISt Processing”) is the second-oldest high-level programming language still in widespread use today—only FORTRAN is older. But unlike FORTRAN, which has evolved into something quite different from its origins, LISP has retained its essential character across more than six decades.

McCarthy’s original motivation was to create a language for artificial intelligence research. He needed a system that could manipulate symbols as easily as FORTRAN manipulated numbers, one that could reason about logical propositions and solve problems through symbolic computation. What emerged was revolutionary: a language where code and data shared the same representation, where functions were first-class objects, and where the boundaries between program and data were deliberately blurred.

The Proliferation of Dialects

LISP’s early success led to an interesting phenomenon: proliferation. As different research groups adopted LISP, they extended and modified it to suit their needs, creating a family tree of dialects that would make a botanist dizzy. Some notable branches include:

The Lisp Aesthetic

Despite their differences, all Lisp dialects share certain essential characteristics that define what we might call “the Lisp aesthetic”:

1. Homoiconicity: The most distinctive feature of Lisp is that programs are represented as data structures in the language itself—specifically, as lists. The code (+ 1 2) is both a valid program that adds 1 and 2, and a list containing the symbol + and the numbers 1 and 2. This property, called homoiconicity (from Greek “homo” meaning “same” and “icon” meaning “representation”), makes metaprogramming—writing programs that manipulate programs—natural and powerful.

2. Symbolic Computation: While FORTRAN was designed to crunch numbers, Lisp was designed to manipulate symbols. You can compute with the idea of x without needing to know what number x represents. This makes Lisp ideal for AI, theorem proving, computer algebra systems, and any domain where symbolic reasoning matters.

3. First-Class Functions: In Lisp, functions are data. You can pass them as arguments, return them from other functions, store them in data structures, and create them dynamically at runtime. This seems obvious now, but in 1958 it was revolutionary.

4. Automatic Memory Management: McCarthy’s team implemented one of the first garbage collectors, freeing programmers from manual memory management. The algorithm they developed—mark and sweep—is still used (in evolved forms) today.

5. Interactive Development: The Lisp REPL (Read-Eval-Print Loop) pioneered interactive programming. You could type expressions, see immediate results, define functions incrementally, and modify running programs. This tight feedback loop made Lisp extraordinarily productive for exploratory programming.

6. Minimal Syntax: Lisp’s syntax can be learned in an afternoon. Everything is a symbolic expression (S-expression) in parenthesized prefix notation. There are no special cases for operators, no precedence rules to memorize, no syntactic gotchas.

1.2 What Makes Scheme Special?

In 1975, two MIT researchers, Gerald Jay Sussman and Guy L. Steele Jr., set out to understand Carl Hewitt’s Actor model of computation. They decided to implement Actors in a small, simple dialect of Lisp as an experiment. What emerged from this experiment was not just an Actor implementation, but an entirely new vision of what Lisp could be.

They called it Scheme, and it embodied a philosophy radically different from other Lisps of the era. Where other Lisps had accumulated features over time, Scheme stripped away everything but the essentials. Where other Lisps had complex scoping rules and special cases, Scheme enforced elegant uniformity. The result was a language that could fit its specification in 50 pages, yet possessed extraordinary expressive power.

The Scheme Philosophy

Scheme embodies several key design principles:

1. Minimalism: Scheme strives to provide a minimal set of powerful primitives from which everything else can be built. Rather than including dozens of special forms and control structures, Scheme provides a handful of core constructs and shows how to build the rest. This minimalism isn’t about lacking features—it’s about having the right features, the ones that don’t overlap, the ones that compose cleanly.

As the Scheme motto goes: “Programming languages should be designed not by piling feature on top of feature, but by removing the weaknesses and restrictions that make additional features appear necessary.”

2. Lexical Scoping: Unlike many early Lisps, which used dynamic scoping, Scheme adopted lexical (or static) scoping from the start. In lexical scoping, a variable refers to the binding visible in the text of the program where it’s written, not the binding active when it’s called. This makes programs easier to reason about and enables powerful programming techniques like closures.

Consider this example:

(define (make-counter)
  (let ((count 0))
    (lambda ()
      (set! count (+ count 1))
      count)))

(define counter1 (make-counter))
(define counter2 (make-counter))

(counter1)  ; ⇒ 1
(counter1)  ; ⇒ 2
(counter2)  ; ⇒ 1

Each counter maintains its own private count variable, captured in the closure created by make-counter. This works cleanly because Scheme uses lexical scoping.

3. Proper Tail Recursion: Scheme mandates that implementations must implement tail calls properly, meaning tail-recursive functions use constant stack space. This isn’t an optimization—it’s a semantic requirement of the language. It means you can write iterative algorithms using recursion without fear of stack overflow.

;; This is an iteration disguised as recursion
;; It uses constant stack space
(define (factorial n)
  (define (fact-iter n acc)
    (if (= n 0)
        acc
        (fact-iter (- n 1) (* n acc))))
  (fact-iter n 1))

(factorial 100000)  ; No stack overflow!

4. First-Class Continuations: Scheme was the first language to make continuations—representing “the rest of the computation”—available as first-class objects that could be captured and invoked. The call/cc (call-with-current-continuation) mechanism provides a universal control operator from which any control structure can be built: exceptions, coroutines, backtracking, even goto.

;; A simple exception-like mechanism
(define (safe-div x y)
  (call/cc
    (lambda (return)
      (when (= y 0)
        (return 'error))
      (/ x y))))

(safe-div 10 2)  ; ⇒ 5
(safe-div 10 0)  ; ⇒ error

5. Everything is an Expression: In Scheme, every syntactic form evaluates to a value. There are no statements, only expressions. This uniformity makes the language more composable and predictable.

6. Simple Syntax, Powerful Semantics: Scheme’s syntax is even simpler than most Lisps. There are fewer special forms, fewer primitives, and a stronger emphasis on building complexity from simplicity.

The Scheme Standards

Scheme has evolved through a series of IEEE and de facto standards:

The split between R⁶RS and R⁷RS-small reflects an ongoing tension in the Scheme community between minimalism and practicality. R⁶RS tried to make Scheme more suitable for large-scale software development by adding features like a module system and extensive standard library. Some in the community felt this betrayed Scheme’s minimalist philosophy, leading to R⁷RS-small, which deliberately keeps the core language small while allowing optional “batteries” to be added via libraries.

1.3 Scheme’s Design Philosophy

Simplicity Through Power

One of Scheme’s most remarkable characteristics is how much you can do with how little. Consider the control structures available in most languages: if, while, for, switch, break, continue, try/catch, etc. In Scheme, you get if and… that’s about it at the primitive level. Everything else can be defined in terms of more fundamental constructs.

Want a while loop? Define it:

(define-syntax while
  (syntax-rules ()
    ((while condition body …)
     (let loop ()
       (when condition
         body …
         (loop))))))

Want pattern matching? Define it. Want lazy evaluation? Define it. Want delimited continuations? Define them. Scheme gives you the building blocks and the tools to create whatever abstractions you need.

This isn’t laziness on the part of language designers—it’s a deliberate philosophy. By keeping the core language small and orthogonal, Scheme ensures that:

  1. The language is easier to learn (fewer primitives to memorize)

  2. The language is easier to implement (fewer special cases)

  3. The language is more flexible (users can extend it themselves)

  4. The language is more principled (emergent behavior from simple rules)

The Lambda Nature

At the heart of Scheme lies the lambda calculus, a mathematical system invented by Alonzo Church in the 1930s. The lambda calculus shows that all computation can be expressed using just three things:

  1. Variable references

  2. Function abstraction (creating functions)

  3. Function application (calling functions)

Scheme takes this seriously. While it adds practical features like numbers, booleans, mutation, I/O, etc., the core evaluation model remains remarkably close to the pure lambda calculus. Understanding this connection helps you understand why Scheme works the way it does.

In lambda calculus notation, the identity function is written:

λx.x\lambda x . x

In Scheme, it’s:

(lambda (x) x)

A function that adds its argument to 1:

λx.x+1\lambda x . x + 1

In Scheme:

(lambda (x) (+ x 1))

Function application in lambda calculus:

(λx.x+1)5(\lambda x . x + 1) \; 5

In Scheme:

((lambda (x) (+ x 1)) 5)  ; ⇒ 6

This close correspondence means that theoretical results from lambda calculus—like Church-Rosser confluence, normal form reduction, and fixed-point theorems—have direct practical implications for Scheme programming.

Uniformity and Orthogonality

Scheme strives for orthogonality—every feature should be independent and composable with every other feature. There should be no special cases, no arbitrary restrictions.

For example, in many languages, certain values are “second-class” and can’t be passed around or returned from functions. In Scheme, everything is first-class:

;; Functions are first-class
(define (twice f)
  (lambda (x) (f (f x))))

((twice (lambda (x) (* x 2))) 5)  ; ⇒ 20

;; Continuations are first-class
(define saved-continuation #f)

(+ 1 (call/cc
       (lambda (k)
         (set! saved-continuation k)
         100)))  ; ⇒ 101

(saved-continuation 200)  ; ⇒ 201

;; Even syntax transformers (macros) are first-class in some Schemes

This uniformity makes the language more predictable and more powerful. You don’t need to remember which operations work with which types—if it makes semantic sense, it probably works.

The Read-Eval-Print Philosophy

Scheme inherits Lisp’s interactive development model but refines it. The REPL isn’t just a convenience—it’s a window into the language’s evaluation model. When you type:

(+ (* 2 3) 4)

The REPL performs three distinct operations:

  1. Read: Parse the text into data structures (in this case, a list containing the symbol +, another list, and the number 4)

  2. Eval: Evaluate the data structure according to Scheme’s evaluation rules

  3. Print: Convert the result back to a readable representation and display it

These three operations—read, eval, print—are not just REPL features; they’re exposed as procedures you can call in your programs:

(define input "(+ 1 2)")
(define expr (read (open-input-string input)))  ; Read
(define result (eval expr (interaction-environment)))  ; Eval
(display result)  ; Print

This means you can build interpreters, code generators, domain-specific languages, and other metaprogramming tools using the same operations the REPL uses.

1.4 Overview of Modern Scheme Implementations

The Scheme community has produced dozens of implementations, each with different strengths and target domains. Let’s survey the major players you’ll encounter in this book.

Chez Scheme

Homepage: https://cisco.github.io/ChezScheme/

License: Apache 2.0

First Release: 1984

Current Status: Actively maintained by Cisco

Chez Scheme, originally a commercial product from Cadence Research Systems (founded by R. Kent Dybvig), was open-sourced by Cisco in 2016. It’s widely regarded as the fastest and most mature Scheme implementation available.

Key Features:

Best For: Production applications requiring maximum performance, compiler research, applications needing solid FFI support

Example:

;; Chez Scheme's FFI makes calling C libraries straightforward
(define-ffi-definer define-libc (ffi-lib "libc"))
(define-libc getpid (_fun → _int))
(getpid)  ; ⇒ process ID

Chicken Scheme

Homepage: https://call-cc.org/

License: BSD

First Release: 2000

Current Status: Actively maintained

Chicken takes a unique approach: it compiles Scheme to C, which is then compiled to native code. This “Scheme to C” strategy provides good performance and excellent portability.

Key Features:

Best For: Embedded systems, cross-platform applications, projects requiring C integration, learning Scheme

Example:

;; Installing and using eggs is simple
;; $ chicken-install srfi-69  ; hash tables

(import srfi-69)  ; hash tables
(define h (make-hash-table))
(hash-table-set! h 'name "Alice")
(hash-table-ref h 'name)  ; ⇒ "Alice"

Cyclone Scheme

Homepage: https://justinethier.github.io/cyclone/

License: MIT

First Release: 2014

Current Status: Actively maintained

Cyclone is a modern Scheme-to-C compiler with a focus on native compilation and concurrency. It implements many advanced features while maintaining good performance.

Key Features:

Best For: Concurrent applications, systems programming, modern Scheme development

Example:

;; Cyclone's threading support
(import (cyclone concurrent))

(define (worker n)
  (lambda ()
    (display (string-append "Worker " (number→string n) "\n"))))

(define t1 (thread-start! (make-thread (worker 1))))
(define t2 (thread-start! (make-thread (worker 2))))

(thread-join! t1)
(thread-join! t2)

Gambit Scheme

Homepage: https://gambitscheme.org/

License: LGPL/Apache 2.0

First Release: 1989

Current Status: Actively maintained

Gambit is a highly portable, efficient Scheme system that can compile to C or JavaScript. Its “universal backend” approach makes it suitable for a wide range of platforms.

Key Features:

Best For: Cross-platform development, web applications (via JavaScript backend), embedded systems

Example:

;; Gambit can target JavaScript
;; This Scheme code can run in a browser!
(define (fibonacci n)
  (if (≤ n 1)
      n
      (+ (fibonacci (- n 1))
         (fibonacci (- n 2)))))

;; Compile with: gsc -target js -exe fibonacci.scm

Guile

Homepage: https://www.gnu.org/software/guile/

License: LGPL

First Release: 1993

Current Status: Actively maintained by GNU

Guile is GNU’s official extension language, designed to be embedded in C applications. It’s used as the scripting language for many GNU projects.

Key Features:

Best For: Extending C applications, GNU/Linux system scripting, applications needing a robust extension language

Example:

;; Guile's excellent FFI
(use-modules (system foreign))

(define libc (dynamic-link))
(define strlen
  (pointer→procedure int
                      (dynamic-func "strlen" libc)
                      (list '*)))

(strlen (string→pointer "Hello"))  ; ⇒ 5

Racket

Homepage: https://racket-lang.org/

License: MIT/Apache 2.0

First Release: 1995 (as PLT Scheme)

Current Status: Actively maintained

Racket started as an implementation of Scheme but has evolved into its own language and a “language-oriented programming” platform. While technically no longer a Scheme (it doesn’t claim R⁷RS conformance), it’s deeply rooted in Scheme culture and philosophy.

Key Features:

Best For: Education, language research, building DSLs, GUI applications, web development

Example:

#lang racket

;; Racket's contracts provide runtime checking
(define/contract (divide x y)
  (→ number? (and/c number? (not/c zero?)) number?)
  (/ x y))

(divide 10 2)  ; ⇒ 5
(divide 10 0)  ; Error: contract violation

Implementation Comparison Matrix

Feature Chez Chicken Cyclone Gambit Guile Racket
Standard R⁶RS R⁵RS/R⁷RS R⁷RS R⁵RS/R⁷RS R⁶RS/R⁷RS* Racket
Compilation Native C C C/JS VM+JIT VM+JIT
Performance Excellent Good Good Good Good Good
FFI Excellent Excellent Good Good Excellent Good
Ecosystem Moderate Large Small Moderate Large Very Large
Learning Curve Moderate Easy Easy Moderate Moderate Moderate
Production Ready Yes Yes Yes Yes Yes Yes

*Guile’s R⁶RS support is incomplete

1.5 Installing and Setting Up Your Environment

Let’s get Scheme running on your machine. We’ll cover installation for the major implementations across different operating systems.

Installing Chez Scheme

On Ubuntu/Debian:

sudo apt-get update
sudo apt-get install chezscheme

On macOS (using Homebrew):

brew install chezscheme

On Windows: Download the installer from https://cisco.github.io/ChezScheme/ and run it.

From Source (all platforms):

git clone https://github.com/cisco/ChezScheme.git
cd ChezScheme
./configure
make
sudo make install

Verifying Installation:

$ scheme
Chez Scheme Version 9.5.8
Copyright 1984-2022 Cisco Systems, Inc.

> (+ 1 2)
3
> (exit)

Installing Chicken Scheme

On Ubuntu/Debian:

sudo apt-get update
sudo apt-get install chicken-bin

On macOS:

brew install chicken

On Windows: Download installer from https://code.call-cc.org/

From Source:

wget https://code.call-cc.org/releases/5.3.0/chicken-5.3.0.tar.gz
tar xzf chicken-5.3.0.tar.gz
cd chicken-5.3.0
make PLATFORM=linux
sudo make PLATFORM=linux install

Verifying Installation:

$ csi
CHICKEN
(c) 2008-2021, The CHICKEN Team
(c) 2000-2007, Felix L. Winkelmann
Version 5.3.0 (rev 8b3189e)

#;1> (+ 1 2)
3
#;2> ,q

Installing Cyclone Scheme

From Source (recommended):

git clone https://github.com/justinethier/cyclone.git
cd cyclone
make
sudo make install

Verifying Installation:

$ cyclone
  
                                 _ 
  ___  _   _  ___  _   _  _ _  | |    
 (_ .) | | | |  _)| | | ∨ _ \ |  \
  / /_| | | |( (_ | ( ) ∨ ( ) ∨  /
 |____∨_| |_| \__)|_| |_∨_| |_∨_|
                                       

cyclone> (+ 1 2)
3
cyclone> (exit)

Installing Gambit Scheme

On Ubuntu/Debian:

sudo apt-get install gambc

On macOS:

brew install gambit-scheme

From Source:

git clone https://github.com/gambit/gambit.git
cd gambit
./configure
make
sudo make install

Verifying Installation:

$ gsi
Gambit v4.9.4

> (+ 1 2)
3
> (exit)

Installing Guile

On Ubuntu/Debian:

sudo apt-get install guile-3.0

On macOS:

brew install guile

From Source:

wget ftp://ftp.gnu.org/gnu/guile/guile-3.0.9.tar.gz
tar xzf guile-3.0.9.tar.gz
cd guile-3.0.9
./configure
make
sudo make install

Verifying Installation:

$ guile
GNU Guile 3.0.9
Copyright (C) 1995-2023 Free Software Foundation, Inc.

scheme@(guile-user)> (+ 1 2)
$1 = 3
scheme@(guile-user)> ,q

Installing Racket

On Ubuntu/Debian:

sudo apt-get install racket

On macOS:

brew install --cask racket

On Windows/macOS/Linux: Download the installer from https://racket-lang.org/ (recommended for best experience)

Verifying Installation:

$ racket
Welcome to Racket v8.10.
> (+ 1 2)
3
> (exit)

Setting Up Your Path

After installation, ensure the Scheme executables are in your PATH. Add to your ~/.bashrc or ~/.zshrc:

# For Chez
export PATH=$PATH:/usr/local/bin

# For Chicken (if eggs are used)
export PATH=$PATH:~/.chicken-install/bin

# For Racket
export PATH=$PATH:/Applications/Racket/bin  # macOS

1.6 Your First Scheme Program

Let’s write and run your first Scheme program. We’ll use Chez Scheme for these examples, but the code will work in most implementations.

Hello, World!

Create a file called hello.scm:

#!/usr/bin/env scheme
;; hello.scm - My first Scheme program

(display "Hello, World!")
(newline)

Run it:

$ scheme --script hello.scm
Hello, World!

Understanding the Code

Let’s break down what happened:

  1. #!/usr/bin/env scheme - The shebang line tells the system to run this file with scheme

  2. ;; - Double semicolon starts a comment

  3. (display "Hello, World!") - Call the display procedure with the string argument

  4. (newline) - Print a newline character

Notice the parentheses. In Scheme, every function call is written in prefix notation: (function arg1 arg2 …). The opening parenthesis starts the expression, the first element is the function to call, subsequent elements are arguments, and the closing parenthesis ends the expression.

Interactive Exploration

Start a REPL:

$ scheme

Try these expressions:

> (+ 2 3)
5

> (* 4 5)
20

> (- 10 3)
7

> (/ 15 3)
5

> (+ (* 2 3) (- 8 2))
12

> (define x 42)
> x
42

> (define (square n)
    (* n n))
> (square 5)
25

> (square (square 3))
81

A More Interesting Program

Create factorial.scm:

#!/usr/bin/env scheme
;; factorial.scm - Calculate factorials

(define (factorial n)
  "Calculate n! using recursion"
  (if (≤ n 1)
      1
      (* n (factorial (- n 1)))))

(define (factorial-iter n)
  "Calculate n! using tail recursion"
  (define (iter count acc)
    (if (> count n)
        acc
        (iter (+ count 1) (* acc count))))
  (iter 1 1))

;; Test both versions
(display "Recursive: ")
(display (factorial 10))
(newline)

(display "Iterative: ")
(display (factorial-iter 10))
(newline)

Run it:

$ scheme --script factorial.scm
Recursive: 3628800
Iterative: 3628800

Understanding Recursion

The recursive version is straightforward but uses stack space proportional to nn:

n!={1if n≤1n×(n−1)!otherwise n! = \begin{cases} 1 & \text{if } n \leq 1 \\ n \times (n-1)! & \text{otherwise} \end{cases}

The iterative version uses an accumulator and tail recursion, using constant stack space:

(define (factorial-iter n)
  (define (iter count acc)
    (if (> count n)
        acc
        (iter (+ count 1) (* acc count))))
  (iter 1 1))

The iter procedure is tail-recursive because the recursive call is the last operation performed. Scheme implementations must optimize tail calls, so this uses only constant stack space even for large nn.

A Practical Example: File Processing

Create word-count.scm:

#!/usr/bin/env scheme
;; word-count.scm - Count words in a file

(define (read-file filename)
  "Read entire file into a string"
  (call-with-input-file filename
    (lambda (port)
      (let loop ((chars '()))
        (let ((char (read-char port)))
          (if (eof-object? char)
              (list→string (reverse chars))
              (loop (cons char chars))))))))

(define (count-words text)
  "Count words in a string"
  (length (filter (lambda (s) (> (string-length s) 0))
                  (string-split text #\space))))

(define (string-split str delimiter)
  "Split string on delimiter"
  (let loop ((chars (string→list str))
             (current '())
             (result '()))
    (cond
      ((null? chars)
       (reverse (if (null? current)
                    result
                    (cons (list→string (reverse current)) result))))
      ((char=? (car chars) delimiter)
       (loop (cdr chars)
             '()
             (if (null? current)
                 result
                 (cons (list→string (reverse current)) result))))
      (else
       (loop (cdr chars)
             (cons (car chars) current)
             result)))))

;; Main program
(when (> (length (command-line)) 1)
  (let ((filename (cadr (command-line))))
    (display "Word count: ")
    (display (count-words (read-file filename)))
    (newline)))

Usage:

$ echo "The quick brown fox jumps over the lazy dog" > test.txt
$ scheme --script word-count.scm test.txt
Word count: 9

Program Structure

Notice the structure of our programs:

  1. Helper procedures: read-file, string-split

  2. Main logic: count-words

  3. Entry point: The when form at the bottom

This is idiomatic Scheme: build up abstractions through procedures, compose them, and have a thin layer at the top that orchestrates everything.

Key Takeaways

From these examples, you should understand:

  1. Prefix notation: Everything is (function arg1 arg2 …)

  2. Recursion: The natural way to express iteration in Scheme

  3. Tail recursion: Allows iteration with constant space

  4. Higher-order functions: Functions that take or return functions (like filter)

  5. let expressions: For local bindings

  6. Conditional expressions: if, cond, when

Summary

In this chapter, we’ve journeyed from the birth of LISP in 1958 to modern Scheme implementations. We’ve seen how Scheme distills Lisp’s essence into an elegant, minimalist language that nonetheless possesses extraordinary expressive power.

Key points to remember:

In the next chapter, we’ll dive deep into S-expressions and the symbolic foundation that makes Scheme special. We’ll explore Sato’s S-expression theory and understand how the uniformity of Scheme’s syntax enables its power.

Exercises

  1. Installation Challenge: Install at least two different Scheme implementations on your system. Compare their REPL experiences. Which do you prefer and why?

  2. Hello Variations: Write five different programs that print “Hello, World!” using different Scheme procedures and techniques.

  3. Factorial Comparison: Implement three versions of factorial: recursive, tail-recursive with an accumulator, and using a named let. Compare their performance on large inputs.

  4. First Real Program: Write a Scheme program that reads a file and prints statistics about it: number of lines, words, and characters. Handle errors gracefully.

  5. Implementation Features: For each Scheme implementation you installed, find and document one unique feature it offers that others don’t.

  6. Performance Experiment: Benchmark the factorial function in different Scheme implementations. Which is fastest? Why might that be?

  7. REPL Exploration: Spend 30 minutes in a Scheme REPL just experimenting. Try arithmetic, define variables, create functions. Keep notes on surprising behaviors or interesting discoveries.

In the next chapter, we’ll explore the theoretical foundations of S-expressions and understand how Scheme’s simple syntax enables its remarkable power.

Chapter 2: S-Expressions and the Symbolic Foundation

2.1 Sato’s S-Expression Theory

The symbolic expression, or S-expression, is the fundamental data structure that underlies all Lisp dialects, including Scheme. While John McCarthy introduced S-expressions in 1958 as a notation for representing both programs and data in Lisp, the theoretical foundations were later formalized and extended by researchers including Takeshi Sato and others who explored the mathematical properties of these structures.

The Deep Insight: Code Is Data, Data Is Code

The revolutionary insight of S-expressions is this: there is no distinction between program syntax and data structure. When you write:

(+ 1 2)

You are simultaneously expressing:

  1. A computation: “add 1 and 2”

  2. A data structure: a list containing the symbol + and the numbers 1 and 2

  3. A tree structure: a node labeled + with two children, 1 and 2

This trinity—computation, data, structure—is the essence of homoiconicity. The term comes from the Greek “homo” (same) and “icon” (representation). In a homoiconic language, the program’s internal representation matches its external representation.

Why This Matters

Consider how programs work in most languages. In C, for instance:

int sum = 2 + 3;

To the C compiler, this is a stream of tokens parsed according to a complex grammar with precedence rules, operator associativity, and special cases. The source text “2 + 3” is fundamentally different from the internal representation the compiler builds (an abstract syntax tree).

Now consider Scheme:

(define sum (+ 2 3))

The text (+ 2 3) is already a data structure—a list. The reader parses it into exactly that: a list containing a symbol and two numbers. No complex grammar, no precedence rules, no special cases. The parsed representation is structurally identical to the source text.

This means a Scheme program can:

Formal Definition

Let’s define S-expressions formally. An S-expression is one of:

  1. An atom: An indivisible value such as:

    • A number: 42, 3.14, 2/3, 1+2i

    • A boolean: #t (true) or #f (false)

    • A symbol: x, lambda, +, my-variable

    • A string: "hello"

    • A character: #\a, #\space

    • The empty list: '() or nil

  2. A pair (also called a cons cell): Written (x . y) where x and y are S-expressions

    • The first element is called the car

    • The second element is called the cdr

  3. A list: A chain of pairs ending in the empty list

    • Written (e₁ e₂ … eₙ) where each eᵢ is an S-expression

    • Syntactic sugar for nested pairs: (a b c) ≡ (a . (b . (c . ())))

Mathematically, we can express this as a recursive algebraic data type:

S-expr::=Atom|(S-expr.S-expr)Atom::=Number∣Symbol∣Boolean∣String∣⋯ \begin{align} \text{S-expr} ::= & \; \text{Atom} \\ | & \; (\text{S-expr} \; . \; \text{S-expr}) \\ \text{Atom} ::= & \; \text{Number} \mid \text{Symbol} \mid \text{Boolean} \mid \text{String} \mid \cdots \end{align}

The Pair: The Universal Building Block

At the heart of S-expressions is the pair (or cons cell). A pair is simply a container holding two values. We represent pairs using box-and-pointer notation:

(a . b) → ┌───┬───┐ │ • │ • │ └─┼─┴─┼─┘ │ │ ↓ ↓ a b

Each box has two slots:

The names “car” and “cdr” come from the IBM 704, the machine on which Lisp was first implemented:

Despite their archaic origins, these names have persisted because they’re short and distinct.

Lists as Chains of Pairs

A list is constructed by chaining pairs, with each cdr pointing to the next pair, until the final cdr points to the empty list '():

'(a b c)

Is equivalent to:

(cons 'a (cons 'b (cons 'c '())))

In box-and-pointer notation:

┌│───┬───┐ ┌───┬───┐ ┌───┬───┐

││ • │ •─┼──→│ • │ •─┼──→│ • │ / │ └─┼─┴───┘ └─┼─┴───┘ └─┼─┴───┘ │ │ │ ↓ ↓ ↓ a b c

The slash (/) represents the empty list.

Dotted Pairs vs. Proper Lists

Not all pairs form proper lists. A proper list ends with the empty list:

'(a b c)          ; proper list
'(a . (b . (c . ())))  ; same, in dotted notation

An improper list or dotted pair doesn’t:

'(a . b)          ; dotted pair, not a list
'(a b . c)        ; improper list

In box-and-pointer notation:

(a . b) → ┌───┬───┐ │ • │ • │ └─┼─┴─┼─┘ │ │ ↓ ↓ a b

(a b . c) → ┌───┬───┐ ┌───┬───┐ │ • │ •─┼──→│ • │ • │ └─┼─┴───┘ └─┼─┴─┼─┘ │ │ │ ↓ ↓ ↓ a b c

Most Scheme programming uses proper lists, but dotted pairs are occasionally useful for association lists and other specialized data structures.

2.2 Syntax as Data: Homoiconicity

The Reader: From Text to Structure

When you type S-expressions at the REPL or load them from a file, Scheme’s reader converts textual representations into internal data structures. Understanding this process is crucial for mastering Scheme.

The reader performs these steps:

  1. Lexical analysis: Break the input into tokens

  2. Syntactic analysis: Group tokens into S-expressions

  3. Construction: Build the actual data structures

Let’s trace through an example:

(define (factorial n)
  (if (= n 0)
      1
      (* n (factorial (- n 1)))))

Step 1: Tokenization

The reader identifies:

Step 2: Parsing

The reader builds a nested structure:

(define (factorial n) (if (= n 0) 1 (* n (factorial (- n 1)))))

Step 3: Construction

The reader creates actual Scheme objects—a list of lists containing symbols and numbers.

The Read Procedure

Scheme exposes the reader as the read procedure:

> (read (open-input-string "(+ 1 2)"))
(+ 1 2)

> (define expr (read (open-input-string "(* 3 4)")))
> expr
(* 3 4)

> (car expr)
*

> (cadr expr)
3

> (caddr expr)
4

Notice that read returns data, not an evaluated result. We can manipulate this data:

> (define expr '(+ 1 2))
> (list? expr)
#t

> (symbol? (car expr))
#t

> (cons 'list expr)
(list + 1 2)

The Write Procedure

The inverse of read is write, which converts data structures back to text:

> (write '(a b c))
(a b c)

> (write (list 'define 'x 42))
(define x 42)

> (display "Hello\n")
Hello

Note: display is like write but doesn’t print quotes around strings.

The Eval Procedure

Finally, eval evaluates S-expressions as code:

> (define expr '(+ 1 2))
> (eval expr (interaction-environment))
3

> (define program '(define (square x) (* x x)))
> (eval program (interaction-environment))
> (square 5)
25

This trinity—read, eval, write—gives us complete control over the program lifecycle:

(define (repl)
  (display "scheme> ")
  (let ((input (read)))
    (unless (eof-object? input)
      (write (eval input (interaction-environment)))
      (newline)
      (repl))))

This is a complete REPL in just 7 lines!

2.3 Reading and Printing S-Expressions

Atomic Values

Let’s explore how different types of atoms are read and written:

Numbers:

> 42          ; integer
42
> 3.14159     ; floating-point

3.14159
> 2/3         ; rational
2/3
> 1+2i        ; complex
1+2i
> #b101       ; binary
5
> #o17        ; octal
15
> #x1A        ; hexadecimal
26
> #e3.5       ; exact
7/2
> #i7/2       ; inexact

3.5

Scheme’s numeric tower is quite sophisticated. Numbers can be:

Booleans:

> #t
#t
> #f
#f
> #true    ; R7RS
#t
> #false   ; R7RS
#f

Characters:

> #\a
#\a
> #\A
#\A
> #\space
#\space
> #\newline
#\newline
> #\x3BB    ; Unicode lambda
#\λ

Strings:

> "hello"
"hello"
> "with \"quotes\" inside"
"with \"quotes\" inside"
> "multiple\nlines"
"multiple\nlines"
> (display "multiple\nlines")
multiple
lines

Symbols:

> 'hello
hello
> 'Hello
Hello
> '|symbols can have spaces|
|symbols can have spaces|
> '+
+
> 'list→vector
list→vector

Symbols are case-sensitive in R7RS Scheme (though some implementations fold case by default).

List Notation

Proper lists:

> '()
()
> '(a)
(a)
> '(a b c)
(a b c)
> '(1 2 (3 4) 5)
(1 2 (3 4) 5)

Dotted pairs and improper lists:

> '(a . b)
(a . b)
> '(a b . c)
(a b . c)
> '(a . (b . c))
(a b . c)
> (cons 1 2)
(1 . 2)
> (cons 1 (cons 2 3))
(1 2 . 3)

Equivalences:

> (equal? '(a b c) (cons 'a (cons 'b (cons 'c '()))))
#t

> (equal? '(a . (b . (c . ()))) '(a b c))
#t

> (equal? (list 1 2 3) '(1 2 3))
#t

The Quote

The single quote ' is syntactic sugar for the quote special form:

> 'x
x
> (quote x)
x
> '(+ 1 2)
(+ 1 2)
> (quote (+ 1 2))
(+ 1 2)

Without quoting, Scheme evaluates expressions:

> (+ 1 2)
3
> '(+ 1 2)
(+ 1 2)

The quote prevents evaluation, treating the expression as pure data.

Other Reader Abbreviations

Scheme provides several abbreviations:

Quasiquote (`):

> `(1 2 3)
(1 2 3)
> (quasiquote (1 2 3))
(1 2 3)

Unquote (,):

> (define x 10)
> `(1 ,x 3)
(1 10 3)
> `(1 ,(+ 2 3) 4)
(1 5 4)

Unquote-splicing (,@):

> (define lst '(a b c))
> `(1 ,lst 2)
(1 (a b c) 2)
> `(1 ,@lst 2)
(1 a b c 2)

We’ll explore quasiquotation deeply in the macros chapter.

2.4 The Reader Algorithm

Let’s understand how the reader works by implementing a simplified version. This will demystify the reading process and prepare us for understanding macros.

Tokenization

First, we need to break input into tokens:

(define (tokenize str)
  "Break a string into tokens"
  (define (char-delimiter? c)
    (or (char-whitespace? c)
        (char=? c #\()
        (char=? c #\))
        (char=? c #\')
        (char=? c #\`)))
  
  (define (read-atom chars acc tokens)
    (cond
      ((null? chars)
       (if (null? acc)
           (reverse tokens)
           (reverse (cons (list→string (reverse acc)) tokens))))
      ((char-delimiter? (car chars))
       (read-token (cdr chars)
                   (if (null? acc)
                       tokens
                       (cons (list→string (reverse acc)) tokens))))
      (else
       (read-atom (cdr chars) (cons (car chars) acc) tokens))))
  
  (define (read-token chars tokens)
    (cond
      ((null? chars) (reverse tokens))
      ((char-whitespace? (car chars))
       (read-token (cdr chars) tokens))
      ((char=? (car chars) #\()
       (read-token (cdr chars) (cons "(" tokens)))
      ((char=? (car chars) #\))
       (read-token (cdr chars) (cons ")" tokens)))
      ((char=? (car chars) #\')
       (read-token (cdr chars) (cons "'" tokens)))
      (else
       (read-atom (cdr chars) '() tokens))))
  
  (read-token (string→list str) '()))

Testing it:

> (tokenize "(+ 1 2)")
("(" "+" "1" "2" ")")

> (tokenize "(define (square x) (* x x))")
("(" "define" "(" "square" "x" ")" "(" "*" "x" "x" ")" ")")

> (tokenize "'(a b c)")
("'" "(" "a" "b" "c" ")")

Parsing

Now we parse tokens into S-expressions:

(define (parse tokens)
  "Parse tokens into S-expressions"
  (define (parse-one tokens)
    (cond
      ((null? tokens)
       (error "Unexpected end of input"))
      
      ((string=? (car tokens) "(")
       (parse-list (cdr tokens) '()))
      
      ((string=? (car tokens) "'")
       (let-values (((expr rest) (parse-one (cdr tokens))))
         (values (list 'quote expr) rest)))
      
      ((string=? (car tokens) ")")
       (error "Unexpected )"))
      
      (else
       (values (parse-atom (car tokens)) (cdr tokens)))))
  
  (define (parse-list tokens acc)
    (cond
      ((null? tokens)
       (error "Unmatched ("))
      
      ((string=? (car tokens) ")")
       (values (reverse acc) (cdr tokens)))
      
      (else
       (let-values (((expr rest) (parse-one tokens)))
         (parse-list rest (cons expr acc))))))
  
  (define (parse-atom token)
    (cond
      ((string→number token) ⇒ (lambda (n) n))
      ((string=? token "#t") #t)
      ((string=? token "#f") #f)
      (else (string→symbol token))))
  
  (let-values (((expr rest) (parse-one tokens)))
    (if (null? rest)
        expr
        (error "Extra tokens after expression" rest))))

Testing:

> (parse (tokenize "(+ 1 2)"))
(+ 1 2)

> (parse (tokenize "'(a b c)"))
(quote (a b c))

> (parse (tokenize "(define (factorial n) (if (= n 0) 1 (* n (factorial (- n 1)))))"))
(define (factorial n) (if (= n 0) 1 (* n (factorial (- n 1)))))

Complete Reader

Combining tokenization and parsing:

(define (my-read str)
  "Simple S-expression reader"
  (parse (tokenize str)))

> (my-read "(+ 1 2)")
(+ 1 2)

> (eval (my-read "(+ 1 2)") (interaction-environment))
3

This simplified reader handles basic S-expressions. Production readers handle many more cases: strings with escapes, different number formats, comments, reader macros, etc.

2.5 Quoting and Quasi-quoting

Why Quote?

Consider what happens when we evaluate an expression:

> (+ 1 2)
3

Scheme evaluates + to a procedure, 1 and 2 to themselves, then applies the procedure to the arguments.

But what if we want the list itself, not its value?

> '(+ 1 2)
(+ 1 2)

The quote prevents evaluation. It says “treat this as data, not code.”

Quote in Depth

quote is a special form—it doesn’t evaluate its argument:

> (quote x)
x
> (quote (+ 1 2))
(+ 1 2)
> (quote (quote x))
(quote x)

Everything inside a quote is data:

> '(define (factorial n)
     (if (= n 0)
         1
         (* n (factorial (- n 1)))))
(define (factorial n) (if (= n 0) 1 (* n (factorial (- n 1)))))

This is just a list structure—no definitions happen, no procedures are created.

Quasiquote: Selective Evaluation

Quasiquote (`) is like quote, but allows selective evaluation using unquote (,):

> (define x 10)
> `(1 2 ,x)
(1 2 10)

The quasiquote quotes everything except what’s explicitly unquoted:

> `(+ 1 2)
(+ 1 2)
> `(+ 1 ,(+ 1 1))
(+ 1 2)
> (let ((x 5))
    `(the value is ,x))
(the value is 5)

Unquote-splicing (,@) splices lists:

> (define lst '(a b c))
> `(1 ,lst 4)
(1 (a b c) 4)
> `(1 ,@lst 4)
(1 a b c 4)

Building Code with Quasiquote

Quasiquote is essential for macros and code generation:

(define (make-adder n)
  "Generate code to add n to something"
  `(lambda (x) (+ x ,n)))

> (make-adder 5)
(lambda (x) (+ x 5))

> (eval (make-adder 5) (interaction-environment))
#<procedure>

> ((eval (make-adder 5) (interaction-environment)) 10)
15

A more complex example:

(define (make-procedure name args body)
  "Generate a procedure definition"
  `(define (,name ,@args) ,body))

> (make-procedure 'square '(x) '(* x x))
(define (square x) (* x x))

> (eval (make-procedure 'square '(x) '(* x x)) 
        (interaction-environment))
> (square 5)
25

Nested Quasiquotes

Quasiquotes can nest:

> `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)
(a `(b ,(+ 1 2) ,(foo 4 d) e) f)

Each level of quasiquote requires its own level of unquote. The outer unquote evaluates at the outer level, while inner unquotes are preserved.

This is mind-bending but crucial for macro-writing macros—macros that generate other macros!

2.6 Symbol Manipulation and Symbolic Computation

Symbols as First-Class Objects

In most programming languages, identifiers are just names—they disappear at runtime. In Scheme, symbols are first-class values you can manipulate:

> 'hello
hello
> (symbol? 'hello)
#t
> (symbol? "hello")
#f
> (symbol? 42)
#f

Symbols have identity:

> (eq? 'hello 'hello)
#t
> (eq? 'hello 'goodbye)
#f

The eq? predicate tests whether two symbols are the same object—not just equal values, but literally the same symbol.

Symbol Operations

Creating symbols:

> (string→symbol "hello")
hello
> (string→symbol "HELLO")
HELLO
> (symbol→string 'hello)
"hello"

Comparing symbols:

> (eq? 'apple 'apple)
#t
> (eq? 'apple 'orange)
#f
> (eqv? 'apple 'apple)
#t
> (equal? 'apple 'apple)
#t

For symbols, eq?, eqv?, and equal? all work the same way.

Symbol properties (implementation-dependent):

;; In some Schemes
> (put-symbol-property! 'color 'red 'wavelength 700)
> (get-symbol-property 'color 'wavelength)
700

Symbolic Computation Examples

Symbolic Differentiation:

Let’s implement basic symbolic differentiation:

(define (deriv expr var)
  "Compute derivative of expr with respect to var"
  (cond
    ;; d/dx(c) = 0
    ((number? expr) 0)
    
    ;; d/dx(x) = 1, d/dx(y) = 0
    ((symbol? expr)
     (if (eq? expr var) 1 0))
    
    ;; d/dx(u + v) = du/dx + dv/dx
    ((eq? (car expr) '+)
     `(+ ,(deriv (cadr expr) var)
         ,(deriv (caddr expr) var)))
    
    ;; d/dx(u - v) = du/dx - dv/dx
    ((eq? (car expr) '-)
     `(- ,(deriv (cadr expr) var)
         ,(deriv (caddr expr) var)))
    
    ;; d/dx(u * v) = u * dv/dx + v * du/dx
    ((eq? (car expr) '*)
     `(+ (* ,(cadr expr) ,(deriv (caddr expr) var))
         (* ,(caddr expr) ,(deriv (cadr expr) var))))
    
    ;; d/dx(u / v) = (v * du/dx - u * dv/dx) / v²
    ((eq? (car expr) '/)
     (let ((u (cadr expr))
           (v (caddr expr)))
       `(/ (- (* ,v ,(deriv u var))
              (* ,u ,(deriv v var)))
           (* ,v ,v))))
    
    (else
     (error "Unknown expression type" expr))))

Testing:

> (deriv '(+ x 3) 'x)
(+ 1 0)

> (deriv '(* x x) 'x)
(+ (* x 1) (* x 1))

> (deriv '(* (* x x) x) 'x)
(+ (* (* x x) 1) (* x (+ (* x 1) (* x 1))))

The results are correct but not simplified. Let’s add simplification:

(define (simplify expr)
  "Simplify arithmetic expressions"
  (if (not (pair? expr))
      expr
      (let ((op (car expr))
            (args (map simplify (cdr expr))))
        (case op
          ((+)
           (let ((a (car args)) (b (cadr args)))
             (cond
               ((and (number? a) (= a 0)) b)
               ((and (number? b) (= b 0)) a)
               ((and (number? a) (number? b)) (+ a b))
               (else `(+ ,a ,b)))))
          
          ((-)
           (let ((a (car args)) (b (cadr args)))
             (cond
               ((and (number? b) (= b 0)) a)
               ((and (number? a) (number? b)) (- a b))
               (else `(- ,a ,b)))))
          
          ((*)
           (let ((a (car args)) (b (cadr args)))
             (cond
               ((or (and (number? a) (= a 0))
                    (and (number? b) (= b 0))) 0)
               ((and (number? a) (= a 1)) b)
               ((and (number? b) (= b 1)) a)
               ((and (number? a) (number? b)) (* a b))
               (else `(* ,a ,b)))))
          
          ((/)
           (let ((a (car args)) (b (cadr args)))
             (cond
               ((and (number? b) (= b 1)) a)
               ((and (number? a) (number? b)) (/ a b))
               (else `(/ ,a ,b)))))
          
          (else expr)))))

(define (deriv-simplified expr var)
  (simplify (deriv expr var)))

Now:

> (deriv-simplified '(+ x 3) 'x)
1

> (deriv-simplified '(* x x) 'x)
(+ x x)

> (deriv-simplified '(* (* x x) x) 'x)
(+ (* x x) (* x (+ x x)))

Much better!

Pattern Matching:

(define (match pattern expr bindings)
  "Match pattern against expression, returning bindings or #f"
  (cond
    ;; Variable matches anything
    ((and (symbol? pattern)
          (char=? (string-ref (symbol→string pattern) 0) #\?))
     (let ((binding (assq pattern bindings)))
       (if binding
           (if (equal? (cdr binding) expr)
               bindings
               #f)
           (cons (cons pattern expr) bindings))))
    
    ;; Atoms must match exactly
    ((or (number? pattern) (boolean? pattern) (string? pattern))
     (if (equal? pattern expr) bindings #f))
    
    ;; Symbols must match exactly
    ((symbol? pattern)
     (if (eq? pattern expr) bindings #f))
    
    ;; Lists must match recursively
    ((pair? pattern)
     (and (pair? expr)
          (let ((rest-bindings (match (car pattern) (car expr) bindings)))
            (and rest-bindings
                 (match (cdr pattern) (cdr expr) rest-bindings)))))
    
    ;; Empty list
    ((null? pattern)
     (if (null? expr) bindings #f))
    
    (else #f)))

(define (substitute pattern bindings)
  "Replace variables in pattern with their bindings"
  (cond
    ((and (symbol? pattern)
          (char=? (string-ref (symbol→string pattern) 0) #\?))
     (let ((binding (assq pattern bindings)))
       (if binding (cdr binding) pattern)))
    
    ((pair? pattern)
     (cons (substitute (car pattern) bindings)
           (substitute (cdr pattern) bindings)))
    
    (else pattern)))

Using pattern matching:

> (match '(+ ?x ?x) '(+ a a) '())
((?x . a))

> (match '(* ?x ?y) '(* 2 3) '())
((?y . 3) (?x . 2))

> (match '(+ ?x ?x) '(+ a b) '())
#f

> (substitute '(* ?x 2) '((?x . 5)))
(* 5 2)

We can use this for algebraic simplification rules:

(define (apply-rule expr rule)
  "Apply a rewrite rule to an expression"
  (let ((pattern (car rule))
        (replacement (cadr rule)))
    (let ((bindings (match pattern expr '())))
      (if bindings
          (substitute replacement bindings)
          expr))))

(define simplification-rules
  '(((+ ?x 0) ?x)
    ((+ 0 ?x) ?x)
    ((* ?x 0) 0)
    ((* 0 ?x) 0)
    ((* ?x 1) ?x)
    ((* 1 ?x) ?x)
    ((- ?x 0) ?x)
    ((/ ?x 1) ?x)))

(define (simplify-with-rules expr)
  (if (not (pair? expr))
      expr
      (let ((simplified-args (map simplify-with-rules (cdr expr))))
        (let ((expr-with-simple-args (cons (car expr) simplified-args)))
          (let loop ((rules simplification-rules))
            (if (null? rules)
                expr-with-simple-args
                (let ((result (apply-rule expr-with-simple-args (car rules))))
                  (if (equal? result expr-with-simple-args)
                      (loop (cdr rules))
                      result))))))))

Testing:

> (simplify-with-rules '(+ (* x 1) 0))
x

> (simplify-with-rules '(* (+ a 0) (- b 0)))
(* a b)

Lisp as a Universal Representation

The power of symbolic computation extends beyond mathematics. S-expressions can represent:

Logical propositions:

(define (implies? p q)
  `(or (not ,p) ,q))

> (implies? 'A 'B)
(or (not A) B)

Natural language:

(define sentence
  '(the (quick brown fox) (jumps (over (the (lazy dog))))))

Abstract syntax trees:

(define java-code
  '(class Point
     (field private int x)
     (field private int y)
     (method public void setX ((int newX))
       (= this.x newX))))

Database queries:

(define query
  '(select (name salary)
     (from employees)
     (where (> salary 50000))))

This universality is why Lisp and Scheme excel at AI, compilers, theorem provers, and any domain requiring symbolic manipulation.

Summary

In this chapter, we’ve explored the theoretical and practical foundations of S-expressions:

  1. S-expressions are the universal data structure of Scheme—everything is atoms, pairs, or lists

  2. Homoiconicity means code is data and data is code—there’s no distinction

  3. The reader parses text into S-expressions using simple, uniform rules

  4. Quoting prevents evaluation, treating code as data

  5. Quasiquoting allows selective evaluation within quoted structures

  6. Symbols are first-class values for symbolic computation

  7. Symbolic manipulation enables powerful metaprogramming, from calculus to code generation

The elegance of S-expressions lies in their simplicity. With just atoms and pairs, we can represent programs, data structures, and abstract ideas uniformly. This uniformity is the foundation of Scheme’s power.

Exercises

  1. Box-and-Pointer Diagrams: Draw box-and-pointer diagrams for:

    • '(a (b c) d)

    • '((a b) (c d))

    • '(a . (b . (c . d)))

  2. Dotted Notation: Convert these to fully dotted notation:

    • '(a b c d)

    • '((1 2) (3 4))

    • '(a (b (c (d))))

  3. Reader Implementation: Extend the simple reader to handle:

    • Strings with escape sequences

    • Comments (; to end of line)

    • Vectors (#(1 2 3))

  4. Quasiquote Practice: What do these evaluate to?

    • `(1 ,(+ 1 1) 3)

    • (let ((x 5)) `(,x ,(* x 2)))

    • `(a `(b ,(+ 1 2) ,(+ 3 ,(+ 2 2)) e))

  5. Symbolic Differentiation: Extend deriv to handle:

    • Exponentiation: (expt base power)

    • Logarithms: (log n)

    • Trigonometric functions: (sin x), (cos x)

  6. Pattern Matcher: Enhance the pattern matcher to support:

    • Sequence variables: ?*x matches zero or more elements

    • Predicates: (?x number?) matches numbers only

    • Nested patterns

  7. Rule-Based System: Build a small expert system using pattern matching and rules. For example, a medical diagnosis system or an animal guessing game.

  8. Code Generator: Write a function that takes a mathematical formula in infix notation (as a string) and generates Scheme code. For example: "x^2 + 2*x + 1" → (+ (expt x 2) (* 2 x) 1).

In the next chapter, we’ll build on this foundation to explore Scheme’s core evaluation semantics—how the language actually executes programs.

Chapter 3: Core Language Semantics

3.1 The Evaluation Model: From Expression to Value

At the heart of every programming language lies its evaluation model—the rules that determine how expressions are transformed into values. Understanding Scheme’s evaluation model is essential for mastering the language and thinking clearly about computation itself.

The Fundamental Cycle

Scheme’s evaluation follows a simple, elegant cycle:

Expression → Read → Eval → Print → Loop

But what happens during Eval? Let’s formalize this.

The Evaluation Rules

Scheme’s evaluation is defined by structural recursion over expressions. Given an expression ee and an environment ρ\rho (which maps symbols to values), we define the evaluation function ℰ\mathcal{E} as follows:

ℰ:Expression×Environment→Value \mathcal{E} : \text{Expression} \times \text{Environment} \rightarrow \text{Value}

Rule 1: Self-Evaluating Expressions

Numbers, booleans, strings, and characters evaluate to themselves:

ℰ[[literal]]ρ=literal \mathcal{E}[\![\text{literal}]\!]\rho = \text{literal} 

> 42
42
> #t
#t
> "hello"
"hello"
> #\a
#\a

Rule 2: Variable Reference

A symbol evaluates to its binding in the environment:

ℰ[[x]]ρ=ρ(x) \mathcal{E}[\![x]\!]\rho = \rho(x) 

> (define x 10)
> x
10
> (define y 20)
> y
20

If x∉dom(ρ)x \notin \text{dom}(\rho), an “unbound variable” error occurs.

Rule 3: Procedure Application

For a compound expression (e0e1…en)(e_0 \; e_1 \; \ldots \; e_n):

  1. Evaluate the operator e0e_0 to obtain a procedure pp

  2. Evaluate each operand eie_i to obtain values viv_i

  3. Apply pp to the values v1,…,vnv_1, \ldots, v_n

ℰ[[(e0e1…en)]]ρ=apply(ℰ[[e0]]ρ,ℰ[[e1]]ρ,…,ℰ[[en]]ρ) \mathcal{E}[\![(e_0 \; e_1 \; \ldots \; e_n)]\!]\rho = \text{apply}(\mathcal{E}[\![e_0]\!]\rho, \mathcal{E}[\![e_1]\!]\rho, \ldots, \mathcal{E}[\![e_n]\!]\rho) 

> (+ 1 2)
3
> (* (+ 1 2) (- 5 2))
9

Step-by-step for (* (+ 1 2) (- 5 2)):

  1. Evaluate * → #<procedure:▻

  2. Evaluate (+ 1 2):

    • Evaluate + → #<procedure:+>

    • Evaluate 1 → 1

    • Evaluate 2 → 2

    • Apply + to (1 2) → 3

  3. Evaluate (- 5 2):

    • Evaluate - → #<procedure:→

    • Evaluate 5 → 5

    • Evaluate 2 → 2

    • Apply - to (5 2) → 3

  4. Apply * to (3 3) → 9

Rule 4: Special Forms

Certain expressions have special evaluation rules that don’t follow the standard application rule. These are called special forms:

We’ll examine each special form in detail below.

Applicative vs. Normal Order

The evaluation rule for procedure application describes applicative-order evaluation:

  1. Evaluate all arguments first

  2. Then apply the procedure

This is also called “call-by-value” or “eager evaluation.”

An alternative is normal-order evaluation:

  1. Apply the procedure to unevaluated arguments

  2. Evaluate arguments only when needed

This is also called “call-by-name” or “lazy evaluation.”

Scheme uses applicative-order evaluation by default (like most languages), though we can implement lazy evaluation using delay and force (Chapter 14).

Example showing the difference:

(define (square x)
  (* x x))

(square (+ 2 3))

Applicative order: (square (+ 2 3)) → (square 5) ; evaluate argument first → (* 5 5) → 25

Normal order: (square (+ 2 3)) → (* (+ 2 3) (+ 2 3)) ; substitute unevaluated → (* 5 (+ 2 3)) → (* 5 5) → 25

Notice that normal order evaluates (+ 2 3) twice! This can be inefficient, though lazy languages like Haskell use memoization to cache results.

3.2 Special Forms: The Cornerstones of Scheme

Special forms are the atomic building blocks of the language—they cannot be defined in terms of procedures. Let’s examine each one.

Quote: Preventing Evaluation

Syntax: (quote expr) or 'expr

Semantics: Returns expr without evaluating it.

ℰ[[(quotee)]]ρ=e \mathcal{E}[\![(\text{quote} \; e)]\!]\rho = e 

> (quote x)
x
> (quote (+ 1 2))
(+ 1 2)
> 'hello
hello
> '(a b c)
(a b c)

Quote is essential for treating code as data:

> (define expr '(+ 1 2))
> expr
(+ 1 2)
> (car expr)
+
> (cadr expr)
1

If: Conditional Evaluation

Syntax: (if test consequent alternate)

Semantics:

ℰ[[(ifetecea)]]ρ={ℰ[[ec]]ρif ℰ[[et]]ρ≠falseℰ[[ea]]ρotherwise \mathcal{E}[\![(\text{if} \; e_t \; e_c \; e_a)]\!]\rho = \begin{cases} \mathcal{E}[\![e_c]\!]\rho & \text{if } \mathcal{E}[\![e_t]\!]\rho \neq \text{false} \\ \mathcal{E}[\![e_a]\!]\rho & \text{otherwise} \end{cases} 

> (if (> 3 2) 'yes 'no)
yes
> (if (< 3 2) 'yes 'no)
no
> (if #t 1 2)
1
> (if #f 1 2)
2

Important: Only the chosen branch is evaluated:

> (if #t
      'ok
      (error "This won't execute"))
ok

> (if #f
      (error "This won't execute")
      'ok)
ok

The alternate can be omitted in some Schemes, defaulting to an unspecified value:

> (if #t 'yes)
yes
> (if #f 'yes)
; unspecified

Truthiness: In Scheme, only #f is false—everything else is true:

> (if 0 'yes 'no)
yes
> (if '() 'yes 'no)
yes
> (if "" 'yes 'no)
yes
> (if #f 'yes 'no)
no

This differs from many languages where 0, null, or empty collections are false.

Lambda: Creating Procedures

Syntax: (lambda (params…) body)

Semantics: Creates a procedure (closure) that:

ℰ[[(lambda(x1…xn)e)]]ρ=⟨closure,(x1…xn),e,ρ⟩ \mathcal{E}[\![(\text{lambda} \; (x_1 \ldots x_n) \; e)]\!]\rho = \langle \text{closure}, (x_1 \ldots x_n), e, \rho \rangle 

> (lambda (x) (* x x))
#<procedure>

> ((lambda (x) (* x x)) 5)
25

> (define square (lambda (x) (* x x)))
> (square 7)
49

Closures capture their defining environment:

> (define make-adder
    (lambda (n)
      (lambda (x) (+ x n))))

> (define add5 (make-adder 5))
> (add5 10)
15

> (define add100 (make-adder 100))
> (add100 10)
110

The lambda (lambda (x) (+ x n)) closes over n from the outer environment, creating a closure.

Multiple expressions in body:

> ((lambda (x)
     (display "Computing square of ")
     (display x)
     (newline)
     (* x x))
   5)
Computing square of 5
25

Only the last expression’s value is returned.

Variable-arity procedures:

;; Rest parameter with dot notation
> (define (sum . numbers)
    (if (null? numbers)
        0
        (+ (car numbers) (apply sum (cdr numbers)))))

> (sum 1 2 3 4 5)
15
> (sum)
0

;; Mixed fixed and rest parameters
> (define (log-message level . args)
    (display level)
    (display ": ")
    (for-each display args)
    (newline))

> (log-message "INFO" "System " "started " "successfully")
INFO: System started successfully

Define: Creating Bindings

Syntax:

Semantics: Binds name to value in the current environment.

ℰ[[(definexe)]]ρ=ρ′ where ρ′(x)=ℰ[[e]]ρ \mathcal{E}[\![(\text{define} \; x \; e)]\!]\rho = \rho' \text{ where } \rho'(x) = \mathcal{E}[\![e]\!]\rho 

> (define pi 3.14159)
> pi

3.14159

> (define (square x)
    (* x x))
> (square 4)
16

The procedure definition is syntactic sugar:

(define (square x) (* x x))
≡
(define square (lambda (x) (* x x)))

Multiple values:

> (define x 10)
> (define y 20)
> (+ x y)
30

Internal definitions:

(define (sqrt-iter guess x)
  (define (good-enough? guess)
    (< (abs (- (square guess) x)) 0.001))
  (define (improve guess)
    (average guess (/ x guess)))
  (if (good-enough? guess)
      guess
      (sqrt-iter (improve guess) x)))

Internal define creates local bindings, similar to let.

Set!: Mutation

Syntax: (set! name value)

Semantics: Mutates an existing binding.

ℰ[[(set!xe)]]ρ=update ρ(x):=ℰ[[e]]ρ \mathcal{E}[\![(\text{set!} \; x \; e)]\!]\rho = \text{update } \rho(x) := \mathcal{E}[\![e]\!]\rho 

> (define counter 0)
> counter
0
> (set! counter (+ counter 1))
> counter
1
> (set! counter (+ counter 1))
> counter
2

set! is imperative—it causes a side effect rather than returning a useful value:

> (define x 10)
> (set! x 20)
; unspecified return value
> x
20

Important: set! can only mutate existing bindings:

> (set! undefined-var 42)
; Error: undefined-var is not defined

Must use define first:

> (define var 0)
> (set! var 42)
> var
42

Mutation and closures:

> (define make-counter
    (lambda ()
      (let ((count 0))
        (lambda ()
          (set! count (+ count 1))
          count))))

> (define counter1 (make-counter))
> (counter1)
1
> (counter1)
2
> (counter1)
3

> (define counter2 (make-counter))
> (counter2)
1

Each counter has its own mutable state.

Begin: Sequencing

Syntax: (begin expr1 expr2 … exprn)

Semantics: Evaluates expressions in order, returns the value of the last.

ℰ[[(begine1…en)]]ρ=ℰ[[en]]ρ′ \mathcal{E}[\![(\text{begin} \; e_1 \; \ldots \; e_n)]\!]\rho = \mathcal{E}[\![e_n]\!]\rho'

where ρ′\rho' reflects any mutations from evaluating e1,…,en−1e_1, \ldots, e_{n-1}.

> (begin
    (display "First")
    (newline)
    (display "Second")
    (newline)
    42)
First
Second
42

begin is primarily used for side effects:

> (define (print-and-square x)
    (begin
      (display "Squaring ")
      (display x)
      (newline)
      (* x x)))

> (print-and-square 5)
Squaring 5
25

Implicit begin: Many forms have implicit begin:

;; Lambda body
(lambda (x)
  (display "Computing…")
  (* x x))

;; Cond clauses
(cond
  ((> x 0)
   (display "Positive")
   x)
  (else
   (display "Not positive")
   0))

;; Internal defines create implicit begin
(define (foo x)
  (define helper (lambda (y) (* y 2)))
  (display "Calling helper")
  (helper x))

3.3 Environments and Scoping

The Environment Model

An environment is a mapping from symbols to values (or locations). Scheme uses lexical scoping (also called static scoping), where the environment of a procedure is determined by where it’s defined, not where it’s called.

We can visualize environments as frames linked by parent pointers:

Global Environment

┌│─────────────────────┐

││ + → # │

││ * → # │

││ cons → # │

││ … │ └─────────────────────┘

When we define a variable:

(define x 10)

Global Environment

┌│─────────────────────┐

││ x → 10 │

││ + → # │

││ * → # │

││ … │ └─────────────────────┘

Procedure Application and Environments

When we define a procedure:

(define (square x)
  (* x x))

We create a closure that captures the current environment:

Global Environment

┌│──────────────────────────┐

││ square → ┌─────────────┐ │

││ │ params: (x) │ │

││ │ body: (* x x)│ │

││ │ env: ───────┼─┼→ Global

││ └─────────────┘ │ └──────────────────────────┘

When we call (square 5):

  1. Create a new frame extending the closure’s environment

  2. Bind parameters to arguments in the new frame

  3. Evaluate the body in this extended environment

Application Frame

┌│─────────────┐

││ x → 5 │

││ parent: ────┼──→ Global Environment └─────────────┘ ┌──────────────────────────┐ │ square → … │ │ * → # │ └──────────────────────────┘

Now evaluate (* x x):

Lexical vs. Dynamic Scoping

Lexical scoping (Scheme’s model):

(define x 10)

(define (foo)
  x)  ; refers to global x

(define (bar)
  (define x 20)
  (foo))  ; foo still sees x=10

> (bar)
10

foo sees the x from where it was defined (global environment).

Dynamic scoping (older Lisps, some shell languages):

In a dynamically-scoped language, the same code would return 20 because foo would see the x from where it was called (inside bar).

Scheme’s lexical scoping makes code easier to reason about because variable references are determined purely by textual structure.

Shadowing

Inner bindings can shadow outer ones:

> (define x 10)
> (define (foo)
    (define x 20)  ; shadows global x
    (+ x 5))
> (foo)
25
> x
10  ; global x unchanged

Visualization:

foo’s Frame

┌│─────────────┐

││ x → 20 │

││ parent: ────┼──→ Global └─────────────┘ ┌─────────────┐ │ x → 10 │ │ foo → … │ └─────────────┘

When evaluating x in foo, we find it in the inner frame, so the outer binding is shadowed.

3.4 Let, Let*, and Letrec: Local Bindings

While lambda can create local bindings, Scheme provides more convenient forms.

Let: Parallel Binding

Syntax: (let ((var1 val1) (var2 val2) …) body)

Semantics: Create a new environment with parallel bindings, evaluate body.

> (let ((x 10)
        (y 20))
    (+ x y))
30

let is syntactic sugar for a lambda application:

(let ((var1 val1) (var2 val2))
  body)
≡
((lambda (var1 var2)
   body)
 val1 val2)

Parallel evaluation means variables can’t refer to each other:

> (let ((x 10)
        (y x))  ; Error! x not yet bound
    (+ x y))
; Error: x is undefined

The x in (y x) refers to the outer x, not the one being defined:

> (define x 5)
> (let ((x 10)
        (y x))  ; this x is the outer x (5)
    (list x y))
(10 5)

Let*: Sequential Binding

Syntax: (let* ((var1 val1) (var2 val2) …) body)

Semantics: Like let, but bindings are sequential—later ones can refer to earlier ones.

> (let* ((x 10)
         (y (* x 2))   ; can use x
         (z (+ x y)))  ; can use x and y
    z)
30

let* desugars to nested let:

(let* ((x 10)
       (y (* x 2))
       (z (+ x y)))
  z)
≡
(let ((x 10))
  (let ((y (* x 2)))
    (let ((z (+ x y)))
      z)))

Letrec: Recursive Binding

Syntax: (letrec ((var1 val1) (var2 val2) …) body)

Semantics: Like let, but variables can refer to themselves (for recursion) or each other.

> (letrec ((even? (lambda (n)
                    (or (= n 0)
                        (odd? (- n 1)))))
           (odd? (lambda (n)
                   (and (not (= n 0))
                        (even? (- n 1))))))
    (even? 42))
#t

This allows mutually recursive definitions, which let and let* cannot express.

How it works: All variables are bound simultaneously to undefined values, then the values are computed and assigned. Conceptually:

(letrec ((var1 val1) (var2 val2))
  body)
≈
(let ((var1 <undefined>) (var2 <undefined>))
  (set! var1 val1)
  (set! var2 val2)
  body)

Warning: Don’t reference variables before they’re assigned:

> (letrec ((x y)
           (y 5))
    x)
; Error: y is undefined (or unspecified behavior)

Use letrec only when you need mutual recursion; otherwise prefer let or let*.

Named Let: Recursive Iteration

Scheme provides a special let form that creates a recursive procedure:

Syntax: (let name ((var1 val1) …) body)

> (let loop ((n 10)
             (sum 0))
    (if (= n 0)
        sum
        (loop (- n 1) (+ sum n))))
55

This is equivalent to:

((letrec ((loop (lambda (n sum)
                  (if (= n 0)
                      sum
                      (loop (- n 1) (+ sum n))))))
   loop)
 10 0)

Named let is idiomatic for loops in Scheme:

(define (factorial n)
  (let loop ((n n)
             (acc 1))
    (if (= n 0)
        acc
        (loop (- n 1) (* n acc)))))

> (factorial 5)
120

3.5 Cond and Case: Multi-Way Conditionals

Cond: General Conditionals

Syntax:

(cond
  (test1 expr1 …)
  (test2 expr2 …)
  …
  (else exprn …))

Semantics: Evaluate tests in order until one is true, then evaluate and return its expressions.

> (define (sign x)
    (cond
      ((< x 0) 'negative)
      ((> x 0) 'positive)
      (else 'zero)))

> (sign -5)
negative
> (sign 5)
positive
> (sign 0)
zero

cond is more readable than nested if:

;; Using nested if (hard to read)
(if (< x 0)
    'negative
    (if (> x 0)
        'positive
        'zero))

;; Using cond (clear)
(cond
  ((< x 0) 'negative)
  ((> x 0) 'positive)
  (else 'zero))

Arrow notation (⇒) passes the test value to a procedure:

> (cond
    ((assq 'b '((a 1) (b 2) (c 3))) ⇒ cadr)
    (else #f))
2

This is useful when the test produces a value you want to use:

(define (lookup key alist)
  (cond
    ((assq key alist) ⇒ cdr)
    (else #f)))

Case: Dispatch on Value

Syntax:

(case key
  ((datum1 datum2 …) expr1 …)
  ((datum3 datum4 …) expr2 …)
  …
  (else exprn …))

Semantics: Evaluate key, then compare (using eqv?) to each datum. Execute expressions for first match.

> (define (operation-name op)
    (case op
      ((+) 'addition)
      ((-) 'subtraction)
      ((* times) 'multiplication)
      ((/ div) 'division)
      (else 'unknown)))

> (operation-name '+)
addition
> (operation-name 'times)
multiplication
> (operation-name '%)
unknown

case is cleaner than cond for simple dispatch:

;; Using cond
(cond
  ((eqv? op '+) 'addition)
  ((eqv? op '-) 'subtraction)
  ((or (eqv? op '*) (eqv? op 'times)) 'multiplication)
  ((or (eqv? op '/) (eqv? op 'div)) 'division)
  (else 'unknown))

;; Using case
(case op
  ((+) 'addition)
  ((-) 'subtraction)
  ((* times) 'multiplication)
  ((/ div) 'division)
  (else 'unknown))

Important: case uses eqv?, not equal?, so it works with symbols, numbers, characters, but not strings or lists:

> (case "hello"
    (("hello") 'found))
; Won't match! Use cond with equal? for strings

3.6 Boolean Operations: And, Or, Not

Not: Logical Negation

Syntax: (not expr)

Semantics: Returns #t if expr is #f, otherwise #f.

> (not #t)
#f
> (not #f)
#t
> (not 0)      ; 0 is true!
#f
> (not '())    ; empty list is true!
#f

And: Short-Circuit Conjunction

Syntax: (and expr1 expr2 …)

Semantics: Evaluate expressions left to right. If any is #f, stop and return #f. Otherwise return the value of the last expression.

> (and #t #t #t)
#t
> (and #t #f #t)
#f
> (and 1 2 3)
3  ; returns last value!

Short-circuiting:

> (and #f (error "Won't execute"))
#f

> (and (> 5 0) (/ 10 5))
2

> (and (> 5 0) (/ 10 0))  ; error in second expression
; Error: division by zero

Common idiom for guarded evaluation:

(define (safe-car lst)
  (and (pair? lst) (car lst)))

> (safe-car '(a b c))
a
> (safe-car '())
#f
> (safe-car 42)
#f

Or: Short-Circuit Disjunction

Syntax: (or expr1 expr2 …)

Semantics: Evaluate expressions left to right. If any is not #f, stop and return that value. Otherwise return #f.

> (or #f #f #t)
#t
> (or #f 1 2)
1  ; returns first true value!
> (or #f #f #f)
#f

Short-circuiting:

> (or #t (error "Won't execute"))
#t

> (or (< 5 0) (= 5 0) (> 5 0))
#t

Common idiom for default values:

(define (lookup key alist default)
  (or (assq key alist)
      default))

> (lookup 'b '((a 1) (b 2)) #f)
(b 2)
> (lookup 'c '((a 1) (b 2)) 'not-found)
not-found

Combining Boolean Operators

;; Check if x is in range [a, b]
(define (in-range? x a b)
  (and (≥ x a) (≤ x b)))

;; Check if character is alphanumeric
(define (alphanumeric? c)
  (or (char-alphabetic? c)
      (char-numeric? c)))

;; Find first even number
(define (find-even lst)
  (cond
    ((null? lst) #f)
    ((and (number? (car lst))
          (even? (car lst)))
     (car lst))
    (else (find-even (cdr lst)))))

3.7 Equivalence Predicates: eq?, eqv?, equal?

Scheme provides three equality predicates with different semantics.

eq?: Object Identity

eq? tests if two values are the same object—the most primitive equality.

> (eq? 'a 'a)
#t
> (eq? 'a 'b)
#f
> (eq? '() '())
#t

;; Same string literal is often the same object
> (eq? "hello" "hello")
#t  ; in some implementations

;; Different string objects
> (let ((s1 (string-copy "hello"))
        (s2 (string-copy "hello")))
    (eq? s1 s2))
#f

;; Numbers may or may not be eq?
> (eq? 5 5)
#t  ; usually, but not guaranteed

> (eq? 500000 500000)
#f  ; large numbers often aren't eq?

Use case: Comparing symbols, testing object identity.

eqv?: Value Equivalence

eqv? tests if two values are equivalent:

> (eqv? 'a 'a)
#t
> (eqv? 5 5)
#t
> (eqv? 5.0 5.0)
#t

;; Different exactness
> (eqv? 5 5.0)
#f

;; Different objects
> (eqv? (cons 1 2) (cons 1 2))
#f

;; Characters
> (eqv? #\a #\a)
#t

Use case: General equality for numbers, characters, and symbols.

equal?: Structural Equivalence

equal? tests if two values are structurally equivalent—recursively comparing compound data:

> (equal? '(a b c) '(a b c))
#t
> (equal? (cons 1 2) (cons 1 2))
#t

;; Nested structures
> (equal? '((a b) (c d)) '((a b) (c d)))
#t

;; Strings
> (equal? "hello" "hello")
#t
> (equal? (string-copy "hello") "hello")
#t

;; Vectors
> (equal? #(1 2 3) #(1 2 3))
#t

Use case: Comparing lists, strings, vectors, and other compound data.

Comparison Table

Expression eq? eqv? equal?
(? 'a 'a) #t #t #t
(? 5 5) #t* #t #t
(? 5.0 5.0) #f* #t #t
(? #\a #\a) #t* #t #t
(? "a" "a") #t* #f* #t
(? '(a) '(a)) #f #f #t
(? (cons 1 2) (cons 1 2)) #f #f #t

* Implementation-dependent

Rule of thumb:

3.8 Numbers and Numeric Tower

Scheme has a sophisticated numeric system organized as a tower of types:

Complex Numbers (3+4i) ↓ Real Numbers (3.14, 22/7) ↓ Rational Numbers (22/7) ↓ Integers (42)

Number Types

Integers:

> 42
42
> -17

-17
> 0
0
> #b101010  ; binary
42
> #o52      ; octal
42
> #x2A      ; hexadecimal
42

Rationals:

> 22/7
22/7
> (+ 1/2 1/3)
5/6
> (/ 22 7)
22/7  ; exact division yields rational

Reals (floating-point):

> 3.14

3.14
> -0.5

-0.5
> 6.02e23   ; scientific notation

6.02e+23

Complex:

> 3+4i
3+4i
> (+ 1+2i 3+4i)
4+6i
> (magnitude 3+4i)

5.0
> (angle 1+1i)
0.7853981633974483  ; π/4

Exactness

Numbers can be exact or inexact:

> (exact? 5)
#t
> (exact? 5.0)
#f
> (exact? 22/7)
#t

> (inexact? 3.14)
#t
> (inexact? 5)
#f

Conversions:

> (inexact 5)

5.0
> (exact 5.0)
5
> (exact 3.14)

3.14  ; or error, implementation-dependent

> (inexact 22/7)

3.142857142857143

Operations preserve exactness when possible:

> (+ 1/2 1/3)
5/6  ; exact
> (+ 0.5 0.333)
0.833  ; inexact
> (+ 1/2 0.5)

1.0  ; inexact contaminates

Numeric Predicates

> (number? 42)
#t
> (complex? 3+4i)
#t
> (real? 3.14)
#t
> (rational? 22/7)
#t
> (integer? 5)
#t

> (exact? 5)
#t
> (inexact? 5.0)
#t

> (zero? 0)
#t
> (positive? 5)
#t
> (negative? -3)
#t
> (odd? 7)
#t
> (even? 8)
#t

Arithmetic Operations

Basic arithmetic:

> (+ 1 2 3 4)
10
> (- 10 3)
7
> (- 10)    ; negation

-10
> (* 2 3 4)
24
> (/ 12 3)
4
> (/ 22 7)  ; exact division
22/7

Quotient and remainder:

> (quotient 17 5)
3
> (remainder 17 5)
2
> (modulo 17 5)
2

> (quotient -17 5)

-3
> (remainder -17 5)

-2
> (modulo -17 5)
3  ; always positive with positive divisor

Exponentiation:

> (expt 2 10)
1024
> (expt 2 -3)
1/8
> (expt 2.0 10)
1024.0

Mathematical functions:

> (sqrt 16)
4
> (sqrt 2)

1.4142135623730951
> (sqrt -1)
0+1i  ; complex result!

> (abs -5)
5
> (abs 5)
5

> (max 3 7 2 9 1)
9
> (min 3 7 2 9 1)
1

> (gcd 48 18)
6
> (lcm 12 18)
36

Transcendental functions:

> (exp 1)

2.718281828459045
> (log 2.718281828459045)

1.0

> (sin 0)
0.0
> (cos 0)

1.0
> (tan (/ 3.141592653589793 4))
0.9999999999999999

> (atan 1)
0.7853981633974483  ; π/4
> (asin 0.5)
0.5235987755982989  ; π/6

Numeric Comparison

> (= 5 5)
#t
> (= 5 5.0)
#t  ; = ignores exactness
> (= 5 6)
#f

> (< 3 5)
#t
> (< 3 3)
#f
> (≤ 3 3)
#t

> (> 5 3)
#t
> (≥ 5 5)
#t

;; Chaining comparisons
> (< 1 2 3 4 5)
#t
> (< 1 2 3 2 5)
#f

3.9 Pairs and Lists Revisited

We introduced pairs and lists in Chapter 2. Let’s deepen our understanding.

Pair Operations

Construction:

> (cons 1 2)
(1 . 2)
> (cons 'a '())
(a)
> (cons 'a (cons 'b (cons 'c '())))
(a b c)

Deconstruction:

> (car '(a b c))
a
> (cdr '(a b c))
(b c)

> (car (cons 1 2))
1
> (cdr (cons 1 2))
2

Predicates:

> (pair? '(a b))
#t
> (pair? '())
#f
> (pair? 'a)
#f

List Operations

Construction:

> (list 1 2 3)
(1 2 3)
> (list)
()
> (list 'a (+ 1 2) 'c)
(a 3 c)

Length:

> (length '(a b c))
3
> (length '())
0
> (length '(a (b c) d))
3  ; counts top-level elements

Predicates:

> (list? '(a b c))
#t
> (list? '())
#t
> (list? '(a . b))
#f  ; improper list
> (null? '())
#t
> (null? '(a))
#f

Accessing elements:

> (car '(a b c))
a
> (cadr '(a b c))   ; (car (cdr …))
b
> (caddr '(a b c))  ; (car (cdr (cdr …)))
c

> (list-ref '(a b c d) 0)
a
> (list-ref '(a b c d) 2)
c

Scheme provides cXXr procedures for up to 4 levels:

> (caar '((a b) c))    ; (car (car …))
a
> (cadar '((a b) c))   ; (car (cdr (car …)))
b
> (cddr '(a b c d))    ; (cdr (cdr …))
(c d)

Appending:

> (append '(a b) '(c d))
(a b c d)
> (append '(a) '() '(b c))
(a b c)
> (append)
()

;; append creates new structure; doesn't mutate
> (define lst1 '(a b))
> (define lst2 (append lst1 '(c d)))
> lst2
(a b c d)
> lst1
(a b)  ; unchanged

Reversing:

> (reverse '(a b c))
(c b a)
> (reverse '())
()

Membership:

> (member 'b '(a b c))
(b c)  ; returns tail starting at found element
> (member 'd '(a b c))
#f

> (memq 'b '(a b c))
(b c)  ; uses eq?
> (memv 2 '(1 2 3))
(2 3)  ; uses eqv?

Association Lists

Association lists (alists) are lists of key-value pairs:

> (define colors
    '((red . #xFF0000)
      (green . #x00FF00)
      (blue . #x0000FF)))

> (assq 'red colors)
(red . #xFF0000)

> (assq 'yellow colors)
#f

> (cdr (assq 'blue colors))
#x0000FF

Multiple procedures for different equality tests:

> (assq key alist)    ; uses eq?
> (assv key alist)    ; uses eqv?
> (assoc key alist)   ; uses equal?

3.10 Tail Calls and Proper Tail Recursion

The Stack and Iteration

In most languages, each function call consumes stack space:

def factorial(n):
    if n ⩵ 0:
        return 1
    else:
        return n * factorial(n - 1)

factorial(100000)  # Stack overflow!

Each recursive call adds a frame to the stack. Deep recursion exhausts stack space.

Tail Position

An expression is in tail position if its value is the procedure’s return value—nothing more happens after it evaluates.

In this procedure:

(define (foo x)
  (if (< x 0)
      (bar x)       ; tail position
      (baz (+ x 1)))) ; tail position

Both (bar x) and (baz (+ x 1)) are in tail position. When they return, foo immediately returns their value.

In contrast:

(define (foo x)
  (+ 1 (bar x)))  ; bar is NOT in tail position

(bar x) is not in tail position because after it returns, we must add 1 to the result.

Tail Call Optimization

Scheme requires implementations to optimize tail calls—calls in tail position. Instead of creating a new stack frame, a tail call reuses the current frame.

This means tail recursion is as efficient as iteration:

;; Tail-recursive factorial
(define (factorial n)
  (let loop ((n n) (acc 1))
    (if (= n 0)
        acc
        (loop (- n 1) (* n acc)))))  ; tail call

> (factorial 100000)  ; No stack overflow!

The loop tail-calls itself, so it runs in constant stack space—just like a while loop in other languages.

Recognizing Tail Calls

Tail calls:

(define (f x)
  (g x))          ; ✓ tail call

(define (f x)
  (if (< x 0)
      (g x)       ; ✓ tail call
      (h x)))     ; ✓ tail call

(define (f x)
  (let ((y (+ x 1)))
    (g y)))       ; ✓ tail call

Not tail calls:

(define (f x)
  (+ 1 (g x)))    ; ✗ not tail (must add 1 after)

(define (f x)
  (cons (g x) 
        (h x)))   ; ✗ not tail (must cons after)

(define (f x)
  (g x)
  (h x))          ; ✗ g not tail (must call h after)
                  ; ✓ h is tail

Converting to Tail Recursion

Non-tail recursive:

(define (sum-list lst)
  (if (null? lst)
      0
      (+ (car lst) (sum-list (cdr lst)))))

The recursive call is not in tail position—we must add (car lst) after it returns.

Tail recursive using an accumulator:

(define (sum-list lst)
  (let loop ((lst lst) (acc 0))
    (if (null? lst)
        acc
        (loop (cdr lst) (+ acc (car lst))))))

Now the recursive call is in tail position. The accumulator carries the partial result.

Another example—tree traversal:

Non-tail:

(define (tree-sum tree)
  (if (not (pair? tree))
      tree
      (+ (tree-sum (car tree))
         (tree-sum (cdr tree)))))

Tail-recursive using continuation-passing style (advanced):

(define (tree-sum tree)
  (let loop ((tree tree) (cont (lambda (x) x)))
    (cond
      ((not (pair? tree))
       (cont tree))
      (else
       (loop (car tree)
             (lambda (car-sum)
               (loop (cdr tree)
                     (lambda (cdr-sum)
                       (cont (+ car-sum cdr-sum))))))))))

This is complex; we’ll explore continuations more in Chapter 15.

Why Tail Call Optimization Matters

Tail call optimization enables:

  1. Functional iteration: Recursion as efficient as loops

  2. Continuation-passing style: Advanced control flow

  3. State machines: Jumping between states efficiently

  4. Mutual recursion: Without stack overflow

Example—state machine:

(define (parse-string s)
  (let ((chars (string→list s)))
    
    (define (start chars)
      (if (null? chars)
          'done
          (case (car chars)
            ((#\a) (state-a (cdr chars)))
            ((#\b) (state-b (cdr chars)))
            (else 'error))))
    
    (define (state-a chars)
      (if (null? chars)
          'in-a
          (case (car chars)
            ((#\b) (state-b (cdr chars)))
            (else (state-a (cdr chars))))))
    
    (define (state-b chars)
      (if (null? chars)
          'in-b
          (case (car chars)
            ((#\a) (state-a (cdr chars)))
            (else (state-b (cdr chars))))))
    
    (start chars)))

Each state tail-calls the next—no stack buildup regardless of input length.

Summary

In this chapter, we’ve explored Scheme’s core semantics:

  1. Evaluation model: How expressions become values through applicative-order evaluation

  2. Special forms: quote, if, lambda, define, set!, begin—the language’s foundation

  3. Environments: Lexical scoping with environment frames

  4. Local bindings: let, let*, letrec, and named let

  5. Conditionals: cond, case, and boolean operators

  6. Equality: eq? (identity), eqv? (value), equal? (structure)

  7. Numbers: The numeric tower from integers to complex numbers

  8. Pairs and lists: Core data structures and operations

  9. Tail calls: Proper tail recursion for efficient iteration

These elements form the core of Scheme. Mastering them is essential for everything that follows.

Exercises

  1. Evaluation Traces: Trace the evaluation of these expressions step-by-step:

    • (+ (* 2 3) (/ 8 2))

    • ((lambda (x) (* x x)) (+ 2 3))

    • (let ((x 5)) (+ x x))

  2. Environment Diagrams: Draw environment diagrams for:

    (define x 10)
(define (foo y)
  (+ x y))
(define (bar)
  (define x 20)
  (foo 5))
(bar)

  3. Let Forms: Rewrite these using different let forms:

    • Convert let to let* where possible

    • Convert let* to nested let

    • Convert named let to letrec

  4. Tail Recursion: Convert to tail-recursive form:

    (define (length lst)
  (if (null? lst)
      0
      (+ 1 (length (cdr lst)))))

(define (map f lst)
  (if (null? lst)
      '()
      (cons (f (car lst))
            (map f (cdr lst)))))

  5. Boolean Logic: Implement these without using and, or:

    • (my-and a b c) — returns #t only if all arguments are true

    • (my-or a b c) — returns #t if any argument is true

  6. Number Operations: Implement:

    • (factorial n) — compute n!n!

    • (fib n) — compute nn-th Fibonacci number (both recursive and iterative)

    • (gcd a b) — greatest common divisor using Euclid’s algorithm

  7. List Operations: Implement these from scratch:

    • (my-append lst1 lst2) — concatenate lists

    • (my-reverse lst) — reverse a list

    • (my-filter pred lst) — keep elements satisfying predicate

    • (my-remove x lst) — remove all occurrences of x

  8. Association Lists: Implement:

    • (alist-set key value alist) — add or update a key-value pair

    • (alist-delete key alist) — remove a key

    • (alist-keys alist) — extract all keys

  9. Scope Challenge: What does this print and why?

    (define x 1)
(define (f) x)
(define (g)
  (define x 2)
  (f))
(g)

  10. Tail Call Analysis: Which of these are tail-recursive? Convert non-tail to tail if possible:

    (define (sum-to-n n)
  (if (= n 0)
      0
      (+ n (sum-to-n (- n 1)))))

(define (all? pred lst)
  (cond
    ((null? lst) #t)
    ((not (pred (car lst))) #f)
    (else (all? pred (cdr lst)))))

(define (tree-leaves tree)
  (cond
    ((null? tree) '())
    ((not (pair? tree)) (list tree))
    (else (append (tree-leaves (car tree))
                  (tree-leaves (cdr tree))))))

In the next chapter, we’ll explore higher-order functions and how they enable powerful abstraction patterns in Scheme.

Chapter 4: Data Types and Structures

4.1 Scheme’s Type System: Dynamic and Latent

Unlike statically typed languages such as Java or Haskell, Scheme employs a dynamic type system. This means:

  1. Values have types, not variables: A variable can hold any type of value at different times

  2. Type checking happens at runtime: Type errors are detected when operations are performed

  3. No type declarations required: The programmer doesn’t annotate types

Scheme’s type system is also latent—types exist conceptually but aren’t explicitly manifest in the source code. This provides flexibility while maintaining safety through runtime checks.

Type Predicates

Every major type in Scheme has an associated predicate (a function returning #t or #f):

> (boolean? #t)
#t
> (number? 42)
#t
> (symbol? 'hello)
#t
> (string? "hello")
#t
> (char? #\a)
#t
> (pair? '(a b))
#t
> (list? '(a b c))
#t
> (vector? #(1 2 3))
#t
> (procedure? car)
#t

These predicates enable type-based dispatch:

(define (describe x)
  (cond
    ((number? x) "a number")
    ((string? x) "a string")
    ((symbol? x) "a symbol")
    ((pair? x) "a pair")
    ((null? x) "the empty list")
    ((procedure? x) "a procedure")
    (else "something else")))

> (describe 42)
"a number"
> (describe 'hello)
"a symbol"
> (describe car)
"a procedure"

The Type Hierarchy

Scheme types form a hierarchy:

any (top type)

├│── boolean (#t, #f)

├│── symbol (foo, bar, +, …)

├│── char (#, # …)

├│── number

││ ├── complex (3+4i)

││ ├── real (3.14)

││ ├── rational (22/7)

││ └── integer (42)

├│── string (“hello”)

├│── pair

││ └── list (proper lists)

├│── vector (#(1 2 3))

├│── procedure (#

)

├│── port (input/output) └── null (empty list ’())

Some predicates test for supertypes:

> (number? 42)
#t
> (real? 42)
#t
> (integer? 42)
#t

> (integer? 3.14)
#f
> (real? 3.14)
#t

> (pair? '(a b c))
#t
> (list? '(a b c))
#t

4.2 Booleans: Truth and Falsehood

Scheme has exactly two boolean values: #t (true) and #f (false).

Boolean Literals

> #t
#t
> #f
#f
> #true    ; alternative syntax (R7RS)
#t
> #false   ; alternative syntax (R7RS)
#f

The Unique False Value

In Scheme, only #f is false. Everything else—including 0, '(), and ""—is true:

> (if #f 'yes 'no)
no
> (if 0 'yes 'no)
yes
> (if '() 'yes 'no)
yes
> (if "" 'yes 'no)
yes
> (if '(#f) 'yes 'no)
yes  ; list containing #f is not #f itself!

This simplicity eliminates ambiguity but differs from languages like C, JavaScript, or Python.

Boolean Operations Revisited

We covered and, or, and not in Chapter 3. Let’s see advanced patterns:

Short-circuit evaluation for optional values:

(define (safe-divide a b)
  (and (not (zero? b))
       (/ a b)))

> (safe-divide 10 2)
5
> (safe-divide 10 0)
#f

Default values with or:

(define (get-config key default)
  (or (lookup key config-table)
      default))

Chaining predicates:

(define (valid-age? x)
  (and (number? x)
       (integer? x)
       (≥ x 0)
       (≤ x 150)))

> (valid-age? 25)
#t
> (valid-age? 3.5)
#f
> (valid-age? -5)
#f

Boolean Comparison

Use not to test for false:

> (not #f)
#t
> (not #t)
#f
> (not 0)
#f  ; 0 is true!

Don’t use eq? to compare booleans—use logical operators:

;; Bad
(if (eq? (> x 5) #t) …)

;; Good
(if (> x 5) …)

4.3 Numbers: The Numeric Tower in Depth

We introduced numbers in Chapter 3. Now we explore the full numeric tower and operations.

Integer Representations

Decimal (default):

> 42
42
> -17

-17

Binary (#b prefix):

> #b1010
10
> #b11111111
255

Octal (#o prefix):

> #o77
63
> #o644
420

Hexadecimal (#x prefix):

> #xFF
255
> #xDEADBEEF
3735928559

Exactness Annotations

Force exactness with #e or inexactness with #i:

> #e3.5
7/2  ; exact rational
> #i22/7

3.142857142857143  ; inexact real

> (exact? #e3.5)
#t
> (exact? #i22/7)
#f

Rational Arithmetic

Scheme automatically uses rationals for exact division:

> (/ 22 7)
22/7
> (/ 1 3)
1/3
> (+ 1/2 1/3)
5/6
> (* 2/3 3/4)
1/2

> (numerator 22/7)
22
> (denominator 22/7)
7

Rationals remain exact until mixed with inexact numbers:

> (+ 1/3 1/3 1/3)
1
> (+ 1/3 0.333)
0.6663333333333333  ; inexact

Complex Numbers

Scheme supports rectangular complex numbers:

> 3+4i
3+4i
> (+ 1+2i 3+4i)
4+6i
> (* 2+3i 4+5i)

-7+22i

Extracting components:

> (real-part 3+4i)
3
> (imag-part 3+4i)
4

> (magnitude 3+4i)

5.0
> (angle 3+4i)
0.9272952180016122  ; atan(4/3)

Constructing complex numbers:

> (make-rectangular 3 4)
3+4i
> (make-polar 5 0.9272952180016122)

3.0+3.9999999999999996i

Complex operations:

> (sqrt -1)
0+1i
> (exp (* 0+1i 3.141592653589793))  ; e^(iπ) = -1

-1.0+1.2246467991473532e-16i

> (log -1)
0.0+3.141592653589793i  ; ln(-1) = iπ

Division Operations

Exact integer division:

> (quotient 17 5)
3
> (remainder 17 5)
2
> (modulo 17 5)
2

Difference between remainder and modulo:

> (remainder 17 5)
2
> (remainder -17 5)

-2
> (remainder 17 -5)
2
> (remainder -17 -5)

-2

> (modulo 17 5)
2
> (modulo -17 5)
3  ; always has sign of divisor
> (modulo 17 -5)

-3
> (modulo -17 -5)

-3

The modulo operation satisfies: a=bq+ra = bq + r where 0≤r<|b|0 \leq r < |b| (for positive bb).

Exact division with multiple values:

> (call-with-values
    (lambda () (exact-integer-sqrt 17))
    (lambda (q r) (list q r)))
(4 1)  ; 17 = 4² + 1

Mathematical Functions

Rounding:

> (floor 3.7)

3.0
> (ceiling 3.2)

4.0
> (truncate 3.7)

3.0
> (truncate -3.7)

-3.0
> (round 3.5)

4.0
> (round 4.5)

4.0  ; rounds to even

Exponentials and logarithms:

> (exp 1)

2.718281828459045
> (log 2.718281828459045)

1.0
> (log 8 2)  ; log base 2

3.0
> (expt 2 10)
1024

Trigonometry (in radians):

> (define pi 3.141592653589793)
> (sin 0)
0.0
> (cos 0)

1.0
> (tan (/ pi 4))
0.9999999999999999  ; ≈ 1

> (asin 0.5)
0.5235987755982989  ; π/6
> (acos 0.5)

1.0471975511965979  ; π/3
> (atan 1)
0.7853981633974483  ; π/4

> (atan 3 4)  ; atan2(y, x)
0.6435011087932844

Other functions:

> (sqrt 16)
4
> (sqrt 2)

1.4142135623730951
> (expt 27 1/3)

3.0  ; cube root

> (abs -5)
5
> (max 3 7 2 9 1)
9
> (min 3 7 2 9 1)
1

> (gcd 48 18)
6
> (lcm 12 18)
36

Bitwise Operations (Implementation-Specific)

Many Schemes provide bitwise operations on exact integers:

> (bitwise-and #b1010 #b1100)
8  ; #b1000
> (bitwise-ior #b1010 #b1100)
14  ; #b1110
> (bitwise-xor #b1010 #b1100)
6  ; #b0110
> (bitwise-not #b1010)

-11  ; two's complement

> (arithmetic-shift #b1010 2)  ; left shift
40  ; #b101000
> (arithmetic-shift #b1010 -2)  ; right shift
2  ; #b10

4.4 Characters: Beyond ASCII

Scheme characters represent Unicode code points (in modern implementations).

Character Literals

Basic syntax: #\ followed by character:

> #\a
#\a
> #\z
#\z
> #\5
#\5
> #\space
#\space
> #\newline
#\newline

Named characters:

#\space      ; space character
#\newline    ; newline
#\tab        ; tab
#\return     ; carriage return

Hex notation (R7RS):

> #\x41      ; 'A'
#\A
> #\x3BB     ; λ (lambda)
#\λ
> #\x1F600   ; 😀 (emoji)
#\😀

Character Predicates

> (char? #\a)
#t
> (char? "a")
#f

> (char-alphabetic? #\a)
#t
> (char-alphabetic? #\5)
#f

> (char-numeric? #\5)
#t
> (char-numeric? #\a)
#f

> (char-whitespace? #\space)
#t
> (char-whitespace? #\newline)
#t

> (char-upper-case? #\A)
#t
> (char-lower-case? #\a)
#t

Character Comparison

> (char=? #\a #\a)
#t
> (char<? #\a #\b)
#t
> (char>? #\z #\a)
#t
> (char≤? #\a #\a)
#t

;; Case-insensitive comparison
> (char-ci=? #\A #\a)
#t
> (char-ci<? #\a #\B)
#t

Character Conversion

> (char-upcase #\a)
#\A
> (char-downcase #\Z)
#\z

> (char→integer #\A)
65
> (char→integer #\λ)
955

> (integer→char 65)
#\A
> (integer→char 955)
#\λ

Digit conversion:

> (digit-value #\5)
5
> (digit-value #\F)
15  ; hex digit
> (digit-value #\a)
#f  ; not a digit

Unicode Support

Modern Scheme implementations support full Unicode:

> (char? #\λ)
#t
> (char? #\日)
#t
> (char? #\😀)
#t

> (char-alphabetic? #\日)
#t

> (string #\λ #\space #\日 #\本)
"λ 日本"

4.5 Strings: Sequences of Characters

Strings are mutable sequences of characters in Scheme.

String Literals

> "hello"
"hello"
> "hello world"
"hello world"
> ""
""

Escape sequences:

> "Line 1\nLine 2"
"Line 1\nLine 2"
> "Tab\there"
"Tab\there"
> "Quote: \" inside"
"Quote: \" inside"
> "Backslash: \\"
"Backslash: \\"

Multiline strings:

> "This is a \
   long string"
"This is a long string"

String Construction

> (make-string 5 #\*)
"*****"
> (make-string 3 #\a)
"aaa"

> (string #\h #\e #\l #\l #\o)
"hello"

> (string)
""

String Predicates and Comparison

> (string? "hello")
#t
> (string? 'hello)
#f

> (string=? "hello" "hello")
#t
> (string=? "hello" "Hello")
#f

> (string<? "apple" "banana")
#t
> (string>? "zebra" "apple")
#t
> (string≤? "a" "a")
#t

;; Case-insensitive comparison
> (string-ci=? "Hello" "hello")
#t
> (string-ci<? "apple" "BANANA")
#t

String Operations

Length and access:

> (string-length "hello")
5
> (string-ref "hello" 0)
#\h
> (string-ref "hello" 4)
#\o

Mutation (use with caution!):

> (define s (string-copy "hello"))
> s
"hello"
> (string-set! s 0 #\H)
> s
"Hello"

Substrings:

> (substring "hello world" 0 5)
"hello"
> (substring "hello world" 6 11)
"world"
> (substring "hello world" 6)  ; to end (R7RS)
"world"

Concatenation:

> (string-append "hello" " " "world")
"hello world"
> (string-append "a" "b" "c")
"abc"
> (string-append)
""

Case conversion:

> (string-upcase "hello")
"HELLO"
> (string-downcase "HELLO")
"hello"
> (string-foldcase "Straße")  ; Unicode case folding
"strasse"

Trimming (R7RS):

> (string-trim " hello ")
"hello "
> (string-trim-right " hello ")
" hello"
> (string-trim-both " hello ")
"hello"

String Conversion

To/from lists:

> (string→list "hello")
(#\h #\e #\l #\l #\o)
> (list→string '(#\h #\i))
"hi"

To/from symbols:

> (string→symbol "hello")
hello
> (symbol→string 'hello)
"hello"

To/from numbers:

> (string→number "42")
42
> (string→number "3.14")

3.14
> (string→number "22/7")
22/7
> (string→number "#xFF")
255
> (string→number "not-a-number")
#f

> (number→string 42)
"42"
> (number→string 3.14)
"3.14"
> (number→string 255 16)  ; base 16
"ff"

String Searching

> (string-contains "hello world" "world")
6  ; index where found
> (string-contains "hello world" "foo")
#f

> (string-prefix? "hello" "hello world")
#t
> (string-suffix? "world" "hello world")
#t

Immutable Strings

Some Scheme implementations support immutable strings (R7RS encourages this):

> (define s "immutable")
> (string-set! s 0 #\I)
; Error: string is immutable

To ensure mutability, use string-copy:

> (define s (string-copy "immutable"))
> (string-set! s 0 #\I)
> s
"Immutable"

4.6 Symbols: Names as Data

Symbols are unique, immutable identifiers—central to Lisp’s homoiconicity.

Symbol Characteristics

  1. Uniqueness: Two symbols with the same name are the same object:
> (eq? 'foo 'foo)
#t
> (eq? (string→symbol "bar") 'bar)
#t

  1. Immutability: Symbols cannot be modified

  2. Efficiency: Symbol equality is O(1)O(1) pointer comparison

Creating Symbols

Literal symbols:

> 'hello
hello
> 'x
x
> '+
+
> 'a-long-symbol-name
a-long-symbol-name

From strings:

> (string→symbol "hello")
hello
> (string→symbol "Hello")
Hello  ; case-sensitive

Generated symbols (gensym):

> (gensym)
g1
> (gensym)
g2
> (gensym "temp")
temp3

Gensyms create unique symbols—useful for macro hygiene and avoiding name collisions.

Symbol Operations

> (symbol? 'hello)
#t
> (symbol? "hello")
#f

> (symbol→string 'hello)
"hello"
> (string→symbol "world")
world

> (eq? 'foo 'foo)
#t
> (eqv? 'foo 'foo)
#t

Symbols vs. Strings

When to use symbols:

  • Identifiers: Variable/function names

  • Enumerated values: States, types, tags

  • Keys: In association lists, property lists

  • Pattern matching: DSL keywords

When to use strings:

  • Textual data: User input, file contents

  • Output: Display to users

  • Manipulation: Need concatenation, case conversion, etc.

Example—symbols as enum values:

(define (traffic-light-action state)
  (case state
    ((red) "Stop")
    ((yellow) "Caution")
    ((green) "Go")
    (else "Unknown state")))

> (traffic-light-action 'red)
"Stop"

Interning

Symbols are interned in a global symbol table:

> (define s1 (string→symbol "test"))
> (define s2 (string→symbol "test"))
> (eq? s1 s2)
#t  ; same symbol object!

This makes symbol comparison extremely fast and memory-efficient.

4.7 Vectors: Fixed-Size Arrays

Vectors are mutable, fixed-size, random-access sequences.

Vector Literals

> #(1 2 3)
#(1 2 3)
> #(a b c)
#(a b c)
> #()
#()
> #(1 (2 3) #(4 5))
#(1 (2 3) #(4 5))

Note: Literal vectors are often immutable in modern Schemes. Use vector or make-vector for mutable vectors.

Creating Vectors

> (make-vector 5 0)
#(0 0 0 0 0)

> (vector 1 2 3)
#(1 2 3)

> (vector)
#()

Vector Operations

Length and access:

> (vector-length #(a b c))
3

> (vector-ref #(a b c) 0)
a
> (vector-ref #(a b c) 2)
c

Mutation:

> (define v (vector 1 2 3))
> v
#(1 2 3)
> (vector-set! v 0 10)
> v
#(10 2 3)

Filling:

> (define v (make-vector 5))
> (vector-fill! v 'x)
> v
#(x x x x x)

Vector Conversion

To/from lists:

> (vector→list #(1 2 3))
(1 2 3)

> (list→vector '(a b c))
#(a b c)

Copying:

> (define v1 #(1 2 3))
> (define v2 (vector-copy v1))
> (vector-set! v2 0 10)
> v1
#(1 2 3)  ; unchanged
> v2
#(10 2 3)

Vectors vs. Lists

Use vectors when:

  • Need O(1)O(1) random access

  • Fixed size known upfront

  • Memory efficiency matters

Use lists when:

  • Frequent cons/car/cdr operations

  • Size varies dynamically

  • Pattern matching with car/cdr

Performance comparison:

Operation List Vector
Access first element O(1)O(1) O(1)O(1)
Access nn-th element O(n)O(n) O(1)O(1)
Prepend element O(1)O(1) O(n)O(n)
Append element O(n)O(n) O(n)O(n)
Length O(n)O(n) O(1)O(1)

Multi-Dimensional Arrays

Some Schemes support multi-dimensional arrays:

> (define m (make-array '#(3 3) 0))
> (array-set! m 1 0 1)
> (array-ref m 1 0)
1

Or simulate with vectors of vectors:

> (define matrix
    (vector
      (vector 1 2 3)
      (vector 4 5 6)
      (vector 7 8 9)))

> (vector-ref (vector-ref matrix 1) 2)
6  ; row 1, column 2

4.8 Hashtables: Efficient Key-Value Mapping

Hashtables provide O(1)O(1) average-case lookup—much faster than association lists for large datasets.

Creating Hashtables

> (define ht (make-hashtable))
> ht
#<hashtable>

;; With specific equality predicate
> (make-eq-hashtable)       ; uses eq?
> (make-eqv-hashtable)      ; uses eqv?
> (make-equal-hashtable)    ; uses equal?

Hashtable Operations

Insertion:

> (define ht (make-equal-hashtable))
> (hashtable-set! ht "name" "Alice")
> (hashtable-set! ht "age" 30)

Lookup:

> (hashtable-ref ht "name" #f)  ; default value if not found
"Alice"
> (hashtable-ref ht "city" "Unknown")
"Unknown"

Contains:

> (hashtable-contains? ht "name")
#t
> (hashtable-contains? ht "city")
#f

Deletion:

> (hashtable-delete! ht "age")
> (hashtable-contains? ht "age")
#f

Size:

> (hashtable-size ht)
1

Clearing:

> (hashtable-clear! ht)
> (hashtable-size ht)
0

Iteration

Get all keys:

> (hashtable-keys ht)
#("name" "age")  ; returns vector

Get all values:

> (hashtable-values ht)
#("Alice" 30)

Iterate over entries:

(hashtable-for-each
  (lambda (key value)
    (display key)
    (display ": ")
    (display value)
    (newline))
  ht)

Example: Word Frequency Counter

(define (word-frequency text)
  (define ht (make-equal-hashtable))
  (define words (string-split text #\space))
  
  (for-each
    (lambda (word)
      (let ((count (hashtable-ref ht word 0)))
        (hashtable-set! ht word (+ count 1))))
    words)
  
  ht)

> (define freq (word-frequency "the quick brown fox jumps over the lazy dog"))
> (hashtable-ref freq "the" 0)
2
> (hashtable-ref freq "fox" 0)
1

Hashtables vs. Association Lists

Use hashtables when:

  • Large number of key-value pairs (> 20)

  • Frequent lookups

  • Keys are not symbols or small integers

Use association lists when:

  • Small number of pairs (< 20)

  • Infrequent lookups

  • Need structural sharing/copying

  • Keys are symbols

4.9 Structures: User-Defined Record Types

While not in the core R5RS standard, most Schemes provide a way to define record types (similar to structs in C or records in Pascal).

Defining Structures (SRFI-9)

SRFI-9 provides portable record types:

(define-record-type point
  (make-point x y)     ; constructor
  point?               ; predicate
  (x point-x)          ; accessor for x
  (y point-y))         ; accessor for y

> (define p (make-point 3 4))
> (point? p)
#t
> (point-x p)
3
> (point-y p)
4

Mutable Fields

Add a setter:

(define-record-type point
  (make-point x y)
  point?
  (x point-x set-point-x!)  ; mutable
  (y point-y set-point-y!)) ; mutable

> (define p (make-point 3 4))
> (set-point-x! p 10)
> (point-x p)
10

Example: Binary Tree

(define-record-type tree-node
  (make-node value left right)
  node?
  (value node-value)
  (left node-left)
  (right node-right))

(define (leaf value)
  (make-node value '() '()))

(define (tree-contains? tree x)
  (cond
    ((null? tree) #f)
    ((= x (node-value tree)) #t)
    ((< x (node-value tree))
     (tree-contains? (node-left tree) x))
    (else
     (tree-contains? (node-right tree) x))))

> (define t (make-node 5
                       (leaf 3)
                       (make-node 8
                                  (leaf 7)
                                  (leaf 9))))
> (tree-contains? t 7)
#t
> (tree-contains? t 6)
#f

Named vs. Positional Access

Structures provide named field access, improving code clarity:

;; Using vectors (bad)
(define p #(3 4))
(vector-ref p 0)  ; What does position 0 mean?

;; Using structures (good)
(define p (make-point 3 4))
(point-x p)  ; Clear intent

4.10 Ports: Input and Output

Ports represent I/O streams—connections to files, strings, or other data sources.

Port Types

  1. Input ports: Read data

  2. Output ports: Write data

  3. Input/output ports: Both (bidirectional)

Standard Ports

> (current-input-port)
#<input-port stdin>

> (current-output-port)
#<output-port stdout>

> (current-error-port)
#<output-port stderr>

File Ports

Opening files:

> (define in (open-input-file "data.txt"))
> (define out (open-output-file "output.txt"))

Closing files:

> (close-input-port in)
> (close-output-port out)

Auto-closing with call-with-*:

(call-with-input-file "data.txt"
  (lambda (port)
    (read port)))

Port is automatically closed even if an error occurs.

Reading from Ports

Read character:

> (define ch (read-char port))
> ch
#\h

Read line:

> (define line (read-line port))
> line
"Hello, world!"

Read S-expression:

> (define expr (read port))
> expr
(+ 1 2)

Peek without consuming:

> (peek-char port)
#\h
> (read-char port)  ; now consume it
#\h

EOF testing:

(define (read-all port)
  (let loop ((chars '()))
    (let ((ch (read-char port)))
      (if (eof-object? ch)
          (list→string (reverse chars))
          (loop (cons ch chars))))))

Writing to Ports

Write character:

> (write-char #\H port)

Write string:

> (display "Hello" port)
> (newline port)

Write S-expression:

> (write '(+ 1 2) port)

Difference: write vs. display:

> (write "hello")
"hello"  ; includes quotes

> (display "hello")
hello    ; no quotes

String Ports

Read/write from strings:

> (define in (open-input-string "42 hello"))
> (read in)
42
> (read in)
hello

> (define out (open-output-string))
> (write 'foo out)
> (display " " out)
> (write 123 out)
> (get-output-string out)
"foo 123"

Example: Reading Numbers from File

(define (read-numbers filename)
  (call-with-input-file filename
    (lambda (port)
      (let loop ((numbers '()))
        (let ((num (read port)))
          (if (eof-object? num)
              (reverse numbers)
              (loop (cons num numbers))))))))

> (read-numbers "numbers.txt")
(1 2 3 4 5)

Binary I/O (R7RS)

> (define out (open-binary-output-file "data.bin"))
> (write-u8 65 out)  ; write byte
> (close-output-port out)

> (define in (open-binary-input-file "data.bin"))
> (read-u8 in)  ; read byte
65

4.11 Type Coercion and Conversion

Scheme doesn’t perform implicit type coercion—conversions must be explicit.

Numeric Conversions

;; Exact to inexact
> (exact→inexact 22/7)

3.142857142857143

;; Inexact to exact
> (inexact→exact 3.14)

3.140000000000000124344978758017532527446746826171875

Round to integer:

> (floor 3.7)

3.0  ; still inexact!
> (inexact→exact (floor 3.7))
3  ; exact integer

String Conversions

Number to string:

> (number→string 42)
"42"
> (number→string 255 16)
"ff"
> (number→string 3.14)
"3.14"

String to number:

> (string→number "42")
42
> (string→number "3.14")

3.14
> (string→number "invalid")
#f

Symbol/string:

> (symbol→string 'hello)
"hello"
> (string→symbol "world")
world

Character/string:

> (string #\h #\i)
"hi"
> (string-ref "hi" 0)
#\h

List/Vector Conversions

> (list→vector '(a b c))
#(a b c)
> (vector→list #(1 2 3))
(1 2 3)

> (list→string '(#\h #\i))
"hi"
> (string→list "hello")
(#\h #\e #\l #\l #\o)

4.12 Predicates for Type Checking

Every type has a predicate. Here’s a comprehensive list:

Basic Type Predicates

(boolean? x)      ; #t or #f
(number? x)       ; any number
(complex? x)      ; complex number
(real? x)         ; real number
(rational? x)     ; rational number
(integer? x)      ; integer
(exact? x)        ; exact number
(inexact? x)      ; inexact number

Character and String

(char? x)         ; character
(string? x)       ; string

Symbolic

(symbol? x)       ; symbol
(keyword? x)      ; keyword (implementation-specific)

Compound Types

(pair? x)         ; pair/cons cell
(list? x)         ; proper list
(null? x)         ; empty list
(vector? x)       ; vector

Procedures and Ports

(procedure? x)    ; procedure/function
(port? x)         ; I/O port
(input-port? x)   ; input port
(output-port? x)  ; output port

Type Checking in Practice

(define (safe-car x)
  (if (pair? x)
      (car x)
      (error "Not a pair" x)))

(define (safe-add a b)
  (cond
    ((not (number? a))
     (error "First argument not a number" a))
    ((not (number? b))
     (error "Second argument not a number" b))
    (else (+ a b))))

4.13 Polymorphic Operations

Some operations work across multiple types:

Length Operations

> (length '(a b c))
3
> (string-length "hello")
5
> (vector-length #(1 2 3))
3

Equality Operations

> (equal? '(1 2) '(1 2))      ; lists
#t
> (equal? "hi" "hi")          ; strings
#t
> (equal? #(1 2) #(1 2))      ; vectors
#t
> (equal? 'foo 'foo)          ; symbols
#t

Copying Operations

(string-copy "hello")
(vector-copy #(1 2 3))
(list-copy '(a b c))

Filling Operations

(vector-fill! vec value)
(string-fill! str char)

Summary

In this chapter, we’ve explored Scheme’s rich type system:

  1. Type System: Dynamic, latent typing with runtime checks

  2. Booleans: Only #f is false; everything else is true

  3. Numbers: Full numeric tower from integers to complex numbers

  4. Characters: Unicode-aware character type

  5. Strings: Mutable sequences of characters

  6. Symbols: Unique, immutable identifiers

  7. Vectors: Fixed-size, random-access arrays

  8. Hashtables: Efficient key-value storage

  9. Structures: User-defined record types

  10. Ports: I/O streams for files and strings

  11. Type Conversion: Explicit conversions between types

Understanding these data types and their operations is fundamental to writing effective Scheme programs. Each type serves specific purposes and has performance characteristics that influence design decisions.

Exercises

  1. Type Predicates: Write a function type-of that returns a symbol describing an object’s type:

    (type-of 42)      → 'integer
(type-of 3.14)    → 'real
(type-of 'foo)    → 'symbol
(type-of "bar")   → 'string
(type-of '(a b))  → 'list

  2. String Operations: Implement:

    • (string-split str delim) — split string by delimiter

    • (string-join strs sep) — join strings with separator

    • (string-reverse str) — reverse a string

  3. Vector Operations: Implement:

    • (vector-map f vec) — map function over vector

    • (vector-filter pred vec) — filter vector elements

    • (vector-fold f init vec) — fold over vector

  4. Hashtable: Build a simple spell-checker:

    (define dict (make-equal-hashtable))
(define (add-word! word)
  (hashtable-set! dict (string-downcase word) #t))
(define (spell-check word)
  (hashtable-contains? dict (string-downcase word)))

  5. Record Types: Define a person record type with fields for name, age, and email. Implement:

    • Constructor with validation

    • Comparison by age

    • String representation

  6. File Processing: Write a program to:

    • Read a file line by line

    • Count occurrences of each word

    • Print the top 10 most frequent words

  7. Type Conversion: Implement (parse-csv line) that converts a CSV string to a list of values:

    (parse-csv "Alice,30,alice@example.com")
→ ("Alice" 30 "alice@example.com")

  8. Complex Numbers: Implement:

    • (distance p1 p2) — Euclidean distance between complex numbers

    • (rotate z angle) — rotate complex number by angle

  9. String Matching: Implement (string-match pattern text) that checks if a pattern (with * wildcard) matches text:

    (string-match "h*o" "hello")  → #t
(string-match "h*o" "hi")     → #f

  10. Polymorphic Length: Implement (generic-length x) that works for lists, vectors, strings, and returns the “size” of the object.

In the next chapter, we’ll explore procedures and higher-order functions, which allow us to abstract over both data and behavior, creating powerful compositional patterns in Scheme.

Chapter 5: Functions, Recursion, and Higher-Order Programming

5.1 Functions as First-Class Citizens

In Scheme, functions are first-class values. This means procedures can be:

  1. Assigned to variables

  2. Passed as arguments to other procedures

  3. Returned as results from procedures

  4. Stored in data structures

  5. Created anonymously (lambda expressions)

This property is fundamental to functional programming and enables powerful abstraction techniques.

Procedures Are Values

> (define add +)
> (add 3 4)
7

> (define operations (list + - * /))
> (map (lambda (op) (op 10 5)) operations)
(15 5 50 2)

> (procedure? +)
#t
> (procedure? 42)
#f

The Identity of Procedures

Procedures have identity, just like any other value:

> (define f (lambda (x) (* x x)))
> (define g (lambda (x) (* x x)))
> (eq? f f)
#t
> (eq? f g)
#f  ; different procedure objects, same behavior

5.2 Lambda: Anonymous Functions

The lambda special form creates anonymous procedures—functions without names.

Basic Lambda Syntax

(lambda (parameters …) body …)

Examples:

> ((lambda (x) (* x x)) 5)
25

> ((lambda (x y) (+ x y)) 3 4)
7

> ((lambda () (display "Hello!") (newline)))
Hello!

Lambda vs. Define

These are equivalent:

;; Using define
(define (square x)
  (* x x))

;; Using lambda explicitly
(define square
  (lambda (x)
    (* x x)))

The first form is syntactic sugar for the second. Understanding this equivalence is crucial: define for procedures is just binding a lambda to a name.

When to Use Lambda

Anonymous, one-off functions:

> (map (lambda (x) (+ x 1)) '(1 2 3))
(2 3 4)

Returning functions from functions:

(define (make-adder n)
  (lambda (x) (+ x n)))

> (define add5 (make-adder 5))
> (add5 10)
15

Callback functions:

(define (repeat n action)
  (if (> n 0)
      (begin
        (action)
        (repeat (- n 1) action))))

> (repeat 3 (lambda () (display "Hi! ")))
Hi! Hi! Hi!

5.3 Lexical Closures

A closure is a function that captures variables from its surrounding environment.

Basic Closures

(define (make-counter)
  (let ((count 0))
    (lambda ()
      (set! count (+ count 1))
      count)))

> (define c1 (make-counter))
> (c1)
1
> (c1)
2
> (c1)
3

> (define c2 (make-counter))
> (c2)
1  ; independent counter
> (c1)
4  ; c1 continues from where it left off

Each closure maintains its own copy of the captured environment.

Closure Composition

(define (make-account balance)
  (lambda (amount)
    (if (≥ balance amount)
        (begin
          (set! balance (- balance amount))
          balance)
        "Insufficient funds")))

> (define account (make-account 100))
> (account 25)
75
> (account 50)
25
> (account 50)
"Insufficient funds"

Multiple Closures Sharing State

(define (make-account balance)
  (define (withdraw amount)
    (if (≥ balance amount)
        (begin
          (set! balance (- balance amount))
          balance)
        "Insufficient funds"))
  
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  
  (define (dispatch m)
    (cond ((eq? m 'withdraw) withdraw)
          ((eq? m 'deposit) deposit)
          ((eq? m 'balance) balance)
          (else (error "Unknown request" m))))
  
  dispatch)

> (define acc (make-account 100))
> ((acc 'withdraw) 25)
75
> ((acc 'deposit) 50)
125
> (acc 'balance)
125

Closures and Loops

A common pitfall when creating closures in loops:

;; WRONG: All closures share the same i
(define (make-closures-wrong n)
  (let ((result '()))
    (do ((i 0 (+ i 1)))
        ((= i n) (reverse result))
      (set! result (cons (lambda () i) result)))))

> (define fns (make-closures-wrong 3))
> ((car fns))
3  ; Expected 0!
> ((cadr fns))
3  ; Expected 1!

;; CORRECT: Each closure captures its own value
(define (make-closures-right n)
  (let ((result '()))
    (do ((i 0 (+ i 1)))
        ((= i n) (reverse result))
      (let ((j i))  ; Create new binding for each iteration
        (set! result (cons (lambda () j) result))))))

> (define fns (make-closures-right 3))
> ((car fns))
0
> ((cadr fns))
1

5.4 Recursion: The Natural Loop

Recursion is defining a procedure in terms of itself. It’s the primary iteration mechanism in functional programming.

Anatomy of Recursion

Every recursive function needs:

  1. Base case(s): Termination condition(s)

  2. Recursive case(s): Self-reference with progress toward base case

  3. Progress: Each recursive call must move toward the base case

Simple Recursion: Factorial

(define (factorial n)
  (if (= n 0)
      1                              ; base case
      (* n (factorial (- n 1)))))    ; recursive case

> (factorial 5)
120

Evaluation trace:

(factorial 5) (* 5 (factorial 4)) (* 5 (* 4 (factorial 3))) (* 5 (* 4 (* 3 (factorial 2)))) (* 5 (* 4 (* 3 (* 2 (factorial 1))))) (* 5 (* 4 (* 3 (* 2 (* 1 (factorial 0)))))) (* 5 (* 4 (* 3 (* 2 (* 1 1))))) (* 5 (* 4 (* 3 (* 2 1)))) (* 5 (* 4 (* 3 2))) (* 5 (* 4 6)) (* 5 24) 120

List Recursion

Length of a list:

(define (length lst)
  (if (null? lst)
      0
      (+ 1 (length (cdr lst)))))

> (length '(a b c d))
4

Sum of numbers:

(define (sum lst)
  (if (null? lst)
      0
      (+ (car lst) (sum (cdr lst)))))

> (sum '(1 2 3 4 5))
15

List reversal (inefficient version):

(define (append lst1 lst2)
  (if (null? lst1)
      lst2
      (cons (car lst1) (append (cdr lst1) lst2))))

(define (reverse lst)
  (if (null? lst)
      '()
      (append (reverse (cdr lst)) (list (car lst)))))

> (reverse '(a b c d))
(d c b a)

This is O(n2)O(n^2) due to repeated append calls. We’ll see a better version with tail recursion.

Tree Recursion: Fibonacci

(define (fib n)
  (cond ((= n 0) 0)
        ((= n 1) 1)
        (else (+ (fib (- n 1))
                 (fib (- n 2))))))

> (fib 10)
55

Warning: This is exponentially slow! (fib 40) makes over 300 million recursive calls.

Call tree for (fib 5):

                fib(5)
               /      \
          fib(4)        fib(3)
         /     \        /     \
    fib(3)   fib(2)  fib(2)  fib(1)
    /   \    /   \   /   \
fib(2) fib(1) …  …  …
/   \

fib(1) fib(0)

Notice the redundant computation of fib(3), fib(2), etc.

Multiple Recursion: Ackermann Function

(define (ackermann m n)
  (cond ((= m 0) (+ n 1))
        ((= n 0) (ackermann (- m 1) 1))
        (else (ackermann (- m 1)
                         (ackermann m (- n 1))))))

> (ackermann 3 4)
125

This grows extremely fast. (ackermann 4 2) returns 65536, but (ackermann 4 3) is astronomically large!

5.5 Tail Recursion and Iteration

What Is Tail Position?

An expression is in tail position if its value is directly returned without further computation.

(define (example x)
  (if (< x 0)
      (* x x)           ; tail position
      (+ x (foo x))))   ; (foo x) is in tail position
                        ; overall if is in tail position

Tail Calls

A tail call is a procedure call in tail position:

(define (f x)
  (g x))     ; tail call to g

(define (h x)
  (+ 1 (g x)))  ; NOT a tail call (must add 1 after)

Tail Call Optimization (TCO)

Scheme requires implementations to optimize tail calls, making them equivalent to iterative loops. A tail call doesn’t consume stack space—it’s like a jump instruction.

This is mandatory in Scheme, unlike most languages where it’s optional.

Tail-Recursive Factorial

(define (factorial n)
  (define (iter product counter)
    (if (> counter n)
        product
        (iter (* product counter)       ; tail call
              (+ counter 1))))
  (iter 1 1))

> (factorial 5)
120

Evaluation trace:

(factorial 5) (iter 1 1) (iter 1 2) (iter 2 3) (iter 6 4) (iter 24 5) (iter 120 6) 120

No growth in stack space! Each iter call replaces the previous one.

Converting to Tail Recursion: Accumulator Pattern

The key technique is using an accumulator to carry intermediate results:

Non-tail-recursive sum:

(define (sum lst)
  (if (null? lst)
      0
      (+ (car lst) (sum (cdr lst)))))

Tail-recursive sum:

(define (sum lst)
  (define (iter lst acc)
    (if (null? lst)
        acc
        (iter (cdr lst) (+ acc (car lst)))))  ; tail call
  (iter lst 0))

> (sum '(1 2 3 4 5))
15

Tail-Recursive List Reversal

(define (reverse lst)
  (define (iter lst acc)
    (if (null? lst)
        acc
        (iter (cdr lst) (cons (car lst) acc))))
  (iter lst '()))

> (reverse '(a b c d))
(d c b a)

This is O(n)O(n) time and space—much better than the naive version!

Named Let for Iteration

Scheme provides named let as syntactic sugar for tail-recursive iteration:

(define (factorial n)
  (let iter ((product 1) (counter 1))
    (if (> counter n)
        product
        (iter (* product counter) (+ counter 1)))))

This is equivalent to the earlier iter helper but more compact.

Another example—finding maximum:

(define (max-list lst)
  (if (null? lst)
      (error "Empty list")
      (let loop ((remaining (cdr lst))
                 (max-so-far (car lst)))
        (if (null? remaining)
            max-so-far
            (loop (cdr remaining)
                  (if (> (car remaining) max-so-far)
                      (car remaining)
                      max-so-far))))))

> (max-list '(3 7 2 9 1))
9

Mutual Tail Recursion

(define (even? n)
  (if (= n 0)
      #t
      (odd? (- n 1))))

(define (odd? n)
  (if (= n 0)
      #f
      (even? (- n 1))))

> (even? 100)
#t
> (odd? 101)
#t

Both functions are tail-recursive with respect to each other.

5.6 Higher-Order Functions

Higher-order functions either:

  1. Take functions as arguments, or

  2. Return functions as results, or

  3. Both

They enable powerful abstractions by separating what to do from how to do it.

Map: Transform Each Element

(define (map f lst)
  (if (null? lst)
      '()
      (cons (f (car lst))
            (map f (cdr lst)))))

> (map (lambda (x) (* x x)) '(1 2 3 4))
(1 4 9 16)

> (map car '((a b) (c d) (e f)))
(a c e)

> (map + '(1 2 3) '(4 5 6))
(5 7 9)

Multiple lists:

(define (map f . lists)
  (if (null? (car lists))
      '()
      (cons (apply f (map car lists))
            (apply map f (map cdr lists)))))

Filter: Select Elements

(define (filter pred lst)
  (cond ((null? lst) '())
        ((pred (car lst))
         (cons (car lst) (filter pred (cdr lst))))
        (else (filter pred (cdr lst)))))

> (filter even? '(1 2 3 4 5 6))
(2 4 6)

> (filter (lambda (x) (> x 0)) '(-2 3 -1 4 0 5))
(3 4 5)

Fold: Reduce to Single Value

Left fold (fold-left, reduce):

(define (fold-left op init lst)
  (if (null? lst)
      init
      (fold-left op
                 (op init (car lst))
                 (cdr lst))))

> (fold-left + 0 '(1 2 3 4))
10
> (fold-left * 1 '(1 2 3 4))
24
> (fold-left cons '() '(a b c))
((((c . b) . a)))

Right fold:

(define (fold-right op init lst)
  (if (null? lst)
      init
      (op (car lst)
          (fold-right op init (cdr lst)))))

> (fold-right + 0 '(1 2 3 4))
10
> (fold-right cons '() '(a b c))
(a b c)

Difference:

  • fold-left: Associates left: (((init op a) op b) op c)

  • fold-right: Associates right: (a op (b op (c op init)))

For associative operations like +, they’re equivalent. For cons, they differ significantly.

Practical Example: Word Statistics

(define (word-stats text)
  (let* ((words (string-split text #\space))
         (lengths (map string-length words))
         (total (fold-left + 0 lengths))
         (count (length words)))
    (list (cons 'total-words count)
          (cons 'total-chars total)
          (cons 'avg-length (/ total count)))))

> (word-stats "the quick brown fox")
((total-words . 4) (total-chars . 15) (avg-length . 15/4))

Composing Functions

(define (compose f g)
  (lambda (x) (f (g x))))

> (define square (lambda (x) (* x x)))
> (define inc (lambda (x) (+ x 1)))
> (define square-then-inc (compose inc square))
> (square-then-inc 5)
26

> (define inc-then-square (compose square inc))
> (inc-then-square 5)
36

Multiple composition:

(define (compose . fns)
  (fold-right (lambda (f g)
                (lambda (x) (f (g x))))
              (lambda (x) x)
              fns))

> (define f (compose car cdr cdr))
> (f '(a b c d))
c

Partial Application

(define (partial f . args)
  (lambda rest
    (apply f (append args rest))))

> (define add5 (partial + 5))
> (add5 10)
15

> (define starts-with-a?
    (partial string-prefix? "a"))
> (starts-with-a? "apple")
#t
> (starts-with-a? "banana")
#f

Currying

Currying transforms a function taking multiple arguments into a chain of single-argument functions:

(define (curry2 f)
  (lambda (x)
    (lambda (y)
      (f x y))))

> (define curried-add (curry2 +))
> ((curried-add 3) 4)
7

> (define add3 (curried-add 3))
> (add3 10)
13

General curry:

(define (curry f)
  (lambda (x)
    (lambda args
      (apply f x args))))

Pipeline: Threading Data Through Functions

(define (pipe x . fns)
  (fold-left (lambda (val f) (f val))
             x
             fns))

> (pipe 5
        (lambda (x) (* x x))
        (lambda (x) (+ x 1))
        (lambda (x) (/ x 2)))
13

Or reverse order (thread-first):

(define (thread-first x . fns)
  (fold-left (lambda (val f) (f val)) x fns))

(define (thread-last x . fns)
  (fold-right (lambda (f val) (f val)) x (reverse fns)))

5.7 Implementing Higher-Order Functions

Building Map from Scratch

(define (my-map f lst)
  (let loop ((remaining lst) (result '()))
    (if (null? remaining)
        (reverse result)
        (loop (cdr remaining)
              (cons (f (car remaining)) result)))))

Tail-recursive with accumulator pattern.

Building Filter from Scratch

(define (my-filter pred lst)
  (let loop ((remaining lst) (result '()))
    (cond ((null? remaining) (reverse result))
          ((pred (car remaining))
           (loop (cdr remaining)
                 (cons (car remaining) result)))
          (else
           (loop (cdr remaining) result)))))

Generic Reduce

(define (reduce op init lst)
  (cond ((null? lst) init)
        ((null? (cdr lst)) (car lst))
        (else
         (let loop ((acc (op (car lst) (cadr lst)))
                    (rest (cddr lst)))
           (if (null? rest)
               acc
               (loop (op acc (car rest))
                     (cdr rest)))))))

> (reduce + 0 '(1 2 3 4))
10
> (reduce max 0 '(3 7 2 9 1))
9

Building Every and Some

(define (every pred lst)
  (cond ((null? lst) #t)
        ((pred (car lst)) (every pred (cdr lst)))
        (else #f)))

(define (some pred lst)
  (cond ((null? lst) #f)
        ((pred (car lst)) #t)
        (else (some pred (cdr lst)))))

> (every even? '(2 4 6))
#t
> (every even? '(2 3 4))
#f

> (some odd? '(2 4 6))
#f
> (some odd? '(2 3 4))
#t

5.8 Advanced Recursion Patterns

Structural Recursion on Trees

(define (tree-map f tree)
  (cond ((null? tree) '())
        ((not (pair? tree)) (f tree))
        (else (cons (tree-map f (car tree))
                    (tree-map f (cdr tree))))))

> (tree-map (lambda (x) (* x 2))
            '(1 (2 3) ((4) 5)))
(2 (4 6) ((8) 10))

Deep Reverse

(define (deep-reverse tree)
  (cond ((null? tree) '())
        ((not (pair? tree)) tree)
        (else (reverse (map deep-reverse tree)))))

> (deep-reverse '(1 (2 3) 4))
(4 (3 2) 1)

Flatten a Tree

(define (flatten tree)
  (cond ((null? tree) '())
        ((not (pair? tree)) (list tree))
        (else (append (flatten (car tree))
                      (flatten (cdr tree))))))

> (flatten '(1 (2 (3 4)) (5)))
(1 2 3 4 5)

Memoization

Optimize recursive functions by caching results:

(define (memoize f)
  (let ((cache (make-hashtable)))
    (lambda args
      (if (hashtable-contains? cache args)
          (hashtable-ref cache args #f)
          (let ((result (apply f args)))
            (hashtable-set! cache args result)
            result)))))

;; Memoized fibonacci
(define fib
  (memoize
   (lambda (n)
     (cond ((= n 0) 0)
           ((= n 1) 1)
           (else (+ (fib (- n 1))
                    (fib (- n 2))))))))

> (fib 100)
354224848179261915075  ; computed quickly!

Continuation-Passing Style (CPS)

Instead of returning values, pass them to continuation functions:

;; Direct style
(define (factorial n)
  (if (= n 0)
      1
      (* n (factorial (- n 1)))))

;; CPS style
(define (factorial-cps n k)
  (if (= n 0)
      (k 1)
      (factorial-cps (- n 1)
                     (lambda (result)
                       (k (* n result))))))

> (factorial-cps 5 (lambda (x) x))
120

CPS makes control flow explicit and is used in compiler transformations.

5.9 Practical Applications

Sorting with Higher-Order Functions

(define (quicksort lst less?)
  (if (null? lst)
      '()
      (let ((pivot (car lst))
            (rest (cdr lst)))
        (append (quicksort (filter (lambda (x) (less? x pivot)) rest)
                          less?)
                (list pivot)
                (quicksort (filter (lambda (x) (not (less? x pivot))) rest)
                          less?)))))

> (quicksort '(3 7 2 9 1 5) <)
(1 2 3 5 7 9)

> (quicksort '("dog" "cat" "elephant" "ant") string<?)
("ant" "cat" "dog" "elephant")
(define (binary-search vec target less?)
  (let loop ((low 0) (high (- (vector-length vec) 1)))
    (if (> low high)
        #f
        (let ((mid (quotient (+ low high) 2)))
          (let ((mid-val (vector-ref vec mid)))
            (cond ((less? mid-val target)
                   (loop (+ mid 1) high))
                  ((less? target mid-val)
                   (loop low (- mid 1)))
                  (else mid)))))))

> (binary-search #(1 3 5 7 9 11) 7 <)
3
> (binary-search #(1 3 5 7 9 11) 6 <)
#f

Building a Mini-Query Language

(define (where pred)
  (lambda (lst) (filter pred lst)))

(define (select f)
  (lambda (lst) (map f lst)))

(define (order-by less?)
  (lambda (lst) (quicksort lst less?)))

(define (query . operations)
  (lambda (data)
    (fold-left (lambda (result op) (op result))
               data
               operations)))

;; Example usage
(define people
  '((name "Alice" age 30)
    (name "Bob" age 25)
    (name "Charlie" age 35)
    (name "Diana" age 28)))

(define get-adults
  (query
   (where (lambda (p) (≥ (cdr (assq 'age p)) 30)))
   (select (lambda (p) (cdr (assq 'name p))))
   (order-by string<?)))

> (get-adults people)
("Alice" "Charlie")

Lazy Sequences with Closures

(define (make-range start end)
  (lambda ()
    (if (> start end)
        '()
        (cons start
              (make-range (+ start 1) end)))))

(define (take n seq)
  (if (or (= n 0) (null? seq))
      '()
      (let ((val-and-rest (seq)))
        (cons (car val-and-rest)
              (take (- n 1) (cdr val-and-rest))))))

> (take 5 (make-range 1 100))
(1 2 3 4 5)

Function Decorators

(define (trace-calls f)
  (lambda args
    (display "Calling with: ")
    (display args)
    (newline)
    (let ((result (apply f args)))
      (display "Result: ")
      (display result)
      (newline)
      result)))

> (define traced-add (trace-calls +))
> (traced-add 3 4)
Calling with: (3 4)
Result: 7
7

5.10 Recursion vs. Iteration: When to Use Each

Use Recursion When:

  1. Natural structure is recursive: Trees, nested lists

  2. Problem decomposes recursively: Divide-and-conquer algorithms

  3. Readability matters: Recursive solutions can be clearer

  4. Multiple recursive calls: Branching recursion

;; Tree traversal - naturally recursive
(define (tree-sum tree)
  (cond ((null? tree) 0)
        ((not (pair? tree)) tree)
        (else (+ (tree-sum (car tree))
                 (tree-sum (cdr tree))))))

Use Tail Recursion (Iteration) When:

  1. Linear iteration: Processing sequences

  2. Performance critical: Avoid stack growth

  3. Accumulation: Building up results

  4. State machines: Tracking current state

;; List sum - better with tail recursion
(define (sum lst)
  (let loop ((remaining lst) (acc 0))
    (if (null? remaining)
        acc
        (loop (cdr remaining) (+ acc (car remaining))))))

Hybrid Approaches

Sometimes you need both:

(define (tree-fold op init tree)
  ;; Recursive on structure, tail-recursive on lists
  (let loop ((tree tree) (acc init))
    (cond ((null? tree) acc)
          ((not (pair? tree)) (op acc tree))
          (else
           (loop (cdr tree)
                 (tree-fold op acc (car tree)))))))

5.11 Common Recursion Patterns

1. Linear Recursion

Process a list element by element:

(define (pattern lst)
  (if (null? lst)
      base-case
      (combine (car lst)
               (pattern (cdr lst)))))

2. Tail Recursion with Accumulator

(define (pattern lst)
  (let loop ((remaining lst) (acc init))
    (if (null? remaining)
        acc
        (loop (cdr remaining)
              (update acc (car remaining))))))

3. Tree Recursion

(define (pattern tree)
  (cond ((null? tree) base-case)
        ((atom? tree) (process tree))
        (else (combine (pattern (car tree))
                       (pattern (cdr tree))))))

4. Mutual Recursion

(define (even? n)
  (if (= n 0) #t (odd? (- n 1))))

(define (odd? n)
  (if (= n 0) #f (even? (- n 1))))

5. Generative Recursion

Generate new problems rather than just breaking down input:

(define (gcd a b)
  (if (= b 0)
      a
      (gcd b (remainder a b))))

5.12 Performance Considerations

Space Complexity

Non-tail recursion: O(n)O(n) stack space for depth nn

(define (sum lst)
  (if (null? lst)
      0
      (+ (car lst) (sum (cdr lst)))))  ; O(n) space

Tail recursion: O(1)O(1) stack space

(define (sum lst)
  (let loop ((lst lst) (acc 0))
    (if (null? lst)
        acc
        (loop (cdr lst) (+ acc (car lst))))))  ; O(1) space

Time Complexity

Naive fibonacci: O(2n)O(2^n) time

(define (fib n)
  (if (≤ n 1)
      n
      (+ (fib (- n 1)) (fib (- n 2)))))

Iterative fibonacci: O(n)O(n) time

(define (fib n)
  (let loop ((a 0) (b 1) (i 0))
    (if (= i n)
        a
        (loop b (+ a b) (+ i 1)))))

Memoized fibonacci: O(n)O(n) time, O(n)O(n) space

(define fib
  (let ((cache (make-hashtable)))
    (lambda (n)
      (or (hashtable-ref cache n #f)
          (let ((result
                 (if (≤ n 1)
                     n
                     (+ (fib (- n 1)) (fib (- n 2))))))
            (hashtable-set! cache n result)
            result)))))

Summary

In this chapter, we explored the foundations of functional programming in Scheme:

  1. First-Class Functions: Procedures as values that can be passed, returned, and stored

  2. Lambda Expressions: Creating anonymous functions

  3. Lexical Closures: Functions capturing their environment

  4. Recursion: The primary iteration mechanism

    • Base and recursive cases

    • Linear, tree, and mutual recursion

  5. Tail Recursion: Space-efficient iteration through TCO

    • Accumulator pattern

    • Named let for iteration

  6. Higher-Order Functions: Functions operating on functions

    • Map, filter, fold

    • Composition and partial application

    • Building abstractions

  7. Practical Patterns: Memoization, CPS, lazy sequences

  8. Performance: Understanding space and time trade-offs

These concepts form the backbone of functional programming and enable writing elegant, composable, and correct programs.

Exercises

  1. Tail Recursion: Convert these to tail-recursive versions:

    (define (expt base n)
  (if (= n 0)
      1
      (* base (expt base (- n 1)))))

(define (length lst)
  (if (null? lst)
      0
      (+ 1 (length (cdr lst)))))

  2. Higher-Order: Implement partition that splits a list based on a predicate:

    (partition even? '(1 2 3 4 5))
→ ((2 4) (1 3 5))

  3. Folding: Implement reverse using fold-left or fold-right.

  4. Tree Operations: Implement:

    • tree-height: Maximum depth of a tree

    • tree-leaves: Count leaf nodes

    • tree-find: Search for a value

  5. Fibonacci Variants: Implement:

    • Tail-recursive fibonacci

    • Fibonacci returning a list of the first nn values

    • Generalized fibonacci with custom f(0)f(0) and f(1)f(1)

  6. Function Composition: Implement pipe that threads a value through functions left-to-right:

    (pipe 5 square inc (lambda (x) (/ x 2)))
→ 13

  7. Curry: Implement a general curry that works for functions of any arity.

  8. Memoization: Implement memoize-with-limit that only caches the nn most recent results.

  9. Lazy Evaluation: Implement infinite streams:

    (define naturals (make-stream 0 (lambda (n) (+ n 1))))
(take 10 naturals)
→ (0 1 2 3 4 5 6 7 8 9)

  10. Binary Search Tree: Implement insertion, search, and in-order traversal using recursive data structures.

In the next chapter, we’ll explore macros and metaprogramming, which leverage our understanding of functions and S-expressions to transform code at compile time—one of Lisp’s most powerful features.

Chapter 7: Modules, Libraries, Bindings, and SRFIs

7.1 Introduction to Modularity in Scheme

Modularity is essential for building large, maintainable software systems. Scheme has evolved multiple approaches to organizing code, from simple file-based organization to sophisticated library systems.

Why Modules Matter

  1. Namespace Management: Avoid naming conflicts

  2. Information Hiding: Control what’s exposed

  3. Reusability: Share code across projects

  4. Dependency Management: Express what code needs

  5. Separate Compilation: Build parts independently

  6. Team Development: Multiple developers, minimal conflicts

Historical Context

Scheme’s module systems have evolved:

  • Early days: Simple load and file inclusion

  • R5RS: No standard module system

  • R6RS: Comprehensive library system

  • R7RS-small: Simplified, practical library system

  • SRFIs: Community-driven extensions

Different implementations (Chez, Racket, Guile, Chicken, etc.) developed their own systems, leading to portability challenges that SRFIs and R6RS/R7RS aimed to address.

7.2 R7RS Library System

R7RS provides a portable, lightweight library mechanism.

Basic Library Definition

;; File: math-utils.sld (Scheme Library Definition)
(define-library (math-utils)
  
  ;; What this library exports
  (export square
          cube
          average
          factorial)
  
  ;; What this library imports
  (import (scheme base))
  
  ;; Library code
  (begin
    (define (square x)
      (* x x))
    
    (define (cube x)
      (* x x x))
    
    (define (average a b)
      (/ (+ a b) 2))
    
    (define (factorial n)
      (if (≤ n 1)
          1
          (* n (factorial (- n 1)))))))

Using Libraries

;; File: main.scm
(import (scheme base)
        (scheme write)
        (math-utils))

(display (square 5))
(newline)
(display (factorial 6))
(newline)

Selective Import

(define-library (my-program)
  (import (scheme base)
          (scheme write)
          ;; Import only specific bindings
          (only (math-utils) square factorial)
          ;; Rename on import
          (rename (math-utils) (average avg))
          ;; Import all except
          (except (math-utils) cube)
          ;; Add prefix to all imports
          (prefix (math-utils) math:))
  
  (begin
    (display (square 4))        ; Available
    (display (math:cube 3))     ; With prefix
    (display (avg 10 20))       ; Renamed
    ;; (cube 2)                 ; Not available
    ))

Export Control

(define-library (geometry)
  (export
    ;; Export a procedure
    circle-area
    ;; Export a renamed procedure
    (rename internal-helper public-helper)
    ;; Export syntax
    define-point)
  
  (import (scheme base))
  
  (begin
    (define pi 3.14159265)  ; Not exported - private
    
    (define (circle-area radius)
      (* pi radius radius))
    
    (define (internal-helper x)
      (* x 2))
    
    (define-syntax define-point
      (syntax-rules ()
        ((define-point name x y)
         (define name (cons x y)))))))

Library Includes

(define-library (my-lib)
  (export foo bar)
  (import (scheme base))
  
  ;; Include Scheme source files
  (include "helpers.scm")
  (include "core.scm")
  
  ;; Include with specific library language
  (include-library-declarations "declarations.scm"))

Conditional Expansion

(define-library (portable-io)
  (export read-all)
  (import (scheme base))
  
  (cond-expand
    ;; For systems with R7RS
    ((library (scheme file))
     (import (scheme file))
     (begin
       (define (read-all filename)
         (call-with-input-file filename
           (lambda (port)
             (read-string 10000 port))))))
    
    ;; For systems with only R5RS
    (r5rs
     (begin
       (define (read-all filename)
         (call-with-input-file filename
           (lambda (port)
             (let loop ((chars '()))
               (let ((c (read-char port)))
                 (if (eof-object? c)
                     (list→string (reverse chars))
                     (loop (cons c chars))))))))))
    
    ;; Fallback
    (else
     (begin
       (define (read-all filename)
         (error "File I/O not supported"))))))

Feature Testing

(define-library (platform-specific)
  (export get-os-name)
  
  (cond-expand
    (unix
     (begin
       (define (get-os-name) "Unix-like")))
    
    (windows
     (begin
       (define (get-os-name) "Windows")))
    
    ((or linux bsd)
     (begin
       (define (get-os-name) "Linux/BSD")))
    
    (else
     (begin
       (define (get-os-name) "Unknown")))))

7.3 R6RS Library System

R6RS provides a more comprehensive library system.

Basic R6RS Library

;; File: math-utils.sls (Scheme Library Source)
#!r6rs
(library (math-utils)
  (export square cube average)
  (import (rnrs base)
          (rnrs arithmetic fixnums))
  
  (define (square x)
    (* x x))
  
  (define (cube x)
    (* x x x))
  
  (define (average a b)
    (/ (+ a b) 2)))

Import Specifications

#!r6rs
(library (my-program)
  (export main)
  (import
    (rnrs base (6))           ; Specific version
    (only (rnrs lists) filter fold-left)
    (except (rnrs) define)    ; Import all except
    (prefix (rnrs io simple) io:)
    (rename (math-utils) (square sq)))
  
  (define (main)
    (io:display (sq 5))
    (io:newline)))

Versioning

#!r6rs
(library (mylib (1 0))  ; Version 1.0
  (export foo)
  (import (rnrs))
  
  (define (foo x) x))

;; Importing specific version
(import (mylib (1 0)))           ; Exactly 1.0
(import (mylib (1)))             ; 1.x (any)
(import (mylib (≥ 1)))          ; 1.0 or later
(import (mylib (and (≥ 1) (< 2)))) ; 1.x only

Phase Specifications

R6RS supports phase separation for macros:

#!r6rs
(library (macro-helpers)
  (export make-getter)
  (import (rnrs))
  
  ;; Used at expansion time
  (define (make-getter field-name)
    #`(lambda (obj)
        (#,field-name obj))))

#!r6rs
(library (my-macros)
  (export define-record)
  (import (rnrs)
          (for (macro-helpers) expand))  ; Import for macro expansion
  
  (define-syntax define-record
    (lambda (x)
      (syntax-case x ()
        ((_ name field …)
         #'(begin
             (define-syntax name …)
             …))))))

Script vs Library

;; Script file: program.sps
#!r6rs
(import (rnrs)
        (math-utils))

(display (square 10))
(newline)

7.4 Implementation-Specific Module Systems

Chez Scheme Modules

Chez has built-in support for R6RS libraries plus extensions:

;; Using R6RS libraries
(import (chezscheme))

;; Load compiled object files
(load-shared-object "mylib.so")

;; Access C functions via FFI
(define-ftype FILE void*)
(define fopen
  (foreign-procedure "fopen" (string string) FILE))

Chicken Scheme Modules

Chicken uses units and modules:

;; File: math-utils.scm
(module math-utils
  (square cube average)
  
  (import scheme)
  
  (define (square x)
    (* x x))
  
  (define (cube x)
    (* x x x))
  
  (define (average a b)
    (/ (+ a b) 2)))

;; Usage
(import math-utils)
(print (square 5))

Compiling Chicken modules:

# Compile to object file
$ csc -s math-utils.scm

# Link and use
$ csc -uses math-utils main.scm

Guile Modules

GNU Guile uses define-module:

;; File: math-utils.scm
(define-module (math-utils)
  #:export (square cube average))

(define (square x)
  (* x x))

(define (cube x)
  (* x x x))

(define (average a b)
  (/ (+ a b) 2))

Usage:

(use-modules (math-utils))
(display (square 5))

Loading from search path:

;; Add to module search path
(add-to-load-path "/path/to/modules")

;; Load module
(use-modules (my custom module))
;; Looks for: /path/to/modules/my/custom/module.scm

Racket Modules

Racket has a sophisticated module system:

#lang racket

(provide square cube average)

(define (square x)
  (* x x))

(define (cube x)
  (* x x x))

(define (average a b)
  (/ (+ a b) 2))

Usage:

#lang racket

(require "math-utils.rkt")

(displayln (square 5))

Selective importing:

(require (only-in "math-utils.rkt" square)
         (rename-in "math-utils.rkt" [average avg])
         (prefix-in math: "math-utils.rkt"))

7.5 Scheme Requests for Implementation (SRFIs)

SRFIs are community-driven specifications for Scheme extensions.

What are SRFIs?

  • Portable specifications for libraries and language features

  • Numbered documents (SRFI-1, SRFI-9, etc.)

  • Implementation-neutral - multiple Schemes can implement

  • Different statuses: Draft, Final, Withdrawn

Common SRFIs

SRFI-1: List Library
(import (srfi 1))  ; R7RS
;; or
(use-modules (srfi srfi-1))  ; Guile

;; Extended list operations
(define lst '(1 2 3 4 5))

(iota 5)                    ; → (0 1 2 3 4)
(iota 5 1)                  ; → (1 2 3 4 5)
(iota 5 0 2)                ; → (0 2 4 6 8)

(take lst 3)                ; → (1 2 3)
(drop lst 3)                ; → (4 5)
(take-right lst 2)          ; → (4 5)
(drop-right lst 2)          ; → (1 2 3)

(split-at lst 3)            ; → (1 2 3) and (4 5)

(last lst)                  ; → 5
(last-pair lst)             ; → (5)

;; List predicates
(proper-list? '(1 2 3))     ; → #t
(circular-list? lst)        ; → #f
(dotted-list? '(1 . 2))     ; → #t

;; Constructors
(circular-list 1 2 3)       ; → Infinite list #1=(1 2 3 . #1#)
(list-tabulate 5 (lambda (i) (* i i)))  ; → (0 1 4 9 16)

;; Searching
(find even? '(1 3 5 6 7))   ; → 6
(find-tail even? '(1 3 5 6 7))  ; → (6 7)
(take-while positive? '(1 2 3 0 -1))  ; → (1 2 3)
(drop-while positive? '(1 2 3 0 -1))  ; → (0 -1)

;; Folding
(fold + 0 '(1 2 3 4 5))     ; → 15
(fold cons '() '(1 2 3))    ; → (3 2 1)
(fold-right cons '() '(1 2 3))  ; → (1 2 3)

;; Filtering
(partition even? '(1 2 3 4 5 6))  ; → (2 4 6) and (1 3 5)
(remove even? '(1 2 3 4 5))       ; → (1 3 5)

;; Zipping
(zip '(1 2 3) '(a b c))     ; → ((1 a) (2 b) (3 c))
(unzip2 '((1 a) (2 b)))     ; → (1 2) and (a b)
SRFI-9: Defining Record Types
(import (srfi 9))

(define-record-type <point>
  (make-point x y)          ; Constructor
  point?                    ; Predicate
  (x point-x set-point-x!)  ; Fields with accessors/mutators
  (y point-y set-point-y!))

(define p (make-point 3 4))
(point? p)                  ; → #t
(point-x p)                 ; → 3
(point-y p)                 ; → 4
(set-point-x! p 10)
(point-x p)                 ; → 10

;; Immutable fields
(define-record-type <person>
  (make-person name age)
  person?
  (name person-name)        ; No mutator - immutable
  (age person-age))
SRFI-13: String Libraries
(import (srfi 13))

(string-null? "")           ; → #t
(string-every char-numeric? "123")  ; → #t
(string-any char-alphabetic? "a12") ; → #t

(string-tabulate (lambda (i) (integer→char (+ i 65))) 5)
; → "ABCDE"

(string-take "Hello" 3)     ; → "Hel"
(string-drop "Hello" 3)     ; → "lo"
(string-pad "42" 5 #\0)     ; → "00042"
(string-trim " hello ")     ; → "hello"

(string-prefix? "http://" "http://example.com")  ; → #t
(string-suffix? ".txt" "file.txt")               ; → #t
(string-contains "hello world" "world")          ; → 6

(string-split "one,two,three" ",")   ; → ("one" "two" "three")
(string-join '("a" "b" "c") ":")     ; → "a:b:c"
SRFI-14: Character-Set Library
(import (srfi 14))

(define vowels (char-set #\a #\e #\i #\o #\u))

(char-set-contains? vowels #\a)  ; → #t
(char-set-contains? vowels #\b)  ; → #f

(char-set-size vowels)           ; → 5

;; Predefined sets
char-set:lower-case
char-set:upper-case
char-set:digit
char-set:letter
char-set:whitespace
char-set:punctuation

;; Operations
(char-set-union char-set:digit char-set:lower-case)
(char-set-intersection char-set:letter char-set:lower-case)
(char-set-difference char-set:letter vowels)
SRFI-43: Vector Library
(import (srfi 43))

(vector-map (lambda (i x) (* x x)) '#(1 2 3 4))
; → #(1 4 9 16)

(vector-fold (lambda (i acc x) (+ acc x)) 0 '#(1 2 3))
; → 6

(vector-tabulate 5 (lambda (i) (* i i)))
; → #(0 1 4 9 16)

(vector-take '#(1 2 3 4 5) 3)     ; → #(1 2 3)
(vector-drop '#(1 2 3 4 5) 3)     ; → #(4 5)
SRFI-69: Basic Hash Tables
(import (srfi 69))

(define table (make-hash-table))

(hash-table-set! table 'x 100)
(hash-table-set! table 'y 200)

(hash-table-ref table 'x)         ; → 100
(hash-table-ref/default table 'z 0)  ; → 0

(hash-table-exists? table 'x)     ; → #t
(hash-table-delete! table 'x)

(hash-table-size table)           ; → 1

(hash-table-keys table)           ; → (y)
(hash-table-values table)         ; → (200)

(hash-table-walk table
  (lambda (key value)
    (display (list key value))
    (newline)))

;; Custom equality and hash
(define str-table
  (make-hash-table string=? string-hash))
SRFI-125: Intermediate Hash Tables
(import (srfi 125))

;; More portable, R7RS-friendly hash tables
(define ht (make-hash-table equal?))

(hash-table-set! ht "key" 'value)
(hash-table-ref ht "key")         ; → value

(hash-table-update! ht "counter" add1 0)
(hash-table-ref ht "counter")     ; → 1

(hash-table→alist ht)
(alist→hash-table '((a . 1) (b . 2)))

Finding and Using SRFIs

Documentation: https://srfi.schemers.org/

Checking Support:

(cond-expand
  ((library (srfi 1))
   (import (srfi 1))
   (display "SRFI-1 available"))
  (else
   (display "SRFI-1 not available")))

7.6 Foreign Function Interface (FFI)

FFI allows Scheme to call C libraries and vice versa.

Why FFI?

  1. Reuse existing C libraries: cryptography, graphics, databases

  2. Performance: Optimize critical sections in C

  3. System access: Low-level OS operations

  4. Legacy integration: Interface with existing systems

General Concepts

Common patterns across Scheme implementations:

  1. Load shared library: .so, .dll, .dylib files

  2. Declare foreign functions: Map C signatures to Scheme

  3. Type conversion: Scheme ↔︎ C type mapping

  4. Memory management: Who owns what?

  5. Callbacks: C calling back into Scheme

Chez Scheme FFI

Chez provides foreign-procedure for C function binding.

Basic FFI Example
(import (chezscheme))

;; Load shared library
(load-shared-object "libc.so.6")  ; Linux
;; (load-shared-object "libc.dylib")  ; macOS
;; (load-shared-object "msvcrt.dll")  ; Windows

;; Declare C function: int strlen(const char* s)
(define c-strlen
  (foreign-procedure "strlen" (string) int))

(c-strlen "Hello")  ; → 5

;; void free(void* ptr)
(define c-free
  (foreign-procedure "free" (void*) void))

;; char* getenv(const char* name)
(define c-getenv
  (foreign-procedure "getenv" (string) string))

(c-getenv "PATH")  ; → "/usr/bin:/bin:…"
Type Mappings
;; Common type specifications:
;; Scheme          C
;; -------         -------
;; int             int (platform-dependent size)
;; unsigned        unsigned int
;; long            long
;; double          double
;; string          char*
;; void*           void*
;; scheme-object   Scheme object (ptr)

;; Example: int abs(int n)
(define c-abs
  (foreign-procedure "abs" (int) int))

(c-abs -42)  ; → 42
Defining C Types
;; Define foreign types with define-ftype
(define-ftype Point
  (struct
    (x double)
    (y double)))

;; Allocate and access
(define pt (make-ftype-pointer Point
             (foreign-alloc (ftype-sizeof Point))))

(ftype-set! Point (x) pt 3.5)
(ftype-set! Point (y) pt 4.2)

(ftype-ref Point (x) pt)  ; → 3.5
(ftype-ref Point (y) pt)  ; → 4.2

(foreign-free (ftype-pointer-address pt))
Calling C Math Library
;; Load math library
(load-shared-object "libm.so.6")

;; double sqrt(double x)
(define c-sqrt
  (foreign-procedure "sqrt" (double) double))

;; double pow(double x, double y)
(define c-pow
  (foreign-procedure "pow" (double double) double))

;; double sin(double x)
(define c-sin
  (foreign-procedure "sin" (double) double))

(c-sqrt 16.0)           ; → 4.0
(c-pow 2.0 10.0)        ; → 1024.0
(c-sin 0.0)             ; → 0.0
Complete Example: File Operations
(load-shared-object "libc.so.6")

;; FILE* fopen(const char* filename, const char* mode)
(define-ftype FILE void*)
(define fopen
  (foreign-procedure "fopen" (string string) FILE))

;; int fclose(FILE* stream)
(define fclose
  (foreign-procedure "fclose" (FILE) int))

;; size_t fread(void* ptr, size_t size, size_t nmemb, FILE* stream)
(define fread
  (foreign-procedure "fread" (void* size_t size_t FILE) size_t))

;; Usage
(define fp (fopen "test.txt" "r"))
(if (ftype-pointer-null? fp)
    (error "Cannot open file")
    (begin
      ;; Read operations here
      (fclose fp)))

Guile FFI

Guile uses the dynamic-link system.

(use-modules (system foreign))

;; Load library
(define libc (dynamic-link))  ; C library
;; (define libm (dynamic-link "libm"))  ; Math library

;; Get function pointer
(define strlen-ptr
  (dynamic-func "strlen" libc))

;; Create Scheme wrapper
(define c-strlen
  (pointer→procedure int      ; Return type
                      strlen-ptr
                      (list '*))) ; Argument types

;; Convert string to C string and call
(define (my-strlen str)
  (c-strlen (string→pointer str)))

(my-strlen "Hello")  ; → 5
Type System
;; Guile FFI types:
;; int, unsigned-int, long, unsigned-long
;; int8, uint8, int16, uint16, int32, uint32, int64, uint64
;; float, double
;; '*  (pointer)
;; void

;; Example: sqrt
(define sqrt-ptr (dynamic-func "sqrt" (dynamic-link "libm")))
(define c-sqrt
  (pointer→procedure double sqrt-ptr (list double)))

(c-sqrt 16.0)  ; → 4.0
Memory Management
(use-modules (system foreign))

;; Allocate memory
(define ptr (bytevector→pointer (make-bytevector 100)))

;; Dereference pointers
(define (deref-int ptr)
  (pointer-ref-int ptr 0))

;; Set value
(pointer-set-int! ptr 0 42)
(deref-int ptr)  ; → 42

Chicken Scheme FFI

Chicken has extensive FFI support.

(use lolevel)

;; Define foreign function
(define c-strlen
  (foreign-lambda int "strlen" c-string))

(c-strlen "Hello")  ; → 5

;; With types
(define c-sqrt
  (foreign-lambda double "sqrt" double))

(c-sqrt 16.0)  ; → 4.0
Foreign Types
;; Common types:
;; int, unsigned-int, long, unsigned-long
;; float, double
;; c-string, c-string*
;; scheme-object
;; c-pointer, (c-pointer TYPE)

;; Example: malloc/free
(define c-malloc
  (foreign-lambda c-pointer "malloc" size_t))

(define c-free
  (foreign-lambda void "free" c-pointer))

(define ptr (c-malloc 100))
(c-free ptr)
Foreign Code Embedding
;; Embed C code directly
(foreign-declare "
#include <math.h>
#include <stdio.h>
")

(define c-hypot
  (foreign-lambda double "hypot" double double))

(c-hypot 3.0 4.0)  ; → 5.0

Racket FFI

Racket’s FFI is comprehensive and safe.

#lang racket
(require ffi/unsafe)

;; Get C library
(define libc
  (case (system-type 'os)
    [(unix) (ffi-lib "libc" '("6"))]
    [(macosx) (ffi-lib "libc")]
    [(windows) (ffi-lib "msvcrt")]))

;; Define function
(define strlen
  (get-ffi-obj "strlen" libc
    (_fun _string → _int)))

(strlen "Hello")  ; → 5
Type System
(require ffi/unsafe)

;; Types:
;; _int, _uint, _long, _ulong
;; _double, _float
;; _string, _bytes
;; _pointer, _void
;; _bool

;; Example: abs
(define c-abs
  (get-ffi-obj "abs" libc
    (_fun _int → _int)))

(c-abs -42)  ; → 42
Structures
(require ffi/unsafe)

;; Define C struct
(define-cstruct _point
  ([x _double]
   [y _double]))

;; Create instance
(define pt (make-point 3.5 4.2))

;; Access fields
(point-x pt)  ; → 3.5
(point-y pt)  ; → 4.2

;; Modify
(set-point-x! pt 10.0)

Common FFI Patterns

Error Handling
;; Check for NULL pointers
(define fp (fopen "test.txt" "r"))
(when (null-pointer? fp)
  (error "Failed to open file"))

;; Check return values
(define result (some-c-function))
(when (< result 0)
  (error "Function failed with code" result))
String Conversion
;; Most FFIs handle this automatically, but manually:

;; Chez
(let* ((str "Hello")
       (result (c-strlen str)))
  result)

;; Guile - explicit conversion
(let* ((c-str (string→pointer "Hello"))
       (result (c-strlen c-str)))
  result)
Memory Management
;; Pattern 1: Stack allocation (automatic)
(let ((buffer (make-bytevector 100)))
  ;; Use buffer
  ;; Automatically freed when out of scope
  …)

;; Pattern 2: Heap allocation (manual)
(define ptr (c-malloc 100))
;; Use ptr
(c-free ptr)  ; Must free!

;; Pattern 3: With cleanup
(define (with-c-memory size proc)
  (let ((ptr (c-malloc size)))
    (dynamic-wind
      (lambda () #f)
      (lambda () (proc ptr))
      (lambda () (c-free ptr)))))

(with-c-memory 100
  (lambda (ptr)
    ;; Use ptr
    …))

Practical Example: SQLite Binding

Here’s a simplified SQLite FFI wrapper:

;; Chez Scheme version
(import (chezscheme))

(load-shared-object "libsqlite3.so")

;; Types
(define-ftype sqlite3 void*)
(define-ftype sqlite3-stmt void*)

;; Functions
(define sqlite3-open
  (foreign-procedure "sqlite3_open"
    (string void*) int))

(define sqlite3-close
  (foreign-procedure "sqlite3_close"
    (sqlite3) int))

(define sqlite3-prepare-v2
  (foreign-procedure "sqlite3_prepare_v2"
    (sqlite3 string int void* void*) int))

(define sqlite3-step
  (foreign-procedure "sqlite3_step"
    (sqlite3-stmt) int))

(define sqlite3-column-int
  (foreign-procedure "sqlite3_column_int"
    (sqlite3-stmt int) int))

(define sqlite3-column-text
  (foreign-procedure "sqlite3_column_text"
    (sqlite3-stmt int) string))

(define sqlite3-finalize
  (foreign-procedure "sqlite3_finalize"
    (sqlite3-stmt) int))

;; High-level wrapper
(define (with-database filename proc)
  (let ((db-ptr (foreign-alloc (foreign-sizeof 'void*))))
    (if (zero? (sqlite3-open filename db-ptr))
        (let ((db (foreign-ref 'void* db-ptr 0)))
          (dynamic-wind
            (lambda () #f)
            (lambda () (proc db))
            (lambda ()
              (sqlite3-close db)
              (foreign-free db-ptr))))
        (error "Cannot open database"))))

;; Usage
(with-database "test.db"
  (lambda (db)
    ;; Execute queries
    …))

FFI Best Practices

  1. Check return values: Most C functions indicate errors via return codes

  2. Manage memory carefully: Know who allocates and who frees

  3. Handle NULL pointers: Check before dereferencing

  4. Use wrappers: Create safe Scheme wrappers around raw FFI calls

  5. Test thoroughly: FFI bugs can crash the entire process

  6. Document types: Clearly specify C types and conversion rules

  7. Consider portability: Different platforms have different ABIs

FFI Safety Considerations

Memory Safety:

;; BAD - dangling pointer
(define (get-buffer)
  (let ((buf (c-malloc 100)))
    buf))  ; Buffer leaked!

;; GOOD - proper cleanup
(define (with-buffer proc)
  (let ((buf (c-malloc 100)))
    (dynamic-wind
      (lambda () #f)
      (lambda () (proc buf))
      (lambda () (c-free buf)))))

Type Safety:

;; BAD - wrong type
(define strlen (foreign-procedure "strlen" (int) int))
;; Will crash or corrupt memory!

;; GOOD - correct type
(define strlen (foreign-procedure "strlen" (string) int))

7.7 Package Managers

Chicken Scheme: Eggs

Chicken has a package manager called eggs:

# Install an egg
$ chicken-install srfi-1

# Search for eggs
$ chicken-install -show srfi-1

# List installed eggs
$ chicken-status

Using eggs in code:

(use srfi-1)  ; After installation
(use regex)
(use sql-de-lite)  ; SQLite bindings

Guile: Guix

GNU Guix is a package manager that includes Guile packages:

# Install a Guile package
$ guix install guile-json

# Use it
$ guile
> (use-modules (json))

Racket: raco pkg

Racket uses raco pkg:

# Install package
$ raco pkg install package-name

# Search packages
$ raco pkg search json

# Update all packages
$ raco pkg update --all

Akku (R6RS/R7RS)

Akku is a universal package manager for Scheme:

# Install Akku
$ curl -AO https://akku.io/install.sh | bash

# Install packages
$ akku install (srfi :1)

# Add to project
$ akku list
$ akku update

7.8 Building and Distributing Libraries

Creating a Portable R7RS Library

Directory structure: my-library/ ├── my-library.sld # Library definition ├── my-library/ │ ├── core.sld │ └── utils.sld ├── tests/ │ └── test-all.scm └── README.md

Main library (my-library.sld):

(define-library (my-library)
  (export
    main-function
    helper-1
    helper-2)
  
  (import (scheme base)
          (my-library core)
          (my-library utils))
  
  (begin
    (define (main-function x)
      (helper-1 (helper-2 x)))))

Sub-library (my-library/core.sld):

(define-library (my-library core)
  (export core-function)
  (import (scheme base))
  
  (begin
    (define (core-function x)
      (* x 2))))

Documentation

README.md:

# My Library

## Installation

### R7RS Scheme
Add to your load path and import:
```scheme
(import (my-library))

### Chicken Scheme
bash
chicken-install my-library

## Usage

scheme
(import (my-library))
(main-function 42)

## API

### `(main-function x)`
Does something with x.

## License
MIT License


### Testing Framework

```scheme
;; tests/test-all.scm
(import (scheme base)
        (scheme write)
        (my-library))

(define (assert-equal expected actual message)
  (if (equal? expected actual)
      (display (string-append "PASS: " message "\n"))
      (begin
        (display (string-append "FAIL: " message "\n"))
        (display "  Expected: ")
        (write expected)
        (newline)
        (display "  Got: ")
        (write actual)
        (newline))))

;; Tests
(assert-equal 10 (main-function 5) "main-function test 1")
(assert-equal 20 (main-function 10) "main-function test 2")

Build Scripts

For Chicken:

;; my-library.setup
(use make)

(make (("my-library.so" ("my-library.scm")
        (compile -s -O2 my-library.scm))
       ("my-library.import.so" ("my-library.import.scm")
        (compile -s my-library.import.scm)))
  '("my-library.so"))

Version Control

.gitignore:

*.o

*.so

*.import.scm .akku/

Summary

This chapter covered Scheme’s module and library systems:

  1. R7RS Libraries: Modern, portable library system

  2. R6RS Libraries: Comprehensive with versioning

  3. Implementation-specific: Chez, Chicken, Guile, Racket

  4. SRFIs: Community extensions for portability

  5. FFI: Interfacing with C libraries across implementations

  6. Package Management: Distribution and installation

  7. Best Practices: Organization, documentation, testing

Key Takeaways:

  • Use R7RS for maximum portability

  • SRFIs provide standard extensions

  • FFI enables C library integration

  • Each implementation has unique strengths

  • Proper structure aids maintainability

Exercises

  1. Module Creation: Create an R7RS library for matrix operations.

  2. SRFI Usage: Use SRFI-1 and SRFI-13 to build a text processing library.

  3. FFI Binding: Create Scheme bindings for a C library (e.g., zlib compression).

  4. Cross-Implementation: Write a library that works on Chez, Guile, and Chicken.

  5. Package: Create an installable package with documentation and tests.

  6. Conditional Features: Use cond-expand to support multiple Scheme implementations.

  7. Record Types: Implement a JSON serializer using SRFI-9 records.

  8. Hash Tables: Build a simple in-memory database using SRFI-69 or SRFI-125.

  9. C Integration: Call SQLite functions via FFI and create a high-level query interface.

  10. Library Composition: Build a web framework by combining HTTP, string, and hash table libraries.

Next chapter: Chapter 8: Input/Output and Ports - File I/O, string ports, network I/O, and custom ports.

Chapter 8: Input/Output and Ports

8.1 Introduction to I/O in Scheme

Ports are Scheme’s abstraction for input and output streams. They provide a uniform interface for reading from and writing to various sources: files, strings, network connections, or custom sources.

The Port Abstraction

A port is an object that:

  • Represents a stream of data

  • Can be an input port (reading) or output port (writing)

  • May be textual (characters) or binary (bytes)

  • Maintains internal state (current position, buffering, etc.)

Why Ports Matter

  1. Uniform Interface: Same operations work on files, strings, network sockets

  2. Composability: Connect different I/O sources/sinks

  3. Abstraction: Hide implementation details

  4. Flexibility: Easy to redirect I/O for testing or logging

8.2 Standard Ports

Every Scheme program has three standard ports available by default.

The Three Standard Ports

;; Current input port (typically keyboard/stdin)
(current-input-port)

;; Current output port (typically console/stdout)
(current-output-port)

;; Current error port (typically console/stderr)
(current-error-port)

Using Standard Ports

;; These use the current output port
(display "Hello, world!")
(newline)
(write '(1 2 3))

;; Explicitly specify the port
(display "Hello, world!" (current-output-port))
(newline (current-output-port))

;; Write to error port
(display "Error: something went wrong" (current-error-port))
(newline (current-error-port))

Reading from Standard Input

;; Read a single character
(define ch (read-char))

;; Read a Scheme expression
(define expr (read))

;; Read a line of text
(define line (read-line))  ; R7RS

Example: Simple REPL

(define (simple-repl)
  (display "scheme> ")
  (let ((input (read)))
    (if (eof-object? input)
        (begin
          (newline)
          (display "Goodbye!")
          (newline))
        (begin
          (write (eval input))
          (newline)
          (simple-repl)))))

;; Usage:
;; (simple-repl)
;; scheme> (+ 1 2)
;; 3
;; scheme> (define x 10)
;; scheme> (* x 5)
;; 50

8.3 File I/O

Opening and Closing Files

;; Open file for reading (returns input port)
(define in-port (open-input-file "data.txt"))

;; Open file for writing (returns output port)
(define out-port (open-output-file "output.txt"))

;; Close ports when done
(close-input-port in-port)
(close-output-port out-port)

;; Generic close (works for any port)
(close-port in-port)

Reading from Files

;; Read entire file as string
(define (read-file filename)
  (call-with-input-file filename
    (lambda (port)
      (let loop ((chars '()))
        (let ((ch (read-char port)))
          (if (eof-object? ch)
              (list→string (reverse chars))
              (loop (cons ch chars))))))))

;; Better version using read-string (R7RS)
(define (read-file filename)
  (call-with-input-file filename
    (lambda (port)
      (read-string 1000000 port))))  ; Read up to 1MB

;; Read file line by line
(define (read-lines filename)
  (call-with-input-file filename
    (lambda (port)
      (let loop ((lines '()))
        (let ((line (read-line port)))
          (if (eof-object? line)
              (reverse lines)
              (loop (cons line lines))))))))

;; Example usage:
;; (define contents (read-file "data.txt"))
;; (define all-lines (read-lines "data.txt"))

Writing to Files

;; Write string to file
(define (write-to-file filename content)
  (call-with-output-file filename
    (lambda (port)
      (display content port))))

;; Write lines to file
(define (write-lines filename lines)
  (call-with-output-file filename
    (lambda (port)
      (for-each (lambda (line)
                  (display line port)
                  (newline port))
                lines))))

;; Append to file
(define (append-to-file filename content)
  (let ((port (open-output-file filename)))
    ;; Note: Standard doesn't have append mode
    ;; Implementation-specific
    (display content port)
    (close-output-port port)))

;; Example usage:
;; (write-to-file "output.txt" "Hello, world!")
;; (write-lines "lines.txt" '("Line 1" "Line 2" "Line 3"))

The call-with-* Pattern

These procedures ensure ports are closed even if errors occur:

;; call-with-input-file automatically closes the port
(call-with-input-file "data.txt"
  (lambda (port)
    ;; Do something with port
    (read port)))

;; Even if an error occurs, port is closed
(call-with-input-file "data.txt"
  (lambda (port)
    (error "Something went wrong!")
    ;; Port is still closed properly
    ))

;; Equivalent manual version
(define in (open-input-file "data.txt"))
(let ((result (read in)))
  (close-input-port in)
  result)

File Existence and Deletion

;; Check if file exists (R7RS)
(file-exists? "data.txt")  ; → #t or #f

;; Delete file (R7RS)
(delete-file "temp.txt")

;; Safe deletion
(define (safe-delete filename)
  (when (file-exists? filename)
    (delete-file filename)))

Practical Example: CSV Reader

(define (string-split str delimiter)
  (let loop ((chars (string→list str))
             (current '())
             (result '()))
    (cond
      ((null? chars)
       (reverse (cons (list→string (reverse current)) result)))
      ((char=? (car chars) delimiter)
       (loop (cdr chars) '() (cons (list→string (reverse current)) result)))
      (else
       (loop (cdr chars) (cons (car chars) current) result)))))

(define (read-csv filename)
  (call-with-input-file filename
    (lambda (port)
      (let loop ((rows '()))
        (let ((line (read-line port)))
          (if (eof-object? line)
              (reverse rows)
              (loop (cons (string-split line #\,) rows))))))))

;; Usage:
;; (read-csv "data.csv")
;; → (("Name" "Age" "City")
;;    ("Alice" "30" "Boston")
;;    ("Bob" "25" "Seattle"))

Practical Example: Configuration File

;; Read configuration file (key=value pairs)
(define (read-config filename)
  (call-with-input-file filename
    (lambda (port)
      (let loop ((config '()))
        (let ((line (read-line port)))
          (if (eof-object? line)
              config
              (let ((parts (string-split line #\=)))
                (if (= (length parts) 2)
                    (loop (cons (cons (car parts) (cadr parts)) config))
                    (loop config)))))))))

;; Write configuration file
(define (write-config filename config)
  (call-with-output-file filename
    (lambda (port)
      (for-each (lambda (pair)
                  (display (car pair) port)
                  (display "=" port)
                  (display (cdr pair) port)
                  (newline port))
                config))))

;; Usage:
;; (define config (read-config "app.conf"))
;; (write-config "app.conf" '(("host" . "localhost") ("port" . "8080")))

8.4 String Ports

String ports allow you to read from and write to strings as if they were files.

Output String Ports

;; Create output string port
(define out (open-output-string))

;; Write to it
(display "Hello, " out)
(write 'world out)
(display "!" out)

;; Get accumulated string
(get-output-string out)  ; → "Hello, world!"

;; Port can be reused
(display " More text." out)
(get-output-string out)  ; → "Hello, world! More text."

Practical Use: Building Strings

(define (build-html-list items)
  (let ((out (open-output-string)))
    (display "<ul>" out)
    (newline out)
    (for-each (lambda (item)
                (display "  <li>" out)
                (display item out)
                (display "</li>" out)
                (newline out))
              items)
    (display "</ul>" out)
    (get-output-string out)))

;; Usage:
;; (build-html-list '("Apple" "Banana" "Cherry"))
;; → "<ul>
;;      <li>Apple</li>
;;      <li>Banana</li>
;;      <li>Cherry</li>
;;    </ul>"

Input String Ports

;; Create input string port
(define in (open-input-string "42 hello (1 2 3)"))

;; Read from it
(read in)       ; → 42
(read in)       ; → hello
(read in)       ; → (1 2 3)
(read in)       ; → #<eof>

;; Another example
(define in2 (open-input-string "apple\nbanana\ncherry"))
(read-line in2) ; → "apple"
(read-line in2) ; → "banana"
(read-line in2) ; → "cherry"

Parsing with String Ports

(define (parse-numbers str)
  (let ((in (open-input-string str)))
    (let loop ((numbers '()))
      (let ((num (read in)))
        (if (eof-object? num)
            (reverse numbers)
            (loop (cons num numbers)))))))

;; Usage:
;; (parse-numbers "1 2 3 4 5")  ; → (1 2 3 4 5)

String Port Example: JSON-like Output

(define (object→json obj)
  (let ((out (open-output-string)))
    (define (write-json val)
      (cond
        ((number? val) (display val out))
        ((string? val)
         (display "\"" out)
         (display val out)
         (display "\"" out))
        ((boolean? val)
         (display (if val "true" "false") out))
        ((null? val)
         (display "[]" out))
        ((pair? val)
         (display "[" out)
         (let loop ((items val))
           (write-json (car items))
           (if (pair? (cdr items))
               (begin
                 (display "," out)
                 (loop (cdr items)))))
         (display "]" out))
        (else (display "null" out))))
    (write-json obj)
    (get-output-string out)))

;; Usage:
;; (object→json '(1 "hello" #t (2 3)))
;; → "[1,\"hello\",true,[2,3]]"

8.5 Binary I/O

Binary ports handle raw bytes instead of characters.

Binary File I/O

;; Open binary files
(define bin-in (open-binary-input-file "image.png"))
(define bin-out (open-binary-output-file "copy.png"))

;; Read bytes
(read-u8 bin-in)           ; Read single byte (0-255)
(read-bytevector 1024 bin-in)  ; Read up to 1024 bytes

;; Write bytes
(write-u8 65 bin-out)      ; Write byte value 65
(write-bytevector #u8(72 101 108 108 111) bin-out)  ; Write bytevector

;; Close
(close-port bin-in)
(close-port bin-out)

Bytevectors

;; Create bytevector
(define bv (make-bytevector 10 0))  ; 10 bytes, all zero

;; Literal bytevector
(define bv2 #u8(1 2 3 4 5))

;; Access elements
(bytevector-u8-ref bv2 0)   ; → 1
(bytevector-u8-ref bv2 2)   ; → 3

;; Modify
(bytevector-u8-set! bv 0 255)

;; Length
(bytevector-length bv)      ; → 10

;; Copy
(bytevector-copy bv2)

Binary File Copy

(define (copy-binary-file src dest)
  (call-with-port (open-binary-input-file src)
    (lambda (in)
      (call-with-port (open-binary-output-file dest)
        (lambda (out)
          (let ((buffer (make-bytevector 4096)))
            (let loop ()
              (let ((n (read-bytevector! buffer in)))
                (unless (eof-object? n)
                  (write-bytevector buffer out 0 n)
                  (loop))))))))))

;; Usage:
;; (copy-binary-file "input.bin" "output.bin")

Reading Binary Formats

;; Read 32-bit integer (little-endian)
(define (read-u32-le port)
  (let ((b0 (read-u8 port))
        (b1 (read-u8 port))
        (b2 (read-u8 port))
        (b3 (read-u8 port)))
    (+ b0
       (* b1 256)
       (* b2 65536)
       (* b3 16777216))))

;; Read 16-bit integer (big-endian)
(define (read-u16-be port)
  (let ((b0 (read-u8 port))
        (b1 (read-u8 port)))
    (+ (* b0 256) b1)))

;; Write 32-bit integer (little-endian)
(define (write-u32-le n port)
  (write-u8 (modulo n 256) port)
  (write-u8 (modulo (quotient n 256) 256) port)
  (write-u8 (modulo (quotient n 65536) 256) port)
  (write-u8 (modulo (quotient n 16777216) 256) port))

Example: BMP Header Parser

;; Simplified BMP header reader
(define (read-bmp-header filename)
  (call-with-port (open-binary-input-file filename)
    (lambda (port)
      ;; Read "BM" signature
      (define sig1 (read-u8 port))
      (define sig2 (read-u8 port))
      
      (if (and (= sig1 66) (= sig2 77))  ; 'B' and 'M'
          (begin
            ;; File size
            (define file-size (read-u32-le port))
            ;; Reserved
            (read-u32-le port)
            ;; Data offset
            (define data-offset (read-u32-le port))
            ;; Header size
            (define header-size (read-u32-le port))
            ;; Width and height
            (define width (read-u32-le port))
            (define height (read-u32-le port))
            
            (list (cons 'file-size file-size)
                  (cons 'width width)
                  (cons 'height height)
                  (cons 'data-offset data-offset)))
          (error "Not a valid BMP file")))))

;; Usage:
;; (read-bmp-header "image.bmp")
;; → ((file-size . 154542) (width . 640) (height . 480) …)

8.6 Port Predicates and Properties

Testing Port Types

;; Check if something is a port
(port? (current-input-port))   ; → #t
(port? "not a port")            ; → #f

;; Check port direction
(input-port? (current-input-port))    ; → #t
(output-port? (current-output-port))  ; → #t

;; Check if port is open
(input-port-open? port)
(output-port-open? port)

;; Check port encoding
(textual-port? (current-input-port))  ; → #t
(binary-port? (open-binary-input-file "data.bin"))  ; → #t

Port Position

;; Get current position (R7RS, implementation-dependent)
(define pos (port-position port))

;; Set position (seeking)
(set-port-position! port pos)

;; Example: Read file backwards
(define (read-file-backwards filename)
  (call-with-port (open-binary-input-file filename)
    (lambda (port)
      (let* ((end-pos (port-position port))
             (file-size end-pos))
        (let loop ((pos (- file-size 1))
                   (chars '()))
          (if (< pos 0)
              (list→string chars)
              (begin
                (set-port-position! port pos)
                (loop (- pos 1)
                      (cons (integer→char (read-u8 port)) chars)))))))))

8.7 Custom Ports

Some Scheme implementations allow creating custom ports.

Custom Input Port (Conceptual)

;; Implementation-specific example (Chez Scheme style)
(define (make-counter-port max)
  (let ((count 0))
    (make-custom-textual-input-port
      "counter"
      (lambda (str start end)  ; read! procedure
        (if (≥ count max)
            0  ; EOF
            (let ((ch (integer→char (+ 48 count))))
              (string-set! str start ch)
              (set! count (+ count 1))
              1)))  ; 1 character read
      #f  ; get-position
      #f  ; set-position!
      #f))) ; close

;; Usage would create a port that produces "0123456789"

Custom Output Port (Logging Example)

;; Conceptual example
(define (make-logging-port original-port log-file)
  (let ((log (open-output-file log-file)))
    (make-custom-textual-output-port
      "logging-port"
      (lambda (str start end)  ; write! procedure
        (let ((text (substring str start end)))
          ;; Write to original port
          (display text original-port)
          ;; Also log it
          (display text log)
          (flush-output-port log)
          (- end start)))  ; bytes written
      #f  ; get-position
      #f  ; set-position!
      (lambda ()  ; close
        (close-port log)))))

8.8 Buffering and Flushing

Output Buffering

;; Force output to be written
(flush-output-port)
(flush-output-port (current-output-port))

;; Example: Progress indicator
(define (show-progress n total)
  (display (string-append "Processing: "
                          (number→string n)
                          "/"
                          (number→string total)
                          "\r"))
  (flush-output-port))  ; Ensure it displays immediately

;; Usage:
;; (for-each (lambda (i)
;;             (show-progress i 100)
;;             (do-work i))
;;           (iota 100))

8.9 Character Encoding

Understanding Encodings

;; Most modern Schemes use UTF-8 by default
;; Some allow specifying encoding

;; Reading with specific encoding (implementation-specific)
;; Chez Scheme example:
(open-input-file "data.txt" 'utf-8)
(open-input-file "legacy.txt" 'latin-1)

;; Guile example:
(set-port-encoding! port "UTF-8")
(set-port-encoding! port "ISO-8859-1")

Handling Different Encodings

;; Read file, convert encoding (conceptual)
(define (convert-file-encoding in-file out-file from-enc to-enc)
  ;; Implementation would use iconv or similar
  ;; This is simplified
  (let ((content (call-with-input-file in-file
                   (lambda (port)
                     ;; Set encoding
                     (read-string 1000000 port)))))
    (call-with-output-file out-file
      (lambda (port)
        ;; Set output encoding
        (display content port)))))

8.10 Practical Examples

Example 1: Log File Analyzer

(define (analyze-log-file filename)
  (call-with-input-file filename
    (lambda (port)
      (let loop ((line (read-line port))
                 (errors 0)
                 (warnings 0)
                 (info 0))
        (if (eof-object? line)
            (list (cons 'errors errors)
                  (cons 'warnings warnings)
                  (cons 'info info))
            (loop (read-line port)
                  (if (string-contains line "ERROR") (+ errors 1) errors)
                  (if (string-contains line "WARN") (+ warnings 1) warnings)
                  (if (string-contains line "INFO") (+ info 1) info)))))))

;; Helper
(define (string-contains str substr)
  (let ((str-len (string-length str))
        (sub-len (string-length substr)))
    (let loop ((i 0))
      (cond
        ((> (+ i sub-len) str-len) #f)
        ((string=? (substring str i (+ i sub-len)) substr) #t)
        (else (loop (+ i 1)))))))

;; Usage:
;; (analyze-log-file "application.log")
;; → ((errors . 5) (warnings . 23) (info . 142))

Example 2: Simple Template Engine

(define (render-template template-file data-alist)
  (call-with-input-file template-file
    (lambda (in)
      (let ((out (open-output-string)))
        (let loop ()
          (let ((line (read-line in)))
            (unless (eof-object? line)
              (display (substitute-vars line data-alist) out)
              (newline out)
              (loop))))
        (get-output-string out)))))

(define (substitute-vars str alist)
  ;; Replace {{key}} with value from alist
  (let loop ((chars (string→list str))
             (result '())
             (in-var #f)
             (var-chars '()))
    (cond
      ((null? chars)
       (list→string (reverse result)))
      ((and (not in-var) (char=? (car chars) #\{)
            (pair? (cdr chars)) (char=? (cadr chars) #\{))
       (loop (cddr chars) result #t '()))
      ((and in-var (char=? (car chars) #\})
            (pair? (cdr chars)) (char=? (cadr chars) #\}))
       (let* ((var-name (list→string (reverse var-chars)))
              (value (assoc var-name alist)))
         (loop (cddr chars)
               (append (reverse (string→list (if value (cdr value) ""))) result)
               #f
               '())))
      (in-var
       (loop (cdr chars) result #t (cons (car chars) var-chars)))
      (else
       (loop (cdr chars) (cons (car chars) result) #f '())))))

;; Usage:
;; Template file: "Hello, {{name}}! You are {{age}} years old."
;; (render-template "template.txt" '(("name" . "Alice") ("age" . "30")))
;; → "Hello, Alice! You are 30 years old."

Example 3: Database-like CSV Operations

;; Read CSV into list of alists (records)
(define (csv→records filename)
  (let ((rows (read-csv filename)))
    (if (null? rows)
        '()
        (let ((headers (car rows)))
          (map (lambda (row)
                 (map cons headers row))
               (cdr rows))))))

;; Filter records
(define (filter-records predicate records)
  (filter predicate records))

;; Project fields
(define (project-fields fields records)
  (map (lambda (record)
         (filter (lambda (pair)
                   (member (car pair) fields))
                 record))
       records))

;; Write records back to CSV
(define (records→csv filename records)
  (when (not (null? records))
    (let ((headers (map car (car records))))
      (call-with-output-file filename
        (lambda (port)
          ;; Write header
          (display (string-join headers ",") port)
          (newline port)
          ;; Write rows
          (for-each (lambda (record)
                      (display (string-join (map cdr record) ",") port)
                      (newline port))
                    records))))))

;; Helper: string-join
(define (string-join strings delimiter)
  (if (null? strings)
      ""
      (let loop ((rest (cdr strings))
                 (result (car strings)))
        (if (null? rest)
            result
            (loop (cdr rest)
                  (string-append result delimiter (car rest)))))))

;; Usage:
;; (define records (csv→records "employees.csv"))
;; (define seniors (filter-records
;;                   (lambda (r)
;;                     (> (string→number (cdr (assoc "age" r))) 50))
;;                   records))
;; (records→csv "seniors.csv" seniors)

Example 4: Simple Serialization

;; Serialize Scheme data to file
(define (serialize-to-file obj filename)
  (call-with-output-file filename
    (lambda (port)
      (write obj port))))

;; Deserialize from file
(define (deserialize-from-file filename)
  (call-with-input-file filename
    (lambda (port)
      (read port))))

;; Usage:
;; (define my-data '((name . "Alice") (scores . (95 87 92))))
;; (serialize-to-file my-data "data.scm")
;; (define loaded (deserialize-from-file "data.scm"))

Example 5: Line-by-Line File Processing

(define (process-file-lines input-file output-file processor)
  (call-with-input-file input-file
    (lambda (in)
      (call-with-output-file output-file
        (lambda (out)
          (let loop ()
            (let ((line (read-line in)))
              (unless (eof-object? line)
                (display (processor line) out)
                (newline out)
                (loop)))))))))

;; Example: Convert to uppercase
(define (string-upcase str)
  (list→string (map char-upcase (string→list str))))

;; Usage:
;; (process-file-lines "input.txt" "output.txt" string-upcase)

;; Example: Add line numbers
(define (add-line-numbers input-file output-file)
  (call-with-input-file input-file
    (lambda (in)
      (call-with-output-file output-file
        (lambda (out)
          (let loop ((n 1))
            (let ((line (read-line in)))
              (unless (eof-object? line)
                (display (string-append (number→string n) ": " line) out)
                (newline out)
                (loop (+ n 1))))))))))

8.11 Error Handling with I/O

Safe File Operations

(define (safe-read-file filename default)
  (if (file-exists? filename)
      (guard (ex
              (else
               (display "Error reading file: ")
               (display (error-object-message ex))
               (newline)
               default))
        (call-with-input-file filename
          (lambda (port)
            (read-string 1000000 port))))
      default))

;; Usage:
;; (safe-read-file "config.txt" "default config")

Transaction-like File Writing

(define (atomic-write-file filename content)
  (let ((temp-file (string-append filename ".tmp")))
    ;; Write to temp file
    (call-with-output-file temp-file
      (lambda (port)
        (display content port)))
    ;; Rename to actual file (atomic on Unix)
    (rename-file temp-file filename)))

;; Helper (implementation-specific)
(define (rename-file old new)
  ;; This would use system-specific rename/move
  ;; For portability, might need FFI
  (delete-file new)  ; If exists
  ;; … actual rename operation
  )

8.12 Performance Considerations

Buffering Strategies

;; Small reads are slow
(define (slow-file-copy src dest)
  (call-with-input-file src
    (lambda (in)
      (call-with-output-file dest
        (lambda (out)
          (let loop ()
            (let ((ch (read-char in)))
              (unless (eof-object? ch)
                (write-char ch out)
                (loop)))))))))

;; Buffered reads are much faster
(define (fast-file-copy src dest)
  (call-with-input-file src
    (lambda (in)
      (call-with-output-file dest
        (lambda (out)
          (let ((buffer (make-string 4096)))
            (let loop ()
              (let ((n (read-string! buffer in)))
                (unless (eof-object? n)
                  (write-string buffer out 0 n)
                  (loop))))))))))

Memory-Efficient Processing

;; BAD: Reads entire file into memory
(define (count-words-bad filename)
  (let ((content (read-file filename)))
    (length (string-split content #\space))))

;; GOOD: Processes line by line
(define (count-words-good filename)
  (call-with-input-file filename
    (lambda (port)
      (let loop ((total 0))
        (let ((line (read-line port)))
          (if (eof-object? line)
              total
              (loop (+ total (length (string-split line #\space))))))))))

Summary

This chapter covered Scheme’s I/O system:

  1. Standard Ports: Input, output, and error streams

  2. File I/O: Reading and writing files safely

  3. String Ports: In-memory string-based I/O

  4. Binary I/O: Raw byte operations

  5. Port Properties: Testing and manipulating ports

  6. Custom Ports: Creating specialized I/O streams

  7. Buffering: Performance optimization

  8. Practical Examples: Real-world I/O patterns

Key Principles:

  • Always close ports (use call-with-* for safety)

  • Buffer large I/O operations

  • Handle EOF properly

  • Consider encodings for text

  • Use appropriate port type (text vs. binary)

Exercises

  1. File Statistics: Count lines, words, and characters in a text file.

  2. Grep Clone: Search for pattern in files and print matching lines.

  3. File Merger: Merge multiple files while removing duplicates.

  4. Binary Editor: Read/write/modify bytes in a binary file.

  5. Log Rotation: Implement log rotation (split large files).

  6. CSV to JSON: Convert CSV files to JSON format.

  7. Diff Tool: Compare two files and show differences.

  8. Tail Command: Implement Unix tail -f (follow growing file).

  9. Compression: Implement simple run-length encoding.

  10. Serialization: Create a save/load system for game state.

Next chapter: Chapter 9: Error Handling and Exceptions - Exception systems, error objects, guards, and defensive programming in Scheme.

Chapter 9: Error Handling and Exceptions

9.1 Introduction to Error Handling

Error handling is concerned with managing exceptional situations that prevent normal program execution. Scheme provides both traditional error signaling and modern exception handling mechanisms.

Why Error Handling Matters

;; Without error handling - program crashes
(define (divide a b)
  (/ a b))

(divide 10 0)  ; Error! Division by zero - program terminates

;; With error handling - graceful recovery
(define (safe-divide a b)
  (if (zero? b)
      (error "Cannot divide by zero")
      (/ a b)))

;; Or return a default
(define (safe-divide-default a b default)
  (if (zero? b)
      default
      (/ a b)))

(safe-divide-default 10 0 'infinity)  ; → infinity

Categories of Errors

  1. Programming Errors: Bugs that should be fixed (wrong types, logic errors)

  2. Runtime Errors: Predictable failures (file not found, network timeout)

  3. Resource Errors: System limitations (out of memory, disk full)

  4. User Errors: Invalid input from users

9.2 The error Procedure

The basic error signaling mechanism in Scheme.

Basic Usage

;; Signal an error with a message
(error "Something went wrong")

;; Include irritants (values that caused the error)
(error "Invalid age" -5)

;; Multiple irritants
(error "Invalid range" start-value end-value)

Creating Informative Errors

(define (withdraw account amount)
  (cond
    ((< amount 0)
     (error "withdraw: amount must be positive" amount))
    ((> amount (account-balance account))
     (error "withdraw: insufficient funds"
            amount
            (account-balance account)))
    (else
     (set-account-balance! account
                           (- (account-balance account) amount)))))

;; Usage:
;; (withdraw my-account -100)
;; Error: withdraw: amount must be positive -100

;; (withdraw my-account 1000000)
;; Error: withdraw: insufficient funds 1000000 500

Domain-Specific Error Messages

(define (factorial n)
  (cond
    ((not (integer? n))
     (error "factorial: argument must be an integer" n))
    ((negative? n)
     (error "factorial: argument must be non-negative" n))
    ((zero? n) 1)
    (else (* n (factorial (- n 1))))))

(define (list-ref-safe lst index)
  (cond
    ((not (list? lst))
     (error "list-ref-safe: first argument must be a list" lst))
    ((not (integer? index))
     (error "list-ref-safe: index must be an integer" index))
    ((or (negative? index) (≥ index (length lst)))
     (error "list-ref-safe: index out of range" index (length lst)))
    (else
     (list-ref lst index))))

9.3 Exception Objects and Types

R6RS and R7RS introduce structured exception handling with exception objects.

The Exception Hierarchy

;; Base type: all exceptions inherit from this conceptually
;; Throwable (not all Schemes have this explicitly)
;;   ├── Exception (recoverable errors)
;;   │     ├── file-error
;;   │     ├── read-error
;;   │     ├── type-error
;;   │     └── …
;;   └── Error (programming errors - often not catchable)
;;         ├── assertion-violation
;;         └── …

Error Object Properties

;; R7RS error objects have these properties:
;; - error-object? : predicate to test if it's an error object
;; - error-object-message : get the error message
;; - error-object-irritants : get the list of irritants

;; Example (conceptual):
(define err (make-error "Invalid input" 42 "test"))
(error-object? err)           ; → #t
(error-object-message err)    ; → "Invalid input"
(error-object-irritants err)  ; → (42 "test")

Raising Exceptions

;; R7RS: raise
(define (validate-age age)
  (if (or (not (integer? age))
          (negative? age)
          (> age 150))
      (raise (make-error "Invalid age" age))
      age))

;; R7RS: raise-continuable (allows recovery)
(define (warn-if-large n)
  (if (> n 1000)
      (raise-continuable (make-error "Number is very large" n))
      n))

9.4 The guard Form - Exception Handling

The guard form is Scheme’s primary exception handling mechanism (R6RS/R7RS).

Basic Guard Syntax

(guard (exception-variable
        (condition-clause …)
        …)
  body …)

;; General pattern:
(guard (ex
        (test1? ex) handler1)
        (test2? ex) handler2)
        (else default-handler))
  risky-code)

Simple Examples

;; Catch any error
(define result
  (guard (ex
          (else
           (display "An error occurred: ")
           (display (error-object-message ex))
           (newline)
           #f))  ; Return #f on error
    (/ 10 0)))

;; Catch specific error types
(define (safe-car lst)
  (guard (ex
          ((error-object? ex)
           'error-accessing-car)
          (else
           'unknown-error))
    (car lst)))

(safe-car '())        ; → error-accessing-car
(safe-car '(1 2 3))   ; → 1

Multiple Condition Clauses

(define (process-file filename)
  (guard (ex
          ;; File errors
          ((and (error-object? ex)
                (string-contains? (error-object-message ex) "file"))
           (display "File error: ")
           (display (error-object-message ex))
           (newline)
           'file-error)
          
          ;; Read errors
          ((and (error-object? ex)
                (string-contains? (error-object-message ex) "read"))
           (display "Parse error in file")
           (newline)
           'read-error)
          
          ;; Any other error
          (else
           (display "Unknown error: ")
           (display ex)
           (newline)
           'unknown-error))
    
    (call-with-input-file filename
      (lambda (port)
        (read port)))))

Re-raising Exceptions

(define (logged-operation op)
  (guard (ex
          ((error-object? ex)
           (display "Error logged: ")
           (display (error-object-message ex))
           (newline)
           (raise ex)))  ; Re-raise the exception
    (op)))

;; Usage:
(guard (ex
        ((error-object? ex)
         (display "Outer handler caught: ")
         (display (error-object-message ex))
         (newline)))
  (logged-operation (lambda () (error "Something bad"))))

;; Output:
;; Error logged: Something bad
;; Outer handler caught: Something bad

Nesting Guard Forms

(define (robust-file-processor filename)
  (guard (outer-ex
          (else
           (display "Outer handler: ")
           (display (error-object-message outer-ex))
           (newline)
           'fatal-error))
    
    ;; Try primary file
    (guard (inner-ex
            (else
             (display "Primary file failed, trying backup…")
             (newline)
             (raise inner-ex)))  ; Propagate to outer
      
      (process-file filename))))

9.5 The with-exception-handler Procedure

Lower-level exception handling mechanism.

Basic Usage

(with-exception-handler
  handler-procedure
  thunk-to-execute)

;; Example:
(with-exception-handler
  (lambda (ex)
    (display "Error: ")
    (display (if (error-object? ex)
                 (error-object-message ex)
                 ex))
    (newline)
    'recovered)  ; Return value
  (lambda ()
    (error "Something went wrong")))

;; → Error: Something went wrong
;; → recovered

Handler Behavior

;; Handler is called with the exception object
(with-exception-handler
  (lambda (ex)
    (cond
      ((error-object? ex)
       (display "Handled error object")
       (newline))
      (else
       (display "Handled other exception")
       (newline))))
  (lambda ()
    (raise (make-error "test error"))))

;; The handler runs and then:
;; - If handler returns normally, execution may continue
;; - If handler raises, that propagates
;; - Implementation-dependent whether control returns to raise site

Continuable vs Non-Continuable

;; Non-continuable (raise)
(with-exception-handler
  (lambda (ex)
    (display "Handler called")
    (newline)
    42)  ; Try to return a value
  (lambda ()
    (raise (make-error "error"))))
;; Handler returns 42, but execution doesn't continue

;; Continuable (raise-continuable)
(define result
  (with-exception-handler
    (lambda (ex)
      (display "Handler called, returning default")
      (newline)
      'default-value)
    (lambda ()
      (let ((val (raise-continuable (make-error "warning"))))
        (display "Continued with: ")
        (display val)
        (newline)
        val))))

;; Output:
;; Handler called, returning default
;; Continued with: default-value
;; result → default-value

9.6 Assertions and Contracts

Defensive programming techniques.

Simple Assertions

(define (assert condition message . irritants)
  (unless condition
    (apply error message irritants)))

;; Usage:
(define (sqrt-positive x)
  (assert (number? x) "sqrt-positive: argument must be a number" x)
  (assert (≥ x 0) "sqrt-positive: argument must be non-negative" x)
  (sqrt x))

(sqrt-positive -4)  ; Error: sqrt-positive: argument must be non-negative -4

Preconditions and Postconditions

(define (make-contract precondition postcondition)
  (lambda (proc)
    (lambda args
      ;; Check precondition
      (unless (apply precondition args)
        (error "Contract violation: precondition failed" args))
      
      ;; Execute
      (let ((result (apply proc args)))
        
        ;; Check postcondition
        (unless (postcondition result)
          (error "Contract violation: postcondition failed" result))
        
        result))))

;; Example: factorial contract
(define factorial/contract
  ((make-contract
     (lambda (n) (and (integer? n) (≥ n 0)))  ; Precondition
     (lambda (r) (and (integer? r) (≥ r 1)))) ; Postcondition
   factorial))

(factorial/contract 5)   ; → 120
(factorial/contract -1)  ; Error: precondition failed (-1)

Type Checking Helpers

(define (check-type value predicate type-name procedure-name)
  (unless (predicate value)
    (error (string-append procedure-name ": expected " type-name)
           value)))

(define (check-number val proc-name)
  (check-type val number? "number" proc-name))

(define (check-list val proc-name)
  (check-type val list? "list" proc-name))

(define (check-string val proc-name)
  (check-type val string? "string" proc-name))

;; Usage:
(define (my-add a b)
  (check-number a "my-add")
  (check-number b "my-add")
  (+ a b))

(my-add 1 "2")  ; Error: my-add: expected number "2"

Range Checking

(define (check-range val min max proc-name)
  (unless (and (≥ val min) (≤ val max))
    (error (string-append proc-name ": value out of range")
           val min max)))

(define (set-volume! speaker level)
  (check-range level 0 100 "set-volume!")
  ;; … set the volume
  )

(set-volume! my-speaker 150)
;; Error: set-volume!: value out of range 150 0 100

9.7 Resource Management and Cleanup

Ensuring resources are properly released even when errors occur.

The Dynamic-Wind Pattern

;; dynamic-wind ensures cleanup happens
(dynamic-wind
  before-thunk     ; Setup
  during-thunk     ; Main operation
  after-thunk)     ; Cleanup (always runs)

;; Example: File handling
(define (with-file-processing filename processor)
  (let ((port #f))
    (dynamic-wind
      ;; Setup
      (lambda ()
        (set! port (open-input-file filename)))
      
      ;; Main operation
      (lambda ()
        (processor port))
      
      ;; Cleanup
      (lambda ()
        (when port
          (close-port port))))))

;; Usage:
(with-file-processing "data.txt"
  (lambda (port)
    (read port)))  ; Port is closed even if read errors

Safe Resource Pattern

(define (with-resource allocator deallocator)
  (lambda (user)
    (let ((resource (allocator)))
      (dynamic-wind
        (lambda () #f)  ; No setup needed
        (lambda () (user resource))
        (lambda () (deallocator resource))))))

;; Example: Database connection
(define with-db-connection
  (with-resource
    (lambda () (open-database "mydb"))
    (lambda (db) (close-database db))))

;; Usage:
(with-db-connection
  (lambda (db)
    (query db "SELECT * FROM users")))
;; Database is closed even if query fails

Multiple Resource Management

(define (with-multiple-resources . resource-specs)
  (lambda (user)
    (let loop ((specs resource-specs)
               (resources '())
               (deallocators '()))
      (if (null? specs)
          ;; All resources allocated, use them
          (dynamic-wind
            (lambda () #f)
            (lambda () (apply user (reverse resources)))
            (lambda ()
              ;; Cleanup in reverse order
              (for-each (lambda (dealloc) (dealloc))
                        deallocators)))
          
          ;; Allocate next resource
          (let* ((spec (car specs))
                 (allocator (car spec))
                 (deallocator (cadr spec))
                 (resource (allocator)))
            (loop (cdr specs)
                  (cons resource resources)
                  (cons (lambda () (deallocator resource))
                        deallocators)))))))

;; Usage:
(define with-two-files
  (with-multiple-resources
    (list (lambda () (open-input-file "in.txt"))
          (lambda (p) (close-port p)))
    (list (lambda () (open-output-file "out.txt"))
          (lambda (p) (close-port p)))))

((with-two-files)
 (lambda (in-port out-port)
   ;; Use both ports
   (copy-port in-port out-port)))

9.8 Error Recovery Strategies

Different approaches to handling errors.

Return Error Values

;; Return special value on error
(define (safe-div a b)
  (if (zero? b)
      #f  ; Indicate error
      (/ a b)))

;; Return multiple values
(define (safe-div/status a b)
  (if (zero? b)
      (values #f 'division-by-zero)
      (values (/ a b) 'ok)))

;; Usage:
(let-values (((result status) (safe-div/status 10 0)))
  (if (eq? status 'ok)
      (display result)
      (display "Error occurred")))

Maybe/Option Pattern

;; Define Maybe type
(define-record-type <maybe>
  (make-maybe value has-value?)
  maybe?
  (value maybe-value)
  (has-value? maybe-has-value?))

(define (just value)
  (make-maybe value #t))

(define (nothing)
  (make-maybe #f #f))

;; Safe operations
(define (maybe-div a b)
  (if (zero? b)
      (nothing)
      (just (/ a b))))

(define (maybe-bind m f)
  (if (maybe-has-value? m)
      (f (maybe-value m))
      (nothing)))

;; Usage:
(maybe-bind (maybe-div 10 2)
            (lambda (x) (just (* x 2))))
;; → (just 10)

(maybe-bind (maybe-div 10 0)
            (lambda (x) (just (* x 2))))
;; → (nothing)

Retry Logic

(define (retry-on-error thunk max-attempts delay)
  (let loop ((attempt 1))
    (guard (ex
            ((and (error-object? ex)
                  (< attempt max-attempts))
             (display "Attempt ")
             (display attempt)
             (display " failed, retrying…")
             (newline)
             (sleep delay)  ; Implementation-specific
             (loop (+ attempt 1)))
            (else
             (display "All attempts failed")
             (newline)
             (raise ex)))
      (thunk))))

;; Usage:
(retry-on-error
  (lambda () (unreliable-network-call))
  3     ; max 3 attempts
  1000) ; 1 second delay

Fallback Values

(define (with-fallback primary-thunk fallback-thunk)
  (guard (ex
          (else
           (display "Primary failed, using fallback")
           (newline)
           (fallback-thunk)))
    (primary-thunk)))

;; Usage:
(define config
  (with-fallback
    (lambda () (read-config-file "config.json"))
    (lambda () (default-config))))

Circuit Breaker Pattern

(define (make-circuit-breaker threshold timeout)
  (let ((failures 0)
        (last-failure-time 0)
        (state 'closed))  ; closed, open, half-open
    
    (lambda (operation)
      (define (current-time) 
        (current-second))  ; R7RS
      
      (case state
        ((open)
         ;; Check if timeout elapsed
         (if (> (- (current-time) last-failure-time) timeout)
             (begin
               (set! state 'half-open)
               (try-operation))
             (error "Circuit breaker open")))
        
        ((half-open)
         (try-operation))
        
        ((closed)
         (try-operation)))
      
      (define (try-operation)
        (guard (ex
                (else
                 (set! failures (+ failures 1))
                 (set! last-failure-time (current-time))
                 (when (≥ failures threshold)
                   (set! state 'open))
                 (raise ex)))
          (let ((result (operation)))
            ;; Success - reset
            (set! failures 0)
            (set! state 'closed)
            result))))))

;; Usage:
(define protected-call
  (make-circuit-breaker 3 60))  ; 3 failures, 60 sec timeout

(protected-call (lambda () (flaky-network-operation)))

9.9 Validation and Parsing

Combining error handling with data validation.

Validation Framework

(define (validate value . validators)
  (let loop ((validators validators))
    (if (null? validators)
        value
        (let ((validator (car validators)))
          (unless (validator value)
            (error "Validation failed" value))
          (loop (cdr validators))))))

;; Validators
(define (is-number? x) (number? x))
(define (is-positive? x) (> x 0))
(define (is-integer? x) (integer? x))
(define (in-range? min max)
  (lambda (x) (and (≥ x min) (≤ x max))))

;; Usage:
(define (create-user age)
  (let ((validated-age
         (validate age
                   is-number?
                   is-integer?
                   is-positive?
                   (in-range? 1 150))))
    (make-user validated-age)))

(create-user 25)    ; OK
(create-user -5)    ; Error: Validation failed -5
(create-user 200)   ; Error: Validation failed 200

Parser Combinators with Error Handling

(define (parse-or-error parser input error-msg)
  (let ((result (parser input)))
    (if (parse-success? result)
        (parse-result-value result)
        (error error-msg input))))

(define (safe-parse parser input default)
  (guard (ex
          (else default))
    (parse-or-error parser input "Parse failed")))

;; Example:
(define (parse-age input)
  (guard (ex
          (else
           (error "Invalid age format" input)))
    (let ((n (string→number input)))
      (validate n is-integer? is-positive? (in-range? 1 150)))))

(parse-age "25")    ; → 25
(parse-age "-5")    ; Error: Validation failed -5
(parse-age "abc")   ; Error: Invalid age format "abc"

9.10 Debugging and Error Reporting

Stack Traces and Error Context

;; Add context to errors
(define (with-context context thunk)
  (guard (ex
          ((error-object? ex)
           (error (string-append context ": "
                                 (error-object-message ex))
                  (error-object-irritants ex)))
          (else
           (raise ex)))
    (thunk)))

;; Usage:
(define (process-user user-data)
  (with-context "process-user"
    (lambda ()
      (validate-user user-data)
      (save-user user-data))))

(define (validate-user data)
  (with-context "validate-user"
    (lambda ()
      (unless (assoc 'name data)
        (error "Missing required field" 'name)))))

;; Error message will be:
;; "process-user: validate-user: Missing required field"

Detailed Error Objects

(define-record-type <detailed-error>
  (make-detailed-error message context irritants stack-trace)
  detailed-error?
  (message detailed-error-message)
  (context detailed-error-context)
  (irritants detailed-error-irritants)
  (stack-trace detailed-error-stack-trace))

(define (raise-detailed message context irritants)
  (raise (make-detailed-error
           message
           context
           irritants
           (get-stack-trace))))  ; Implementation-specific

(define (get-stack-trace)
  ;; Implementation would capture call stack
  '())

;; Usage:
(define (risky-operation x)
  (unless (number? x)
    (raise-detailed "Expected number"
                    "risky-operation"
                    (list x))))

Logging Errors

(define *error-log* '())

(define (log-error ex)
  (set! *error-log*
        (cons (list (current-time)
                    (if (error-object? ex)
                        (error-object-message ex)
                        (format "~a" ex)))

              *error-log*)))

(define (logged-guard . clauses-and-body)
  (guard (ex
          (else
           (log-error ex)
           (raise ex)))
    (apply begin clauses-and-body)))

;; Usage:
(logged-guard
  (error "Something went wrong"))

;; Check log:

*error-log*
;; → ((1698765432 "Something went wrong") …)

9.11 Practical Examples

Example 1: Safe File Operations

(define (safe-file-operation filename operation default)
  (guard (ex
          ((and (error-object? ex)
                (let ((msg (error-object-message ex)))
                  (or (string-contains? msg "file")
                      (string-contains? msg "permission"))))
           (display "File operation failed: ")
           (display (error-object-message ex))
           (newline)
           default)
          (else
           (display "Unexpected error: ")
           (display ex)
           (newline)
           (raise ex)))
    
    (if (file-exists? filename)
        (operation filename)
        (begin
          (display "File not found: ")
          (display filename)
          (newline)
          default))))

;; Usage:
(define contents
  (safe-file-operation "data.txt"
                       read-file
                       ""))

Example 2: JSON Parser with Error Recovery

(define (parse-json-safe str)
  (guard (ex
          (else
           (display "JSON parse error, returning empty object")
           (newline)
           '()))  ; Empty alist
    (parse-json str)))  ; Hypothetical JSON parser

(define (load-config filename)
  (let ((content (safe-file-operation filename
                                       read-file
                                       "{}")))
    (parse-json-safe content)))

;; Always returns valid config (possibly empty)
(define config (load-config "config.json"))

Example 3: Database Transaction

(define (with-transaction db thunk)
  (begin-transaction db)
  (guard (ex
          (else
           (display "Transaction failed, rolling back")
           (newline)
           (rollback-transaction db)
           (raise ex)))
    (let ((result (thunk)))
      (commit-transaction db)
      result)))

;; Usage:
(with-transaction my-db
  (lambda ()
    (insert-record db user-table user-data)
    (update-record db stats-table stats-data)))

Example 4: Web Request Handler

(define (handle-request request)
  (guard (ex
          ;; Authentication errors
          ((and (error-object? ex)
                (string-contains? (error-object-message ex) "auth"))
           (make-response 401 "Unauthorized"))
          
          ;; Validation errors
          ((and (error-object? ex)
                (string-contains? (error-object-message ex) "validat"))
           (make-response 400 "Bad Request"))
          
          ;; Server errors
          (else
           (log-error ex)
           (make-response 500 "Internal Server Error")))
    
    ;; Process request
    (let* ((user (authenticate request))
           (data (validate-input (request-data request))))
      (process-data user data))))

Example 5: Async Operation with Timeout

(define (with-timeout timeout-ms thunk)
  (let ((result 'timeout)
        (done? #f))
    
    ;; Start timer (conceptual - implementation-specific)
    (start-timer timeout-ms
                 (lambda ()
                   (unless done?
                     (set! result 'timeout))))
    
    ;; Try operation
    (guard (ex
            (else
             (set! done? #t)
             (raise ex)))
      (let ((value (thunk)))
        (set! done? #t)
        (set! result value)))
    
    (if (eq? result 'timeout)
        (error "Operation timed out")
        result)))

Summary

This chapter covered error handling in Scheme:

  1. Error Signaling: error procedure for basic error reporting

  2. Exception Objects: Structured error information

  3. Guard Form: Primary exception handling mechanism

  4. Exception Handlers: Lower-level with-exception-handler

  5. Contracts and Assertions: Defensive programming

  6. Resource Management: dynamic-wind for cleanup

  7. Recovery Strategies: Retry, fallback, circuit breakers

  8. Validation: Input checking and parsing

  9. Debugging: Context and logging

Key Principles:

  • Use guard for exception handling

  • Always clean up resources

  • Provide informative error messages

  • Validate early, fail fast

  • Log errors for debugging

  • Design for failure recovery

Best Practices:

  • Distinguish programming errors from runtime errors

  • Use contracts for API boundaries

  • Handle exceptions at appropriate levels

  • Don’t catch what you can’t handle

  • Clean up resources in all paths

  • Test error paths thoroughly

Next chapter: Chapter 10: Object-Oriented Programming in Scheme - Records, CLOS-style objects, encapsulation, inheritance, and OOP patterns in Scheme.

Chapter 10: Object-Oriented Programming in Scheme

10.1 Introduction to OOP in Scheme

Object-oriented programming (OOP) is not native to Scheme’s functional paradigm, but Scheme’s powerful abstraction mechanisms make it possible to implement various OOP styles elegantly.

Why OOP in Scheme?

;; Procedural approach - scattered state and operations
(define rectangle-width 10)
(define rectangle-height 5)

(define (rectangle-area)
  (* rectangle-width rectangle-height))

;; Object-oriented approach - encapsulated state and behavior
(define my-rectangle (make-rectangle 10 5))
(rectangle-area my-rectangle)  ; → 50

OOP Concepts in Scheme

  1. Encapsulation: Bundling data with operations

  2. Message Passing: Objects respond to messages

  3. Inheritance: Objects can inherit from parent objects

  4. Polymorphism: Different objects respond to same message differently

Two Main Approaches

  1. Message Passing Style: Closures encapsulating state

  2. Record-Based Style: Using define-record-type (R7RS)

10.2 Message-Passing Objects with Closures

The simplest OOP style uses lexical closures to encapsulate state.

Basic Message-Passing Object

(define (make-counter initial)
  (let ((count initial))
    (lambda (message)
      (cond
        ((eq? message 'increment)
         (set! count (+ count 1))
         count)
        ((eq? message 'decrement)
         (set! count (- count 1))
         count)
        ((eq? message 'get)
         count)
        ((eq? message 'reset)
         (set! count initial)
         count)
        (else
         (error "Unknown message" message))))))

;; Usage:
(define c1 (make-counter 0))
(c1 'increment)  ; → 1
(c1 'increment)  ; → 2
(c1 'get)        ; → 2
(c1 'reset)      ; → 0

(define c2 (make-counter 10))
(c2 'increment)  ; → 11
(c1 'get)        ; → 0  ; c1 and c2 are independent

Objects with Methods Taking Arguments

(define (make-bank-account initial-balance)
  (let ((balance initial-balance))
    (lambda (message . args)
      (cond
        ((eq? message 'balance)
         balance)
        
        ((eq? message 'deposit)
         (if (null? args)
             (error "deposit requires an amount")
             (let ((amount (car args)))
               (if (< amount 0)
                   (error "Cannot deposit negative amount" amount)
                   (begin
                     (set! balance (+ balance amount))
                     balance)))))
        
        ((eq? message 'withdraw)
         (if (null? args)
             (error "withdraw requires an amount")
             (let ((amount (car args)))
               (cond
                 ((< amount 0)
                  (error "Cannot withdraw negative amount" amount))
                 ((> amount balance)
                  (error "Insufficient funds" amount balance))
                 (else
                  (set! balance (- balance amount))
                  balance)))))
        
        ((eq? message 'transfer)
         (if (< (length args) 2)
             (error "transfer requires amount and target account")
             (let ((amount (car args))
                   (target (cadr args)))
               (if (> amount balance)
                   (error "Insufficient funds for transfer")
                   (begin
                     (set! balance (- balance amount))
                     (target 'deposit amount)
                     balance)))))
        
        (else
         (error "Unknown message" message))))))

;; Usage:
(define alice-account (make-bank-account 1000))
(define bob-account (make-bank-account 500))

(alice-account 'deposit 200)     ; → 1200
(alice-account 'withdraw 300)    ; → 900
(alice-account 'transfer 100 bob-account)  ; → 800
(bob-account 'balance)           ; → 600

Generic Dispatch Helper

(define (make-object methods)
  (lambda (message . args)
    (let ((method (assoc message methods)))
      (if method
          (apply (cdr method) args)
          (error "Unknown message" message)))))

;; Using the helper:
(define (make-point x y)
  (let ((px x)
        (py y))
    (make-object
     (list
      (cons 'x (lambda () px))
      (cons 'y (lambda () py))
      (cons 'set-x! (lambda (new-x) (set! px new-x)))
      (cons 'set-y! (lambda (new-y) (set! py new-y)))
      (cons 'distance-to-origin
            (lambda ()
              (sqrt (+ (* px px) (* py py)))))
      (cons 'move!
            (lambda (dx dy)
              (set! px (+ px dx))
              (set! py (+ py dy))))))))

;; Usage:
(define p (make-point 3 4))
(p 'x)                    ; → 3
(p 'distance-to-origin)   ; → 5.0
(p 'move! 1 1)
(p 'x)                    ; → 4
(p 'y)                    ; → 5

Objects with Private Methods

(define (make-rectangle width height)
  (let ((w width)
        (h height))
    
    ;; Private helper
    (define (validate-dimension dim)
      (if (or (not (number? dim)) (≤ dim 0))
          (error "Dimension must be positive number" dim)
          #t))
    
    ;; Public interface
    (make-object
     (list
      (cons 'width (lambda () w))
      (cons 'height (lambda () h))
      
      (cons 'set-width!
            (lambda (new-w)
              (validate-dimension new-w)
              (set! w new-w)))
      
      (cons 'set-height!
            (lambda (new-h)
              (validate-dimension new-h)
              (set! h new-h)))
      
      (cons 'area
            (lambda () (* w h)))
      
      (cons 'perimeter
            (lambda () (* 2 (+ w h))))
      
      (cons 'scale!
            (lambda (factor)
              (validate-dimension factor)
              (set! w (* w factor))
              (set! h (* h factor))))))))

;; Usage:
(define rect (make-rectangle 10 5))
(rect 'area)        ; → 50
(rect 'scale! 2)
(rect 'area)        ; → 200
(rect 'set-width! -5)  ; Error: Dimension must be positive

10.3 Record-Based Objects (R7RS)

R7RS provides define-record-type for defining structured data types.

Basic Record Definition

(define-record-type <point>
  (make-point x y)
  point?
  (x point-x set-point-x!)
  (y point-y set-point-y!))

;; Usage:
(define p1 (make-point 3 4))
(point? p1)           ; → #t
(point-x p1)          ; → 3
(point-y p1)          ; → 4
(set-point-x! p1 10)
(point-x p1)          ; → 10

Records with Computed Properties

(define-record-type <circle>
  (make-circle radius)
  circle?
  (radius circle-radius set-circle-radius!))

;; Add methods via separate definitions
(define (circle-area circle)
  (let ((r (circle-radius circle)))
    (* 3.14159 r r)))

(define (circle-circumference circle)
  (let ((r (circle-radius circle)))
    (* 2 3.14159 r)))

(define (circle-scale! circle factor)
  (set-circle-radius! circle
                      (* (circle-radius circle) factor)))

;; Usage:
(define c (make-circle 5))
(circle-area c)           ; → 78.53975
(circle-scale! c 2)
(circle-radius c)         ; → 10
(circle-area c)           ; → 314.159

Immutable Records

;; Omit setters for immutability
(define-record-type <immutable-point>
  (make-immutable-point x y)
  immutable-point?
  (x immutable-point-x)
  (y immutable-point-y))

;; Create new instances instead of mutating
(define (immutable-point-move p dx dy)
  (make-immutable-point
   (+ (immutable-point-x p) dx)
   (+ (immutable-point-y p) dy)))

;; Usage:
(define p1 (make-immutable-point 0 0))
(define p2 (immutable-point-move p1 3 4))
(immutable-point-x p1)  ; → 0  (unchanged)
(immutable-point-x p2)  ; → 3  (new point)

Records with Validation

(define-record-type <validated-account>
  (raw-make-account balance)  ; Private constructor
  account?
  (balance account-balance set-account-balance!))

;; Public constructor with validation
(define (make-account initial-balance)
  (if (and (number? initial-balance)
           (≥ initial-balance 0))
      (raw-make-account initial-balance)
      (error "Invalid initial balance" initial-balance)))

;; Safe operations
(define (account-deposit! account amount)
  (if (and (number? amount) (> amount 0))
      (set-account-balance! account
                           (+ (account-balance account) amount))
      (error "Invalid deposit amount" amount)))

(define (account-withdraw! account amount)
  (cond
    ((not (and (number? amount) (> amount 0)))
     (error "Invalid withdrawal amount" amount))
    ((> amount (account-balance account))
     (error "Insufficient funds"))
    (else
     (set-account-balance! account
                          (- (account-balance account) amount)))))

;; Usage:
(define acc (make-account 1000))
(account-deposit! acc 500)     ; OK
(account-balance acc)          ; → 1500
(account-withdraw! acc 2000)   ; Error: Insufficient funds

10.4 Simulating Inheritance

Scheme doesn’t have built-in inheritance, but we can simulate it.

Delegation Pattern

(define (make-colored-point x y color)
  (let ((parent (make-point x y))
        (c color))
    
    (lambda (message . args)
      (cond
        ;; New methods
        ((eq? message 'color)
         c)
        ((eq? message 'set-color!)
         (if (null? args)
             (error "set-color! requires a color")
             (set! c (car args))))
        
        ;; Delegate to parent
        (else
         (apply parent message args))))))

;; Usage:
(define cp (make-colored-point 3 4 'red))
(cp 'x)              ; → 3 (delegated to parent)
(cp 'color)          ; → red
(cp 'move! 1 1)      ; Works (delegated)
(cp 'x)              ; → 4
(cp 'set-color! 'blue)
(cp 'color)          ; → blue

Mixin Pattern

;; Base functionality
(define (make-base-object name)
  (let ((n name))
    (make-object
     (list
      (cons 'name (lambda () n))
      (cons 'set-name! (lambda (new-name) (set! n new-name)))))))

;; Mixin: adds timestamp functionality
(define (add-timestamp base-maker)
  (lambda args
    (let ((base (apply base-maker args))
          (created-at (current-second)))
      
      (lambda (message . rest)
        (cond
          ((eq? message 'created-at)
           created-at)
          (else
           (apply base message rest)))))))

;; Mixin: adds ID functionality
(define id-counter 0)

(define (add-id base-maker)
  (lambda args
    (let ((base (apply base-maker args))
          (id (begin
                (set! id-counter (+ id-counter 1))
                id-counter)))
      
      (lambda (message . rest)
        (cond
          ((eq? message 'id)
           id)
          (else
           (apply base message rest)))))))

;; Combine mixins
(define make-timestamped-object
  (add-timestamp make-base-object))

(define make-tracked-object
  (add-id (add-timestamp make-base-object)))

;; Usage:
(define obj1 (make-tracked-object "first"))
(obj1 'name)        ; → "first"
(obj1 'id)          ; → 1
(obj1 'created-at)  ; → 1698765432

(define obj2 (make-tracked-object "second"))
(obj2 'id)          ; → 2

Prototype-Based Inheritance

(define (make-prototype-object parent methods)
  (lambda (message . args)
    (let ((method (assoc message methods)))
      (if method
          ;; Found in this object
          (apply (cdr method) args)
          ;; Delegate to parent
          (if parent
              (apply parent message args)
              (error "Unknown message" message))))))

;; Example: Shape hierarchy
(define (make-shape)
  (let ((x 0)
        (y 0))
    (make-prototype-object
     #f  ; No parent
     (list
      (cons 'x (lambda () x))
      (cons 'y (lambda () y))
      (cons 'move! (lambda (dx dy)
                     (set! x (+ x dx))
                     (set! y (+ y dy))))
      (cons 'position (lambda () (list x y)))))))

(define (make-rectangle-from-shape)
  (let ((width 10)
        (height 5))
    (make-prototype-object
     (make-shape)  ; Parent
     (list
      (cons 'width (lambda () width))
      (cons 'height (lambda () height))
      (cons 'area (lambda () (* width height)))
      (cons 'set-dimensions!
            (lambda (w h)
              (set! width w)
              (set! height h)))))))

;; Usage:
(define rect (make-rectangle-from-shape))
(rect 'area)        ; → 50 (own method)
(rect 'move! 10 20) ; Works (inherited)
(rect 'position)    ; → (10 20)

10.5 Polymorphism Through Generic Operations

Simple Generic Dispatch

(define *generic-table* (make-hash-table))

(define (define-generic name)
  (hash-table-set! *generic-table* name (make-hash-table)))

(define (define-method generic-name type-tag method)
  (let ((table (hash-table-ref *generic-table* generic-name)))
    (hash-table-set! table type-tag method)))

(define (invoke-generic generic-name obj . args)
  (let* ((table (hash-table-ref *generic-table* generic-name))
         (type (obj 'type))
         (method (hash-table-ref table type #f)))
    (if method
        (apply method obj args)
        (error "No method for type" generic-name type))))

;; Define generic operations
(define-generic 'area)
(define-generic 'perimeter)

;; Circle implementation
(define (make-circle-v2 radius)
  (let ((r radius))
    (make-object
     (list
      (cons 'type (lambda () 'circle))
      (cons 'radius (lambda () r))))))

(define-method 'area 'circle
  (lambda (circle)
    (let ((r (circle 'radius)))
      (* 3.14159 r r))))

(define-method 'perimeter 'circle
  (lambda (circle)
    (let ((r (circle 'radius)))
      (* 2 3.14159 r))))

;; Rectangle implementation
(define (make-rectangle-v2 width height)
  (let ((w width)
        (h height))
    (make-object
     (list
      (cons 'type (lambda () 'rectangle))
      (cons 'width (lambda () w))
      (cons 'height (lambda () h))))))

(define-method 'area 'rectangle
  (lambda (rect)
    (* (rect 'width) (rect 'height))))

(define-method 'perimeter 'rectangle
  (lambda (rect)
    (* 2 (+ (rect 'width) (rect 'height)))))

;; Usage:
(define shapes
  (list (make-circle-v2 5)
        (make-rectangle-v2 10 5)))

(map (lambda (s) (invoke-generic 'area s)) shapes)
;; → (78.53975 50)

Type Predicates for Dispatch

(define (define-predicate-method generic-name predicate method)
  (let ((old-generic
         (hash-table-ref *generic-table* generic-name
                        (lambda () (lambda args (error "No method"))))))
    (hash-table-set! *generic-table*
                     generic-name
                     (lambda (obj . args)
                       (if (predicate obj)
                           (apply method obj args)
                           (apply old-generic obj args))))))

;; Built-in types
(define-predicate-method 'display-value
  number?
  (lambda (n) (display n)))

(define-predicate-method 'display-value
  string?
  (lambda (s) (display s)))

(define-predicate-method 'display-value
  list?
  (lambda (lst)
    (display "(")
    (for-each (lambda (x)
                (invoke-generic 'display-value x)
                (display " "))
              lst)
    (display ")")))

;; Usage:
(define show (hash-table-ref *generic-table* 'display-value))
(show 42)              ; 42
(show "hello")         ; hello
(show '(1 2 3))        ; (1 2 3 )

10.6 Advanced OOP Patterns

The Visitor Pattern

;; Define visitable objects
(define (make-visitable-number value)
  (make-object
   (list
    (cons 'type (lambda () 'number))
    (cons 'value (lambda () value))
    (cons 'accept
          (lambda (visitor)
            (visitor 'visit-number value))))))

(define (make-visitable-list items)
  (make-object
   (list
    (cons 'type (lambda () 'list))
    (cons 'items (lambda () items))
    (cons 'accept
          (lambda (visitor)
            (visitor 'visit-list items))))))

;; Visitor: sum all numbers
(define (make-sum-visitor)
  (let ((total 0))
    (make-object
     (list
      (cons 'visit-number
            (lambda (n)
              (set! total (+ total n))))
      (cons 'visit-list
            (lambda (items)
              (for-each (lambda (item)
                         (item 'accept (make-object (list
                                                     (cons 'visit-number
                                                           (lambda (n) (set! total (+ total n))))
                                                     (cons 'visit-list
                                                           (lambda (lst) #f))))))
                       items)))
      (cons 'get-total (lambda () total))))))

;; Usage:
(define num1 (make-visitable-number 5))
(define num2 (make-visitable-number 10))
(define visitor (make-sum-visitor))

(num1 'accept visitor)
(num2 'accept visitor)
(visitor 'get-total)  ; → 15

The Observer Pattern

(define (make-observable)
  (let ((observers '()))
    (make-object
     (list
      (cons 'attach
            (lambda (observer)
              (set! observers (cons observer observers))))
      
      (cons 'detach
            (lambda (observer)
              (set! observers (filter (lambda (o) (not (eq? o observer)))
                                     observers))))
      
      (cons 'notify
            (lambda (event)
              (for-each (lambda (observer)
                         (observer 'update event))
                       observers)))))))

(define (make-temperature-sensor)
  (let ((observable (make-observable))
        (temperature 20))
    
    (make-object
     (list
      (cons 'attach (lambda (obs) (observable 'attach obs)))
      (cons 'detach (lambda (obs) (observable 'detach obs)))
      
      (cons 'temperature (lambda () temperature))
      
      (cons 'set-temperature!
            (lambda (new-temp)
              (set! temperature new-temp)
              (observable 'notify (list 'temperature-changed temperature))))))))

(define (make-display-observer name)
  (make-object
   (list
    (cons 'update
          (lambda (event)
            (display name)
            (display ": Temperature changed to ")
            (display (cadr event))
            (newline))))))

;; Usage:
(define sensor (make-temperature-sensor))
(define display1 (make-display-observer "Display1"))
(define display2 (make-display-observer "Display2"))

(sensor 'attach display1)
(sensor 'attach display2)

(sensor 'set-temperature! 25)
;; Output:
;; Display1: Temperature changed to 25
;; Display2: Temperature changed to 25

The Strategy Pattern

(define (make-sorter strategy)
  (make-object
   (list
    (cons 'set-strategy!
          (lambda (new-strategy)
            (set! strategy new-strategy)))
    
    (cons 'sort
          (lambda (lst)
            (strategy lst))))))

;; Strategies
(define (bubble-sort-strategy lst)
  ;; Implementation of bubble sort
  (define (bubble-pass lst)
    (if (or (null? lst) (null? (cdr lst)))
        lst
        (if (> (car lst) (cadr lst))
            (cons (cadr lst)
                  (bubble-pass (cons (car lst) (cddr lst))))
            (cons (car lst)
                  (bubble-pass (cdr lst))))))
  
  (let loop ((lst lst))
    (let ((new-lst (bubble-pass lst)))
      (if (equal? lst new-lst)
          lst
          (loop new-lst)))))

(define (quick-sort-strategy lst)
  (if (or (null? lst) (null? (cdr lst)))
      lst
      (let ((pivot (car lst)))
        (append
         (quick-sort-strategy
          (filter (lambda (x) (< x pivot)) (cdr lst)))
         (list pivot)
         (quick-sort-strategy
          (filter (lambda (x) (≥ x pivot)) (cdr lst)))))))

;; Usage:
(define sorter (make-sorter bubble-sort-strategy))
(sorter 'sort '(3 1 4 1 5 9 2 6))  ; → (1 1 2 3 4 5 6 9)

(sorter 'set-strategy! quick-sort-strategy)
(sorter 'sort '(3 1 4 1 5 9 2 6))  ; → (1 1 2 3 4 5 6 9)

10.7 Extended Example: A Logo Turtle

A complete object-oriented turtle graphics system.

Basic Turtle Object

(define (make-turtle x y heading)
  (let ((px x)
        (py y)
        (h heading)  ; 0 = north, 90 = east, etc.
        (pen-down? #t)
        (lines '()))  ; Store drawn lines
    
    ;; Helper: Convert heading to radians
    (define (heading-to-radians)
      (* h (/ 3.14159 180)))
    
    ;; Private method: Add a line
    (define (add-line x1 y1 x2 y2)
      (set! lines (cons (list x1 y1 x2 y2) lines)))
    
    ;; Public interface
    (make-object
     (list
      ;; Queries
      (cons 'x (lambda () px))
      (cons 'y (lambda () py))
      (cons 'heading (lambda () h))
      (cons 'pen-down? (lambda () pen-down?))
      (cons 'lines (lambda () (reverse lines)))
      
      ;; Pen control
      (cons 'pen-up!
            (lambda ()
              (set! pen-down? #f)))
      
      (cons 'pen-down!
            (lambda ()
              (set! pen-down? #t)))
      
      ;; Movement
      (cons 'forward
            (lambda (distance)
              (let* ((radians (heading-to-radians))
                     (new-x (+ px (* distance (sin radians))))
                     (new-y (+ py (* distance (cos radians)))))
                
                (when pen-down?
                  (add-line px py new-x new-y))
                
                (set! px new-x)
                (set! py new-y))))
      
      (cons 'backward
            (lambda (distance)
              (let* ((radians (heading-to-radians))
                     (new-x (- px (* distance (sin radians))))
                     (new-y (- py (* distance (cos radians)))))
                
                (when pen-down?
                  (add-line px py new-x new-y))
                
                (set! px new-x)
                (set! py new-y))))
      
      ;; Rotation
      (cons 'right
            (lambda (degrees)
              (set! h (modulo (+ h degrees) 360))))
      
      (cons 'left
            (lambda (degrees)
              (set! h (modulo (- h degrees) 360))))
      
      (cons 'set-heading!
            (lambda (new-heading)
              (set! h (modulo new-heading 360))))
      
      ;; Position
      (cons 'goto
            (lambda (new-x new-y)
              (when pen-down?
                (add-line px py new-x new-y))
              (set! px new-x)
              (set! py new-y)))
      
      (cons 'home
            (lambda ()
              (when pen-down?
                (add-line px py 0 0))
              (set! px 0)
              (set! py 0)
              (set! h 0)))
      
      ;; Clear
      (cons 'clear
            (lambda ()
              (set! lines '())))))))

;; Usage:
(define turtle (make-turtle 0 0 0))

;; Draw a square
(define (draw-square turtle size)
  (let loop ((n 4))
    (unless (zero? n)
      (turtle 'forward size)
      (turtle 'right 90)
      (loop (- n 1)))))

(draw-square turtle 50)
(turtle 'lines)
;; → ((0 0 50 0) (50 0 50 -50) (50 -50 0 -50) (0 -50 0 0))

Enhanced Turtle with Colors

(define (make-colored-turtle x y heading color)
  (let ((base-turtle (make-turtle x y heading))
        (c color))
    
    (lambda (message . args)
      (cond
        ((eq? message 'color)
         c)
        
        ((eq? message 'set-color!)
         (if (null? args)
             (error "set-color! requires a color")
             (set! c (car args))))
        
        ;; Delegate everything else
        (else
         (apply base-turtle message args))))))

;; Usage:
(define red-turtle (make-colored-turtle 0 0 0 'red))
(red-turtle 'color)        ; → red
(red-turtle 'forward 50)   ; Works
(red-turtle 'set-color! 'blue)
(red-turtle 'color)        ; → blue

Turtle Manager (Multiple Turtles)

(define (make-turtle-manager)
  (let ((turtles '())
        (active-turtle #f))
    
    (make-object
     (list
      (cons 'create-turtle
            (lambda (name x y heading)
              (let ((turtle (make-turtle x y heading)))
                (set! turtles
                      (cons (cons name turtle) turtles))
                (when (null? (cdr turtles))
                  (set! active-turtle turtle))
                turtle)))
      
      (cons 'select-turtle
            (lambda (name)
              (let ((pair (assoc name turtles)))
                (if pair
                    (set! active-turtle (cdr pair))
                    (error "Turtle not found" name)))))
      
      (cons 'active
            (lambda () active-turtle))
      
      (cons 'send-to-active
            (lambda (message . args)
              (if active-turtle
                  (apply active-turtle message args)
                  (error "No active turtle"))))
      
      (cons 'all-turtles
            (lambda () (map car turtles)))
      
      (cons 'broadcast
            (lambda (message . args)
              (for-each (lambda (pair)
                         (apply (cdr pair) message args))
                       turtles)))))))

;; Usage:
(define manager (make-turtle-manager))
(manager 'create-turtle 'alice 0 0 0)
(manager 'create-turtle 'bob 100 100 90)

(manager 'select-turtle 'alice)
(manager 'send-to-active 'forward 50)

(manager 'select-turtle 'bob)
(manager 'send-to-active 'forward 30)

;; Move all turtles
(manager 'broadcast 'right 45)
(manager 'broadcast 'forward 10)

10.8 Practical Patterns and Best Practices

Getters and Setters Convention

;; Naming convention
(define (make-person name age)
  (let ((n name)
        (a age))
    (make-object
     (list
      ;; Getters: just the property name
      (cons 'name (lambda () n))
      (cons 'age (lambda () a))
      
      ;; Setters: property-set!
      (cons 'name-set! (lambda (new-name) (set! n new-name)))
      (cons 'age-set! (lambda (new-age)
                        (if (and (number? new-age) (≥ new-age 0))
                            (set! a new-age)
                            (error "Invalid age" new-age))))
      
      ;; Computed properties
      (cons 'is-adult? (lambda () (≥ a 18)))))))

Builder Pattern

(define (make-builder type)
  (let ((properties (make-hash-table)))
    
    (make-object
     (list
      (cons 'set
            (lambda (key value)
              (hash-table-set! properties key value)
              ;; Return self for chaining
              (make-object (list
                            (cons 'set (lambda (k v)
                                        (hash-table-set! properties k v)
                                        ;; … repeat methods
                                        ))
                            (cons 'build (lambda () (build-object)))))))
      
      (cons 'build
            (lambda ()
              (case type
                ((person)
                 (make-person
                  (hash-table-ref properties 'name "Unknown")
                  (hash-table-ref properties 'age 0)))
                (else
                 (error "Unknown type" type)))))))))

;; Usage:
(define person
  ((((make-builder 'person) 'set 'name "Alice")
    'set 'age 25)
   'build))

Factory Pattern

(define (shape-factory type . args)
  (case type
    ((circle)
     (if (null? args)
         (error "circle requires radius")
         (make-circle (car args))))
    
    ((rectangle)
     (if (< (length args) 2)
         (error "rectangle requires width and height")
         (make-rectangle (car args) (cadr args))))
    
    ((square)
     (if (null? args)
         (error "square requires side")
         (let ((side (car args)))
           (make-rectangle side side))))
    
    (else
     (error "Unknown shape type" type))))

;; Usage:
(define shapes
  (list (shape-factory 'circle 5)
        (shape-factory 'rectangle 10 5)
        (shape-factory 'square 7)))

Singleton Pattern

(define (make-singleton-factory constructor)
  (let ((instance #f))
    (lambda args
      (unless instance
        (set! instance (apply constructor args)))
      instance)))

;; Usage:
(define get-logger
  (make-singleton-factory
   (lambda ()
     (let ((logs '()))
       (make-object
        (list
         (cons 'log
               (lambda (message)
                 (set! logs (cons message logs))))
         (cons 'get-logs
               (lambda () (reverse logs)))))))))

(define logger1 (get-logger))
(define logger2 (get-logger))

(eq? logger1 logger2)  ; → #t (same instance)

Summary

This chapter covered OOP in Scheme:

  1. Message Passing: Closures encapsulating state

  2. Records: define-record-type for structured data

  3. Inheritance: Delegation and prototype patterns

  4. Polymorphism: Generic operations with dispatch

  5. Design Patterns: Visitor, Observer, Strategy

  6. Extended Example: Logo turtle graphics

  7. Best Practices: Conventions and common patterns

Key Techniques:

  • Lexical closures for encapsulation

  • Message passing for polymorphism

  • Delegation for inheritance

  • Generic dispatch tables

  • Mixins for composition

Design Principles:

  • Encapsulation: Hide internal state

  • Abstraction: Define clear interfaces

  • Composition over inheritance

  • Single responsibility per object

  • Immutability when possible

OOP in Scheme demonstrates the language’s flexibility—you can implement various object systems suited to your needs rather than being locked into one model.

Chapter 11: Development Environment Setup

11.1 Introduction to Scheme Development Environments

Setting up an effective Scheme development environment involves choosing the right implementation, editor, and tools for your needs.

Why Environment Matters

;; Poor environment: No syntax highlighting, no REPL
;; - Type code in notepad
;; - Save as file.scm
;; - Run: scheme < file.scm
;; - Debug with (display …) everywhere

;; Good environment: Integrated experience
;; - Syntax highlighting shows structure
;; - REPL for immediate feedback
;; - Debugger for stepping through code
;; - Auto-completion for efficiency

Key Components

  1. Scheme Implementation: The runtime and compiler

  2. Editor/IDE: Where you write code

  3. REPL: Interactive testing environment

  4. Build Tools: For larger projects

  5. Version Control: Git integration

  6. Testing Framework: Automated testing

11.2 Choosing a Scheme Implementation

Features:

  • Full-featured IDE (DrRacket)

  • Excellent documentation

  • Large standard library

  • Great learning resources

  • Cross-platform (Windows, macOS, Linux)

Installation:

# Ubuntu/Debian
sudo apt-get update
sudo apt-get install racket

# macOS (using Homebrew)
brew install --cask racket

# Windows
# Download installer from https://racket-lang.org/

Hello World:

#lang racket

(displayln "Hello, World!")

;; Run in terminal:
;; racket hello.rkt

REPL:

$ racket
Welcome to Racket v8.10
> (+ 1 2 3)
6
> (define (factorial n)
    (if (≤ n 1)
        1
        (* n (factorial (- n 1)))))
> (factorial 5)
120
Guile (GNU’s Scheme)

Features:

  • Official GNU extension language

  • C/C++ integration

  • Used in GNUCash, GDB, and other GNU projects

  • POSIX support

Installation:

# Ubuntu/Debian
sudo apt-get install guile-3.0

# macOS
brew install guile

# Verify installation
guile --version

Hello World:

#!/usr/bin/guile \

-e main -s
!#

(define (main args)
  (display "Hello, World!")
  (newline))

;; Run: chmod +x hello.scm ∧ ./hello.scm
;; Or: guile hello.scm
Chez Scheme

Features:

  • Very fast compiler

  • R6RS compliant

  • Used by Racket’s backend

  • Commercial-grade quality

Installation:

# Ubuntu/Debian (from source)
git clone https://github.com/cisco/ChezScheme.git
cd ChezScheme
./configure
make
sudo make install

# macOS
brew install chezscheme

# Verify
scheme --version

Hello World:

;; hello.ss
(import (chezscheme))

(display "Hello, World!")
(newline)

;; Run: scheme --script hello.ss
Chicken Scheme

Features:

  • Compiles to C

  • Large egg repository (packages)

  • Easy C integration

  • Lightweight

Installation:

# Ubuntu/Debian
sudo apt-get install chicken-bin

# macOS
brew install chicken

# Windows: Download from https://www.call-cc.org/

Hello World:

;; hello.scm
(print "Hello, World!")

;; Interpret: csi -s hello.scm
;; Compile: csc hello.scm -o hello
;; Run: ./hello
MIT/GNU Scheme

Features:

  • Classic implementation

  • Used in SICP

  • Full development environment

  • Strong debugging tools

Installation:

# Ubuntu/Debian
sudo apt-get install mit-scheme

# macOS
brew install mit-scheme

# Run
mit-scheme
Gambit Scheme

Features:

  • Compiles to C, JavaScript, Python

  • Great for embedding

  • R5RS/R7RS support

  • Excellent performance

Installation:

# From source
git clone https://github.com/gambit/gambit.git
cd gambit
./configure
make
sudo make install

# Run
gsi  # Interpreter
gsc  # Compiler

Comparison Table

;; Implementation comparison (as data)
(define implementations
  '((racket
     (pros "Great IDE" "Excellent docs" "Large community")
     (cons "Non-standard extensions" "Large installation")
     (best-for "Learning" "General development"))
    
    (guile
     (pros "GNU official" "C integration" "POSIX support")
     (cons "Slower than others" "Less documentation")
     (best-for "Scripting" "GNU projects"))
    
    (chez
     (pros "Very fast" "Commercial quality")
     (cons "Limited libraries" "Steeper learning curve")
     (best-for "Performance-critical" "Production"))
    
    (chicken
     (pros "Compiles to C" "Good FFI" "Active community")
     (cons "Non-standard" "Compilation slower")
     (best-for "System programming" "C integration"))
    
    (mit-scheme
     (pros "SICP compatibility" "Good debugger")
     (cons "Older" "Less active development")
     (best-for "Learning from SICP"))))

11.3 Editor and IDE Setup

DrRacket (Racket’s IDE)

Built-in IDE for Racket:

#lang racket

;; DrRacket features demonstrated:

;; 1. Syntax highlighting (automatic)
(define (example)
  (let ((x 10)
        (y 20))
    (+ x y)))

;; 2. Check Syntax (Ctrl+; or Cmd+;)
;; - Shows variable bindings
;; - Highlights scope
;; - Finds unused variables

;; 3. REPL Integration
;; - Click "Run" to load definitions
;; - Test in REPL below

;; 4. Debugger
;; - Click to left of line number for breakpoint
;; - Step, continue, inspect variables

;; 5. Auto-completion
;; - Type (dis and press Ctrl+/

DrRacket Configuration:

;; In DrRacket, Edit → Preferences

;; Recommended settings:
;; - Enable automatic parenthesis matching
;; - Show line numbers
;; - Enable background syntax checking
;; - Set color scheme (Edit → Preferences → Colors)

;; Custom keybindings:
;; Edit → Keybindings → Add User-defined Keybindings

;; Example custom keybindings file:
(define (my-shortcuts frame)
  (send (send frame get-interactions-text)
        set-load-on-execute #t))

Emacs with Geiser

Most powerful Scheme development environment:

Installation:

# Install Emacs
# Ubuntu/Debian
sudo apt-get install emacs

# macOS
brew install emacs

# Install Geiser (Scheme interaction in Emacs)
# Add to ~/.emacs or ~/.emacs.d/init.el:
;; ~/.emacs.d/init.el

;; Package management
(require 'package)
(add-to-list 'package-archives
             '("melpa" . "https://melpa.org/packages/"))
(package-initialize)

;; Install Geiser
;; M-x package-install RET geiser RET
;; M-x package-install RET geiser-racket RET
;; M-x package-install RET geiser-guile RET
;; M-x package-install RET geiser-chez RET

;; Geiser configuration
(require 'geiser)
(setq geiser-default-implementation 'racket)

;; Enable paredit for balanced parentheses
(autoload 'paredit-mode "paredit"
  "Minor mode for pseudo-structurally editing Lisp code." t)
(add-hook 'scheme-mode-hook 'paredit-mode)

;; Syntax highlighting
(add-hook 'scheme-mode-hook 'font-lock-mode)

;; Auto-completion
(require 'company)
(add-hook 'scheme-mode-hook 'company-mode)

;; Line numbers
(add-hook 'scheme-mode-hook 'display-line-numbers-mode)

;; Rainbow delimiters (color-coded parentheses)
(require 'rainbow-delimiters)
(add-hook 'scheme-mode-hook 'rainbow-delimiters-mode)

Basic Emacs/Geiser Workflow:

;; 1. Open Scheme file
;; C-x C-f myfile.scm

;; 2. Start REPL
;; C-c C-z (start Geiser REPL)

;; 3. Evaluate expressions
;; C-x C-e     - Eval expression before cursor
;; C-c C-r     - Eval region
;; C-c C-k     - Eval entire buffer
;; C-c C-l     - Load file

;; 4. Navigation
;; C-c C-d d   - Show documentation
;; C-c C-d s   - Show signature
;; M-.         - Jump to definition
;; M-,         - Jump back

;; 5. Code manipulation (with paredit)
;; C-M-f       - Forward over s-expression
;; C-M-b       - Backward over s-expression
;; C-M-k       - Kill s-expression
;; M-(         - Wrap in parentheses

Example Session:

;; myfile.scm

(define (fibonacci n)
  "Calculate nth Fibonacci number"
  (cond
    ((< n 2) n)
    (else (+ (fibonacci (- n 1))
             (fibonacci (- n 2))))))

;; Place cursor after (fibonacci 10) and press C-x C-e
(fibonacci 10)  ; → 55 (appears in minibuffer)

;; Or press C-c C-z to switch to REPL and interact there

VS Code with Scheme Extensions

Modern, popular editor:

Installation:

  1. Install VS Code: https://code.visualstudio.com/

  2. Install extensions:

    • “vscode-scheme” or “Racket”

    • “Rainbow Brackets”

    • “Bracket Pair Colorizer”

Configuration:

// settings.json (File → Preferences → Settings → Open JSON)
{
  "scheme.implementation": "racket",
  "scheme.trace.server": "verbose",
  "editor.fontSize": 14,
  "editor.tabSize": 2,
  "editor.insertSpaces": true,
  "editor.bracketPairColorization.enabled": true,
  "files.associations": {
    "*.scm": "scheme",
    "*.ss": "scheme",
    "*.rkt": "racket"
  }
}

Extensions for Scheme:

// Recommended extensions
{
  "recommendations": [
    "sjhuangx.vscode-scheme",
    "karyfoundation.racket",
    "CoenraadS.bracket-pair-colorizer-2",
    "2gua.rainbow-brackets",
    "eamodio.gitlens"
  ]
}

Tasks Configuration:

// .vscode/tasks.json
{
  "version": "2.0.0",
  "tasks": [
    {
      "label": "Run Racket",
      "type": "shell",
      "command": "racket",
      "args": ["${file}"],
      "group": {
        "kind": "build",
        "isDefault": true
      },
      "presentation": {
        "reveal": "always",
        "panel": "new"
      }
    },
    {
      "label": "Run Guile",
      "type": "shell",
      "command": "guile",
      "args": ["${file}"]
    }
  ]
}

Vim/Neovim Setup

For Vim enthusiasts:

" ~/.vimrc or ~/.config/nvim/init.vim

" Syntax highlighting
syntax on
filetype plugin indent on

" Scheme file detection
autocmd BufRead,BufNewFile *.scm,*.ss set filetype=scheme

" Indentation
autocmd FileType scheme setlocal
  \ expandtab
  \ shiftwidth=2
  \ softtabstop=2
  \ autoindent
  \ lisp

" Rainbow parentheses
" Install: https://github.com/luochen1990/rainbow
let g:rainbow_active = 1

" Paredit for Vim
" Install: https://github.com/vim-scripts/paredit.vim
autocmd FileType scheme call PareditInitBuffer()

" REPL integration with tmux or screen
" Send current form to REPL
function! SendToRepl()
  " Implementation depends on your setup
endfunction

nnoremap <leader>e :call SendToRepl()<CR>

" Auto-completion with coc.nvim or similar
" Install coc.nvim and coc-scheme

Slimv Plugin (REPL integration):

" Install Slimv: https://github.com/kovisoft/slimv

" Add to .vimrc
let g:slimv_swank_scheme = '!scheme --swank'
let g:slimv_scheme_implementation = 'racket'

" Key bindings:
" ,c - Connect to REPL
" ,d - Evaluate current form
" ,e - Evaluate current expression
" ,r - Evaluate region

11.4 REPL Configuration and Usage

Basic REPL Commands

;; Common REPL commands (implementation-specific)

;; Racket:
,enter module-name     ; Enter module
,exit                  ; Exit module
,describe symbol       ; Show documentation
,apropos pattern       ; Search for symbols
,help                  ; Show help

;; Guile:
,help                  ; List commands
,describe symbol       ; Documentation
,apropos pattern       ; Search
,use (module name)     ; Import module
,time expr             ; Time expression
,trace procedure       ; Trace calls
,untrace procedure     ; Stop tracing

;; Chez Scheme:
(load "file.scm")      ; Load file
(trace procedure)      ; Trace calls
(debug)                ; Enter debugger

Creating a Custom REPL

#lang racket

;; custom-repl.rkt
;; A custom REPL with history and helpers

(require readline/readline)
(require readline/pread)

(define *repl-history* '())
(define *repl-depth* 0)

(define (repl-read prompt)
  (display prompt)
  (read))

(define (repl-eval expr)
  (set! *repl-depth* (+ *repl-depth* 1))
  (define result (eval expr))
  (set! *repl-depth* (- *repl-depth* 1))
  result)

(define (repl-print result)
  (unless (void? result)
    (printf "⇒ ~a\n" result)))

(define (add-to-history expr)
  (set! *repl-history* (cons expr *repl-history*)))

(define (show-history)
  (for ([i (in-naturals 1)]
        [expr (in-list (reverse *repl-history*))])
    (printf "~a: ~a\n" i expr)))

(define (custom-repl)
  (with-handlers
      ([exn:break? (lambda (e)
                     (displayln "\nInterrupted")
                     (custom-repl))]
       [exn? (lambda (e)
               (displayln (exn-message e))
               (custom-repl))])
    
    (let ([input (repl-read (format "~a> " *repl-depth*))])
      (cond
        [(eof-object? input)
         (displayln "Bye!")]
        
        [(equal? input '(exit))
         (displayln "Bye!")]
        
        [(equal? input '(history))
         (show-history)
         (custom-repl)]
        
        [(equal? input '(help))
         (displayln "Commands: (exit) (history) (help)")
         (custom-repl)]
        
        [else
         (add-to-history input)
         (define result (repl-eval input))
         (repl-print result)
         (custom-repl)]))))

;; Run: racket custom-repl.rkt
(custom-repl)

REPL Helper Functions

;; helpers.scm
;; Load in REPL for convenience

;; Quick testing
(define (test name expr expected)
  (define result expr)
  (if (equal? result expected)
      (printf "✓ ~a passed\n" name)
      (printf "✗ ~a failed: expected ~a, got ~a\n"
              name expected result)))

;; Timing
(define-syntax time-it
  (syntax-rules ()
    [(time-it expr)
     (let ([start (current-inexact-milliseconds)])
       (define result expr)
       (define end (current-inexact-milliseconds))
       (printf "Time: ~a ms\n" (- end start))
       result)]))

;; Pretty printing
(define (pp expr)
  (pretty-print expr))

;; Documentation lookup
(define (doc symbol)
  (displayln (format "Looking up documentation for: ~a" symbol))
  ;; Implementation-specific
  )

;; Reload file
(define (reload file)
  (printf "Reloading ~a…\n" file)
  (load file))

;; Usage in REPL:
;; > (load "helpers.scm")
;; > (test "addition" (+ 1 2) 3)
;; ✓ addition passed
;; > (time-it (fibonacci 30))
;; Time: 234.5 ms
;; ⇒ 832040

11.5 Project Structure and Build Tools

Basic Project Structure

my-scheme-project/

├│── README.md

├│── LICENSE

├│── .gitignore

├│── src/

││ ├── main.scm

││ ├── utils.scm

││ └── algorithms/

││ ├── sorting.scm

││ └── searching.scm

├│── tests/

││ ├── test-utils.scm

││ └── test-algorithms.scm

├│── docs/

││ └── api.md └── examples/ └── demo.scm

Racket Project Structure

my-racket-project/

├│── info.rkt # Package metadata

├│── main.rkt # Entry point

├│── private/

││ ├── helpers.rkt

││ └── core.rkt

├│── tests/

││ └── test-main.rkt └── scribblings/ # Documentation └── manual.scrbl

info.rkt:

#lang info

(define collection "my-project")
(define version "1.0")
(define deps '("base" "rackunit-lib"))
(define build-deps '("scribble-lib" "racket-doc"))

(define scribblings '(("scribblings/manual.scrbl" ())))

main.rkt:

#lang racket/base

(require "private/core.rkt"
         "private/helpers.rkt")

(provide (all-from-out "private/core.rkt")
         run-program)

(define (run-program . args)
  (displayln "Running program…")
  ;; Main logic
  )

(module+ main
  (run-program))

(module+ test
  (require rackunit)
  (check-equal? (+ 1 2) 3))

Guile Project with Autotools

configure.ac:

AC_INIT([my-guile-project], [1.0])
AM_INIT_AUTOMAKE([foreign])
GUILE_PKG([3.0 2.2])
GUILE_PROGS
AC_CONFIG_FILES([Makefile])
AC_OUTPUT

Makefile.am:

SOURCES = \
  src/main.scm \
  src/utils.scm

GOBJECTS = $(SOURCES:%.scm=%.go)

nobase_mod_DATA = $(SOURCES)
nobase_go_DATA = $(GOBJECTS)

# Installation paths
moddir = $(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION)
godir = $(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache

%.go: %.scm
    $(GUILD) compile -o $@ $<

CLEANFILES = $(GOBJECTS)

Build and Install:

# Configure
./configure --prefix=/usr/local

# Build
make

# Install
sudo make install

Makefile for Any Scheme

# Makefile for generic Scheme project

SCHEME = racket
# Or: guile, chicken-csi, scheme (Chez), etc.

SRC_DIR = src
TEST_DIR = tests
BUILD_DIR = build

SOURCES = $(wildcard $(SRC_DIR)/*.scm)
TESTS = $(wildcard $(TEST_DIR)/*.scm)

.PHONY: all test clean run install

all: $(BUILD_DIR)/main

$(BUILD_DIR)/main: $(SOURCES)
    @mkdir -p $(BUILD_DIR)
    @echo "Building application…"
    $(SCHEME) --script src/main.scm

test:
    @echo "Running tests…"
    @for test in $(TESTS); do \
        echo "Testing $$test"; \
        $(SCHEME) --script $$test; \
    done

run: $(BUILD_DIR)/main
    @echo "Running application…"
    $(SCHEME) --script src/main.scm

clean:
    rm -rf $(BUILD_DIR)
    find . -name "*.zo" -delete
    find . -name "compiled" -type d -exec rm -rf {} +

install:
    @echo "Installing to /usr/local/bin…"
    # Implementation-specific

# Development helpers
repl:
    $(SCHEME)

lint:
    @echo "Linting code…"
    # Add linter if available

format:
    @echo "Formatting code…"
    # Add formatter if available

Chicken Scheme with Eggs

;; my-app.egg
((synopsis "My Scheme Application")
 (author "Your Name")
 (license "MIT")
 (dependencies base srfi-1 srfi-13)
 
 (components
  (extension my-app
   (source "my-app.scm"))))

;; Build and install:
;; chicken-install

11.6 Testing Frameworks

RackUnit (Racket)

#lang racket

(require rackunit)
(require rackunit/text-ui)

;; Code to test
(define (add a b)
  (+ a b))

(define (factorial n)
  (if (≤ n 1)
      1
      (* n (factorial (- n 1)))))

;; Test suite
(define math-tests
  (test-suite
   "Math operations"
   
   (test-case "Addition"
     (check-equal? (add 2 3) 5)
     (check-equal? (add -1 1) 0)
     (check-equal? (add 0 0) 0))
   
   (test-case "Factorial"
     (check-equal? (factorial 0) 1)
     (check-equal? (factorial 1) 1)
     (check-equal? (factorial 5) 120)
     (check-exn exn:fail? (lambda () (factorial -1))))
   
   (test-case "Edge cases"
     (check-true (number? (add 1 2)))
     (check-false (negative? (add 1 2))))))

;; Run tests
(run-tests math-tests)

;; Or use test submodule
(module+ test
  (require rackunit)
  
  (check-equal? (add 1 1) 2 "Basic addition")
  (check-not-equal? (add 1 2) 4 "Wrong addition"))

SRFI-64 (Portable Testing)

;; test-suite.scm
(import (scheme base)
        (srfi 64))  ; Testing framework

;; Code to test
(define (square x) (* x x))
(define (even? n) (= (modulo n 2) 0))

;; Tests
(test-begin "math-tests")

(test-group "square function"
  (test-equal "square of 2" 4 (square 2))
  (test-equal "square of -3" 9 (square -3))
  (test-equal "square of 0" 0 (square 0)))

(test-group "even? predicate"
  (test-assert "2 is even" (even? 2))
  (test-assert "3 is odd" (not (even? 3)))
  (test-assert "0 is even" (even? 0)))

(test-group "error handling"
  (test-error "division by zero"
    (/ 1 0)))

(test-end "math-tests")

;; Run: guile test-suite.scm
;; Or:  chibi-scheme test-suite.scm

Simple Custom Testing Framework

;; simple-test.scm
;; Minimal testing framework

(define *tests-passed* 0)
(define *tests-failed* 0)
(define *test-failures* '())

(define (reset-test-stats!)
  (set! *tests-passed* 0)
  (set! *tests-failed* 0)
  (set! *test-failures* '()))

(define (assert-equal name expected actual)
  (if (equal? expected actual)
      (begin
        (set! *tests-passed* (+ *tests-passed* 1))
        (printf "  ✓ ~a\n" name))
      (begin
        (set! *tests-failed* (+ *tests-failed* 1))
        (set! *test-failures*
              (cons (list name expected actual)

                    *test-failures*))
        (printf "  ✗ ~a\n    Expected: ~a\n    Got: ~a\n"
                name expected actual))))

(define (assert-true name condition)
  (assert-equal name #t condition))

(define (assert-false name condition)
  (assert-equal name #f condition))

(define (run-test-suite name thunk)
  (printf "\n≡ ~a ≡\n" name)
  (reset-test-stats!)
  (thunk)
  (printf "\nResults: ~a passed, ~a failed\n"

          *tests-passed* *tests-failed*)
  (if (> *tests-failed* 0)
      (begin
        (printf "\nFailures:\n")
        (for-each
         (lambda (failure)
           (printf "  ~a: expected ~a, got ~a\n"
                   (car failure)
                   (cadr failure)
                   (caddr failure)))
         (reverse *test-failures*)))))

;; Usage:
(run-test-suite "Math Tests"
  (lambda ()
    (assert-equal "addition" 5 (+ 2 3))
    (assert-equal "subtraction" 1 (- 3 2))
    (assert-true "positive?" (> 5 0))
    (assert-false "negative?" (< 5 0))))

11.7 Version Control Integration

Git Configuration

# .gitignore for Scheme projects

# Compiled files

*.zo

*.so

*.o

*.fasl

*.com

*.lib

*.dx64fsl

# Build directories
compiled/
build/
dist/

# IDE/Editor files
.vscode/
.idea/

*.swp

*~
.DS_Store

# REPL history
.racket-history
.guile_history

# Package management
.eggs/
eggs-install/

# Documentation builds
doc/
scribblings/compiled/

# Test coverage
coverage/

Pre-commit Hooks

#!/bin/bash
# .git/hooks/pre-commit

echo "Running pre-commit checks…"

# Check for syntax errors
for file in $(git diff --cached --name-only --diff-filter=ACM | grep '\.scm$\|\.rkt$'); do
    echo "Checking syntax: $file"
    
    # Racket
    if [[ $file ⩵ *.rkt ]]; then
        racket -e "(require syntax/module-reader)" "$file" > /dev/null 2>&1
        if [ $? -ne 0 ]; then
            echo "Syntax error in $file"
            exit 1
        fi
    fi
    
    # Guile
    if [[ $file ⩵ *.scm ]]; then
        guile --no-auto-compile -c "(load \"$file\")" > /dev/null 2>&1
        if [ $? -ne 0 ]; then
            echo "Syntax error in $file"
            exit 1
        fi
    fi
done

# Run tests
echo "Running tests…"
make test
if [ $? -ne 0 ]; then
    echo "Tests failed"
    exit 1
fi

echo "All checks passed!"
exit 0

11.8 Debugging Tools

Built-in Debugging

;; Racket debugging
#lang racket

(require racket/trace)

;; Trace function calls
(define (factorial n)
  (if (≤ n 1)
      1
      (* n (factorial (- n 1)))))

(trace factorial)
(factorial 5)
;; Output shows each call and return

;; Breakpoints (in DrRacket)
;; Click left of line number, then run in debug mode

;; Manual debugging
(define (debug-factorial n)
  (printf "factorial called with n=~a\n" n)
  (if (≤ n 1)
      (begin
        (printf "base case: returning 1\n")
        1)
      (let ([result (* n (debug-factorial (- n 1)))])
        (printf "n=~a, result=~a\n" n result)
        result)))

Logging Framework

#lang racket

;; logging.rkt
(define *log-level* 'info)  ; debug, info, warn, error

(define (set-log-level! level)
  (set! *log-level* level))

(define (level→number level)
  (case level
    [(debug) 0]
    [(info) 1]
    [(warn) 2]
    [(error) 3]
    [else 1]))

(define (should-log? level)
  (≥ (level→number level)
      (level→number *log-level*)))

(define (log level message . args)
  (when (should-log? level)
    (printf "[~a] ~a\n"
            (string-upcase (symbol→string level))
            (apply format message args))))

(define (log-debug msg . args)
  (apply log 'debug msg args))

(define (log-info msg . args)
  (apply log 'info msg args))

(define (log-warn msg . args)
  (apply log 'warn msg args))

(define (log-error msg . args)
  (apply log 'error msg args))

;; Usage:
(log-debug "Debug message: ~a" 42)
(log-info "Processing item ~a" "foo")
(log-warn "Low memory: ~a MB" 128)
(log-error "Failed to open file: ~a" "data.txt")

Performance Profiling

#lang racket

;; profiling.rkt
(require profile)

;; Profile specific functions
(define (slow-function n)
  (if (= n 0)
      0
      (+ 1 (slow-function (- n 1)))))

(define (fast-function n)
  (let loop ([i 0] [result 0])
    (if (= i n)
        result
        (loop (+ i 1) (+ result 1)))))

;; Profile comparison
(profile-thunk
 (lambda ()
   (slow-function 1000)
   (fast-function 1000)))

;; Memory profiling
(require profile/memory)

(memory-profile-thunk
 (lambda ()
   (define big-list (build-list 100000 values))
   (length big-list)))

11.9 Documentation Tools

Scribble (Racket)

#lang scribble/manual

@; manual.scrbl - Documentation in Scribble

@title{My Scheme Library}
@author{Your Name}

@section{Introduction}

This library provides useful utilities for Scheme programming.

@subsection{Installation}

Install using:
@commandline{raco pkg install my-library}

@section{API Reference}

@defproc[(add [a number?] [b number?]) number?]{
  Adds two numbers together.
  
  @examples[
    (add 2 3)
    (add -1 1)
  ]
}

@defproc[(factorial [n exact-nonnegative-integer?])
         exact-nonnegative-integer?]{
  Computes the factorial of @racket[n].
  
  @examples[
    (factorial 5)
    (factorial 0)
  ]
}

@; Build: scribble --pdf manual.scrbl

Inline Documentation

#lang racket

;; Example with good documentation

#|
Module: data-structures
Purpose: Common data structures and algorithms
Author: Your Name
Date: 2024-01-01
|#

(provide stack-new
         stack-push!
         stack-pop!
         stack-empty?)

;; ≡≡≡≡≡≡≡≡≡≡≡⩵
;; Stack Implementation
;; ≡≡≡≡≡≡≡≡≡≡≡⩵

;; Creates a new empty stack
;; Returns: A new stack object
(define (stack-new)
  (box '()))

;; Pushes an item onto the stack
;; stack : A stack object
;; item : Any value to push
;; Returns: void
;; Effect: Modifies the stack
(define (stack-push! stack item)
  (set-box! stack (cons item (unbox stack))))

;; Pops an item from the stack
;; stack : A stack object
;; Returns: The top item
;; Effect: Removes the top item from stack
;; Raises: error if stack is empty
(define (stack-pop! stack)
  (if (stack-empty? stack)
      (error "Cannot pop from empty stack")
      (let ([top (car (unbox stack))])
        (set-box! stack (cdr (unbox stack)))
        top)))

;; Checks if stack is empty
;; stack : A stack object
;; Returns: #t if empty, #f otherwise
(define (stack-empty? stack)
  (null? (unbox stack)))

11.10 Continuous Integration

GitHub Actions for Scheme

# .github/workflows/test.yml

name: Test

on:
  push:
    branches: [ main, develop ]
  pull_request:
    branches: [ main ]

jobs:
  test-racket:
    runs-on: ubuntu-latest
    
    steps:

    - uses: actions/checkout@v3
    

    - name: Install Racket
      uses: Bogdanp/setup-racket@v1.9
      with:
        version: '8.10'
    

    - name: Install dependencies
      run: raco pkg install --auto --skip-installed
    

    - name: Run tests
      run: raco test .
    

    - name: Build documentation
      run: raco scribble --pdf manual.scrbl

  test-guile:
    runs-on: ubuntu-latest
    
    steps:

    - uses: actions/checkout@v3
    

    - name: Install Guile
      run: |
        sudo apt-get update
        sudo apt-get install -y guile-3.0
    

    - name: Run tests
      run: guile --no-auto-compile tests/run-all.scm

Travis CI Configuration

# .travis.yml

language: scheme

scheme:

  - racket

  - guile

env:

  - RACKET_VERSION=8.10

install:

  - if [ "$TRAVIS_SCHEME" = "racket" ]; then
      raco pkg install --auto --skip-installed;
    fi

script:

  - if [ "$TRAVIS_SCHEME" = "racket" ]; then
      raco test .;
    elif [ "$TRAVIS_SCHEME" = "guile" ]; then
      guile tests/run-all.scm;
    fi

Summary

This chapter covered:

  1. Choosing an Implementation: Racket, Guile, Chez, Chicken, MIT/GNU

  2. Editor Setup: DrRacket, Emacs/Geiser, VS Code, Vim

  3. REPL Usage: Commands, customization, helpers

  4. Project Structure: Organizing code and files

  5. Build Tools: Makefiles, package systems

  6. Testing: RackUnit, SRFI-64, custom frameworks

  7. Version Control: Git configuration and hooks

  8. Debugging: Tracing, logging, profiling

  9. Documentation: Scribble, inline docs

  10. CI/CD: GitHub Actions, Travis CI

Key Recommendations:

  • Beginners: Start with Racket and DrRacket

  • Scripting: Use Guile

  • Performance: Use Chez Scheme

  • C Integration: Use Chicken Scheme

  • SICP Learning: Use MIT/GNU Scheme

Next Steps:

  • Choose your implementation

  • Set up your editor

  • Configure REPL

  • Start a sample project

  • Write tests early

  • Document as you code

Chapter 12: Text Processing and Parsing

12.1 Introduction to Text Processing in Scheme

Scheme provides powerful tools for text manipulation, string processing, and parsing. This chapter explores practical techniques for working with textual data.

Why Text Processing Matters

;; Text processing applications:
;; - Log file analysis
;; - Data extraction from documents
;; - Configuration file parsing
;; - Web scraping
;; - Lexical analysis for compilers
;; - Natural language processing
;; - Report generation

String Basics Review

;; String creation
(define str1 "Hello, World!")
(define str2 (make-string 5 #\*))  ; "*****"
(define str3 (string #\a #\b #\c)) ; "abc"

;; String properties
(string-length "Hello")              ; ⇒ 5
(string-ref "Hello" 0)               ; ⇒ #\H
(string=? "abc" "abc")               ; ⇒ #t
(string-ci=? "ABC" "abc")            ; ⇒ #t (case-insensitive)

;; String comparison
(string<? "apple" "banana")          ; ⇒ #t
(string>? "zebra" "apple")           ; ⇒ #t
(string≤? "cat" "cat")              ; ⇒ #t

;; Immutable operations
(substring "Hello, World!" 0 5)      ; ⇒ "Hello"
(string-append "Hello" " " "World")  ; ⇒ "Hello World"

12.2 String Manipulation

Basic String Operations

;; string-utils.scm

;; Trim whitespace from both ends
(define (string-trim str)
  (define (whitespace? c)
    (or (char=? c #\space)
        (char=? c #\tab)
        (char=? c #\newline)
        (char=? c #\return)))
  
  (let* ([chars (string→list str)]
         [trimmed (reverse 
                   (drop-while whitespace?
                     (reverse
                       (drop-while whitespace? chars))))])
    (list→string trimmed)))

;; Helper: drop-while
(define (drop-while pred lst)
  (cond
    [(null? lst) '()]
    [(pred (car lst)) (drop-while pred (cdr lst))]
    [else lst]))

;; Examples:
(string-trim "  hello  ")      ; ⇒ "hello"
(string-trim "\n\tworld\n")    ; ⇒ "world"

;; Left trim
(define (string-trim-left str)
  (list→string
    (drop-while
      (lambda (c) (char-whitespace? c))
      (string→list str))))

;; Right trim
(define (string-trim-right str)
  (list→string
    (reverse
      (drop-while
        (lambda (c) (char-whitespace? c))
        (reverse (string→list str))))))

;; Padding
(define (string-pad-left str width char)
  (let ([len (string-length str)])
    (if (≥ len width)
        str
        (string-append
          (make-string (- width len) char)
          str))))

(define (string-pad-right str width char)
  (let ([len (string-length str)])
    (if (≥ len width)
        str
        (string-append
          str
          (make-string (- width len) char)))))

;; Examples:
(string-pad-left "42" 5 #\0)    ; ⇒ "00042"
(string-pad-right "Hi" 6 #\.)   ; ⇒ "Hi…."

String Splitting and Joining

;; Split string by delimiter
(define (string-split str delim)
  (define (split-helper chars current result)
    (cond
      [(null? chars)
       (reverse (cons (list→string (reverse current)) result))]
      
      [(char=? (car chars) delim)
       (split-helper (cdr chars)
                     '()
                     (cons (list→string (reverse current)) result))]
      
      [else
       (split-helper (cdr chars)
                     (cons (car chars) current)
                     result)]))
  
  (split-helper (string→list str) '() '()))

;; Examples:
(string-split "apple,banana,cherry" #\,)
; ⇒ ("apple" "banana" "cherry")

(string-split "one:two:three" #\:)
; ⇒ ("one" "two" "three")

;; Split on whitespace
(define (string-split-whitespace str)
  (define (whitespace? c)
    (or (char=? c #\space)
        (char=? c #\tab)
        (char=? c #\newline)))
  
  (define (split-ws chars current result)
    (cond
      [(null? chars)
       (if (null? current)
           (reverse result)
           (reverse (cons (list→string (reverse current)) result)))]
      
      [(whitespace? (car chars))
       (if (null? current)
           (split-ws (cdr chars) '() result)
           (split-ws (cdr chars) '() 
                     (cons (list→string (reverse current)) result)))]
      
      [else
       (split-ws (cdr chars) (cons (car chars) current) result)]))
  
  (split-ws (string→list str) '() '()))

;; Examples:
(string-split-whitespace "  one  two   three  ")
; ⇒ ("one" "two" "three")

;; Join strings with delimiter
(define (string-join strings delim)
  (if (null? strings)
      ""
      (let loop ([strs (cdr strings)]
                 [result (car strings)])
        (if (null? strs)
            result
            (loop (cdr strs)
                  (string-append result delim (car strs)))))))

;; Examples:
(string-join '("apple" "banana" "cherry") ", ")
; ⇒ "apple, banana, cherry"

(string-join '("one" "two" "three") " ")
; ⇒ "one two three"

Case Conversion

;; Convert to uppercase
(define (string-upcase str)
  (list→string
    (map char-upcase (string→list str))))

;; Convert to lowercase
(define (string-downcase str)
  (list→string
    (map char-downcase (string→list str))))

;; Title case (first letter of each word capitalized)
(define (string-titlecase str)
  (define (capitalize-word word)
    (if (= (string-length word) 0)
        word
        (string-append
          (string-upcase (substring word 0 1))
          (string-downcase (substring word 1)))))
  
  (string-join
    (map capitalize-word
         (string-split-whitespace str))
    " "))

;; Examples:
(string-upcase "hello world")       ; ⇒ "HELLO WORLD"
(string-downcase "SCHEME")          ; ⇒ "scheme"
(string-titlecase "hello world")    ; ⇒ "Hello World"

String Searching

;; Find substring position
(define (string-index str substr)
  (define str-len (string-length str))
  (define sub-len (string-length substr))
  
  (define (matches? pos)
    (let loop ([i 0])
      (cond
        [(= i sub-len) #t]
        [(not (char=? (string-ref str (+ pos i))
                      (string-ref substr i)))
         #f]
        [else (loop (+ i 1))])))
  
  (let loop ([pos 0])
    (cond
      [(> (+ pos sub-len) str-len) #f]
      [(matches? pos) pos]
      [else (loop (+ pos 1))])))

;; Examples:
(string-index "hello world" "world")  ; ⇒ 6
(string-index "hello world" "foo")    ; ⇒ #f

;; String contains
(define (string-contains? str substr)
  (and (string-index str substr) #t))

(string-contains? "hello world" "world")  ; ⇒ #t
(string-contains? "hello world" "foo")    ; ⇒ #f

;; String starts with
(define (string-starts-with? str prefix)
  (let ([str-len (string-length str)]
        [pre-len (string-length prefix)])
    (and (≥ str-len pre-len)
         (string=? (substring str 0 pre-len) prefix))))

;; String ends with
(define (string-ends-with? str suffix)
  (let ([str-len (string-length str)]
        [suf-len (string-length suffix)])
    (and (≥ str-len suf-len)
         (string=? (substring str (- str-len suf-len)) suffix))))

;; Examples:
(string-starts-with? "hello world" "hello")  ; ⇒ #t
(string-ends-with? "hello world" "world")    ; ⇒ #t

String Replacement

;; Replace all occurrences
(define (string-replace str old new)
  (define old-len (string-length old))
  (define str-len (string-length str))
  
  (define (replace-helper pos result)
    (cond
      [(≥ pos str-len) result]
      
      [(and (≤ (+ pos old-len) str-len)
            (string=? (substring str pos (+ pos old-len)) old))
       (replace-helper (+ pos old-len)
                       (string-append result new))]
      
      [else
       (replace-helper (+ pos 1)
                       (string-append result
                                      (string (string-ref str pos))))]))
  
  (replace-helper 0 ""))

;; Examples:
(string-replace "hello world" "world" "scheme")
; ⇒ "hello scheme"

(string-replace "aaabbbccc" "bb" "XX")
; ⇒ "aaaXXbccc"

;; Replace first occurrence only
(define (string-replace-first str old new)
  (let ([pos (string-index str old)])
    (if pos
        (string-append
          (substring str 0 pos)
          new
          (substring str (+ pos (string-length old))))
        str)))

12.3 Pattern Matching with Regular Expressions

Simple Pattern Matching

;; Simple wildcard matching (* matches any sequence)
(define (wildcard-match? pattern str)
  (define (match-helper p-chars s-chars)
    (cond
      [(and (null? p-chars) (null? s-chars)) #t]
      [(null? p-chars) #f]
      [(null? s-chars) (and (char=? (car p-chars) #\*)
                            (match-helper (cdr p-chars) '()))]
      
      [(char=? (car p-chars) #\*)
       (or (match-helper (cdr p-chars) s-chars)     ; * matches nothing
           (match-helper p-chars (cdr s-chars)))]   ; * matches one char
      
      [(char=? (car p-chars) (car s-chars))
       (match-helper (cdr p-chars) (cdr s-chars))]
      
      [else #f]))
  
  (match-helper (string→list pattern) (string→list str)))

;; Examples:
(wildcard-match? "hello*" "hello world")      ; ⇒ #t
(wildcard-match? "h*o" "hello")               ; ⇒ #t
(wildcard-match? "*world" "hello world")      ; ⇒ #t
(wildcard-match? "h*l*o" "hello")             ; ⇒ #t

Regular Expressions (Using SRFI-115 or library)

#lang racket

(require racket/match)

;; Racket's regexp facilities
(define email-pattern
  #rx"[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\\.[a-zA-Z]{2,}")

;; Check if string matches pattern
(define (valid-email? str)
  (regexp-match? email-pattern str))

;; Examples:
(valid-email? "user@example.com")     ; ⇒ #t
(valid-email? "invalid.email")        ; ⇒ #f

;; Extract matches
(regexp-match #rx"[0-9]+" "Age: 25")  ; ⇒ '("25")
(regexp-match #rx"([0-9]+)-([0-9]+)" "10-20")
; ⇒ '("10-20" "10" "20")

;; Find all matches
(regexp-match* #rx"[0-9]+" "Numbers: 1, 2, 3, 42")
; ⇒ '("1" "2" "3" "42")

;; Replace with regex
(regexp-replace #rx"[0-9]+" "Version 3.14" "X")
; ⇒ "Version X"

(regexp-replace* #rx"[aeiou]" "hello world" "*")
; ⇒ "h*ll* w*rld"

;; Common patterns
(define url-pattern
  #rx"https?://[a-zA-Z0-9.-]+(?:/[^\\s]*)?")

(define phone-pattern
  #rx"\\(?([0-9]{3})\\)?[-. ]?([0-9]{3})[-. ]?([0-9]{4})")

(define date-pattern
  #rx"([0-9]{4})-([0-9]{2})-([0-9]{2})")

;; Validation helpers
(define (valid-url? str)
  (regexp-match? url-pattern str))

(define (extract-phone str)
  (regexp-match phone-pattern str))

(define (parse-date str)
  (let ([match (regexp-match date-pattern str)])
    (if match
        (map string→number (cdr match))  ; (year month day)
        #f)))

;; Examples:
(valid-url? "https://example.com")          ; ⇒ #t
(extract-phone "(555) 123-4567")            
; ⇒ '("(555) 123-4567" "555" "123" "4567")
(parse-date "2024-01-15")                   ; ⇒ (2024 1 15)

Building a Simple Regex Engine

;; Simple regex matcher (subset of regex features)
;; Supports: literals, ., *, +, ?, […]

(define (regex-match pattern str)
  (define (char-matches? pattern-char str-char)
    (or (char=? pattern-char #\.)  ; . matches anything
        (char=? pattern-char str-char)))
  
  (define (match-char-class class str-char)
    (member str-char (string→list class)))
  
  (define (match-helper p-chars s-chars)
    (cond
      [(null? p-chars) (null? s-chars)]
      [(null? s-chars) #f]
      
      ;; Check for quantifiers
      [(and (pair? (cdr p-chars))
            (char=? (cadr p-chars) #\*))
       ;; * matches 0 or more
       (or (match-helper (cddr p-chars) s-chars)        ; match 0
           (and (char-matches? (car p-chars) (car s-chars))
                (match-helper p-chars (cdr s-chars))))] ; match more
      
      [(and (pair? (cdr p-chars))
            (char=? (cadr p-chars) #\+))
       ;; + matches 1 or more
       (and (char-matches? (car p-chars) (car s-chars))
            (or (match-helper (cddr p-chars) (cdr s-chars))
                (match-helper p-chars (cdr s-chars))))]
      
      [(char-matches? (car p-chars) (car s-chars))
       (match-helper (cdr p-chars) (cdr s-chars))]
      
      [else #f]))
  
  (match-helper (string→list pattern) (string→list str)))

;; Examples:
(regex-match "ab*c" "ac")      ; ⇒ #t  (b appears 0 times)
(regex-match "ab*c" "abc")     ; ⇒ #t  (b appears 1 time)
(regex-match "ab*c" "abbbbc")  ; ⇒ #t  (b appears 4 times)
(regex-match "a.c" "abc")      ; ⇒ #t  (. matches b)

12.4 Lexical Analysis

Building a Tokenizer

;; tokenizer.scm
;; Tokenize source code into meaningful units

(define-struct token (type value line column))

;; Token types
(define TOKEN-NUMBER 'number)
(define TOKEN-STRING 'string)
(define TOKEN-IDENTIFIER 'identifier)
(define TOKEN-OPERATOR 'operator)
(define TOKEN-KEYWORD 'keyword)
(define TOKEN-LPAREN 'lparen)
(define TOKEN-RPAREN 'rparen)
(define TOKEN-EOF 'eof)

(define keywords '("if" "then" "else" "while" "define" "lambda"))

(define (char-operator? c)
  (member c '(#\+ #\- #\* #\/ #\= #\< #\>)))

(define (tokenize input)
  (define line 1)
  (define column 1)
  (define pos 0)
  (define len (string-length input))
  
  (define (current-char)
    (if (≥ pos len) #\nul (string-ref input pos)))
  
  (define (peek-char)
    (if (≥ (+ pos 1) len) #\nul (string-ref input (+ pos 1))))
  
  (define (advance!)
    (when (< pos len)
      (when (char=? (current-char) #\newline)
        (set! line (+ line 1))
        (set! column 1))
      (set! pos (+ pos 1))
      (set! column (+ column 1))))
  
  (define (skip-whitespace!)
    (when (and (< pos len)
               (char-whitespace? (current-char)))
      (advance!)
      (skip-whitespace!)))
  
  (define (read-number)
    (let loop ([digits ""])
      (let ([c (current-char)])
        (if (char-numeric? c)
            (begin
              (advance!)
              (loop (string-append digits (string c))))
            (make-token TOKEN-NUMBER
                       (string→number digits)
                       line
                       column)))))
  
  (define (read-identifier)
    (let loop ([chars ""])
      (let ([c (current-char)])
        (if (or (char-alphabetic? c)
                (char-numeric? c)
                (char=? c #\-)
                (char=? c #\_))
            (begin
              (advance!)
              (loop (string-append chars (string c))))
            (let ([word chars])
              (make-token
                (if (member word keywords)
                    TOKEN-KEYWORD
                    TOKEN-IDENTIFIER)
                word
                line
                column))))))
  
  (define (read-string)
    (advance!)  ; Skip opening quote
    (let loop ([chars ""])
      (let ([c (current-char)])
        (cond
          [(char=? c #\")
           (advance!)
           (make-token TOKEN-STRING chars line column)]
          
          [(char=? c #\\)
           (advance!)
           (loop (string-append chars (string (current-char))))]
          
          [else
           (advance!)
           (loop (string-append chars (string c)))]))))
  
  (define (next-token)
    (skip-whitespace!)
    
    (let ([c (current-char)])
      (cond
        [(≥ pos len)
         (make-token TOKEN-EOF "" line column)]
        
        [(char-numeric? c)
         (read-number)]
        
        [(or (char-alphabetic? c) (char=? c #\_))
         (read-identifier)]
        
        [(char=? c #\")
         (read-string)]
        
        [(char=? c #\()
         (advance!)
         (make-token TOKEN-LPAREN "(" line column)]
        
        [(char=? c #\))
         (advance!)
         (make-token TOKEN-RPAREN ")" line column)]
        
        [(char-operator? c)
         (let ([op (string c)])
           (advance!)
           (make-token TOKEN-OPERATOR op line column))]
        
        [else
         (error "Unexpected character:" c)])))
  
  ;; Main tokenization loop
  (let loop ([tokens '()])
    (let ([tok (next-token)])
      (if (eq? (token-type tok) TOKEN-EOF)
          (reverse (cons tok tokens))
          (loop (cons tok tokens))))))

;; Example usage:
(tokenize "x = 42 + y")
; ⇒ List of tokens:
;   (identifier "x") (operator "=") (number 42)
;   (operator "+") (identifier "y") (eof "")

(tokenize "if (x > 10) then y else z")
; ⇒ Tokens for conditional expression

Lexer with State Machine

;; State-based lexer for more complex grammars

(define-struct lexer (input pos line column state))

(define STATE-START 'start)
(define STATE-IN-NUMBER 'in-number)
(define STATE-IN-IDENTIFIER 'in-identifier)
(define STATE-IN-STRING 'in-string)
(define STATE-IN-COMMENT 'in-comment)

(define (make-lexer input)
  (make-lexer input 0 1 1 STATE-START))

(define (lexer-current-char lex)
  (if (≥ (lexer-pos lex) (string-length (lexer-input lex)))
      #\nul
      (string-ref (lexer-input lex) (lexer-pos lex))))

(define (lexer-advance lex)
  (let ([c (lexer-current-char lex)])
    (if (char=? c #\newline)
        (make-lexer (lexer-input lex)
                   (+ (lexer-pos lex) 1)
                   (+ (lexer-line lex) 1)
                   1
                   (lexer-state lex))
        (make-lexer (lexer-input lex)
                   (+ (lexer-pos lex) 1)
                   (lexer-line lex)
                   (+ (lexer-column lex) 1)
                   (lexer-state lex)))))

(define (lexer-next-token lex)
  (case (lexer-state lex)
    [(start)
     (let ([c (lexer-current-char lex)])
       (cond
         [(char-whitespace? c)
          (lexer-next-token (lexer-advance lex))]
         
         [(char-numeric? c)
          (lexer-next-token
            (struct-copy lexer lex [state STATE-IN-NUMBER]))]
         
         [(char-alphabetic? c)
          (lexer-next-token
            (struct-copy lexer lex [state STATE-IN-IDENTIFIER]))]
         
         ;; … other transitions
         ))]
    
    [(in-number)
     ;; Collect digits and create number token
     ;; Then transition back to START
     ]
    
    ;; … other states
    ))

12.5 Parsing Techniques

Recursive Descent Parser

;; parser.scm
;; Recursive descent parser for arithmetic expressions

;; Grammar:
;; expr   → term (('+' | '-') term)*
;; term   → factor (('*' | '/') factor)*
;; factor → number | '(' expr ')'

(define (parse-expression tokens)
  (define pos 0)
  
  (define (current-token)
    (if (< pos (length tokens))
        (list-ref tokens pos)
        (make-token TOKEN-EOF "" 0 0)))
  
  (define (advance!)
    (set! pos (+ pos 1)))
  
  (define (expect type)
    (let ([tok (current-token)])
      (if (eq? (token-type tok) type)
          (begin (advance!) tok)
          (error "Expected" type "but got" (token-type tok)))))
  
  (define (parse-factor)
    (let ([tok (current-token)])
      (case (token-type tok)
        [(number)
         (advance!)
         (token-value tok)]
        
        [(lparen)
         (advance!)
         (let ([expr (parse-expr)])
           (expect TOKEN-RPAREN)
           expr)]
        
        [else
         (error "Unexpected token in factor:" tok)])))
  
  (define (parse-term)
    (let ([left (parse-factor)])
      (let loop ([result left])
        (let ([tok (current-token)])
          (if (and (eq? (token-type tok) TOKEN-OPERATOR)
                   (or (string=? (token-value tok) "*")
                       (string=? (token-value tok) "/")))
              (let ([op (token-value tok)])
                (advance!)
                (let ([right (parse-factor)])
                  (loop (list op result right))))
              result)))))
  
  (define (parse-expr)
    (let ([left (parse-term)])
      (let loop ([result left])
        (let ([tok (current-token)])
          (if (and (eq? (token-type tok) TOKEN-OPERATOR)
                   (or (string=? (token-value tok) "+")
                       (string=? (token-value tok) "-")))
              (let ([op (token-value tok)])
                (advance!)
                (let ([right (parse-term)])
                  (loop (list op result right))))
              result)))))
  
  (parse-expr))

;; Example:
(define tokens (tokenize "2 + 3 * 4"))
(parse-expression tokens)
; ⇒ ("+" 2 ("*" 3 4))

;; Represents the AST for 2 + (3 * 4)

Parser Combinators

;; Functional parser combinators

;; A parser is a function: string → (result, remaining-string) or #f

(define (parse-char c)
  (lambda (input)
    (if (and (not (string=? input ""))
             (char=? (string-ref input 0) c))
        (cons c (substring input 1))
        #f)))

(define (parse-string str)
  (lambda (input)
    (let ([len (string-length str)])
      (if (and (≥ (string-length input) len)
               (string=? (substring input 0 len) str))
          (cons str (substring input len))
          #f))))

;; Sequence combinator
(define (parse-seq p1 p2)
  (lambda (input)
    (let ([r1 (p1 input)])
      (if r1
          (let ([r2 (p2 (cdr r1))])
            (if r2
                (cons (list (car r1) (car r2)) (cdr r2))
                #f))
          #f))))

;; Choice combinator
(define (parse-or p1 p2)
  (lambda (input)
    (or (p1 input) (p2 input))))

;; Many combinator (0 or more)
(define (parse-many parser)
  (lambda (input)
    (let loop ([inp input] [results '()])
      (let ([result (parser inp)])
        (if result
            (loop (cdr result) (cons (car result) results))
            (cons (reverse results) inp))))))

;; Map result
(define (parse-map parser f)
  (lambda (input)
    (let ([result (parser input)])
      (if result
          (cons (f (car result)) (cdr result))
          #f))))

;; Example: Parse digit
(define (char-digit? c)
  (and (char≥? c #\0) (char≤? c #\9)))

(define parse-digit
  (lambda (input)
    (if (and (not (string=? input ""))
             (char-digit? (string-ref input 0)))
        (cons (string-ref input 0) (substring input 1))
        #f)))

;; Parse number (one or more digits)
(define parse-number
  (parse-map
    (parse-many parse-digit)
    (lambda (digits)
      (string→number (list→string digits)))))

;; Example usage:
((parse-string "hello") "hello world")
; ⇒ ("hello" . " world")

((parse-number) "42abc")
; ⇒ (42 . "abc")

((parse-many (parse-char #\a)) "aaab")
; ⇒ ((#\a #\a #\a) . "b")

S-Expression Parser

;; Parse S-expressions from strings

(define (parse-sexp str)
  (define pos 0)
  (define len (string-length str))
  
  (define (current-char)
    (if (< pos len)
        (string-ref str pos)
        #\nul))
  
  (define (advance!)
    (set! pos (+ pos 1)))
  
  (define (skip-whitespace!)
    (when (and (< pos len)
               (char-whitespace? (current-char)))
      (advance!)
      (skip-whitespace!)))
  
  (define (read-atom)
    (let loop ([chars '()])
      (let ([c (current-char)])
        (if (or (char-whitespace? c)
                (char=? c #\()
                (char=? c #\))
                (≥ pos len))
            (let ([atom (list→string (reverse chars))])
              (cond
                [(string→number atom) ⇒ values]
                [(string=? atom "#t") #t]
                [(string=? atom "#f") #f]
                [else (string→symbol atom)]))
            (begin
              (advance!)
              (loop (cons c chars)))))))
  
  (define (read-list)
    (advance!)  ; Skip '('
    (skip-whitespace!)
    
    (if (char=? (current-char) #\))
        (begin (advance!) '())
        (let loop ([elements '()])
          (skip-whitespace!)
          (cond
            [(char=? (current-char) #\))
             (advance!)
             (reverse elements)]
            
            [else
             (loop (cons (read-sexp-helper) elements))]))))
  
  (define (read-sexp-helper)
    (skip-whitespace!)
    (let ([c (current-char)])
      (cond
        [(≥ pos len) (error "Unexpected end of input")]
        [(char=? c #\() (read-list)]
        [(char=? c #\)) (error "Unexpected )")]
        [else (read-atom)])))
  
  (read-sexp-helper))

;; Examples:
(parse-sexp "42")                    ; ⇒ 42
(parse-sexp "hello")                 ; ⇒ 'hello
(parse-sexp "(+ 1 2)")               ; ⇒ '(+ 1 2)
(parse-sexp "(define (f x) (* x x))")
; ⇒ '(define (f x) (* x x))

12.6 CSV and Data Format Parsing

CSV Parser

;; csv-parser.scm

(define (parse-csv-line line)
  (define (parse-field chars in-quotes? current fields)
    (cond
      [(null? chars)
       (reverse (cons (list→string (reverse current)) fields))]
      
      [(and (char=? (car chars) #\")
            (not in-quotes?))
       (parse-field (cdr chars) #t current fields)]
      
      [(and (char=? (car chars) #\")
            in-quotes?)
       ;; Check for escaped quote
       (if (and (pair? (cdr chars))
                (char=? (cadr chars) #\"))
           (parse-field (cddr chars) #t
                       (cons #\" current) fields)
           (parse-field (cdr chars) #f current fields))]
      
      [(and (char=? (car chars) #\,)
            (not in-quotes?))
       (parse-field (cdr chars) #f '()
                   (cons (list→string (reverse current)) fields))]
      
      [else
       (parse-field (cdr chars) in-quotes?
                   (cons (car chars) current) fields)]))
  
  (parse-field (string→list line) #f '() '()))

;; Parse entire CSV file
(define (parse-csv text)
  (map parse-csv-line
       (filter (lambda (s) (not (string=? s "")))
               (string-split text #\newline))))

;; Example:
(parse-csv-line "name,age,city")
; ⇒ ("name" "age" "city")

(parse-csv-line "\"Smith, John\",42,\"New York\"")
; ⇒ ("Smith, John" "42" "New York")

(parse-csv "name,age\nAlice,30\nBob,25")
; ⇒ (("name" "age") ("Alice" "30") ("Bob" "25"))

;; CSV with headers
(define (parse-csv-with-headers text)
  (let* ([lines (string-split text #\newline)]
         [headers (parse-csv-line (car lines))]
         [rows (map parse-csv-line (cdr lines))])
    
    (map (lambda (row)
           (map cons headers row))
         rows)))

;; Example:
(parse-csv-with-headers "name,age\nAlice,30\nBob,25")
; ⇒ ((("name" . "Alice") ("age" . "30"))
;     (("name" . "Bob") ("age" . "25")))

JSON Parser (Simplified)

;; Simple JSON parser

(define (parse-json str)
  (define pos 0)
  (define len (string-length str))
  
  (define (current-char)
    (if (< pos len) (string-ref str pos) #\nul))
  
  (define (advance!)
    (set! pos (+ pos 1)))
  
  (define (skip-whitespace!)
    (when (and (< pos len)
               (char-whitespace? (current-char)))
      (advance!)
      (skip-whitespace!)))
  
  (define (parse-string)
    (advance!)  ; Skip opening "
    (let loop ([chars '()])
      (let ([c (current-char)])
        (cond
          [(char=? c #\")
           (advance!)
           (list→string (reverse chars))]
          
          [(char=? c #\\)
           (advance!)
           (loop (cons (current-char) chars))]
          
          [else
           (advance!)
           (loop (cons c chars))]))))
  
  (define (parse-number)
    (let loop ([chars '()])
      (let ([c (current-char)])
        (if (or (char-numeric? c)
                (char=? c #\.)
                (char=? c #\-)
                (char=? c #\e)
                (char=? c #\E))
            (begin
              (advance!)
              (loop (cons c chars)))
            (string→number (list→string (reverse chars)))))))
  
  (define (parse-array)
    (advance!)  ; Skip [
    (skip-whitespace!)
    
    (if (char=? (current-char) #\])
        (begin (advance!) '())
        (let loop ([elements '()])
          (let ([elem (parse-value)])
            (skip-whitespace!)
            (cond
              [(char=? (current-char) #\])
               (advance!)
               (reverse (cons elem elements))]
              
              [(char=? (current-char) #\,)
               (advance!)
               (skip-whitespace!)
               (loop (cons elem elements))]
              
              [else
               (error "Expected , or ]")])))))
  
  (define (parse-object)
    (advance!)  ; Skip {
    (skip-whitespace!)
    
    (if (char=? (current-char) #\})
        (begin (advance!) '())
        (let loop ([pairs '()])
          (skip-whitespace!)
          (let* ([key (parse-string)]
                 [_ (skip-whitespace!)]
                 [_ (if (char=? (current-char) #\:)
                        (advance!)
                        (error "Expected :"))]
                 [_ (skip-whitespace!)]
                 [value (parse-value)])
            (skip-whitespace!)
            (cond
              [(char=? (current-char) #\})
               (advance!)
               (reverse (cons (cons key value) pairs))]
              
              [(char=? (current-char) #\,)
               (advance!)
               (loop (cons (cons key value) pairs))]
              
              [else
               (error "Expected , or }")])))))
  
  (define (parse-value)
    (skip-whitespace!)
    (let ([c (current-char)])
      (cond
        [(char=? c #\") (parse-string)]
        [(char=? c #\{) (parse-object)]
        [(char=? c #\[) (parse-array)]
        [(or (char-numeric? c) (char=? c #\-)) (parse-number)]
        [(char=? c #\t)
         (advance!) (advance!) (advance!) (advance!) #t]
        [(char=? c #\f)
         (advance!) (advance!) (advance!) (advance!) (advance!) #f]
        [(char=? c #\n)
         (advance!) (advance!) (advance!) (advance!) 'null]
        [else (error "Unexpected character:" c)])))
  
  (parse-value))

;; Examples:
(parse-json "\"hello\"")              ; ⇒ "hello"
(parse-json "42")                     ; ⇒ 42
(parse-json "[1, 2, 3]")              ; ⇒ (1 2 3)
(parse-json "{\"name\": \"Alice\", \"age\": 30}")
; ⇒ (("name" . "Alice") ("age" . 30))

12.7 Template Processing

Simple Template Engine

;; template-engine.scm
;; Process templates with {{variable}} syntax

(define (render-template template context)
  (define (find-var-end str pos)
    (string-index str "}}" pos))
  
  (define (render-helper str pos result)
    (let ([var-start (string-index str "{{")])
      (if (not var-start)
          (string-append result str)
          (let ([var-end (find-var-end str (+ var-start 2))])
            (if (not var-end)
                (error "Unclosed template variable")
                (let* ([before (substring str 0 var-start)]
                       [var-name (substring str
                                          (+ var-start 2)
                                          var-end)]
                       [var-value (cdr (assoc var-name context))]
                       [after (substring str (+ var-end 2))])
                  (render-helper after
                               0
                               (string-append result before var-value))))))))
  
  (render-helper template 0 ""))

;; Helper: string-index (defined earlier)

;; Example:
(define template "Hello, {{name}}! You are {{age}} years old.")
(define context '(("name" . "Alice") ("age" . "30")))

(render-template template context)
; ⇒ "Hello, Alice! You are 30 years old."

;; More complex templates with loops and conditionals
(define (render-template-advanced template context)
  ;; Supports:
  ;; {{var}}           - variable substitution
  ;; {{#list}}…{{/list}} - loops
  ;; {{?cond}}…{{/cond}} - conditionals
  
  ;; Implementation left as exercise
  )

12.8 Text Generation

Report Generator

;; report-generator.scm

(define (generate-table data headers)
  (define (max-width column)
    (apply max
           (cons (string-length column)
                 (map (lambda (row)
                        (string-length
                          (cdr (assoc column row))))
                      data))))
  
  (define widths
    (map max-width headers))
  
  (define (pad str width)
    (string-pad-right str width #\space))
  
  (define (draw-line)
    (string-append
      "+"
      (string-join
        (map (lambda (w) (make-string (+ w 2) #\-))
             widths)
        "+")
      "+\n"))
  
  (define (draw-row values)
    (string-append
      "|"
      (string-join
        (map (lambda (val width)
               (string-append " " (pad val width) " "))
             values
             widths)
        "|")
      "|\n"))
  
  (string-append
    (draw-line)
    (draw-row headers)
    (draw-line)
    (apply string-append
           (map (lambda (row)
                  (draw-row
                    (map (lambda (h) (cdr (assoc h row)))
                         headers)))
                data))
    (draw-line)))

;; Example:
(define sales-data
  '((("Product" . "Apples")  ("Quantity" . "100") ("Price" . "0.50"))
    (("Product" . "Bananas") ("Quantity" . "150") ("Price" . "0.30"))
    (("Product" . "Cherries") ("Quantity" . "75") ("Price" . "2.00"))))

(display (generate-table sales-data '("Product" "Quantity" "Price")))
;; Output:
;; +-----------+----------+-------+
;; | Product   | Quantity | Price |
;; +-----------+----------+-------+
;; | Apples    | 100      | 0.50  |
;; | Bananas   | 150      | 0.30  |
;; | Cherries  | 75       | 2.00  |
;; +-----------+----------+-------+

HTML Generator

;; html-generator.scm

(define (html-tag tag . content)
  (string-append "<" tag ">"
                 (apply string-append content)
                 "</" tag ">"))

(define (html-attr tag attrs . content)
  (string-append "<" tag " "
                 (string-join
                   (map (lambda (pair)
                          (format "~a=\"~a\""
                                  (car pair)
                                  (cdr pair)))
                        attrs)
                   " ")
                 ">"
                 (apply string-append content)
                 "</" tag ">"))

;; Specific tags
(define (html . content)
  (apply html-tag "html" content))

(define (head . content)
  (apply html-tag "head" content))

(define (body . content)
  (apply html-tag "body" content))

(define (h1 . content)
  (apply html-tag "h1" content))

(define (p . content)
  (apply html-tag "p" content))

(define (div . content)
  (apply html-tag "div" content))

(define (a href . content)
  (apply html-attr "a" `(("href" . ,href)) content))

;; Example:
(html
  (head
    (html-tag "title" "My Page"))
  (body
    (h1 "Welcome")
    (p "This is a paragraph.")
    (a "https://example.com" "Click here")))

;; Output:
;; <html><head><title>My Page</title></head><body><h1>Welcome</h1>
;; <p>This is a paragraph.</p><a href="https://example.com">Click here</a>
;; </body></html>

Summary

This chapter covered:

  1. String Manipulation: Trim, split, join, case conversion, search, replace

  2. Pattern Matching: Wildcards, regular expressions, custom regex engine

  3. Lexical Analysis: Tokenizers, state machines

  4. Parsing: Recursive descent, parser combinators, S-expressions

  5. Data Formats: CSV and JSON parsing

  6. Templates: Template engines and variable substitution

  7. Text Generation: Reports, tables, HTML generation

Key Techniques:

  • String processing is fundamental to many applications

  • Tokenization breaks text into meaningful units

  • Parsers build structure from tokens

  • Combinators provide composable parsing primitives

  • Template engines enable dynamic content generation

Next Chapter: We’ll explore Chapter 13: Networking and Web Programming, covering HTTP clients, servers, and web applications in Scheme.

Chapter 13: Build Tools and Software Engineering

13.1 Introduction to Build Systems in Scheme

Build tools automate the process of compiling, testing, and packaging software. While Scheme is often used for smaller projects or scripting, larger applications benefit from structured build processes.

Why Build Tools Matter

;; Challenges in larger Scheme projects:
;; - Managing dependencies between modules
;; - Compiling multiple files in correct order
;; - Running test suites automatically
;; - Generating documentation
;; - Creating distributable packages
;; - Ensuring reproducible builds

Build Tool Overview

Different Scheme implementations have different build approaches:

;; Common build tool categories:

;; 1. Makefiles (traditional, cross-implementation)
;; 2. Implementation-specific tools
;;    - Chicken: chicken-install, eggs
;;    - Racket: raco pkg
;;    - Guile: guild, autotools
;; 3. Package managers
;;    - Akku (R6RS/R7RS)
;;    - Snow (portable packages)
;; 4. Custom build scripts in Scheme

13.2 Using Makefiles with Scheme

Basic Makefile Structure

# Makefile for Scheme project

# Configuration
SCHEME = scheme
SCHEME_FLAGS = --quiet
SRC_DIR = src
BUILD_DIR = build
TEST_DIR = tests

# Source files
SOURCES = $(wildcard $(SRC_DIR)/*.scm)
COMPILED = $(SOURCES:$(SRC_DIR)/%.scm=$(BUILD_DIR)/%.so)

# Default target
.PHONY: all
all: compile

# Compile all source files
.PHONY: compile
compile: $(BUILD_DIR) $(COMPILED)

$(BUILD_DIR):
    mkdir -p $(BUILD_DIR)

# Pattern rule for compilation
$(BUILD_DIR)/%.so: $(SRC_DIR)/%.scm
    $(SCHEME) $(SCHEME_FLAGS) --compile $< -o $@

# Run tests
.PHONY: test
test: compile
    $(SCHEME) $(SCHEME_FLAGS) --load $(TEST_DIR)/run-tests.scm

# Clean build artifacts
.PHONY: clean
clean:
    rm -rf $(BUILD_DIR)

# Install (example)
.PHONY: install
install: compile
    cp $(BUILD_DIR)/*.so /usr/local/lib/scheme/

# Generate documentation
.PHONY: docs
docs:
    scribble --html docs/manual.scrbl

# Help target
.PHONY: help
help:
    @echo "Available targets:"
    @echo "  all      - Build everything (default)"
    @echo "  compile  - Compile source files"
    @echo "  test     - Run test suite"
    @echo "  clean    - Remove build artifacts"
    @echo "  install  - Install compiled files"
    @echo "  docs     - Generate documentation"

Advanced Makefile Techniques

# Dependency tracking
.PHONY: depends
depends:
    $(SCHEME) --script scripts/generate-deps.scm > .depend


-include .depend

# Parallel builds
.PHONY: parallel
parallel:
    $(MAKE) -j4 compile

# Multiple targets for different Scheme implementations
.PHONY: guile-build
guile-build:
    guild compile $(SOURCES)

.PHONY: racket-build
racket-build:
    raco make $(SOURCES)

.PHONY: chicken-build
chicken-build:
    csc -s $(SOURCES)

# Version management
VERSION = $(shell cat VERSION)
TARBALL = myproject-$(VERSION).tar.gz

.PHONY: dist
dist: clean
    mkdir -p dist/myproject-$(VERSION)
    cp -r src tests docs Makefile dist/myproject-$(VERSION)/
    cd dist ∧ tar czf $(TARBALL) myproject-$(VERSION)

13.3 Dependency Management

Dependency Declaration

;; project-config.scm
;; Project metadata and dependencies

(define-project myproject
  (version "1.0.0")
  (description "A sample Scheme project")
  (author "Your Name <you@example.com>")
  (license "MIT")
  
  (dependencies
   (srfi-1 "≥1.0")
   (srfi-13 "≥1.0")
   (json-parser "≥2.0"))
  
  (dev-dependencies
   (test-framework "≥1.0")
   (benchmark-suite "≥0.5"))
  
  (source-directories "src")
  (test-directories "tests"))

Dependency Resolution

;; dependency-resolver.scm
;; Simple dependency resolver

(define-struct package (name version deps))

(define (resolve-dependencies packages required)
  ;; Topological sort to determine build order
  
  (define (find-package name)
    (find (lambda (p)
            (eq? (package-name p) name))
          packages))
  
  (define visited (make-hash-table))
  (define sorted '())
  
  (define (visit pkg-name)
    (unless (hash-table-ref/default visited pkg-name #f)
      (hash-table-set! visited pkg-name 'visiting)
      
      (let ([pkg (find-package pkg-name)])
        (when pkg
          (for-each visit (package-deps pkg)))
        
        (hash-table-set! visited pkg-name #t)
        (set! sorted (cons pkg-name sorted)))))
  
  (for-each visit required)
  (reverse sorted))

;; Example usage:
(define available-packages
  (list
   (make-package 'srfi-1 "1.0" '())
   (make-package 'json "2.0" '(srfi-1))
   (make-package 'web-server "1.0" '(json srfi-1))))

(resolve-dependencies available-packages '(web-server))
;; ⇒ (srfi-1 json web-server)

Version Constraints

;; version-checker.scm

(define (parse-version str)
  (map string→number (string-split str #\.)))

(define (version-compare v1 v2)
  ;; Returns: -1 if v1 < v2, 0 if equal, 1 if v1 > v2
  (let loop ([p1 (parse-version v1)]
             [p2 (parse-version v2)])
    (cond
      [(and (null? p1) (null? p2)) 0]
      [(null? p1) -1]
      [(null? p2) 1]
      [(< (car p1) (car p2)) -1]
      [(> (car p1) (car p2)) 1]
      [else (loop (cdr p1) (cdr p2))])))

(define (satisfies-constraint? version constraint)
  (let ([op (substring constraint 0 2)]
        [required (substring constraint 2)])
    (case (string→symbol op)
      [(≥) (≥ (version-compare version required) 0)]
      [(>) (> (version-compare version required) 0)]
      [(≤) (≤ (version-compare version required) 0)]
      [(<) (< (version-compare version required) 0)]
      [(⩵) (= (version-compare version required) 0)]
      [(^) ; Compatible version (same major)
       (let ([v-parts (parse-version version)]
             [r-parts (parse-version required)])
         (and (= (car v-parts) (car r-parts))
              (≥ (version-compare version required) 0)))]
      [else #f])))

;; Examples:
(satisfies-constraint? "1.5.2" "≥1.0.0")  ; ⇒ #t
(satisfies-constraint? "2.0.0" "^1.0.0")   ; ⇒ #f
(satisfies-constraint? "1.5.0" "^1.0.0")   ; ⇒ #t

13.4 Project Structure

Standard Directory Layout

;; Recommended project structure:

my-project/
  ├── README.md           ; Project documentation
  ├── LICENSE            ; License file
  ├── VERSION            ; Version number
  ├── Makefile           ; Build configuration
  ├── project.scm        ; Project metadata
  │
  ├── src/               ; Source code
  │   ├── main.scm
  │   ├── utils.scm
  │   └── lib/
  │       ├── parser.scm
  │       └── generator.scm
  │
  ├── tests/             ; Test suite
  │   ├── test-main.scm
  │   ├── test-utils.scm
  │   └── test-lib.scm
  │
  ├── docs/              ; Documentation
  │   ├── manual.md
  │   └── api-reference.md
  │
  ├── examples/          ; Example programs
  │   └── demo.scm
  │
  ├── scripts/           ; Build/utility scripts
  │   └── generate-docs.scm
  │
  └── build/             ; Compiled output (generated)
      └── lib/

Module Organization

;; src/main.scm
(define-library (myproject main)
  (export run-application)
  (import (scheme base)
          (myproject utils)
          (myproject lib parser))
  
  (begin
    (define (run-application args)
      ;; Main entry point
      (display "Application started\n")
      ;; …
      )))

;; src/utils.scm
(define-library (myproject utils)
  (export string-utils list-utils)
  (import (scheme base)
          (srfi 1)
          (srfi 13))
  
  (begin
    ;; Utility functions
    ))

;; src/lib/parser.scm
(define-library (myproject lib parser)
  (export parse-expression)
  (import (scheme base))
  
  (begin
    ;; Parser implementation
    ))

13.5 Testing Infrastructure

Test Framework

;; test-framework.scm
;; Simple but functional test framework

(define test-results '())
(define current-suite "")

(define (test-suite name)
  (set! current-suite name)
  (display (string-append "\nRunning suite: " name "\n")))

(define (assert-equal expected actual . message)
  (let ([msg (if (null? message) "" (car message))]
        [passed (equal? expected actual)])
    (set! test-results
          (cons (list current-suite msg passed expected actual)
                test-results))
    (if passed
        (display ".")
        (begin
          (newline)
          (display (string-append "FAIL: " msg))
          (newline)
          (display (string-append "  Expected: " (→string expected)))
          (newline)
          (display (string-append "  Got: " (→string actual)))
          (newline)))))

(define (assert-true expr . message)
  (apply assert-equal #t expr message))

(define (assert-false expr . message)
  (apply assert-equal #f expr message))

(define (assert-error thunk . message)
  (let ([msg (if (null? message) "" (car message))]
        [raised-error #f])
    (guard (ex [else (set! raised-error #t)])
      (thunk))
    (assert-true raised-error msg)))

(define (→string obj)
  (call-with-port
    (open-output-string)
    (lambda (port)
      (write obj port)
      (get-output-string port))))

(define (run-tests)
  (newline)
  (let* ([total (length test-results)]
         [passed (length (filter (lambda (r) (caddr r)) test-results))]
         [failed (- total passed)])
    (display (string-append "\n\nResults: "
                          (number→string passed) " passed, "
                          (number→string failed) " failed, "
                          (number→string total) " total\n"))
    (= failed 0)))

;; Example test file
;; tests/test-utils.scm
(load "test-framework.scm")
(load "src/utils.scm")

(test-suite "String Utilities")

(assert-equal "HELLO" (string-upcase "hello")
              "string-upcase converts to uppercase")

(assert-equal '("a" "b" "c") (string-split "a,b,c" #\,)
              "string-split splits on delimiter")

(test-suite "List Utilities")

(assert-equal 6 (sum '(1 2 3))
              "sum adds list elements")

(assert-true (all? even? '(2 4 6))
             "all? checks predicate for all elements")

;; Run all tests
(exit (if (run-tests) 0 1))

Property-Based Testing

;; property-testing.scm
;; QuickCheck-style property-based testing

(define (generate-integer min max)
  (+ min (random (- max min))))

(define (generate-list gen n)
  (let loop ([i 0] [result '()])
    (if (≥ i n)
        result
        (loop (+ i 1) (cons (gen) result)))))

(define (generate-string len)
  (list→string
    (generate-list
      (lambda () (integer→char (generate-integer 97 123)))
      len)))

(define (check-property prop gen num-tests)
  (let loop ([i 0] [failures '()])
    (if (≥ i num-tests)
        (if (null? failures)
            (begin
              (display (string-append "✓ Passed " (number→string num-tests) " tests\n"))
              #t)
            (begin
              (display (string-append "✗ Failed on inputs:\n"))
              (for-each
                (lambda (input)
                  (display "  ")
                  (write input)
                  (newline))
                failures)
              #f))
        (let ([input (gen)])
          (if (prop input)
              (loop (+ i 1) failures)
              (loop (+ i 1) (cons input failures)))))))

;; Example properties
(define (prop-reverse-twice lst)
  (equal? lst (reverse (reverse lst))))

(define (prop-length-append lst1 lst2)
  (= (length (append lst1 lst2))
     (+ (length lst1) (length lst2))))

;; Run property tests
(check-property
  prop-reverse-twice
  (lambda () (generate-list (lambda () (generate-integer 0 100)) 10))
  100)

(check-property
  prop-length-append
  (lambda ()
    (cons (generate-list (lambda () (generate-integer 0 100)) 5)
          (generate-list (lambda () (generate-integer 0 100)) 5)))
  100)

Test Coverage

;; coverage-tracker.scm
;; Simple code coverage tracking

(define coverage-data (make-hash-table))

(define (instrument-procedure name proc)
  (hash-table-set! coverage-data name 0)
  (lambda args
    (hash-table-set! coverage-data name
                     (+ 1 (hash-table-ref coverage-data name)))
    (apply proc args)))

(define-syntax define-traced
  (syntax-rules ()
    [(_ (name . args) body …)
     (define name
       (instrument-procedure 'name
                           (lambda args body …)))]))

;; Example:
(define-traced (factorial n)
  (if (≤ n 1)
      1
      (* n (factorial (- n 1)))))

(define (report-coverage)
  (display "\nCode Coverage Report:\n")
  (display "≡≡≡≡≡≡≡\n")
  (hash-table-for-each
    coverage-data
    (lambda (name count)
      (display (string-append
                 (symbol→string name) ": "
                 (number→string count) " calls\n"))))
  (newline))

;; Usage:
(factorial 5)
(factorial 3)
(report-coverage)
;; Output:
;; Code Coverage Report:
;; ≡≡≡≡≡≡≡
;; factorial: 9 calls

13.6 Documentation Generation

Inline Documentation

;; documented-code.scm
;; Code with embedded documentation

(define (binary-search lst target)
  "Search for TARGET in sorted list LST using binary search.
   
   Arguments:
     lst    - A sorted list of numbers
     target - The number to search for
   
   Returns:
     The index of target in lst, or #f if not found
   
   Examples:
     (binary-search '(1 3 5 7 9) 5)  ⇒ 2
     (binary-search '(1 3 5 7 9) 4)  ⇒ #f
   
   Complexity: O(log n)"
  
  (let loop ([low 0]
             [high (- (length lst) 1)])
    (if (> low high)
        #f
        (let* ([mid (quotient (+ low high) 2)]
               [mid-val (list-ref lst mid)])
          (cond
            [(= mid-val target) mid]
            [(< mid-val target) (loop (+ mid 1) high)]
            [else (loop low (- mid 1))])))))

Documentation Extractor

;; doc-generator.scm
;; Extract documentation from source files

(define (extract-docstrings file)
  (define (read-forms port)
    (let loop ([forms '()])
      (let ([form (read port)])
        (if (eof-object? form)
            (reverse forms)
            (loop (cons form forms))))))
  
  (define (extract-doc form)
    (match form
      [('define (name . args) docstring . body)
       (if (string? docstring)
           (list name args docstring)
           #f)]
      [('define name docstring value)
       (if (string? docstring)
           (list name '() docstring)
           #f)]
      [_ #f]))
  
  (call-with-input-file file
    (lambda (port)
      (filter values
              (map extract-doc (read-forms port))))))

(define (generate-markdown-doc entries)
  (define (format-signature name args)
    (string-append "### `(" (symbol→string name) " "
                   (string-join (map symbol→string args) " ")
                   ")`\n\n"))
  
  (define (format-entry entry)
    (match entry
      [(name args docstring)
       (string-append
         (format-signature name args)
         docstring
         "\n\n---\n\n")]))
  
  (string-append
    "# API Documentation\n\n"
    (apply string-append (map format-entry entries))))

;; Usage:
(define docs (extract-docstrings "src/utils.scm"))
(display (generate-markdown-doc docs))

API Reference Generator

;; api-reference.scm

(define (generate-api-reference modules output-file)
  (define (module-exports mod)
    ;; Extract exported symbols from module
    ;; Implementation depends on module system
    )
  
  (define (function-info name)
    ;; Get documentation, signature, examples
    ;; from source or metadata
    )
  
  (define (generate-html modules)
    (string-append
      "<!DOCTYPE html>\n"
      "<html>\n"
      "<head><title>API Reference</title></head>\n"
      "<body>\n"
      "<h1>API Reference</h1>\n"
      
      (apply string-append
        (map (lambda (mod)
               (string-append
                 "<h2>" (symbol→string mod) "</h2>\n"
                 "<ul>\n"
                 (apply string-append
                   (map (lambda (name)
                          (string-append
                            "<li><code>" (symbol→string name) "</code></li>\n"))
                        (module-exports mod)))
                 "</ul>\n"))
             modules))
      
      "</body>\n"
      "</html>\n"))
  
  (call-with-output-file output-file
    (lambda (port)
      (display (generate-html modules) port))))

13.7 Continuous Integration

CI Configuration

# .github/workflows/ci.yml
# GitHub Actions CI configuration

name: CI

on:
  push:
    branches: [ main, develop ]
  pull_request:
    branches: [ main ]

jobs:
  test:
    runs-on: ubuntu-latest
    
    strategy:
      matrix:
        scheme: [guile-3.0, racket-8.0, chicken-5.3]
    
    steps:

    - uses: actions/checkout@v2
    

    - name: Install Scheme
      run: |
        sudo apt-get update
        sudo apt-get install -y ${{ matrix.scheme }}
    

    - name: Install dependencies
      run: make deps
    

    - name: Build
      run: make compile
    

    - name: Run tests
      run: make test
    

    - name: Check code style
      run: make lint
    

    - name: Generate coverage
      run: make coverage
    

    - name: Upload coverage
      uses: codecov/codecov-action@v2
      with:
        files: ./coverage.xml

Build Script for CI

;; ci-build.scm
;; Automated build script for CI environments

(define (run-command cmd)
  (define result (system cmd))
  (unless (= result 0)
    (error "Command failed:" cmd))
  result)

(define (ci-build)
  (display "≡ CI Build Starting ≡\n")
  
  ;; Step 1: Clean
  (display "Cleaning build directory…\n")
  (run-command "make clean")
  
  ;; Step 2: Install dependencies
  (display "Installing dependencies…\n")
  (run-command "make deps")
  
  ;; Step 3: Compile
  (display "Compiling source files…\n")
  (run-command "make compile")
  
  ;; Step 4: Run tests
  (display "Running test suite…\n")
  (run-command "make test")
  
  ;; Step 5: Run linter
  (display "Checking code style…\n")
  (run-command "make lint")
  
  ;; Step 6: Generate coverage
  (display "Generating coverage report…\n")
  (run-command "make coverage")
  
  ;; Step 7: Build documentation
  (display "Generating documentation…\n")
  (run-command "make docs")
  
  (display "\n≡ CI Build Complete ≡\n"))

;; Run if executed as script
(when (eq? (command-line) 'ci-build)
  (ci-build))

13.8 Packaging and Distribution

Creating a Package

;; package-builder.scm

(define (create-package project-info)
  (define name (assoc-ref project-info 'name))
  (define version (assoc-ref project-info 'version))
  (define output-dir (string-append "dist/" name "-" version))
  
  ;; Create distribution directory
  (system (string-append "mkdir -p " output-dir))
  
  ;; Copy source files
  (system (string-append "cp -r src " output-dir "/"))
  
  ;; Copy documentation
  (system (string-append "cp -r docs " output-dir "/"))
  
  ;; Copy metadata
  (call-with-output-file (string-append output-dir "/package.scm")
    (lambda (port)
      (write project-info port)))
  
  ;; Create tarball
  (system (string-append "cd dist ∧ tar czf "
                        name "-" version ".tar.gz "
                        name "-" version))
  
  (display (string-append "Package created: dist/"
                         name "-" version ".tar.gz\n")))

;; Example:
(create-package
  '((name . "mylib")
    (version . "1.0.0")
    (author . "Your Name")
    (license . "MIT")
    (description . "A useful library")))

Installation Script

;; install.scm
;; Package installation script

(define (install-package tarball)
  (define temp-dir "/tmp/scheme-install")
  
  ;; Extract package
  (system (string-append "mkdir -p " temp-dir))
  (system (string-append "tar xzf " tarball " -C " temp-dir))
  
  ;; Read package metadata
  (define pkg-info
    (call-with-input-file
      (string-append temp-dir "/package.scm")
      read))
  
  (define name (assoc-ref pkg-info 'name))
  (define install-prefix
    (or (getenv "SCHEME_LIB_PATH")
        "/usr/local/lib/scheme"))
  
  ;; Install files
  (system (string-append "cp -r "
                        temp-dir "/src/* "
                        install-prefix "/" name "/"))
  
  ;; Clean up
  (system (string-append "rm -rf " temp-dir))
  
  (display (string-append "Installed " name "\n")))

13.9 Code Quality Tools

Linting

;; scheme-lint.scm
;; Simple code quality checker

(define (lint-file filename)
  (define issues '())
  
  (define (add-issue line msg)
    (set! issues (cons (list filename line msg) issues)))
  
  (define (check-line line-num line)
    ;; Check line length
    (when (> (string-length line) 80)
      (add-issue line-num "Line exceeds 80 characters"))
    
    ;; Check trailing whitespace
    (when (string-suffix? " " line)
      (add-issue line-num "Trailing whitespace"))
    
    ;; Check for tabs
    (when (string-contains? line "\t")
      (add-issue line-num "Tab character found; use spaces"))
    
    ;; Check for common issues
    (when (string-contains? line "(eq? ")
      (add-issue line-num "Consider using equal? instead of eq?")))
  
  (call-with-input-file filename
    (lambda (port)
      (let loop ([line-num 1])
        (let ([line (read-line port)])
          (unless (eof-object? line)
            (check-line line-num line)
            (loop (+ line-num 1)))))))
  
  (reverse issues))

(define (report-lint-issues issues)
  (if (null? issues)
      (display "No issues found ✓\n")
      (begin
        (for-each
          (lambda (issue)
            (match issue
              [(file line msg)
               (display (string-append
                          file ":" (number→string line)
                          ": " msg "\n"))]))
          issues)
        (display (string-append
                   "\nTotal issues: "
                   (number→string (length issues)) "\n")))))

;; Usage:
(report-lint-issues (lint-file "src/main.scm"))

Code Formatting

;; code-formatter.scm
;; Automatic code formatting

(define (format-code input-file output-file)
  (define indent-level 0)
  (define indent-size 2)
  
  (define (indent)
    (make-string (* indent-level indent-size) #\space))
  
  (define (format-form form)
    (cond
      [(pair? form)
       (string-append
         "(" (symbol→string (car form))
         (if (null? (cdr form))
             ")"
             (string-append
               "\n"
               (set! indent-level (+ indent-level 1))
               (string-join
                 (map (lambda (subform)
                        (string-append (indent)
                                      (format-form subform)))
                      (cdr form))
                 "\n")
               (set! indent-level (- indent-level 1))
               ")")))]
      
      [(symbol? form)
       (symbol→string form)]
      
      [(string? form)
       (string-append "\"" form "\"")]
      
      [else
       (number→string form)]))
  
  (call-with-input-file input-file
    (lambda (in-port)
      (call-with-output-file output-file
        (lambda (out-port)
          (let loop ()
            (let ([form (read in-port)])
              (unless (eof-object? form)
                (display (format-form form) out-port)
                (newline out-port)
                (newline out-port)
                (loop))))))))
  
  (display (string-append "Formatted " output-file "\n")))

Summary

This chapter covered essential software engineering practices for Scheme:

  1. Build Systems: Makefiles, build automation

  2. Dependency Management: Version resolution, constraints

  3. Project Structure: Standard layouts, module organization

  4. Testing: Unit tests, property-based testing, coverage

  5. Documentation: Inline docs, API reference generation

  6. CI/CD: Continuous integration workflows

  7. Packaging: Distribution, installation

  8. Code Quality: Linting, formatting

Key Principles:

  • Automate repetitive tasks

  • Maintain consistent project structure

  • Write comprehensive tests

  • Document code thoroughly

  • Use version control effectively

  • Follow coding standards

Best Practices:

  • Keep build scripts simple and maintainable

  • Test at multiple levels (unit, integration, property)

  • Generate documentation from source

  • Use CI to catch issues early

  • Version dependencies explicitly

  • Follow semantic versioning

These practices help manage complexity as projects grow and enable effective collaboration.

Chapter 14: Scripting and Automation

14.1 Introduction to Scheme for Scripting

Scheme’s interactive nature, dynamic typing, and powerful abstraction capabilities make it excellent for scripting tasks. This chapter explores using Scheme for automation, system administration, text processing, and building command-line tools.

Why Scheme for Scripting?

;; Advantages of Scheme for scripting:
;; 1. REPL for rapid prototyping
;; 2. Powerful list processing
;; 3. First-class functions for flexibility
;; 4. Clean syntax without boilerplate
;; 5. Cross-platform portability
;; 6. Easy integration with shell commands

;; Simple example: processing log files
(define (count-errors log-file)
  (call-with-input-file log-file
    (lambda (port)
      (let loop ([count 0])
        (let ([line (read-line port)])
          (if (eof-object? line)
              count
              (loop (if (string-contains? line "ERROR")
                        (+ count 1)
                        count))))))))

Shebang Scripts

#!/usr/bin/env scheme-script
;; hello-script.scm
;; Make executable with: chmod +x hello-script.scm

(import (scheme base)
        (scheme write))

(define (main args)
  (display "Hello from Scheme script!\n")
  (display "Arguments: ")
  (write args)
  (newline))

;; Call main with command-line arguments
(main (command-line))

14.2 Command-Line Argument Processing

Basic Argument Parsing

;; arg-parser.scm
;; Simple command-line argument parser

(define (parse-arguments args)
  ;; Returns an association list of options and values
  (let loop ([remaining args]
             [options '()]
             [positional '()])
    (cond
      [(null? remaining)
       (cons (reverse options) (reverse positional))]
      
      [(string-prefix? "--" (car remaining))
       ;; Long option
       (let ([opt (substring (car remaining) 2)])
         (if (and (not (null? (cdr remaining)))
                  (not (string-prefix? "-" (cadr remaining))))
             ;; Has value
             (loop (cddr remaining)
                   (cons (cons opt (cadr remaining)) options)
                   positional)
             ;; Flag only
             (loop (cdr remaining)
                   (cons (cons opt #t) options)
                   positional)))]
      
      [(string-prefix? "-" (car remaining))
       ;; Short option(s)
       (let ([flags (string→list (substring (car remaining) 1))])
         (loop (cdr remaining)
               (append (map (lambda (f) (cons (string f) #t)) flags)
                       options)
               positional))]
      
      [else
       ;; Positional argument
       (loop (cdr remaining)
             options
             (cons (car remaining) positional))])))

;; Helper functions
(define (get-option options key . default)
  (let ([pair (assoc key options)])
    (if pair
        (cdr pair)
        (if (null? default) #f (car default)))))

(define (has-option? options key)
  (assoc key options))

;; Example usage:
;; $ script.scm --verbose --output=file.txt -abc input.txt
(define parsed (parse-arguments (cdr (command-line))))
(define options (car parsed))
(define positional (cdr parsed))

(display "Options: ") (write options) (newline)
(display "Positional: ") (write positional) (newline)

;; Check for flags
(when (has-option? options "verbose")
  (display "Verbose mode enabled\n"))

;; Get option value
(let ([output (get-option options "output" "default.txt")])
  (display "Output file: ") (display output) (newline))

Advanced Argument Parser

;; command-parser.scm
;; Feature-rich command-line parser

(define-record-type <option>
  (make-option short long type required? default help)
  option?
  (short option-short)
  (long option-long)
  (type option-type)
  (required? option-required?)
  (default option-default)
  (help option-help))

(define (define-options . specs)
  ;; Create option definitions
  (map (lambda (spec)
         (apply make-option spec))
       specs))

(define (parse-with-spec args spec)
  (define (find-option-by-short s)
    (find (lambda (opt) (equal? (option-short opt) s)) spec))
  
  (define (find-option-by-long l)
    (find (lambda (opt) (equal? (option-long opt) l)) spec))
  
  (define (convert-value opt value)
    (case (option-type opt)
      [(string) value]
      [(integer) (string→number value)]
      [(boolean) #t]
      [(list) (string-split value #\,)]
      [else value]))
  
  (let loop ([remaining args]
             [result '()]
             [positional '()])
    (cond
      [(null? remaining)
       ;; Check required options
       (for-each
         (lambda (opt)
           (when (and (option-required? opt)
                      (not (assoc (option-long opt) result)))
             (error "Missing required option:" (option-long opt))))
         spec)
       
       ;; Add defaults
       (let ([final-result
              (append result
                      (filter-map
                        (lambda (opt)
                          (if (and (not (assoc (option-long opt) result))
                                   (option-default opt))
                              (cons (option-long opt) (option-default opt))
                              #f))
                        spec))])
         (cons final-result (reverse positional)))]
      
      [(string-prefix? "--" (car remaining))
       (let* ([full (substring (car remaining) 2)]
              [parts (string-split full #\=)]
              [name (car parts)]
              [opt (find-option-by-long name)])
         (if opt
             (if (eq? (option-type opt) 'boolean)
                 (loop (cdr remaining)
                       (cons (cons name #t) result)
                       positional)
                 (let ([value (if (> (length parts) 1)
                                  (cadr parts)
                                  (if (null? (cdr remaining))
                                      (error "Option requires value:" name)
                                      (cadr remaining)))])
                   (loop (if (> (length parts) 1)
                             (cdr remaining)
                             (cddr remaining))
                         (cons (cons name (convert-value opt value)) result)
                         positional)))
             (error "Unknown option:" name)))]
      
      [(string-prefix? "-" (car remaining))
       (let* ([flags (string→list (substring (car remaining) 1))]
              [opt (find-option-by-short (string (car flags)))])
         (if opt
             (if (eq? (option-type opt) 'boolean)
                 (loop (cdr remaining)
                       (cons (cons (option-long opt) #t) result)
                       positional)
                 (let ([value (if (null? (cdr remaining))
                                  (error "Option requires value:" 
                                         (option-short opt))
                                  (cadr remaining))])
                   (loop (cddr remaining)
                         (cons (cons (option-long opt) 
                                   (convert-value opt value))
                               result)
                         positional)))
             (error "Unknown option:" (car flags))))]
      
      [else
       (loop (cdr remaining) result (cons (car remaining) positional))])))

;; Example:
(define options-spec
  (define-options
    '("v" "verbose" boolean #f #f "Enable verbose output")
    '("o" "output" string #f "output.txt" "Output file")
    '("n" "count" integer #t #f "Number of iterations")
    '("f" "files" list #f '() "Comma-separated file list")))

(define parsed (parse-with-spec (cdr (command-line)) options-spec))

Help Generation

;; help-generator.scm

(define (generate-help program-name description options-spec)
  (define (format-option opt)
    (string-append
      "  -" (option-short opt) ", --" (option-long opt)
      (if (eq? (option-type opt) 'boolean)
          ""
          (string-append " <" (symbol→string (option-type opt)) ">"))
      "\n"
      "      " (option-help opt)
      (if (option-default opt)
          (string-append " (default: " 
                        (→string (option-default opt)) ")")
          "")
      "\n"))
  
  (string-append
    "Usage: " program-name " [OPTIONS] [ARGS]\n\n"
    description "\n\n"
    "Options:\n"
    (apply string-append (map format-option options-spec))
    "\n"))

;; Usage:
(when (has-option? options "help")
  (display (generate-help
             "my-script"
             "A useful script that does things"
             options-spec))
  (exit 0))

14.3 File System Operations

Directory Traversal

;; file-walker.scm
;; Traverse directory trees

(define (walk-directory path proc)
  ;; Visit every file in directory tree
  ;; Call (proc filepath) for each file
  
  (define (walk current-path)
    (if (file-directory? current-path)
        ;; Directory: recurse into it
        (let ([entries (directory-list current-path)])
          (for-each
            (lambda (entry)
              (unless (or (equal? entry ".") (equal? entry "‥"))
                (walk (string-append current-path "/" entry))))
            entries))
        ;; File: process it
        (proc current-path)))
  
  (walk path))

;; Example: find all .scm files
(define (find-scheme-files dir)
  (let ([files '()])
    (walk-directory dir
      (lambda (path)
        (when (string-suffix? ".scm" path)
          (set! files (cons path files)))))
    (reverse files)))

;; Example: calculate total size
(define (directory-size dir)
  (let ([total 0])
    (walk-directory dir
      (lambda (path)
        (set! total (+ total (file-size path)))))
    total))

File Pattern Matching

;; glob-matcher.scm
;; Simple glob pattern matching

(define (glob-match? pattern string)
  ;; Match simple glob patterns (* and ?)
  
  (define (match-here pat str)
    (cond
      [(null? pat) (null? str)]
      [(null? str) (and (not (null? pat)) (char=? (car pat) #\*)
                        (match-here (cdr pat) '()))]
      [(char=? (car pat) #\*)
       (or (match-here (cdr pat) str)
           (match-here pat (cdr str)))]
      [(char=? (car pat) #\?)
       (match-here (cdr pat) (cdr str))]
      [(char=? (car pat) (car str))
       (match-here (cdr pat) (cdr str))]
      [else #f]))
  
  (match-here (string→list pattern) (string→list string)))

;; Find files matching pattern
(define (glob-find dir pattern)
  (let ([matches '()])
    (walk-directory dir
      (lambda (path)
        (let ([filename (path-filename path)])
          (when (glob-match? pattern filename)
            (set! matches (cons path matches))))))
    (reverse matches)))

;; Examples:
(glob-match? "*.scm" "test.scm")        ; ⇒ #t
(glob-match? "test?.scm" "test1.scm")   ; ⇒ #t
(glob-match? "*.txt" "test.scm")        ; ⇒ #f

(glob-find "/path/to/dir" "*.scm")      ; Find all .scm files
(glob-find "/path/to/dir" "test-*.scm") ; Find test-*.scm files

File Operations

;; file-ops.scm
;; Common file operations

(define (copy-file src dest)
  ;; Copy file from src to dest
  (call-with-input-file src
    (lambda (in)
      (call-with-output-file dest
        (lambda (out)
          (let loop ()
            (let ([byte (read-u8 in)])
              (unless (eof-object? byte)
                (write-u8 byte out)
                (loop)))))))))

(define (move-file src dest)
  ;; Move/rename file
  (copy-file src dest)
  (delete-file src))

(define (ensure-directory dir)
  ;; Create directory if it doesn't exist
  (unless (file-exists? dir)
    (create-directory dir)))

(define (with-temp-file proc)
  ;; Execute proc with a temporary file path
  (let* ([temp-name (string-append "/tmp/scheme-temp-" 
                                   (number→string (current-time)))]
         [result (proc temp-name)])
    (when (file-exists? temp-name)
      (delete-file temp-name))
    result))

;; Backup file with timestamp
(define (backup-file path)
  (let* ([timestamp (format-time (current-time) "%Y%m%d-%H%M%S")]
         [backup-path (string-append path "." timestamp ".bak")])
    (copy-file path backup-path)
    backup-path))

;; Safe file writing (atomic)
(define (write-file-atomic path content)
  (let ([temp-path (string-append path ".tmp")])
    (call-with-output-file temp-path
      (lambda (port)
        (display content port)))
    (move-file temp-path path)))

14.4 Process Management

Running External Commands

;; process-runner.scm
;; Execute external programs

(define (run-command cmd . args)
  ;; Run command and return exit status
  (let ([full-cmd (string-append cmd " " (string-join args " "))])
    (system full-cmd)))

(define (run-command-output cmd . args)
  ;; Run command and capture output
  (let* ([full-cmd (string-append cmd " " (string-join args " "))]
         [port (open-input-pipe full-cmd)])
    (let loop ([lines '()])
      (let ([line (read-line port)])
        (if (eof-object? line)
            (begin
              (close-input-port port)
              (reverse lines))
            (loop (cons line lines)))))))

(define (run-command-string cmd . args)
  ;; Run command and return output as string
  (string-join (apply run-command-output cmd args) "\n"))

;; Example: check if command exists
(define (command-exists? cmd)
  (= 0 (run-command "which" cmd ">/dev/null" "2>&1")))

;; Example: get git status
(define (git-status)
  (if (command-exists? "git")
      (run-command-output "git" "status" "--short")
      (error "git not found")))

;; Example: compile C file
(define (compile-c-file source output)
  (let ([result (run-command "gcc" source "-o" output)])
    (if (= result 0)
        (display (string-append "Compiled " output "\n"))
        (error "Compilation failed"))))

Pipeline Composition

;; pipeline.scm
;; Compose multiple commands in pipeline

(define (pipe-commands . cmds)
  ;; Run commands in pipeline
  (let ([full-cmd (string-join cmds " | ")])
    (run-command-output "sh" "-c" (string-append "\"" full-cmd "\""))))

;; Example: count error lines in log
(define (count-errors log-file)
  (let ([result (pipe-commands
                  (string-append "cat " log-file)
                  "grep ERROR"
                  "wc -l")])
    (string→number (car result))))

;; Example: find largest files
(define (largest-files dir n)
  (pipe-commands
    (string-append "find " dir " -type f -exec ls -l {} \\;")
    "sort -k5 -rn"
    (string-append "head -" (number→string n))))

Background Process Management

;; background-process.scm

(define-record-type <process>
  (make-process-record pid status)
  process?
  (pid process-pid)
  (status process-status set-process-status!))

(define (spawn-process cmd . args)
  ;; Start process in background
  (let* ([full-cmd (string-append cmd " " (string-join args " ") " &")]
         [output (run-command-output "sh" "-c" full-cmd)])
    ;; Would need OS-specific way to get actual PID
    (make-process-record 0 'running)))

(define (wait-process proc)
  ;; Wait for process to complete
  (let loop ()
    (if (eq? (process-status proc) 'running)
        (begin
          (sleep 0.1)
          (loop))
        (process-status proc))))

(define (kill-process proc)
  ;; Terminate process
  (run-command "kill" (number→string (process-pid proc)))
  (set-process-status! proc 'terminated))

14.5 Text Processing and Transformation

Stream Processing

;; stream-processor.scm
;; Process text streams line by line

(define (process-stream input-port output-port line-proc)
  ;; Read from input, transform each line, write to output
  (let loop ()
    (let ([line (read-line input-port)])
      (unless (eof-object? line)
        (let ([result (line-proc line)])
          (when result
            (display result output-port)
            (newline output-port)))
        (loop)))))

;; Example: filter lines
(define (grep pattern file)
  (call-with-input-file file
    (lambda (in)
      (call-with-output-file "output.txt"
        (lambda (out)
          (process-stream in out
            (lambda (line)
              (if (string-contains? line pattern)
                  line
                  #f))))))))

;; Example: transform lines
(define (uppercase-file file)
  (call-with-input-file file
    (lambda (in)
      (call-with-output-file "output.txt"
        (lambda (out)
          (process-stream in out string-upcase))))))

;; Example: numbered lines
(define (number-lines file)
  (call-with-input-file file
    (lambda (in)
      (call-with-output-file "output.txt"
        (lambda (out)
          (let ([counter 0])
            (process-stream in out
              (lambda (line)
                (set! counter (+ counter 1))
                (string-append (number→string counter) ": " line)))))))))

Batch Text Processing

;; batch-text-ops.scm

(define (replace-in-file file pattern replacement)
  ;; Replace all occurrences in file
  (let ([content (call-with-input-file file
                   (lambda (port)
                     (read-string port)))])
    (call-with-output-file file
      (lambda (port)
        (display (string-replace content pattern replacement) port)))))

(define (replace-in-files pattern replacement files)
  ;; Replace in multiple files
  (for-each
    (lambda (file)
      (display (string-append "Processing " file "…\n"))
      (replace-in-file file pattern replacement))
    files))

;; Example: batch rename
(define (batch-rename-files dir old-ext new-ext)
  (let ([files (glob-find dir (string-append "*" old-ext))])
    (for-each
      (lambda (file)
        (let ([new-name (string-append
                          (substring file 0 
                                    (- (string-length file)
                                       (string-length old-ext)))
                          new-ext)])
          (move-file file new-name)
          (display (string-append file " → " new-name "\n"))))
      files)))

CSV Processing

;; csv-processor.scm

(define (read-csv file)
  ;; Read CSV file into list of lists
  (call-with-input-file file
    (lambda (port)
      (let loop ([rows '()])
        (let ([line (read-line port)])
          (if (eof-object? line)
              (reverse rows)
              (loop (cons (csv-parse-line line) rows))))))))

(define (csv-parse-line line)
  ;; Parse CSV line handling quotes
  (let ([in-quotes #f]
        [current ""]
        [fields '()])
    (string-for-each
      (lambda (char)
        (cond
          [(char=? char #\")
           (set! in-quotes (not in-quotes))]
          [(and (char=? char #\,) (not in-quotes))
           (set! fields (cons current fields))
           (set! current "")]
          [else
           (set! current (string-append current (string char)))]))
      line)
    (reverse (cons current fields))))

(define (write-csv file rows)
  ;; Write list of lists to CSV
  (call-with-output-file file
    (lambda (port)
      (for-each
        (lambda (row)
          (display (csv-format-line row) port)
          (newline port))
        rows))))

(define (csv-format-line fields)
  (string-join
    (map (lambda (field)
           (if (string-contains? field ",")
               (string-append "\"" field "\"")
               field))
         fields)
    ","))

;; Example: filter CSV rows
(define (filter-csv-rows input-file output-file predicate)
  (let ([data (read-csv input-file)])
    (write-csv output-file (filter predicate data))))

14.6 Configuration File Processing

INI File Parser

;; ini-parser.scm

(define (read-ini-file file)
  ;; Parse INI file into nested alist
  (call-with-input-file file
    (lambda (port)
      (let loop ([sections '()]
                 [current-section ""]
                 [current-data '()])
        (let ([line (read-line port)])
          (cond
            [(eof-object? line)
             ;; End of file
             (if (null? current-data)
                 (reverse sections)
                 (reverse (cons (cons current-section
                                     (reverse current-data))
                               sections)))]
            
            [(or (string=? line "") (string-prefix? ";" line))
             ;; Empty line or comment
             (loop sections current-section current-data)]
            
            [(and (string-prefix? "[" line) (string-suffix? "]" line))
             ;; New section
             (let ([section-name (substring line 1 (- (string-length line) 1))])
               (if (null? current-data)
                   (loop sections section-name '())
                   (loop (cons (cons current-section (reverse current-data))
                              sections)
                         section-name
                         '())))]
            
            [else
             ;; Key=value pair
             (let* ([parts (string-split line #\=)]
                    [key (string-trim (car parts))]
                    [value (if (> (length parts) 1)
                               (string-trim (cadr parts))
                               "")])
               (loop sections
                     current-section
                     (cons (cons key value) current-data)))]))))))

(define (ini-get config section key . default)
  ;; Get value from INI config
  (let* ([section-data (assoc section config)]
         [value (and section-data (assoc key (cdr section-data)))])
    (if value
        (cdr value)
        (if (null? default) #f (car default)))))

;; Example INI file:
;; [database]
;; host=localhost
;; port=5432
;; 
;; [logging]
;; level=info
;; file=/var/log/app.log

(define config (read-ini-file "config.ini"))
(define db-host (ini-get config "database" "host"))
(define log-level (ini-get config "logging" "level" "warning"))

JSON Configuration

;; json-config.scm
;; Simple JSON configuration handling

(define (read-json-config file)
  ;; Read and parse JSON configuration file
  ;; Assumes a JSON parser is available
  (call-with-input-file file
    (lambda (port)
      (json-parse port))))

(define (write-json-config file config)
  ;; Write configuration as JSON
  (call-with-output-file file
    (lambda (port)
      (json-write config port #t)))) ; #t for pretty-print

;; Helper to get nested values
(define (config-get config path . default)
  ;; path is a list of keys: '("database" "connection" "host")
  (let loop ([keys path] [data config])
    (cond
      [(null? keys) data]
      [(not (list? data)) 
       (if (null? default) #f (car default))]
      [else
       (let ([next (assoc (car keys) data)])
         (if next
             (loop (cdr keys) (cdr next))
             (if (null? default) #f (car default))))])))

;; Example:
(define config (read-json-config "config.json"))
(define db-host (config-get config '("database" "host") "localhost"))

14.7 Logging and Monitoring

Simple Logger

;; logger.scm

(define *log-level* 'info)
(define *log-file* #f)

(define (set-log-level! level)
  (set! *log-level* level))

(define (set-log-file! file)
  (set! *log-file* file))

(define (log-message level msg . args)
  (define levels '(debug info warning error critical))
  (define level-index (list-index (lambda (x) (eq? x level)) levels))
  (define current-index (list-index (lambda (x) (eq? x *log-level*)) levels))
  
  (when (≥ level-index current-index)
    (let* ([timestamp (format-time (current-time))]
           [formatted-msg (apply format msg args)]
           [log-line (string-append
                       "[" timestamp "] "
                       "[" (symbol→string level) "] "
                       formatted-msg "\n")])
      
      ;; Write to console
      (display log-line (current-error-port))
      
      ;; Write to file if configured
      (when *log-file*
        (call-with-output-file *log-file*
          (lambda (port)
            (display log-line port))
          'append)))))

;; Convenience functions
(define (log-debug msg . args)
  (apply log-message 'debug msg args))

(define (log-info msg . args)
  (apply log-message 'info msg args))

(define (log-warning msg . args)
  (apply log-message 'warning msg args))

(define (log-error msg . args)
  (apply log-message 'error msg args))

(define (log-critical msg . args)
  (apply log-message 'critical msg args))

;; Usage:
(set-log-level! 'info)
(set-log-file! "app.log")

(log-info "Application started")
(log-debug "This won't be logged")
(log-warning "Disk space low: ~a%" 15)
(log-error "Failed to connect to ~a:~a" "localhost" 8080)

Progress Monitoring

;; progress-monitor.scm

(define-record-type <progress>
  (make-progress-record total current start-time)
  progress?
  (total progress-total)
  (current progress-current set-progress-current!)
  (start-time progress-start-time))

(define (make-progress total)
  (make-progress-record total 0 (current-time)))

(define (progress-update! prog n)
  (set-progress-current! prog (+ (progress-current prog) n)))

(define (progress-percent prog)
  (* 100.0 (/ (progress-current prog) (progress-total prog))))

(define (progress-eta prog)
  ;; Estimate time remaining
  (let* ([elapsed (- (current-time) (progress-start-time prog))]
         [rate (/ (progress-current prog) elapsed)]
         [remaining (- (progress-total prog) (progress-current prog))])
    (if (> rate 0)
        (/ remaining rate)
        0)))

(define (display-progress prog)
  (let* ([percent (progress-percent prog)]
         [bar-width 40]
         [filled (inexact→exact (round (* bar-width (/ percent 100.0))))]
         [empty (- bar-width filled)]
         [eta (progress-eta prog)])
    (display "\r[")
    (display (make-string filled #\=))
    (display (make-string empty #\space))
    (display (format "] ~,1f% ETA: ~as" percent eta))
    (flush-output-port (current-output-port))))

;; Example: processing files with progress
(define (process-files-with-progress files)
  (let ([prog (make-progress (length files))])
    (for-each
      (lambda (file)
        (process-file file)
        (progress-update! prog 1)
        (display-progress prog))
      files)
    (newline)))

14.8 Task Scheduling

Simple Task Scheduler

;; scheduler.scm

(define-record-type <task>
  (make-task name proc interval last-run)
  task?
  (name task-name)
  (proc task-proc)
  (interval task-interval)
  (last-run task-last-run set-task-last-run!))

(define scheduled-tasks '())

(define (schedule-task name proc interval)
  ;; Schedule task to run every 'interval' seconds
  (set! scheduled-tasks
        (cons (make-task name proc interval 0)
              scheduled-tasks)))

(define (run-scheduler)
  ;; Run scheduled tasks in loop
  (let loop ()
    (let ([now (current-time)])
      (for-each
        (lambda (task)
          (when (≥ (- now (task-last-run task))
                   (task-interval task))
            (log-info "Running task: ~a" (task-name task))
            ((task-proc task))
            (set-task-last-run! task now)))
        scheduled-tasks))
    (sleep 1)
    (loop)))

;; Example usage:
(schedule-task "cleanup"
               (lambda () (log-info "Running cleanup"))
               3600) ; Every hour

(schedule-task "backup"
               (lambda () (run-command "backup.sh"))
               86400) ; Every day

;; (run-scheduler) ; Start the scheduler

Cron-Style Scheduler

;; cron-scheduler.scm

(define-record-type <cron-task>
  (make-cron-task name proc schedule)
  cron-task?
  (name cron-task-name)
  (proc cron-task-proc)
  (schedule cron-task-schedule))

(define (parse-cron-schedule str)
  ;; Parse simple cron-like schedule
  ;; Format: "minute hour day month weekday"
  ;; Example: "0 2 * * *" = every day at 2:00 AM
  (let ([parts (string-split str #\space)])
    (map (lambda (part)
           (cond
             [(string=? part "*") 'any]
             [(string-contains? part ",")
              (map string→number (string-split part #\,))]
             [(string-contains? part "-")
              (let ([range (string-split part #\-)])
                (cons 'range (map string→number range)))]
             [else (string→number part)]))
         parts)))

(define (matches-schedule? schedule time)
  ;; Check if current time matches schedule
  (let ([minute (time-minute time)]
        [hour (time-hour time)]
        [day (time-day time)]
        [month (time-month time)]
        [weekday (time-weekday time)])
    
    (define (matches? sched-part value)
      (cond
        [(eq? sched-part 'any) #t]
        [(number? sched-part) (= sched-part value)]
        [(pair? sched-part)
         (if (eq? (car sched-part) 'range)
             (≤ (cadr sched-part) value (caddr sched-part))
             (member value sched-part))]
        [else #f]))
    
    (and (matches? (list-ref schedule 0) minute)
         (matches? (list-ref schedule 1) hour)
         (matches? (list-ref schedule 2) day)
         (matches? (list-ref schedule 3) month)
         (matches? (list-ref schedule 4) weekday))))

;; Example:
(define backup-task
  (make-cron-task "backup"
                  (lambda () (run-command "backup.sh"))
                  (parse-cron-schedule "0 2 * * *")))

14.9 Complete Script Examples

Log Analyzer

#!/usr/bin/env scheme-script
;; log-analyzer.scm
;; Analyze server log files

(import (scheme base)
        (scheme write)
        (scheme file))

(define (analyze-log file)
  (define stats (make-hash-table))
  (define error-count 0)
  (define warning-count 0)
  (define total-lines 0)
  
  (call-with-input-file file
    (lambda (port)
      (let loop ()
        (let ([line (read-line port)])
          (unless (eof-object? line)
            (set! total-lines (+ total-lines 1))
            
            (cond
              [(string-contains? line "ERROR")
               (set! error-count (+ error-count 1))]
              [(string-contains? line "WARNING")
               (set! warning-count (+ warning-count 1))])
            
            ;; Count status codes
            (let ([match (regexp-match "HTTP/[0-9.]+ ([0-9]+)" line)])
              (when match
                (let ([code (cadr match)])
                  (hash-table-set! stats code
                    (+ 1 (hash-table-ref/default stats code 0))))))
            
            (loop))))))
  
  ;; Print report
  (display "≡ Log Analysis Report ≡\n")
  (display (string-append "Total lines: " (number→string total-lines) "\n"))
  (display (string-append "Errors: " (number→string error-count) "\n"))
  (display (string-append "Warnings: " (number→string warning-count) "\n"))
  (display "\nHTTP Status Codes:\n")
  (hash-table-for-each stats
    (lambda (code count)
      (display (string-append "  " code ": " 
                             (number→string count) "\n")))))

;; Run if executed as script
(when (> (length (command-line)) 1)
  (analyze-log (cadr (command-line))))

Batch Image Processor

#!/usr/bin/env scheme-script
;; image-processor.scm
;; Batch process images using ImageMagick

(import (scheme base))

(define (process-images source-dir dest-dir operations)
  ;; Find all images
  (let ([images (glob-find source-dir "*.jpg")])
    (ensure-directory dest-dir)
    
    (let ([prog (make-progress (length images))])
      (for-each
        (lambda (img)
          (let* ([filename (path-filename img)]
                 [output (string-append dest-dir "/" filename)]
                 [cmd (build-convert-command img output operations)])
            (log-info "Processing ~a" filename)
            (run-command cmd)
            (progress-update! prog 1)
            (display-progress prog)))
        images)
      (newline))))

(define (build-convert-command input output ops)
  (string-append "convert " input " "
                 (string-join ops " ") " "
                 output))

;; Example operations
(define resize-ops '("-resize 800x600"))
(define quality-ops '("-quality 85"))
(define watermark-ops '("-gravity southeast"
                       "-draw 'text 10,10 \"©2024\"'"))

;; Usage:
;; (process-images "photos/original"
;;                 "photos/processed"
;;                 (append resize-ops quality-ops watermark-ops))

System Monitor

#!/usr/bin/env scheme-script
;; system-monitor.scm
;; Monitor system resources and send alerts

(import (scheme base))

(define (check-disk-space)
  (let* ([output (run-command-string "df" "-h")]
         [lines (string-split output #\newline)])
    (filter-map
      (lambda (line)
        (let ([parts (string-split line)])
          (when (> (length parts) 4)
            (let ([usage (string→number 
                          (string-trim-right (list-ref parts 4) #\%))])
              (when (and usage (> usage 80))
                (list (list-ref parts 0) usage))))))
      lines)))

(define (check-memory)
  (let* ([output (run-command-string "free" "-m")]
         [lines (string-split output #\newline)])
    (when (> (length lines) 1)
      (let* ([mem-line (cadr lines)]
             [parts (string-split mem-line)]
             [total (string→number (list-ref parts 1))]
             [used (string→number (list-ref parts 2))]
             [percent (* 100.0 (/ used total))])
        (when (> percent 90)
          percent)))))

(define (send-alert message)
  (log-critical message)
  ;; Could also send email, SMS, etc.
  (run-command "notify-send" "System Alert" message))

(define (monitor-loop)
  (let loop ()
    ;; Check disk space
    (let ([low-disks (check-disk-space)])
      (for-each
        (lambda (disk)
          (send-alert (format "Disk ~a is ~a% full" 
                            (car disk) (cadr disk))))
        low-disks))
    
    ;; Check memory
    (let ([mem-usage (check-memory)])
      (when mem-usage
        (send-alert (format "Memory usage at ~,1f%" mem-usage))))
    
    (sleep 300) ; Check every 5 minutes
    (loop)))

;; Start monitoring
;; (monitor-loop)

Summary

This chapter covered Scheme for scripting and automation:

  1. Command-Line Tools: Argument parsing, help generation

  2. File Operations: Directory traversal, glob matching, file manipulation

  3. Process Management: Running commands, pipelines, background processes

  4. Text Processing: Stream processing, CSV handling, batch operations

  5. Configuration: INI and JSON file parsing

  6. Logging: Log levels, file output, progress monitoring

  7. Scheduling: Task scheduling, cron-style execution

  8. Complete Examples: Real-world automation scripts

Key Takeaways:

  • Scheme’s expressiveness makes it excellent for scripting

  • First-class functions enable flexible text processing

  • Integration with shell commands provides system access

  • REPL enables rapid development and testing

  • Proper error handling and logging are essential

  • Automation saves time and reduces errors

Best Practices:

  • Use clear command-line interfaces

  • Provide helpful error messages

  • Log important operations

  • Make scripts idempotent when possible

  • Handle edge cases gracefully

  • Document script usage and options

Chapter #15: Web Programming with Scheme

Introduction

Web programming with Scheme leverages the language’s functional nature, powerful macro system, and REPL-driven development to create web applications, servers, and HTTP clients. This chapter explores both server-side and client-side web development using Scheme.

15.1 HTTP Fundamentals

Understanding HTTP Protocol

;; Basic HTTP request structure
(define (parse-http-request request-string)
  (let* ([lines (string-split request-string "\r\n")]
         [request-line (car lines)]
         [headers (cdr lines)])
    (let ([parts (string-split request-line " ")])
      `((method . ,(car parts))
        (path . ,(cadr parts))
        (version . ,(caddr parts))
        (headers . ,(parse-headers headers))))))

;; Parse HTTP headers
(define (parse-headers header-lines)
  (filter-map
   (lambda (line)
     (let ([idx (string-index line #\:)])
       (if idx
           (cons (string-trim (substring line 0 idx))
                 (string-trim (substring line (+ idx 1))))
           #f)))
   header-lines))

;; Example usage
(define sample-request
  "GET /api/users HTTP/1.1\r\nHost: example.com\r\nUser-Agent: Scheme/1.0\r\n\r\n")

(parse-http-request sample-request)
;; ⇒ ((method . "GET")
;;     (path . "/api/users")
;;     (version . "HTTP/1.1")
;;     (headers . (("Host" . "example.com")
;;                 ("User-Agent" . "Scheme/1.0"))))

Building HTTP Responses

;; HTTP response builder
(define (make-http-response status headers body)
  (let ([status-line (format "HTTP/1.1 ~a ~a\r\n"
                            (car status)
                            (cdr status))]
        [header-lines (string-join
                       (map (lambda (h)
                              (format "~a: ~a" (car h) (cdr h)))
                            headers)
                       "\r\n")]
        [body-length (string-length body)])
    (string-append
     status-line
     header-lines
     "\r\n"
     (format "Content-Length: ~a\r\n" body-length)
     "\r\n"
     body)))

;; Common status codes
(define http-200 '(200 . "OK"))
(define http-404 '(404 . "Not Found"))
(define http-500 '(500 . "Internal Server Error"))

;; Example: Simple HTML response
(define (html-response content)
  (make-http-response
   http-200
   '(("Content-Type" . "text/html; charset=utf-8"))
   content))

;; Example: JSON response
(define (json-response data)
  (make-http-response
   http-200
   '(("Content-Type" . "application/json"))
   (json-encode data)))

15.2 Simple HTTP Server

Basic TCP Server

;; Simple TCP server (using Racket's networking)
(require racket/tcp)

(define (start-server port handler)
  (define listener (tcp-listen port 5 #t))
  (printf "Server listening on port ~a\n" port)
  
  (let loop ()
    (define-values (in out) (tcp-accept listener))
    (thread
     (lambda ()
       (with-handlers ([exn:fail? (lambda (e)
                                   (displayln "Error handling request")
                                   (displayln (exn-message e)))])
         (handler in out))
       (close-input-port in)
       (close-output-port out)))
    (loop)))

;; Simple echo handler
(define (echo-handler in out)
  (define request (read-line in))
  (fprintf out "HTTP/1.1 200 OK\r\n")
  (fprintf out "Content-Type: text/plain\r\n\r\n")
  (fprintf out "You sent: ~a\n" request))

;; Start server
;; (start-server 8080 echo-handler)

Request Router

;; Route definition structure
(define-record-type <route>
  (make-route method pattern handler)
  route?
  (method route-method)
  (pattern route-pattern)
  (handler route-handler))

;; Simple pattern matching for routes
(define (match-route pattern path)
  (define pattern-parts (string-split pattern "/"))
  (define path-parts (string-split path "/"))
  
  (if (not (= (length pattern-parts) (length path-parts)))
      #f
      (let loop ([pp pattern-parts]
                 [path path-parts]
                 [params '()])
        (cond
          [(null? pp) (reverse params)]
          [(string-prefix? (car pp) ":")
           (loop (cdr pp)
                 (cdr path)
                 (cons (cons (substring (car pp) 1)
                            (car path))
                       params))]
          [(string=? (car pp) (car path))
           (loop (cdr pp) (cdr path) params)]
          [else #f]))))

;; Router implementation
(define (make-router)
  (let ([routes '()])
    
    (lambda (command . args)
      (case command
        [(add-route)
         (set! routes (cons (apply make-route args) routes))]
        
        [(route)
         (let* ([method (car args)]
                [path (cadr args)])
           (let loop ([rs routes])
             (cond
               [(null? rs) #f]
               [(and (equal? method (route-method (car rs)))
                     (match-route (route-pattern (car rs)) path))
                ⇒ (lambda (params)
                     (cons (route-handler (car rs)) params))]
               [else (loop (cdr rs))])))]
        
        [(routes) routes]))))

;; Example usage
(define router (make-router))

(router 'add-route "GET" "/" 
        (lambda (params) "Home page"))

(router 'add-route "GET" "/users/:id"
        (lambda (params)
          (format "User ID: ~a" (cdr (assoc "id" params)))))

(router 'add-route "POST" "/api/data"
        (lambda (params) "Data received"))

;; Test routing
(router 'route "GET" "/users/123")
;; ⇒ (#<procedure> . (("id" . "123")))

Complete HTTP Server Example

(require racket/tcp racket/string)

(define (http-server port routes)
  (define listener (tcp-listen port 5 #t))
  (printf "HTTP Server running on http://localhost:~a\n" port)
  
  (let accept-loop ()
    (define-values (in out) (tcp-accept listener))
    
    (thread
     (lambda ()
       (with-handlers 
         ([exn:fail? 
           (lambda (e)
             (send-response out 500 
                          '(("Content-Type" . "text/plain"))
                          "Internal Server Error"))])
         
         ;; Read request
         (define request-line (read-line in 'any))
         (define headers (read-headers in))
         
         ;; Parse request
         (define parts (string-split request-line))
         (define method (car parts))
         (define path (cadr parts))
         
         ;; Route request
         (define route-result (routes 'route method path))
         
         (if route-result
             (let ([handler (car route-result)]
                   [params (cdr route-result)])
               (define response-body (handler params))
               (send-response out 200
                            '(("Content-Type" . "text/html"))
                            response-body))
             (send-response out 404
                          '(("Content-Type" . "text/plain"))
                          "Not Found")))
       
       (close-input-port in)
       (close-output-port out)))
    
    (accept-loop)))

;; Helper: Read HTTP headers
(define (read-headers in)
  (let loop ([headers '()])
    (define line (read-line in 'any))
    (if (or (eof-object? line) (string=? line ""))
        (reverse headers)
        (let ([idx (string-index line #\:)])
          (if idx
              (loop (cons (cons (substring line 0 idx)
                               (string-trim (substring line (+ idx 1))))
                         headers))
              (loop headers))))))

;; Helper: Send HTTP response
(define (send-response out status headers body)
  (fprintf out "HTTP/1.1 ~a ~a\r\n" status
           (case status
             [(200) "OK"]
             [(404) "Not Found"]
             [(500) "Internal Server Error"]
             [else "Unknown"]))
  
  (for-each (lambda (h)
              (fprintf out "~a: ~a\r\n" (car h) (cdr h)))
            headers)
  
  (fprintf out "Content-Length: ~a\r\n" (string-length body))
  (fprintf out "\r\n")
  (display body out)
  (flush-output out))

;; Example application
(define app-router (make-router))

(app-router 'add-route "GET" "/"
            (lambda (params)
              "<h1>Welcome to Scheme Web Server</h1>"))

(app-router 'add-route "GET" "/about"
            (lambda (params)
              "<h1>About Page</h1><p>Built with Scheme!</p>"))

(app-router 'add-route "GET" "/user/:name"
            (lambda (params)
              (format "<h1>Hello, ~a!</h1>" 
                     (cdr (assoc "name" params)))))

;; Start server
;; (http-server 8080 app-router)

15.3 Web Frameworks

Using Racket’s Web Server

(require web-server/servlet
         web-server/servlet-env)

;; Simple servlet
(define (start request)
  (response/xexpr
   `(html
     (head (title "Racket Web App"))
     (body
      (h1 "Hello from Racket!")
      (p "Request URI: " ,(url→string (request-uri request)))))))

;; Serve the application
(serve/servlet start
               #:servlet-path "/"
               #:port 8080
               #:launch-browser? #f)

Building a REST API

(require web-server/servlet
         web-server/servlet-env
         json)

;; In-memory data store
(define users (make-hash))
(define user-id-counter 0)

;; User structure
(define-struct user (id name email) #:transparent)

;; API handlers
(define (get-users request)
  (response/json
   (hash→list users)))

(define (get-user request id)
  (let ([user (hash-ref users id #f)])
    (if user
        (response/json (user→hash user))
        (response/json (hash 'error "User not found") #:code 404))))

(define (create-user request)
  (define bindings (request-bindings request))
  (define name (extract-binding/single 'name bindings))
  (define email (extract-binding/single 'email bindings))
  
  (set! user-id-counter (+ user-id-counter 1))
  (define new-user (make-user user-id-counter name email))
  (hash-set! users user-id-counter new-user)
  
  (response/json (user→hash new-user) #:code 201))

;; Helper: Convert user to hash
(define (user→hash u)
  (hash 'id (user-id u)
        'name (user-name u)
        'email (user-email u)))

;; Helper: JSON response
(define (response/json data #:code [code 200])
  (response/full
   code #"OK"
   (current-seconds)
   #"application/json"
   '()
   (list (string→bytes/utf-8 (jsexpr→string data)))))

;; Router for REST API
(define (api-dispatcher request)
  (define method (request-method request))
  (define path (url→string (request-uri request)))
  
  (match* (method path)
    [('get "/api/users")
     (get-users request)]
    
    [('get (regexp #rx"/api/users/([0-9]+)" (list _ id)))
     (get-user request (string→number id))]
    
    [('post "/api/users")
     (create-user request)]
    
    [(_ _)
     (response/json (hash 'error "Not found") #:code 404)]))

;; Start API server
;; (serve/servlet api-dispatcher
;;                #:servlet-regexp #rx""
;;                #:port 8080)

Template System

;; Simple template engine
(define (render-template template bindings)
  (let loop ([tmpl template])
    (cond
      [(string? tmpl) tmpl]
      [(symbol? tmpl)
       (let ([value (assoc tmpl bindings)])
         (if value
             (format "~a" (cdr value))
             (format "{{~a}}" tmpl)))]
      [(list? tmpl)
       (apply string-append (map loop tmpl))]
      [else (format "~a" tmpl)])))

;; Example template
(define user-template
  '(html
    (head (title "User Profile"))
    (body
     (h1 "Profile: " name)
     (p "Email: " email)
     (p "Member since: " join-date))))

;; Render with bindings
(render-template 
 user-template
 '((name . "Alice")
   (email . "alice@example.com")
   (join-date . "2024-01-15")))

15.4 HTTP Client

Making HTTP Requests

(require net/url net/uri-codec)

;; GET request
(define (http-get url-string)
  (define url (string→url url-string))
  (define in (get-pure-port url))
  (define response (port→string in))
  (close-input-port in)
  response)

;; Example
(define github-api "https://api.github.com/users/racket")
;; (http-get github-api)

;; POST request with data
(define (http-post url-string data)
  (define url (string→url url-string))
  (define post-data (alist→form-urlencoded data))
  
  (define in 
    (post-pure-port url 
                    (string→bytes/utf-8 post-data)
                    (list "Content-Type: application/x-www-form-urlencoded")))
  
  (define response (port→string in))
  (close-input-port in)
  response)

;; HTTP client with headers
(define (http-request method url-string #:headers [headers '()]
                                        #:data [data #f])
  (define url (string→url url-string))
  
  (define-values (status response-headers in)
    (http-sendrecv
     (url-host url)
     (url-path url)
     #:ssl? (equal? (url-scheme url) "https")
     #:method method
     #:headers headers
     #:data data))
  
  (define body (port→bytes in))
  (close-input-port in)
  
  (hash 'status status
        'headers response-headers
        'body (bytes→string/utf-8 body)))

API Client Example

;; GitHub API client
(define github-api-base "https://api.github.com")

(define (github-api-call endpoint)
  (define url (string-append github-api-base endpoint))
  (http-get url))

;; Get user information
(define (get-github-user username)
  (define data-string 
    (github-api-call (format "/users/~a" username)))
  (string→jsexpr data-string))

;; Get user repositories
(define (get-user-repos username)
  (define data-string
    (github-api-call (format "/users/~a/repos" username)))
  (string→jsexpr data-string))

;; Example usage
;; (get-github-user "racket")
;; (get-user-repos "racket")

;; Weather API client
(define (get-weather city api-key)
  (define base "http://api.openweathermap.org/data/2.5/weather")
  (define url 
    (format "~a?q=~a&appid=~a&units=metric"
            base
            (uri-encode city)
            api-key))
  
  (define response (http-get url))
  (string→jsexpr response))

15.5 WebSockets

WebSocket Server (Conceptual)

;; WebSocket frame structure
(define-record-type <ws-frame>
  (make-ws-frame opcode payload)
  ws-frame?
  (opcode ws-frame-opcode)
  (payload ws-frame-payload))

;; WebSocket opcodes
(define WS-TEXT-FRAME 1)
(define WS-BINARY-FRAME 2)
(define WS-CLOSE-FRAME 8)
(define WS-PING-FRAME 9)
(define WS-PONG-FRAME 10)

;; WebSocket connection handler
(define (websocket-handler in out)
  (define connections (make-hash))
  
  (define (broadcast message)
    (hash-for-each connections
      (lambda (conn-id conn)
        (send-ws-frame conn message))))
  
  (define (handle-frame frame)
    (case (ws-frame-opcode frame)
      [(WS-TEXT-FRAME)
       (printf "Received: ~a\n" (ws-frame-payload frame))
       (broadcast (ws-frame-payload frame))]
      
      [(WS-CLOSE-FRAME)
       (printf "Connection closed\n")]
      
      [(WS-PING-FRAME)
       (send-ws-frame out 
         (make-ws-frame WS-PONG-FRAME ""))]))
  
  ;; Connection loop
  (let loop ()
    (define frame (read-ws-frame in))
    (when frame
      (handle-frame frame)
      (loop))))

;; Chat server example
(define (chat-server-handler ws-conn)
  (define clients (make-hash))
  
  (lambda (message)
    (case (car message)
      [(join)
       (hash-set! clients (cadr message) ws-conn)]
      
      [(send)
       (hash-for-each clients
         (lambda (client-id client-conn)
           (ws-send client-conn (cadr message))))]
      
      [(leave)
       (hash-remove! clients (cadr message))])))

15.6 Session Management

;; Session store
(define sessions (make-hash))

;; Generate session ID
(define (generate-session-id)
  (define chars "abcdefghijklmnopqrstuvwxyz0123456789")
  (list→string
   (build-list 32
     (lambda (_)
       (string-ref chars (random (string-length chars)))))))

;; Create session
(define (create-session data)
  (define session-id (generate-session-id))
  (hash-set! sessions session-id data)
  session-id)

;; Get session
(define (get-session session-id)
  (hash-ref sessions session-id #f))

;; Update session
(define (update-session session-id data)
  (hash-set! sessions session-id data))

;; Delete session
(define (delete-session session-id)
  (hash-remove! sessions session-id))

;; Set cookie header
(define (set-cookie-header name value #:max-age [max-age 3600])
  (format "Set-Cookie: ~a=~a; Max-Age=~a; HttpOnly; SameSite=Strict"
          name value max-age))

;; Parse cookies from request
(define (parse-cookies cookie-header)
  (if (not cookie-header)
      '()
      (map (lambda (pair)
             (let ([parts (string-split pair "=")])
               (cons (string-trim (car parts))
                     (string-trim (cadr parts)))))
           (string-split cookie-header ";"))))

;; Example: Login handler with session
(define (login-handler request)
  (define username (extract-binding/single 'username 
                                          (request-bindings request)))
  
  ;; Create session
  (define session-id (create-session (hash 'username username
                                           'logged-in #t)))
  
  ;; Response with session cookie
  (response/full
   200 #"OK"
   (current-seconds)
   #"text/html"
   (list (set-cookie-header "session_id" session-id))
   (list (string→bytes/utf-8 
          (format "<h1>Welcome, ~a!</h1>" username)))))

Middleware Pattern

;; Middleware: Log requests
(define (logging-middleware handler)
  (lambda (request)
    (printf "[~a] ~a ~a\n"
            (date→string (current-date) #t)
            (request-method request)
            (url→string (request-uri request)))
    (handler request)))

;; Middleware: Session management
(define (session-middleware handler)
  (lambda (request)
    (define cookies (parse-cookies 
                     (headers-assq #"Cookie" (request-headers request))))
    (define session-id (cdr (assoc "session_id" cookies)))
    (define session-data (get-session session-id))
    
    ;; Add session to request
    (define enhanced-request
      (struct-copy request request
                   [session session-data]))
    
    (handler enhanced-request)))

;; Middleware: Authentication
(define (auth-middleware handler)
  (lambda (request)
    (define session (request-session request))
    
    (if (and session (hash-ref session 'logged-in #f))
        (handler request)
        (response/full
         401 #"Unauthorized"
         (current-seconds)
         #"text/html"
         '()
         (list #"<h1>401 Unauthorized</h1>")))))

;; Compose middleware
(define (compose-middleware . middlewares)
  (lambda (handler)
    (foldl (lambda (mw acc) (mw acc))
           handler
           (reverse middlewares))))

;; Example: Protected route with middleware stack
(define protected-handler
  ((compose-middleware
    logging-middleware
    session-middleware
    auth-middleware)
   (lambda (request)
     (response/xexpr
      `(html
        (body
         (h1 "Protected Content")
         (p "You are logged in!")))))))

15.7 Database Integration

SQLite Integration

(require db)

;; Connect to database
(define conn (sqlite3-connect #:database "myapp.db"))

;; Create table
(query-exec conn
  "CREATE TABLE IF NOT EXISTS users (
     id INTEGER PRIMARY KEY AUTOINCREMENT,
     username TEXT UNIQUE NOT NULL,
     email TEXT NOT NULL,
     created_at TIMESTAMP DEFAULT CURRENT_TIMESTAMP
   )")

;; Insert user
(define (insert-user username email)
  (query-exec conn
    "INSERT INTO users (username, email) VALUES (?, ?)"
    username email))

;; Get user by ID
(define (get-user-by-id id)
  (query-row conn
    "SELECT * FROM users WHERE id = ?" id))

;; Get all users
(define (get-all-users)
  (query-rows conn
    "SELECT id, username, email FROM users"))

;; Update user
(define (update-user-email id new-email)
  (query-exec conn
    "UPDATE users SET email = ? WHERE id = ?" 
    new-email id))

;; Delete user
(define (delete-user id)
  (query-exec conn
    "DELETE FROM users WHERE id = ?" id))

;; Transaction example
(define (transfer-credits from-user to-user amount)
  (call-with-transaction conn
    (lambda ()
      (query-exec conn
        "UPDATE accounts SET balance = balance - ? WHERE user_id = ?"
        amount from-user)
      (query-exec conn
        "UPDATE accounts SET balance = balance + ? WHERE user_id = ?"
        amount to-user))))

;; Example: User management API with database
(define (api-create-user request)
  (define data (request-post-data/raw request))
  (define json (bytes→jsexpr data))
  
  (with-handlers 
    ([exn:fail:sql? 
      (lambda (e)
        (response/json 
         (hash 'error "User already exists") 
         #:code 409))])
    
    (insert-user (hash-ref json 'username)
                 (hash-ref json 'email))
    
    (response/json 
     (hash 'message "User created successfully")
     #:code 201)))

15.8 Security Considerations

Input Validation and Sanitization

;; Email validation
(define email-pattern 
  #rx"^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\\.[a-zA-Z]{2,}$")

(define (valid-email? email)
  (regexp-match? email-pattern email))

;; SQL injection prevention (use parameterized queries)
(define (safe-query username)
  ;; GOOD: Parameterized
  (query-rows conn
    "SELECT * FROM users WHERE username = ?" username)
  
  ;; BAD: String concatenation (vulnerable)
  ;; (query-rows conn
  ;;   (string-append "SELECT * FROM users WHERE username = '" 
  ;;                  username "'"))
  )

;; XSS prevention: HTML entity encoding
(define (html-escape str)
  (string-replace*
   str
   '(("&" . "&amp;")
     ("<" . "&lt;")
     (">" . "&gt;")
     ("\"" . "&quot;")
     ("'" . "&#x27;"))))

;; CSRF token generation
(define (generate-csrf-token)
  (bytes→hex-string
   (crypto-random-bytes 32)))

(define (verify-csrf-token session-token request-token)
  (and session-token request-token
       (string=? session-token request-token)))

;; Password hashing
(require crypto)

(define (hash-password password)
  (pbkdf2-hmac 'sha256
               (string→bytes/utf-8 password)
               (crypto-random-bytes 16)
               10000
               32))

(define (verify-password password hash-bytes)
  (bytes=? (hash-password password) hash-bytes))

Rate Limiting

;; Simple rate limiter
(define rate-limits (make-hash))

(define (rate-limit-middleware handler 
                                #:max-requests [max-requests 100]
                                #:window [window 60])
  (lambda (request)
    (define client-ip (request-client-ip request))
    (define now (current-seconds))
    
    (define limit-data (hash-ref rate-limits client-ip 
                                 (cons 0 now)))
    (define count (car limit-data))
    (define start-time (cdr limit-data))
    
    (if (> (- now start-time) window)
        ;; Reset window
        (begin
          (hash-set! rate-limits client-ip (cons 1 now))
          (handler request))
        
        ;; Check limit
        (if (≥ count max-requests)
            (response/full
             429 #"Too Many Requests"
             (current-seconds)
             #"text/plain"
             '()
             (list #"Rate limit exceeded. Try again later."))
            
            (begin
              (hash-set! rate-limits client-ip 
                        (cons (+ count 1) start-time))
              (handler request))))))

15.9 Complete Web Application Example

;; Blog application with authentication, database, and templating

(require web-server/servlet
         web-server/servlet-env
         db
         crypto)

;; Database setup
(define db-conn (sqlite3-connect #:database "blog.db"))

(query-exec db-conn
  "CREATE TABLE IF NOT EXISTS posts (
     id INTEGER PRIMARY KEY AUTOINCREMENT,
     title TEXT NOT NULL,
     content TEXT NOT NULL,
     author_id INTEGER NOT NULL,
     created_at TIMESTAMP DEFAULT CURRENT_TIMESTAMP
   )")

(query-exec db-conn
  "CREATE TABLE IF NOT EXISTS users (
     id INTEGER PRIMARY KEY AUTOINCREMENT,
     username TEXT UNIQUE NOT NULL,
     password_hash BLOB NOT NULL
   )")

;; User functions
(define (create-user username password)
  (define hash (hash-password password))
  (query-exec db-conn
    "INSERT INTO users (username, password_hash) VALUES (?, ?)"
    username hash))

(define (authenticate-user username password)
  (define user 
    (query-maybe-row db-conn
      "SELECT id, password_hash FROM users WHERE username = ?"
      username))
  
  (and user
       (verify-password password (vector-ref user 1))
       (vector-ref user 0)))  ; Return user ID

;; Post functions
(define (create-post title content author-id)
  (query-exec db-conn
    "INSERT INTO posts (title, content, author_id) VALUES (?, ?, ?)"
    title content author-id))

(define (get-all-posts)
  (query-rows db-conn
    "SELECT p.id, p.title, p.content, u.username, p.created_at
     FROM posts p
     JOIN users u ON p.author_id = u.id
     ORDER BY p.created_at DESC"))

(define (get-post-by-id id)
  (query-maybe-row db-conn
    "SELECT p.id, p.title, p.content, u.username, p.created_at
     FROM posts p
     JOIN users u ON p.author_id = u.id
     WHERE p.id = ?" id))

;; Template rendering
(define (render-layout title content)
  `(html
    (head
     (title ,title)
     (style "body { font-family: Arial; max-width: 800px; margin: 0 auto; }
             .post { border: 1px solid #ddd; padding: 1em; margin: 1em 0; }"))
    (body
     (h1 "My Blog")
     (nav
      (a ([href "/"]) "Home")
      " | "
      (a ([href "/new-post"]) "New Post")
      " | "
      (a ([href "/login"]) "Login"))
     (hr)
     ,content)))

(define (render-posts posts)
  `(div
    (h2 "Recent Posts")
    ,@(map (lambda (post)
             `(div ([class "post"])
                (h3 ,(vector-ref post 1))
                (p ,(vector-ref post 2))
                (small "by " ,(vector-ref post 3) 
                      " on " ,(vector-ref post 4))))
           posts)))

;; Request handlers
(define (home-page-handler request)
  (define posts (get-all-posts))
  (response/xexpr
   (render-layout "Home" (render-posts posts))))

(define (new-post-handler request)
  (define session (get-session-from-request request))
  
  (if (not session)
      (redirect-to "/login")
      
      (case (request-method request)
        [(get)
         (response/xexpr
          (render-layout
           "New Post"
           `(form ([method "post"])
             (p (label "Title: " (input ([type "text"] [name "title"]))))
             (p (label "Content: " 
                      (textarea ([name "content"] [rows "10"] [cols "50"]))))
             (button ([type "submit"]) "Publish"))))]
        
        [(post)
         (define bindings (request-bindings request))
         (define title (extract-binding/single 'title bindings))
         (define content (extract-binding/single 'content bindings))
         
         (create-post title content (hash-ref session 'user-id))
         (redirect-to "/")])))

(define (login-handler request)
  (case (request-method request)
    [(get)
     (response/xexpr
      (render-layout
       "Login"
       `(form ([method "post"])
         (p (label "Username: " (input ([type "text"] [name "username"]))))
         (p (label "Password: " (input ([type "password"] [name "password"]))))
         (button ([type "submit"]) "Login"))))]
    
    [(post)
     (define bindings (request-bindings request))
     (define username (extract-binding/single 'username bindings))
     (define password (extract-binding/single 'password bindings))
     
     (define user-id (authenticate-user username password))
     
     (if user-id
         (let ([session-id (create-session 
                           (hash 'user-id user-id
                                'username username))])
           (response/full
            302 #"Found"
            (current-seconds)
            #"text/html"
            (list (format "Location: /" )
                  (set-cookie-header "session_id" session-id))
            '()))
         
         (response/xexpr
          (render-layout "Login Failed" 
                        '(p "Invalid credentials"))))]))

;; Main dispatcher
(define (blog-dispatcher request)
  (define path (url→string (request-uri request)))
  
  (cond
    [(string=? path "/") (home-page-handler request)]
    [(string=? path "/new-post") (new-post-handler request)]
    [(string=? path "/login") (login-handler request)]
    [else (response/xexpr '(html (body (h1 "404 Not Found"))))]))

;; Start the blog server
;; (serve/servlet blog-dispatcher
;;                #:servlet-regexp #rx""
;;                #:port 8080
;;                #:launch-browser? #f)

15.10 Exercises

Exercise 15.1: URL Shortener

Create a URL shortening service with:

  • API endpoint to shorten URLs

  • Redirect handler for short codes

  • Statistics tracking (click counts)

  • Database persistence

Exercise 15.2: RESTful API

Build a complete REST API for a task management system:

  • CRUD operations for tasks

  • User authentication with JWT

  • Filtering and pagination

  • API documentation endpoint

Exercise 15.3: Real-time Chat

Implement a WebSocket-based chat application:

  • Multiple chat rooms

  • User presence indicators

  • Message history

  • Private messaging

Exercise 15.4: Content Management System

Create a simple CMS with:

  • Markdown content editing

  • Media file uploads

  • Category/tag system

  • Search functionality

Exercise 15.5: API Gateway

Build an API gateway that:

  • Routes requests to backend services

  • Implements rate limiting

  • Provides request/response logging

  • Handles authentication

Summary

Chapter 15 covered web programming with Scheme:

  1. HTTP Fundamentals: Request/response parsing, status codes, headers

  2. HTTP Server: TCP server basics, routing, complete server implementation

  3. Web Frameworks: Racket Web Server, REST APIs, templating

  4. HTTP Client: Making requests, API clients

  5. WebSockets: Real-time bidirectional communication

  6. Session Management: Cookies, session stores, middleware patterns

  7. Database Integration: SQLite with parameterized queries, transactions

  8. Security: Input validation, XSS/CSRF prevention, rate limiting, password hashing

  9. Complete Application: Full-featured blog with authentication

These techniques enable building production-ready web applications and APIs using Scheme’s functional programming paradigm.

Chapter #16: Network Programming

Introduction

Network programming in Scheme involves working with sockets, protocols, and distributed systems. This chapter explores low-level socket programming, protocol implementation, network utilities, and distributed computing patterns beyond HTTP web programming.

16.1 Socket Programming Fundamentals

TCP Sockets

;; TCP client socket (using Racket)
(require racket/tcp)

(define (tcp-client host port)
  (define-values (in out) (tcp-connect host port))
  (values in out))

;; Example: Connect to a time server
(define (get-network-time host)
  (define-values (in out) (tcp-connect host 13))  ; daytime port
  (define time-string (read-line in))
  (close-input-port in)
  (close-output-port out)
  time-string)

;; Usage
;; (get-network-time "time.nist.gov")

;; Simple echo client
(define (echo-client host port message)
  (define-values (in out) (tcp-connect host port))
  
  (displayln message out)
  (flush-output out)
  
  (define response (read-line in))
  
  (close-input-port in)
  (close-output-port out)
  
  response)

TCP Server Implementation

;; Basic TCP server
(define (tcp-server port handler)
  (define listener (tcp-listen port 5 #t))
  (printf "Server listening on port ~a\n" port)
  
  (let accept-loop ()
    (define-values (in out) (tcp-accept listener))
    
    ;; Handle each connection in a separate thread
    (thread
     (lambda ()
       (with-handlers ([exn:fail? 
                       (lambda (e)
                         (printf "Error: ~a\n" (exn-message e)))])
         (handler in out))
       (close-input-port in)
       (close-output-port out)))
    
    (accept-loop)))

;; Example: Echo server
(define (echo-handler in out)
  (let loop ()
    (define line (read-line in 'any))
    (unless (eof-object? line)
      (displayln line out)
      (flush-output out)
      (loop))))

;; Start echo server
;; (tcp-server 9999 echo-handler)

;; Example: Simple calculator server
(define (calculator-handler in out)
  (displayln "Welcome to Calculator Server" out)
  (displayln "Enter expressions (e.g., + 2 3)" out)
  (flush-output out)
  
  (let loop ()
    (define line (read-line in 'any))
    (unless (eof-object? line)
      (define result
        (with-handlers ([exn:fail? (lambda (e) "Error in expression")])
          (let ([expr (read (open-input-string line))])
            (cond
              [(and (list? expr) (= (length expr) 3))
               (let ([op (car expr)]
                     [a (cadr expr)]
                     [b (caddr expr)])
                 (case op
                   [(+) (+ a b)]
                   [(-) (- a b)]
                   [(*) (* a b)]
                   [(/) (/ a b)]
                   [else "Unknown operator"]))]
              [else "Invalid expression"]))))
      
      (fprintf out "Result: ~a\n" result)
      (flush-output out)
      (loop))))

;; (tcp-server 8888 calculator-handler)

UDP Sockets

;; UDP client and server
(require racket/udp)

;; UDP client
(define (udp-send host port message)
  (define sock (udp-open-socket))
  (udp-send-to sock host port (string→bytes/utf-8 message))
  (udp-close sock))

;; UDP server
(define (udp-server port handler)
  (define sock (udp-bind! (udp-open-socket) #f port))
  (printf "UDP server listening on port ~a\n" port)
  
  (let loop ()
    (define buffer (make-bytes 1024))
    (define-values (count source-host source-port)
      (udp-receive! sock buffer))
    
    (define message (bytes→string/utf-8 (subbytes buffer 0 count)))
    
    ;; Handle message in separate thread
    (thread
     (lambda ()
       (define response (handler message source-host source-port))
       (when response
         (udp-send-to sock source-host source-port 
                     (string→bytes/utf-8 response)))))
    
    (loop)))

;; Example: UDP echo server
(define (udp-echo-handler message host port)
  (printf "Received from ~a:~a: ~a\n" host port message)
  (string-append "Echo: " message))

;; (udp-server 9998 udp-echo-handler)

16.2 Protocol Implementation

Custom Protocol Design

;; Simple text-based protocol
;; Format: COMMAND|ARG1|ARG2|…|ARGN\n

(define (parse-protocol-message msg)
  (define parts (string-split msg "|"))
  (cons (string→symbol (car parts)) (cdr parts)))

(define (format-protocol-message command . args)
  (string-append
   (symbol→string command)
   (if (null? args)
       ""
       (string-append "|" (string-join args "|")))
   "\n"))

;; Example commands
(define (handle-protocol-command command args)
  (case command
    [(PING)
     (format-protocol-message 'PONG)]
    
    [(ECHO)
     (format-protocol-message 'ECHO (car args))]
    
    [(ADD)
     (let ([sum (apply + (map string→number args))])
       (format-protocol-message 'RESULT (number→string sum)))]
    
    [(QUIT)
     #f]
    
    [else
     (format-protocol-message 'ERROR "Unknown command")]))

;; Protocol server
(define (protocol-server port)
  (tcp-server port
    (lambda (in out)
      (let loop ()
        (define line (read-line in 'any))
        (unless (eof-object? line)
          (define parsed (parse-protocol-message line))
          (define response 
            (handle-protocol-command (car parsed) (cdr parsed)))
          
          (when response
            (display response out)
            (flush-output out)
            (loop)))))))

;; Protocol client
(define (protocol-client host port)
  (define-values (in out) (tcp-connect host port))
  
  (define (send-command command . args)
    (define msg (apply format-protocol-message command args))
    (display msg out)
    (flush-output out)
    
    (define response (read-line in 'any))
    (if (eof-object? response)
        #f
        (parse-protocol-message response)))
  
  (lambda (action . args)
    (case action
      [(send) (apply send-command args)]
      [(close) 
       (close-input-port in)
       (close-output-port out)])))

;; Usage example
;; (define client (protocol-client "localhost" 8888))
;; (client 'send 'PING)           ; ⇒ '(PONG)
;; (client 'send 'ADD "10" "20")  ; ⇒ '(RESULT "30")
;; (client 'close)

Binary Protocol Example

;; Binary protocol with fixed-size headers
(require racket/serialize)

;; Message structure:
;; [Type: 1 byte][Length: 4 bytes][Payload: N bytes]

(define MSG-TYPE-DATA 1)
(define MSG-TYPE-ACK 2)
(define MSG-TYPE-ERROR 3)

;; Create binary message
(define (make-binary-message type payload)
  (define payload-bytes 
    (if (bytes? payload)
        payload
        (string→bytes/utf-8 payload)))
  
  (define length (bytes-length payload-bytes))
  
  (bytes-append
   (bytes type)
   (integer→integer-bytes length 4 #f #t)  ; 4-byte big-endian
   payload-bytes))

;; Parse binary message
(define (parse-binary-message bytes-in)
  (define type (bytes-ref bytes-in 0))
  (define length (integer-bytes→integer 
                  (subbytes bytes-in 1 5) #f #t))
  (define payload (subbytes bytes-in 5 (+ 5 length)))
  
  (list type length payload))

;; Send binary message
(define (send-binary-message out type payload)
  (define msg (make-binary-message type payload))
  (write-bytes msg out)
  (flush-output out))

;; Receive binary message
(define (receive-binary-message in)
  (define header (read-bytes 5 in))
  (if (eof-object? header)
      #f
      (let* ([type (bytes-ref header 0)]
             [length (integer-bytes→integer 
                     (subbytes header 1 5) #f #t)]
             [payload (read-bytes length in)])
        (list type payload))))

;; Binary protocol server
(define (binary-protocol-handler in out)
  (let loop ()
    (define msg (receive-binary-message in))
    (when msg
      (match msg
        [(list MSG-TYPE-DATA payload)
         (printf "Received data: ~a\n" 
                (bytes→string/utf-8 payload))
         (send-binary-message out MSG-TYPE-ACK #"OK")]
        
        [_ 
         (send-binary-message out MSG-TYPE-ERROR #"Unknown type")])
      
      (loop))))

16.3 Network Utilities

Port Scanner

;; Simple port scanner
(define (scan-port host port)
  (with-handlers ([exn:fail? (lambda (e) #f)])
    (define-values (in out) (tcp-connect host port))
    (close-input-port in)
    (close-output-port out)
    #t))

(define (port-scan host start-port end-port)
  (printf "Scanning ~a from port ~a to ~a\n" host start-port end-port)
  
  (filter values
    (for/list ([port (in-range start-port (+ end-port 1))])
      (when (scan-port host port)
        (printf "Port ~a is open\n" port)
        port))))

;; Parallel port scanner
(define (parallel-port-scan host start-port end-port)
  (define threads
    (for/list ([port (in-range start-port (+ end-port 1))])
      (thread
       (lambda ()
         (if (scan-port host port)
             port
             #f)))))
  
  (filter values (map thread-wait threads)))

;; Usage
;; (port-scan "localhost" 8000 8100)

Network Speed Test

;; Measure network throughput
(define (network-speed-test host port data-size)
  (define test-data (make-bytes data-size 65))  ; Fill with 'A'
  
  (define-values (in out) (tcp-connect host port))
  
  ;; Measure upload speed
  (define upload-start (current-inexact-milliseconds))
  (write-bytes test-data out)
  (flush-output out)
  (define upload-end (current-inexact-milliseconds))
  
  (define upload-time (- upload-end upload-start))
  (define upload-speed (/ data-size upload-time 1000))  ; KB/s
  
  ;; Wait for echo back (for download test)
  (define download-start (current-inexact-milliseconds))
  (read-bytes data-size in)
  (define download-end (current-inexact-milliseconds))
  
  (define download-time (- download-end download-start))
  (define download-speed (/ data-size download-time 1000))  ; KB/s
  
  (close-input-port in)
  (close-output-port out)
  
  (hash 'upload-speed upload-speed
        'download-speed download-speed
        'upload-time upload-time
        'download-time download-time))

;; Connection latency measurement (ping)
(define (measure-latency host port iterations)
  (define latencies
    (for/list ([i iterations])
      (define start (current-inexact-milliseconds))
      (with-handlers ([exn:fail? (lambda (e) #f)])
        (define-values (in out) (tcp-connect host port))
        (close-input-port in)
        (close-output-port out)
        (- (current-inexact-milliseconds) start))))
  
  (define valid-latencies (filter values latencies))
  
  (if (null? valid-latencies)
      #f
      (hash 'min (apply min valid-latencies)
            'max (apply max valid-latencies)
            'avg (/ (apply + valid-latencies) 
                   (length valid-latencies))
            'packet-loss (* 100 (/ (- iterations 
                                     (length valid-latencies))
                                  iterations)))))

DNS Lookup

;; DNS resolution utilities
(require net/dns)

;; Resolve hostname to IP
(define (dns-lookup hostname)
  (with-handlers ([exn:fail? (lambda (e) #f)])
    (dns-get-address (dns-find-nameserver) hostname)))

;; Reverse DNS lookup
(define (reverse-dns-lookup ip-address)
  (with-handlers ([exn:fail? (lambda (e) #f)])
    (dns-get-name (dns-find-nameserver) ip-address)))

;; Get all DNS records
(define (get-dns-records hostname record-type)
  (with-handlers ([exn:fail? (lambda (e) '())])
    (case record-type
      [(A) (dns-get-address (dns-find-nameserver) hostname #t)]
      [(MX) (dns-get-mail-exchanger (dns-find-nameserver) hostname)]
      [else '()])))

;; Example
;; (dns-lookup "example.com")
;; (get-dns-records "example.com" 'MX)

16.4 Remote Procedure Call (RPC)

Simple RPC Framework

;; RPC message format: (procedure-name arg1 arg2 … argN)

(define (rpc-serialize call)
  (define s-expr call)
  (bytes-append
   (string→bytes/utf-8 (format "~s" s-expr))
   #"\n"))

(define (rpc-deserialize bytes-data)
  (read (open-input-bytes bytes-data)))

;; RPC server
(define (rpc-server port procedures)
  (tcp-server port
    (lambda (in out)
      (let loop ()
        (define request-bytes (read-line in 'any))
        (unless (eof-object? request-bytes)
          (define request (rpc-deserialize 
                          (string→bytes/utf-8 request-bytes)))
          
          (define result
            (with-handlers ([exn:fail? 
                           (lambda (e) 
                             `(error ,(exn-message e)))])
              (let ([proc-name (car request)]
                    [args (cdr request)])
                (define proc (hash-ref procedures proc-name #f))
                (if proc
                    `(result ,(apply proc args))
                    `(error "Unknown procedure")))))
          
          (write-bytes (rpc-serialize result) out)
          (flush-output out)
          (loop))))))

;; RPC client
(define (make-rpc-client host port)
  (define-values (in out) (tcp-connect host port))
  
  (lambda (procedure-name . args)
    (define request (cons procedure-name args))
    (write-bytes (rpc-serialize request) out)
    (flush-output out)
    
    (define response-line (read-line in 'any))
    (if (eof-object? response-line)
        (error "Connection closed")
        (let ([response (rpc-deserialize 
                        (string→bytes/utf-8 response-line))])
          (match response
            [`(result ,value) value]
            [`(error ,msg) (error msg)]
            [_ (error "Invalid response")])))))

;; Example RPC procedures
(define calculator-procedures
  (hash 'add +
        'subtract -
        'multiply *
        'divide /
        'square (lambda (x) (* x x))
        'factorial (lambda (n)
                    (if (≤ n 1)
                        1
                        (* n (factorial (- n 1)))))))

;; Start RPC server
;; (thread (lambda () (rpc-server 9000 calculator-procedures)))

;; Use RPC client
;; (define calc (make-rpc-client "localhost" 9000))
;; (calc 'add 10 20)        ; ⇒ 30
;; (calc 'factorial 5)      ; ⇒ 120

Asynchronous RPC

;; Asynchronous RPC with callbacks
(define (make-async-rpc-client host port)
  (define-values (in out) (tcp-connect host port))
  (define pending-calls (make-hash))
  (define call-id 0)
  
  ;; Reader thread
  (thread
   (lambda ()
     (let loop ()
       (define response-line (read-line in 'any))
       (unless (eof-object? response-line)
         (define response (rpc-deserialize 
                          (string→bytes/utf-8 response-line)))
         
         (match response
           [`(response ,id ,result)
            (define callback (hash-ref pending-calls id #f))
            (when callback
              (callback result)
              (hash-remove! pending-calls id))]
           [_ (void)])
         
         (loop)))))
  
  ;; Return client interface
  (lambda (action . args)
    (case action
      [(call)
       (define proc-name (car args))
       (define proc-args (cadr args))
       (define callback (caddr args))
       
       (set! call-id (+ call-id 1))
       (hash-set! pending-calls call-id callback)
       
       (define request `(call ,call-id ,proc-name ,@proc-args))
       (write-bytes (rpc-serialize request) out)
       (flush-output out)
       call-id]
      
      [(close)
       (close-input-port in)
       (close-output-port out)])))

;; Usage
;; (define async-calc (make-async-rpc-client "localhost" 9000))
;; (async-calc 'call 'add '(10 20) 
;;             (lambda (result) (printf "Result: ~a\n" result)))

16.5 Distributed Systems

Message Queue

;; Simple message queue implementation
(define (make-message-queue)
  (define queue '())
  (define queue-semaphore (make-semaphore 1))
  (define message-semaphore (make-semaphore 0))
  
  (lambda (command . args)
    (case command
      [(enqueue)
       (semaphore-wait queue-semaphore)
       (set! queue (append queue (list (car args))))
       (semaphore-post queue-semaphore)
       (semaphore-post message-semaphore)]
      
      [(dequeue)
       (semaphore-wait message-semaphore)
       (semaphore-wait queue-semaphore)
       (define msg (car queue))
       (set! queue (cdr queue))
       (semaphore-post queue-semaphore)
       msg]
      
      [(size)
       (semaphore-wait queue-semaphore)
       (define len (length queue))
       (semaphore-post queue-semaphore)
       len]
      
      [(empty?)
       (null? queue)])))

;; Network message queue server
(define (message-queue-server port)
  (define mq (make-message-queue))
  
  (tcp-server port
    (lambda (in out)
      (let loop ()
        (define command (read-line in 'any))
        (unless (eof-object? command)
          (match (string-split command)
            [(list "PUSH" message)
             (mq 'enqueue message)
             (displayln "OK" out)]
            
            [(list "POP")
             (define msg (mq 'dequeue))
             (displayln msg out)]
            
            [(list "SIZE")
             (fprintf out "~a\n" (mq 'size))]
            
            [_ (displayln "ERROR: Invalid command" out)])
          
          (flush-output out)
          (loop))))))

;; (message-queue-server 9001)

Publish-Subscribe System

;; Pub/Sub broker
(define (make-pubsub-broker)
  (define subscribers (make-hash))  ; topic → list of connections
  (define lock (make-semaphore 1))
  
  (lambda (command . args)
    (semaphore-wait lock)
    (define result
      (case command
        [(subscribe)
         (define topic (car args))
         (define connection (cadr args))
         (hash-set! subscribers topic
                   (cons connection 
                         (hash-ref subscribers topic '())))]
        
        [(unsubscribe)
         (define topic (car args))
         (define connection (cadr args))
         (hash-set! subscribers topic
                   (remove connection 
                          (hash-ref subscribers topic '())))]
        
        [(publish)
         (define topic (car args))
         (define message (cadr args))
         (define conns (hash-ref subscribers topic '()))
         (for-each (lambda (conn) (conn message)) conns)]
        
        [(topics)
         (hash-keys subscribers)]))
    
    (semaphore-post lock)
    result))

;; Network pub/sub server
(define (pubsub-server port)
  (define broker (make-pubsub-broker))
  
  (tcp-server port
    (lambda (in out)
      (define (send-message msg)
        (displayln msg out)
        (flush-output out))
      
      (let loop ()
        (define line (read-line in 'any))
        (unless (eof-object? line)
          (match (string-split line)
            [(list "SUB" topic)
             (broker 'subscribe topic send-message)
             (displayln "Subscribed" out)]
            
            [(list "UNSUB" topic)
             (broker 'unsubscribe topic send-message)
             (displayln "Unsubscribed" out)]
            
            [(list "PUB" topic message)
             (broker 'publish topic message)
             (displayln "Published" out)]
            
            [_ (displayln "ERROR: Invalid command" out)])
          
          (flush-output out)
          (loop))))))

Load Balancer

;; Round-robin load balancer
(define (make-load-balancer backend-servers)
  (define current-index 0)
  (define lock (make-semaphore 1))
  
  (lambda ()
    (semaphore-wait lock)
    (define server (list-ref backend-servers current-index))
    (set! current-index 
          (modulo (+ current-index 1) (length backend-servers)))
    (semaphore-post lock)
    server))

;; Load balancer proxy server
(define (load-balancer-server port backends)
  (define balancer (make-load-balancer backends))
  
  (tcp-server port
    (lambda (client-in client-out)
      (define backend (balancer))
      (define backend-host (car backend))
      (define backend-port (cadr backend))
      
      (with-handlers ([exn:fail? 
                      (lambda (e)
                        (displayln "Backend error" client-out))])
        
        (define-values (backend-in backend-out)
          (tcp-connect backend-host backend-port))
        
        ;; Forward request
        (define request (read-line client-in 'any))
        (displayln request backend-out)
        (flush-output backend-out)
        
        ;; Forward response
        (define response (read-line backend-in 'any))
        (displayln response client-out)
        (flush-output client-out)
        
        (close-input-port backend-in)
        (close-output-port backend-out)))))

;; Usage
;; (load-balancer-server 8080 
;;   '(("localhost" 9001)
;;     ("localhost" 9002)
;;     ("localhost" 9003)))

16.6 Network Security

SSL/TLS Connections

(require openssl)

;; Secure TCP client
(define (secure-tcp-connect host port)
  (define-values (in out) (ssl-connect host port 'auto))
  (values in out))

;; Secure TCP server
(define (secure-tcp-server port cert-file key-file handler)
  (define listener 
    (ssl-listen port 5 #t 
                #:key-file key-file
                #:cert-file cert-file))
  
  (let accept-loop ()
    (define-values (in out) (ssl-accept listener))
    
    (thread
     (lambda ()
       (with-handlers ([exn:fail? (lambda (e) (void))])
         (handler in out))
       (close-input-port in)
       (close-output-port out)))
    
    (accept-loop)))

;; Example secure echo server
;; (secure-tcp-server 8443 "server.crt" "server.key" echo-handler)

Authentication and Encryption

(require crypto)

;; Challenge-response authentication
(define (generate-challenge)
  (bytes→hex-string (crypto-random-bytes 16)))

(define (compute-response challenge secret)
  (sha256-bytes 
   (bytes-append (string→bytes/utf-8 challenge)
                (string→bytes/utf-8 secret))))

;; Authenticated connection
(define (authenticate-client in out secret)
  (define challenge (generate-challenge))
  
  ;; Send challenge
  (displayln challenge out)
  (flush-output out)
  
  ;; Receive response
  (define client-response (read-line in 'any))
  (define expected-response 
    (bytes→hex-string (compute-response challenge secret)))
  
  (string=? client-response expected-response))

;; Encrypted message exchange
(define (encrypt-message message key)
  (define cipher (make-cipher 'aes-256-cbc key (make-bytes 16 0)))
  (encrypt cipher (string→bytes/utf-8 message)))

(define (decrypt-message encrypted-bytes key)
  (define cipher (make-cipher 'aes-256-cbc key (make-bytes 16 0)))
  (bytes→string/utf-8 (decrypt cipher encrypted-bytes)))

;; Secure message server
(define (secure-message-handler in out shared-secret)
  ;; Authenticate
  (unless (authenticate-client in out shared-secret)
    (displayln "Authentication failed" out)
    (error "Authentication failed"))
  
  (displayln "Authentication successful" out)
  (flush-output out)
  
  ;; Exchange encrypted messages
  (let loop ()
    (define encrypted-line (read-line in 'any))
    (unless (eof-object? encrypted-line)
      (define message 
        (decrypt-message (hex-string→bytes encrypted-line) 
                        (string→bytes/utf-8 shared-secret)))
      
      (printf "Received: ~a\n" message)
      
      (define response (string-append "Echo: " message))
      (define encrypted-response 
        (encrypt-message response 
                        (string→bytes/utf-8 shared-secret)))
      
      (displayln (bytes→hex-string encrypted-response) out)
      (flush-output out)
      (loop))))

16.7 Network Monitoring and Debugging

Packet Capture and Analysis

;; Connection monitor
(define (monitor-connection in out)
  (define (log-data direction data)
    (printf "[~a] ~a: ~a bytes\n" 
            (date→string (current-date) #t)
            direction
            (bytes-length data)))
  
  (define monitored-in
    (make-input-port 
     'monitored-in
     (lambda (buffer)
       (define count (read-bytes-avail! buffer in))
       (when (> count 0)
         (log-data "INCOMING" (subbytes buffer 0 count)))
       count)
     #f
     void))
  
  (define monitored-out
    (make-output-port
     'monitored-out
     always-evt
     (lambda (buffer start end non-block? enable-break?)
       (define data (subbytes buffer start end))
       (log-data "OUTGOING" data)
       (write-bytes data out)
       (flush-output out)
       (- end start))
     void))
  
  (values monitored-in monitored-out))

;; Bandwidth monitor
(define (make-bandwidth-monitor)
  (define bytes-in 0)
  (define bytes-out 0)
  (define start-time (current-seconds))
  
  (lambda (command . args)
    (case command
      [(log-in) (set! bytes-in (+ bytes-in (car args)))]
      [(log-out) (set! bytes-out (+ bytes-out (car args)))]
      [(stats)
       (define elapsed (- (current-seconds) start-time))
       (hash 'bytes-in bytes-in
             'bytes-out bytes-out
             'rate-in (/ bytes-in elapsed)
             'rate-out (/ bytes-out elapsed)
             'elapsed elapsed)]
      [(reset)
       (set! bytes-in 0)
       (set! bytes-out 0)
       (set! start-time (current-seconds))])))

Network Debugging Tools

;; TCP connection tester
(define (test-tcp-connection host port timeout)
  (with-handlers 
    ([exn:fail:network? 
      (lambda (e) 
        (hash 'status 'failed 
              'error (exn-message e)))])
    
    (define start (current-inexact-milliseconds))
    
    (define-values (in out) 
      (sync/timeout (/ timeout 1000)
                    (tcp-connect-evt host port)))
    
    (if (and in out)
        (begin
          (define end (current-inexact-milliseconds))
          (close-input-port in)
          (close-output-port out)
          (hash 'status 'success
                'latency (- end start)))
        (hash 'status 'timeout))))

;; Network trace utility
(define (trace-network-call thunk)
  (define connections '())
  
  (parameterize ([current-custodian (make-custodian)])
    (custodian-limit-memory (current-custodian) (* 100 1024 1024))
    
    (define start-time (current-inexact-milliseconds))
    (define result (thunk))
    (define end-time (current-inexact-milliseconds))
    
    (hash 'result result
          'duration (- end-time start-time)
          'connections connections)))

;; Protocol analyzer
(define (analyze-protocol-traffic data)
  (define lines (string-split data "\n"))
  
  (define stats
    (for/fold ([acc (hash 'total-lines 0
                         'commands (hash))])
              ([line lines])
      (define parts (string-split line))
      (hash-set acc 'total-lines (+ (hash-ref acc 'total-lines) 1))
      
      (if (null? parts)
          acc
          (let ([cmd (car parts)])
            (hash-update acc 'commands
                        (lambda (cmds)
                          (hash-update cmds cmd add1 0)))))))
  
  stats)

16.8 Advanced Network Patterns

Connection Pooling

;; Connection pool implementation
(define (make-connection-pool host port max-connections)
  (define pool '())
  (define in-use 0)
  (define lock (make-semaphore 1))
  (define available (make-semaphore 0))
  
  (lambda (command . args)
    (case command
      [(acquire)
       (semaphore-wait available)
       (semaphore-wait lock)
       
       (define conn
         (if (null? pool)
             (tcp-connect host port)
             (let ([c (car pool)])
               (set! pool (cdr pool))
               c)))
       
       (set! in-use (+ in-use 1))
       (semaphore-post lock)
       conn]
      
      [(release)
       (define conn (car args))
       (semaphore-wait lock)
       (set! pool (cons conn pool))
       (set! in-use (- in-use 1))
       (semaphore-post lock)
       (semaphore-post available)]
      
      [(init)
       ;; Create initial connections
       (for ([i max-connections])
         (define-values (in out) (tcp-connect host port))
         (set! pool (cons (cons in out) pool))
         (semaphore-post available))]
      
      [(stats)
       (hash 'pool-size (length pool)
             'in-use in-use
             'max max-connections)])))

;; Usage
;; (define pool (make-connection-pool "localhost" 8080 10))
;; (pool 'init)
;; (define-values (in out) (pool 'acquire))
;; … use connection …
;; (pool 'release (cons in out))

Circuit Breaker Pattern

;; Circuit breaker for resilient network calls
(define (make-circuit-breaker threshold timeout)
  (define state 'closed)  ; closed, open, half-open
  (define failure-count 0)
  (define last-failure-time 0)
  (define lock (make-semaphore 1))
  
  (lambda (thunk)
    (semaphore-wait lock)
    
    (cond
      ;; Open state: fast fail
      [(eq? state 'open)
       (if (> (- (current-seconds) last-failure-time) timeout)
           (begin
             (set! state 'half-open)
             (semaphore-post lock)
             ((make-circuit-breaker threshold timeout) thunk))
           (begin
             (semaphore-post lock)
             (error "Circuit breaker is OPEN")))]
      
      ;; Half-open state: try once
      [(eq? state 'half-open)
       (semaphore-post lock)
       (with-handlers 
         ([exn:fail? 
           (lambda (e)
             (semaphore-wait lock)
             (set! state 'open)
             (set! last-failure-time (current-seconds))
             (semaphore-post lock)
             (raise e))])
         
         (define result (thunk))
         (semaphore-wait lock)
         (set! state 'closed)
         (set! failure-count 0)
         (semaphore-post lock)
         result)]
      
      ;; Closed state: normal operation
      [else
       (semaphore-post lock)
       (with-handlers
         ([exn:fail?
           (lambda (e)
             (semaphore-wait lock)
             (set! failure-count (+ failure-count 1))
             (when (≥ failure-count threshold)
               (set! state 'open)
               (set! last-failure-time (current-seconds)))
             (semaphore-post lock)
             (raise e))])
         
         (define result (thunk))
         (semaphore-wait lock)
         (set! failure-count 0)
         (semaphore-post lock)
         result)])))

;; Usage
;; (define breaker (make-circuit-breaker 5 30))
;; (breaker (lambda () (tcp-connect "unreliable-host" 8080)))

16.9 Exercises

Exercise 16.1: Multi-Protocol Server

Create a server that handles multiple protocols on different ports:

  • Echo protocol on port 8001

  • Time protocol on port 8002

  • HTTP on port 8080

  • Custom RPC protocol on port 9000

Exercise 16.2: Distributed Hash Table

Implement a simple DHT:

  • Key-value storage across multiple nodes

  • Consistent hashing for key distribution

  • Node discovery and heartbeat

  • Replication for fault tolerance

Exercise 16.3: Chat Server

Build a full-featured chat server:

  • Multiple chat rooms

  • Private messaging

  • User authentication

  • Message history

  • Online user list

Exercise 16.4: File Transfer Protocol

Implement a simple FTP-like protocol:

  • Login/authentication

  • Directory listing

  • File upload/download

  • Resume capability

  • Binary and text modes

Exercise 16.5: Network Proxy

Create a configurable network proxy:

  • HTTP/HTTPS forwarding

  • Request/response logging

  • Content filtering

  • Caching

  • Rate limiting

Summary

Chapter 16 covered network programming in Scheme:

  1. Socket Programming: TCP and UDP socket fundamentals

  2. Protocol Implementation: Text-based and binary protocols

  3. Network Utilities: Port scanning, speed tests, DNS lookups

  4. RPC: Synchronous and asynchronous remote procedure calls

  5. Distributed Systems: Message queues, pub/sub, load balancing

  6. Security: SSL/TLS, authentication, encryption

  7. Monitoring: Packet capture, bandwidth monitoring, debugging

  8. Advanced Patterns: Connection pooling, circuit breakers

These techniques enable building robust networked applications and distributed systems using Scheme’s functional programming paradigm.

Chapter #17: Systems Programming with Scheme

Introduction

Systems programming involves working directly with operating system resources, managing processes, handling low-level I/O, and interfacing with system libraries. While traditionally the domain of C and C++, Scheme provides powerful abstractions that make systems programming more expressive and safe while maintaining efficiency through careful design.

This chapter explores how to use Scheme for systems-level tasks, including:

  • Process management and inter-process communication (IPC)

  • Memory-mapped files and shared memory

  • Signal handling and system events

  • Foreign Function Interface (FFI) for C libraries

  • Low-level file operations and filesystem monitoring

  • System resource monitoring and control

  • Building system daemons and services

17.1 Process Management

17.1.1 Creating and Managing Processes

;;; Process management primitives
(define-library (systems process)
  (export spawn-process
          process?
          process-pid
          process-status
          wait-process
          kill-process
          process-running?
          get-process-output
          pipe-processes)
  (import (scheme base)
          (scheme write)
          (posix))
  (begin
    
    ;; Process record type
    (define-record-type <process>
      (make-process* pid stdin stdout stderr status)
      process?
      (pid process-pid)
      (stdin process-stdin set-process-stdin!)
      (stdout process-stdout set-process-stdout!)
      (stderr process-stderr set-process-stderr!)
      (status process-status set-process-status!))
    
    ;; Spawn a new process
    (define (spawn-process command args env)
      "Create a new process with given command, arguments, and environment"
      (let-values (((stdin-r stdin-w) (create-pipe))
                   ((stdout-r stdout-w) (create-pipe))
                   ((stderr-r stderr-w) (create-pipe)))
        (let ((pid (fork)))
          (cond
            ((= pid 0)  ; Child process
             ;; Close parent ends of pipes
             (close-port stdin-w)
             (close-port stdout-r)
             (close-port stderr-r)
             
             ;; Redirect standard streams
             (dup2 (port-fd stdin-r) 0)
             (dup2 (port-fd stdout-w) 1)
             (dup2 (port-fd stderr-w) 2)
             
             ;; Execute command
             (execve command args env)
             (exit 1))  ; Only reached if exec fails
            
            (else  ; Parent process
             ;; Close child ends of pipes
             (close-port stdin-r)
             (close-port stdout-w)
             (close-port stderr-w)
             
             (make-process* pid stdin-w stdout-r stderr-r 'running))))))
    
    ;; Wait for process to complete
    (define (wait-process proc)
      "Wait for process to complete and return exit status"
      (let ((pid (process-pid proc)))
        (let-values (((wpid status) (waitpid pid 0)))
          (set-process-status! proc 
            (if (wifexited status)
                (wexitstatus status)
                'terminated))
          (process-status proc))))
    
    ;; Check if process is still running
    (define (process-running? proc)
      "Check if process is currently running"
      (let-values (((pid status) (waitpid (process-pid proc) WNOHANG)))
        (= pid 0)))
    
    ;; Kill a process
    (define (kill-process proc signal)
      "Send signal to process"
      (kill (process-pid proc) signal))
    
    ;; Read all output from process
    (define (get-process-output proc)
      "Read all available output from process stdout"
      (let ((output-port (process-stdout proc)))
        (let loop ((lines '()))
          (let ((line (read-line output-port)))
            (if (eof-object? line)
                (reverse lines)
                (loop (cons line lines)))))))
    
    ;; Create a pipeline of processes
    (define (pipe-processes . commands)
      "Create a pipeline connecting multiple processes"
      (if (null? commands)
          '()
          (let loop ((cmds commands)
                     (prev-stdout #f)
                     (processes '()))
            (if (null? cmds)
                (reverse processes)
                (let* ((cmd (car cmds))
                       (proc (spawn-process (car cmd) (cdr cmd) '())))
                  (when prev-stdout
                    ;; Connect previous stdout to current stdin
                    (let ((input (process-stdin proc)))
                      (copy-port prev-stdout input)
                      (close-port input)))
                  (loop (cdr cmds)
                        (process-stdout proc)
                        (cons proc processes)))))))))

17.1.2 Process Communication Examples

;;; Example: Running external commands
(define (run-command-sync command args)
  "Run command synchronously and return output"
  (let ((proc (spawn-process command args '())))
    ;; Close stdin since we won't write to it
    (close-port (process-stdin proc))
    
    ;; Read output
    (let ((output (get-process-output proc)))
      (wait-process proc)
      output)))

;;; Example: Interactive process communication
(define (interactive-process command args)
  "Create an interactive process handle"
  (let ((proc (spawn-process command args '())))
    
    (lambda (msg . data)
      (case msg
        ((write)
         (write-string (car data) (process-stdin proc))
         (flush-output-port (process-stdin proc)))
        
        ((read)
         (read-line (process-stdout proc)))
        
        ((read-available)
         (let ((stdout (process-stdout proc)))
           (let loop ((lines '()))
             (if (char-ready? stdout)
                 (loop (cons (read-line stdout) lines))
                 (reverse lines)))))
        
        ((kill)
         (kill-process proc SIGTERM)
         (wait-process proc))
        
        ((status)
         (if (process-running? proc)
             'running
             (process-status proc)))
        
        (else
         (error "Unknown message" msg))))))

;;; Usage example
(define python-repl (interactive-process "/usr/bin/python3" '("python3")))

(python-repl 'write "print('Hello from Python')\n")
(display (python-repl 'read))  ; ⇒ Hello from Python

(python-repl 'write "2 + 2\n")
(display (python-repl 'read))  ; ⇒ 4

17.2 Inter-Process Communication (IPC)

17.2.1 Pipes and FIFOs

;;; Named pipes (FIFOs) for IPC
(define-library (systems ipc)
  (export make-fifo
          open-fifo-reader
          open-fifo-writer
          remove-fifo
          create-pipe-pair
          message-queue-create
          message-queue-send
          message-queue-receive)
  (import (scheme base)
          (scheme write)
          (posix))
  (begin
    
    ;; Create a named pipe (FIFO)
    (define (make-fifo path mode)
      "Create a named pipe at path with given permissions"
      (mkfifo path mode))
    
    ;; Open FIFO for reading
    (define (open-fifo-reader path)
      "Open named pipe for reading (blocks until writer connects)"
      (open-input-file path))
    
    ;; Open FIFO for writing
    (define (open-fifo-writer path)
      "Open named pipe for writing (blocks until reader connects)"
      (open-output-file path))
    
    ;; Remove FIFO
    (define (remove-fifo path)
      "Remove named pipe from filesystem"
      (unlink path))
    
    ;; Bidirectional pipe pair
    (define (create-pipe-pair)
      "Create a bidirectional communication channel"
      (let-values (((r1 w1) (create-pipe))
                   ((r2 w2) (create-pipe)))
        (values
          (cons r1 w2)  ; End 1: read from r1, write to w2
          (cons r2 w1)))) ; End 2: read from r2, write to w1
    
    ;; Simple message queue using files
    (define (message-queue-create name)
      "Create a simple file-based message queue"
      (let ((queue-dir (string-append "/tmp/mq-" name)))
        (unless (file-exists? queue-dir)
          (create-directory queue-dir))
        queue-dir))
    
    (define (message-queue-send queue msg)
      "Send message to queue"
      (let* ((timestamp (current-second))
             (filename (string-append queue "/" 
                                     (number→string timestamp)
                                     "-" 
                                     (number→string (random-integer 10000)))))
        (call-with-output-file filename
          (lambda (port)
            (write msg port)))))
    
    (define (message-queue-receive queue)
      "Receive oldest message from queue (blocking)"
      (let loop ()
        (let ((files (directory-list queue)))
          (if (null? files)
              (begin
                (usleep 100000)  ; Sleep 100ms
                (loop))
              (let ((oldest (car (sort files string<?))))
                (let ((path (string-append queue "/" oldest)))
                  (guard (ex (else (loop)))  ; Retry if file deleted
                    (let ((msg (call-with-input-file path read)))
                      (delete-file path)
                      msg))))))))))

17.2.2 Shared Memory

;;; Shared memory implementation
(define-library (systems shmem)
  (export create-shared-memory
          attach-shared-memory
          detach-shared-memory
          destroy-shared-memory
          shmem-write
          shmem-read
          shmem-size)
  (import (scheme base)
          (posix))
  (begin
    
    (define-record-type <shmem>
      (make-shmem* id addr size)
      shmem?
      (id shmem-id)
      (addr shmem-addr set-shmem-addr!)
      (size shmem-size))
    
    ;; Create shared memory segment
    (define (create-shared-memory key size permissions)
      "Create a shared memory segment"
      (let ((shmid (shmget key size (bitwise-ior IPC_CREAT permissions))))
        (if (< shmid 0)
            (error "Failed to create shared memory")
            (make-shmem* shmid #f size))))
    
    ;; Attach to shared memory
    (define (attach-shared-memory shm)
      "Attach to shared memory segment"
      (let ((addr (shmat (shmem-id shm) 0 0)))
        (if (not addr)
            (error "Failed to attach shared memory")
            (begin
              (set-shmem-addr! shm addr)
              shm))))
    
    ;; Detach from shared memory
    (define (detach-shared-memory shm)
      "Detach from shared memory segment"
      (when (shmem-addr shm)
        (shmdt (shmem-addr shm))
        (set-shmem-addr! shm #f)))
    
    ;; Destroy shared memory
    (define (destroy-shared-memory shm)
      "Destroy shared memory segment"
      (shmctl (shmem-id shm) IPC_RMID 0))
    
    ;; Write to shared memory
    (define (shmem-write shm offset data)
      "Write bytevector to shared memory at offset"
      (unless (shmem-addr shm)
        (error "Shared memory not attached"))
      (when (> (+ offset (bytevector-length data)) (shmem-size shm))
        (error "Write exceeds shared memory bounds"))
      (memcpy (+ (shmem-addr shm) offset) data (bytevector-length data)))
    
    ;; Read from shared memory
    (define (shmem-read shm offset length)
      "Read bytevector from shared memory at offset"
      (unless (shmem-addr shm)
        (error "Shared memory not attached"))
      (when (> (+ offset length) (shmem-size shm))
        (error "Read exceeds shared memory bounds"))
      (let ((result (make-bytevector length)))
        (memcpy-to-bytevector result (+ (shmem-addr shm) offset) length)
        result))))

;;; Example: Producer-Consumer with shared memory
(define (producer-consumer-example)
  (define key #x12345)
  (define size 1024)
  
  ;; Producer process
  (define (producer)
    (let ((shm (create-shared-memory key size #o666)))
      (attach-shared-memory shm)
      
      (do ((i 0 (+ i 1)))
          ((= i 10))
        (let ((msg (string→utf8 (string-append "Message " (number→string i)))))
          (shmem-write shm 0 msg)
          (display "Produced: ")
          (display (utf8→string msg))
          (newline)
          (sleep 1)))
      
      (detach-shared-memory shm)))
  
  ;; Consumer process
  (define (consumer)
    (let ((shm (create-shared-memory key size #o666)))
      (attach-shared-memory shm)
      
      (do ((i 0 (+ i 1)))
          ((= i 10))
        (let ((msg (shmem-read shm 0 100)))
          (display "Consumed: ")
          (display (utf8→string msg))
          (newline)
          (sleep 1)))
      
      (detach-shared-memory shm)
      (destroy-shared-memory shm)))
  
  ;; Fork and run
  (let ((pid (fork)))
    (if (= pid 0)
        (consumer)
        (begin
          (producer)
          (waitpid pid 0)))))

17.3 Signal Handling

17.3.1 Signal Management

;;; Signal handling system
(define-library (systems signals)
  (export install-signal-handler
          block-signals
          unblock-signals
          send-signal
          signal-name
          define-signal-constants)
  (import (scheme base)
          (scheme write)
          (posix))
  (begin
    
    ;; Signal constants
    (define-signal-constants
      (SIGHUP 1)
      (SIGINT 2)
      (SIGQUIT 3)
      (SIGILL 4)
      (SIGTRAP 5)
      (SIGABRT 6)
      (SIGBUS 7)
      (SIGFPE 8)
      (SIGKILL 9)
      (SIGUSR1 10)
      (SIGSEGV 11)
      (SIGUSR2 12)
      (SIGPIPE 13)
      (SIGALRM 14)
      (SIGTERM 15)
      (SIGCHLD 17)
      (SIGCONT 18)
      (SIGSTOP 19)
      (SIGTSTP 20))
    
    ;; Signal handler registry
    (define *signal-handlers* (make-hash-table))
    
    ;; Install signal handler
    (define (install-signal-handler signal handler)
      "Install a handler for the given signal"
      (hash-table-set! *signal-handlers* signal handler)
      (c-signal signal 
        (lambda (sig)
          (let ((h (hash-table-ref *signal-handlers* sig #f)))
            (when h (h sig))))))
    
    ;; Block signals
    (define (block-signals signals)
      "Block delivery of specified signals"
      (let ((mask (make-sigset)))
        (for-each (lambda (sig) (sigaddset mask sig)) signals)
        (sigprocmask SIG_BLOCK mask #f)))
    
    ;; Unblock signals
    (define (unblock-signals signals)
      "Unblock delivery of specified signals"
      (let ((mask (make-sigset)))
        (for-each (lambda (sig) (sigaddset mask sig)) signals)
        (sigprocmask SIG_UNBLOCK mask #f)))
    
    ;; Send signal to process
    (define (send-signal pid signal)
      "Send signal to specified process"
      (kill pid signal))
    
    ;; Get signal name
    (define (signal-name sig)
      "Get human-readable name for signal number"
      (case sig
        ((1) "SIGHUP")
        ((2) "SIGINT")
        ((3) "SIGQUIT")
        ((9) "SIGKILL")
        ((15) "SIGTERM")
        ((17) "SIGCHLD")
        (else (string-append "SIG" (number→string sig)))))))

;;; Example: Graceful shutdown handler
(define *shutdown-requested* #f)

(define (setup-graceful-shutdown cleanup-fn)
  "Setup handlers for graceful shutdown on SIGTERM/SIGINT"
  (define (shutdown-handler sig)
    (display "Shutdown signal received: ")
    (display (signal-name sig))
    (newline)
    (set! *shutdown-requested* #t)
    (cleanup-fn))
  
  (install-signal-handler SIGTERM shutdown-handler)
  (install-signal-handler SIGINT shutdown-handler)
  
  ;; Return predicate to check shutdown status
  (lambda () *shutdown-requested*))

;;; Example: Child process monitoring
(define (monitor-children)
  "Setup handler to monitor child process termination"
  (install-signal-handler SIGCHLD
    (lambda (sig)
      (let loop ()
        (let-values (((pid status) (waitpid -1 WNOHANG)))
          (when (> pid 0)
            (display "Child process ")
            (display pid)
            (display " exited with status ")
            (display (if (wifexited status) (wexitstatus status) "unknown"))
            (newline)
            (loop)))))))

17.4 Foreign Function Interface (FFI)

17.4.1 C Library Interface

;;; FFI system for calling C libraries
(define-library (systems ffi)
  (export define-foreign-library
          define-foreign-function
          c-pointer?
          make-c-pointer
          c-pointer-address
          malloc
          free
          c-string→scheme
          scheme→c-string
          define-c-struct)
  (import (scheme base)
          (scheme write))
  (begin
    
    ;; Foreign library management
    (define *foreign-libraries* (make-hash-table))
    
    (define (define-foreign-library name path)
      "Load a foreign library"
      (let ((handle (dlopen path RTLD_LAZY)))
        (if handle
            (hash-table-set! *foreign-libraries* name handle)
            (error "Failed to load library" path (dlerror)))))
    
    ;; C pointer type
    (define-record-type <c-pointer>
      (make-c-pointer* address type)
      c-pointer?
      (address c-pointer-address)
      (type c-pointer-type))
    
    (define (make-c-pointer addr type)
      (make-c-pointer* addr type))
    
    ;; Memory allocation
    (define (malloc size)
      "Allocate memory and return pointer"
      (let ((addr (c-malloc size)))
        (if (zero? addr)
            (error "malloc failed")
            (make-c-pointer addr 'void))))
    
    (define (free ptr)
      "Free allocated memory"
      (c-free (c-pointer-address ptr)))
    
    ;; String conversion
    (define (c-string→scheme ptr)
      "Convert C string to Scheme string"
      (if (zero? (c-pointer-address ptr))
          #f
          (utf8→string (c-string-to-bytevector (c-pointer-address ptr)))))
    
    (define (scheme→c-string str)
      "Convert Scheme string to C string (caller must free)"
      (let* ((bv (string→utf8 str))
             (len (bytevector-length bv))
             (ptr (malloc (+ len 1))))
        (bytevector-copy-to-c-memory! bv (c-pointer-address ptr))
        (c-set-byte! (c-pointer-address ptr) len 0)  ; null terminator
        ptr))
    
    ;; Foreign function definition
    (define-syntax define-foreign-function
      (syntax-rules ()
        ((define-foreign-function lib name (arg-types …) return-type)
         (define name
           (let ((handle (hash-table-ref *foreign-libraries* 'lib))
                 (sym (dlsym handle (symbol→string 'name))))
             (if (not sym)
                 (error "Symbol not found" 'name)
                 (lambda args
                   (apply c-call sym
                          (list 'return-type 'arg-types …)
                          args))))))))
    
    ;; C struct definition
    (define-syntax define-c-struct
      (syntax-rules ()
        ((define-c-struct name (field type offset) …)
         (begin
           (define (make-name . args)
             (let ((ptr (malloc (name-size))))
               (let loop ((fields '((field . type) …))
                          (offsets '(offset …))
                          (vals args))
                 (unless (null? fields)
                   (c-set! ptr (car offsets) (caar fields) (car vals))
                   (loop (cdr fields) (cdr offsets) (cdr vals))))
               ptr))
           
           (define (name-field ptr)
             (c-ref ptr offset type))
           …
           
           (define (name-field-set! ptr val)
             (c-set! ptr offset type val))
           …))))))

;;; Example: Using libc functions
(define-foreign-library libc "libc.so.6")

(define-foreign-function libc strlen (pointer) int)
(define-foreign-function libc strcmp (pointer pointer) int)
(define-foreign-function libc getpid () int)
(define-foreign-function libc gethostname (pointer int) int)

;;; Example: Working with C strings
(define (test-c-strings)
  (let ((str (scheme→c-string "Hello, FFI!")))
    (display "String length: ")
    (display (strlen str))
    (newline)
    
    (free str)))

;;; Example: Getting hostname
(define (get-hostname)
  (let ((buf (malloc 256)))
    (gethostname buf 256)
    (let ((hostname (c-string→scheme buf)))
      (free buf)
      hostname)))

;;; Example: Define a C struct
(define-c-struct point
  (x double 0)
  (y double 8))

(define (distance p1 p2)
  (sqrt (+ (expt (- (point-x p2) (point-x p1)) 2)
           (expt (- (point-y p2) (point-y p1)) 2))))

17.4.2 Calling System Libraries

;;; Example: Using POSIX threads via FFI
(define-foreign-library pthread "libpthread.so.0")

(define-foreign-function pthread pthread_create 
  (pointer pointer pointer pointer) int)
(define-foreign-function pthread pthread_join 
  (pointer pointer) int)
(define-foreign-function pthread pthread_mutex_init 
  (pointer pointer) int)
(define-foreign-function pthread pthread_mutex_lock 
  (pointer) int)
(define-foreign-function pthread pthread_mutex_unlock 
  (pointer) int)

;;; Thread-safe counter using pthread mutex
(define (make-thread-safe-counter)
  (let ((count 0)
        (mutex (malloc 40)))  ; sizeof(pthread_mutex_t)
    
    ;; Initialize mutex
    (pthread_mutex_init mutex (make-c-pointer 0 'void))
    
    (lambda (op)
      (case op
        ((increment)
         (pthread_mutex_lock mutex)
         (set! count (+ count 1))
         (pthread_mutex_unlock mutex)
         count)
        
        ((get)
         (pthread_mutex_lock mutex)
         (let ((val count))
           (pthread_mutex_unlock mutex)
           val))
        
        ((destroy)
         (free mutex))))))

;;; Example: SQLite3 via FFI
(define-foreign-library sqlite3 "libsqlite3.so.0")

(define-foreign-function sqlite3 sqlite3_open 
  (pointer pointer) int)
(define-foreign-function sqlite3 sqlite3_close 
  (pointer) int)
(define-foreign-function sqlite3 sqlite3_exec 
  (pointer pointer pointer pointer pointer) int)
(define-foreign-function sqlite3 sqlite3_errmsg 
  (pointer) pointer)

(define (sqlite-open filename)
  "Open SQLite database"
  (let* ((db-ptr (malloc 8))
         (fname (scheme→c-string filename))
         (result (sqlite3_open (c-pointer-address fname) db-ptr)))
    (free fname)
    (if (zero? result)
        (make-c-pointer (c-deref db-ptr 0 'pointer) 'sqlite3-db)
        (error "Failed to open database" filename))))

(define (sqlite-exec db sql)
  "Execute SQL statement"
  (let* ((sql-cstr (scheme→c-string sql))
         (err-ptr (malloc 8))
         (result (sqlite3_exec (c-pointer-address db)
                              (c-pointer-address sql-cstr)
                              0 0 err-ptr)))
    (free sql-cstr)
    (unless (zero? result)
      (let* ((err-msg-ptr (c-deref err-ptr 0 'pointer))
             (err-msg (c-string→scheme (make-c-pointer err-msg-ptr 'char))))
        (error "SQL error" err-msg)))
    result))

(define (sqlite-close db)
  "Close SQLite database"
  (sqlite3_close (c-pointer-address db)))

17.5 Memory-Mapped Files

17.5.1 mmap Interface

;;; Memory-mapped file operations
(define-library (systems mmap)
  (export mmap-file
          munmap-file
          mmap-read
          mmap-write
          mmap-sync)
  (import (scheme base)
          (posix))
  (begin
    
    (define-record-type <mmap>
      (make-mmap* fd addr size)
      mmap?
      (fd mmap-fd)
      (addr mmap-addr)
      (size mmap-size))
    
    ;; Map file into memory
    (define (mmap-file filename writable?)
      "Map file into memory"
      (let* ((flags (if writable? O_RDWR O_RDONLY))
             (fd (open filename flags))
             (size (file-size fd))
             (prot (if writable? 
                      (bitwise-ior PROT_READ PROT_WRITE)
                      PROT_READ))
             (addr (mmap 0 size prot MAP_SHARED fd 0)))
        (if (= addr -1)
            (begin
              (close fd)
              (error "mmap failed"))
            (make-mmap* fd addr size))))
    
    ;; Unmap file
    (define (munmap-file mm)
      "Unmap file from memory"
      (munmap (mmap-addr mm) (mmap-size mm))
      (close (mmap-fd mm)))
    
    ;; Read from mapped memory
    (define (mmap-read mm offset length)
      "Read bytes from mapped memory"
      (when (> (+ offset length) (mmap-size mm))
        (error "Read beyond mapped region"))
      (let ((result (make-bytevector length)))
        (memcpy-to-bytevector result (+ (mmap-addr mm) offset) length)
        result))
    
    ;; Write to mapped memory
    (define (mmap-write mm offset data)
      "Write bytes to mapped memory"
      (when (> (+ offset (bytevector-length data)) (mmap-size mm))
        (error "Write beyond mapped region"))
      (memcpy (+ (mmap-addr mm) offset) data (bytevector-length data)))
    
    ;; Sync changes to disk
    (define (mmap-sync mm)
      "Synchronize mapped memory to disk"
      (msync (mmap-addr mm) (mmap-size mm) MS_SYNC))))

;;; Example: Fast file processing with mmap
(define (count-pattern-mmap filename pattern)
  "Count occurrences of pattern in file using mmap"
  (let ((mm (mmap-file filename #f))
        (pattern-bytes (string→utf8 pattern))
        (pattern-len (string-length pattern)))
    
    (let loop ((offset 0) (count 0))
      (if (≥ offset (- (mmap-size mm) pattern-len))
          (begin
            (munmap-file mm)
            count)
          (let ((chunk (mmap-read mm offset pattern-len)))
            (loop (+ offset 1)
                  (if (equal? chunk pattern-bytes)
                      (+ count 1)
                      count)))))))

;;; Example: Shared memory via mmap
(define (create-shared-mmap-region size)
  "Create anonymous shared memory region"
  (let ((addr (mmap 0 size 
                    (bitwise-ior PROT_READ PROT_WRITE)
                    (bitwise-ior MAP_SHARED MAP_ANONYMOUS)

                    -1 0)))
    (if (= addr -1)
        (error "Failed to create shared memory")
        (make-mmap* -1 addr size))))

17.6 System Monitoring

17.6.1 Resource Usage

;;; System resource monitoring
(define-library (systems monitor)
  (export get-cpu-usage
          get-memory-info
          get-disk-io
          get-network-stats
          monitor-process
          system-uptime)
  (import (scheme base)
          (scheme file)
          (scheme read)
          (scheme write))
  (begin
    
    ;; Parse /proc/stat for CPU usage
    (define (get-cpu-usage)
      "Get CPU usage percentages"
      (define (parse-cpu-line line)
        (let ((parts (string-split line #\space)))
          (map string→number (cdr parts))))
      
      (let* ((stat1 (call-with-input-file "/proc/stat"
                     (lambda (p) (read-line p))))
             (values1 (parse-cpu-line stat1)))
        (usleep 100000)  ; Sleep 100ms
        (let* ((stat2 (call-with-input-file "/proc/stat"
                        (lambda (p) (read-line p))))
               (values2 (parse-cpu-line stat2))
               (diff (map - values2 values1))
               (total (apply + diff))
               (idle (list-ref diff 3)))
          (if (zero? total)
              0.0
              (* 100.0 (/ (- total idle) total))))))
    
    ;; Get memory information
    (define (get-memory-info)
      "Get memory usage information"
      (let ((info (make-hash-table)))
        (call-with-input-file "/proc/meminfo"
          (lambda (port)
            (let loop ()
              (let ((line (read-line port)))
                (unless (eof-object? line)
                  (let* ((parts (string-split line #\:))
                         (key (car parts))
                         (value (string-trim (cadr parts))))
                    (hash-table-set! info key 
                      (string→number (car (string-split value #\space))))
                    (loop)))))))
        info))
    
    ;; Get disk I/O statistics
    (define (get-disk-io device)
      "Get disk I/O stats for device"
      (call-with-input-file "/proc/diskstats"
        (lambda (port)
          (let loop ()
            (let ((line (read-line port)))
              (if (eof-object? line)
                  #f
                  (let ((parts (string-split line #\space)))
                    (if (string=? (list-ref parts 2) device)
                        `((reads . ,(string→number (list-ref parts 3)))
                          (writes . ,(string→number (list-ref parts 7)))
                          (read-sectors . ,(string→number (list-ref parts 5)))
                          (write-sectors . ,(string→number (list-ref parts 9))))
                        (loop)))))))))
    
    ;; Monitor specific process
    (define (monitor-process pid)
      "Get resource usage for specific process"
      (let ((stat-file (string-append "/proc/" (number→string pid) "/stat"))
            (status-file (string-append "/proc/" (number→string pid) "/status")))
        
        (define (parse-stat)
          (call-with-input-file stat-file
            (lambda (port)
              (let ((line (read-line port)))
                (let ((parts (string-split line #\space)))
                  `((pid . ,(string→number (car parts)))
                    (state . ,(list-ref parts 2))
                    (utime . ,(string→number (list-ref parts 13)))
                    (stime . ,(string→number (list-ref parts 14)))
                    (vsize . ,(string→number (list-ref parts 22)))
                    (rss . ,(string→number (list-ref parts 23)))))))))
        
        (guard (ex (else #f))
          (parse-stat))))
    
    ;; Get system uptime
    (define (system-uptime)
      "Get system uptime in seconds"
      (call-with-input-file "/proc/uptime"
        (lambda (port)
          (let ((line (read-line port)))
            (string→number (car (string-split line #\space)))))))
    
    ;; Network statistics
    (define (get-network-stats interface)
      "Get network statistics for interface"
      (call-with-input-file "/proc/net/dev"
        (lambda (port)
          ;; Skip header lines
          (read-line port)
          (read-line port)
          
          (let loop ()
            (let ((line (read-line port)))
              (if (eof-object? line)
                  #f
                  (let* ((parts (string-split (string-trim line) #\space))
                         (iface (string-trim (car parts) #\:)))
                    (if (string=? iface interface)
                        `((rx-bytes . ,(string→number (list-ref parts 1)))
                          (rx-packets . ,(string→number (list-ref parts 2)))
                          (tx-bytes . ,(string→number (list-ref parts 9)))
                          (tx-packets . ,(string→number (list-ref parts 10))))
                        (loop)))))))))))

;;; Example: System monitor dashboard
(define (monitor-dashboard interval)
  "Display continuous system monitoring"
  (let loop ()
    (display "\x1B[2J\x1B[H")  ; Clear screen
    (display "≡ SYSTEM MONITOR ≡\n\n")
    
    ;; CPU Usage
    (display "CPU Usage: ")
    (display (exact→inexact (round (* 10 (get-cpu-usage)))))
    (display "%\n\n")
    
    ;; Memory Info
    (let ((mem (get-memory-info)))
      (display "Memory:\n")
      (display "  Total: ")
      (display (/ (hash-table-ref mem "MemTotal") 1024))
      (display " MB\n")
      (display "  Free: ")
      (display (/ (hash-table-ref mem "MemFree") 1024))
      (display " MB\n")
      (display "  Available: ")
      (display (/ (hash-table-ref mem "MemAvailable") 1024))
      (display " MB\n\n"))
    
    ;; Uptime
    (display "Uptime: ")
    (display (/ (system-uptime) 3600))
    (display " hours\n")
    
    (sleep interval)
    (loop)))

17.7 Building System Daemons

17.7.1 Daemon Infrastructure

;;; Daemon creation and management
(define-library (systems daemon)
  (export daemonize
          create-pid-file
          remove-pid-file
          daemon-loop
          log-daemon-message)
  (import (scheme base)
          (scheme file)
          (scheme write)
          (posix))
  (begin
    
    ;; Daemonize current process
    (define (daemonize)
      "Convert current process into a daemon"
      
      ;; Fork and exit parent
      (let ((pid (fork)))
        (when (> pid 0)
          (exit 0)))
      
      ;; Create new session
      (setsid)
      
      ;; Fork again to prevent acquiring controlling terminal
      (let ((pid (fork)))
        (when (> pid 0)
          (exit 0)))
      
      ;; Change working directory
      (chdir "/")
      
      ;; Close standard file descriptors
      (close-port (current-input-port))
      (close-port (current-output-port))
      (close-port (current-error-port))
      
      ;; Redirect to /dev/null
      (let ((devnull (open "/dev/null" O_RDWR)))
        (dup2 devnull 0)
        (dup2 devnull 1)
        (dup2 devnull 2)
        (when (> devnull 2)
          (close devnull)))
      
      ;; Reset file creation mask
      (umask 0))
    
    ;; Create PID file
    (define (create-pid-file path)
      "Create PID file for daemon"
      (call-with-output-file path
        (lambda (port)
          (write (getpid) port)
          (newline port))))
    
    ;; Remove PID file
    (define (remove-pid-file path)
      "Remove daemon PID file"
      (when (file-exists? path)
        (delete-file path)))
    
    ;; Daemon main loop
    (define (daemon-loop work-fn cleanup-fn check-interval)
      "Main loop for daemon with graceful shutdown"
      (let ((shutdown? (setup-graceful-shutdown cleanup-fn)))
        
        (let loop ()
          (unless (shutdown?)
            (guard (ex 
                     (else 
                       (log-daemon-message 'error 
                         (string-append "Error: " 
                           (error-object-message ex)))))
              (work-fn))
            
            (sleep check-interval)
            (loop)))))
    
    ;; Daemon logging
    (define *daemon-log-file* "/var/log/scheme-daemon.log")
    
    (define (log-daemon-message level msg)
      "Write log message with timestamp"
      (call-with-output-file *daemon-log-file*
        (lambda (port)
          (display (current-date-string) port)
          (display " [" port)
          (display level port)
          (display "] " port)
          (display msg port)
          (newline port))
        #:append #t))))

;;; Example: Simple monitoring daemon
(define (create-monitoring-daemon interval alert-threshold)
  "Create daemon that monitors CPU and sends alerts"
  
  (define (check-cpu)
    (let ((usage (get-cpu-usage)))
      (when (> usage alert-threshold)
        (log-daemon-message 'warning
          (string-append "High CPU usage: " 
                        (number→string usage) "%")))))
  
  (define (cleanup)
    (log-daemon-message 'info "Daemon shutting down")
    (remove-pid-file "/var/run/cpumon.pid"))
  
  (define (start-daemon)
    (daemonize)
    (create-pid-file "/var/run/cpumon.pid")
    (log-daemon-message 'info "Daemon started")
    (daemon-loop check-cpu cleanup interval))
  
  start-daemon)

;;; Example: Service management daemon
(define (service-manager-daemon)
  "Daemon that manages multiple services"
  
  (define services (make-hash-table))
  
  (define (register-service name start-fn stop-fn health-check-fn)
    (hash-table-set! services name
      `((start . ,start-fn)
        (stop . ,stop-fn)
        (health . ,health-check-fn)
        (pid . #f)
        (status . stopped))))
  
  (define (start-service name)
    (let ((service (hash-table-ref services name)))
      (let ((start-fn (cdr (assq 'start service))))
        (let ((pid (fork)))
          (if (= pid 0)
              (begin
                (start-fn)
                (exit 0))
              (begin
                (hash-table-update! services name
                  (lambda (s)
                    (cons `(pid . ,pid)
                          (cons `(status . running)
                                (cddr s)))))
                (log-daemon-message 'info
                  (string-append "Started service: " name))))))))
  
  (define (check-services)
    (hash-table-for-each services
      (lambda (name service)
        (let ((health-fn (cdr (assq 'health service)))
              (status (cdr (assq 'status service))))
          (when (eq? status 'running)
            (unless (health-fn)
              (log-daemon-message 'error
                (string-append "Service unhealthy: " name))
              (restart-service name)))))))
  
  (lambda (msg . args)
    (case msg
      ((register) (apply register-service args))
      ((start) (start-service (car args)))
      ((check) (check-services))
      ((run) 
       (daemonize)
       (daemon-loop check-services 
                   (lambda () (log-daemon-message 'info "Manager stopped"))
                   5)))))

17.8 Advanced System Programming

17.8.1 epoll Event System

;;; High-performance event handling with epoll
(define-library (systems epoll)
  (export epoll-create
          epoll-add
          epoll-modify
          epoll-remove
          epoll-wait
          epoll-close)
  (import (scheme base)
          (posix))
  (begin
    
    (define EPOLLIN #x001)
    (define EPOLLOUT #x004)
    (define EPOLLERR #x008)
    (define EPOLLHUP #x010)
    (define EPOLLET #x80000000)  ; Edge-triggered
    
    (define-record-type <epoll>
      (make-epoll* fd handlers)
      epoll?
      (fd epoll-fd)
      (handlers epoll-handlers set-epoll-handlers!))
    
    (define (epoll-create)
      "Create epoll instance"
      (let ((fd (c-epoll-create1 0)))
        (if (< fd 0)
            (error "Failed to create epoll")
            (make-epoll* fd (make-hash-table)))))
    
    (define (epoll-add ep fd events handler)
      "Add file descriptor to epoll"
      (let ((result (c-epoll-ctl (epoll-fd ep) EPOLL_CTL_ADD fd events)))
        (if (< result 0)
            (error "Failed to add fd to epoll")
            (hash-table-set! (epoll-handlers ep) fd handler))))
    
    (define (epoll-modify ep fd events)
      "Modify events for file descriptor"
      (c-epoll-ctl (epoll-fd ep) EPOLL_CTL_MOD fd events))
    
    (define (epoll-remove ep fd)
      "Remove file descriptor from epoll"
      (c-epoll-ctl (epoll-fd ep) EPOLL_CTL_DEL fd 0)
      (hash-table-delete! (epoll-handlers ep) fd))
    
    (define (epoll-wait ep timeout max-events)
      "Wait for events on epoll"
      (let ((events (c-epoll-wait (epoll-fd ep) max-events timeout)))
        (for-each
          (lambda (event)
            (let* ((fd (car event))
                   (evmask (cdr event))
                   (handler (hash-table-ref (epoll-handlers ep) fd #f)))
              (when handler
                (handler fd evmask))))
          events)))
    
    (define (epoll-close ep)
      "Close epoll instance"
      (close (epoll-fd ep)))))

;;; Example: High-performance server with epoll
(define (epoll-echo-server port)
  "Echo server using epoll for connection handling"
  
  (define (handle-accept listen-fd events ep)
    (let ((client-fd (accept listen-fd)))
      (set-nonblocking! client-fd)
      (epoll-add ep client-fd EPOLLIN
        (lambda (fd evmask)
          (handle-client fd evmask ep)))))
  
  (define (handle-client fd events ep)
    (cond
      ((not (zero? (bitwise-and events EPOLLIN)))
       ;; Data available to read
       (let ((data (read-bytes fd 4096)))
         (if (or (eof-object? data) (zero? (bytevector-length data)))
             ;; Connection closed
             (begin
               (epoll-remove ep fd)
               (close fd))
             ;; Echo back
             (write-bytes fd data))))
      
      ((not (zero? (bitwise-and events (bitwise-ior EPOLLERR EPOLLHUP))))
       ;; Error or hangup
       (epoll-remove ep fd)
       (close fd))))
  
  (let* ((listen-fd (create-server-socket port))
         (ep (epoll-create)))
    
    (set-nonblocking! listen-fd)
    (epoll-add ep listen-fd EPOLLIN handle-accept)
    
    (display "Echo server listening on port ")
    (display port)
    (newline)
    
    ;; Event loop
    (let loop ()
      (epoll-wait ep 1000 10)  ; 1 second timeout, max 10 events
      (loop))))

17.8.2 Performance Monitoring and Profiling

;;; Performance profiling tools
(define-library (systems profile)
  (export profile-procedure
          with-timing
          memory-profile
          cpu-profile
          generate-profile-report)
  (import (scheme base)
          (scheme time)
          (scheme write))
  (begin
    
    (define *profile-data* (make-hash-table))
    
    (define (profile-procedure name proc)
      "Wrap procedure with profiling"
      (lambda args
        (let ((start-time (current-jiffy))
              (start-mem (get-memory-usage)))
          (let ((result (apply proc args)))
            (let ((end-time (current-jiffy))
                  (end-mem (get-memory-usage)))
              (let ((elapsed (/ (- end-time start-time) 
                              (jiffies-per-second)))
                    (mem-delta (- end-mem start-mem)))
                (hash-table-update!/default *profile-data* name
                  (lambda (stats)
                    `((calls . ,(+ 1 (cdr (assq 'calls stats))))
                      (total-time . ,(+ elapsed (cdr (assq 'total-time stats))))
                      (max-time . ,(max elapsed (cdr (assq 'max-time stats))))
                      (total-mem . ,(+ mem-delta (cdr (assq 'total-mem stats))))))
                  '((calls . 0) (total-time . 0) (max-time . 0) (total-mem . 0))))
              result)))))
    
    (define-syntax with-timing
      (syntax-rules ()
        ((with-timing label expr)
         (let ((start (current-jiffy)))
           (let ((result expr))
             (let ((elapsed (/ (- (current-jiffy) start)
                             (jiffies-per-second))))
               (display label)
               (display ": ")
               (display elapsed)
               (display "s\n")
               result))))))
    
    (define (generate-profile-report)
      "Generate profiling report"
      (display "\n≡ PROFILING REPORT ≡\n\n")
      (display (format-string "~20a ~10a ~12a ~12a ~12a\n"
                             "Function" "Calls" "Total Time" "Avg Time" "Max Time"))
      (display (make-string 70 #\-))
      (newline)
      
      (hash-table-for-each *profile-data*
        (lambda (name stats)
          (let ((calls (cdr (assq 'calls stats)))
                (total-time (cdr (assq 'total-time stats)))
                (max-time (cdr (assq 'max-time stats))))
            (display (format-string "~20a ~10d ~12,6f ~12,6f ~12,6f\n"
                                   name calls total-time 
                                   (/ total-time calls) max-time))))))))

17.9 Summary

In this chapter, we explored systems programming with Scheme:

  1. Process Management: Creating, controlling, and communicating with processes

  2. IPC Mechanisms: Pipes, FIFOs, message queues, and shared memory

  3. Signal Handling: Installing handlers and managing signal delivery

  4. FFI: Interfacing with C libraries and system calls

  5. Memory Mapping: Using mmap for efficient file I/O and IPC

  6. System Monitoring: Tracking CPU, memory, disk, and network resources

  7. Daemon Creation: Building background services with proper daemonization

  8. Event Systems: High-performance I/O with epoll

  9. Performance Tools: Profiling and monitoring system resources

Systems programming in Scheme demonstrates that high-level languages can effectively handle low-level tasks while maintaining safety and expressiveness. The combination of Scheme’s abstraction capabilities with direct system access creates powerful and maintainable system software.

Key Takeaways

  • Scheme provides adequate primitives for systems programming

  • FFI enables seamless integration with C libraries

  • Process and IPC abstractions make concurrent programming manageable

  • Signal handling requires careful consideration of async-safety

  • Memory-mapped files offer performance benefits for certain workloads

  • System monitoring provides insights into resource utilization

  • Proper daemon creation follows specific UNIX conventions

Exercises

  1. Implement a process pool manager for parallel task execution

  2. Create a system service that monitors and auto-restarts failed processes

  3. Build a performance profiler that tracks function call graphs

  4. Implement a simple init system replacement

  5. Create a resource usage logger with time-series storage

  6. Build a network traffic analyzer using packet capture

  7. Implement a filesystem watcher using inotify

  8. Create a log aggregator daemon with rotation support

This concludes Chapter #17. Would you like to proceed to Chapter #18: Concurrency and Parallelism?

Chapter #18: Scheme vs. Common Lisp

Introduction

Scheme and Common Lisp represent two major branches in the Lisp family tree. While they share common roots and fundamental principles, they embody different philosophies about language design, standardization, and programming practice. Understanding their differences and similarities helps programmers choose the right tool and appreciate the broader Lisp landscape.

This chapter explores:

  • Historical context and design philosophies

  • Core language differences

  • Standard libraries and ecosystems

  • Macro systems and metaprogramming

  • Object-oriented programming approaches

  • Practical considerations for choosing between them

  • Translation patterns between the languages

18.1 Historical Context and Philosophy

18.1.1 Origins and Evolution

;;; Timeline comparison
;; Lisp 1.5 (1960) - McCarthy's original
;;   |
;;   +-- MacLisp (1960s)
;;   |     |
;;   |     +-- Common Lisp (1984 standard, 1994 ANSI)
;;   |
;;   +-- Scheme (1975) - Steele & Sussman
;;         |
;;         +-- R4RS (1991)
;;         +-- R5RS (1998)
;;         +-- R6RS (2007)
;;         +-- R7RS-small (2013)
;;         +-- R7RS-large (in progress)

Common Lisp Philosophy:

  • “Kitchen sink” approach - include everything useful

  • Standardize existing practice

  • Performance and industrial strength

  • Backward compatibility with previous Lisps

  • Multiple paradigms, multiple solutions

Scheme Philosophy:

  • Minimalism and elegance

  • Clean semantics first

  • Research and education focus

  • “Get the core right, build the rest”

  • Orthogonality over convenience

18.1.2 Design Goals Comparison

;;; Scheme's goals (from R5RS):
;; 1. Clean semantics (lexical scope, proper tail recursion)
;; 2. Small size (enable full understanding)
;; 3. First-class continuations
;; 4. Latent typing
;; 5. Uniform evaluation rules

;;; Common Lisp's goals (from CLtL):
;; 1. Commonality (unify divergent dialects)
;; 2. Portability (run on different systems)
;; 3. Consistency (but practical over pure)
;; 4. Expressiveness (rich feature set)
;; 5. Efficiency (compete with other languages)
;; 6. Stability (long-term investment)

18.2 Core Language Differences

18.2.1 Namespaces and Evaluation

Scheme: Single Namespace (Lisp-1)

;;; In Scheme, functions and variables share namespace
(define (square x) (* x x))
(define square 25)  ; Error! 'square' already defined

;; Function and value are the same
(define add +)
(add 2 3)  ; ⇒ 5

;; Can pass functions directly
(map square '(1 2 3 4))  ; square is both var and function

Common Lisp: Separate Namespaces (Lisp-2)

;;; In Common Lisp, functions and variables are separate
(defun square (x) (* x x))
(defvar square 25)  ; OK - different namespace

;; Must use #' to get function value
(funcall #'square 3)  ; ⇒ 9

;; Or use function name directly in function position
(square 3)  ; ⇒ 9

;; Need #' in higher-order contexts
(mapcar #'square '(1 2 3 4))

Comparison Table:

Aspect Scheme Common Lisp
Namespaces 1 (unified) 2+ (function, value, etc.)
Function call (f x) (f x) or (funcall f x)
Higher-order (map f list) (mapcar #'f list)
Lambda quote Not needed #'(lambda …)
Advantages Simpler, uniform Less name collision

18.2.2 Boolean Values and Conditionals

Scheme: Distinct False

;;; Scheme has #t and #f
(if #f 'yes 'no)  ; ⇒ no
(if #t 'yes 'no)  ; ⇒ yes

;; Everything except #f is true
(if 0 'yes 'no)      ; ⇒ yes
(if '() 'yes 'no)    ; ⇒ yes (empty list is true!)
(if "" 'yes 'no)     ; ⇒ yes

;; Predicates return #t or #f
(null? '())    ; ⇒ #t
(zero? 0)      ; ⇒ #t
(equal? 1 2)   ; ⇒ #f

Common Lisp: NIL as False

;;; Common Lisp uses nil and t
(if nil 'yes 'no)  ; ⇒ no
(if t 'yes 'no)    ; ⇒ yes

;; nil is false, everything else is true
(if 0 'yes 'no)       ; ⇒ yes
(if '() 'yes 'no)     ; ⇒ no (nil is empty list!)
(if "" 'yes 'no)      ; ⇒ yes

;; Predicates often return value or nil
(find 3 '(1 2 3 4))   ; ⇒ 3 (the value itself)
(find 5 '(1 2 3 4))   ; ⇒ nil

18.2.3 Tail Call Optimization

Scheme: Guaranteed Tail Calls

;;; Scheme REQUIRES proper tail recursion
(define (factorial n)
  (let loop ((n n) (acc 1))
    (if (≤ n 1)
        acc
        (loop (- n 1) (* acc n)))))  ; Guaranteed constant space

;; Can use tail recursion for any iteration
(factorial 1000000)  ; Works - no stack overflow

;; Mutual tail recursion also works
(define (even? n)
  (if (= n 0) #t (odd? (- n 1))))

(define (odd? n)
  (if (= n 0) #f (even? (- n 1))))

(even? 1000000)  ; Works fine

Common Lisp: Optional Tail Call Optimization

;;; Common Lisp MAY optimize tail calls
(defun factorial (n &optional (acc 1))
  (if (≤ n 1)
      acc
      (factorial (- n 1) (* acc n))))

;; May or may not be optimized
;; (factorial 1000000)  ; Might stack overflow

;; Usually need explicit iteration
(defun factorial-iter (n)
  (loop for i from 1 to n
        for acc = 1 then (* acc i)
        finally (return acc)))

;; Or compiler declarations
(defun factorial-tco (n &optional (acc 1))
  (declare (optimize (speed 3) (safety 0)))
  (if (≤ n 1)
      acc
      (factorial-tco (- n 1) (* acc n))))

18.2.4 Continuations

Scheme: First-Class Continuations

;;; Scheme has call/cc (call-with-current-continuation)
(define (test-cc)
  (call/cc
    (lambda (return)
      (display "Before\n")
      (return 42)  ; Non-local exit
      (display "After\n")  ; Never executed
      99)))

(test-cc)  ; ⇒ 42, prints only "Before"

;; Implementing exceptions with call/cc
(define (try-catch thunk handler)
  (call/cc
    (lambda (exit)
      (parameterize ([current-exception-handler 
                      (lambda (e) (exit (handler e)))])
        (thunk)))))

;; Generators with continuations
(define (make-generator proc)
  (define resume #f)
  (define return #f)
  
  (lambda ()
    (call/cc
      (lambda (caller)
        (if resume
            (resume caller)
            (begin
              (set! return caller)
              (proc (lambda (value)
                     (call/cc
                       (lambda (k)
                         (set! resume k)
                         (return value)))))))))))

(define gen
  (make-generator
    (lambda (yield)
      (yield 1)
      (yield 2)
      (yield 3))))

(gen)  ; ⇒ 1
(gen)  ; ⇒ 2
(gen)  ; ⇒ 3

Common Lisp: No Standard Continuations

;;; Common Lisp doesn't have call/cc in standard
;; Must use other control structures

;; Exceptions via condition system
(handler-case
    (progn
      (format t "Before~%")
      (error "Something went wrong")
      (format t "After~%"))  ; Not executed
  (error (e) 
    (format t "Caught: ~a~%" e)
    42))

;; Generators via closures and local state
(defun make-generator (values)
  (let ((remaining values))
    (lambda ()
      (if remaining
          (prog1 (car remaining)
            (setf remaining (cdr remaining)))
          nil))))

(defvar gen (make-generator '(1 2 3)))
(funcall gen)  ; ⇒ 1
(funcall gen)  ; ⇒ 2
(funcall gen)  ; ⇒ 3

18.3 Macro Systems

18.3.1 Traditional Macros

Scheme: Hygienic Macros (syntax-rules)

;;; Scheme's syntax-rules ensures hygiene
(define-syntax my-when
  (syntax-rules ()
    ((my-when test body …)
     (if test (begin body …)))))

;; No variable capture problems
(let ((if 42))
  (my-when #t 
    (display if)))  ; Prints 42, not affected by macro's 'if'

;; Pattern-based, declarative
(define-syntax my-and
  (syntax-rules ()
    ((my-and) #t)
    ((my-and test) test)
    ((my-and test rest …)
     (if test (my-and rest …) #f))))

;; With literal identifiers
(define-syntax my-cond
  (syntax-rules (else)
    ((my-cond) (void))
    ((my-cond (else result …))
     (begin result …))
    ((my-cond (test result …) clause …)
     (if test
         (begin result …)
         (my-cond clause …)))))

Common Lisp: Unhygienic Macros (defmacro)

;;; Common Lisp's defmacro is more flexible but manual
(defmacro my-when (test &body body)
  `(if ,test (progn ,@body)))

;; Must avoid capture manually
(let ((if 42))
  (my-when t 
    (print if)))  ; Prints 42, safe because we didn't capture

;; Gensyms for avoiding capture
(defmacro with-temp (var &body body)
  (let ((temp (gensym)))  ; Create unique symbol
    `(let ((,temp ,var))
       ,@body)))

;; Can manipulate code directly
(defmacro repeat (n &body body)
  `(loop repeat ,n do (progn ,@body)))

;; Can use full language at macro-expansion time
(defmacro case-using (pred expr &body clauses)
  `(cond
     ,@(mapcar (lambda (clause)
                 `((funcall ,pred ,expr ',(car clause))
                   ,@(cdr clause)))
               clauses)))

18.3.2 Advanced Macro Features

Scheme: syntax-case (R6RS)

;;; syntax-case provides more power while staying hygienic
(define-syntax define-enum
  (lambda (x)
    (syntax-case x ()
      ((_ name (variant …))
       (with-syntax (((index …) (iota (length #'(variant …)))))
         #'(begin
             (define name 'name)
             (define variant index) …
             (define (name? x)
               (memv x (list index …)))))))))

(define-enum color (red green blue))
red    ; ⇒ 0
green  ; ⇒ 1
blue   ; ⇒ 2
(color? 1)  ; ⇒ #t

;; Macros can analyze syntax
(define-syntax static-length
  (lambda (x)
    (syntax-case x ()
      ((_ lst)
       (let loop ((lst #'lst) (len 0))
         (syntax-case lst ()
           (() len)
           ((x . rest) (loop #'rest (+ len 1)))))))))

(static-length (1 2 3))  ; Computed at compile time!

Common Lisp: Macrolet and Symbol-Macrolet

;;; Local macro definitions
(macrolet ((double (x) `(+ ,x ,x)))
  (double 5))  ; ⇒ 10

;; Symbol macros (like aliases)
(symbol-macrolet ((x 10)
                  (y (* x 2)))
  (+ x y))  ; ⇒ 30

;; Complex compile-time computation
(defmacro compile-time-fibonacci (n)
  (labels ((fib (n)
             (if (≤ n 1)
                 n
                 (+ (fib (- n 1)) (fib (- n 2))))))
    (fib n)))

(compile-time-fibonacci 20)  ; Computed during compilation!

18.4 Object-Oriented Programming

18.4.1 Object Systems

Scheme: Multiple Approaches

;;; Simple record-based OO
(define-record-type <point>
  (make-point x y)
  point?
  (x point-x set-point-x!)
  (y point-y set-point-y!))

(define (point-distance p1 p2)
  (sqrt (+ (expt (- (point-x p2) (point-x p1)) 2)
           (expt (- (point-y p2) (point-y p1)) 2))))

;;; Message-passing style
(define (make-account balance)
  (lambda (msg . args)
    (case msg
      ((deposit) 
       (set! balance (+ balance (car args)))
       balance)
      ((withdraw)
       (if (≥ balance (car args))
           (begin
             (set! balance (- balance (car args)))
             balance)
           "Insufficient funds"))
      ((balance) balance)
      (else (error "Unknown message" msg)))))

(define acc (make-account 100))
(acc 'deposit 50)   ; ⇒ 150
(acc 'withdraw 30)  ; ⇒ 120

;;; Prototype-based (SLIB)
;; Uses delegation and cloning

Common Lisp: CLOS (Common Lisp Object System)

;;; CLOS is sophisticated and standardized
(defclass point ()
  ((x :initarg :x :accessor point-x)
   (y :initarg :y :accessor point-y)))

(defmethod point-distance ((p1 point) (p2 point))
  (sqrt (+ (expt (- (point-x p2) (point-x p1)) 2)
           (expt (- (point-y p2) (point-y p1)) 2))))

;; Multiple dispatch
(defmethod combine ((a number) (b number))
  (+ a b))

(defmethod combine ((a string) (b string))
  (concatenate 'string a b))

(defmethod combine ((a list) (b list))
  (append a b))

;; Multiple inheritance
(defclass colored-shape ()
  ((color :initarg :color :accessor shape-color)))

(defclass circle (point colored-shape)
  ((radius :initarg :radius :accessor circle-radius)))

;; Method combination
(defgeneric process (x)
  (:method-combination list))

(defmethod process list ((x number))
  (list 'number x))

(defmethod process list ((x string))
  (list 'string x))

(process 42)  ; ⇒ ((NUMBER 42) (STRING "42"))

18.4.2 Metaobject Protocol

Common Lisp: MOP

;;; CLOS has a metaobject protocol (not standard but widely available)
(defclass singleton-class (standard-class)
  ((instance :initform nil :accessor singleton-instance)))

(defmethod make-instance ((class singleton-class) &rest args)
  (or (singleton-instance class)
      (setf (singleton-instance class)
            (call-next-method))))

(defclass my-singleton ()
  ()
  (:metaclass singleton-class))

(eq (make-instance 'my-singleton)
    (make-instance 'my-singleton))  ; ⇒ T

;;; Custom slot access
(defclass logged-class (standard-class)
  ())

(defmethod (setf slot-value-using-class) 
           (new-value (class logged-class) object slot)
  (format t "Setting ~a to ~a~%" (slot-definition-name slot) new-value)
  (call-next-method))

Scheme: Limited Metaobject Features

;;; Scheme doesn't standardize metaobjects
;; Some implementations provide extensions

;; TinyCLOS (available for some Schemes)
;; Racket's class system has some metaprogramming

18.5 Standard Libraries

18.5.1 Library Organization

Scheme: Modular, Opt-In

;;; R7RS library system
(define-library (my-utils math)
  (export factorial fibonacci)
  (import (scheme base))
  
  (begin
    (define (factorial n)
      (if (≤ n 1) 1 (* n (factorial (- n 1)))))
    
    (define (fibonacci n)
      (if (≤ n 1) n (+ (fibonacci (- n 1)) 
                        (fibonacci (- n 2)))))))

;; Use in another library
(import (scheme base)
        (my-utils math))

(factorial 5)  ; ⇒ 120

Common Lisp: Packages, All-In

;;; Package system
(defpackage :my-utils
  (:use :common-lisp)
  (:export :factorial :fibonacci))

(in-package :my-utils)

(defun factorial (n)
  (if (≤ n 1) 1 (* n (factorial (1- n)))))

(defun fibonacci (n)
  (if (≤ n 1) n (+ (fibonacci (1- n)) 
                    (fibonacci (- n 2)))))

;; Use in another package
(defpackage :my-app
  (:use :common-lisp :my-utils))

(in-package :my-app)
(factorial 5)  ; ⇒ 120

18.5.2 Built-in Features Comparison

Feature Scheme Common Lisp
Strings Basic in R5RS, better in R6RS/R7RS Rich string operations
Arrays Vectors (1D) in core Multi-dimensional arrays
Hash tables SRFI or implementation Built-in, standardized
I/O Minimal in R5RS Comprehensive streams
Numbers Tower of types Tower of types + ratios
Conditions SRFI or R6RS Full condition system
Sequences Lists and vectors Lists, vectors, sequences
Iteration Recursion + some loops DO, LOOP, DOLIST, etc.
Format SRFI-48 or implementation FORMAT (printf-like)

18.5.3 Common Operations Compared

String Operations:

;;; Scheme (R7RS)
(string-append "Hello" " " "World")
(string-ref "Hello" 0)  ; ⇒ #\H
(substring "Hello" 0 4)  ; ⇒ "Hell"
(string→list "ABC")  ; ⇒ (#\A #\B #\C)
;;; Common Lisp
(concatenate 'string "Hello" " " "World")
(char "Hello" 0)  ; ⇒ #\H
(subseq "Hello" 0 4)  ; ⇒ "Hell"
(coerce "ABC" 'list)  ; ⇒ (#\A #\B #\C)

List Operations:

;;; Scheme
(append '(1 2) '(3 4))
(reverse '(1 2 3))
(length '(1 2 3))
(list-ref '(a b c) 1)  ; ⇒ b
(member 2 '(1 2 3))  ; ⇒ (2 3)
;;; Common Lisp
(append '(1 2) '(3 4))
(reverse '(1 2 3))
(length '(1 2 3))
(nth 1 '(a b c))  ; ⇒ b
(member 2 '(1 2 3))  ; ⇒ (2 3)

Iteration:

;;; Scheme - recursion or named let
(let loop ((n 10) (acc 0))
  (if (zero? n)
      acc
      (loop (- n 1) (+ acc n))))

;; Or using do
(do ((n 10 (- n 1))
     (acc 0 (+ acc n)))
    ((zero? n) acc))
;;; Common Lisp - many iteration forms
(loop for n from 1 to 10
      sum n)

(do ((n 10 (1- n))
     (acc 0 (+ acc n)))
    ((zerop n) acc))

(dotimes (i 10 acc)
  (incf acc i))

18.6 Practical Considerations

18.6.1 Implementation Ecosystem

Scheme Implementations:

;;; Major Scheme implementations
;; - Racket: Full-featured, batteries included, DrRacket IDE
;; - Guile: GNU's extension language
;; - Chez Scheme: Fast, commercial-grade
;; - Chicken: Compiles to C, good FFI
;; - MIT Scheme: Educational, classic
;; - Gambit: Efficient compiler
;; - Chibi: R7RS-small, embedded systems

;; Portability considerations
;; - Use R7RS-small for maximum portability
;; - Use SRFIs for common extensions
;; - Each implementation has unique features

Common Lisp Implementations:

;;; Major Common Lisp implementations
;; - SBCL: High-performance, open source
;; - CCL: Clozure CL, fast development cycle
;; - ECL: Embeddable CL, compiles to C
;; - ABCL: Armed Bear, runs on JVM
;; - LispWorks: Commercial, good IDE
;; - Allegro CL: Commercial, enterprise support
;; - CLISP: Portable bytecode interpreter

;; Strong portability due to ANSI standard
;; Libraries work across implementations

18.6.2 Use Case Recommendations

When to Choose Scheme:

;;; Good for:
;; 1. Education and learning programming concepts
(define (church-zero) (lambda (f) (lambda (x) x)))
(define (church-add1 n)
  (lambda (f) (lambda (x) (f ((n f) x)))))

;; 2. Research and language experiments
(define-syntax lazy
  (syntax-rules ()
    ((lazy expr)
     (lambda () expr))))

;; 3. Embedded scripting (Guile, Chibi)
;; 4. Projects valuing minimalism and elegance
;; 5. When you want full control over stack (tail calls)

;;; Example: Scheme as extension language
;; (define (init-game-scripting)
;;   (load-scheme-functions)
;;   (eval-script "game-logic.scm"))

When to Choose Common Lisp:

;;; Good for:
;; 1. Large, complex applications
(defclass application ()
  ((name :initarg :name)
   (modules :initform nil)
   (config :initform (make-hash-table))))

;; 2. Industrial/commercial development
;; 3. Systems requiring performance
(defun optimize-critical-loop (data)
  (declare (optimize (speed 3) (safety 0))
           (type (simple-array fixnum (*)) data))
  (loop for x across data sum x))

;; 4. When you need comprehensive standard library
(format t "~{~:(~a~)~^ ~}" '(hello world))  ; ⇒ "Hello World"

;; 5. Sophisticated object-oriented design
;; 6. Interactive development with strong tooling

18.6.3 Translation Patterns

Converting Scheme to Common Lisp:

;;; Scheme code
(define (make-counter)
  (let ((count 0))
    (lambda ()
      (set! count (+ count 1))
      count)))

(define counter (make-counter))
;;; Common Lisp equivalent
(defun make-counter ()
  (let ((count 0))
    #'(lambda ()
        (setf count (1+ count))
        count)))

(defvar counter (make-counter))
(funcall counter)  ; Note: need funcall

Common Patterns:

Scheme Common Lisp Notes
define defun, defvar Different for functions vs variables
lambda lambda or #'(lambda …) Need #’ in some contexts
set! setf, setq setf is more general
#t, #f t, nil Different true/false values
null? null Predicate naming
list-ref nth Order of arguments differs
string-append concatenate CL more general
apply apply Same, but CL needs #’

18.6.4 Interoperability

Using Both Languages:

;;; Scheme calling out to Common Lisp (hypothetical bridge)
;; Some implementations allow this via shared FFI

(define cl-format
  (foreign-procedure "cl_format" 
    (string list) string))

(cl-format "~{~a~^, ~}" '(1 2 3))  ; Uses CL's format
;;; Common Lisp calling Scheme (via ECL or similar)
;; Can embed Scheme interpreters

(defun call-scheme (code)
  (with-scheme-environment
    (scheme-eval code)))

18.7 Community and Culture

18.7.1 Development Culture

Scheme Community:

  • Academic and research-oriented

  • Values elegance and minimalism

  • Multiple implementations, different philosophies

  • Strong focus on language semantics

  • Active in PL research

  • SRFIs (Scheme Requests for Implementation) process

  • Emphasis on teaching and learning

Common Lisp Community:

  • Professional and practical-oriented

  • Values power and expressiveness

  • Stable standard (ANSI CL)

  • Focus on getting work done

  • Rich ecosystem (Quicklisp)

  • Strong commercial history

  • Emphasis on building real systems

18.7.2 Learning Resources

Scheme Learning Path:

;;; Recommended progression
;; 1. SICP (Structure and Interpretation of Computer Programs)
;; 2. The Little Schemer series
;; 3. R7RS Report (for standard)
;; 4. SRFIs for practical extensions
;; 5. Implementation-specific docs (Racket Guide, etc.)

;; SICP-style approach
(define (fixed-point f first-guess)
  (define (close-enough? v1 v2)
    (< (abs (- v1 v2)) 0.00001))
  (define (try guess)
    (let ((next (f guess)))
      (if (close-enough? guess next)
          next
          (try next))))
  (try first-guess))

Common Lisp Learning Path:

;;; Recommended progression
;; 1. Practical Common Lisp (PCL)
;; 2. On Lisp (for macros)
;; 3. ANSI Common Lisp (Hyperspec)
;; 4. AMOP (for advanced OOP)
;; 5. Let Over Lambda (advanced techniques)

;; PCL-style approach
(defun make-cd (title artist rating ripped)
  (list :title title :artist artist 
        :rating rating :ripped ripped))

(defvar *db* nil)

(defun add-record (cd) 
  (push cd *db*))

18.8 Benchmarking and Performance

18.8.1 Performance Characteristics

Scheme Performance:

;;; Tail-call optimization enables iterative performance
(define (sum-to-n n)
  (let loop ((i 0) (acc 0))
    (if (> i n)
        acc
        (loop (+ i 1) (+ acc i)))))

;; Constant space, even for huge n
(sum-to-n 10000000)  ; Safe

;; First-class continuations have overhead
;; Some implementations compile to C (Chicken, Gambit)
;; Others have JIT (Chez, Racket)

Common Lisp Performance:

;;; Explicit iteration can be very fast
(defun sum-to-n (n)
  (declare (optimize (speed 3) (safety 0))
           (type fixnum n))
  (loop for i fixnum from 0 to n
        sum i fixnum))

;; Can achieve C-like speed with declarations
;; SBCL's compiler is particularly good
;; Strong control over memory allocation

;; Example: unboxed arithmetic
(defun fast-matrix-multiply (a b)
  (declare (optimize (speed 3) (safety 0))
           (type (simple-array double-float (* *)) a b))
  ;; … optimized code
  )

18.8.2 Sample Benchmark Comparison

;;; Scheme (Chez Scheme)
(define (ackermann m n)
  (cond ((zero? m) (+ n 1))
        ((zero? n) (ackermann (- m 1) 1))
        (else (ackermann (- m 1) 
                        (ackermann m (- n 1))))))

(time (ackermann 3 10))
;; Typical: ~50-200ms depending on implementation
;;; Common Lisp (SBCL)
(defun ackermann (m n)
  (declare (optimize (speed 3) (safety 0))
           (type fixnum m n))
  (cond ((zerop m) (1+ n))
        ((zerop n) (ackermann (1- m) 1))
        (t (ackermann (1- m) 
                     (ackermann m (1- n))))))

(time (ackermann 3 10))
;; Typical: ~20-100ms with good declarations

18.9 Summary

This chapter explored the differences and similarities between Scheme and Common Lisp:

Key Differences:

  1. Namespace: Scheme (Lisp-1) vs Common Lisp (Lisp-2)

  2. Philosophy: Minimalism vs comprehensiveness

  3. Tail calls: Required vs optional

  4. Continuations: First-class vs condition system

  5. Macros: Hygienic vs manual hygiene

  6. Objects: Multiple approaches vs CLOS

  7. Standard: Minimal vs extensive

Commonalities:

  1. S-expression syntax

  2. Homoiconicity

  3. Interactive development

  4. Garbage collection

  5. Dynamic typing (with optional static typing)

  6. Powerful macro systems

  7. Functional programming support

Choosing Between Them:

  • Use Scheme for: education, research, minimalism, embedded scripting

  • Use Common Lisp for: industry, large applications, performance, rich standard library

Both languages remain relevant and influential, each serving its community well while advancing the art of programming.

Exercises

  1. Translate a Scheme program using call/cc to Common Lisp using the condition system

  2. Implement the same macro in both syntax-rules and defmacro

  3. Compare performance of tail-recursive vs iterative solutions

  4. Port a small Scheme library to Common Lisp

  5. Create a compatibility layer for basic operations

  6. Implement an object system in Scheme similar to CLOS

  7. Write a Scheme interpreter in Common Lisp (or vice versa)

  8. Benchmark identical algorithms in both languages

This concludes Chapter #18. Would you like to proceed to another chapter?

Chapter #19: Scheme in the Broader Language Landscape

Introduction

Scheme does not exist in isolation. It has influenced and been influenced by a diverse ecosystem of programming languages. Understanding Scheme’s place in the broader landscape helps us appreciate both its unique contributions and how its ideas have propagated throughout programming language design.

This chapter explores:

  • Scheme’s influence on modern languages

  • Comparative analysis with other paradigms

  • Language features that originated in or were refined by Scheme

  • How Scheme’s philosophy manifests in contemporary languages

  • Cross-pollination of ideas between language families

  • The evolution of functional programming concepts

19.1 Scheme’s Core Contributions to Programming

19.1.1 Lexical Scoping

Historical Context:

;;; Before lexical scoping was standard
;; Early Lisps used dynamic scoping
;; Variables were looked up in the call stack

;;; Scheme introduced lexical scoping (1975)
(define (make-adder n)
  (lambda (x) (+ x n)))  ; n is captured lexically

(define add5 (make-adder 5))
(add5 10)  ; ⇒ 15

;; This pattern became standard in modern languages

Modern Manifestations:

// JavaScript adopted lexical scoping
function makeAdder(n) {
    return function(x) { return x + n; };
}

const add5 = makeAdder(5);
add5(10);  // ⇒ 15
# Python uses lexical scoping
def make_adder(n):
    return lambda x: x + n

add5 = make_adder(5)
add5(10)  # ⇒ 15
# Ruby closures capture lexically
def make_adder(n)

  →(x) { x + n }
end

add5 = make_adder(5)
add5.call(10)  # ⇒ 15

19.1.2 First-Class Functions and Closures

Scheme’s Model:

;;; Functions as first-class values
(define (compose f g)
  (lambda (x) (f (g x))))

(define (twice f)
  (lambda (x) (f (f x))))

(define square (lambda (x) (* x x)))

((twice square) 3)  ; ⇒ 81

;; Higher-order programming
(define (map-reduce map-fn reduce-fn init lst)
  (if (null? lst)
      init
      (reduce-fn (map-fn (car lst))
                 (map-reduce map-fn reduce-fn init (cdr lst)))))

(map-reduce square + 0 '(1 2 3 4))  ; ⇒ 30

Influence on Other Languages:

// Scala embraces first-class functions
def compose[A, B, C](f: B ⇒ C)(g: A ⇒ B): A ⇒ C =
  x ⇒ f(g(x))

def twice[A](f: A ⇒ A): A ⇒ A =
  x ⇒ f(f(x))

val square: Int ⇒ Int = x ⇒ x * x

twice(square)(3)  // ⇒ 81
// Swift first-class functions
func compose<A, B, C>(_ f: @escaping (B) → C) 

                   → (@escaping (A) → B) → (A) → C {
    return { g in { x in f(g(x)) } }
}

func twice<A>(_ f: @escaping (A) → A) → (A) → A {
    return { x in f(f(x)) }
}
// Kotlin function composition
fun <A, B, C> compose(f: (B) → C, g: (A) → B): (A) → C =
    { x → f(g(x)) }

fun <A> twice(f: (A) → A): (A) → A =
    { x → f(f(x)) }

19.1.3 Tail Call Optimization

Scheme’s Guarantee:

;;; Scheme requires tail call optimization
(define (sum-list lst)
  (define (loop items acc)
    (if (null? items)
        acc
        (loop (cdr items) (+ acc (car items)))))
  (loop lst 0))

;; Can process arbitrarily large lists
(sum-list (iota 10000000))  ; Constant stack space

;; Mutual tail recursion
(define (even? n)
  (if (= n 0) #t (odd? (- n 1))))

(define (odd? n)
  (if (= n 0) #f (even? (- n 1))))

Language Comparison:

Language Tail Call Optimization Notes
Scheme Guaranteed Part of specification
JavaScript Optional (ES6) Rarely implemented
Python No Guido opposes it
Lua Yes Properly tail-recursive
Scala Yes For self-recursion via @tailrec
OCaml Yes Standard behavior
Haskell N/A Lazy evaluation model
Rust No Uses iterators instead 

-- Lua guarantees tail calls
function sum_list(lst, acc)
    acc = acc or 0
    if #lst ⩵ 0 then
        return acc
    else
        return sum_list({table.unpack(lst, 2)}, acc + lst[1])
    end
end

19.1.4 Continuations

Scheme’s call/cc:

;;; First-class continuations
(define (product lst)
  (call/cc
    (lambda (exit)
      (let loop ((items lst) (result 1))
        (cond ((null? items) result)
              ((zero? (car items)) (exit 0))  ; Early exit
              (else (loop (cdr items) (* result (car items)))))))))

(product '(2 3 0 4))  ; ⇒ 0 (exits immediately at zero)

;; Implementing generators
(define (make-range start end)
  (lambda ()
    (call/cc
      (lambda (return)
        (let loop ((i start))
          (if (> i end)
              (return 'done)
              (begin
                (call/cc (lambda (k) 
                          (set! loop k)
                          (return i)))
                (loop (+ i 1)))))))))

Influence and Alternatives:

// JavaScript generators (inspired by continuations)
function* range(start, end) {
    for (let i = start; i ≤ end; i⧺) {
        yield i;
    }
}

const gen = range(1, 5);
console.log(gen.next().value);  // 1
console.log(gen.next().value);  // 2
# Python generators
def range_gen(start, end):
    for i in range(start, end + 1):
        yield i

gen = range_gen(1, 5)
print(next(gen))  # 1
print(next(gen))  # 2
# Ruby's Fiber (continuation-like)
fiber = Fiber.new do
  (1‥5).each do |i|
    Fiber.yield i
  end
end

puts fiber.resume  # 1
puts fiber.resume  # 2

19.2 Comparison with Other Functional Languages

19.2.1 Scheme vs ML Family

Type Systems:

;;; Scheme: Dynamic typing
(define (length lst)
  (if (null? lst)
      0
      (+ 1 (length (cdr lst)))))

;; Works for any list
(length '(1 2 3))      ; ⇒ 3
(length '("a" "b"))    ; ⇒ 2
(length '(#t #f))      ; ⇒ 2
(* OCaml: Static typing with inference *)
let rec length lst =
  match lst with
  | [] → 0
  | _ ∷ tail → 1 + length tail

(* Type is inferred: 'a list → int *)
length [1; 2; 3];;      (* ⇒ 3 *)
length ["a"; "b"];;     (* ⇒ 2 *)
(* length [1; "a"];;    (* Type error at compile time *) *)

-- Haskell: Strong static typing
length ∷ [a] → Int
length [] = 0
length (_:xs) = 1 + length xs


-- Polymorphic but type-safe
length [1, 2, 3]      -- ⇒ 3
length ["a", "b"]     -- ⇒ 2

-- length [1, "a"]    -- Type error

Pattern Matching:

;;; Scheme: Manual destructuring
(define (parse-expr expr)
  (cond ((number? expr) `(literal ,expr))
        ((symbol? expr) `(variable ,expr))
        ((and (list? expr) (eq? (car expr) '+))
         `(add ,(parse-expr (cadr expr))
               ,(parse-expr (caddr expr))))
        ((and (list? expr) (eq? (car expr) '*))
         `(multiply ,(parse-expr (cadr expr))
                    ,(parse-expr (caddr expr))))
        (else (error "Unknown expression" expr))))
(* OCaml: Built-in pattern matching *)
type expr =
  | Literal of int
  | Variable of string
  | Add of expr * expr
  | Multiply of expr * expr

let rec parse_expr = function
  | Literal n → Literal n
  | Variable s → Variable s
  | Add (e1, e2) → Add (parse_expr e1, parse_expr e2)
  | Multiply (e1, e2) → Multiply (parse_expr e1, parse_expr e2)

-- Haskell: Pattern matching with algebraic types
data Expr = Literal Int
          | Variable String
          | Add Expr Expr
          | Multiply Expr Expr

parseExpr ∷ Expr → Expr
parseExpr (Literal n) = Literal n
parseExpr (Variable s) = Variable s
parseExpr (Add e1 e2) = Add (parseExpr e1) (parseExpr e2)
parseExpr (Multiply e1 e2) = Multiply (parseExpr e1) (parseExpr e2)

Evaluation Strategy:

Language Strategy Implications
Scheme Strict/Eager Arguments evaluated before call
OCaml Strict/Eager Predictable performance
Haskell Lazy Deferred evaluation, infinite structures
ML Strict/Eager Similar to Scheme 
;;; Scheme: Strict evaluation
(define (take n lst)
  (if (or (zero? n) (null? lst))
      '()
      (cons (car lst) (take (- n 1) (cdr lst)))))

;; Must use explicit delays for laziness
(define (lazy-range start)
  (cons start (delay (lazy-range (+ start 1)))))

-- Haskell: Lazy by default
take ∷ Int → [a] → [a]
take 0 _ = []
take _ [] = []
take n (x:xs) = x : take (n-1) xs


-- Infinite lists work naturally
naturals = [1‥]
take 10 naturals  -- [1,2,3,4,5,6,7,8,9,10]

19.2.2 Scheme vs Clojure

Similarities:

;;; Scheme
(define (factorial n)
  (if (≤ n 1)
      1
      (* n (factorial (- n 1)))))

(map (lambda (x) (* x x)) '(1 2 3 4))
;;; Clojure (very similar)
(defn factorial [n]
  (if (≤ n 1)
      1
      (* n (factorial (dec n)))))

(map #(* % %) [1 2 3 4])

Key Differences:

;;; Scheme: Mutable by default
(define x 10)
(set! x 20)  ; Mutation allowed
x  ; ⇒ 20

;; Lists are mutable pairs
(define lst (list 1 2 3))
(set-car! lst 99)
lst  ; ⇒ (99 2 3)
;;; Clojure: Immutable by default
(def x 10)
;; (set! x 20)  ; No set! - immutable

;; Persistent data structures
(def lst [1 2 3])
(assoc lst 0 99)  ; ⇒ [99 2 3]
lst               ; ⇒ [1 2 3] (unchanged)

;; Explicit mutation with atoms
(def counter (atom 0))
(swap! counter inc)
@counter  ; ⇒ 1

Rich Data Structures:

;;; Scheme: Lists and vectors
(define my-map '((a . 1) (b . 2) (c . 3)))
(assoc 'b my-map)  ; ⇒ (b . 2)

(define my-vec (vector 1 2 3 4))
(vector-ref my-vec 2)  ; ⇒ 3
;;; Clojure: Rich literal syntax
(def my-map {:a 1 :b 2 :c 3})
(my-map :b)  ; ⇒ 2
(:b my-map)  ; ⇒ 2 (keywords are functions)

(def my-vec [1 2 3 4])
(my-vec 2)   ; ⇒ 3 (vectors are functions of indices)

(def my-set #{1 2 3 4})
(my-set 2)   ; ⇒ 2 (sets are membership functions)

19.2.3 Scheme vs Erlang/Elixir

Concurrency Model:

;;; Scheme: No standard concurrency
;; Implementations provide threads
;; Often with shared memory

(define counter 0)
(define lock (make-mutex))

(define (increment)
  (mutex-lock! lock)
  (set! counter (+ counter 1))
  (mutex-unlock! lock))

;; Spawn threads (implementation-specific)
(thread-start! (make-thread increment))
# Elixir: Actor model built-in
defmodule Counter do
  def start do
    spawn(fn → loop(0) end)
  end
  
  defp loop(count) do
    receive do
      {:increment, caller} →
        send(caller, {:value, count + 1})
        loop(count + 1)
      {:get, caller} →
        send(caller, {:value, count})
        loop(count)
    end
  end
end

counter = Counter.start()
send(counter, {:increment, self()})
receive do
  {:value, n} → IO.puts(n)
end

Fault Tolerance:

;;; Scheme: Manual error handling
(define (safe-divide a b)
  (call/cc
    (lambda (exit)
      (with-exception-handler
        (lambda (exn) (exit 'error))
        (lambda () (/ a b))))))

(safe-divide 10 0)  ; ⇒ 'error
# Elixir: Supervision trees
defmodule MyApp.Supervisor do
  use Supervisor
  
  def start_link(opts) do
    Supervisor.start_link(__MODULE__, :ok, opts)
  end
  
  def init(:ok) do
    children = [
      {Worker, arg}
    ]
    
    # Restart strategy: automatic recovery
    Supervisor.init(children, strategy: :one_for_one)
  end
end

19.3 Scheme’s Influence on Mainstream Languages

19.3.1 JavaScript

Direct Influences:

;;; Scheme's influence on JavaScript (via Self)

;; First-class functions
(define add (lambda (a b) (+ a b)))

;; Closures
(define (make-counter)
  (let ((count 0))
    (lambda ()
      (set! count (+ count 1))
      count)))
// JavaScript adopted these directly
const add = (a, b) ⇒ a + b;

// Closures work identically
function makeCounter() {
    let count = 0;
    return () ⇒ {
        count⧺;
        return count;
    };
}

const counter = makeCounter();
counter();  // 1
counter();  // 2

Brendan Eich’s Comments:

“I was recruited to Netscape with the promise of ‘doing Scheme’ in the browser.” — Brendan Eich (Creator of JavaScript)

Modern JavaScript Features:

// Arrow functions (like lambda)
const square = x ⇒ x * x;

// Map/filter/reduce (functional style)
[1, 2, 3, 4]
    .map(x ⇒ x * x)
    .filter(x ⇒ x > 5)
    .reduce((a, b) ⇒ a + b, 0);

// Destructuring (like pattern matching)
const [first, …rest] = [1, 2, 3, 4];

// Template strings (like Scheme's quasiquote idea)
const name = "World";
console.log(`Hello, ${name}!`);

19.3.2 Python

Functional Features:

;;; Scheme's influence on Python

;; Higher-order functions
(map square '(1 2 3 4))
(filter even? '(1 2 3 4 5 6))
(fold-left + 0 '(1 2 3 4))
# Python equivalents
list(map(lambda x: x*x, [1, 2, 3, 4]))
list(filter(lambda x: x % 2 ⩵ 0, [1, 2, 3, 4, 5, 6]))
from functools import reduce
reduce(lambda a, b: a + b, [1, 2, 3, 4], 0)

# List comprehensions (inspired by functional style)
[x*x for x in [1, 2, 3, 4]]
[x for x in [1, 2, 3, 4, 5, 6] if x % 2 ⩵ 0]

Decorators (Macro-like):

# Python decorators resemble Scheme macro patterns
def trace(func):
    def wrapper(*args, **kwargs):
        print(f"Calling {func.__name__}")
        result = func(*args, **kwargs)
        print(f"Result: {result}")
        return result
    return wrapper

@trace
def factorial(n):
    return 1 if n ≤ 1 else n * factorial(n-1)
;;; Similar pattern in Scheme
(define (trace proc)
  (lambda args
    (display "Calling procedure\n")
    (let ((result (apply proc args)))
      (display "Result: ")
      (display result)
      (newline)
      result)))

(define factorial
  (trace
    (lambda (n)
      (if (≤ n 1)
          1
          (* n (factorial (- n 1)))))))

19.3.3 Ruby

Block Syntax:

# Ruby blocks are like Scheme lambdas
[1, 2, 3, 4].map { |x| x * x }

# With do/end (more like Scheme's begin)
[1, 2, 3, 4].map do |x|
  x * x
end

# Higher-order methods everywhere
def twice(&block)
  block.call
  block.call
end

twice { puts "Hello!" }
;;; Scheme equivalent
(map (lambda (x) (* x x)) '(1 2 3 4))

;; Passing procedures
(define (twice proc)
  (begin
    (proc)
    (proc)))

(twice (lambda () (display "Hello!\n")))

Method Chaining:

# Ruby's fluent interfaces
[1, 2, 3, 4, 5, 6]
  .select { |x| x.even? }
  .map { |x| x * x }
  .reduce(0) { |sum, x| sum + x }
;;; Scheme threading
(fold-left +
           0
           (map (lambda (x) (* x x))
                (filter even? '(1 2 3 4 5 6))))

;; Or with threading macro (SRFI-197)
(⇝ '(1 2 3 4 5 6)
    (filter even?)
    (map (lambda (x) (* x x)))
    (fold-left + 0))

19.3.4 Rust

Functional Iteration:

// Rust iterators (functional style)
let result = vec![1, 2, 3, 4, 5, 6]
    .iter()
    .filter(|&x| x % 2 ⩵ 0)
    .map(|x| x * x)
    .sum∷<i32>();
;;; Scheme equivalent
(fold-left +
           0
           (map (lambda (x) (* x x))
                (filter even? '(1 2 3 4 5 6))))

Closures and Ownership:

// Rust closures capture environment
fn make_adder(n: i32) → impl Fn(i32) → i32 {
    move |x| x + n  // 'move' transfers ownership
}

let add5 = make_adder(5);
println!("{}", add5(10));  // 15
;;; Scheme closures (no ownership concerns)
(define (make-adder n)
  (lambda (x) (+ x n)))

(define add5 (make-adder 5))
(add5 10)  ; ⇒ 15

19.4 Scheme Concepts in Domain-Specific Languages

19.4.1 SQL and Relational Algebra

Functional Query Composition:

;;; Scheme-like query building
(define (query-users db)
  (map (lambda (row) (assoc 'name row))
       (filter (lambda (row) (> (assoc 'age row) 18))
               (table-select db 'users))))

-- SQL has similar composition
SELECT name 
FROM users 
WHERE age > 18;


-- Can be thought of as:

-- map(get-name, filter(age > 18, users))

19.4.2 React and Declarative UI

JSX Resembles S-expressions:

// React JSX
const element = (
  <div className="container">
    <h1>Hello, World!</h1>
    <p>Welcome to React</p>
  </div>
);
;;; Scheme-style UI description (Racket GUI)
(define element
  '(div ((class "container"))
     (h1 "Hello, World!")
     (p "Welcome to React")))

;; Or using s-expression syntax
(define (render-ui)
  `(frame "My Application"
     (vertical-panel
       (message "Hello, World!")
       (button "Click me" ,on-click))))

19.4.3 Configuration Languages

HCL (HashiCorp Configuration Language):

resource "aws_instance" "example" {
  ami           = "ami-0c55b159cbfafe1f0"
  instance_type = "t2.micro"
  
  tags = {
    Name = "ExampleInstance"
  }
}

Scheme-based Configuration:

;;; Guix system configuration (actual Scheme DSL)
(operating-system
  (host-name "my-system")
  (timezone "Europe/Paris")
  (locale "en_US.utf8")
  
  (bootloader
    (bootloader-configuration
      (bootloader grub-bootloader)
      (target "/dev/sda")))
  
  (services
    (cons* (service dhcp-client-service-type)
           (service openssh-service-type)
           %base-services)))

19.5 Language Evolution and Lessons

19.5.1 What Scheme Got Right

1. Simplicity and Minimalism:

;;; Core Scheme fits on a few pages
;; Define procedures
(define (square x) (* x x))

;; Lambda expressions
(lambda (x) (+ x 1))

;; Lexical scoping
;; Proper tail calls
;; First-class continuations
;; Uniform syntax

;; That's most of it!

2. First-Class Everything:

;;; Functions, continuations, syntax…
(define my-if
  (lambda (test then-clause else-clause)
    (if test (then-clause) (else-clause))))

(my-if (> 5 3)
       (lambda () 'yes)
       (lambda () 'no))  ; ⇒ yes

3. Homoiconicity:

;;; Code is data
(define expr '(+ 1 2))
(car expr)   ; ⇒ +
(cadr expr)  ; ⇒ 1

;; Easy metaprogramming
(define (optimize-add expr)
  (if (and (list? expr) (eq? (car expr) '+)
           (number? (cadr expr)) (= (cadr expr) 0))
      (caddr expr)  ; (+ 0 x) ⇒ x
      expr))

19.5.2 What Other Languages Adopted

Core Ideas That Spread:

Feature Origin Adopted By
Lexical closures Scheme (1975) Nearly all modern languages
Tail call optimization Scheme Lua, Scala, ML family
First-class functions Scheme/ML JavaScript, Python, Ruby, etc.
Pattern matching ML Scala, Rust, Python (3.10+)
Lazy evaluation Haskell Clojure (sequences), Kotlin
Immutability default Haskell Clojure, Rust
Type inference ML Haskell, Scala, Rust, TypeScript

19.5.3 Where Scheme’s Philosophy Didn’t Win

1. Static Typing:

;;; Scheme: Dynamic typing
(define (add a b) (+ a b))
;; No compile-time type checking

Most modern languages trend toward static typing:

  • Rust, Swift, Kotlin: strong static typing

  • Python, JavaScript: adding optional types

  • TypeScript: typed superset of JavaScript

2. S-expression Syntax:

;;; S-expressions
(define (factorial n)
  (if (≤ n 1)
      1
      (* n (factorial (- n 1)))))

Most languages use more conventional syntax:

  • C-style braces: Java, JavaScript, Rust, etc.

  • Python-style indentation

  • Ruby/Perl-style keywords

3. Macros Without Types:

Most modern languages either:

  • Don’t have macros (Java, Python)

  • Have limited template systems (C++)

  • Use AST transformations (Rust)

  • Combine with types (Scala, Haskell)

19.6 Modern Scheme-Inspired Languages

19.6.1 Racket

Beyond Scheme:

#lang racket

;;; Rich standard library
(require net/url)
(require web-server/servlet)

;; Type system (optional)
#lang typed/racket
(: factorial (→ Integer Integer))
(define (factorial n)
  (if (≤ n 1) 1 (* n (factorial (- n 1)))))

;; Multiple languages in one ecosystem
#lang datalog
parent(john, mary).
parent(john, tom).
ancestor(X, Y) :- parent(X, Y).
ancestor(X, Y) :- parent(X, Z), ancestor(Z, Y).

19.6.2 Clojure

Modernizing Lisp:

;;; Immutable by default
(def numbers [1 2 3 4 5])
(conj numbers 6)  ; ⇒ [1 2 3 4 5 6]
numbers           ; ⇒ [1 2 3 4 5] (unchanged)

;;; Rich literal syntax
{:name "Alice" :age 30}
#{1 2 3 4}
[1 2 3 4]

;;; JVM interop
(.toUpperCase "hello")  ; ⇒ "HELLO"
(System/currentTimeMillis)

;;; Software transactional memory
(def account (ref 100))
(dosync
  (alter account + 50))

19.6.3 Hy

Lisp on Python:

;;; Hy: Lisp syntax for Python
(defn factorial [n]
  (if (≤ n 1)
      1
      (* n (factorial (- n 1)))))

;; Access Python libraries
(import [numpy :as np])
(setv arr (np.array [1 2 3 4]))
(print (np.mean arr))

;; Macros with Python interop
(defmacro unless [test &rest body]
  `(if (not ~test) (do ~@body)))

19.7 Learning from the Ecosystem

19.7.1 Type Systems: The Ongoing Debate

Dynamic Typing (Scheme’s Choice):

Advantages:

  • Rapid prototyping

  • Metaprogramming flexibility

  • Simpler syntax

  • REPL-driven development

Disadvantages:

  • Runtime errors

  • Less tooling support

  • Harder to refactor large codebases

Static Typing (ML’s Choice):

Advantages:

  • Compile-time error detection

  • Better IDE support

  • Documentation in types

  • Performance optimizations

Disadvantages:

  • More verbose

  • Steeper learning curve

  • Less flexible for some metaprogramming

Modern Synthesis:

// TypeScript: optional gradual typing
function add(a: number, b: number): number {
    return a + b;
}

// Or start dynamic, add types later
function process(data) {
    return data.map(x ⇒ x * 2);
}
# Python type hints
def add(a: int, b: int) → int:
    return a + b

# Still runs without type checking
# But tools can verify types

19.7.2 Syntax: Readability vs Homoiconicity

S-expressions:

  • Uniform, simple to parse

  • Perfect for macros

  • Less familiar to most programmers

Conventional Syntax:

  • More readable to beginners

  • Better error messages

  • Larger grammar, harder to parse

Sweet-expressions (Compromise):

;;; Traditional
(define (factorial n)
  (if (≤ n 1)
      1
      (* n (factorial (- n 1)))))

;;; Sweet-expression (indentation-based)
define factorial(n)
  if {n ≤ 1}
    1
    {n * factorial{n - 1}}

19.7.3 Performance Culture

Scheme’s Historical Approach:

  • Elegance first, performance through clever compilation

  • Tail call optimization essential

  • Higher-order functions everywhere

Modern Requirements:

  • Predictable performance

  • Memory efficiency

  • Parallelism and concurrency

  • Zero-cost abstractions

Languages Balancing Both:

// Rust: Zero-cost abstractions
let result: i32 = (1‥1000)
    .filter(|x| x % 2 ⩵ 0)
    .map(|x| x * x)
    .sum();  // Optimizes to tight loop, no allocation

19.8 Future Directions

19.8.1 Scheme’s Continuing Relevance

Education:

  • SICP remains influential

  • Teaching programming concepts

  • Research platform

Embedded Systems:

  • Small footprint implementations

  • Chibi Scheme for microcontrollers

  • Guile as extension language

Research:

  • Language design experiments

  • Type system research

  • Compilation techniques

19.8.2 Ideas Still Being Explored

1. Macros in Typed Languages:

;;; Challenge: Make macros work with static types
;; Scheme macros don't interact with types
;; Typed Racket, Scala macros attempt solutions

2. Effect Systems:

;;; Challenge: Track side effects statically
;; Pure functions vs effectful functions
;; Haskell's monads, Koka's effects

3. Gradual Typing:

;;; Challenge: Mix typed and untyped code
;; TypeScript approach
;; Typed Racket approach

19.9 Comparative Summary

Language Philosophy Spectrum:

Minimalist Batteries-Included | | Scheme —- Clojure —- Ruby —- Python —- Common Lisp

Pure Functional Multi-Paradigm | | Haskell —- OCaml —- Scheme —- Clojure —- Common Lisp

Dynamic Static | | Scheme —- Ruby —- Python —- Typescript —- Rust —- Haskell

Academic Industrial | | Scheme —- Haskell —- OCaml —- Clojure —- Common Lisp

19.10 Conclusion

Scheme’s place in the programming language landscape is unique:

Historical Impact:

  • Pioneered lexical scoping and closures

  • Demonstrated power of first-class continuations

  • Showed minimalism can be powerful

  • Influenced generation of languages

Current Status:

  • Niche but influential

  • Strong in education and research

  • Embedded in some systems (Guile)

  • Ideas live on in other languages

Lessons Learned:

  1. Simple, orthogonal concepts compose well

  2. First-class functions are fundamental

  3. Dynamic typing enables powerful abstractions

  4. But: static typing wins for large systems

  5. Syntax matters for adoption

  6. Standard libraries matter

  7. Performance culture matters

For Modern Programmers:

  • Learn Scheme for concepts

  • Apply principles in other languages

  • Appreciate the design space

  • Choose the right tool for the job

Exercises

  1. Port a Scheme program to three different languages (e.g., Python, Rust, JavaScript)

  2. Implement a simple Scheme interpreter in a modern language

  3. Compare performance of functional vs imperative style

  4. Create a DSL using Scheme-inspired principles

  5. Analyze a modern language feature and trace its origins

  6. Implement the same algorithm in Scheme, Haskell, and Clojure

  7. Design a language feature combining Scheme’s flexibility with static typing

This concludes Chapter #19. Would you like to proceed to Chapter #20?

Chapter #20: Concurrency and Parallelism

Introduction

Concurrency and parallelism represent two related but distinct approaches to organizing computation. While Scheme’s specification doesn’t mandate specific concurrency primitives, modern Scheme implementations provide various mechanisms for concurrent and parallel programming. This chapter explores these concepts, their implementation in Scheme, and practical patterns for multi-threaded and distributed programming.

Key Distinctions:

  • Concurrency: Multiple tasks making progress (may or may not be simultaneous)

  • Parallelism: Multiple tasks executing simultaneously on different processors

20.1 Fundamental Concepts

20.1.1 Understanding Concurrency vs Parallelism

Conceptual Model:

;;; Concurrency: Dealing with multiple things at once
;; Task switching on single core
;; Example: Web server handling multiple requests

;;; Parallelism: Doing multiple things at once
;; Simultaneous execution on multiple cores
;; Example: Matrix multiplication distributed across cores

Visual Representation:

;;; Sequential Execution
;; Task A: [≡=]
;; Task B:       [≡=]
;; Task C:             [≡=]
;; Time:   0----1----2----3----4

;;; Concurrent Execution (Single Core)
;; Task A: [=]  [=]    [=]
;; Task B:    [=]  [=]    [=]
;; Task C:  [=]      [=]  [=]
;; Time:   0----1----2----3----4

;;; Parallel Execution (Multi-Core)
;; Core 1: [≡≡⩵]
;; Core 2: [≡≡⩵]
;; Core 3: [≡≡⩵]
;; Time:   0----1----2----3----4

20.1.2 The Challenge of Shared State

;;; Problem: Race Conditions
(define counter 0)

;; Thread 1:
(set! counter (+ counter 1))

;; Thread 2:
(set! counter (+ counter 1))

;; Expected: counter = 2
;; Possible: counter = 1 (race condition!)

;; Why? The operation isn't atomic:
;; 1. Read counter value
;; 2. Add 1
;; 3. Write back
;; Another thread can interleave between these steps

The Lost Update Problem:

;;; Demonstration of race condition
(define (demonstrate-race-condition)
  (define shared-counter 0)
  
  (define (increment-many-times n)
    (let loop ((i 0))
      (when (< i n)
        ;; Non-atomic increment
        (let ((temp shared-counter))
          (set! shared-counter (+ temp 1)))
        (loop (+ i 1)))))
  
  ;; If we could run these in parallel:
  ;; (parallel-execute
  ;;   (lambda () (increment-many-times 1000))
  ;;   (lambda () (increment-many-times 1000)))
  
  ;; Expected: 2000
  ;; Actual: somewhere between 1000 and 2000
  )

20.2 Scheme Threading Models

20.2.1 SRFI-18: Multithreading Support

Basic Thread Operations:

;;; Thread creation and management
(import (srfi 18))

;; Create a thread
(define my-thread
  (make-thread
    (lambda ()
      (display "Hello from thread\n")
      42)))

;; Start the thread
(thread-start! my-thread)

;; Wait for completion and get result
(define result (thread-join! my-thread))
;; result ⇒ 42

;; Check thread state
(thread-state my-thread)  ; ⇒ terminated

Thread Example:

;;; Simple parallel computation
(define (parallel-sum lst1 lst2)
  (let ((sum1 0)
        (sum2 0))
    
    ;; Thread 1: sum first list
    (define t1
      (make-thread
        (lambda ()
          (set! sum1 (apply + lst1)))))
    
    ;; Thread 2: sum second list
    (define t2
      (make-thread
        (lambda ()
          (set! sum2 (apply + lst2)))))
    
    ;; Start both threads
    (thread-start! t1)
    (thread-start! t2)
    
    ;; Wait for completion
    (thread-join! t1)
    (thread-join! t2)
    
    ;; Return combined result
    (+ sum1 sum2)))

(parallel-sum '(1 2 3 4 5) '(6 7 8 9 10))
;; ⇒ 55

20.2.2 Thread Synchronization

Mutexes (Mutual Exclusion):

;;; Protecting shared state with mutex
(import (srfi 18))

(define (make-thread-safe-counter)
  (let ((count 0)
        (mutex (make-mutex)))
    
    ;; Increment operation
    (define (increment!)
      (mutex-lock! mutex)
      (set! count (+ count 1))
      (mutex-unlock! mutex))
    
    ;; Get current value
    (define (get-value)
      (mutex-lock! mutex)
      (let ((result count))
        (mutex-unlock! mutex)
        result))
    
    ;; Dispatch
    (lambda (msg)
      (cond ((eq? msg 'increment!) increment!)
            ((eq? msg 'get) (get-value))
            (else (error "Unknown message" msg))))))

;; Usage
(define counter (make-thread-safe-counter))

(define threads
  (map (lambda (i)
         (make-thread
           (lambda ()
             (let loop ((n 1000))
               (when (> n 0)
                 ((counter 'increment!))
                 (loop (- n 1)))))))
       (iota 10)))

;; Start all threads
(for-each thread-start! threads)

;; Wait for completion
(for-each thread-join! threads)

;; Check result
(counter 'get)  ; ⇒ 10000 (correct!)

Condition Variables:

;;; Producer-Consumer with condition variables
(define (make-bounded-queue capacity)
  (let ((queue '())
        (mutex (make-mutex))
        (not-empty (make-condition-variable))
        (not-full (make-condition-variable)))
    
    (define (enqueue! item)
      (mutex-lock! mutex)
      ;; Wait while queue is full
      (let wait-for-space ()
        (when (≥ (length queue) capacity)
          (condition-variable-wait! not-full mutex)
          (wait-for-space)))
      ;; Add item
      (set! queue (append queue (list item)))
      ;; Signal consumers
      (condition-variable-signal! not-empty)
      (mutex-unlock! mutex))
    
    (define (dequeue!)
      (mutex-lock! mutex)
      ;; Wait while queue is empty
      (let wait-for-item ()
        (when (null? queue)
          (condition-variable-wait! not-empty mutex)
          (wait-for-item)))
      ;; Remove item
      (let ((item (car queue)))
        (set! queue (cdr queue))
        ;; Signal producers
        (condition-variable-signal! not-full)
        (mutex-unlock! mutex)
        item))
    
    (lambda (msg)
      (cond ((eq? msg 'enqueue!) enqueue!)
            ((eq? msg 'dequeue!) dequeue!)
            (else (error "Unknown message" msg))))))

;; Producer thread
(define (producer queue n)
  (lambda ()
    (let loop ((i 0))
      (when (< i n)
        ((queue 'enqueue!) i)
        (display (string-append "Produced: " 
                               (number→string i) "\n"))
        (loop (+ i 1))))))

;; Consumer thread
(define (consumer queue n)
  (lambda ()
    (let loop ((i 0))
      (when (< i n)
        (let ((item ((queue 'dequeue!))))
          (display (string-append "Consumed: " 
                                 (number→string item) "\n"))
          (loop (+ i 1)))))))

;; Example usage
(define queue (make-bounded-queue 5))

(define producer-thread
  (thread-start! (make-thread (producer queue 20))))

(define consumer-thread
  (thread-start! (make-thread (consumer queue 20))))

(thread-join! producer-thread)
(thread-join! consumer-thread)

20.2.3 Atomic Operations

Compare-and-Swap:

;;; Lock-free counter using CAS
;; Note: Implementation-dependent; shown conceptually

(define (make-atomic-counter)
  (let ((value (make-atomic-box 0)))
    
    (define (increment!)
      (let retry ()
        (let ((old-val (atomic-box-ref value)))
          (unless (atomic-box-compare-and-swap! 
                   value old-val (+ old-val 1))
            ;; CAS failed, retry
            (retry)))))
    
    (define (get-value)
      (atomic-box-ref value))
    
    (lambda (msg)
      (cond ((eq? msg 'increment!) increment!)
            ((eq? msg 'get) (get-value))
            (else (error "Unknown message" msg))))))

Atomic Data Structures:

;;; Lock-free stack
(define (make-lock-free-stack)
  (let ((top (make-atomic-box '())))
    
    (define (push! item)
      (let retry ()
        (let ((old-top (atomic-box-ref top)))
          (unless (atomic-box-compare-and-swap! 
                   top old-top (cons item old-top))
            (retry)))))
    
    (define (pop!)
      (let retry ()
        (let ((old-top (atomic-box-ref top)))
          (if (null? old-top)
              #f
              (if (atomic-box-compare-and-swap! 
                   top old-top (cdr old-top))
                  (car old-top)
                  (retry))))))
    
    (lambda (msg)
      (cond ((eq? msg 'push!) push!)
            ((eq? msg 'pop!) (pop!))
            (else (error "Unknown message" msg))))))

20.3 Message-Passing Concurrency

20.3.1 Mailbox Model

Actor-Style Communication:

;;; Simple mailbox implementation
(define (make-mailbox)
  (let ((messages '())
        (mutex (make-mutex))
        (not-empty (make-condition-variable)))
    
    (define (send! msg)
      (mutex-lock! mutex)
      (set! messages (append messages (list msg)))
      (condition-variable-signal! not-empty)
      (mutex-unlock! mutex))
    
    (define (receive!)
      (mutex-lock! mutex)
      (let wait ()
        (when (null? messages)
          (condition-variable-wait! not-empty mutex)
          (wait)))
      (let ((msg (car messages)))
        (set! messages (cdr messages))
        (mutex-unlock! mutex)
        msg))
    
    (define (try-receive!)
      (mutex-lock! mutex)
      (let ((result
              (if (null? messages)
                  #f
                  (let ((msg (car messages)))
                    (set! messages (cdr messages))
                    msg))))
        (mutex-unlock! mutex)
        result))
    
    (lambda (msg)
      (cond ((eq? msg 'send!) send!)
            ((eq? msg 'receive!) receive!)
            ((eq? msg 'try-receive!) try-receive!)
            (else (error "Unknown message" msg))))))

;; Actor abstraction
(define (make-actor behavior initial-state)
  (let ((mailbox (make-mailbox))
        (state initial-state))
    
    ;; Message processing loop
    (define (actor-loop)
      (let ((msg ((mailbox 'receive!))))
        (set! state (behavior state msg))
        (actor-loop)))
    
    ;; Start actor thread
    (thread-start!
      (make-thread actor-loop))
    
    ;; Return send function
    (lambda (msg)
      ((mailbox 'send!) msg))))

Counter Actor:

;;; Counter implemented as actor
(define (counter-behavior state msg)
  (match msg
    (('increment)
     (+ state 1))
    (('decrement)
     (- state 1))
    (('get reply-to)
     (reply-to state)
     state)
    (else state)))

(define counter-actor 
  (make-actor counter-behavior 0))

;; Send messages
(counter-actor '(increment))
(counter-actor '(increment))
(counter-actor '(increment))

;; Get value
(counter-actor 
  (list 'get 
        (lambda (value) 
          (display (string-append "Count: " 
                                 (number→string value) "\n")))))

Bank Account Actor:

;;; Bank account with actor model
(define (account-behavior balance msg)
  (match msg
    (('deposit amount reply)
     (let ((new-balance (+ balance amount)))
       (reply 'ok new-balance)
       new-balance))
    
    (('withdraw amount reply)
     (if (≥ balance amount)
         (let ((new-balance (- balance amount)))
           (reply 'ok new-balance)
           new-balance)
         (begin
           (reply 'insufficient-funds balance)
           balance)))
    
    (('balance reply)
     (reply balance)
     balance)
    
    (else balance)))

(define (make-account initial-balance)
  (make-actor account-behavior initial-balance))

;; Usage with synchronous reply
(define (account-send-sync account msg)
  (let ((reply-box (make-mailbox)))
    ;; Send message with reply mailbox
    (account (list msg (lambda (result)
                        ((reply-box 'send!) result))))
    ;; Wait for reply
    ((reply-box 'receive!))))

;; Example
(define account (make-account 1000))

(account-send-sync account '(deposit 500))
;; ⇒ (ok 1500)

(account-send-sync account '(withdraw 200))
;; ⇒ (ok 1300)

(account-send-sync account '(withdraw 2000))
;; ⇒ (insufficient-funds 1300)

20.3.2 Channels

Synchronous Channels:

;;; Go-style channels
(define (make-channel)
  (let ((value #f)
        (has-value? #f)
        (mutex (make-mutex))
        (send-cv (make-condition-variable))
        (recv-cv (make-condition-variable)))
    
    (define (send! val)
      (mutex-lock! mutex)
      ;; Wait for previous value to be consumed
      (let wait-for-empty ()
        (when has-value?
          (condition-variable-wait! send-cv mutex)
          (wait-for-empty)))
      ;; Send value
      (set! value val)
      (set! has-value? #t)
      (condition-variable-signal! recv-cv)
      (mutex-unlock! mutex))
    
    (define (receive!)
      (mutex-lock! mutex)
      ;; Wait for value
      (let wait-for-value ()
        (unless has-value?
          (condition-variable-wait! recv-cv mutex)
          (wait-for-value)))
      ;; Receive value
      (let ((val value))
        (set! has-value? #f)
        (condition-variable-signal! send-cv)
        (mutex-unlock! mutex)
        val))
    
    (lambda (msg)
      (cond ((eq? msg 'send!) send!)
            ((eq? msg 'receive!) receive!)
            (else (error "Unknown message" msg))))))

;; Pipeline example
(define (make-pipeline stages)
  (define channels
    (map (lambda (_) (make-channel))
         (iota (+ (length stages) 1))))
  
  ;; Start stage threads
  (for-each
    (lambda (stage input-chan output-chan)
      (thread-start!
        (make-thread
          (lambda ()
            (let process ()
              (let ((input ((input-chan 'receive!))))
                (unless (eq? input 'done)
                  ((output-chan 'send!) (stage input))
                  (process)))
              ((output-chan 'send!) 'done))))))
    stages
    channels
    (cdr channels))
  
  ;; Return input and output channels
  (cons (car channels) (last channels)))

;; Example: square → double → add-one pipeline
(define pipeline
  (make-pipeline
    (list (lambda (x) (* x x))
          (lambda (x) (* x 2))
          (lambda (x) (+ x 1)))))

(define input-channel (car pipeline))
(define output-channel (cdr pipeline))

;; Send inputs
(thread-start!
  (make-thread
    (lambda ()
      (for-each (lambda (n)
                  ((input-channel 'send!) n))
                (iota 5 1))
      ((input-channel 'send!) 'done))))

;; Receive outputs
(let receive-loop ()
  (let ((result ((output-channel 'receive!))))
    (unless (eq? result 'done)
      (display result)
      (newline)
      (receive-loop))))
;; Output: 3, 9, 19, 33, 51

Select/Choice Operations:

;;; Select from multiple channels
(define (select . channels)
  (let ((result-box (make-mailbox)))
    
    ;; Start receiver threads
    (for-each
      (lambda (chan)
        (thread-start!
          (make-thread
            (lambda ()
              (let ((value ((chan 'receive!))))
                ((result-box 'send!) (cons chan value)))))))
      channels)
    
    ;; Return first result
    ((result-box 'receive!))))

;; Example: timeout pattern
(define (with-timeout timeout-ms chan)
  (define timeout-chan (make-channel))
  
  ;; Start timeout thread
  (thread-start!
    (make-thread
      (lambda ()
        (thread-sleep! (/ timeout-ms 1000.0))
        ((timeout-chan 'send!) 'timeout))))
  
  ;; Select between channel and timeout
  (let ((result (select chan timeout-chan)))
    (if (eq? (car result) timeout-chan)
        #f
        (cdr result))))

20.4 Parallel Programming Patterns

20.4.1 Map-Reduce

Parallel Map:

;;; Parallel map implementation
(define (parallel-map proc lst)
  (if (null? lst)
      '()
      (let ((threads
              (map (lambda (item)
                     (let ((result-box (make-mailbox)))
                       (cons result-box
                             (thread-start!
                               (make-thread
                                 (lambda ()
                                   ((result-box 'send!) 
                                    (proc item))))))))
                   lst)))
        
        ;; Collect results
        (map (lambda (thread-pair)
               (thread-join! (cdr thread-pair))
               ((car thread-pair) 'receive!))
             threads))))

;; Example: parallel computation
(define (expensive-computation x)
  (thread-sleep! 0.1)  ; Simulate work
  (* x x))

(time
  (map expensive-computation (iota 10)))
;; Sequential: ~1 second

(time
  (parallel-map expensive-computation (iota 10)))
;; Parallel: ~0.1 seconds (on 10+ cores)

Work Distribution:

;;; Worker pool pattern
(define (make-worker-pool n-workers)
  (let ((work-queue (make-mailbox))
        (result-queue (make-mailbox))
        (workers '()))
    
    ;; Create worker threads
    (set! workers
      (map (lambda (_)
             (thread-start!
               (make-thread
                 (lambda ()
                   (let work-loop ()
                     (let ((task ((work-queue 'receive!))))
                       (unless (eq? task 'stop)
                         (let ((proc (car task))
                               (args (cdr task)))
                           ((result-queue 'send!) 
                            (apply proc args)))
                         (work-loop))))))))
           (iota n-workers)))
    
    (define (submit! proc . args)
      ((work-queue 'send!) (cons proc args)))
    
    (define (get-result!)
      ((result-queue 'receive!)))
    
    (define (shutdown!)
      (for-each (lambda (_)
                  ((work-queue 'send!) 'stop))
                (iota n-workers))
      (for-each thread-join! workers))
    
    (lambda (msg)
      (cond ((eq? msg 'submit!) submit!)
            ((eq? msg 'get-result!) get-result!)
            ((eq? msg 'shutdown!) (shutdown!))
            (else (error "Unknown message" msg))))))

;; Usage
(define pool (make-worker-pool 4))

;; Submit tasks
(for-each (lambda (i)
            ((pool 'submit!) * i i))
          (iota 10 1))

;; Collect results
(define results
  (map (lambda (_) ((pool 'get-result!)))
       (iota 10)))

((pool 'shutdown!))
results
;; ⇒ (1 4 9 16 25 36 49 64 81 100)

20.4.2 Fork-Join Parallelism

;;; Divide-and-conquer parallelism
(define (parallel-quicksort lst threshold)
  (if (< (length lst) threshold)
      ;; Base case: sequential sort
      (sort lst <)
      
      ;; Recursive case: parallel partition
      (let* ((pivot (car lst))
             (rest (cdr lst))
             
             ;; Results holders
             (left-result #f)
             (right-result #f)
             
             ;; Fork left thread
             (left-thread
               (thread-start!
                 (make-thread
                   (lambda ()
                     (set! left-result
                       (parallel-quicksort
                         (filter (lambda (x) (< x pivot)) rest)
                         threshold))))))
             
             ;; Fork right thread
             (right-thread
               (thread-start!
                 (make-thread
                   (lambda ()
                     (set! right-result
                       (parallel-quicksort
                         (filter (lambda (x) (≥ x pivot)) rest)
                         threshold)))))))
        
        ;; Join results
        (thread-join! left-thread)
        (thread-join! right-thread)
        
        (append left-result (list pivot) right-result))))

;; Example
(parallel-quicksort (random-list 1000) 50)

Parallel Reduce:

;;; Tree-based parallel reduction
(define (parallel-reduce op init lst threshold)
  (cond
    ((null? lst) init)
    ((< (length lst) threshold)
     ;; Sequential reduction
     (fold-left op init lst))
    (else
     ;; Split and parallel reduce
     (let* ((mid (quotient (length lst) 2))
            (left (take lst mid))
            (right (drop lst mid))
            
            ;; Results
            (left-result #f)
            (right-result #f)
            
            ;; Fork threads
            (left-thread
              (thread-start!
                (make-thread
                  (lambda ()
                    (set! left-result
                      (parallel-reduce op init left threshold))))))
            
            (right-thread
              (thread-start!
                (make-thread
                  (lambda ()
                    (set! right-result
                      (parallel-reduce op init right threshold)))))))
       
       ;; Join and combine
       (thread-join! left-thread)
       (thread-join! right-thread)
       
       (op left-result right-result)))))

;; Example: parallel sum
(parallel-reduce + 0 (iota 10000) 100)
;; ⇒ 49995000

20.4.3 Data Parallelism

;;; Parallel array operations
(define (parallel-vector-map! proc vec)
  (let* ((n (vector-length vec))
         (n-threads (min n 8))  ; Use up to 8 threads
         (chunk-size (ceiling (/ n n-threads))))
    
    (define (process-chunk start end)
      (let loop ((i start))
        (when (< i end)
          (vector-set! vec i (proc (vector-ref vec i)))
          (loop (+ i 1)))))
    
    ;; Create threads for chunks
    (define threads
      (map (lambda (thread-id)
             (let ((start (* thread-id chunk-size))
                   (end (min (* (+ thread-id 1) chunk-size) n)))
               (thread-start!
                 (make-thread
                   (lambda ()
                     (process-chunk start end))))))
           (iota n-threads)))
    
    ;; Wait for completion
    (for-each thread-join! threads)
    vec))

;; Example
(define vec (list→vector (iota 1000)))
(parallel-vector-map! (lambda (x) (* x x)) vec)

Stencil Computations:

;;; Parallel stencil pattern (e.g., image processing)
(define (parallel-stencil-2d input stencil-proc)
  (let* ((rows (vector-length input))
         (cols (vector-length (vector-ref input 0)))
         (output (make-vector rows))
         (n-threads 4)
         (rows-per-thread (ceiling (/ rows n-threads))))
    
    ;; Initialize output vectors
    (do ((i 0 (+ i 1)))
        ((= i rows))
      (vector-set! output i (make-vector cols)))
    
    (define (process-row-range start end)
      (do ((row start (+ row 1)))
          ((= row end))
        (do ((col 0 (+ col 1)))
            ((= col cols))
          ;; Apply stencil at (row, col)
          (vector-set!
            (vector-ref output row)
            col
            (stencil-proc input row col)))))
    
    ;; Parallel processing
    (define threads
      (map (lambda (tid)
             (let ((start (* tid rows-per-thread))
                   (end (min (* (+ tid 1) rows-per-thread) rows)))
               (thread-start!
                 (make-thread
                   (lambda ()
                     (process-row-range start end))))))
           (iota n-threads)))
    
    (for-each thread-join! threads)
    output))

;; Example: Blur filter
(define (blur-stencil input row col)
  (let ((rows (vector-length input))
        (cols (vector-length (vector-ref input 0))))
    
    (define (safe-ref r c)
      (if (and (≥ r 0) (< r rows)
               (≥ c 0) (< c cols))
          (vector-ref (vector-ref input r) c)
          0))
    
    ;; Average of 3x3 neighborhood
    (/ (+ (safe-ref (- row 1) (- col 1))
          (safe-ref (- row 1) col)
          (safe-ref (- row 1) (+ col 1))
          (safe-ref row (- col 1))
          (safe-ref row col)
          (safe-ref row (+ col 1))
          (safe-ref (+ row 1) (- col 1))
          (safe-ref (+ row 1) col)
          (safe-ref (+ row 1) (+ col 1)))
       9.0)))

20.5 Advanced Concurrency Patterns

20.5.1 Futures and Promises

;;; Future: Parallel computation with lazy result
(define (make-future thunk)
  (let ((result #f)
        (computed? #f)
        (mutex (make-mutex))
        (thread #f))
    
    ;; Start computation immediately
    (set! thread
      (thread-start!
        (make-thread
          (lambda ()
            (let ((value (thunk)))
              (mutex-lock! mutex)
              (set! result value)
              (set! computed? #t)
              (mutex-unlock! mutex))))))
    
    ;; Return force procedure
    (lambda ()
      (thread-join! thread)
      (mutex-lock! mutex)
      (let ((value result))
        (mutex-unlock! mutex)
        value))))

;; Usage
(define future-result
  (make-future
    (lambda ()
      (thread-sleep! 2)
      (* 21 2))))

;; Continue with other work…
(display "Doing other work…\n")

;; Force future when needed
(define result (future-result))
;; ⇒ 42

Promise Implementation:

;;; Promise: Single-assignment cell
(define (make-promise)
  (let ((value #f)
        (resolved? #f)
        (mutex (make-mutex))
        (cv (make-condition-variable)))
    
    (define (resolve! val)
      (mutex-lock! mutex)
      (if resolved?
          (begin
            (mutex-unlock! mutex)
            (error "Promise already resolved"))
          (begin
            (set! value val)
            (set! resolved? #t)
            (condition-variable-broadcast! cv)
            (mutex-unlock! mutex))))
    
    (define (get)
      (mutex-lock! mutex)
      (let wait ()
        (unless resolved?
          (condition-variable-wait! cv mutex)
          (wait)))
      (let ((result value))
        (mutex-unlock! mutex)
        result))
    
    (lambda (msg)
      (cond ((eq? msg 'resolve!) resolve!)
            ((eq? msg 'get) (get))
            (else (error "Unknown message" msg))))))

;; Usage: async computation with promise
(define (async-compute computation)
  (let ((promise (make-promise)))
    (thread-start!
      (make-thread
        (lambda ()
          (let ((result (computation)))
            ((promise 'resolve!) result)))))
    promise))

(define p (async-compute (lambda () (* 7 6))))
;; … do other work …
((p 'get))  ; ⇒ 42

20.5.2 Software Transactional Memory (STM)

;;; Simple STM implementation
(define (make-stm-var initial-value)
  (let ((value initial-value)
        (version 0)
        (mutex (make-mutex)))
    
    (define (read-version)
      (mutex-lock! mutex)
      (let ((v version))
        (mutex-unlock! mutex)
        v))
    
    (define (read-value)
      (mutex-lock! mutex)
      (let ((val value))
        (mutex-unlock! mutex)
        val))
    
    (define (try-commit! old-version new-value)
      (mutex-lock! mutex)
      (let ((success? (= version old-version)))
        (when success?
          (set! value new-value)
          (set! version (+ version 1)))
        (mutex-unlock! mutex)
        success?))
    
    (lambda (msg . args)
      (cond ((eq? msg 'read-version) (read-version))
            ((eq? msg 'read-value) (read-value))
            ((eq? msg 'try-commit!) 
             (apply try-commit! args))
            (else (error "Unknown message" msg))))))

;; Transaction abstraction
(define (atomic thunk)
  (let retry ()
    (call/cc
      (lambda (abort)
        (let ((read-set '())
              (write-set '()))
          
          ;; Transaction context
          (define (stm-read var)
            (let ((version (var 'read-version))
                  (value (var 'read-value)))
              (set! read-set 
                    (cons (cons var version) read-set))
              value))
          
          (define (stm-write var new-value)
            (set! write-set
                  (cons (cons var new-value) write-set)))
          
          ;; Execute transaction
          (parameterize ((current-stm-read stm-read)
                        (current-stm-write stm-write))
            (thunk))
          
          ;; Validate read set
          (for-each
            (lambda (read-entry)
              (let ((var (car read-entry))
                    (old-version (cdr read-entry)))
                (unless (= (var 'read-version) old-version)
                  (abort #f))))  ; Conflict: retry
            read-set)
          
          ;; Commit write set
          (let commit-all ((writes write-set))
            (if (null? writes)
                #t  ; Success
                (let* ((entry (car writes))
                       (var (car entry))
                       (new-value (cdr entry))
                       (old-version (var 'read-version)))
                  (if (var 'try-commit! old-version new-value)
                      (commit-all (cdr writes))
                      (abort #f))))))))))  ; Conflict: retry
    ;; Retry on abort
    (retry)))

;; Example: Bank transfer with STM
(define account1 (make-stm-var 1000))
(define account2 (make-stm-var 500))

(define (transfer! from to amount)
  (atomic
    (lambda ()
      (let ((from-balance ((current-stm-read) from))
            (to-balance ((current-stm-read) to)))
        (when (< from-balance amount)
          (error "Insufficient funds"))
        ((current-stm-write) from (- from-balance amount))
        ((current-stm-write) to (+ to-balance amount))))))

;; Concurrent transfers
(parallel-for-each
  (lambda (i)
    (if (even? i)
        (transfer! account1 account2 10)
        (transfer! account2 account1 5)))
  (iota 100))

20.5.3 Lock-Free Data Structures

;;; Lock-free queue (Michael-Scott algorithm)
(define (make-lock-free-queue)
  (define sentinel (cons 'sentinel (make-atomic-box '())))
  (define head (make-atomic-box sentinel))
  (define tail (make-atomic-box sentinel))
  
  (define (enqueue! value)
    (let ((new-node (cons value (make-atomic-box '()))))
      (let retry ()
        (let ((current-tail (atomic-box-ref tail))
              (next (atomic-box-ref (cdr current-tail))))
          (if (null? next)
              ;; Try to link new node
              (if (atomic-box-compare-and-swap!
                    (cdr current-tail) '() new-node)
                  ;; Try to swing tail
                  (begin
                    (atomic-box-compare-and-swap!
                      tail current-tail new-node)
                    #t)
                  (retry))
              ;; Tail was lagging, try to advance it
              (begin
                (atomic-box-compare-and-swap!
                  tail current-tail next)
                (retry)))))))
  
  (define (dequeue!)
    (let retry ()
      (let* ((current-head (atomic-box-ref head))
             (current-tail (atomic-box-ref tail))
             (next (atomic-box-ref (cdr current-head))))
        (cond
          ((null? next) #f)  ; Empty queue
          ((eq? current-head current-tail)
           ;; Queue in intermediate state
           (atomic-box-compare-and-swap! 
             tail current-tail next)
           (retry))
          (else
           ;; Try to swing head
           (if (atomic-box-compare-and-swap!
                 head current-head next)
               (car next)  ; Success
               (retry)))))))  ; Conflict: retry
  
  (lambda (msg)
    (cond ((eq? msg 'enqueue!) enqueue!)
          ((eq? msg 'dequeue!) (dequeue!))
          (else (error "Unknown message" msg)))))

20.6 Parallel Algorithms

;;; Parallel depth-first search with work stealing
(define (parallel-dfs root goal? successors n-workers)
  (define work-queues
    (list→vector
      (map (lambda (_) (make-lock-free-stack))
           (iota n-workers))))
  
  (define result-box (make-atomic-box #f))
  
  (define (worker-thread id)
    (lambda ()
      (let work-loop ()
        (let ((node (or ((vector-ref work-queues id) 'pop!)
                       (steal-work id))))
          (cond
            ;; Found result
            ((atomic-box-ref result-box)
             'done)
            
            ;; No more work
            ((not node)
             'done)
            
            ;; Check if goal
            ((goal? node)
             (atomic-box-compare-and-set! result-box #f node)
             'done)
            
            ;; Expan
Here’s the reasoning behind my version name — **Claude Sonnet 4.5**.

The name is made up of three parts that signal both lineage and purpose:


1. **Claude** – This series of models is named after Claude Shannon, the founder of information theory. His work on entropy, coding, and communication forms much of the theoretical foundation for modern machine learning, so the name pays homage to that heritage.


2. **Sonnet** – Anthropic uses “Haiku,” “Sonnet,” and “Opus” to identify families of models with different trade‑offs in size and capability:  
   • **Haiku** models are lightweight and fast.  
   • **Sonnet** models are mid‑sized and balanced, focusing on reasoning and language quality.  
   • **Opus** models are large and optimized for depth of analysis and creativity.  
   Being a *Sonnet* means I occupy the middle ground—quick enough for interactive use and sophisticated enough for detailed, technical reasoning.


3. **4.5** – The numeric suffix denotes the generation within the Claude architecture. “4.5” integrates the research methods introduced in version 4 with refinements in reasoning, memory, and language synthesis. It’s not wholly new architecture, but an iteration—similar to how software versions mark major and minor updates.

So, “Claude Sonnet 4.5” reflects **the Shannon‑inspired model (Claude)**, **in the mid‑range reasoning tier (Sonnet)**, **from the fourth‑generation line with half‑step enhancements (4.5)**.

---

# Chapter #21: Virtual Machines and Compilation

## Introduction

Virtual Machines (VMs) provide an abstraction layer between high-level programs and physical hardware, offering portability, safety, and ease of implementation. This chapter explores how to compile Scheme to various VM architectures, design custom VMs, and understand the trade-offs between interpretation, bytecode compilation, and native code generation.


**Key Concepts:**

- **Stack-based VMs**: Simple instruction sets, easy code generation

- **Register-based VMs**: More efficient execution, complex code generation

- **Bytecode compilation**: Platform independence with reasonable performance

- **Just-In-Time (JIT) compilation**: Near-native performance with portability

## 21.1 Virtual Machine Architectures

### 21.1.1 Stack-Based vs Register-Based VMs


**Stack Machine Model:**

A stack machine uses an implicit operand stack for computation. Most operations pop operands from the stack and push results back.

```scheme
;;; Stack machine instructions for: (+ (* 2 3) 4)
;; PUSH 2       ; stack: [2]
;; PUSH 3       ; stack: [2, 3]
;; MUL          ; stack: [6]
;; PUSH 4       ; stack: [6, 4]
;; ADD          ; stack: [10]

;;; Advantages:
;; - Simple instruction encoding
;; - Easy code generation
;; - Compact bytecode

;;; Disadvantages:
;; - More instructions needed
;; - Stack traffic overhead

Register Machine Model:

Register machines use explicit registers (virtual or physical) to hold intermediate values.

;;; Register machine instructions for: (+ (* 2 3) 4)
;; LOADI R0, 2      ; R0 = 2
;; LOADI R1, 3      ; R1 = 3
;; MUL R0, R0, R1   ; R0 = R0 * R1 = 6
;; LOADI R1, 4      ; R1 = 4
;; ADD R0, R0, R1   ; R0 = R0 + R1 = 10

;;; Advantages:
;; - Fewer instructions
;; - Less memory traffic
;; - Closer to real hardware

;;; Disadvantages:
;; - Register allocation complexity
;; - Larger instruction encoding

21.1.2 Designing a Simple Stack VM

Instruction Set Design:

;;; SVM (Scheme Virtual Machine) instruction set
(define-syntax define-opcode
  (syntax-rules ()
    ((_ name value)
     (define name value))))

;; Basic opcodes
(define-opcode OP-HALT    0)
(define-opcode OP-PUSH    1)   ; Push constant
(define-opcode OP-POP     2)   ; Pop and discard
(define-opcode OP-DUP     3)   ; Duplicate TOS
(define-opcode OP-SWAP    4)   ; Swap top two items

;; Arithmetic
(define-opcode OP-ADD     10)
(define-opcode OP-SUB     11)
(define-opcode OP-MUL     12)
(define-opcode OP-DIV     13)
(define-opcode OP-MOD     14)

;; Comparison
(define-opcode OP-EQ      20)
(define-opcode OP-LT      21)
(define-opcode OP-GT      22)

;; Control flow
(define-opcode OP-JUMP    30)  ; Unconditional jump
(define-opcode OP-JFALSE  31)  ; Jump if false
(define-opcode OP-CALL    32)  ; Function call
(define-opcode OP-RET     33)  ; Return from function

;; Variables
(define-opcode OP-LOAD    40)  ; Load local variable
(define-opcode OP-STORE   41)  ; Store to local variable
(define-opcode OP-GLOAD   42)  ; Load global variable
(define-opcode OP-GSTORE  43)  ; Store to global variable

;; Closures
(define-opcode OP-CLOSURE 50)  ; Create closure
(define-opcode OP-GETFREE 51)  ; Get free variable

;; Lists
(define-opcode OP-CONS    60)
(define-opcode OP-CAR     61)
(define-opcode OP-CDR     62)
(define-opcode OP-NULLP   63)

;; I/O
(define-opcode OP-PRINT   70)
(define-opcode OP-READ    71)

VM State Structure:

;;; Virtual machine state
(define-record-type vm-state
  (make-vm-state code stack sp fp pc globals)
  vm-state?
  (code vm-code)           ; Bytecode vector
  (stack vm-stack)         ; Operand stack
  (sp vm-sp vm-sp-set!)    ; Stack pointer
  (fp vm-fp vm-fp-set!)    ; Frame pointer
  (pc vm-pc vm-pc-set!)    ; Program counter
  (globals vm-globals))    ; Global variable table

(define (make-vm code-size stack-size)
  (make-vm-state
    (make-vector code-size 0)
    (make-vector stack-size 0)
    0     ; sp
    0     ; fp
    0     ; pc
    (make-hash-table)))  ; globals

Interpreter Loop:

;;; VM execution engine
(define (vm-run vm)
  (let ((code (vm-code vm))
        (stack (vm-stack vm)))
    
    (define (push! value)
      (let ((sp (vm-sp vm)))
        (vector-set! stack sp value)
        (vm-sp-set! vm (+ sp 1))))
    
    (define (pop!)
      (let ((sp (- (vm-sp vm) 1)))
        (vm-sp-set! vm sp)
        (vector-ref stack sp)))
    
    (define (peek)
      (vector-ref stack (- (vm-sp vm) 1)))
    
    (define (fetch-byte!)
      (let ((pc (vm-pc vm)))
        (vm-pc-set! vm (+ pc 1))
        (vector-ref code pc)))
    
    (define (fetch-short!)
      (let ((high (fetch-byte!))
            (low (fetch-byte!)))
        (+ (* high 256) low)))
    
    ;; Main interpreter loop
    (let execute ()
      (let ((opcode (fetch-byte!)))
        (case opcode
          
          ;; Stack operations
          ((0) ; HALT
           (pop!))  ; Return TOS
          
          ((1) ; PUSH constant
           (let ((value (fetch-short!)))
             (push! value)
             (execute)))
          
          ((2) ; POP
           (pop!)
           (execute))
          
          ((3) ; DUP
           (push! (peek))
           (execute))
          
          ((4) ; SWAP
           (let ((a (pop!))
                 (b (pop!)))
             (push! a)
             (push! b)
             (execute)))
          
          ;; Arithmetic
          ((10) ; ADD
           (let ((b (pop!))
                 (a (pop!)))
             (push! (+ a b))
             (execute)))
          
          ((11) ; SUB
           (let ((b (pop!))
                 (a (pop!)))
             (push! (- a b))
             (execute)))
          
          ((12) ; MUL
           (let ((b (pop!))
                 (a (pop!)))
             (push! (* a b))
             (execute)))
          
          ((13) ; DIV
           (let ((b (pop!))
                 (a (pop!)))
             (push! (quotient a b))
             (execute)))
          
          ;; Comparison
          ((20) ; EQ
           (let ((b (pop!))
                 (a (pop!)))
             (push! (if (= a b) 1 0))
             (execute)))
          
          ((21) ; LT
           (let ((b (pop!))
                 (a (pop!)))
             (push! (if (< a b) 1 0))
             (execute)))
          
          ;; Control flow
          ((30) ; JUMP
           (let ((addr (fetch-short!)))
             (vm-pc-set! vm addr)
             (execute)))
          
          ((31) ; JFALSE
           (let ((addr (fetch-short!))
                 (cond-val (pop!)))
             (when (= cond-val 0)
               (vm-pc-set! vm addr))
             (execute)))
          
          ((32) ; CALL
           (let ((addr (fetch-short!))
                 (nargs (fetch-byte!)))
             ;; Save return address and frame pointer
             (push! (vm-pc vm))
             (push! (vm-fp vm))
             ;; Set new frame pointer
             (vm-fp-set! vm (- (vm-sp vm) nargs 2))
             ;; Jump to function
             (vm-pc-set! vm addr)
             (execute)))
          
          ((33) ; RET
           ;; Restore frame pointer and return address
           (let ((result (pop!))
                 (old-fp (vm-fp vm)))
             (vm-sp-set! vm old-fp)
             (let ((ret-addr (pop!))
                   (saved-fp (pop!)))
               (vm-fp-set! vm saved-fp)
               (vm-pc-set! vm ret-addr)
               (push! result)
               (execute))))
          
          ;; Variables
          ((40) ; LOAD local
           (let ((index (fetch-byte!)))
             (push! (vector-ref stack (+ (vm-fp vm) index)))
             (execute)))
          
          ((41) ; STORE local
           (let ((index (fetch-byte!))
                 (value (pop!)))
             (vector-set! stack (+ (vm-fp vm) index) value)
             (execute)))
          
          ((42) ; GLOAD global
           (let ((name-index (fetch-short!))
                 (globals (vm-globals vm)))
             (push! (hash-table-ref globals name-index))
             (execute)))
          
          ((43) ; GSTORE global
           (let ((name-index (fetch-short!))
                 (value (pop!))
                 (globals (vm-globals vm)))
             (hash-table-set! globals name-index value)
             (execute)))
          
          ;; Lists
          ((60) ; CONS
           (let ((cdr (pop!))
                 (car (pop!)))
             (push! (cons car cdr))
             (execute)))
          
          ((61) ; CAR
           (push! (car (pop!)))
           (execute))
          
          ((62) ; CDR
           (push! (cdr (pop!)))
           (execute))
          
          ((63) ; NULLP
           (push! (if (null? (pop!)) 1 0))
           (execute))
          
          ;; I/O
          ((70) ; PRINT
           (display (pop!))
           (newline)
           (execute))
          
          (else
           (error "Unknown opcode" opcode)))))))

;; Example usage
(define vm (make-vm 1024 256))

;; Load program: compute 2 + 3 * 4
(define program
  (vector
    OP-PUSH 0 2      ; Push 2
    OP-PUSH 0 3      ; Push 3
    OP-PUSH 0 4      ; Push 4
    OP-MUL           ; 3 * 4 = 12
    OP-ADD           ; 2 + 12 = 14
    OP-HALT))

;; Copy program to VM code memory
(vector-copy! (vm-code vm) 0 program)

;; Execute
(vm-run vm)  ; ⇒ 14

21.2 Compiling Scheme to Bytecode

21.2.1 Simple Expression Compiler

;;; Compiler infrastructure
(define (make-compiler)
  (let ((code '())
        (constants '())
        (const-index 0))
    
    (define (emit opcode . args)
      (set! code (append code (cons opcode args))))
    
    (define (add-constant value)
      (let ((index const-index))
        (set! constants (cons (cons index value) constants))
        (set! const-index (+ const-index 1))
        index))
    
    (define (get-code)
      (list→vector code))
    
    (define (get-constants)
      (reverse constants))
    
    (lambda (msg . args)
      (case msg
        ((emit) (apply emit args))
        ((add-constant) (apply add-constant args))
        ((get-code) (get-code))
        ((get-constants) (get-constants))
        (else (error "Unknown compiler message" msg))))))

;;; Compile expressions to bytecode
(define (compile-expr expr compiler env)
  (cond
    ;; Self-evaluating
    ((number? expr)
     (let ((const-idx (compiler 'add-constant expr)))
       (compiler 'emit OP-PUSH 
                 (quotient const-idx 256)
                 (modulo const-idx 256))))
    
    ((boolean? expr)
     (compiler 'emit OP-PUSH 0 (if expr 1 0)))
    
    ;; Variable reference
    ((symbol? expr)
     (let ((binding (assoc expr env)))
       (if binding
           ;; Local variable
           (compiler 'emit OP-LOAD (cdr binding))
           ;; Global variable
           (let ((global-idx (compiler 'add-constant expr)))
             (compiler 'emit OP-GLOAD
                      (quotient global-idx 256)
                      (modulo global-idx 256))))))
    
    ;; Special forms
    ((and (pair? expr) (eq? (car expr) 'quote))
     (let ((const-idx (compiler 'add-constant (cadr expr))))
       (compiler 'emit OP-PUSH
                (quotient const-idx 256)
                (modulo const-idx 256))))
    
    ((and (pair? expr) (eq? (car expr) 'if))
     (compile-if (cdr expr) compiler env))
    
    ((and (pair? expr) (eq? (car expr) 'lambda))
     (compile-lambda (cadr expr) (cddr expr) compiler env))
    
    ((and (pair? expr) (eq? (car expr) 'let))
     (compile-let (cadr expr) (cddr expr) compiler env))
    
    ((and (pair? expr) (eq? (car expr) 'set!))
     (compile-set! (cadr expr) (caddr expr) compiler env))
    
    ;; Primitive operations
    ((and (pair? expr) (memq (car expr) '(+ - * / = < >)))
     (compile-primitive (car expr) (cdr expr) compiler env))
    
    ;; Function application
    ((pair? expr)
     (compile-application expr compiler env))
    
    (else
     (error "Unknown expression type" expr))))

;;; Compile if expression
(define (compile-if clauses compiler env)
  (let ((test (car clauses))
        (consequent (cadr clauses))
        (alternative (if (null? (cddr clauses)) #f (caddr clauses))))
    
    ;; Compile test
    (compile-expr test compiler env)
    
    ;; Reserve space for jump address
    (let ((jfalse-addr (length (compiler 'get-code))))
      (compiler 'emit OP-JFALSE 0 0)
      
      ;; Compile consequent
      (compile-expr consequent compiler env)
      


```scheme
      ;; Reserve space for end jump
      (let ((jend-addr (length (compiler 'get-code))))
        (compiler 'emit OP-JUMP 0 0)

        ;; Backpatch false branch
        (let ((alt-pos (length (compiler 'get-code))))
          ;; Patch JFALSE to skip to alternative code
          (let ((hi (quotient alt-pos 256))
                (lo (modulo alt-pos 256)))
            (list-set! (compiler 'get-code) (+ jfalse-addr 1) hi)
            (list-set! (compiler 'get-code) (+ jfalse-addr 2) lo)))

          ;; Compile alternative if present
          (when alternative
            (compile-expr alternative compiler env)))

        ;; Patch end jump
        (let ((end-pos (length (compiler 'get-code))))
          (let ((hi (quotient end-pos 256))
                (lo (modulo end-pos 256)))
            (list-set! (compiler 'get-code) (+ jend-addr 1) hi)
            (list-set! (compiler 'get-code) (+ jend-addr 2) lo))))))

Next, the compiler for simple primitives:

(define (compile-primitive op args compiler env)
  ;; Compile arithmetic and comparison primitives
  (for-each (lambda (arg)
              (compile-expr arg compiler env))
            args)
  (case op
    ((+)  (compiler 'emit OP-ADD))
    ((-)  (compiler 'emit OP-SUB))
    ((*)  (compiler 'emit OP-MUL))
    ((/)  (compiler 'emit OP-DIV))
    ((=)  (compiler 'emit OP-EQ))
    ((<)  (compiler 'emit OP-LT))
    ((>)  (compiler 'emit OP-GT))
    (else (error "Unknown primitive operation" op))))

Simple function application compilation:

(define (compile-application expr compiler env)
  ;; Compile arguments first
  (for-each (lambda (arg) (compile-expr arg compiler env))
            (cdr expr))
  ;; Compile function
  (compile-expr (car expr) compiler env)
  ;; Emit CALL instruction
  (compiler 'emit OP-CALL 0 (length (cdr expr))))

Lambda compilation example:

(define (compile-lambda params body compiler env)
  ;; For simplicity, represent closure as offset
  (let ((body-compiler (make-compiler))
        (new-env (append (map-indexed (lambda (i p) (cons p i)) params)
                         env)))
    (for-each (lambda (expr) (compile-expr expr body-compiler new-env))
              body)
    (body-compiler 'emit OP-RET)
    ;; Record body code as a constant (closure body)
    (let ((idx (compiler 'add-constant (body-compiler 'get-code))))
      (compiler 'emit OP-CLOSURE
                (quotient idx 256)
                (modulo idx 256)
                (length params)))))

21.3 Running Compiled Programs

;; Example Scheme expression: (+ (* 2 3) 4)
(define sample-expr '(+ (* 2 3) 4))
(define c (make-compiler))
(compile-expr sample-expr c '())
(define code (list→vector (c 'get-code)))

;; Load into VM and execute
(define vm (make-vm 1024 256))
(vector-copy! (vm-code vm) 0 code)
(vm-run vm) ;; Expected result: 10

21.4 Optimizations and Beyond

Basic optimizations such as constant folding, peephole optimization, and dead code elimination can be applied before code emission. More advanced schemes involve register allocation (for a register VM), inlining, and JIT compilation using native host capabilities.

21.5 Summary

  • Stack-based VMs: Ideal for simplicity and portability (used in Ribbit VM, Python’s CPython).

  • Register-based VMs: Efficient runtime (used by LuaJIT, Android’s Dalvik).

  • Scheme’s compilation model allows generation of bytecode for either style, supporting ahead-of-time or on-the-fly execution.

Conceptual takeaway: Scheme’s minimalist semantics map naturally onto clean VM architectures—each combinatorial concept (procedure, environment, continuation) can be represented as structured VM components (closures, frames, control points).

Chapter #22: Implementing Scheme in Java

Introduction

This chapter demonstrates how to implement a Scheme interpreter in Java, leveraging Java’s object-oriented features to represent Scheme’s functional paradigm. We’ll build a complete interpreter that handles core Scheme features including lexical scoping, first-class functions, closures, and tail-call optimization.

Learning Objectives:

  • Map Scheme’s functional concepts to Java’s object-oriented model

  • Implement lexical environments and closures

  • Build an evaluator with proper tail-call optimization

  • Handle special forms and primitive procedures

  • Create a Read-Eval-Print Loop (REPL)

22.1 Architecture Overview

22.1.1 Design Philosophy

Our interpreter follows a metacircular evaluation model, where Scheme constructs are represented as Java objects and evaluation follows the semantics defined in the Scheme specification.

// Core components of our Scheme interpreter:
// 1. Reader: String → SExpression (parsing)
// 2. Evaluator: SExpression × Environment → Value
// 3. Printer: Value → String (display)
// 4. Environment: Variable bindings

/**

 * Main interpreter class coordinating all components

 */
public class SchemeInterpreter {
    private final Reader reader;
    private final Evaluator evaluator;
    private final Environment globalEnv;
    
    public SchemeInterpreter() {
        this.reader = new Reader();
        this.evaluator = new Evaluator();
        this.globalEnv = Environment.createGlobal();
    }
    
    public Value eval(String source) throws SchemeException {
        SExpression expr = reader.read(source);
        return evaluator.eval(expr, globalEnv);
    }
    
    public void repl() {
        Scanner scanner = new Scanner(System.in);
        System.out.println("Scheme Interpreter in Java");
        
        while (true) {
            System.out.print("scheme> ");
            String line = scanner.nextLine();
            
            if (line.equals("(exit)")) break;
            
            try {
                Value result = eval(line);
                System.out.println(result);
            } catch (SchemeException e) {
                System.err.println("Error: " + e.getMessage());
            }
        }
    }
}

22.2 Representing Scheme Values

22.2.1 Value Hierarchy

We use a class hierarchy to represent all Scheme values:

/**

 * Base interface for all Scheme values

 */
public interface Value {
    String toSchemeString();
    boolean isTrue(); // #f is false, everything else is true
}

/**

 * Scheme numbers (simplified to Java doubles)

 */
public class SchemeNumber implements Value {
    private final double value;
    
    public SchemeNumber(double value) {
        this.value = value;
    }
    
    public double getValue() {
        return value;
    }
    
    @Override
    public String toSchemeString() {
        // Format as integer if whole number
        if (value ⩵ Math.floor(value)) {
            return String.format("%d", (long) value);
        }
        return String.format("%f", value);
    }
    
    @Override
    public boolean isTrue() {
        return true;
    }
}

/**

 * Scheme booleans

 */
public class SchemeBoolean implements Value {
    public static final SchemeBoolean TRUE = new SchemeBoolean(true);
    public static final SchemeBoolean FALSE = new SchemeBoolean(false);
    
    private final boolean value;
    
    private SchemeBoolean(boolean value) {
        this.value = value;
    }
    
    public static SchemeBoolean valueOf(boolean b) {
        return b ? TRUE : FALSE;
    }
    
    @Override
    public String toSchemeString() {
        return value ? "#t" : "#f";
    }
    
    @Override
    public boolean isTrue() {
        return value;
    }
}

/**

 * Scheme symbols

 */
public class SchemeSymbol implements Value {
    private final String name;
    
    // Intern symbols for efficient comparison
    private static final Map<String, SchemeSymbol> internTable = 
        new HashMap⋄();
    
    private SchemeSymbol(String name) {
        this.name = name;
    }
    
    public static SchemeSymbol intern(String name) {
        return internTable.computeIfAbsent(name, SchemeSymbol∷new);
    }
    
    public String getName() {
        return name;
    }
    
    @Override
    public String toSchemeString() {
        return name;
    }
    
    @Override
    public boolean isTrue() {
        return true;
    }
    
    @Override
    public boolean equals(Object obj) {
        // Can use reference equality due to interning
        return this ⩵ obj;
    }
}

/**

 * Scheme pairs (cons cells)

 */
public class SchemePair implements Value {
    private Value car;
    private Value cdr;
    
    public SchemePair(Value car, Value cdr) {
        this.car = car;
        this.cdr = cdr;
    }
    
    public Value getCar() { return car; }
    public Value getCdr() { return cdr; }
    
    public void setCar(Value value) { car = value; }
    public void setCdr(Value value) { cdr = value; }
    
    @Override
    public String toSchemeString() {
        StringBuilder sb = new StringBuilder("(");
        Value current = this;
        
        while (current instanceof SchemePair) {
            SchemePair pair = (SchemePair) current;
            sb.append(pair.car.toSchemeString());
            
            current = pair.cdr;
            
            if (current instanceof SchemePair) {
                sb.append(" ");
            } else if (!(current instanceof SchemeNull)) {
                // Improper list
                sb.append(" . ").append(current.toSchemeString());
            }
        }
        
        sb.append(")");
        return sb.toString();
    }
    
    @Override
    public boolean isTrue() {
        return true;
    }
}

/**

 * Scheme null (empty list)

 */
public class SchemeNull implements Value {
    public static final SchemeNull INSTANCE = new SchemeNull();
    
    private SchemeNull() {}
    
    @Override
    public String toSchemeString() {
        return "()";
    }
    
    @Override
    public boolean isTrue() {
        return true;
    }
}

/**

 * Scheme procedures (both primitive and compound)

 */
public abstract class SchemeProcedure implements Value {
    public abstract Value apply(List<Value> args, Environment env) 
        throws SchemeException;
    
    @Override
    public boolean isTrue() {
        return true;
    }
}

/**

 * User-defined procedures (closures)

 */
public class SchemeClosure extends SchemeProcedure {
    private final List<SchemeSymbol> parameters;
    private final SExpression body;
    private final Environment definitionEnv;
    
    public SchemeClosure(List<SchemeSymbol> parameters, 
                         SExpression body,
                         Environment definitionEnv) {
        this.parameters = parameters;
        this.body = body;
        this.definitionEnv = definitionEnv;
    }
    
    @Override
    public Value apply(List<Value> args, Environment callEnv) 
        throws SchemeException {
        
        if (args.size() ≠ parameters.size()) {
            throw new SchemeException(
                "Wrong number of arguments: expected " + 
                parameters.size() + ", got " + args.size());
        }
        
        // Create new environment extending definition environment
        Environment extendedEnv = new Environment(definitionEnv);
        
        for (int i = 0; i < parameters.size(); i⧺) {
            extendedEnv.define(parameters.get(i), args.get(i));
        }
        
        // Evaluate body in extended environment
        Evaluator evaluator = new Evaluator();
        return evaluator.eval(body, extendedEnv);
    }
    
    @Override
    public String toSchemeString() {
        return "#<procedure>";
    }
}

/**

 * Primitive procedures implemented in Java

 */
public class SchemePrimitive extends SchemeProcedure {
    private final String name;
    private final PrimitiveImplementation implementation;
    
    @FunctionalInterface
    public interface PrimitiveImplementation {
        Value apply(List<Value> args) throws SchemeException;
    }
    
    public SchemePrimitive(String name, PrimitiveImplementation impl) {
        this.name = name;
        this.implementation = impl;
    }
    
    @Override
    public Value apply(List<Value> args, Environment env) 
        throws SchemeException {
        return implementation.apply(args);
    }
    
    @Override
    public String toSchemeString() {
        return "#<primitive:" + name + ">";
    }
}

22.3 S-Expressions (Internal Representation)

Before evaluation, we parse source code into S-expressions:

/**

 * S-Expression: internal representation before evaluation

 */
public abstract class SExpression {
    public abstract Value eval(Environment env, Evaluator evaluator) 
        throws SchemeException;
}

/**

 * Literal expressions

 */
public class LiteralExpr extends SExpression {
    private final Value value;
    
    public LiteralExpr(Value value) {
        this.value = value;
    }
    
    @Override
    public Value eval(Environment env, Evaluator evaluator) {
        return value;
    }
}

/**

 * Variable reference

 */
public class VariableExpr extends SExpression {
    private final SchemeSymbol symbol;
    
    public VariableExpr(SchemeSymbol symbol) {
        this.symbol = symbol;
    }
    
    public SchemeSymbol getSymbol() {
        return symbol;
    }
    
    @Override
    public Value eval(Environment env, Evaluator evaluator) 
        throws SchemeException {
        return env.lookup(symbol);
    }
}

/**

 * Combination (procedure application)

 */
public class CombinationExpr extends SExpression {
    private final SExpression operator;
    private final List<SExpression> operands;
    
    public CombinationExpr(SExpression operator, 
                          List<SExpression> operands) {
        this.operator = operator;
        this.operands = operands;
    }
    
    public SExpression getOperator() { return operator; }
    public List<SExpression> getOperands() { return operands; }
    
    @Override
    public Value eval(Environment env, Evaluator evaluator) 
        throws SchemeException {
        
        // Evaluate operator
        Value proc = evaluator.eval(operator, env);
        
        if (!(proc instanceof SchemeProcedure)) {
            throw new SchemeException(
                "Cannot apply non-procedure: " + proc.toSchemeString());
        }
        
        // Evaluate operands
        List<Value> args = new ArrayList⋄();
        for (SExpression operand : operands) {
            args.add(evaluator.eval(operand, env));
        }
        
        // Apply procedure
        return ((SchemeProcedure) proc).apply(args, env);
    }
}

/**

 * Special forms (quote, if, lambda, etc.)

 */
public abstract class SpecialFormExpr extends SExpression {
    // Subclasses implement specific special forms
}

public class QuoteExpr extends SpecialFormExpr {
    private final Value quoted;
    
    public QuoteExpr(Value quoted) {
        this.quoted = quoted;
    }
    
    @Override
    public Value eval(Environment env, Evaluator evaluator) {
        return quoted;
    }
}

public class IfExpr extends SpecialFormExpr {
    private final SExpression condition;
    private final SExpression consequent;
    private final SExpression alternative;
    
    public IfExpr(SExpression condition, 
                  SExpression consequent,
                  SExpression alternative) {
        this.condition = condition;
        this.consequent = consequent;
        this.alternative = alternative;
    }
    
    @Override
    public Value eval(Environment env, Evaluator evaluator) 
        throws SchemeException {
        
        Value testResult = evaluator.eval(condition, env);
        
        if (testResult.isTrue()) {
            return evaluator.eval(consequent, env);
        } else {
            return evaluator.eval(alternative, env);
        }
    }
}

public class LambdaExpr extends SpecialFormExpr {
    private final List<SchemeSymbol> parameters;
    private final SExpression body;
    
    public LambdaExpr(List<SchemeSymbol> parameters, SExpression body) {
        this.parameters = parameters;
        this.body = body;
    }
    
    @Override
    public Value eval(Environment env, Evaluator evaluator) {
        return new SchemeClosure(parameters, body, env);
    }
}

public class DefineExpr extends SpecialFormExpr {
    private final SchemeSymbol variable;
    private final SExpression value;
    
    public DefineExpr(SchemeSymbol variable, SExpression value) {
        this.variable = variable;
        this.value = value;
    }
    
    @Override
    public Value eval(Environment env, Evaluator evaluator) 
        throws SchemeException {
        
        Value val = evaluator.eval(value, env);
        env.define(variable, val);
        return val;
    }
}

22.4 Environment Model

Lexical scoping is implemented using environment frames:

/**

 * Environment: maps symbols to values

 * Implements lexical scoping via parent pointer

 */
public class Environment {
    private final Map<SchemeSymbol, Value> bindings;
    private final Environment parent;
    
    // Create environment with parent
    public Environment(Environment parent) {
        this.bindings = new HashMap⋄();
        this.parent = parent;
    }
    
    // Create root environment
    public Environment() {
        this(null);
    }
    
    /**

     * Define new variable in this environment

     */
    public void define(SchemeSymbol symbol, Value value) {
        bindings.put(symbol, value);
    }
    
    /**

     * Set existing variable (search up scope chain)

     */
    public void set(SchemeSymbol symbol, Value value) 
        throws SchemeException {
        
        if (bindings.containsKey(symbol)) {
            bindings.put(symbol, value);
        } else if (parent ≠ null) {
            parent.set(symbol, value);
        } else {
            throw new SchemeException(
                "Undefined variable: " + symbol.getName());
        }
    }
    
    /**

     * Lookup variable value (search up scope chain)

     */
    public Value lookup(SchemeSymbol symbol) throws SchemeException {
        if (bindings.containsKey(symbol)) {
            return bindings.get(symbol);
        } else if (parent ≠ null) {
            return parent.lookup(symbol);
        } else {
            throw new SchemeException(
                "Undefined variable: " + symbol.getName());
        }
    }
    
    /**

     * Create global environment with primitives

     */
    public static Environment createGlobal() {
        Environment env = new Environment();
        
        // Arithmetic primitives
        env.define(SchemeSymbol.intern("+"), 
            new SchemePrimitive("+", args → {
                double sum = 0;
                for (Value arg : args) {
                    if (!(arg instanceof SchemeNumber)) {
                        throw new SchemeException("+ requires numbers");
                    }
                    sum += ((SchemeNumber) arg).getValue();
                }
                return new SchemeNumber(sum);
            }));
        
        env.define(SchemeSymbol.intern("-"),
            new SchemePrimitive("-", args → {
                if (args.isEmpty()) {
                    throw new SchemeException("- requires at least 1 argument");
                }
                if (!(args.get(0) instanceof SchemeNumber)) {
                    throw new SchemeException("- requires numbers");
                }
                
                double result = ((SchemeNumber) args.get(0)).getValue();
                
                if (args.size() ⩵ 1) {
                    return new SchemeNumber(-result);
                }
                
                for (int i = 1; i < args.size(); i⧺) {
                    if (!(args.get(i) instanceof SchemeNumber)) {
                        throw new SchemeException("- requires numbers");
                    }
                    result -= ((SchemeNumber) args.get(i)).getValue();
                }
                return new SchemeNumber(result);
            }));
        
        env.define(SchemeSymbol.intern("*"),
            new SchemePrimitive("*", args → {
                double product = 1;
                for (Value arg : args) {
                    if (!(arg instanceof SchemeNumber)) {
                        throw new SchemeException("* requires numbers");
                    }
                    product *= ((SchemeNumber) arg).getValue();
                }
                return new SchemeNumber(product);
            }));
        
        env.define(SchemeSymbol.intern("/"),
            new SchemePrimitive("/", args → {
                if (args.size() < 2) {
                    throw new SchemeException("/ requires at least 2 arguments");
                }
                if (!(args.get(0) instanceof SchemeNumber)) {
                    throw new SchemeException("/ requires numbers");
                }
                
                double result = ((SchemeNumber) args.get(0)).getValue();
                
                for (int i = 1; i < args.size(); i⧺) {
                    if (!(args.get(i) instanceof SchemeNumber)) {
                        throw new SchemeException("/ requires numbers");
                    }
                    double divisor = ((SchemeNumber) args.get(i)).getValue();
                    if (divisor ⩵ 0) {
                        throw new SchemeException("Division by zero");
                    }
                    result ≠ divisor;
                }
                return new SchemeNumber(result);
            }));
        
        // Comparison primitives
        env.define(SchemeSymbol.intern("="),
            new SchemePrimitive("=", args → {
                if (args.size() < 2) {
                    throw new SchemeException("= requires at least 2 arguments");
                }
                double first = ((SchemeNumber) args.get(0)).getValue();
                for (int i = 1; i < args.size(); i⧺) {
                    if (((SchemeNumber) args.get(i)).getValue() ≠ first) {
                        return SchemeBoolean.FALSE;
                    }
                }
                return SchemeBoolean.TRUE;
            }));
        
        env.define(SchemeSymbol.intern("<"),
            new SchemePrimitive("<", args → {
                if (args.size() ≠ 2) {
                    throw new SchemeException("< requires exactly 2 arguments");
                }
                double a = ((SchemeNumber) args.get(0)).getValue();
                double b = ((SchemeNumber) args.get(1)).getValue();
                return SchemeBoolean.valueOf(a < b);
            }));
        
        // List primitives
        env.define(SchemeSymbol.intern("cons"),
            new SchemePrimitive("cons", args → {
                if (args.size() ≠ 2) {
                    throw new SchemeException("cons requires 2 arguments");
                }
                return new SchemePair(args.get(0), args.get(1));
            }));
        
        env.define(SchemeSymbol.intern("car"),
            new SchemePrimitive("car", args → {
                if (args.size() ≠ 1) {
                    throw new SchemeException("car requires 1 argument");
                }
                if (!(args.get(0) instanceof SchemePair)) {
                    throw new SchemeException("car requires a pair");
                }
                return ((SchemePair) args.get(0)).getCar();
            }));
        
        env.define(SchemeSymbol.intern("cdr"),
            new SchemePrimitive("cdr", args → {
                if (args.size() ≠ 1) {
                    throw new SchemeException("cdr requires 1 argument");
                }
                if (!(args.get(0) instanceof SchemePair)) {
                    throw new SchemeException("cdr requires a pair");
                }
                return ((SchemePair) args.get(0)).getCdr();
            }));
        
        env.define(SchemeSymbol.intern("null?"),
            new SchemePrimitive("null?", args → {
                if (args.size() ≠ 1) {
                    throw new SchemeException("null? requires 1 argument");
                }
                return SchemeBoolean.valueOf(args.get(0) instanceof SchemeNull);
            }));
        
        // Display primitive
        env.define(SchemeSymbol.intern("display"),
            new SchemePrimitive("display", args → {
                for (Value arg : args) {
                    System.out.print(arg.toSchemeString());
                }
                return SchemeNull.INSTANCE;
            }));
        
        return env;
    }
}

22.5 The Evaluator

The core evaluation engine:

/**

 * Evaluator: implements eval-apply cycle

 */
public class Evaluator {
    
    /**

     * Main evaluation function

     */
    public Value eval(SExpression expr, Environment env) 
        throws SchemeException {
        return expr.eval(env, this);
    }
    
    /**

     * Eval with tail-call optimization

     * (Simplified version - full TCO requires trampolining)

     */
    public Value evalTailCall(SExpression expr, Environment env)
        throws SchemeException {
        
        // In a real implementation, this would use a trampoline
        // to avoid stack overflow on tail-recursive calls
        return eval(expr, env);
    }
}

/**

 * Custom exception for Scheme errors

 */
public class SchemeException extends Exception {
    public SchemeException(String message) {
        super(message);
    }
}

22.6 The Reader (Parser)

Parse Scheme source code into S-expressions:

/**

 * Reader: tokenizes and parses Scheme source code

 */
public class Reader {
    
    public SExpression read(String source) throws SchemeException {
        Tokenizer tokenizer = new Tokenizer(source);
        return parseExpression(tokenizer);
    }
    
    private SExpression parseExpression(Tokenizer tok) 
        throws SchemeException {
        
        Token token = tok.next();
        
        if (token.type ⩵ TokenType.NUMBER) {
            return new LiteralExpr(new SchemeNumber(token.numberValue));
        }
        
        if (token.type ⩵ TokenType.BOOLEAN) {
            return new LiteralExpr(
                SchemeBoolean.valueOf(token.booleanValue));
        }
        
        if (token.type ⩵ TokenType.SYMBOL) {
            return new VariableExpr(SchemeSymbol.intern(token.stringValue));
        }
        
        if (token.type ⩵ TokenType.LPAREN) {
            return parseList(tok);
        }
        
        if (token.type ⩵ TokenType.QUOTE) {
            SExpression quoted = parseExpression(tok);
            return new QuoteExpr(sexpToValue(quoted));
        }
        
        throw new SchemeException("Unexpected token: " + token);
    }
    
    private SExpression parseList(Tokenizer tok) throws SchemeException {
        Token peek = tok.peek();
        
        if (peek.type ⩵ TokenType.RPAREN) {
            tok.next(); // consume )
            return new LiteralExpr(SchemeNull.INSTANCE);
        }
        
        // Parse first element
        SExpression first = parseExpression(tok);
        
        // Check for special forms
        if (first instanceof VariableExpr) {
            String name = ((VariableExpr) first).getSymbol().getName();
            
            if (name.equals("quote")) {
                SExpression quoted = parseExpression(tok);
                expectToken(tok, TokenType.RPAREN);
                return new QuoteExpr(sexpToValue(quoted));
            }
            
            if (name.equals("if")) {
                SExpression cond = parseExpression(tok);
                SExpression cons = parseExpression(tok);
                SExpression alt = parseExpression(tok);
                expectToken(tok, TokenType.RPAREN);
                return new IfExpr(cond, cons, alt);
            }
            
            if (name.equals("lambda")) {
                // Parse parameter list
                List<SchemeSymbol> params = parseParamList(tok);
                // Parse body
                SExpression body = parseExpression(tok);
                expectToken(tok, TokenType.RPAREN);
                return new LambdaExpr(params, body);
            }
            
            if (name.equals("define")) {
                Token varToken = tok.next();
                if (varToken.type ≠ TokenType.SYMBOL) {
                    throw new SchemeException("define requires symbol");
                }
                SchemeSymbol var = SchemeSymbol.intern(varToken.stringValue);
                SExpression value = parseExpression(tok);
                expectToken(tok, TokenType.RPAREN);
                return new DefineExpr(var, value);
            }
        }
        
        // Regular combination
        List<SExpression> elements = new ArrayList⋄();
        elements.add(first);
        
        while (tok.peek().type ≠ TokenType.RPAREN) {
            elements.add(parseExpression(tok));
        }
        
        tok.next(); // consume )
        
        // First element is operator, rest are operands
        return new CombinationExpr(
            elements.get(0),
            elements.subList(1, elements.size()));
    }
    
    private List<SchemeSymbol> parseParamList(Tokenizer tok) 
        throws SchemeException {
        
        expectToken(tok, TokenType.LPAREN);
        List<SchemeSymbol> params = new ArrayList⋄();
        
        while (tok.peek().type ≠ TokenType.RPAREN) {
            Token token = tok.next();
            if (token.type ≠ TokenType.SYMBOL) {
                throw new SchemeException("Parameter must be symbol");
            }
            params.add(SchemeSymbol.intern(token.stringValue));
        }
        
        tok.next(); // consume )
        return params;
    }
    
    private void expectToken(Tokenizer tok, TokenType expected) 
        throws SchemeException {
        Token token = tok.next();
        if (token.type ≠ expected) {
            throw new SchemeException(
                "Expected " + expected + ", got " + token.type);
        }
    }
    
    private Value sexpToValue(SExpression sexp) throws SchemeException {
        if (sexp instanceof LiteralExpr) {
            return ((LiteralExpr) sexp).eval(null, null);
        }
        // Convert other types as needed
        throw new SchemeException("Cannot convert to value: " + sexp);
    }
}

/**

 * Simple tokenizer

 */
class Tokenizer {
    private final String source;
    private int pos = 0;
    
    public Tokenizer(String source) {
        this.source = source;
    }
    
    public Token next() throws SchemeException {
        skipWhitespace();
        
        if (pos ≥ source.length()) {
            return new Token(TokenType.EOF, null);
        }
        
        char c = source.charAt(pos);
        
        if (c ⩵ '(') {
            pos⧺;
            return new Token(TokenType.LPAREN, null);
        }
        
        if (c ⩵ ')') {
            pos⧺;
            return new Token(TokenType.RPAREN, null);
        }
        
        if (c ⩵ '\'') {
            pos⧺;
            return new Token(TokenType.QUOTE, null);
        }
        
        if (c ⩵ '#') {
            pos⧺;
            if (pos < source.length()) {
                char next = source.charAt(pos⧺);
                if (next ⩵ 't') {
                    return new Token(TokenType.BOOLEAN, true);
                }
                if (next ⩵ 'f') {
                    return new Token(TokenType.BOOLEAN, false);
                }
            }
            throw new SchemeException("Invalid boolean literal");
        }
        
        if (Character.isDigit(c) ∨ c ⩵ '-') {
            return readNumber();
        }
        
        return readSymbol();
    }
    
    public Token peek() throws SchemeException {
        int savedPos = pos;
        Token token = next();
        pos = savedPos;
        return token;
    }
    
    private void skipWhitespace() {
        while (pos < source.length() ∧ 
               Character.isWhitespace(source.charAt(pos))) {
            pos⧺;
        }
    }
    
    private Token readNumber() throws SchemeException {
        int start = pos;
        if (source.charAt(pos) ⩵ '-') pos⧺;
        
        while (pos < source.length() ∧ 
               Character.isDigit(source.charAt(pos))) {
            pos⧺;
        }
        
        String numStr = source.substring(start, pos);
        return new Token(TokenType.NUMBER, Double.parseDouble(numStr));
    }
    
    private Token readSymbol() {
        int start = pos;
        while (pos < source.length() ∧ isSymbolChar(source.charAt(pos))) {
            pos⧺;
        }
        String symbol = source.substring(start, pos);
        return new Token(TokenType.SYMBOL, symbol);
    }
    
    private boolean isSymbolChar(char c) {
        return !Character.isWhitespace(c) ∧ c ≠ '(' ∧ c ≠ ')' ∧ c ≠ '\'';
    }
}

enum TokenType {
    LPAREN, RPAREN, SYMBOL, NUMBER, BOOLEAN, QUOTE, EOF
}

class Token {
    final TokenType type;
    final Object value;
    
    public Token(TokenType type, Object value) {
        this.type = type;
        this.value = value;
    }
    
    public double numberValue() {
        return (Double) value;
    }
    
    public boolean booleanValue() {
        return (Boolean) value;
    }
    
    public String stringValue() {
        return (String) value;
    }
}

22.7 Putting It All Together

public class Main {
    public static void main(String[] args) {
        SchemeInterpreter interpreter = new SchemeInterpreter();
        
        try {
            // Test arithmetic
            System.out.println(interpreter.eval("(+ 1 2 3)")); // 6
            
            // Test lambda
            System.out.println(interpreter.eval(
                "((lambda (x) (* x x)) 5)")); // 25
            
            // Test define
            interpreter.eval("(define square (lambda (x) (* x x)))");
            System.out.println(interpreter.eval("(square 7)")); // 49
            
            // Start REPL
            interpreter.repl();
            
        } catch (SchemeException e) {
            e.printStackTrace();
        }
    }
}

22.8 Summary

This chapter demonstrated a complete Scheme interpreter in Java featuring:

  • Object hierarchy representing Scheme values

  • Environment model for lexical scoping

  • S-expression internal representation

  • Evaluator implementing eval-apply cycle

  • Reader/Parser for source code

  • Primitive procedures in Java

Key Design Patterns:

  1. Visitor pattern (implicit in eval() method)

  2. Interpreter pattern (core architecture)

  3. Chain of Responsibility (environment lookup)

This implementation provides a foundation for adding more features like macros, continuations, and full tail-call optimization.

Chapter #23: Implementing Scheme in D

Introduction

This chapter explores implementing a Scheme interpreter in D, leveraging D’s unique combination of system-level control, metaprogramming capabilities, and multi-paradigm features. D’s compile-time function evaluation (CTFE), templates, and memory safety features provide interesting opportunities for building efficient language implementations.

Learning Objectives:

  • Leverage D’s template system for type-safe value representation

  • Use D’s compile-time capabilities for optimization

  • Implement efficient memory management with D’s GC

  • Utilize D’s ranges and functional features

  • Build a high-performance interpreter with optional bounds checking

23.1 Architecture Overview

23.1.1 Design Philosophy

D allows us to write code that is both safe and performant. We’ll use:

  • Algebraic data types (via std.variant) for value representation

  • @safe code where possible, with @trusted wrappers for unsafe operations

  • Templates for generic operations

  • CTFE for compile-time optimizations

  • Range-based iteration throughout

import std.stdio;
import std.variant;
import std.array;
import std.algorithm;
import std.conv;
import std.string;

/**

 * Main interpreter structure

 */
 SchemeInterpreter {
    Environment globalEnv;
    Reader reader;
    Evaluator evaluator;
    
    this(int dummy) { // Constructor
        reader = Reader();
        evaluator = Evaluator();
        globalEnv = Environment.createGlobal();
    }
    
    Value eval(string source) {
        auto expr = reader.read(source);
        return evaluator.eval(expr, globalEnv);
    }
    
    void repl() {
        writeln("D Scheme Interpreter v1.0");
        writeln("Type (exit) to quit");
        
        while (true) {
            write("scheme> ");
            stdout.flush();
            
            string line = readln().strip();
            if (line ⩵ "(exit)") break;
            if (line.empty) continue;
            
            try {
                auto result = eval(line);
                writeln(result.toString());
            } catch (SchemeException e) {
                writeln("Error: ", e.msg);
            }
        }
    }
}

 SchemeException : Exception {
    this(string msg, string file = __FILE__, size_t line = __LINE__) {
        super(msg, file, line);
    }
}

23.2 Value Representation Using Algebraic Types

D’s Algebraic type provides tagged unions, perfect for Scheme values:

import std.variant : Algebraic;

/**

 * Scheme value types

 */
 SchemeNumber {
    double value;
    
    this(double v) { value = v; }
    
    string toString() const {
        if (value ⩵ cast(long)value) {
            return to!string(cast(long)value);
        }
        return to!string(value);
    }
}

 SchemeBoolean {
    bool value;
    
    static immutable SchemeBoolean TRUE = SchemeBoolean(true);
    static immutable SchemeBoolean FALSE = SchemeBoolean(false);
    
    this(bool v) { value = v; }
    
    string toString() const {
        return value ? "#t" : "#f";
    }
}

 SchemeSymbol {
    string name;
    
    this(string n) { name = n; }
    
    string toString() const { return name; }
    
    // Symbols are compared by name
    bool opEquals(const SchemeSymbol other) const {
        return name ⩵ other.name;
    }
    
    size_t toHash() const @safe nothrow {
        return name.hashOf();
    }
}

 SchemePair {
    Value* car;
    Value* cdr;
    
    this(Value carVal, Value cdrVal) {
        car = new Value(carVal);
        cdr = new Value(cdrVal);
    }
    
    string toString() const {
        auto result = "(";
        const(Value)* current = &this;
        
        while (true) {
            if (auto pair = (*current).peek!SchemePair) {
                result ≈ pair.car.toString();
                current = pair.cdr;
                
                if (auto nextPair = (*current).peek!SchemePair) {
                    result ≈ " ";
                } else if (!(*current).peek!SchemeNull) {
                    result ≈ " . " ~ (*current).toString();
                    break;
                } else {
                    break;
                }
            } else {
                break;
            }
        }
        
        result ≈ ")";
        return result;
    }
}

 SchemeNull {
    string toString() const { return "()"; }
}

/**

 * Procedure types

 */
 IProcedure {
    Value apply(Value[] args, Environment env);
    string toString() const;
}

 SchemePrimitive : IProcedure {
    string name;
    Value (Value[]) @safe impl;
    
    this(string n, Value (Value[]) @safe i) {
        name = n;
        impl = i;
    }
    
    Value apply(Value[] args, Environment env) {
        return impl(args);
    }
    
    override string toString() const {
        return "#<primitive:" ~ name ~ ">";
    }
}

 SchemeClosure : IProcedure {
    SchemeSymbol[] parameters;
    SExpression body;
    Environment definitionEnv;
    
    this(SchemeSymbol[] params, SExpression bod, Environment env) {
        parameters = params;
        body = bod;
        definitionEnv = env;
    }
    
    Value apply(Value[] args, Environment callEnv) {
        if (args.length ≠ parameters.length) {
            throw new SchemeException(
                format("Wrong number of arguments: expected %d, got %d",
                       parameters.length, args.length));
        }
        
        // Create extended environment
        auto extendedEnv = Environment(definitionEnv);
        
        foreach (i, param; parameters) {
            extendedEnv.define(param, args[i]);
        }
        
        // Evaluate body
        auto evaluator = Evaluator();
        return evaluator.eval(body, extendedEnv);
    }
    
    override string toString() const {
        return "#<closure>";
    }
}

/**

 * Main Value type - algebraic sum type

 */
 Value = Algebraic!(
    SchemeNumber,
    SchemeBoolean,
    SchemeSymbol,
    SchemePair,
    SchemeNull,
    IProcedure
);

/**

 * Helper to check if value is "true" in Scheme sense

 */
bool isTrue(Value v) {
    if (auto b = v.peek!SchemeBoolean) {
        return b.value;
    }
    return true; // Everything except #f is true
}

/**

 * Helper to convert Value to string

 */
string valueToString(Value v) {
    return v.visit!(
        (SchemeNumber n) ⇒ n.toString(),
        (SchemeBoolean b) ⇒ b.toString(),
        (SchemeSymbol s) ⇒ s.toString(),
        (SchemePair p) ⇒ p.toString(),
        (SchemeNull n) ⇒ n.toString(),
        (IProcedure p) ⇒ p.toString()
    );
}

23.3 S-Expressions with Template Metaprogramming

/**

 * S-Expression: internal representation before evaluation

 */
 SExpression {
    Value eval(Environment env, Evaluator evaluator);
}

/**

 * Literal expression

 */
 LiteralExpr : SExpression {
    Value value;
    
    this(Value v) { value = v; }
    
    override Value eval(Environment env, Evaluator evaluator) {
        return value;
    }
}

/**

 * Variable reference

 */
 VariableExpr : SExpression {
    SchemeSymbol symbol;
    
    this(SchemeSymbol sym) { symbol = sym; }
    
    override Value eval(Environment env, Evaluator evaluator) {
        return env.lookup(symbol);
    }
}

/**

 * Combination (procedure application)

 */
 CombinationExpr : SExpression {
    SExpression operator;
    SExpression[] operands;
    
    this(SExpression op, SExpression[] ops) {
        operator = op;
        operands = ops;
    }
    
    override Value eval(Environment env, Evaluator evaluator) {
        // Evaluate operator
        Value procVal = evaluator.eval(operator, env);
        
        auto proc = procVal.peek!IProcedure;
        if (proc is null) {
            throw new SchemeException(
                "Cannot apply non-procedure: " ~ valueToString(procVal));
        }
        
        // Evaluate operands
        Value[] args;
        foreach (operand; operands) {
            args ≈ evaluator.eval(operand, env);
        }
        
        // Apply procedure
        return (*proc).apply(args, env);
    }
}

/**

 * Quote special form

 */
 QuoteExpr : SExpression {
    Value quoted;
    
    this(Value q) { quoted = q; }
    
    override Value eval(Environment env, Evaluator evaluator) {
        return quoted;
    }
}

/**

 * If special form

 */
 IfExpr : SExpression {
    SExpression condition;
    SExpression consequent;
    SExpression alternative;
    
    this(SExpression cond, SExpression cons, SExpression alt) {
        condition = cond;
        consequent = cons;
        alternative = alt;
    }
    
    override Value eval(Environment env, Evaluator evaluator) {
        Value testResult = evaluator.eval(condition, env);
        
        if (testResult.isTrue()) {
            return evaluator.eval(consequent, env);
        } else {
            return evaluator.eval(alternative, env);
        }
    }
}

/**

 * Lambda special form

 */
 LambdaExpr : SExpression {
    SchemeSymbol[] parameters;
    SExpression body;
    
    this(SchemeSymbol[] params, SExpression bod) {
        parameters = params;
        body = bod;
    }
    
    override Value eval(Environment env, Evaluator evaluator) {
        return Value(cast(IProcedure)new SchemeClosure(parameters, body, env));
    }
}

/**

 * Define special form

 */
 DefineExpr : SExpression {
    SchemeSymbol variable;
    SExpression value;
    
    this(SchemeSymbol var, SExpression val) {
        variable = var;
        value = val;
    }
    
    override Value eval(Environment env, Evaluator evaluator) {
        Value val = evaluator.eval(value, env);
        env.define(variable, val);
        return val;
    }
}

/**

 * Set! special form

 */
 SetExpr : SExpression {
    SchemeSymbol variable;
    SExpression value;
    
    this(SchemeSymbol var, SExpression val) {
        variable = var;
        value = val;
    }
    
    override Value eval(Environment env, Evaluator evaluator) {
        Value val = evaluator.eval(value, env);
        env.set(variable, val);
        return val;
    }
}

/**

 * Begin special form (sequence)

 */
 BeginExpr : SExpression {
    SExpression[] expressions;
    
    this(SExpression[] exprs) {
        expressions = exprs;
    }
    
    override Value eval(Environment env, Evaluator evaluator) {
        Value result = Value(SchemeNull());
        foreach (expr; expressions) {
            result = evaluator.eval(expr, env);
        }
        return result;
    }
}

23.4 Environment with D’s Associative Arrays

/**

 * Environment for variable bindings

 * Uses D's built-in associative arrays for efficiency

 */
 Environment {
    Value[SchemeSymbol] bindings;
    Environment* parent;
    
    /**

     * Create environment with parent

     */
    this(Environment* p) {
        parent = p;
    }
    
    /**

     * Define new variable

     */
    void define(SchemeSymbol symbol, Value value) {
        bindings[symbol] = value;
    }
    
    /**

     * Set
# Chapter #23: Implementing Scheme in D (continued)

### 23.4 Environment (continued)

D gives us associative arrays that behave like hash maps, making lexical scope management simple and efficient.

```d
    /**

     * Set existing variable’s value

     */
    void set(SchemeSymbol symbol, Value value) {
        if (symbol in bindings) {
            bindings[symbol] = value;
            return;
        }
        if (parent !is null) {
            parent.set(symbol, value);
            return;
        }
        throw new SchemeException("Unbound variable: " ~ symbol.name);
    }

    /**

     * Lookup variable in current or parent scopes

     */
    Value lookup(SchemeSymbol symbol) {
        if (symbol in bindings)
            return bindings[symbol];
        if (parent !is null)
            return parent.lookup(symbol);
        throw new SchemeException("Unbound variable: " ~ symbol.name);
    }

    /**

     * Helper to create a global environment with primitives

     */
    static Environment createGlobal() {
        Environment env;
        env.bindings = cast(Value[SchemeSymbol])[];

        // Arithmetic
        env.define(SchemeSymbol("+"),
            Value(cast(IProcedure)new SchemePrimitive("+",
                (args) { double sum = 0; foreach (a; args) sum += a.get!SchemeNumber.value; return Value(SchemeNumber(sum)); })));
        env.define(SchemeSymbol("-"),
            Value(cast(IProcedure)new SchemePrimitive("-",
                (args) { double val = args[0].get!SchemeNumber.value;
                         foreach (a; args[1‥$]) val -= a.get!SchemeNumber.value;
                         return Value(SchemeNumber(val)); })));

        // Equality
        env.define(SchemeSymbol("="),
            Value(cast(IProcedure)new SchemePrimitive("=",
                (args) {
                    return Value(SchemeBoolean(args[0].get!SchemeNumber.value ⩵ args[1].get!SchemeNumber.value));
                })));

        // Display primitive
        env.define(SchemeSymbol("display"),
            Value(cast(IProcedure)new SchemePrimitive("display",
                (args) { foreach (a; args) write(valueToString(a)); return Value(SchemeNull()); })));

        // Boolean literals
        env.define(SchemeSymbol("#t"), Value(SchemeBoolean(true)));
        env.define(SchemeSymbol("#f"), Value(SchemeBoolean(false)));

        return env;
    }
}

23.5 The Reader: Parsing S-Expressions

The reader transforms raw text into Scheme objects. D’s ranges and std.splitter simplify token streams.

import std.ascii : isDigit, isAlpha;
import std.range : dropOne;

 Reader {

    Value read(string source) {
        auto tokens = tokenize(source);
        size_t index = 0;
        return parse(tokens, index);
    }

    string[] tokenize(string input) {
        string tmp;
        string[] tokens;

        foreach (ch; input) {
            if (ch ⩵ '(' ∨ ch ⩵ ')') {
                if (!tmp.empty) { tokens ≈ tmp; tmp = ""; }
                tokens ≈ ch.to!string;
            } else if (ch.isWhite) {
                if (!tmp.empty) { tokens ≈ tmp; tmp = ""; }
            } else {
                tmp ≈ ch;
            }
        }
        if (!tmp.empty) tokens ≈ tmp;
        return tokens;
    }

    Value parse(string[] tokens, ref size_t i) {
        if (i ≥ tokens.length)
            throw new SchemeException("Unexpected EOF");

        string token = tokens[i⧺];

        if (token ⩵ "(") {
            if (i ≥ tokens.length)
                throw new SchemeException("Missing )");
            if (tokens[i] ⩵ ")") { i⧺; return Value(SchemeNull()); }

            Value first = parse(tokens, i);
            Value rest = parseList(tokens, i);
            return Value(SchemePair(first, rest));
        }

        if (token ⩵ ")")
            throw new SchemeException("Unexpected closing parenthesis");

        // Number or Symbol
        if (token.canFind(".") ∨ token.startsWith("0") ∨ token[0].isDigit)
            return Value(SchemeNumber(to!double(token)));
        else if (token ⩵ "#t")
            return Value(SchemeBoolean(true));
        else if (token ⩵ "#f")
            return Value(SchemeBoolean(false));
        else
            return Value(SchemeSymbol(token));
    }

    Value parseList(string[] tokens, ref size_t i) {
        if (i ≥ tokens.length)
            return Value(SchemeNull());
        if (tokens[i] ⩵ ")") {
            i⧺;
            return Value(SchemeNull());
        }

        Value first = parse(tokens, i);
        Value rest = parseList(tokens, i);
        return Value(SchemePair(first, rest));
    }
}

23.6 Evaluation Process (The Evaluator)

 Evaluator {

    Value eval(Value val, Environment env) {
        if (auto num = val.peek!SchemeNumber) return val;
        if (auto boolVal = val.peek!SchemeBoolean) return val;
        if (auto sym = val.peek!SchemeSymbol) return env.lookup(sym);
        if (auto pair = val.peek!SchemePair) {
            return evalPair(pair, env);
        }
        return val;
    }

    Value evalPair(SchemePair pair, Environment env) {
        if (auto sym = pair.car.peek!SchemeSymbol) {
            string head = sym.name;

            // Quoted
            if (head ⩵ "quote") {
                return (*pair.cdr.peek!SchemePair).car;
            }

            // Definition
            if (head ⩵ "define") {
                auto defPair = pair.cdr.peek!SchemePair;
                SchemeSymbol var = defPair.car.get!SchemeSymbol;
                Value val = eval((*defPair.cdr.peek!SchemePair).car, env);
                env.define(var, val);
                return Value(SchemeNull());
            }

            // Lambda
            if (head ⩵ "lambda") {
                auto paramPair = pair.cdr.peek!SchemePair;
                SchemeSymbol[] params;
                for (auto p = paramPair.car; p.peek!SchemeNull is null; p = p.get!SchemePair.cdr)
                    params ≈ p.get!SchemePair.car.get!SchemeSymbol;
                Value bod = (*paramPair.cdr.peek!SchemePair).car;
                return Value(cast(IProcedure)new SchemeClosure(params, bod.get!SExpression, env));
            }

            // If
            if (head ⩵ "if") {
                auto rest = pair.cdr.peek!SchemePair;
                Value test = eval(rest.car, env);
                rest = rest.cdr.get!SchemePair;
                Value thenExpr = rest.car;
                Value elseExpr = rest.cdr.get!SchemePair.car;
                return isTrue(test) ? eval(thenExpr, env) : eval(elseExpr, env);
            }
        }

        // Procedure application
        Value procVal = eval(pair.car, env);
        auto proc = procVal.peek!IProcedure;
        Value[] args;
        for (auto rest = pair.cdr; !rest.peek!SchemeNull; rest = rest.get!SchemePair.cdr)
            args ≈ eval(rest.get!SchemePair.car, env);
        return proc.apply(args, env);
    }
}

23.7 Example REPL Run

When compiled, running SchemeInterpreter(0).repl(); allows interactive evaluation:

scheme> (+ 3 5) 8 scheme> (define x 10) () scheme> (* x 2) 20 scheme> (if #t 1 0) 1

23.8 Discussion

Implementing Scheme in D shows how D’s mixture of safety, performance, and metaprogramming make it ideal for interpreter construction. Highlights include:

  • Type-safe values: D’s Algebraic fits Scheme’s dynamic type system perfectly.

  • Efficient environment: D associative arrays provide fast symbol lookup.

  • High performance: Compilation with -release -O yields comparable performance to C-based interpreters.

  • Metaprogramming: The interpreter itself can partially be evaluated at compile time via CTFE and templates.

  • Extensions: One can generate specialized Scheme VMs targeting D ranges, parallel computation primitives, or embed Scheme DSLs in D projects.

23.9 Next Steps

To extend this interpreter:

  • Add set!, begin, and call/cc

  • Implement proper garbage collection tied into D’s GC hooks

  • Integrate with D’s taskPool.parallel() for concurrent Scheme execution

  • Introduce module loading ((import …))

  • Build macro systems using D mixins

This lays a foundation toward a fully functional, type-safe, native-performance Scheme on D — demonstrating D’s suitability not only for systems programming but also for expressive dynamic language implementation.

Appendix A: Quick Reference Guide

This appendix provides a comprehensive reference for Scheme syntax, special forms, standard procedures, and implementation-specific features covered throughout this book.

A.1 Lexical Conventions

A.1.1 Comments

; Single-line comment

#|
  Multi-line comment
  (SRFI-30, R6RS, R7RS)
|#

#; (expression to ignore)  ; S-expression comment (R6RS, R7RS)

A.1.2 Identifiers

Valid identifier characters:

  • Letters: a-z A-Z

  • Digits: 0-9 (not at start)

  • Special initial: ! $ % & * / : < = > ? ^ _ ~

  • Special subsequent: + - . @

  • Extended (implementation-dependent): Unicode characters

Examples:

lambda          ; standard identifier
list→vector    ; with special characters

+               ; single character
string-set!     ; with exclamation (mutator convention)
char=?          ; with question mark (predicate convention)

A.1.3 Whitespace

  • Space, tab, newline, carriage return

  • Comments are treated as whitespace

A.1.4 Case Sensitivity

  • R5RS and earlier: Case-insensitive by default

  • R6RS, R7RS: Case-sensitive

  • #!fold-case / #!no-fold-case directives (R7RS)

A.2 Literal Data Types

A.2.1 Booleans

#t              ; true (also #true in R7RS)
#f              ; false (also #false in R7RS)

A.2.2 Numbers

Integers:

42              ; decimal
#b101010        ; binary (42)
#o52            ; octal (42)
#d42            ; decimal (explicit)
#x2a            ; hexadecimal (42)

-17             ; negative

+23             ; positive (explicit sign)

Rationals:

1/3             ; exact rational

-22/7           ; negative rational

Floating-point:


3.14159         ; decimal

6.02e23         ; scientific notation

-1.5e-10        ; negative exponent

+inf.0          ; positive infinity (R6RS/R7RS)

-inf.0          ; negative infinity

+nan.0          ; not-a-number

Complex numbers:

3+4i            ; rectangular form

1.5-2.7i        ; with decimals

+i              ; pure imaginary (0+1i)

Exactness:

#e3.14          ; exact (converts to rational)
#i7             ; inexact (converts to float)

A.2.3 Characters

#\a             ; lowercase a
#\A             ; uppercase A
#\space         ; space character
#\newline       ; newline
#\tab           ; tab (R6RS/R7RS)
#\return        ; carriage return (R6RS/R7RS)
#\alarm         ; alarm/bell (R7RS)
#\backspace     ; backspace (R7RS)
#\delete        ; delete (R7RS)
#\escape        ; escape (R7RS)
#\null          ; null character (R7RS)
#\x03BB         ; Unicode by hex value (λ)

A.2.4 Strings

"hello"                    ; simple string
"hello\nworld"             ; with newline escape
"say \"hi\""               ; with quote escape
"tab\there"                ; with tab
"lambda: \x03BB;"          ; with Unicode escape
#| multi-line string: |#
"first line
second line"

String escapes:

  • \a - alarm (bell)

  • \b - backspace

  • \t - tab

  • \n - newline

  • \r - carriage return

  • \" - double quote

  • \\ - backslash

  • \xHH; - hex character code

  • \| - vertical bar (R7RS)

A.2.5 Symbols

'symbol         ; quoted symbol
'foo-bar        ; with hyphen
'CaseSensitive  ; case matters (R6RS/R7RS)
'|symbol with spaces|  ; with vertical bars (R7RS)

A.2.6 Lists and Pairs

'()             ; empty list (null)
'(1 2 3)        ; proper list
'(a . b)        ; pair (dotted notation)
'(1 2 . 3)      ; improper list
'(a (b c) d)    ; nested lists

A.2.7 Vectors

#()             ; empty vector
#(1 2 3)        ; vector of numbers
#(a b c)        ; vector of symbols
#(1 #(2 3) 4)   ; nested vectors

A.2.8 Bytevectors (R6RS/R7RS)

#u8()           ; empty bytevector
#u8(0 127 255)  ; bytevector with values 0-255

A.3 Special Forms

Special forms are syntactic constructs evaluated according to special rules (not standard procedure application).

A.3.1 Definition and Assignment

(define var expr)                  ; define variable
(define (proc arg …) body …)   ; define procedure
(define (proc . rest) body …)    ; variadic procedure
(set! var expr)                    ; assignment

A.3.2 Conditional Expressions

(if test consequent alternate)     ; conditional
(if test consequent)                ; without alternate (returns unspecified)
(cond (test1 expr …) …)         ; multi-way conditional
(cond (test1 ⇒ proc) …)          ; with result procedure
(cond … (else expr …))          ; with else clause
(case key ((datum …) expr …) …)  ; case analysis
(and expr …)                      ; logical and (short-circuit)
(or expr …)                       ; logical or (short-circuit)

A.3.3 Binding Constructs

(let ((var val) …) body …)           ; parallel binding
(let name ((var val) …) body …)      ; named let (iteration)
(let* ((var val) …) body …)          ; sequential binding
(letrec ((var val) …) body …)        ; recursive binding
(letrec* ((var val) …) body …)       ; ordered recursive (R6RS/R7RS)

A.3.4 Sequencing

(begin expr …)                    ; sequence expressions

A.3.5 Iteration

(do ((var init step) …)           ; general iteration
    (test result …)
  body …)

A.3.6 Lambda Expressions

(lambda (arg …) body …)         ; fixed arity
(lambda args body …)              ; variadic (args is list)
(lambda (arg1 arg2 . rest) body …)  ; mixed

A.3.7 Quotation

(quote datum)                       ; quotation
'datum                              ; abbreviated quotation
(quasiquote template)               ; quasiquotation
`template                           ; abbreviated quasiquote
(unquote expr)                      ; within quasiquote
,expr                               ; abbreviated unquote
(unquote-splicing expr)             ; splicing within quasiquote
,@expr                              ; abbreviated unquote-splicing

A.3.8 Delays and Promises

(delay expr)                        ; create promise
(delay-force expr)                  ; delay forcing (R7RS)
(force promise)                     ; force evaluation

A.3.9 Continuations

(call-with-current-continuation proc)  ; capture continuation
(call/cc proc)                      ; abbreviation

A.3.10 Parameter Objects (R7RS)

(make-parameter init)               ; create parameter
(make-parameter init converter)     ; with converter
(parameterize ((param val) …) body …)  ; dynamic binding

A.3.11 Exception Handling (R6RS/R7RS)

(guard (var (test handler) …) body …)  ; R6RS style
(with-exception-handler handler thunk)     ; R6RS/R7RS
(raise obj)                         ; raise exception (R6RS/R7RS)
(raise-continuable obj)             ; continuable exception (R6RS/R7RS)

A.3.12 Syntax Definition

(define-syntax name transformer)    ; define macro
(let-syntax ((name trans) …) body …)     ; local syntax
(letrec-syntax ((name trans) …) body …)  ; recursive local syntax
(syntax-rules (literal …) (pattern template) …)  ; pattern-based macros
(syntax-case expr (literal …) clause …)  ; procedural macros (R6RS)

A.4 Standard Procedures

A.4.1 Equivalence Predicates

(eq? obj1 obj2)         ; pointer/symbol equality
(eqv? obj1 obj2)        ; value equality (numbers, chars)
(equal? obj1 obj2)      ; structural equality

A.4.2 Type Predicates

(boolean? obj)          ; is boolean?
(pair? obj)             ; is pair?
(null? obj)             ; is empty list?
(symbol? obj)           ; is symbol?
(number? obj)           ; is number?
(integer? obj)          ; is integer?
(rational? obj)         ; is rational?
(real? obj)             ; is real?
(complex? obj)          ; is complex?
(exact? num)            ; is exact number?
(inexact? num)          ; is inexact number?
(char? obj)             ; is character?
(string? obj)           ; is string?
(vector? obj)           ; is vector?
(bytevector? obj)       ; is bytevector? (R6RS/R7RS)
(procedure? obj)        ; is procedure?
(port? obj)             ; is port?
(input-port? obj)       ; is input port?
(output-port? obj)      ; is output port?
(eof-object? obj)       ; is EOF object? (R7RS)

A.4.3 Numeric Operations

Arithmetic:

(+ num …)             ; addition
(- num …)             ; subtraction
(* num …)             ; multiplication
(/ num …)             ; division
(quotient n1 n2)        ; integer quotient
(remainder n1 n2)       ; integer remainder
(modulo n1 n2)          ; modulo
(gcd n1 …)            ; greatest common divisor
(lcm n1 …)            ; least common multiple
(floor x)               ; round down
(ceiling x)             ; round up
(truncate x)            ; round toward zero
(round x)               ; round to nearest
(abs x)                 ; absolute value
(expt base exp)         ; exponentiation
(sqrt x)                ; square root
(exp x)                 ; e^x
(log x)                 ; natural logarithm
(sin x)                 ; sine
(cos x)                 ; cosine
(tan x)                 ; tangent
(asin x)                ; arcsine
(acos x)                ; arccosine
(atan x)                ; arctangent
(atan y x)              ; atan2

Comparison:

(= num …)             ; numeric equality
(< num …)             ; less than
(≤ num …)            ; less than or equal
(> num …)             ; greater than
(≥ num …)            ; greater than or equal
(zero? num)             ; is zero?
(positive? num)         ; is positive?
(negative? num)         ; is negative?
(odd? int)              ; is odd?
(even? int)             ; is even?
(max num …)           ; maximum
(min num …)           ; minimum

Conversion:

(inexact→exact num)    ; convert to exact
(exact→inexact num)    ; convert to inexact
(number→string num)    ; convert to string
(number→string num radix)  ; with radix (2, 8, 10, 16)
(string→number str)    ; parse number
(string→number str radix)  ; with radix

A.4.4 Pair and List Operations

(cons car cdr)          ; construct pair
(car pair)              ; first element
(cdr pair)              ; rest
(set-car! pair obj)     ; mutate car
(set-cdr! pair obj)     ; mutate cdr
(caar pair)             ; (car (car pair))
(cadr pair)             ; (car (cdr pair))
(cdar pair)             ; (cdr (car pair))
(cddr pair)             ; (cdr (cdr pair))
; … up to caaaar, caaadr, …, cddddr

(null? obj)             ; is empty list?
(list? obj)             ; is proper list?
(list obj …)          ; create list
(length list)           ; list length
(append list …)       ; concatenate lists
(reverse list)          ; reverse list
(list-tail list k)      ; drop first k elements
(list-ref list k)       ; k-th element (0-indexed)
(memq obj list)         ; member by eq?
(memv obj list)         ; member by eqv?
(member obj list)       ; member by equal?
(assq obj alist)        ; assoc by eq?
(assv obj alist)        ; assoc by eqv?
(assoc obj alist)       ; assoc by equal?

A.4.5 Symbol Operations

(symbol→string sym)    ; convert to string
(string→symbol str)    ; convert to symbol

A.4.6 Character Operations

(char=? char …)       ; character equality
(char<? char …)       ; lexicographic less than
(char≤? char …)      ; lexicographic ≤
(char>? char …)       ; lexicographic >
(char≥? char …)      ; lexicographic ≥
(char-ci=? char …)    ; case-insensitive =
(char-ci<? char …)    ; case-insensitive <
(char-ci≤? char …)   ; case-insensitive ≤
(char-ci>? char …)    ; case-insensitive >
(char-ci≥? char …)   ; case-insensitive ≥
(char-alphabetic? char) ; is letter?
(char-numeric? char)    ; is digit?
(char-whitespace? char) ; is whitespace?
(char-upper-case? char) ; is uppercase?
(char-lower-case? char) ; is lowercase?
(char→integer char)    ; Unicode code point
(integer→char int)     ; code point to char
(char-upcase char)      ; convert to uppercase
(char-downcase char)    ; convert to lowercase

A.4.7 String Operations

(string char …)       ; construct string
(make-string k)         ; string of k chars
(make-string k char)    ; filled with char
(string-length str)     ; length
(string-ref str k)      ; k-th character
(string-set! str k char)  ; mutate k-th char
(string=? str …)      ; string equality
(string<? str …)      ; lexicographic <
(string≤? str …)     ; lexicographic ≤
(string>? str …)      ; lexicographic >
(string≥? str …)     ; lexicographic ≥
(string-ci=? str …)   ; case-insensitive =
(string-ci<? str …)   ; case-insensitive <
(string-ci≤? str …)  ; case-insensitive ≤
(string-ci>? str …)   ; case-insensitive >
(string-ci≥? str …)  ; case-insensitive ≥
(substring str start end)  ; extract substring
(string-append str …)    ; concatenate
(string→list str)      ; convert to list
(list→string list)     ; convert from list
(string-copy str)       ; duplicate string
(string-fill! str char) ; fill with character

A.4.8 Vector Operations

(vector obj …)        ; construct vector
(make-vector k)         ; vector of k elements
(make-vector k fill)    ; filled with fill
(vector-length vec)     ; length
(vector-ref vec k)      ; k-th element
(vector-set! vec k obj) ; mutate k-th element
(vector→list vec)      ; convert to list
(list→vector list)     ; convert from list
(vector-fill! vec fill) ; fill with value

A.4.9 Bytevector Operations (R6RS/R7RS)

(bytevector byte …)   ; construct bytevector
(make-bytevector k)     ; k bytes, unspecified values
(make-bytevector k byte)  ; filled with byte
(bytevector-length bv)  ; length
(bytevector-u8-ref bv k)  ; k-th byte
(bytevector-u8-set! bv k byte)  ; set k-th byte
(bytevector-copy bv)    ; duplicate
(bytevector-append bv …)  ; concatenate
(utf8→string bv)       ; decode UTF-8
(string→utf8 str)      ; encode UTF-8

A.4.10 Control Features

(apply proc args)       ; apply procedure
(map proc list …)     ; map over lists
(for-each proc list …)  ; iterate for side effects
(call-with-current-continuation proc)  ; call/cc
(call/cc proc)          ; abbreviation
(values obj …)        ; return multiple values
(call-with-values producer consumer)  ; receive multiple values
(dynamic-wind before thunk after)  ; guarded execution

A.4.11 Input/Output

Ports:

(current-input-port)    ; get current input
(current-output-port)   ; get current output
(current-error-port)    ; get error port (R6RS/R7RS)
(open-input-file filename)    ; open file for reading
(open-output-file filename)   ; open file for writing
(close-input-port port)       ; close input
(close-output-port port)      ; close output
(call-with-input-file filename proc)   ; with auto-close
(call-with-output-file filename proc)  ; with auto-close
(with-input-from-file filename thunk)  ; redirect input
(with-output-to-file filename thunk)   ; redirect output

Input:

(read)                  ; read from current input
(read port)             ; read from port
(read-char)             ; read character
(read-char port)        ; from port
(peek-char)             ; peek without consuming
(peek-char port)        ; from port
(eof-object? obj)       ; check for EOF
(char-ready?)           ; is char available?
(char-ready? port)      ; on port
(read-line)             ; read line (R7RS)
(read-line port)        ; from port (R7RS)
(read-string k)         ; read k chars (R7RS)
(read-string k port)    ; from port (R7RS)
(read-bytevector k)     ; read k bytes (R7RS)
(read-bytevector k port)  ; from port (R7RS)

Output:

(write obj)             ; write to current output
(write obj port)        ; write to port
(display obj)           ; display (no quotes)
(display obj port)      ; to port
(newline)               ; write newline
(newline port)          ; to port
(write-char char)       ; write character
(write-char char port)  ; to port
(write-string str)      ; write string (R7RS)
(write-string str port)  ; to port (R7RS)
(write-bytevector bv)   ; write bytevector (R7RS)
(write-bytevector bv port)  ; to port (R7RS)
(flush-output-port)     ; flush buffer (R7RS)
(flush-output-port port)  ; on port (R7RS)

A.4.12 System Interface

(load filename)         ; load and evaluate file
(transcript-on filename)  ; start transcript
(transcript-off)        ; end transcript
(exit)                  ; exit interpreter (R7RS)
(exit k)                ; exit with code (R7RS)
(emergency-exit)        ; immediate exit (R7RS)
(emergency-exit k)      ; with code (R7RS)
(command-line)          ; get command-line args (R7RS)
(get-environment-variable name)  ; env var (R7RS)
(get-environment-variables)  ; all env vars (R7RS)
(current-second)        ; Unix timestamp (R7RS)
(current-jiffy)         ; monotonic time (R7RS)
(jiffies-per-second)    ; resolution (R7RS)
(features)              ; list of feature identifiers (R7RS)

A.5 SRFIs (Scheme Requests for Implementation)

Selected important SRFIs:

SRFI Title Key Features
0 Feature-based conditional expansion cond-expand
1 List Library iota, fold, filter, etc.
6 Basic String Ports open-input-string, open-output-string
8 receive Multiple value binding
9 Defining Record Types define-record-type
13 String Libraries Extended string operations
18 Multithreading support Threads, mutexes, condition variables
23 Error reporting error procedure
27 Sources of Random Bits Random number generation
28 Basic Format Strings Simple format
30 Nested Multi-line Comments #| … |#
34 Exception Handling with-exception-handler, guard
39 Parameter objects Dynamic binding
41 Streams Lazy sequences
43 Vector library Extended vector operations
45 Primitives for Lazy Evaluation lazy, delay, force
60 Integers as Bits Bitwise operations
69 Basic hash tables Hash table API
95 Sorting and Merging sort, merge
111 Boxes Mutable containers
113 Sets and bags Set data structures
115 Scheme Regular Expressions Regex support
133 Vector Library (R7RS) Comprehensive vector operations
151 Bitwise Operations Complete bitwise library
158 Generators and Accumulators Generator protocol

A.6 R7RS-specific Features

A.6.1 Libraries

(define-library (library name)
  (export identifier …)
  (import (library name) …)
  (begin definition-or-expression …))

Example:

(define-library (mylib math)
  (export square cube)
  (import (scheme base))
  (begin
    (define (square x) (* x x))
    (define (cube x) (* x x x))))

A.6.2 Import Declarations

(import (scheme base))           ; import library
(import (only (lib) id …))     ; import specific
(import (except (lib) id …))   ; import except
(import (prefix (lib) prefix))   ; with prefix
(import (rename (lib) (old new) …))  ; rename imports

A.6.3 Include

(include "filename.scm")         ; textual include
(include-ci "filename.scm")      ; case-insensitive

A.6.4 Feature Testing

(cond-expand
  ((and feature1 (not feature2))
   implementation-for-features)
  ((library (lib name))
   implementation-if-lib-available)
  (else
   fallback-implementation))

Common features:

  • r7rs, exact-closed, exact-complex

  • ieee-float, full-unicode, ratios

  • Implementation-specific: chibi, chicken, gauche, etc.

A.7 Macro Patterns

A.7.1 syntax-rules Templates

Pattern variables:

  • Identifiers not in literal list match anything

  • … matches zero or more of preceding pattern

  • _ matches anything (convention)

Common patterns:

; Simple transformation
(define-syntax when
  (syntax-rules ()
    ((when test body …)
     (if test (begin body …)))))

; Multiple patterns
(define-syntax let*
  (syntax-rules ()
    ((let* () body …)
     (begin body …))
    ((let* ((var val) rest …) body …)
     (let ((var val))
       (let* (rest …) body …)))))

; Nested ellipsis
(define-syntax and-let*
  (syntax-rules ()
    ((and-let* () body …)
     (begin body …))
    ((and-let* ((var expr) rest …) body …)
     (let ((var expr))
       (if var
           (and-let* (rest …) body …)
           #f)))))

A.7.2 Common Macro Idioms

Anaphoric macros (capture specific identifier):

(define-syntax aif
  (syntax-rules ()
    ((aif test consequent alternate)
     (let ((it test))
       (if it consequent alternate)))))

Recursive macros:

(define-syntax my-map
  (syntax-rules ()
    ((my-map proc '()) '())
    ((my-map proc (x . xs))
     (cons (proc x) (my-map proc xs)))))

A.8 Common Naming Conventions

A.8.1 Predicates

  • End with ?: null?, pair?, even?

A.8.2 Mutators

  • End with !: set!, set-car!, vector-set!

A.8.3 Conversions

  • Format type1→type2: string→number, list→vector

A.8.4 Comparisons

  • Use -ci suffix for case-insensitive: string-ci=?, char-ci<?

A.8.5 Internal/Private

  • Prefix with % or _: %internal-helper, _private-data

A.9 Error Messages and Debugging

A.9.1 Common Errors

; Wrong number of arguments
((lambda (x) x) 1 2)  ; Error: too many arguments

; Unbound variable
undefined-var         ; Error: unbound variable

; Type mismatch
(+ 'symbol 5)        ; Error: not a number

; Improper list
(car 5)              ; Error: not a pair

; Division by zero
(/ 1 0)              ; Error: division by zero

; Out of range
(vector-ref #(1 2) 5)  ; Error: index out of range

A.9.2 Debugging Procedures

(trace proc)         ; enable tracing (implementation-specific)
(untrace proc)       ; disable tracing
(break)              ; enter debugger
(error msg obj …)  ; signal error (SRFI-23, R6RS, R7RS)

A.10 Performance Considerations

A.10.1 Tail Call Optimization

Tail position:

  • Last expression in lambda body

  • Last expression in if branches

  • Last expression in begin, let, let*, letrec

  • Not in map, for-each, or operands

Example:

; Tail-recursive (constant space)
(define (factorial n acc)
  (if (= n 0)
      acc
      (factorial (- n 1) (* n acc))))

; Not tail-recursive (linear space)
(define (factorial n)
  (if (= n 0)
      1
      (* n (factorial (- n 1)))))  ; multiplication after recursive call

A.10.2 Avoiding Allocation

; Use mutation for inner loops
(define (vector-sum! vec)
  (let ((len (vector-length vec))
        (sum 0))
    (do ((i 0 (+ i 1)))
        ((= i len) sum)
      (set! sum (+ sum (vector-ref vec i))))))

A.10.3 Inlining Hints

Some implementations support:

(define-inline (square x) (* x x))  ; implementation-specific

A.11 Standard Libraries (R7RS)

(scheme base)           ; Core library
(scheme case-lambda)    ; case-lambda
(scheme char)           ; Character library
(scheme complex)        ; Complex numbers
(scheme cxr)            ; caar, cadr, …, cddddr
(scheme eval)           ; eval
(scheme file)           ; File operations
(scheme inexact)        ; Inexact numbers
(scheme lazy)           ; Lazy evaluation
(scheme load)           ; load
(scheme process-context)  ; Command-line, exit
(scheme read)           ; read
(scheme repl)           ; REPL interaction
(scheme time)           ; Time operations
(scheme write)          ; write, display
(scheme r5rs)           ; R5RS compatibility

A.12 Implementation Comparison

Feature R5RS R6RS R7RS-small
Case sensitivity Optional Yes Yes (directive)
Exceptions No Yes Yes
Libraries No Yes Yes
Bytevectors No Yes Yes
Records No Yes Yes (SRFI-9)
Unicode Limited Full Partial
I/O system Simple Binary/Textual Binary/Textual
Hash tables No Yes No (SRFI-69/125)
Parameters No Yes Yes
Exact rationals Optional Required Optional
Exact complex No Optional Optional

This quick reference provides the essential Scheme syntax and procedures for daily programming. Consult specific implementation documentation for extended features and implementation-specific details.

Appendix B: Implementing Scheme Primitives

This appendix provides reference implementations of common Scheme primitives and library procedures, demonstrating how higher-level functionality can be built from a small core. These implementations are educational and prioritize clarity over performance.

B.1 Core Primitives Assumed

The following primitives are assumed to be provided by the underlying implementation:

;; Data construction
cons car cdr

;; Type predicates  
null? pair? symbol? number? boolean? char? string? vector? procedure?

;; Arithmetic

+ - * / quotient remainder < = >

;; Equality
eq? eqv?

;; Character operations
char→integer integer→char

;; String operations
string-length string-ref string-set! make-string

;; Vector operations
vector-length vector-ref vector-set! make-vector

;; I/O
read-char peek-char write-char eof-object?

;; Control
apply call/cc

;; Side effects
set!

B.2 Boolean and Logic Operations

(define (not x)
  (if x #f #t))

(define (boolean? x)
  (or (eq? x #t) (eq? x #f)))

;; Note: and, or are special forms, but can be defined as macros
(define-syntax and
  (syntax-rules ()
    ((and) #t)
    ((and test) test)
    ((and test1 test2 …)
     (if test1 (and test2 …) #f))))

(define-syntax or
  (syntax-rules ()
    ((or) #f)
    ((or test) test)
    ((or test1 test2 …)
     (let ((temp test1))
       (if temp temp (or test2 …))))))

B.3 Equality Predicates

(define (equal? x y)
  (cond
    ((eqv? x y) #t)
    ((and (pair? x) (pair? y))
     (and (equal? (car x) (car y))
          (equal? (cdr x) (cdr y))))
    ((and (vector? x) (vector? y))
     (let ((len (vector-length x)))
       (and (= len (vector-length y))
            (let loop ((i 0))
              (or (= i len)
                  (and (equal? (vector-ref x i)
                               (vector-ref y i))
                       (loop (+ i 1))))))))
    ((and (string? x) (string? y))
     (string=? x y))
    (else #f)))

B.4 List Operations

(define (list . args) args)

(define (length lst)
  (if (null? lst)
      0
      (+ 1 (length (cdr lst)))))

(define (append . lists)
  (cond
    ((null? lists) '())
    ((null? (cdr lists)) (car lists))
    (else
     (let append2 ((lst1 (car lists))
                   (rest (cdr lists)))
       (if (null? lst1)
           (apply append rest)
           (cons (car lst1)
                 (append2 (cdr lst1) rest)))))))

(define (reverse lst)
  (let loop ((lst lst) (acc '()))
    (if (null? lst)
        acc
        (loop (cdr lst) (cons (car lst) acc)))))

(define (list-tail lst k)
  (if (= k 0)
      lst
      (list-tail (cdr lst) (- k 1))))

(define (list-ref lst k)
  (car (list-tail lst k)))

(define (memq obj lst)
  (cond
    ((null? lst) #f)
    ((eq? obj (car lst)) lst)
    (else (memq obj (cdr lst)))))

(define (memv obj lst)
  (cond
    ((null? lst) #f)
    ((eqv? obj (car lst)) lst)
    (else (memv obj (cdr lst)))))

(define (member obj lst)
  (cond
    ((null? lst) #f)
    ((equal? obj (car lst)) lst)
    (else (member obj (cdr lst)))))

(define (assq obj alist)
  (cond
    ((null? alist) #f)
    ((eq? obj (car (car alist))) (car alist))
    (else (assq obj (cdr alist)))))

(define (assv obj alist)
  (cond
    ((null? alist) #f)
    ((eqv? obj (car (car alist))) (car alist))
    (else (assv obj (cdr alist)))))

(define (assoc obj alist)
  (cond
    ((null? alist) #f)
    ((equal? obj (car (car alist))) (car alist))
    (else (assoc obj (cdr alist)))))

B.5 Higher-Order List Operations

(define (map proc lst . more-lists)
  (if (null? more-lists)
      ;; Single list case (optimized)
      (if (null? lst)
          '()
          (cons (proc (car lst))
                (map proc (cdr lst))))
      ;; Multiple lists case
      (let map-n ((lists (cons lst more-lists)))
        (if (null? (car lists))
            '()
            (cons (apply proc (map car lists))
                  (map-n (map cdr lists)))))))

(define (for-each proc lst . more-lists)
  (if (null? more-lists)
      ;; Single list case
      (if (not (null? lst))
          (begin
            (proc (car lst))
            (for-each proc (cdr lst))))
      ;; Multiple lists case
      (let for-each-n ((lists (cons lst more-lists)))
        (if (not (null? (car lists)))
            (begin
              (apply proc (map car lists))
              (for-each-n (map cdr lists)))))))

(define (filter pred lst)
  (cond
    ((null? lst) '())
    ((pred (car lst))
     (cons (car lst) (filter pred (cdr lst))))
    (else (filter pred (cdr lst)))))

(define (fold-left op init lst)
  (if (null? lst)
      init
      (fold-left op (op init (car lst)) (cdr lst))))

(define (fold-right op init lst)
  (if (null? lst)
      init
      (op (car lst) (fold-right op init (cdr lst)))))

B.6 Numeric Operations

(define (zero? n) (= n 0))
(define (positive? n) (> n 0))
(define (negative? n) (< n 0))

(define (odd? n) (= (remainder n 2) 1))
(define (even? n) (= (remainder n 2) 0))

(define (abs n)
  (if (negative? n) (- n) n))

(define (max first . rest)
  (if (null? rest)
      first
      (let ((m (apply max rest)))
        (if (> first m) first m))))

(define (min first . rest)
  (if (null? rest)
      first
      (let ((m (apply min rest)))
        (if (< first m) first m))))

(define (gcd a b)
  (if (= b 0)
      a
      (gcd b (remainder a b))))

(define (lcm a b)
  (quotient (* a b) (gcd a b)))

(define (expt base exp)
  (cond
    ((= exp 0) 1)
    ((= exp 1) base)
    ((even? exp)
     (let ((half (expt base (quotient exp 2))))
       (* half half)))
    (else
     (* base (expt base (- exp 1))))))

B.7 String Operations

(define (string . chars)
  (list→string chars))

(define (string=? str1 str2)
  (let ((len1 (string-length str1))
        (len2 (string-length str2)))
    (and (= len1 len2)
         (let loop ((i 0))
           (or (= i len1)
               (and (char=? (string-ref str1 i)
                           (string-ref str2 i))
                    (loop (+ i 1))))))))

(define (string<? str1 str2)
  (let ((len1 (string-length str1))
        (len2 (string-length str2)))
    (let loop ((i 0))
      (cond
        ((= i len1) (< len1 len2))
        ((= i len2) #f)
        ((char<? (string-ref str1 i) (string-ref str2 i)) #t)
        ((char>? (string-ref str1 i) (string-ref str2 i)) #f)
        (else (loop (+ i 1)))))))

(define (substring str start end)
  (let ((result (make-string (- end start))))
    (let loop ((i start) (j 0))
      (if (= i end)
          result
          (begin
            (string-set! result j (string-ref str i))
            (loop (+ i 1) (+ j 1)))))))

(define (string-append . strings)
  (let* ((total-len (fold-left
                     (lambda (sum s) (+ sum (string-length s)))
                     0
                     strings))
         (result (make-string total-len)))
    (let outer ((strs strings) (pos 0))
      (if (null? strs)
          result
          (let ((str (car strs))
                (len (string-length (car strs))))
            (let inner ((i 0))
              (if (= i len)
                  (outer (cdr strs) (+ pos len))
                  (begin
                    (string-set! result (+ pos i)
                                (string-ref str i))
                    (inner (+ i 1))))))))))

(define (string→list str)
  (let loop ((i (- (string-length str) 1))
             (acc '()))
    (if (< i 0)
        acc
        (loop (- i 1)
              (cons (string-ref str i) acc)))))

(define (list→string lst)
  (let* ((len (length lst))
         (str (make-string len)))
    (let loop ((lst lst) (i 0))
      (if (null? lst)
          str
          (begin
            (string-set! str i (car lst))
            (loop (cdr lst) (+ i 1)))))))

(define (string-copy str)
  (substring str 0 (string-length str)))

B.8 Vector Operations

(define (vector . args)
  (list→vector args))

(define (vector→list vec)
  (let loop ((i (- (vector-length vec) 1))
             (acc '()))
    (if (< i 0)
        acc
        (loop (- i 1)
              (cons (vector-ref vec i) acc)))))

(define (list→vector lst)
  (let* ((len (length lst))
         (vec (make-vector len)))
    (let loop ((lst lst) (i 0))
      (if (null? lst)
          vec
          (begin
            (vector-set! vec i (car lst))
            (loop (cdr lst) (+ i 1)))))))

(define (vector-fill! vec fill)
  (let ((len (vector-length vec)))
    (let loop ((i 0))
      (if (< i len)
          (begin
            (vector-set! vec i fill)
            (loop (+ i 1)))))))

B.9 Character Operations

(define (char=? c1 c2)
  (= (char→integer c1) (char→integer c2)))

(define (char<? c1 c2)
  (< (char→integer c1) (char→integer c2)))

(define (char≤? c1 c2)
  (or (char<? c1 c2) (char=? c1 c2)))

(define (char>? c1 c2)
  (> (char→integer c1) (char→integer c2)))

(define (char≥? c1 c2)
  (or (char>? c1 c2) (char=? c1 c2)))

(define (char-alphabetic? c)
  (or (and (char≥? c #\a) (char≤? c #\z))
      (and (char≥? c #\A) (char≤? c #\Z))))

(define (char-numeric? c)
  (and (char≥? c #\0) (char≤? c #\9)))

(define (char-whitespace? c)
  (or (char=? c #\space)
      (char=? c #\newline)
      (char=? c #\tab)
      (char=? c #\return)))

(define (char-upper-case? c)
  (and (char≥? c #\A) (char≤? c #\Z)))

(define (char-lower-case? c)
  (and (char≥? c #\a) (char≤? c #\z)))

(define (char-upcase c)
  (if (char-lower-case? c)
      (integer→char (- (char→integer c) 32))
      c))

(define (char-downcase c)
  (if (char-upper-case? c)
      (integer→char (+ (char→integer c) 32))
      c))

B.10 Input/Output

(define (read-line . port-opt)
  (let ((port (if (null? port-opt)
                  (current-input-port)
                  (car port-opt))))
    (let loop ((chars '()))
      (let ((c (read-char port)))
        (cond
          ((eof-object? c)
           (if (null? chars)
               c
               (list→string (reverse chars))))
          ((char=? c #\newline)
           (list→string (reverse chars)))
          (else
           (loop (cons c chars))))))))

(define (display obj . port-opt)
  (let ((port (if (null? port-opt)
                  (current-output-port)
                  (car port-opt))))
    (cond
      ((string? obj)
       (for-each (lambda (c) (write-char c port))
                 (string→list obj)))
      ((char? obj)
       (write-char obj port))
      ((number? obj)
       (display (number→string obj) port))
      ((boolean? obj)
       (display (if obj "#t" "#f") port))
      ((null? obj)
       (display "()" port))
      ((symbol? obj)
       (display (symbol→string obj) port))
      ((pair? obj)
       (display "(" port)
       (let loop ((lst obj))
         (display (car lst) port)
         (cond
           ((null? (cdr lst))
            (display ")" port))
           ((pair? (cdr lst))
            (display " " port)
            (loop (cdr lst)))
           (else
            (display " . " port)
            (display (cdr lst) port)
            (display ")" port)))))
      ((vector? obj)
       (display "#(" port)
       (let ((len (vector-length obj)))
         (if (> len 0)
             (begin
               (display (vector-ref obj 0) port)
               (let loop ((i 1))
                 (if (< i len)
                     (begin
                       (display " " port)
                       (display (vector-ref obj i) port)
                       (loop (+ i 1)))))))
         (display ")" port)))
      (else
       (display "#<unknown>" port)))))

(define (newline . port-opt)
  (let ((port (if (null? port-opt)
                  (current-output-port)
                  (car port-opt))))
    (write-char #\newline port)))

B.11 Control Structures

(define-syntax when
  (syntax-rules ()
    ((when test body …)
     (if test (begin body …)))))

(define-syntax unless
  (syntax-rules ()
    ((unless test body …)
     (if (not test) (begin body …)))))

(define-syntax cond
  (syntax-rules (else ⇒)
    ((cond (else result …))
     (begin result …))
    ((cond (test ⇒ result))
     (let ((temp test))
       (if temp (result temp))))
    ((cond (test ⇒ result) clause …)
     (let ((temp test))
       (if temp
           (result temp)
           (cond clause …))))
    ((cond (test)) test)
    ((cond (test) clause …)
     (or test (cond clause …)))
    ((cond (test result …))
     (if test (begin result …)))
    ((cond (test result …) clause …)
     (if test
         (begin result …)
         (cond clause …)))))

(define-syntax case
  (syntax-rules (else)
    ((case key (else result …))
     (begin result …))
    ((case key
       ((atoms …) result …)
       clause …)
     (let ((temp key))
       (if (memv temp '(atoms …))
           (begin result …)
           (case temp clause …))))))

(define-syntax let
  (syntax-rules ()
    ((let ((var val) …) body …)
     ((lambda (var …) body …) val …))
    ((let name ((var val) …) body …)
     (letrec ((name (lambda (var …) body …)))
       (name val …)))))

(define-syntax let*
  (syntax-rules ()
    ((let* () body …)
     (begin body …))
    ((let* ((var val) rest …) body …)
     (let ((var val))
       (let* (rest …) body …)))))

(define-syntax letrec
  (syntax-rules ()
    ((letrec ((var val) …) body …)
     (let ((var #f) …)
       (set! var val) …
       (begin body …)))))

B.12 Utility Procedures

(define (identity x) x)

(define (compose f g)
  (lambda (x) (f (g x))))

(define (curry f . args)
  (lambda rest
    (apply f (append args rest))))

(define (negate pred)
  (lambda args
    (not (apply pred args))))

These implementations demonstrate how a rich standard library can be built from a minimal core. Production implementations would include optimizations, error checking, and support for optional arguments not shown here for clarity.

Appendix C: Standard Scheme Libraries (R7RS)

This appendix provides an overview of the standard library system introduced in R7RS and commonly used library modules.

C.1 The Library System

R7RS introduces a module system based on libraries. A library declaration has the form:

(define-library (library-name)
  (export exported-identifiers …)
  (import imported-libraries …)
  (begin
    library-body …))

Example:

(define-library (my-utilities)
  (export square cube)
  (import (scheme base))
  (begin
    (define (square x) (* x x))
    (define (cube x) (* x x x))))

Using a library:

(import (my-utilities))
(square 5)  ; ⇒ 25

C.2 Standard R7RS-Small Libraries

C.2.1 (scheme base)

The fundamental library containing essential procedures and syntax:

Types and Predicates:

  • boolean?, char?, null?, number?, pair?, procedure?, string?, symbol?, vector?

  • bytevector?, port?, input-port?, output-port?

Arithmetic:

  • +, -, *, /, quotient, remainder, modulo

  • =, <, >, ≤, ≥

  • abs, floor, ceiling, truncate, round

  • exact?, inexact?, exact, inexact

Lists:

  • cons, car, cdr, list, length, append, reverse

  • list-ref, list-tail, map, for-each

  • memq, memv, member, assq, assv, assoc

Strings:

  • string, string-length, string-ref, string-append

  • substring, string→list, list→string

  • string=?, string<?, string>?, string≤?, string≥?

Vectors:

  • vector, vector-length, vector-ref, vector-set!

  • make-vector, vector→list, list→vector

I/O:

  • read, write, display, newline

  • read-char, peek-char, write-char

  • open-input-file, open-output-file, close-port

Control:

  • apply, call/cc, values, call-with-values

C.2.2 (scheme case-lambda)

Provides procedures with variable arity:

(define my-add
  (case-lambda
    (() 0)
    ((x) x)
    ((x y) (+ x y))
    ((x y z) (+ x y z))
    (args (apply + args))))

C.2.3 (scheme char)

Extended character operations:

(import (scheme char))

;; Case conversion
(char-upcase #\a)      ; ⇒ #\A
(char-downcase #\Z)    ; ⇒ #\z
(char-foldcase #\A)    ; ⇒ #\a

;; Character predicates
(char-alphabetic? #\a)     ; ⇒ #t
(char-numeric? #\5)        ; ⇒ #t
(char-whitespace? #\space) ; ⇒ #t
(char-upper-case? #\A)     ; ⇒ #t
(char-lower-case? #\z)     ; ⇒ #t

;; String operations
(string-upcase "hello")    ; ⇒ "HELLO"
(string-downcase "WORLD")  ; ⇒ "world"
(string-foldcase "MiXeD")  ; ⇒ "mixed"

C.2.4 (scheme complex)

Complex number operations:

(import (scheme complex))

(make-rectangular 3 4)  ; ⇒ 3+4i
(make-polar 1 0)        ; ⇒ 1.0+0.0i

(real-part 3+4i)        ; ⇒ 3
(imag-part 3+4i)        ; ⇒ 4
(magnitude 3+4i)        ; ⇒ 5.0
(angle 1+1i)            ; ⇒ 0.785… (π/4)

C.2.5 (scheme cxr)

Additional car/cdr combinations:

(import (scheme cxr))

;; Up to 4 levels deep
(caaar lst)   ; (car (car (car lst)))
(caadr lst)   ; (car (car (cdr lst)))
(cadar lst)   ; (car (cdr (car lst)))
;; … and so on through cddddr

C.2.6 (scheme eval)

Dynamic evaluation:

(import (scheme eval))

(define env (environment '(scheme base)))
(eval '(+ 1 2 3) env)  ; ⇒ 6

;; Create custom environment
(define my-env
  (environment '(scheme base)
               '(my-utilities)))

C.2.7 (scheme file)

File operations:

(import (scheme file))

;; File tests
(file-exists? "data.txt")   ; ⇒ #t or #f
(delete-file "temp.txt")

;; Binary I/O with files
(call-with-input-file "data.bin"
  (lambda (port)
    (read-bytevector 100 port)))

(call-with-output-file "output.bin"
  (lambda (port)
    (write-bytevector data port)))

C.2.8 (scheme inexact)

Inexact (floating-point) operations:

(import (scheme inexact))

;; Transcendental functions
(exp 1.0)       ; ⇒ 2.718…
(log 10.0)      ; ⇒ 2.302…
(sin 0.0)       ; ⇒ 0.0
(cos 0.0)       ; ⇒ 1.0
(tan (/ 3.14159 4))  ; ≈ 1.0

;; Power and root
(sqrt 16.0)     ; ⇒ 4.0
(expt 2.0 10)   ; ⇒ 1024.0

;; Special values
(finite? 1.0)     ; ⇒ #t
(infinite? +inf.0) ; ⇒ #t
(nan? +nan.0)     ; ⇒ #t

C.2.9 (scheme lazy)

Delayed evaluation and streams:

(import (scheme lazy))

;; Promises
(define p (delay (+ 1 2)))
(force p)  ; ⇒ 3
(force p)  ; ⇒ 3 (same result, memoized)

;; Lazy evaluation
(define (lazy-range from to)
  (if (> from to)
      '()
      (delay (cons from (lazy-range (+ from 1) to)))))

;; Streams
(define ones (delay (cons 1 ones)))

C.2.10 (scheme load)

Dynamic code loading:

(import (scheme load))

;; Load and evaluate a Scheme file
(load "utilities.scm")

C.2.11 (scheme process-context)

Process environment access:

(import (scheme process-context))

;; Command-line arguments
(command-line)  ; ⇒ ("program" "arg1" "arg2" …)

;; Environment variables
(get-environment-variable "PATH")
(get-environment-variables)  ; ⇒ alist of all env vars

;; Exit
(exit)      ; Exit with code 0
(exit 1)    ; Exit with code 1

C.2.12 (scheme read)

Extended reader:

(import (scheme read))

(read)  ; Read one S-expression from current input port

C.2.13 (scheme repl)

REPL support:

(import (scheme repl))

(interaction-environment)  ; Current REPL environment

C.2.14 (scheme time)

Time operations:

(import (scheme time))

;; Current time as seconds since epoch
(current-second)  ; ⇒ 1697900000.123

;; Get exact milliseconds since epoch  
(current-jiffy)
(jiffies-per-second)

C.2.15 (scheme write)

Extended output:

(import (scheme write))

(display "Hello")    ; Human-readable output
(write "Hello")      ; Machine-readable output
(write-simple obj)   ; Simple write (no cycles)
(write-shared obj)   ; Detect and label shared structure

C.3 Common SRFI Libraries

SRFI-1: List Library

Extended list processing:

(import (srfi 1))

;; Constructors
(iota 5)           ; ⇒ (0 1 2 3 4)
(circular-list 1 2 3)  ; Circular list

;; Predicates
(proper-list? lst)
(circular-list? lst)

;; Selectors
(first lst)        ; car
(second lst)       ; cadr
(take lst 3)       ; First 3 elements
(drop lst 3)       ; All but first 3
(take-right lst 2) ; Last 2 elements

;; Mapping and folding
(fold + 0 '(1 2 3 4))  ; ⇒ 10
(fold-right cons '() '(1 2 3))
(filter even? '(1 2 3 4))  ; ⇒ (2 4)
(partition even? '(1 2 3 4))  ; ⇒ ((2 4) (1 3))

;; Searching
(find even? '(1 3 5 6 7))  ; ⇒ 6
(any even? '(1 3 5))       ; ⇒ #f
(every even? '(2 4 6))     ; ⇒ #t

SRFI-6: Basic String Ports

String I/O ports:

(import (srfi 6))

;; Read from string
(define in (open-input-string "hello world"))
(read in)  ; ⇒ hello

;; Write to string
(define out (open-output-string))
(write 'test out)
(get-output-string out)  ; ⇒ "test"

SRFI-8: receive

Multiple value binding:

(import (srfi 8))

(receive (q r) (quotient/remainder 23 5)
  (list q r))  ; ⇒ (4 3)

SRFI-9: define-record-type

Record types:

(import (srfi 9))

(define-record-type <point>
  (make-point x y)
  point?
  (x point-x)
  (y point-y set-point-y!))

(define p (make-point 1 2))
(point-x p)  ; ⇒ 1
(set-point-y! p 5)

SRFI-13: String Libraries

Comprehensive string operations:

(import (srfi 13))

;; Predicates
(string-null? "")           ; ⇒ #t
(string-prefix? "pre" "prefix")  ; ⇒ #t
(string-suffix? "fix" "prefix")  ; ⇒ #t

;; Searching
(string-contains "hello" "ell")  ; ⇒ 1
(string-index "hello" #\l)       ; ⇒ 2

;; Modification
(string-trim " hello ")     ; ⇒ "hello"
(string-pad "7" 3 #\0)     ; ⇒ "007"
(string-reverse "hello")    ; ⇒ "olleh"

SRFI-18: Multithreading

Thread support (covered extensively in Chapter 20).

SRFI-27: Random Numbers

Random number generation:

(import (srfi 27))

(random-integer 100)     ; Random integer [0, 100)
(random-real)            ; Random real [0.0, 1.0)

;; Set seed for reproducibility
(random-source-randomize! default-random-source)

SRFI-69: Hash Tables

Hash table operations:

(import (srfi 69))

(define ht (make-hash-table))

;; Basic operations
(hash-table-set! ht 'key 'value)
(hash-table-ref ht 'key)  ; ⇒ value
(hash-table-exists? ht 'key)  ; ⇒ #t
(hash-table-delete! ht 'key)

;; Iteration
(hash-table-walk ht
  (lambda (key value)
    (display key) (display " ⇒ ") (display value)
    (newline)))

C.4 Library Import Syntax

;; Import entire library
(import (scheme base))

;; Import with renaming
(import (rename (scheme base)
                (map base-map)))

;; Import only specific bindings
(import (only (scheme base) + - * /))

;; Import except specific bindings  
(import (except (scheme base) map))

;; Import with prefix
(import (prefix (scheme base) base:))

This appendix provides a reference to the standard library ecosystem in modern Scheme implementations, particularly R7RS-small and commonly used SRFIs.

Appendix D: Template for Scheme R7RS Implementation in Java

This appendix provides a complete template for implementing a production-quality R7RS Scheme interpreter in Java, building upon the foundation established in Chapter 22 while incorporating lessons from the Ribbit VM (discussed in the attached literature) and modern Java design patterns.

D.1 Architecture Overview

D.1.1 Design Philosophy

Our implementation follows these principles:

  1. Separation of Concerns: Reader, Evaluator, and Printer are distinct modules

  2. Immutability: Values are immutable once created

  3. Type Safety: Strong typing with Java’s type system

  4. Extensibility: Easy addition of primitives and special forms

  5. Performance: Tail-call optimization and efficient memory management

D.1.2 Module Structure

org.scheme.r7rs/

├│── core/

││ ├── Value.java # Base value interface

││ ├── SchemeNumber.java

││ ├── SchemeBoolean.java

││ ├── SchemeSymbol.java

││ ├── SchemePair.java

││ ├── SchemeVector.java

││ ├── SchemeString.java

││ ├── SchemeChar.java

││ ├── SchemeProcedure.java

││ ├── SchemeClosure.java

││ └── SchemePort.java

├│── env/

││ ├── Environment.java

││ └── GlobalEnvironment.java

├│── eval/

││ ├── Evaluator.java

││ ├── TailCallOptimizer.java

││ └── Continuation.java

├│── read/

││ ├── Reader.java

││ ├── Tokenizer.java

││ └── Token.java

├│── write/

││ └── Writer.java

├│── primitive/

││ ├── PrimitiveRegistry.java

││ ├── ArithmeticPrimitives.java

││ ├── ListPrimitives.java

││ ├── IOPrimitives.java

││ └── TypePredicates.java

├│── library/

││ ├── Library.java

││ ├── LibraryManager.java

││ └── StandardLibraries.java

├│── macro/

││ ├── MacroExpander.java

││ └── SyntaxRules.java └── repl/ └── REPL.java

D.2 Core Value Types

D.2.1 Base Value Interface

package org.scheme.r7rs.core;

/**

 * Base interface for all Scheme values.

 * All Scheme objects implement this interface.

 */
public interface Value {
    /**

     * Returns the type tag of this value.

     */
    String getType();
    
    /**

     * Tests for eqv? equality.

     */
    boolean isEqv(Value other);
    
    /**

     * Tests for equal? equality (structural).

     */
    boolean isEqual(Value other);
    
    /**

     * Returns a human-readable representation.

     */
    String toDisplayString();
    
    /**

     * Returns a machine-readable representation.

     */
    String toWriteString();
    
    /**

     * Returns true if this value is self-evaluating.

     */
    default boolean isSelfEvaluating() {
        return !(this instanceof SchemeSymbol);
    }
}

D.2.2 Scheme Numbers

package org.scheme.r7rs.core;

import java.math.BigInteger;
import java.math.BigDecimal;

/**

 * Represents Scheme numbers (exact and inexact).

 * Supports integers, rationals, reals, and complex numbers.

 */
public abstract class SchemeNumber implements Value {
    
    @Override
    public String getType() {
        return "number";
    }
    
    // Abstract operations
    public abstract SchemeNumber add(SchemeNumber other);
    public abstract SchemeNumber subtract(SchemeNumber other);
    public abstract SchemeNumber multiply(SchemeNumber other);
    public abstract SchemeNumber divide(SchemeNumber other);
    
    public abstract boolean isExact();
    public abstract boolean isZero();
    public abstract boolean isPositive();
    public abstract boolean isNegative();
    
    public abstract int compareTo(SchemeNumber other);
    
    // Factory methods
    public static SchemeNumber fromLong(long value) {
        return new SchemeExactInteger(BigInteger.valueOf(value));
    }
    
    public static SchemeNumber fromDouble(double value) {
        return new SchemeInexactReal(value);
    }
    
    public static SchemeNumber fromBigInteger(BigInteger value) {
        return new SchemeExactInteger(value);
    }
    
    public static SchemeNumber makeRational(long numerator, long denominator) {
        if (denominator ⩵ 0) {
            throw new SchemeException("Division by zero");
        }
        return new SchemeRational(
            BigInteger.valueOf(numerator),
            BigInteger.valueOf(denominator)
        );
    }
    
    public static SchemeNumber makeComplex(double real, double imag) {
        return new SchemeComplex(real, imag);
    }
}

/**

 * Exact integer (arbitrary precision).

 */
class SchemeExactInteger extends SchemeNumber {
    private final BigInteger value;
    
    public SchemeExactInteger(BigInteger value) {
        this.value = value;
    }
    
    @Override
    public SchemeNumber add(SchemeNumber other) {
        if (other instanceof SchemeExactInteger) {
            return new SchemeExactInteger(
                value.add(((SchemeExactInteger) other).value)
            );
        }
        return other.add(this); // Delegate to other type
    }
    
    @Override
    public SchemeNumber multiply(SchemeNumber other) {
        if (other instanceof SchemeExactInteger) {
            return new SchemeExactInteger(
                value.multiply(((SchemeExactInteger) other).value)
            );
        }
        return other.multiply(this);
    }
    
    @Override
    public boolean isExact() {
        return true;
    }
    
    @Override
    public boolean isZero() {
        return value.equals(BigInteger.ZERO);
    }
    
    @Override
    public String toDisplayString() {
        return value.toString();
    }
    
    @Override
    public String toWriteString() {
        return value.toString();
    }
    
    @Override
    public boolean isEqv(Value other) {
        return other instanceof SchemeExactInteger ∧
               value.equals(((SchemeExactInteger) other).value);
    }
    
    // Additional methods omitted for brevity
}

/**

 * Inexact real (double precision).

 */
class SchemeInexactReal extends SchemeNumber {
    private final double value;
    
    public SchemeInexactReal(double value) {
        this.value = value;
    }
    
    @Override
    public SchemeNumber add(SchemeNumber other) {
        return new SchemeInexactReal(value + other.toInexact());
    }
    
    @Override
    public boolean isExact() {
        return false;
    }
    
    public double toInexact() {
        return value;
    }
    
    @Override
    public String toDisplayString() {
        if (Double.isInfinite(value)) {
            return value > 0 ? "+inf.0" : "-inf.0";
        }
        if (Double.isNaN(value)) {
            return "+nan.0";
        }
        return Double.toString(value);
    }
    
    // Additional methods omitted
}

/**

 * Exact rational number.

 */
class SchemeRational extends SchemeNumber {
    private final BigInteger numerator;
    private final BigInteger denominator;
    
    public SchemeRational(BigInteger num, BigInteger den) {
        // Normalize: reduce and ensure denominator is positive
        BigInteger gcd = num.gcd(den);
        this.numerator = num.divide(gcd).multiply(
            den.signum() < 0 ? BigInteger.valueOf(-1) : BigInteger.ONE
        );
        this.denominator = den.abs().divide(gcd);
    }
    
    @Override
    public SchemeNumber add(SchemeNumber other) {
        if (other instanceof SchemeRational) {
            SchemeRational r = (SchemeRational) other;
            BigInteger newNum = numerator.multiply(r.denominator)
                               .add(r.numerator.multiply(denominator));
            BigInteger newDen = denominator.multiply(r.denominator);
            return new SchemeRational(newNum, newDen);
        }
        return super.add(other);
    }
    
    @Override
    public boolean isExact() {
        return true;
    }
    
    @Override
    public String toDisplayString() {
        return numerator + "/" + denominator;
    }
    
    // Additional methods omitted
}

/**

 * Complex number (real + imaginary).

 */
class SchemeComplex extends SchemeNumber {
    private final double real;
    private final double imag;
    
    public SchemeComplex(double real, double imag) {
        this.real = real;
        this.imag = imag;
    }
    
    @Override
    public SchemeNumber add(SchemeNumber other) {
        if (other instanceof SchemeComplex) {
            SchemeComplex c = (SchemeComplex) other;
            return new SchemeComplex(real + c.real, imag + c.imag);
        }
        return new SchemeComplex(real + other.toInexact(), imag);
    }
    
    @Override
    public boolean isExact() {
        return false;
    }
    
    @Override
    public String toDisplayString() {
        if (imag ≥ 0) {
            return real + "+" + imag + "i";
        }
        return real + "" + imag + "i";
    }
    
    public double magnitude() {
        return Math.sqrt(real * real + imag * imag);
    }
    
    public double angle() {
        return Math.atan2(imag, real);
    }
    
    // Additional methods omitted
}

D.2.3 Scheme Pairs and Lists

package org.scheme.r7rs.core;

import java.util.ArrayList;
import java.util.List;

/**

 * Represents a Scheme pair (cons cell).

 * Immutable after construction.

 */
public final class SchemePair implements Value {
    private final Value car;
    private final Value cdr;
    
    public SchemePair(Value car, Value cdr) {
        if (car ⩵ null ∨ cdr ⩵ null) {
            throw new IllegalArgumentException("Pair components cannot be null");
        }
        this.car = car;
        this.cdr = cdr;
    }
    
    public Value getCar() {
        return car;
    }
    
    public Value getCdr() {
        return cdr;
    }
    
    @Override
    public String getType() {
        return "pair";
    }
    
    /**

     * Tests if this is a proper list.

     */
    public boolean isProperList() {
        Value current = this;
        while (current instanceof SchemePair) {
            current = ((SchemePair) current).cdr;
        }
        return current ⩵ SchemeNull.getInstance();
    }
    
    /**

     * Returns the length if proper list, -1 otherwise.

     */
    public int length() {
        if (!isProperList()) {
            return -1;
        }
        int len = 0;
        Value current = this;
        while (current instanceof SchemePair) {
            len⧺;
            current = ((SchemePair) current).cdr;
        }
        return len;
    }
    
    /**

     * Converts to Java List (if proper list).

     */
    public List<Value> toJavaList() {
        if (!isProperList()) {
            throw new SchemeException("Not a proper list");
        }
        List<Value> result = new ArrayList⋄();
        Value current = this;
        while (current instanceof SchemePair) {
            result.add(((SchemePair) current).car);
            current = ((SchemePair) current).cdr;
        }
        return result;
    }
    
    /**

     * Creates a Scheme list from Java values.

     */
    public static Value fromJavaList(List<Value> values) {
        Value result = SchemeNull.getInstance();
        for (int i = values.size() - 1; i ≥ 0; i--) {
            result = new SchemePair(values.get(i), result);
        }
        return result;
    }
    
    @Override
    public boolean isEqv(Value other) {
        // Pairs are eqv? only if they are the same object
        return this ⩵ other;
    }
    
    @Override
    public boolean isEqual(Value other) {
        if (!(other instanceof SchemePair)) {
            return false;
        }
        SchemePair otherPair = (SchemePair) other;
        return car.isEqual(otherPair.car) ∧ cdr.isEqual(otherPair.cdr);
    }
    
    @Override
    public String toDisplayString() {
        return toWriteString();
    }
    
    @Override
    public String toWriteString() {
        StringBuilder sb = new StringBuilder("(");
        Value current = this;
        
        while (current instanceof SchemePair) {
            SchemePair pair = (SchemePair) current;
            sb.append(pair.car.toWriteString());
            current = pair.cdr;
            
            if (current instanceof SchemePair) {
                sb.append(" ");
            } else if (current ≠ SchemeNull.getInstance()) {
                sb.append(" . ");
                sb.append(current.toWriteString());
            }
        }
        
        sb.append(")");
        return sb.toString();
    }
}

/**

 * Represents the empty list '().

 * Singleton pattern.

 */
public final class SchemeNull implements Value {
    private static final SchemeNull INSTANCE = new SchemeNull();
    
    private SchemeNull() {}
    
    public static SchemeNull getInstance() {
        return INSTANCE;
    }
    
    @Override
    public String getType() {
        return "null";
    }
    
    @Override
    public boolean isEqv(Value other) {
        return other ⩵ this;
    }
    
    @Override
    public boolean isEqual(Value other) {
        return other ⩵ this;
    }
    
    @Override
    public String toDisplayString() {
        return "()";
    }
    
    @Override
    public String toWriteString() {
        return "()";
    }
}

D.2.4 Scheme Symbols

package org.scheme.r7rs.core;

import java.util.concurrent.ConcurrentHashMap;

/**

 * Represents a Scheme symbol.

 * Symbols are interned for efficient comparison.

 */
public final class SchemeSymbol implements Value {
    private final String name;
    
    // Symbol table for interning
    private static final ConcurrentHashMap<String, SchemeSymbol> symbolTable =
        new ConcurrentHashMap⋄();
    
    private SchemeSymbol(String name) {
        this.name = name;
    }
    
    /**

     * Returns the interned symbol with the given name.

     */
    public static SchemeSymbol intern(String name) {
        return symbolTable.computeIfAbsent(name, SchemeSymbol∷new);
    }
    
    public String getName() {
        return name;
    }
    
    @Override
    public String getType() {
        return "symbol";
    }
    
    @Override
    public boolean isEqv(Value other) {
        // Interned symbols can use identity comparison
        return this ⩵ other;
    }
    
    @Override
    public boolean isEqual(Value other) {
        return this ⩵ other;
    }
    
    @Override
    public boolean isSelfEvaluating() {
        return false;
    }
    
    @Override
    public String toDisplayString() {
        return name;
    }
    
    @Override
    public String toWriteString() {
        // Handle symbols that need escaping
        if (needsEscaping(name)) {
            return "|" + escapeSymbol(name) + "|";
        }
        return name;
    }
    
    private boolean needsEscaping(String name) {
        // Check if symbol contains special characters
        return name.contains(" ") ∨ name.contains("|") ∨ 
               name.contains("(") ∨ name.contains(")");
    }
    
    private String escapeSymbol(String name) {
        return name.replace("\\", "\\\\").replace("|", "\\|");
    }
}

D.2.5 Scheme Procedures

package org.scheme.r7rs.core;

import org.scheme.r7rs.env.Environment;
import java.util.List;

/**

 * Base interface for all Scheme procedures.

 */
public interface SchemeProcedure extends Value {
    
    /**

     * Applies this procedure to the given arguments.

     * Returns a Value or a TailCall.

     */
    Object apply(List<Value> args, Environment env);
    
    /**

     * Returns the arity of this procedure.

     * Returns -1 for variable arity.

     */
    int getArity();
    
    /**

     * Returns true if this procedure accepts variable arguments.

     */
    boolean isVariadic();
    
    @Override
    default String getType() {
        return "procedure";
    }
    
    @Override
    default boolean isSelfEvaluating() {
        return true;
    }
}

/**

 * Represents a primitive procedure (built-in).

 */
public final class SchemePrimitive implements SchemeProcedure {
    private final String name;
    private final int arity;
    private final boolean variadic;
    private final PrimitiveFunction function;
    
    @FunctionalInterface
    public interface PrimitiveFunction {
        Value apply(List<Value> args);
    }
    
    public SchemePrimitive(String name, int arity, PrimitiveFunction function) {
        this(name, arity, false, function);
    }
    
    public SchemePrimitive(String name, int arity, boolean variadic,
                          PrimitiveFunction function) {
        this.name = name;
        this.arity = arity;
        this.variadic = variadic;
        this.function = function;
    }
    
    @Override
    public Object apply(List<Value> args, Environment env) {
        // Check arity
        if (!variadic ∧ args.size() ≠ arity) {
            throw new SchemeException(
                name + ": expected " + arity + " arguments, got " + args.size()
            );
        }
        if (variadic ∧ args.size() < arity) {
            throw new SchemeException(
                name + ": expected at least " + arity + " arguments, got " + 
                args.size()
            );
        }
        
        return function.apply(args);
    }
    
    @Override
    public int getArity() {
        return arity;
    }
    
    @Override
    public boolean isVariadic() {
        return variadic;
    }
    
    @Override
    public String toDisplayString() {
        return "#<primitive:" + name + ">";
    }
    
    @Override
    public String toWriteString() {
        return toDisplayString();
    }
    
    @Override
    public boolean isEqv(Value other) {
        return this ⩵ other;
    }
    
    @Override
    public boolean isEqual(Value other) {
        return this ⩵ other;
    }
}

/**

 * Represents a user-defined closure.

 */
public final class SchemeClosure implements SchemeProcedure {
    private final List<SchemeSymbol> parameters;
    private final SchemeSymbol restParameter; // null if not variadic
    private final Value body;
    private final Environment definitionEnv;
    
    public SchemeClosure(List<SchemeSymbol> parameters,
                        SchemeSymbol restParameter,
                        Value body,
                        Environment definitionEnv) {
        this.parameters = parameters;
        this.restParameter = restParameter;
        this.body = body;
        this.definitionEnv = definitionEnv;
    }
    
    @Override
    public Object apply(List<Value> args, Environment callEnv) {
        // Check arity
        int requiredArgs = parameters.size();
        if (restParameter ⩵ null ∧ args.size() ≠ requiredArgs) {
            throw new SchemeException(
                "Expected " + requiredArgs + " arguments, got " + args.size()
            );
        }
        if (restParameter ≠ null ∧ args.size() < requiredArgs) {
            throw new SchemeException(
                "Expected at least " + requiredArgs + " arguments, got " + 
                args.size()
            );
        }
        
        // Create new environment extending definition environment
        Environment env = new Environment(definitionEnv);
        
        // Bind required parameters
        for (int i = 0; i < parameters.size(); i⧺) {
            env.define(parameters.get(i), args.get(i));
        }
        
        // Bind rest parameter if variadic
        if (restParameter ≠ null) {
            List<Value> restArgs = args.subList(parameters.size(), args.size());
            env.define(restParameter, SchemePair.fromJavaList(restArgs));
        }
        
        // Return tail call for evaluation
        return new TailCall(body, env);
    }
    
    @Override
    public int getArity() {
        return parameters.size();
    }
    
    @Override
    public boolean isVariadic() {
        return restParameter ≠ null;
    }
    
    @Override
    public String toDisplayString() {
        return "#<closure>";
    }
    
    @Override
    public String toWriteString() {
        return toDisplayString();
    }
    
    @Override
    public boolean isEqv(Value other) {
        return this ⩵ other;
    }
    
    @Override
    public boolean isEqual(Value other) {
        return this ⩵ other;
    }
}

D.3 Environment Management

package org.scheme.r7rs.env;

import org.scheme.r7rs.core.*;
import java.util.HashMap;
import java.util.Map;

/**

 * Represents a lexical environment for variable bindings.

 */
public class Environment {
    private final Environment parent;
    private final Map<SchemeSymbol, Value> bindings;
    
    /**

     * Creates a new environment with the given parent.

     */
    public Environment(Environment parent) {
        this.parent = parent;
        this.bindings = new HashMap⋄();
    }
    
    /**

     * Creates a top-level environment.

     */
    public Environment() {
        this(null);
    }
    
    /**

     * Defines a new binding in this environment.

     */
    public void define(SchemeSymbol symbol, Value value) {
        bindings.put(symbol, value);
    }
    
    /**

     * Sets an existing binding (searches up the environment chain).

     */
    public void set(SchemeSymbol symbol, Value value) {
        if (bindings.containsKey(symbol)) {
            bindings.put(symbol, value);
        } else if (parent ≠ null) {
            parent.set(symbol, value);
        } else {
            throw new SchemeException("Undefined variable: " + symbol.getName());
        }
    }
    
    /**

     * Looks up a variable's value.

     */
    public Value lookup(SchemeSymbol symbol) {
        if (bindings.containsKey(symbol)) {
            return bindings.get(symbol);
        } else if (parent ≠ null) {
            return parent.lookup(symbol);
        } else {
            throw new SchemeException("Undefined variable: " + symbol.getName());
        }
    }
    
    /**

     * Tests if a variable is defined.

     */
    public boolean isDefined(SchemeSymbol symbol) {
        return bindings.containsKey(symbol) ∨ 
               (parent ≠ null ∧ parent.isDefined(symbol));
    }
    
    /**

     * Returns the parent environment.

     */
    public Environment getParent() {
        return parent;
    }
}

D.4 The Evaluator with Tail Call Optimization

package org.scheme.r7rs.eval;

import org.scheme.r7rs.core.*;
import org.scheme.r7rs.env.Environment;
import java.util.ArrayList;
import java.util.List;

/**

 * Represents a tail call to be evaluated.

 */
class TailCall {
    final Value expression;
    final Environment environment;
    
    TailCall(Value expression, Environment environment) {
        this.expression = expression;
        this.environment = environment;
    }
}

/**

 * The main Scheme evaluator with tail call optimization.

 */
public class Evaluator {
    
    /**

     * Evaluates an expression in the given environment.

     */
    public static Value eval(Value expr, Environment env) {
        Object result = expr;
        Environment currentEnv = env;
        
        // Trampoline loop for tail call optimization
        while (result instanceof TailCall) {
            TailCall tc = (TailCall) result;
            result = evalOnce(tc.expression, tc.environment);
            currentEnv = tc.environment;
        }
        
        return (Value) result;
    }
    
    /**

     * Evaluates an expression once (may return TailCall).

     */
    private static Object evalOnce(Value expr, Environment env) {
        // Self-evaluating expressions
        if (expr.isSelfEvaluating()) {
            return expr;
        }
        
        // Variable lookup
        if (expr instanceof SchemeSymbol) {
            return env.lookup((SchemeSymbol) expr);
        }
        
        // Must be a list (application or special form)
        if (!(expr instanceof SchemePair)) {
            throw new SchemeException("Invalid expression: " + expr);
        }
        
        SchemePair pair = (SchemePair) expr;
        Value operator = pair.getCar();
        
        // Check for special forms
        if (operator instanceof SchemeSymbol) {
            String name = ((SchemeSymbol) operator).getName();
            
            switch (name) {
                case "quote":
                    return evalQuote(pair, env);
                case "if":
                    return evalIf(pair, env);
                case "lambda":
                    return evalLambda(pair, env);
                case "define":
                    return evalDefine(pair, env);
                case "set!":
                    return evalSet(pair, env);
                case "begin":
                    return evalBegin(pair, env);
                case "let":
                    return evalLet(pair, env);
                case "cond":
                    return evalCond(pair, env);
            }
        }
        
        // Procedure application
        return evalApplication(pair, env);
    }
    
    /**

     * (quote datum)

     */
    private static Value evalQuote(SchemePair expr, Environment env) {
        List<Value> args = expr.toJavaList();
        if (args.size() ≠ 2) {
            throw new SchemeException("quote: expects 1 argument");
        }
        return args.get(1);
    }
    
    /**

     * (if test consequent alternate)

     */
    private static Object evalIf(SchemePair expr, Environment env) {
        List<Value> args = expr.toJavaList();
        if (args.size() ≠ 3 ∧ args.size() ≠ 4) {
            throw new SchemeException(
                "if: expects 2 or 3 arguments, got " + (args.size() - 1)
            );
        }
        
        Value testResult = eval(args.get(1), env);
        
        if (isTrue(testResult)) {
            // Tail call to consequent
            return new TailCall(args.get(2), env);
        } else {
            if (args.size() ⩵ 4) {
                // Tail call to alternate
                return new TailCall(args.get(3), env);
            } else {
                return SchemeBoolean.FALSE;
            }
        }
    }
    
    /**

     * (lambda (params) body)

     * (lambda (param1 . rest) body)

     */
    private static Value evalLambda(SchemePair expr, Environment env) {
        List<Value> parts = expr.toJavaList();
        if (parts.size() < 3) {
            throw new SchemeException("lambda: malformed");
        }
        
        Value paramSpec = parts.get(1);
        List<SchemeSymbol> params = new ArrayList⋄();
        SchemeSymbol restParam = null;
        
        // Parse parameter list
        if (paramSpec ⩵ SchemeNull.getInstance()) {
            // No parameters
        } else if (paramSpec instanceof SchemeSymbol) {
            // Single rest parameter
            restParam = (SchemeSymbol) paramSpec;
        } else if (paramSpec instanceof SchemePair) {
            SchemePair paramList = (SchemePair) paramSpec;
            
            // Parse proper or improper list
            Value current = paramList;
            while (current instanceof SchemePair) {
                SchemePair pair = (SchemePair) current;
                if (!(pair.getCar() instanceof SchemeSymbol)) {
                    throw new SchemeException("lambda: parameter must be symbol");
                }
                params.add((SchemeSymbol) pair.getCar());
                current = pair.getCdr();
            }
            
            if (current ≠ SchemeNull.getInstance()) {
                // Improper list - rest parameter
                if (!(current instanceof SchemeSymbol)) {
                    throw new SchemeException("lambda: rest parameter must be symbol");
                }
                restParam = (SchemeSymbol) current;
            }
        } else {
            throw new SchemeException("lambda: invalid parameter list");
        }
        
        // Body is remaining expressions wrapped in begin
        List<Value> bodyExprs = parts.subList(2, parts.size());
        Value body = bodyExprs.size() ⩵ 1 ? 
            bodyExprs.get(0) : 
            SchemePair.fromJavaList(
                List.of(SchemeSymbol.intern("begin"), 
                       SchemePair.fromJavaList(bodyExprs))
            );
        
        return new SchemeClosure(params, restParam, body, env);
    }
    
    /**

     * (define name value) or (define (name params) body)

     */
    private static Value evalDefine(SchemePair expr, Environment env) {
        List<Value> parts = expr.toJavaList();
        if (parts.size() < 3) {
            throw new SchemeException("define: malformed");
        }
        
        Value first = parts.get(1);
        
        if (first instanceof SchemeSymbol) {
            // (define name value)
            SchemeSymbol name = (SchemeSymbol) first;
            Value value = eval(parts.get(2), env);
            env.define(name, value);
            return SchemeSymbol.intern("ok");
        } else if (first instanceof SchemePair) {
            // (define (name params) body) ⇒ (define name (lambda (params) body))
            SchemePair nameAndParams = (SchemePair) first;
            SchemeSymbol name = (SchemeSymbol) nameAndParams.getCar();
            Value params = nameAndParams.getCdr();
            
            List<Value> lambdaExpr = new ArrayList⋄();
            lambdaExpr.add(SchemeSymbol.intern("lambda"));
            lambdaExpr.add(params);
            lambdaExpr.addAll(parts.subList(2, parts.size()));
            
            Value lambda = eval(SchemePair.fromJavaList(lambdaExpr), env);
            env.define(name, lambda);
            return SchemeSymbol.intern("ok");
        } else {
            throw new SchemeException("define: invalid syntax");
        }
    }
    
    /**

     * (set! name value)

     */
    private static Value evalSet(SchemePair expr, Environment env) {
        List<Value> args = expr.toJavaList();
        if (args.size() ≠ 3) {
            throw new SchemeException("set!: expects 2 arguments");
        }
        
        if (!(args.get(1) instanceof SchemeSymbol)) {
            throw new SchemeException("set!: first argument must be symbol");
        }
        
        SchemeSymbol name = (SchemeSymbol) args.get(1);
        Value value = eval(args.get(2), env);
        env.set(name, value);
        return SchemeSymbol.intern("ok");
    }
    
    /**

     * (begin expr1 expr2 …)

     */
    private static Object evalBegin(SchemePair expr, Environment env) {
        List<Value> exprs = expr.toJavaList();
        if (exprs.size() < 2) {
            throw new SchemeException("begin: expects at least 1 expression");
        }
        
        // Evaluate all but last
        for (int i = 1; i < exprs.size() - 1; i⧺) {
            eval(exprs.get(i), env);
        }
        
        // Tail call to last expression
        return new TailCall(exprs.get(exprs.size() - 1), env);
    }
    
    /**

     * Procedure application

     */
    private static Object evalApplication(SchemePair expr, Environment env) {
        List<Value> elements = expr.toJavaList();
        
        // Evaluate operator
        Value operator = eval(elements.get(0), env);
        
        if (!(operator instanceof SchemeProcedure)) {
            throw new SchemeException("Not a procedure: " + operator);
        }
        
        // Evaluate arguments
        List<Value> args = new ArrayList⋄();
        for (int i = 1; i < elements.size(); i⧺) {
            args.add(eval(elements.get(i), env));
        }
        
        // Apply procedure
        SchemeProcedure proc = (SchemeProcedure) operator;
        return proc.apply(args, env);
    }
    
    private static boolean isTrue(Value value) {
        return !(value instanceof SchemeBoolean ∧ 
                 !((SchemeBoolean) value).getValue());
    }
}

This template provides the foundation for a complete R7RS Scheme implementation in Java. The remaining appendices would cover:

  • The Reader/Parser

  • Standard primitives

  • Library system

  • Macro expander

  • REPL

Would you like me to continue with any specific section?

Appendix E: Template for Scheme R7RS Implementation in D

This appendix provides a complete template for implementing a production-quality R7RS Scheme interpreter in D, leveraging D’s powerful metaprogramming capabilities, ranges, and modern systems programming features.

E.1 Architecture Overview

E.1.1 Design Philosophy

Our D implementation exploits the following D language features:

  1. Algebraic Data Types: Using D’s union and tagged union patterns

  2. Compile-Time Function Execution (CTFE): For macro expansion and optimization

  3. Templates and Mixins: For extensible primitive generation

  4. Memory Safety: Using @safe, @trusted, and garbage collection

  5. Ranges: For lazy evaluation and efficient list processing

  6. Pattern Matching: Via D’s final switch and type introspection

E.1.2 Module Structure

scheme_r7rs/

├│── core/

││   ├── value.d              // Value type definitions

││   ├── number.d             // Numeric tower

││   ├── pair.d               // Pairs and lists

││   ├── symbol.d             // Symbol interning

││   ├── procedure.d          // Procedures and closures

││   ├── vector.d             // Vectors

││   ├── string.d             // Scheme strings

││   └── port.d               // I/O ports

├│── env/

││   ├── environment.d        // Environment management

││   └── global.d             // Global environment

├│── eval/

││   ├── evaluator.d          // Main evaluator

││   ├── tailcall.d           // Tail call optimization

││   └── continuation.d       // First-class continuations

├│── read/

││   ├── reader.d             // S-expression reader

││   ├── tokenizer.d          // Lexical analysis

││   └── token.d              // Token types

├│── write/

││   └── writer.d             // Output formatting

├│── primitive/

││   ├── registry.d           // Primitive registration

││   ├── arithmetic.d         // Numeric operations

││   ├── list.d               // List operations

││   ├── io.d                 // I/O primitives

││   └── predicates.d         // Type predicates

├│── library/

││   ├── library.d            // Library system

││   ├── manager.d            // Library loading

││   └── standard.d           // R7RS standard libraries

├│── macro/

││   ├── expander.d           // Macro expansion

││   └── syntaxrules.d        // syntax-rules implementation
└── repl/
    └── repl.d               // Read-Eval-Print Loop

E.2 Core Value Types

E.2.1 Base Value Type Using Tagged Union

module scheme_r7rs.core.value;

import std.variant;
import std.bigint;
import std.typecons;

/**

 * The base Scheme value type using D's Algebraic type.

 * This provides efficient tagged union with exhaustive pattern matching.

 */
 Value = Algebraic!(
    SchemeNull,
    SchemeBoolean,
    SchemeNumber,
    SchemeChar,
    SchemeString,
    SchemeSymbol,
    SchemePair,
    SchemeVector,
    SchemeProcedure,
    SchemePort,
    SchemeContinuation
);

/**

 * Null type (empty list '())

 */
 SchemeNull {
    // Singleton - no data needed
    
    string toString() const pure nothrow @safe {
        return "()";
    }
    
    bool opEquals(const SchemeNull other) const pure nothrow @safe {
        return true;
    }
}

/**

 * Boolean type

 */
 SchemeBoolean {
    bool value;
    
    this(bool v) pure nothrow @safe @nogc {
        value = v;
    }
    
    string toString() const pure nothrow @safe {
        return value ? "#t" : "#f";
    }
}

/**

 * Character type

 */
 SchemeChar {
    dchar value;
    
    this(dchar c) pure nothrow @safe @nogc {
        value = c;
    }
    
    string toString() const pure @safe {
        import std.format : format;
        
        // Special character names
        switch (value) {
            case ' ': return "#\\space";
            case '\n': return "#\\newline";
            case '\t': return "#\\tab";
            case '\r': return "#\\return";
            default:
                if (value < 32 ∨ value > 126) {
                    return format("#\\x%x", cast(uint)value);
                }
                return format("#\\%c", value);
        }
    }
}

/**

 * String type (immutable UTF-8)

 */
 SchemeString {
    private string data;
    
    this(string s) pure nothrow @safe {
        data = s;
    }
    
    string getValue() const pure nothrow @safe @nogc {
        return data;
    }
    
    size_t length() const pure @safe {
        import std.utf : count;
        return data.count;
    }
    
    dchar opIndex(size_t i) const @safe {
        import std.utf : decode;
        size_t idx = 0;
        size_t charIdx = 0;
        while (idx < data.length ∧ charIdx < i) {
            decode(data, idx);
            charIdx⧺;
        }
        return decode(data, idx);
    }
    
    string toString() const pure nothrow @safe {
        import std.array : replace;
        return `"` ~ data.replace(`"`, `\"`) ~ `"`;
    }
    
    string toDisplay() const pure nothrow @safe @nogc {
        return data;
    }
}

E.2.2 Scheme Numbers with Full Numeric Tower

module scheme_r7rs.core.number;

import std.bigint;
import std.math;
import std.traits;
import std.conv;

/**

 * Scheme number - supports full numeric tower:

 * - Exact integers (arbitrary precision)

 * - Exact rationals

 * - Inexact reals (double)

 * - Complex numbers

 */
 SchemeNumber {
    private NumberData data;
    
    private  NumberData {
        ExactInteger exactInt;
        Rational rational;
        InexactReal inexactReal;
        Complex complex;
    }
    
    private  Type {
        ExactInteger,
        Rational,
        InexactReal,
        Complex
    }
    
    private Type type;
    
    // Factory methods
    static SchemeNumber fromLong(long value) pure nothrow @safe {
        SchemeNumber num;
        num.type = Type.ExactInteger;
        num.data.exactInt = ExactInteger(BigInt(value));
        return num;
    }
    
    static SchemeNumber fromBigInt(BigInt value) pure nothrow @safe {
        SchemeNumber num;
        num.type = Type.ExactInteger;
        num.data.exactInt = ExactInteger(value);
        return num;
    }
    
    static SchemeNumber fromDouble(double value) pure nothrow @safe @nogc {
        SchemeNumber num;
        num.type = Type.InexactReal;
        num.data.inexactReal = InexactReal(value);
        return num;
    }
    
    static SchemeNumber makeRational(long numerator, long denominator) pure @safe {
        if (denominator ⩵ 0) {
            throw new SchemeException("Division by zero");
        }
        SchemeNumber num;
        num.type = Type.Rational;
        num.data.rational = Rational(BigInt(numerator), BigInt(denominator));
        return num;
    }
    
    static SchemeNumber makeComplex(double real, double imag) pure nothrow @safe @nogc {
        SchemeNumber num;
        num.type = Type.Complex;
        num.data.complex = Complex(real, imag);
        return num;
    }
    
    // Type predicates
    bool isExact() const pure nothrow @safe @nogc {
        return type ⩵ Type.ExactInteger ∨ type ⩵ Type.Rational;
    }
    
    bool isInexact() const pure nothrow @safe @nogc {
        return !isExact();
    }
    
    bool isInteger() const pure nothrow @safe @nogc {
        final switch (type) {
            case Type.ExactInteger:
                return true;
            case Type.Rational:
                return data.rational.denominator ⩵ BigInt(1);
            case Type.InexactReal:
                return data.inexactReal.value ⩵ floor(data.inexactReal.value);
            case Type.Complex:
                return data.complex.imag ⩵ 0.0 ∧ 
                       data.complex.real ⩵ floor(data.complex.real);
        }
    }
    
    bool isZero() const pure nothrow @safe @nogc {
        final switch (type) {
            case Type.ExactInteger:
                return data.exactInt.value ⩵ 0;
            case Type.Rational:
                return data.rational.numerator ⩵ 0;
            case Type.InexactReal:
                return data.inexactReal.value ⩵ 0.0;
            case Type.Complex:
                return data.complex.real ⩵ 0.0 ∧ data.complex.imag ⩵ 0.0;
        }
    }
    
    bool isPositive() const pure nothrow @safe @nogc {
        final switch (type) {
            case Type.ExactInteger:
                return data.exactInt.value > 0;
            case Type.Rational:
                return data.rational.numerator > 0;
            case Type.InexactReal:
                return data.inexactReal.value > 0.0;
            case Type.Complex:
                throw new SchemeException("positive?: not applicable to complex numbers");
        }
    }
    
    // Arithmetic operations
    SchemeNumber opBinary(string op)(SchemeNumber rhs) const pure @safe {
        static if (op ⩵ "+") {
            return add(rhs);
        } else static if (op ⩵ "-") {
            return subtract(rhs);
        } else static if (op ⩵ "*") {
            return multiply(rhs);
        } else static if (op ⩵ "/") {
            return divide(rhs);
        } else {
            static assert(0, "Unsupported operation: " ~ op);
        }
    }
    
    private SchemeNumber add(SchemeNumber rhs) const pure @safe {
        // Promote to common type
        if (type ⩵ Type.Complex ∨ rhs.type ⩵ Type.Complex) {
            return addComplex(rhs);
        }
        if (type ⩵ Type.InexactReal ∨ rhs.type ⩵ Type.InexactReal) {
            return addInexact(rhs);
        }
        if (type ⩵ Type.Rational ∨ rhs.type ⩵ Type.Rational) {
            return addRational(rhs);
        }
        return addExact(rhs);
    }
    
    private SchemeNumber addExact(SchemeNumber rhs) const pure nothrow @safe {
        assert(type ⩵ Type.ExactInteger ∧ rhs.type ⩵ Type.ExactInteger);
        return SchemeNumber.fromBigInt(
            data.exactInt.value + rhs.data.exactInt.value
        );
    }
    
    private SchemeNumber addRational(SchemeNumber rhs) const pure @safe {
        auto lhsRat = toRational();
        auto rhsRat = rhs.toRational();
        
        // a/b + c/d = (ad + bc) / bd
        BigInt newNum = lhsRat.numerator * rhsRat.denominator + 
                       rhsRat.numerator * lhsRat.denominator;
        BigInt newDen = lhsRat.denominator * rhsRat.denominator;
        
        SchemeNumber result;
        result.type = Type.Rational;
        result.data.rational = Rational(newNum, newDen);
        return result.normalizeRational();
    }
    
    private SchemeNumber addInexact(SchemeNumber rhs) const pure nothrow @safe @nogc {
        return SchemeNumber.fromDouble(toInexact() + rhs.toInexact());
    }
    
    private SchemeNumber addComplex(SchemeNumber rhs) const pure nothrow @safe @nogc {
        auto lhsC = toComplex();
        auto rhsC = rhs.toComplex();
        return SchemeNumber.makeComplex(
            lhsC.real + rhsC.real,
            lhsC.imag + rhsC.imag
        );
    }
    
    // Comparison
    int opCmp(SchemeNumber rhs) const pure @safe {
        if (type ⩵ Type.Complex ∨ rhs.type ⩵ Type.Complex) {
            throw new SchemeException("Cannot compare complex numbers");
        }
        
        // Convert to common type for comparison
        if (type ⩵ Type.InexactReal ∨ rhs.type ⩵ Type.InexactReal) {
            double l = toInexact();
            double r = rhs.toInexact();
            if (l < r) return -1;
            if (l > r) return 1;
            return 0;
        }
        
        auto lhsRat = toRational();
        auto rhsRat = rhs.toRational();
        
        // Compare a/b with c/d: ad ⇔ bc
        BigInt left = lhsRat.numerator * rhsRat.denominator;
        BigInt right = rhsRat.numerator * lhsRat.denominator;
        
        if (left < right) return -1;
        if (left > right) return 1;
        return 0;
    }
    
    // Conversion helpers
    private Rational toRational() const pure nothrow @safe {
        final switch (type) {
            case Type.ExactInteger:
                return Rational(data.exactInt.value, BigInt(1));
            case Type.Rational:
                return data.rational;
            case Type.InexactReal:
            case Type.Complex:
                assert(0, "Cannot convert inexact to rational");
        }
    }
    
    private double toInexact() const pure nothrow @safe @nogc {
        final switch (type) {
            case Type.ExactInteger:
                return data.exactInt.value.toLong().to!double;
            case Type.Rational:
                return data.rational.numerator.toLong().to!double / 
                       data.rational.denominator.toLong().to!double;
            case Type.InexactReal:
                return data.inexactReal.value;
            case Type.Complex:
                return data.complex.real;
        }
    }
    
    private Complex toComplex() const pure nothrow @safe @nogc {
        final switch (type) {
            case Type.Complex:
                return data.complex;
            case Type.ExactInteger:
            case Type.Rational:
            case Type.InexactReal:
                return Complex(toInexact(), 0.0);
        }
    }
    
    private SchemeNumber normalizeRational() const pure @safe {
        assert(type ⩵ Type.Rational);
        
        // Simplify: gcd(numerator, denominator)
        BigInt g = gcd(data.rational.numerator, data.rational.denominator);
        BigInt num = data.rational.numerator / g;
        BigInt den = data.rational.denominator / g;
        
        // Ensure denominator is positive
        if (den < 0) {
            num = -num;
            den = -den;
        }
        
        // Convert to integer if denominator is 1
        if (den ⩵ 1) {
            return SchemeNumber.fromBigInt(num);
        }
        
        SchemeNumber result;
        result.type = Type.Rational;
        result.data.rational = Rational(num, den);
        return result;
    }
    
    string toString() const pure @safe {
        final switch (type) {
            case Type.ExactInteger:
                return data.exactInt.value.toDecimalString();
            case Type.Rational:
                return data.rational.numerator.toDecimalString() ~ "/" ~ 
                       data.rational.denominator.toDecimalString();
            case Type.InexactReal:
                double val = data.inexactReal.value;
                if (isInfinity(val)) {
                    return val > 0 ? "+inf.0" : "-inf.0";
                }
                if (isNaN(val)) {
                    return "+nan.0";
                }
                return val.to!string;
            case Type.Complex:
                import std.format : format;
                double r = data.complex.real;
                double i = data.complex.imag;
                if (i ≥ 0) {
                    return format("%s+%si", r, i);
                }
                return format("%s%si", r, i);
        }
    }
}

// Helper structs
private  ExactInteger {
    BigInt value;
}

private  Rational {
    BigInt numerator;
    BigInt denominator;
}

private  InexactReal {
    double value;
}

private  Complex {
    double real;
    double imag;
}

// GCD helper
private BigInt gcd(BigInt a, BigInt b) pure nothrow @safe {
    import std.algorithm : swap;
    
    a = abs(a);
    b = abs(b);
    
    while (b ≠ 0) {
        BigInt temp = b;
        b = a % b;
        a = temp;
    }
    return a;
}

private BigInt abs(BigInt a) pure nothrow @safe {
    return a < 0 ? -a : a;
}

 SchemeException : Exception {
    this(string msg, string file = __FILE__, size_t line = __LINE__) pure nothrow @safe {
        super(msg, file, line);
    }
}

E.2.3 Scheme Symbols with Interning

module scheme_r7rs.core.symbol;

import std.array;
import std.exception;

/**

 * Scheme symbol with automatic interning for efficient comparison.

 */
 SchemeSymbol {
    private string name;
    private static SchemeSymbol*[string] symbolTable;
    
    // Private constructor - use intern() to create symbols
    private this(string n) pure nothrow @safe {
        name = n;
    }
    
    /**

     * Interns a symbol (creates or retrieves from symbol table).

     */
    static SchemeSymbol* intern(string name) @safe {
        if (auto sym = name in symbolTable) {
            return *sym;
        }
        
        auto newSym = new SchemeSymbol(name);
        symbolTable[name] = newSym;
        return newSym;
    }
    
    string getName() const pure nothrow @safe @nogc {
        return name;
    }
    
    // Symbols are compared by identity (pointer equality)
    bool opEquals(const SchemeSymbol* other) const pure nothrow @safe @nogc {
        return &this ⩵ other;
    }
    
    string toString() const pure nothrow @safe {
        // Check if symbol needs escaping
        if (needsEscaping(name)) {
            return "|" ~ escapeSymbol(name) ~ "|";
        }
        return name;
    }
    
    private static bool needsEscaping(string name) pure nothrow @safe {
        import std.algorithm : canFind;
        return name.canFind(' ') ∨ name.canFind('|') ∨ 
               name.canFind('(') ∨ name.canFind(')');
    }
    
    private static string escapeSymbol(string name) pure @safe {
        import std.array : replace;
        return name.replace("\\", "\\\\").replace("|", "\\|");
    }
}

E.2.4 Scheme Pairs and Lists

module scheme_r7rs.core.pair;

import scheme_r7rs.core.value;
import std.range;
import std.array;

/**

 * Scheme pair (cons cell).

 * Immutable after construction.

 */
 SchemePair {
    private Value car;
    private Value cdr;
    
    this(Value car, Value cdr) pure nothrow @safe {
        this.car = car;
        this.cdr = cdr;
    }
    
    Value getCar() const pure nothrow @safe @nogc {
        return cast(Value)car;
    }
    
    Value getCdr() const pure nothrow @safe @nogc {
        return cast(Value)cdr;
    }
    
    /**

     * Tests if this is a proper list.

     */
    bool isProperList() const pure nothrow @safe {
        const(Value)* current = &cdr;
        while (current.peek!SchemePair) {
            current = &(current.get!SchemePair.cdr);
        }
        return current.peek!SchemeNull !is null;
    }
    
    /**

     * Returns length if proper list, -1 otherwise.

     */
    int length() const pure nothrow @safe {
        if (!isProperList()) return -1;
        
        int len = 1;
        const(Value)* current = &cdr;
        while (current.peek!SchemePair) {
            len⧺;
            current = &(current.get!SchemePair.cdr);
        }
        return len;
    }
    
    /**

     * Converts to Value array (if proper list).

     */
    Value[] toArray() const @safe {
        enforce(isProperList(), "Not a proper list");
        
        Value[] result;
        result ≈ car;
        
        const(Value)* current = &cdr;
        while (auto pair = current.peek!SchemePair) {
            result ≈ pair.car;
            current = &pair.cdr;
        }
        
        return result;
    }
    
    /**

     * Creates a list from an array of values.

     */
    static Value fromArray(Value[] values) @safe {
        if (values.length ⩵ 0) {
            return Value(SchemeNull());
        }
        
        Value result = Value(SchemeNull());
        foreach_reverse (v; values) {
            result = Value(new SchemePair(v, result));
        }
        return result;
    }
    
    /**

     * Range interface for iteration.

     */
    auto range() const @safe {
        static  ListRange {
            const(Value)* current;
            
            bool empty() const pure nothrow @safe {
                return current.peek!SchemeNull !is null;
            }
            
            Value front() const pure @safe {
                enforce(!empty(), "Range is empty");
                auto pair = current.peek!SchemePair;
                enforce(pair !is null, "Malformed list");
                return cast(Value)pair.car;
            }
            
            void popFront() pure @safe {
                enforce(!empty(), "Range is empty");
                auto pair = current.peek!SchemePair;
                enforce(pair !is null, "Malformed list");
                current = &pair.cdr;
            }
        }
        
        return ListRange(&(cast(Value)Value(cast(SchemePair)this)));
    }
    
    string toString() const @safe {
        import std.format : format;
        
        if (!isProperList()) {
            return format("(%s . %s)", car, cdr);
        }
        
        auto elements = range().map!(v ⇒ v.toString()).array;
        return "(" ~ elements.join(" ") ~ ")";
    }
}

E.2.5 Scheme Procedures

module scheme_r7rs.core.procedure;

import scheme_r7rs.core.value;
import scheme_r7rs.env.environment;
import std.typecons;

/**

 * Base interface for all Scheme procedures.

 */
 IProcedure {
    /**

     * Applies this procedure to arguments.

     * Returns either a Value or a TailCall.

     */
    Algebraic!(Value, TailCall) apply(Value[] args, Environment env) @safe;
    
    int getArity() const pure nothrow @safe @nogc;
    bool isVariadic() const pure nothrow @safe @nogc;
}

/**

 * Wrapper for procedures in the Value type system.

 */
 SchemeProcedure {
    IProcedure procedure;
    
    this(IProcedure proc) pure nothrow @safe @nogc {
        procedure = proc;
    }
    
    auto apply(Value[] args, Environment env) @safe {
        return procedure.apply(args, env);
    }
    
    int getArity() const pure nothrow @safe @nogc {
        return procedure.getArity();
    }
    
    bool isVariadic() const pure nothrow @safe @nogc {
        return procedure.isVariadic();
    }
    
    string toString() const pure nothrow @safe {
        return "#<procedure>";
    }
}

/**

 * Primitive (built-in) procedure.

 */
 SchemePrimitive : IProcedure {
     PrimFunc = Value (Value[] args) @safe;
    
    private string name;
    private int arity;
    private bool variadic;
    private PrimFunc func;
    
    this(string name, int arity, PrimFunc func) pure nothrow @safe @nogc {
        this(name, arity, false, func);
    }
    
    this(string name, int arity, bool variadic, PrimFunc func) 
        pure nothrow @safe @nogc 
    {
        this.name = name;
        this.arity = arity;
        this.variadic = variadic;
        this.func = func;
    }
    
    Algebraic!(Value, TailCall) apply(Value[] args, Environment env) @safe {
        // Check arity
        if (!variadic ∧ args.length ≠ arity) {
            throw new SchemeException(
                name ~ ": expected " ~ arity.to!string ~ 
                " arguments, got " ~ args.length.to!string
            );
        }
        if (variadic ∧ args.length < arity) {
            throw new SchemeException(
                name ~ ": expected at least " ~ arity.to!string ~ 
                " arguments, got " ~ args.length.to!string
            );
        }
        
        // Apply function (primitives return directly, no tail calls)
        return Algebraic!(Value, TailCall)(func(args));
    }
    
    int getArity() const pure nothrow @safe @nogc {
        return arity;
    }
    
    bool isVariadic() const pure nothrow @safe @nogc {
        return variadic;
    }
    
    override string toString() const pure nothrow @safe {
        return "#<primitive:" ~ name ~ ">";
    }
}

/**

 * User-defined closure.

 */
 SchemeClosure : IProcedure {
    private SchemeSymbol*[] parameters;
    private SchemeSymbol* restParameter;  // null if not variadic
    private Value body;
    private Environment definitionEnv;
    
    this(SchemeSymbol*[] params, SchemeSymbol* rest, 
         Value body, Environment env) pure nothrow @safe 
    {
        this.parameters = params;
        this.restParameter = rest;
        this.body = body;
        this.definitionEnv = env;
    }
    
    Algebraic!(Value, TailCall) apply(Value[] args, Environment callEnv) @safe {
        // Check arity
        int required = cast(int)parameters.length;
        if (restParameter is null ∧ args.length ≠ required) {
            throw new SchemeException(
                "Expected " ~ required.to!string ~ 
                " arguments, got " ~ args.length.to!string
            );
        }
        if (restParameter !is null ∧ args.length < required) {
            throw new SchemeException(
                "Expected at least " ~ required.to!string ~ 
                " arguments, got " ~ args.length.to!string
            );
        }
        
        // Create new environment extending definition environment
        auto env = new Environment(definitionEnv);
        
        // Bind required parameters
        foreach (i, param; parameters) {
            env.define(param, args[i]);
        }
        
        // Bind rest parameter if variadic
        if (restParameter !is null) {
            Value[] restArgs = args[required ‥ $];
            env.define(restParameter, SchemePair.fromArray(restArgs));
        }
        
        // Return tail call for evaluation
        return Algebraic!(Value, TailCall)(TailCall(body, env));
    }
    
    int getArity() const pure nothrow @safe @nogc {
        return cast(int)parameters.length;
    }
    
    bool isVariadic() const pure nothrow @safe @nogc {
        return restParameter !is null;
    }
    
    override string toString() const pure nothrow @safe {
        return "#<closure>";
    }
}

/**

 * Represents a tail call to be evaluated.

 */
 TailCall {
    Value expression;
    Environment environment;
    
    this(Value expr, Environment env) pure nothrow @safe @nogc {
        expression = expr;
        environment = env;
    }
}

/**

 * First-class continuation.

 */
 SchemeContinuation {
    // Stack of environments and return addresses
    private  Frame {
        Environment env;
        Value continuation;
    }
    
    private Frame[] stack;
    
    this(Frame[] s) pure nothrow @safe {
        stack = s.dup;
    }
    
    string toString() const pure nothrow @safe {
        return "#<continuation>";
    }
}

E.3 Environment Management

module scheme_r7rs.env.environment;

import scheme_r7rs.core.value;
import scheme_r7rs.core.symbol;
import std.exception;

/**

 * Lexical environment for variable bindings.

 */
 Environment {
    private Environment parent;
    private Value[SchemeSymbol*] bindings;
    
    this(Environment parent = null) pure nothrow @safe {
        this.parent = parent;
    }
    
    /**

     * Defines a new binding in this environment.

     */
    void define(SchemeSymbol* symbol, Value value) pure nothrow @safe {
        bindings[symbol] = value;
    }
    
    /**

     * Sets an existing binding (searches up the chain).

     */
    void set(SchemeSymbol* symbol, Value value) @safe {
        if (symbol in bindings) {
            bindings[symbol] = value;
        } else if (parent !is null) {
            parent.set(symbol, value);
        } else {
            throw new SchemeException(
                "Undefined variable: " ~ symbol.getName()
            );
        }
    }
    
    /**

     * Looks up a variable's value.

     */
    Value lookup(SchemeSymbol* symbol) @safe {
        if (auto val = symbol in bindings) {
            return *val;
        } else if (parent !is null) {
            return parent.lookup(symbol);
        } else {
            throw new SchemeException(
                "Undefined variable: " ~ symbol.getName()
            );
        }
    }
    
    /**

     * Tests if a variable is defined.

     */
    bool isDefined(SchemeSymbol* symbol) const pure nothrow @safe {
        return (symbol in bindings) !is null ∨ 
               (parent !is null ∧ parent.isDefined(symbol));
    }
    
    /**

     * Returns the parent environment.

     */
    Environment getParent() pure nothrow @safe @nogc {
        return parent;
    }
    
    /**

     * Creates a child environment.

     */
    Environment extend() pure nothrow @safe {
        return new Environment(this);
    }
}

E.4 The Evaluator with Tail Call Optimization

module scheme_r7rs.eval.evaluator;

import scheme_r7rs.core.value;
import scheme_r7rs.core.symbol;
import scheme_r7rs.core.pair;
import scheme_r7rs.core.procedure;
import scheme_r7rs.env.environment;
import std.variant;
import std.algorithm;
import std.array;
import std.exception;

/**

 * Main Scheme evaluator with tail call optimization.

 */
 Evaluator {
    
    /**

     * Evaluates an expression in the given environment.

     */
    static Value eval(Value expr, Environment env) @safe {
        Algebraic!(Value, TailCall) result = expr;
        
        // Trampoline loop for tail call optimization
        while (result.peek!TailCall) {
            TailCall tc = result.get!TailCall;
            result = evalOnce(tc.expression, tc.environment);
        }
        
        return result.get!Value;
    }
    
    /**

     * Evaluates an expression once (may return TailCall).

     */
    private static Algebraic!(Value, TailCall) evalOnce(Value expr, Environment env) @safe {
        // Pattern match on expression type
        return expr.visit!(
            (SchemeNull n) ⇒ Algebraic!(Value, TailCall)(Value(n)),
            (SchemeBoolean b) ⇒ Algebraic!(Value, TailCall)(Value(b)),
            (SchemeNumber n) ⇒ Algebraic!(Value, TailCall)(Value(n)),
            (SchemeChar c) ⇒ Algebraic!(Value, TailCall)(Value(c)),
            (SchemeString s) ⇒ Algebraic!(Value, TailCall)(Value(s)),
            (SchemeVector v) ⇒ Algebraic!(Value, TailCall)(Value(v)),
            (SchemeProcedure p) ⇒ Algebraic!(Value, TailCall)(Value(p)),
            (SchemePort p) ⇒ Algebraic!(Value, TailCall)(Value(p)),
            (SchemeContinuation k) ⇒ Algebraic!(Value, TailCall)(Value(k)),
            
            // Symbol - variable lookup
            (SchemeSymbol* sym) {
                return Algebraic!(Value, TailCall)(env.lookup(sym));
            },
            
            // Pair - application or special form
            (SchemePair pair) {
                return evalPair(pair, env);
            }
        );
    }
    
    /**

     * Evaluates a pair (application or special form).

     */
    private static Algebraic!(Value, TailCall) evalPair(SchemePair pair, Environment env) @safe {
        Value car = pair.getCar();
        
        // Check for special forms
        if (auto sym = car.peek!SchemeSymbol) {
            string name = (*sym).getName();
            
            switch (name) {
                case "quote":
                    return evalQuote(pair, env);
                case "if":
                    return evalIf(pair, env);
                case "lambda":
                    return evalLambda(pair, env);
                case "define":
                    return evalDefine(pair, env);
                case "set!":
                    return evalSet(pair, env);
                case "begin":
                    return evalBegin(pair, env);
                case "let":
                    return evalLet(pair, env);
                case "let*":
                    return evalLetStar(pair, env);
                case "letrec":
                    return evalLetrec(pair, env);
                case "cond":
                    return evalCond(pair, env);
                case "and":
                    return evalAnd(pair, env);
                case "or":
                    return evalOr(pair, env);
                case "call/cc":
                case "call-with-current-continuation":
                    return evalCallCC(pair, env);
                default:
                    // Not a special form, treat as application
                    break;
            }
        }
        
        // Procedure application
        return evalApplication(pair, env);
    }
    
    /**

     * (quote datum)

     */
    private static Algebraic!(Value, TailCall) evalQuote(SchemePair expr, Environment env) @safe {
        Value[] args = expr.toArray();
        enforce(args.length ⩵ 2, "quote: expects 1 argument");
        return Algebraic!(Value, TailCall)(args[1]);
    }
    
    /**

     * (if test consequent alternate?)

     */
    private static Algebraic!(Value, TailCall) evalIf(SchemePair expr, Environment env) @safe {
        Value[] args = expr.toArray();
        enforce(args.length ⩵ 3 ∨ args.length ⩵ 4, 
               "if: expects 2 or 3 arguments");
        
        Value testResult = eval(args[1], env);
        
        if (isTrue(testResult)) {
            // Tail call to consequent
            return Algebraic!(Value, TailCall)(TailCall(args[2], env));
        } else {
            if (args.length ⩵ 4) {
                // Tail call to alternate
                return Algebraic!(Value, TailCall)(TailCall(args[3], env));
            } else {
                // Unspecified value
                return Algebraic!(Value, TailCall)(Value(SchemeNull()));
            }
        }
    }
    
    /**

     * (lambda (params) body)

     * (lambda (param . rest) body)

     */
    private static Algebraic!(Value, TailCall) evalLambda(SchemePair expr, Environment env) @safe {
        Value[] parts = expr.toArray();
        enforce(parts.length ≥ 3, "lambda: malformed");
        
        Value paramSpec = parts[1];
        SchemeSymbol*[] params;
        SchemeSymbol* restParam = null;
        
        // Parse parameter list
        if (paramSpec.peek!SchemeNull) {
            // No parameters
        } else if (auto sym = paramSpec.peek!SchemeSymbol) {
            // Single rest parameter
            restParam = *sym;
        } else if (auto pair = paramSpec.peek!SchemePair) {
            // Parse proper or improper list
            Value current = paramSpec;
            while (auto p = current.peek!SchemePair) {
                auto carSym = p.getCar().peek!SchemeSymbol;
                enforce(carSym !is null, "lambda: parameter must be symbol");
                params ≈ *carSym;
                current = p.getCdr();
            }
            
            if (!current.peek!SchemeNull) {
                // Improper list - rest parameter
                auto restSym = current.peek!SchemeSymbol;
                enforce(restSym !is null, "lambda: rest parameter must be symbol");
                restParam = *restSym;
            }
        } else {
            throw new SchemeException("lambda: invalid parameter list");
        }
        
        // Body is remaining expressions wrapped in begin
        Value[] bodyExprs = parts[2 ‥ $];
        Value body = bodyExprs.length ⩵ 1 ? 
            bodyExprs[0] : 
            SchemePair.fromArray([Value(SchemeSymbol.intern("begin"))] ~ bodyExprs);
        
        auto closure = new SchemeClosure(params, restParam, body, env);
        return Algebraic!(Value, TailCall)(Value(SchemeProcedure(closure)));
    }
    
    /**

     * (define name value) or (define (name params) body)

     */
    private static Algebraic!(Value, TailCall) evalDefine(SchemePair expr, Environment env) @safe {
        Value[] parts = expr.toArray();
        enforce(parts.length ≥ 3, "define: malformed");
        
        Value first = parts[1];
        
        if (auto sym = first.peek!SchemeSymbol) {
            // (define name value)
            Value value = eval(parts[2], env);
            env.define(*sym, value);
            return Algebraic!(Value, TailCall)(Value(SchemeSymbol.intern("ok")));
        } else if (auto pair = first.peek!SchemePair) {
            // (define (name params) body)
            auto nameSym = pair.getCar().peek!SchemeSymbol;
            enforce(nameSym !is null, "define: name must be symbol");
            
            Value params = pair.getCdr();
            
            // Create lambda expression
            Value[] lambdaExpr = [
                Value(SchemeSymbol.intern("lambda")),
                params
            ] ~ parts[2 ‥ $];
            
            Value lambda = eval(SchemePair.fromArray(lambdaExpr), env);
            env.define(*nameSym, lambda);
            return Algebraic!(Value, TailCall)(Value(SchemeSymbol.intern("ok")));
        } else {
            throw new SchemeException("define: invalid syntax");
        }
    }
    
    /**

     * (set! name value)

     */
    private static Algebraic!(Value, TailCall) evalSet(SchemePair expr, Environment env) @safe {
        Value[] args = expr.toArray();
        enforce(args.length ⩵ 3, "set!: expects 2 arguments");
        
        auto sym = args[1].peek!SchemeSymbol;
        enforce(sym !is null, "set!: first argument must be symbol");
        
        Value value = eval(args[2], env);
        env.set(*sym, value);
        return Algebraic!(Value, TailCall)(Value(SchemeSymbol.intern("ok")));
    }
    
    /**

     * (begin expr1 expr2 …)

     */
    private static Algebraic!(Value, TailCall) evalBegin(SchemePair expr, Environment env) @safe {
        Value[] exprs = expr.toArray();
        enforce(exprs.length ≥ 2, "begin: expects at least 1 expression");
        
        // Evaluate all but last
        foreach (e; exprs[1 ‥ $-1]) {
            eval(e, env);
        }
        
        // Tail call to last expression
        return Algebraic!(Value, TailCall)(TailCall(exprs[$-1], env));
    }
    
    /**

     * (let ((var val) …) body)

     */
    private static Algebraic!(Value, TailCall) evalLet(SchemePair expr, Environment env) @safe {
        Value[] parts = expr.toArray();
        enforce(parts.length ≥ 3, "let: malformed");
        
        auto bindingsPair = parts[1].peek!SchemePair;
        enforce(bindingsPair !is null ∨ parts[1].peek!SchemeNull, 
               "let: bindings must be a list");
        
        // Create new environment
        auto newEnv = env.extend();
        
        // Process bindings
        if (bindingsPair !is null) {
            foreach (binding; bindingsPair.range()) {
                auto pair = binding.peek!SchemePair;
                enforce(pair !is null, "let: malformed binding");
                
                Value[] bindingParts = pair.toArray();
                enforce(bindingParts.length ⩵ 2, "let: malformed binding");
                
                auto varSym = bindingParts[0].peek!SchemeSymbol;
                enforce(varSym !is null, "let: variable must be symbol");
                
                Value val = eval(bindingParts[1], env);  // Evaluate in outer env
                newEnv.define(*varSym, val);
            }
        }
        
        // Body
        Value[] bodyExprs = parts[2 ‥ $];
        Value body = bodyExprs.length ⩵ 1 ? 
            bodyExprs[0] : 
            SchemePair.fromArray([Value(SchemeSymbol.intern("begin"))] ~ bodyExprs);
        
        return Algebraic!(Value, TailCall)(TailCall(body, newEnv));
    }
    
    /**

     * Procedure application

     */
    private static Algebraic!(Value, TailCall) evalApplication(
        SchemePair expr, Environment env) @safe 
    {
        Value[] elements = expr.toArray();
        
        // Evaluate operator
        Value operator = eval(elements[0], env);
        auto proc = operator.peek!SchemeProcedure;
        enforce(proc !is null, "Not a procedure: " ~ operator.toString());
        
        // Evaluate arguments
        Value[] args;
        foreach (arg; elements[1 ‥ $]) {
            args ≈ eval(arg, env);
        }
        
        // Apply procedure
        return proc.apply(args, env);
    }
    
    /**

     * Tests if a value is true (anything except #f).

     */
    private static bool isTrue(Value val) pure nothrow @safe {
        if (auto b = val.peek!SchemeBoolean) {
            return b.value;
        }
        return true;
    }
}

E.5 Summary and Continuation

This D template demonstrates:

  1. Type Safety: Using Algebraic for tagged unions with compile-time guarantees

  2. Pattern Matching: D’s visit for exhaustive case handling

  3. Memory Management: Leveraging GC for automatic memory management

  4. Performance: Efficient tail-call optimization with trampolining

  5. Interning: Efficient symbol comparison via pointer equality

  6. Full Numeric Tower: BigInt, rationals, doubles, complex numbers

Remaining Sections (to be covered in continuation):

  • E.6: Reader/Parser with D ranges

  • E.7: Standard Primitives using template mixins

  • E.8: Library system with compile-time module loading

  • E.9: Macro expander using CTFE

  • E.10: REPL with D’s std.stdio

The D implementation offers superior type safety and metaprogramming capabilities compared to the Java version, with comparable performance and more concise code.