Forth thru a Lisp-y Lens

February 23, 2019

Brad Nelson / @flagxor

Introduction

• Structured Interpretation of Computer Programs
• 6.001
• 1980 - 2007

Disclaimers

• SICP is a big book, I'll cover some
• There are many Forths, and many Lisps
• Reframing from scratch is hard
• Trying to illuminate, not stack rank

Lisp

Chapters

• 1. Building Abstraction with Procedures
• 2. Building Abstraction with Data
• 3. Modularity, Objects, and State
• 4. Metalinguistic Abstraction
• 5. Computing with Register Machines

1. Building Abstraction with Procedures

Elements of Programming

• Primitive Expressions
• Means of Combination
• Means of Abstraction

Primitive Expressions

(+ 137 349)
486
(- 1000 334)
666
(/ 10 5)
2
(+ 2.7 10)
12.7

137 349 + .
486
1000 334 - .
666
10 5 / .
2
2.7e 10e f+ f.
12.7

Means of Combination

; Nesting
(+ (* 3 (+ (* 2 4) (+ 3 5))) (+ (- 10 7) 6))

\ Nesting by way of stacks
2 4 * 3 5 + 3 *  10 7 - 6 +  +

Means of Abstraction

(define size 2)
(* 5 size)
10

: size   5 ;    \ 5 constant size
size 5 * .
10

Compound Procedures

(define (square x) (* x x))
(square 21)
441

: square   dup * ;
21 square .
441

Compound Procedures

(define (square x) (* x x))
(define (sum-of-squares x y)
   (+ (square x) (square y)))
(sum-of-squares 3 4)
25

: square   dup * ;
: sum-of-squares   square swap square + ;
3 4 sum-of-squares .
25

Conditionals

(define (abs x)
  (if (< x 0) (- x) x))

: abs ( n -- n )
   dup 0< if negate then ;

Conditionals

(define (abs x)
  (cond ((> x 0) x)
        ((= x 0) 0)
        ((< x 0) (- x))))

: abs ( n -- n )
   dup 0> if exit then
   dup 0= if exit then
   dup 0< if negate exit then ;

Euclid's Algorithm

(define (gcd a b)
  (if (= b 0)
      a
      (gcd b (remainder a b))))

: gcd ( a b -- n )
   dup 0= if drop else swap over mod recurse then ;

Square Root

(define (square x) (* x x))
(define (average x y) (/ (+ x y) 2))
(define (improve guess x) (average guess (/ x guess)))
(define (good-enough? guess x)
  (< (abs (- (square guess) x)) 0.001))
(define (sqrt-iter guess x)
  (if (good-enough? guess x)
      guess
      (sqrt-iter (improve guess x) x)))
(define (sqrt x) (sqrt-iter 1.0 x))

Square Root

: fsquare ( n -- n2 ) fdup f* ;
: faverage ( a b -- mid ) f+ 2e f/ ;
: fgood-enough? ( x guess ) fsquare f- fabs 0.001e f< ;
: fimprove ( guess x ) fover f/ faverage ;
: f2dup ( a b -- a b a b ) fover fover ;
: fsqrt-iter ( x guess )
   f2dup fgood-enough? if fnip else fover fimprove recurse then ;
: fsqrt ( x -- rx ) 1.0e fsqrt-iter ;

Square Root

: square ( n -- n2 ) dup * ;
: average ( a b -- mid ) + 2/ ;
: improve ( guess x ) over / average ;
: good-enough? ( x guess ) dup >r square - abs r> < ;
: sqrt-iter ( x guess )
   2dup good-enough? if nip else over improve recurse then ;
: sqrt ( x -- rx ) 1 sqrt-iter ;

Recursive Factorial

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

: factorial ( n -- n! )
  dup 1 <> if dup 1- recurse * then ;

Recursive Factorial

(factorial 4)
(* 4 (factorial 3))
(* 4 (* 3 (factorial 2)))
(* 4 (* 3 (* 2 (factorial 1))))
(* 4 (* 3 (* 2 1)))
(* 4 (* 3 2))
(* 4 6)
24

4 factorial
4 3 factorial *
4 3 2 factorial * *
4 3 2 1 factorial * * *
4 3 2 1 * * *
4 3 2 * *
4 6 *
24

Iterative Factorial

(define (factorial n)
  (fact-iter 1 1 n))

(define (fact-iter product counter max-count)
  (if (> counter max-count)
      product
      (fact-iter (* counter product)
                 (+ counter 1)
                 max-count)))

: factorial ( n -- n! )
  1+ 1 swap 1 ?do i * loop ;

Iterative Factorial

(factorial 4)
(fact-iter 1 1 4)
(fact-iter 1 2 4)
(fact-iter 2 3 4)
(fact-iter 6 4 4)
(fact-iter 24 5 4)
24

4 factorial
1      ( i = 1 )
1 2 *  ( i = 2 )
2 3 *  ( i = 3 )
6 4 *  ( i = 4 )
24

Recursive Fibonacci

(define (fib n)
  (cond ((= n 0) 0)
        ((= n 1) 1)
        (else (+ (fib (- n 1))
                 (fib (- n 2))))))

: fib ( n -- nfib )
    dup 1 > if dup 1- recurse swap 2 - recurse + then ;

Tree Recursion

Iterative Fibonacci

(define (fib n)
  (fib-iter 1 0 n))

(define (fib-iter a b count)
  (if (= count 0)
      b
      (fib-iter (+ a b) a (- count 1))))

: fib-iter ( n -- nfib )
  0 1 rot 0 ?do swap over + loop drop ;

Counting Change

(define (count-change amount)
  (cc amount 5))
(define (cc amount kinds-of-coins)
  (cond ((= amount 0) 1)
        ((or (< amount 0) (= kinds-of-coins 0)) 0)
        (else (+ (cc amount
                     (- kinds-of-coins 1))
                 (cc (- amount
                        (first-denomination kinds-of-coins))
                     kinds-of-coins)))))
(define (first-denomination kinds-of-coins)
  (cond ((= kinds-of-coins 1) 1)
        ((= kinds-of-coins 2) 5)
        ((= kinds-of-coins 3) 10)
        ((= kinds-of-coins 4) 25)
        ((= kinds-of-coins 5) 50)))

Counting Change

create denominations 1 , 5 , 10 , 25 , 50 ,
: first-denomination ( kinds-of-coins -- n )
   1- cells denominations + @ ;
: cc ( amount kinds-of-coins )
   recursive
   over 0= if 2drop 1 exit then
   2dup 0= swap 0< or if 2drop 0 exit then
   2dup 1- cc >r dup >r first-denomination - r> cc r> + ;
: count-change ( amount -- n ) 5 cc ;

Higher Order Procedures

• Procedures that manipulate procedures

Procedures as Arguments (summing)

(define sum-integers a b)
  (if > a b)
      0
      (+ a (sum-integers (+ a 1) b))))

: sum-integers ( b a -- sum )
   0 -rot ?do i + loop ;

Procedures as Arguments (cubes)

(define sum-cubes a b)
  (if > a b)
      0
      (+ (cube a) (sum-cubes (+ a 1) b))))

: sum-cubes ( b a -- sum )
   0 -rot ?do i cube + loop ;

Procedures as Arguments (pi-sum)

(define pi-sum a b)
  (if > a b)
      0
      (+ (/ 1.0 (* a (+ a 2))) (pi-sum (+ a 4) b))))

: pi-sum ( b a -- sum )
   0 -rot ?do
      1000000000 i 2 + i * / +
   4 +loop ;

Procedures as Arguments

(define sum term a next b)
  (if > a b)
      0
      (+ (term a) (sum (next a) next b))))
(define (inc n) (+ n 1))
(define (sum-cubes a b) (sum cube a inc b))

: sum ( next term b a -- n )
   0 -rot ?do over i swap execute dup . +
             >r over r> swap execute dup .
             +loop nip nip ;
: one 1 ;
: sum-cubes ( b a -- n )
   ['] one -rot ['] cube -rot sum ;

Lambda (?)

(define (adder a) (lambda (b) (+ a b)))
((adder 3) 4)  ; 7

?

Lambda (create does>)

(define (adder a) (lambda (b) (+ a b)))
((adder 3) 4)  ; 7

: adder create , does> @ + ;
3 adder 3plus
4 3plus  \ 7

Lambda (dynamic)

(define (adder a) (lambda (b) (+ a b)))
((adder 3) 4)  ; 7

: adder create , does> @ + ;
4 3 noname adder latestxt execute  \ 7

Lambda (closure)

(define (adder a) (lambda (b) (+ a b)))
((adder 3) 4)  ; 7

: adder ( n -- xt ) >s [: s> + ;] sdrop ;
4 3 adder execute

Lambda (closure+)

(define (adder a) (lambda (b) (+ a b)))
((adder 3) 4)  ; 7

: adder
   >s ( add to scope stack )
   [:
     s> ( pull out of scope )
     +
   ;]
   sdrop ( drop in the parent scope )
;
4 3 adder execute

August 25, 2012 - Event Driven Programming

2. Building Abstraction with Data

Two Kinds of "Closure"

• Combined things can themselves be combined using same ops
• Function which has its own environment

Abstraction Barriers

• Define layered abstractions
• Compose them to isolate implementation details

Rational Numbers

Bringing Lisp-y Lists to Forth

• Store in the dictionary
• Leak like crazy
• Zone/Arena allocation works ok
• Handles / Boehm collector if we're serious
• We probably aren't

( Symbols and Pairs )
: cons ( a b -- c ) noname create , , latestxt ;
: car ( c -- a ) execute cell+ @ ;
: cdr ( c -- b ) execute @ ;
: atom   create latest , ;
: atom>string ( x -- a n ) @ name>string ;
: atom. ( x -- ) atom>string type space ;

Generic Operators

• Higher level abstraction
• Use the power of the closure property

( Reinterpret Floats and Numbers )
variable ftemp
: f->n ftemp f! ftemp @ ;
: n->f ftemp ! ftemp f@ ;

( Utility )
: private[[   get-order wordlist swap 1+ set-order definitions ;
: ]]private   previous definitions ;
: fsquare   fdup f* ;

(put <op> <type> <item>)
; installs the <item> in the table,
;   indexed by the <op> and the <type>.

(get <op> <type>)
; looks up the <op>, <type> entry in the table
;   and returns the item found there.
;   If no item is found, get returns false.

( Type Tags )
: attach-tag swap cons ;
: type-tag car ;
: contents cdr ;

( Type Table )
variable table
: put ( item op type -- )
   cons swap cons table @ cons table ! ;
: equiv ( a b -- f )
   2dup car swap car = -rot cdr swap cdr = and ;
: get ( op type -- item )
   cons table @ begin dup while
     2dup car car equiv if nip car cdr exit then
     cdr repeat -1 throw ;

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (error
            "No method for these types -- APPLY-GENERIC"
            (list op type-tags))))))

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (if (= (length args) 2)
              (let ((type1 (car type-tags))
                    (type2 (cadr type-tags))
                    (a1 (car args))
                    (a2 (cadr args)))
                (let ((t1->t2 (get-coercion type1 type2))
                      (t2->t1 (get-coercion type2 type1)))
                  (cond (t1->t2
                         (apply-generic op (t1->t2 a1) a2))
                        (t2->t1
                         (apply-generic op a1 (t2->t1 a2)))
                        (else
                         (error "No method for these types"
                                (list op type-tags))))))
              (error "No method for these types"
                     (list op type-tags)))))))

( Applying generic ops )
: apply-generic ( .. op -- .. )
   over type-tag get swap contents swap execute ;
: apply-generic2 ( .. op -- .. )
   over type-tag get rot contents rot contents rot execute ;

(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (make-from-real-imag x y)
  ((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
  ((get 'make-from-mag-ang 'polar) r a))

( Generic Complex Ops )
atom 'real-part   atom 'imag-part
atom 'magnitude   atom 'angle
atom 'make-from-real-imag   atom 'make-from-mag-ang
atom 'rectangular   atom 'polar
: real-part 'real-part apply-generic ;
: imag-part 'imag-part apply-generic ;
: magnitude 'magnitude apply-generic ;
: angle 'angle apply-generic ;
: rect>z 'make-from-real-imag 'rectangular get execute ;
: polar>z 'make-from-mag-ang 'polar get execute ;

(define (add-complex z1 z2)
  (make-from-real-imag (+ (real-part z1) (real-part z2))
                       (+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
  (make-from-real-imag (- (real-part z1) (real-part z2))
                       (- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
  (make-from-mag-ang (* (magnitude z1) (magnitude z2))
                     (+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
  (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
                     (- (angle z1) (angle z2))))

( Complex Math )
: z+ ( z1 z2 -- z )
   2dup real-part real-part f+
   imag-part imag-part f+ rect>z ;
: z- ( z1 z2 -- z )
   2dup real-part real-part fswap f-
   imag-part imag-part fswap f- rect>z ;
: z* ( z1 z2 -- z )
   2dup magnitude magnitude f*
   angle angle f+ polar>z ;
: z/ ( z1 z2 -- z )
   2dup magnitude magnitude fswap f/
   angle angle fswap f- polar>z ;

: zsquare ( z -- z2 ) dup z* ;
: z. ( z -- )
   ." ( " dup real-part f. ." + i * " imag-part f. ." ) " ;
: zp. ( z -- )
   ." ( " dup magnitude f. ." * e^ ( i * " angle f. ." ) ) " ;

(define (install-rectangular-package)
  ;; internal procedures
  (define (real-part z) (car z))
  (define (imag-part z) (cdr z))
  (define (make-from-real-imag x y) (cons x y))
  (define (magnitude z)
    (sqrt (+ (square (real-part z))
             (square (imag-part z)))))
  (define (angle z)
    (atan (imag-part z) (real-part z)))
  (define (make-from-mag-ang r a)
    (cons (* r (cos a)) (* r (sin a))))
  ;; interface to the rest of the system
  (define (tag x) (attach-tag 'rectangular x))
  (put 'real-part '(rectangular) real-part)
  (put 'imag-part '(rectangular) imag-part)
  (put 'magnitude '(rectangular) magnitude)
  (put 'angle '(rectangular) angle)
  (put 'make-from-real-imag 'rectangular
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'rectangular
       (lambda (r a) (tag (make-from-mag-ang r a))))
  'done)

( Rectangular Complex Numbers )
private[[
: real-part car n->f ;
: imag-part cdr n->f ;
: magnitude
   dup real-part fsquare
   imag-part fsquare f+ fsqrt ;
: angle
   dup imag-part
   real-part fatan2 ;
: make-from-real-imag
   f->n f->n swap cons 'rectangular attach-tag ;

' real-part 'real-part 'rectangular put
' imag-part 'imag-part 'rectangular put
' magnitude 'magnitude 'rectangular put
' angle 'angle 'rectangular put
' make-from-real-imag 'make-from-real-imag 'rectangular put
]]private

(define (install-polar-package)
  ;; internal procedures
  (define (magnitude z) (car z))
  (define (angle z) (cdr z))
  (define (make-from-mag-ang r a) (cons r a))
  (define (real-part z)
    (* (magnitude z) (cos (angle z))))
  (define (imag-part z)
    (* (magnitude z) (sin (angle z))))
  (define (make-from-real-imag x y)
    (cons (sqrt (+ (square x) (square y)))
          (atan y x)))
  ;; interface to the rest of the system
  (define (tag x) (attach-tag 'polar x))
  (put 'real-part '(polar) real-part)
  (put 'imag-part '(polar) imag-part)
  (put 'magnitude '(polar) magnitude)
  (put 'angle '(polar) angle)
  (put 'make-from-real-imag 'polar
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'polar
       (lambda (r a) (tag (make-from-mag-ang r a))))
  'done)

( Polar Complex Numbers )
private[[
: magnitude car n->f ;
: angle cdr n->f ;
: real-part dup magnitude angle fcos f* ;
: imag-part dup magnitude angle fsin f* ;
: make-from-mag-ang
  f->n f->n swap cons 'polar attach-tag ;

' real-part 'real-part 'polar put
' imag-part 'imag-part 'polar put
' magnitude 'magnitude 'polar put
' angle 'angle 'polar put
' make-from-mag-ang 'make-from-mag-ang 'polar put
]]private

(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (make-scheme-number n)
  ((get 'make 'scheme-number) n))
(define (make-rational n d)
  ((get 'make 'rational) n d))
(define (make-complex-from-real-imag x y)
  ((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
  ((get 'make-from-mag-ang 'complex) r a))
(define (make-polynomial var terms)
  ((get 'make 'polynomial) var terms))

( Generic Ops )
atom '+   atom '-   atom '*   atom '/   atom '.   atom 'make
atom 'number   atom 'float   atom 'complex
atom 'rational   atom 'polynomial
: g+ '+ apply-generic2 ;
: g- '- apply-generic2 ;
: g* '* apply-generic2 ;
: g/ '/ apply-generic2 ;
: g. '. apply-generic ;
: make-number 'make 'number get execute ;
: make-float 'make 'float get execute ;
: make-complex 'make 'complex get execute ;
: make-rational 'make 'rational get execute ;
: make-poly 'make 'polynomial get execute ;

(define (install-scheme-number-package)
  (define (tag x)
    (attach-tag 'scheme-number x))
  (put 'add '(scheme-number scheme-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(scheme-number scheme-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(scheme-number scheme-number)
       (lambda (x y) (tag (* x y))))
  (put 'div '(scheme-number scheme-number)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'scheme-number
       (lambda (x) (tag x)))
  'done)

( Simple Numbers )
private[[
: tag 'number attach-tag ;
: add + tag ;
: sub - tag ;
: mul * tag ;
: div / tag ;
: print . ;
: make tag ;

' add '+ 'number put
' sub '- 'number put
' mul '* 'number put
' div '/ 'number put
' print '. 'number put
' make 'make 'number put
]]private

( Simple Floats )
private[[
: tag 'float attach-tag ;
: add f+ tag ;
: sub f- tag ;
: mul f* tag ;
: div f/ tag ;
: print f. ;
: make f->n tag ;

' add '+ 'float put
' sub '- 'float put
' mul '* 'float put
' div '/ 'float put
' print '. 'float put
' make 'make 'float put
]]private

(define (install-complex-package)
  (define (tag z) (attach-tag 'complex z))
  (put 'add '(complex complex)
       (lambda (z1 z2) (tag (add-complex z1 z2))))
  (put 'sub '(complex complex)
       (lambda (z1 z2) (tag (sub-complex z1 z2))))
  (put 'mul '(complex complex)
       (lambda (z1 z2) (tag (mul-complex z1 z2))))
  (put 'div '(complex complex)
       (lambda (z1 z2) (tag (div-complex z1 z2))))
  (put 'make-from-real-imag 'complex
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'complex
       (lambda (r a) (tag (make-from-mag-ang r a))))
  'done)

( Complex )
private[[
: tag 'complex attach-tag ;
: add z+ tag ;
: sub z- tag ;
: mul z* tag ;
: div z/ tag ;
: print z. ;
: make tag ;

' add '+ 'complex put
' sub '- 'complex put
' mul '* 'complex put
' div '/ 'complex put
' print '. 'complex put
' make 'make 'complex put
]]private

(define (install-rational-package)
  ;; internal procedures
  (define (numer x) (car x))
  (define (denom x) (cdr x))
  (define (make-rat n d)
    (let ((g (gcd n d)))
      (cons (/ n g) (/ d g))))
  (define (add-rat x y)
    (make-rat (+ (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (sub-rat x y)
    (make-rat (- (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (mul-rat x y)
    (make-rat (* (numer x) (numer y))
              (* (denom x) (denom y))))
  (define (div-rat x y)
    (make-rat (* (numer x) (denom y))
              (* (denom x) (numer y))))
  ...

  ...
  ;; interface to rest of the system
  (define (tag x) (attach-tag 'rational x))
  (put 'add '(rational rational)
       (lambda (x y) (tag (add-rat x y))))
  (put 'sub '(rational rational)
       (lambda (x y) (tag (sub-rat x y))))
  (put 'mul '(rational rational)
       (lambda (x y) (tag (mul-rat x y))))
  (put 'div '(rational rational)
       (lambda (x y) (tag (div-rat x y))))

  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  'done)

( Rational )
private[[
: gcd ( a b -- n ) dup 0= if drop else swap over mod recurse then ;
: reduce ( a b -- a' b' ) 2dup gcd swap over / -rot / swap ;
: tag 'rational attach-tag ;
: numer car ;
: denom cdr ;
: make-rat reduce cons tag ;
: add 2dup numer swap denom * >r
      2dup denom swap numer * r> + -rot
      denom swap denom * make-rat ;
: sub 2dup numer swap denom * >r
      2dup denom swap numer * r> - -rot
      denom swap denom * make-rat ;
: mul 2dup numer swap numer * -rot
      denom swap denom * make-rat ;
: div 2dup denom swap numer * -rot
      numer swap denom * make-rat ;
: print ." ( " dup numer . ." / " denom . ." ) " ;
: make make-rat ;
...

...
' add '+ 'rational put
' sub '- 'rational put
' mul '* 'rational put
' div '/ 'rational put
' print '. 'rational put
' make 'make 'rational put
]]private

(define (install-polynomial-package)
  ;; internal procedures
  ;; representation of poly
  (define (make-poly variable term-list)
    (cons variable term-list))
  (define (variable p) (car p))
  (define (term-list p) (cdr p))
  
  ;; representation of terms and term lists
  

  ;; continued on next page
  ...

  ...
  (define (add-poly p1 p2) ...)
  
  (define (mul-poly p1 p2) ...)
  
  ;; interface to rest of the system
  (define (tag p) (attach-tag 'polynomial p))
  (put 'add '(polynomial polynomial)
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'mul '(polynomial polynomial)
       (lambda (p1 p2) (tag (mul-poly p1 p2))))
  (put 'make 'polynomial
       (lambda (var terms) (tag (make-poly var terms))))
  'done)

( Polynomial )
private[[
: make-poly cons ;
: variable car ;
: term-list cdr ;

: make-term cons ;
: coeff car ;
: order cdr ;
: add-poly
   dup variable -rot term-list swap term-list +terms make-poly ;
: mul-poly
   dup variable -rot term-list swap term-list *terms make-poly ;
: print ." [ "
  dup variable swap term-list
  begin dup while
    dup car coeff g. ." " over atom. ." ^" dup car order .
    cdr dup if ." + " then
  repeat
  2drop ." ] "
;
...

...
: tag 'polynomial attach-tag ;
: add add-poly tag ;
: mul mul-poly tag ;
: make cons 0 cons make-poly tag ;

' add '+ 'polynomial put
' mul '* 'polynomial put
' print '. 'polynomial put
' make 'make 'polynomial put
]]private

(define (add-terms L1 L2)
  (cond ((empty-termlist? L1) L2)
        ((empty-termlist? L2) L1)
        (else
         (let ((t1 (first-term L1)) (t2 (first-term L2)))
           (cond ((> (order t1) (order t2))
                  (adjoin-term
                   t1 (add-terms (rest-terms L1) L2)))
                 ((< (order t1) (order t2))
                  (adjoin-term
                   t2 (add-terms L1 (rest-terms L2))))
                 (else
                  (adjoin-term
                   (make-term (order t1)
                              (add (coeff t1) (coeff t2)))
                   (add-terms (rest-terms L1)
                              (rest-terms L2)))))))))

: +terms ( L1 L2 -- L )
   dup 0= if drop exit then
   over 0= if nip exit then
   2dup car swap car swap
   2dup order swap order swap
   2dup > if 2drop drop -rot swap cdr recurse cons exit then
   < if nip -rot cdr recurse cons exit then
   dup order -rot coeff swap coeff g+ swap make-term
   -rot cdr swap cdr recurse cons
;

(define (mul-terms L1 L2)
  (if (empty-termlist? L1)
      (the-empty-termlist)
      (add-terms (mul-term-by-all-terms (first-term L1) L2)
                 (mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
  (if (empty-termlist? L)
      (the-empty-termlist)
      (let ((t2 (first-term L)))
        (adjoin-term
         (make-term (+ (order t1) (order t2))
                    (mul (coeff t1) (coeff t2)))
         (mul-term-by-all-terms t1 (rest-terms L))))))

: t*terms ( t L -- L )
   dup 0= if nip exit then
   over swap ( t t L )
   dup >r car 2dup order swap order +
   -rot coeff swap coeff g* swap make-term
   swap r> cdr recurse cons
;
: *terms ( L1 L2 -- L )
   dup 0= if nip exit then
   2dup car swap t*terms
   -rot cdr recurse +terms
;

A Picture Language

• Devise a high level language for describing pictures
• Build more complex pictures from composition of smaller ones
• A focus on recursive / symetric images (Escher)

( Raw postscript drawing )
: line ( x1 y1 x2 y2 )
   ." newpath " swap . . ."  moveto "
   swap . . ."  lineto 10 setlinewidth stroke" cr ;
: showpage ." showpage" cr ;

(define (transform-painter painter origin corner1 corner2)
  (lambda (frame)
    (let ((m (frame-coord-map frame)))
      (let ((new-origin (m origin)))
        (painter
         (make-frame new-origin
                     (sub-vect (m corner1) new-origin)
                     (sub-vect (m corner2) new-origin)))))))

( Transform stack )
1000000 constant divisor
100000 constant size
variable org-x   variable org-y
variable hx   variable hy   divisor hx !
variable vx   variable vy   divisor vy !
create transform-stack 1000 cells allot
variable tsp   transform-stack tsp !
: >t   tsp @ !  cell tsp +! ;
: t>   -1 cells tsp +!  tsp @ @ ;
: t{ org-x @ >t  org-y @ >t  hx @ >t  hy @ >t  vx @ >t  vy @ >t ;
: }t t> vy !  t> vx !  t> hy !  t> hx !  t> org-y !  t> org-x ! ;

( Transforming lines )
: @* @ divisor */ ;
: transform ( x y -- x' y' )
   2dup vy @* swap hy @* + org-y @ + >r
        vx @* swap hx @* + org-x @ + r> ;
: tline ( x1 y1 x2 y2 ) transform >r >r transform r> r> line ;

( Basic Transformations )
: scale-x ( n -- ) dup hx @* hx !  hy @* hy ! ;
: scale-y ( n -- ) dup vx @* vx !  vy @* vy ! ;
: scale ( n -- ) dup scale-x scale-y ;
: trans ( x y -- ) transform org-y ! org-x ! ;
: swap! ( a1 a2 -- ) 2dup @ swap @ rot ! swap ! ;
: diag-flip   hx vx swap!  hy vy swap! ;
: turn45   hx @ vx @ + 2/   hy @ vy @ + 2/
           hx @ vx @ - 2/   hy @ vy @ - 2/
           vy ! vx ! hy ! hx ! ;

( Pairs )
: atom ( a -- c ) noname create , latestxt ;
: cons ( a b -- c ) noname create , , latestxt ;

(define (beside painter1 painter2)
  (let ((split-point (make-vect 0.5 0.0)))
    (let ((paint-left
           (transform-painter painter1
                              (make-vect 0.0 0.0)
                              split-point
                              (make-vect 0.0 1.0)))
          (paint-right
           (transform-painter painter2
                              split-point
                              (make-vect 1.0 0.0)
                              (make-vect 0.5 1.0))))
      (lambda (frame)
        (paint-left frame)
        (paint-right frame)))))

: beside ( a b -- c ) cons does>
   t{ size 2/ 0 trans
      divisor 1 2 */ scale-x  dup @ execute }t
   t{ divisor 1 2 */ scale-x  cell+ @ execute }t ;
: above ( a b -- c ) cons does>
   t{ 0 size 2/ trans
      divisor 1 2 */ scale-y  dup cell+ @ execute }t
   t{ divisor 1 2 */ scale-y  @ execute }t ;

: beside3rd ( a b -- c ) cons does>
   t{ size 3 / 0 trans
      divisor 2 3 */ scale-x  dup @ execute }t
   t{ divisor 1 3 */ scale-x  cell+ @ execute }t ;
: above3rd ( a b -- c ) cons does>
   t{ 0 size 2 3 */ trans
      divisor 1 3 */ scale-y  dup cell+ @ execute }t
   t{ divisor 2 3 */ scale-y  @ execute }t ;

(define (flip-vert painter)
  (transform-painter painter
                     (make-vect 0.0 1.0)   ; new origin
                     (make-vect 1.0 1.0)   ; new end of edge1
                     (make-vect 0.0 0.0))) ; new end of edge2

(define (rotate90 painter)
  (transform-painter painter
                     (make-vect 1.0 0.0)
                     (make-vect 1.0 1.0)
                     (make-vect 0.0 0.0)))

...

: hflip ( a -- a' ) atom does>
   t{ size 0 trans  divisor negate scale-x  @ execute }t ;
: vflip ( a -- a' ) atom does>
   t{ 0 size trans   divisor negate scale-y  @ execute }t ;
: dmirror ( a -- a' ) atom does> t{ diag-flip  @ execute }t ;
: rot90 ( a -- a' ) dmirror hflip ;
: rot45' ( a -- a' ) atom does> t{ turn45  @ execute }t ;
: rot45 ( a -- a' ) rot90 rot45' vflip ;
: both ( a b -- c ) cons does> dup @ execute cell+ @ execute ;

: /10 size swap 10 */ ;
: /20 size swap 20 */ ;
: fish
   0    0       size 0    tline
   0    0       0    size tline
   size 0       0    size tline
   2 /10  1 /10     2 /10  5 /10  tline
   2 /10  5 /10     4 /10  5 /10  tline
   2 /10  3 /10     3 /10  3 /10  tline
   4 /10  1 /10     4 /10  3 /10  tline
   5 /10  1 /10     7 /10  1 /10  tline
   5 /10  1 /10     5 /10  2 /10  tline
   5 /10  2 /10     7 /10  2 /10  tline
   7 /10  1 /20     7 /10  2 /10  tline
   7 /10  1 /20     4 /10  1 /20  tline
;

: blanky ;
: fish2   ['] fish rot45 hflip execute ;
: fish3   ['] fish2 rot90 rot90 rot90 execute ;
: tile   fish fish2 fish3 ;
: tile-u
    ['] fish2 dup rot90 dup rot90 dup rot90
    both both both execute ;

: quartet ( p q r s -- c ) beside >r beside r> above ;
: cycle ( p -- c ) dup rot90 dup rot90 dup rot90 quartet ;
: side ( n -- c )
   dup 0= if drop ['] blanky else
     1- recurse dup ['] tile dup rot90 swap quartet then ;
: corner ( n -- c )
   dup 0= if drop ['] blanky else
     1- dup recurse swap side dup rot90 ['] tile-u quartet then ;

: nonet ( p q r s t u v w x )
   beside beside3rd >r
   beside beside3rd r> above >r
   beside beside3rd r> above3rd ;
: squarelimit ( n -- c )
   dup corner swap side 2dup >r >r over rot90 rot90 rot90
   over rot90 ['] tile-u over rot90 rot90
   r> rot90 r> rot90 rot90 over rot90 nonet ;

3 squarelimit execute
showpage

3. Modularity, Objects, and State

Registers Machines

• TODO: More exploration of this chapter
• Explore when Forth overfavors mutable state?
• Explore simulators in Forth?
• Generators / Infinite Streams?
• Concurrency?

4. Metalinguistic Abstraction

Lisp in Lisp, Forth in Forth

• Meta-circular evaluator / Meta-compilation
• Implement the semantics of the language
• Reuse the parser
• Reuse "basic" operations

Eval-Apply

Eval

(define (eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((quoted? exp) (text-of-quotation exp))
        ((assignment? exp) (eval-assignment exp env))
        ((definition? exp) (eval-definition exp env))
        ((if? exp) (eval-if exp env))
        ((lambda? exp)
         (make-procedure (lambda-parameters exp)
                         (lambda-body exp)
                         env))
        ((begin? exp)
         (eval-sequence (begin-actions exp) env))
        ((cond? exp) (eval (cond->if exp) env))
        ((application? exp)
         (apply (eval (operator exp) env)
                (list-of-values (operands exp) env)))
        (else
         (error "Unknown expression type -- EVAL" exp))))

Apply

(define (apply procedure arguments)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure procedure arguments))
        ((compound-procedure? procedure)
         (eval-sequence
           (procedure-body procedure)
           (extend-environment
             (procedure-parameters procedure)
             arguments
             (procedure-environment procedure))))
        (else
         (error
          "Unknown procedure type -- APPLY" procedure))))

Meta-Compiler (rstack)

( Internal rstack )
create rstack 1000 cells allot   variable rp rstack rp !
: rp@ rp @ ;   : rp! rp ! ;  : r@ rp@ @ ;
: >r cell rp +! rp@ ! ;   : r> r@ -1 cells rp +! ;

Meta-Compiler (core)

( Internal IP & W )
variable ip   variable w
: run   0 >r begin
        ip @ @ cell ip +! dup w ! @ execute ip @ 0= until ;

(define (make-procedure parameters body env)
  (list 'procedure parameters body env))
(define (compound-procedure? p)
  (tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))

(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())

(define (make-frame variables values)
  (cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
  (set-car! frame (cons var (car frame)))
  (set-cdr! frame (cons val (cdr frame))))

(define (extend-environment vars vals base-env)
  (if (= (length vars) (length vals))
      (cons (make-frame vars vals) base-env)
      (if (< (length vars) (length vals))
          (error "Too many arguments supplied" vars vals)
          (error "Too few arguments supplied" vars vals))))

(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (car vals))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))

Dictionary

variable last
( Create dictionary entry:
  { name-bytes name-len flags link code } )
: splace ( a n -- ) dup >r 0 do dup c@ c, 1+ loop drop r> , ;
: create-name ( a n -- ) splace 0 , last @ , here 0 , last ! ;
: code!   last @ ! ;
: p:   ' dup >name name>string create-name code! ;
: >p   create-name ' code! ;
( Access dictionary entry )
: >link 1 cells - @ ;   : >flags 2 cells - ;
: >name ( xt -- a n )
   dup 3 cells - @ swap over - 3 cells - swap ;
: or! ( n a -- ) dup @ rot or swap ! ;
: immediate   1 last @ >flags or! ;
: immediate? >flags @ 1 and 0<> ;

Evaluating If

(define (eval-if exp env)
  (if (true? (eval (if-predicate exp) env))
      (eval (if-consequent exp) env)
      (eval (if-alternative exp) env)))

Threaded Interperter

( Interpreter branching, calling, and literals )
: docreate: w @ cell+ cell+ ;
: dodoes: docreate: ip @ >r w @ cell+ @ ip ! ;
: docol: ip @ >r w @ cell+ ip ! ;
: dolit: ip @ @ cell ip +! ;
: branch ip @ @ ip ! ;
: 0branch if cell ip +! else ip @ @ ip ! then ;

( CREATE DOES> )
: create   parse-name create-name ['] docreate: code! 0 , ;
: does>   ['] dodoes: code! ip @ last @ cell+ ! r> ip ! ;

Searching the Dictionary

( Words that traverse the dictionary )
: find ( a n -- xt )
   last @ begin >r 2dup r@ >name str= if 2drop r> exit then
                r> >link dup 0= until drop 2drop 0 ;
: words last @ begin
        dup >name type space >link dup 0= until drop cr ;

( Literal handling )
p: dolit:   s" dolit:" find constant dolit:-xt
: aliteral dolit:-xt , , ;   p: aliteral
( Exit & Execute )
: 'exit r> ip ! ;   s" exit" >p 'exit
   s" exit" find constant exit-xt
: execute ( xt -- ) >r exit-xt >r rp @ 1 cells - ip ! ;
   p: execute
( Compiling words )
variable state
: colon parse-name create-name ['] docol: code! -1 state ! ;
   s" :" >p colon
: semicolon exit-xt , 0 state ! ;   s" ;" >p semicolon immediate

(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'null? null?)
        
        ))
(define (primitive-procedure-names)
  (map car
       primitive-procedures))

(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (cadr proc)))
       primitive-procedures))

( Pass thru primitives )
p: 0=   p: 0<   p: +   p: */mod   p: and   p: or   p: xor
p: dup   p: swap   p: over   p: drop   p: sp@   p: sp!
p: .   p: type   p: key
p: @   p: !   p: c@   p: c!
p: parse-name   p: parse   p: here   p: ,   p: allot
p: base   p: depth   p: cell
( Reimplemented primitives )
p: r@   p: >r   p: r>   p: rp@   p: rp!
p: words   p: branch   p: 0branch   p: find
p: immediate   p: create   p: does>
p: last   p: state

(define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")
(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (let ((output (eval input the-global-environment)))
      (announce-output output-prompt)
      (user-print output)))
  (driver-loop))
(define (prompt-for-input string)
  (newline) (newline) (display string) (newline))

(define (announce-output string)
  (newline) (display string) (newline))

( Evaluate source )
: one-word dup immediate? 0= state @ and
    if , else execute run then ;
: one-number' state @ if aliteral then ;
: one-number s>number? 0= throw drop one-number' ;
: one-name 2dup find dup if nip nip one-word
           else drop one-number then ;
: prompt source-id 0= if ."  ok" cr then ;
: eval-line begin parse-name dup
            if one-name else 2drop exit then again ;
: boot begin ['] eval-line catch if ." ERROR" cr then
       prompt refill drop again ;
: include parse-name slurp-file ['] eval-line execute-parsing ;
    p: include
: ok ." CircleForth" cr ."   ok" cr query ;
    p: ok   : bye cr bye ;   p: bye

( Bootstrap )
boot
: (   41 parse drop drop ; immediate
( And now we have comments! )
include compound.fs
ok

( Useful basic compound words )
: 2drop ( n n -- ) drop drop ;
: 2dup ( a b -- a b a b ) over over ;
: nip ( a b -- b ) swap drop ;
: rdrop ( r: n n -- ) r> r> drop >r ;
: */ ( n n n -- n ) */mod nip ;
: * ( n n -- n ) 1 */ ;
: /mod ( n n -- n n ) 1 swap */mod ;
: / ( n n -- n ) /mod nip ;
: mod ( n n -- n ) /mod drop ;
: invert ( n -- ~n ) -1 xor ;
: negate ( n -- -n ) invert 1 + ;
: - ( n n -- n ) negate + ;
: rot ( a b c -- c a b ) >r swap r> swap ;
: -rot ( a b c -- b c a ) swap >r swap r> ;
: cell+ ( n -- n ) cell + ;
: cells ( n -- n ) cell * ;
: < ( a b -- a<b) - 0< ;
: > ( a b -- a>b) swap - 0< ;
: emit ( n -- ) >r rp@ 1 type rdrop ;
: bl 32 ;   : space bl emit ;
: nl 10 ;   : cr nl emit ;

( Compilation State )
: [ 0 state ! ; immediate
: ] -1 state ! ; immediate

( Quoting words )
: ' parse-name find ;
: ['] ' aliteral ; immediate
: char parse-name drop c@ ;
: [char] char aliteral ; immediate
: literal aliteral ; immediate

( Core Control Flow )
: begin here ; immediate
: again ['] branch , , ; immediate
: until ['] 0branch , , ; immediate
: ahead ['] branch , here 0 , ; immediate
: then here swap ! ; immediate
: if ['] 0branch , here 0 , ; immediate
: else ['] branch , here 0 , swap here swap ! ; immediate

( Compound words requiring conditionals )
: min 2dup < if drop else nip then ;
: max 2dup < if nip else drop then ;

( Postpone - done here so we have ['] and if )
: >flags 2 cells - @ ;
: immediate? >flags 1 and 1 - 0= ;
: postpone ' dup immediate? if , else
           aliteral ['] , , then ; immediate

( Counted Loops )
: do postpone swap postpone >r postpone >r here ; immediate
: i postpone r@ ; immediate
: unloop postpone rdrop postpone rdrop ; immediate
: +loop postpone r> postpone + postpone r>
        postpone 2dup postpone >r postpone >r
        postpone < postpone 0= postpone until
        postpone unloop ; immediate
: loop 1 aliteral postpone +loop ; immediate

( Constants and Variables )
: constant create , does> @ ;
: variable create 0 , ;

( Exceptions )
variable handler
: catch
   sp@ > handler @ >r rp@ handler ! execute r> handler !
   r> drop 0 ;
: throw
   handler @ rp! r> handler ! r> swap >r sp! drop r> ;

( Examine Dictionary )
: >link ( xt -- a ) 1 cells - @ ;   : >flags 2 cells - ;
: >name ( xt -- a n )
   dup 3 cells - @ swap over - 3 cells - swap ;
: >body ( xt -- a ) cell+ ;
: see. ( xt -- ) >name type space ;
: see-one ( xt -- xt+1 )
   dup @ dup ['] dolit: = if drop cell+ dup @ .
   else see. then cell+ ;
: exit= ( xt -- ) ['] exit = ;
: see-loop   >body begin see-one dup @ exit= until ;
: see
   cr ['] : see.  ' dup see.  see-loop drop  ['] ; see.  cr ;

CircleForth

• 84 circle.fs
• 85 compound.fs
• DEMO

5. Computing with Register Machines

Registers Machines

• TODO: More exploration of this chapter
• Explore the Forth machine model?
• Forth Garbage Collection?
• Smarter Forth Compilation?

Notable Learnings

• Lists in Forth can be handy
• Closure in the math sense is powerful
• Tighter core, to tell a clearer language story
• Escher rocks

slides at: github.com/flagxor

SICP is available online

⚘

Thank you