This section lists code examples from the Revised^5 Report on the Algorithmic Language Scheme (r5rs) for which Armpit Scheme produces either the same output as in the report or a result that is considered very close to that in the report.
; 4. Expressions
; 4.1.1 variable references
(define x 28)
x
; 4.1.2 literal expressions
(quote a)
(quote #(a b c))
(quote (+ 1 2))
'a
'#(a b c)
'()
'(+ 1 2)
'(quote a)
''a
'"abc"
"abc"
'145932
145932
'#t
#t
; 4.1.3 procedure calls
(+ 3 4)
((if #f + *) 3 4)
; 4.1.4 procedures
(lambda (x) (+ x x))
((lambda (x) (+ x x)) 4)
(define reverse-subtract
(lambda (x y) (- y x)))
(reverse-subtract 7 10)
(define add4
(let ((x 4))
(lambda (y) (+ x y))))
(add4 6)
((lambda x x) 3 4 5 6)
((lambda (x y . z) z) 3 4 5 6)
; 4.1.5 conditionals
(if (> 3 2) 'yes 'no)
(if (> 2 3) 'yes 'no)
(if (> 3 2)
(- 3 2)
(+ 3 2))
; 4.1.6 assignments
(define x 2)
(+ x 1)
(set! x 4)
(+ x 1)
; 4.2.1 conditionals
(cond ((> 3 2) 'greater)
((< 3 2) 'less))
(cond ((> 3 3) 'greater)
((< 3 3) 'less)
(else 'equal))
(cond ((assv 'b '((a 1) (b 2))) => cadr)
(else #f))
(case (* 2 3)
((2 3 5 7) 'prime)
((1 4 6 8 9) 'composite))
(case (car '(c d))
((a) 'a)
((b) 'b))
(case (car '(c d))
((a e i o u) 'vowel)
((w y) 'semivowel)
(else 'consonant))
(and (= 2 2) (> 2 1))
(and (= 2 2) (< 2 1))
(and 1 2 'c '(f g))
(and)
(or (= 2 2) (> 2 1))
(or (= 2 2) (< 2 1))
(or #f #f #f)
(or (memq 'b '(a b c))
(/ 3 0))
; 4.2.2 binding constructs
(let ((x 2) (y 3))
(* x y))
(let ((x 2) (y 3))
(let ((x 7) (z (+ x y)))
(* z x)))
(let ((x 2) (y 3))
(let* ((x 7) (z (+ x y)))
(* z x)))
(letrec
((even?
(lambda (n)
(if (zero? n)
#t
(odd? (- n 1)))))
(odd?
(lambda (n)
(if (zero? n)
#f
(even? (- n 1))))))
(even? 88))
; 4.2.3 sequencing
(define x 0)
(begin (set! x 5)
(+ x 1))
(begin (display "4 plus 1 equals ")
(display (+ 4 1)))
; 4.2.4 iteration
(do ((vec (make-vector 5))
(i 0 (+ i 1)))
((= i 5) vec)
(vector-set! vec i i))
(let ((x '(1 3 5 7 9)))
(do ((x x (cdr x))
(sum 0 (+ sum (car x))))
((null? x) sum)))
(let loop ((numbers '(3 -2 1 6 -5))
(nonneg '())
(neg '()))
(cond ((null? numbers) (list nonneg neg))
((>= (car numbers) 0)
(loop (cdr numbers)
(cons (car numbers) nonneg)
neg))
((< (car numbers) 0)
(loop (cdr numbers)
nonneg
(cons (car numbers) neg)))))
; 4.2.6 quasiquotation
`(list ,(+ 1 2) 4)
(let ((name 'a)) `(list ,name ',name))
`(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)
`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))
`#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8) ; -> within rounding error: #(10 5 2. 3.99999 3. 8)
; 5. Program Structure
; 5.2 definitions
; 5.2.1 top level definitions
(define add3
(lambda (x) (+ x 3)))
(add3 3)
(define first car)
(first '(1 2))
; 5.2.2 internal definitions
(let ((x 5))
(define foo (lambda (y) (bar x y)))
(define bar (lambda (a b) (+ (* a b) a)))
(foo (+ x 3)))
(let ((x 5))
(letrec ((foo (lambda (y) (bar x y)))
(bar (lambda (a b) (+ (* a b) a))))
(foo (+ x 3))))
; 6. Standard Procedures
; 6.1 equivalence predicates
(eqv? 'a 'a)
(eqv? 'a 'b)
(eqv? 2 2)
(eqv? '() '())
(eqv? 100000000 100000000)
(eqv? (cons 1 2) (cons 1 2))
(eqv? (lambda () 1) (lambda () 2))
(eqv? #f 'nil)
(let ((p (lambda (x) x)))
(eqv? p p))
(eqv? "" "")
(eqv? '#() '#())
(eqv? (lambda (x) x) (lambda (x) x))
(eqv? (lambda (x) x) (lambda (y) y))
(define gen-counter
(lambda ()
(let ((n 0))
(lambda () (set! n (+ n 1)) n))))
(let ((g (gen-counter)))
(eqv? g g))
(eqv? (gen-counter) (gen-counter))
(define gen-loser
(lambda ()
(let ((n 0))
(lambda () (set! n (+ n 1)) 27))))
(let ((g (gen-loser)))
(eqv? g g))
(eqv? (gen-loser) (gen-loser))
(letrec ((f (lambda () (if (eqv? f g) 'both 'f)))
(g (lambda () (if (eqv? f g) 'both 'g))))
(eqv? f g))
(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
(g (lambda () (if (eqv? f g) 'g 'both))))
(eqv? f g))
(eq? '(a) '(a))
(eqv? "a" "a")
(eqv? '(b) (cdr '(a b)))
(let ((x '(a)))
(eqv? x x))
(eq? 'a 'a)
(eq? '(a) '(a))
(eq? (list 'a) (list 'a))
(eq? "a" "a")
(eq? "" "")
(eq? '() '())
(eq? 2 2)
(eq? #\A #\A)
(eq? car car)
(let ((n (+ 2 3)))
(eq? n n))
(let ((x '(a)))
(eq? x x))
(let ((x '#()))
(eq? x x))
(let ((p (lambda (x) x)))
(eq? p p))
(equal? 'a 'a)
(equal? '(a) '(a))
(equal? '(a (b) c) '(a (b) c))
(equal? "abc" "abc")
(equal? 2 2)
(equal? (make-vector 5 'a) (make-vector 5 'a))
(equal? (lambda (x) x) (lambda (y) y))
; 6.2 Numbers
; 6.2.5 numerical operations
(max 3 4)
(max 3.9 4)
(+ 3 4)
(+ 3)
(+)
(* 4)
(*)
(- 3 4)
(- 3 4 5)
(- 3)
(/ 3 4 5)
(/ 3)
(abs -7)
(modulo 13 4)
(remainder 13 4)
(modulo -13 4)
(remainder -13 4)
(modulo 13 -4)
(remainder 13 -4)
(modulo -13 -4)
(remainder -13 -4)
(gcd 32 -36)
(lcm 32 -36)
(floor -4.3)
(ceiling -4.3)
(truncate -4.3)
(round -4.3)
(floor 3.5)
(ceiling 3.5)
(truncate 3.5)
(round 3.5)
(round 7)
; 6.2.6 numerical input and output
(string->number "100")
(string->number "100" 16)
(string->number "1e2")
(string->number "15##") ; -> 1.5e4 = o.k. (fortuitious?)
; 6.3 Other Data Types
; 6.3.1 booleans
#t
#f
'#f
(not #t)
(not 3)
(not (list 3))
(not #f)
(not '())
(not (list))
(not 'nil)
(boolean? #f)
(boolean? 0)
(boolean? '())
; 6.3.2 pairs and list
(define x (list 'a 'b 'c))
(define y x)
y
(list? y)
(set-cdr! x 4)
x
(eqv? x y)
y
(list? y)
(set-cdr! x x)
(list? x)
(pair? '(a . b))
(pair? '(a b c))
(pair? '())
(pair? '#(a b))
(cons 'a '())
(cons '(a) '(b c d))
(cons "a" '(b c))
(cons 'a 3)
(cons '(a b) 'c)
(car '(a b c))
(car '((a) b c d))
(car '(1 . 2))
(cdr '((a) b c d))
(cdr '(1 . 2))
(define (f) (list 'not-a-constant-list))
(define (g) '(constant-list))
(set-car! (f) 3)
(list? '(a b c))
(list? '())
(list? '(a . b))
(let ((x (list 'a)))
(set-cdr! x x)
(list? x))
(list 'a (+ 3 4) 'c)
(list)
(length '(a b c))
(length '(a (b) (c d e)))
(length '())
(append '(x) '(y))
(append '(a) '(b c d))
(append '(a (b)) '((c)))
(append '(a b) '(c . d))
(append '() 'a)
(reverse '(a b c))
(reverse '(a (b c) d (e (f))))
(list-ref '(a b c d) 2)
(memq 'a '(a b c))
(memq 'b '(a b c))
(memq 'a '(b c d))
(memq (list 'a) '(b (a) c))
(member (list 'a) '(b (a) c))
(memq 101 '(100 101 102))
(memv 101 '(100 101 102))
(define e '((a 1) (b 2) (c 3)))
(assq 'a e)
(assq 'b e)
(assq 'd e)
(assq (list 'a) '(((a)) ((b)) ((c))))
(assoc (list 'a) '(((a)) ((b)) ((c))))
(assq 5 '((2 3) (5 7) (11 13)))
(assv 5 '((2 3) (5 7) (11 13)))
; 6.3.3 symbols
(symbol? 'foo)
(symbol? (car '(a b)))
(symbol? "bar")
(symbol? 'nil)
(symbol? '())
(symbol? #f)
(symbol->string 'flying-fish)
(symbol->string 'Martin)
(symbol->string
(string->symbol "Malvina"))
(string->symbol "mISSISSIppi")
(eq? 'JollyWog
(string->symbol
(symbol->string 'JollyWog)))
(string=? "K. Harper, M.D."
(symbol->string
(string->symbol "K. Harper, M.D.")))
(string=? "K. Harper, M.D."
(symbol->string
(string->symbol "K. Harper, M.D.")))
; 6.3.4 characters
#\a
#\A
#\(
#\
#\space
#\newline ; -> linefeed only (no carriage return)
(char>? #\A #\B)
(char>? #\a #\b)
(char>? #\0 #\9)
; 6.3.5 strings
"The word \"recursion\" has many meanings."
(define (f) (make-string 3 #\*))
(define (g) "***")
(string-set! (f) 0 #\?)
; 6.3.6 vectors
'#(0 (2 2 2 2) "Anna")
(vector 'a 'b 'c)
(vector-ref '#(1 1 2 3 5 8 13 21)
5)
(let ((vec (vector 0 '(2 2 2 2) "Anna")))
(vector-set! vec 1 '("Sue" "Sue"))
vec)
(vector->list '#(dah dah didah))
(list->vector '(dididit dah))
; 6.4 control features
(procedure? car)
(procedure? 'car)
(procedure? (lambda (x) (* x x)))
(procedure? '(lambda (x) (* x x)))
(call/cc procedure?)
(apply + (list 3 4))
(define compose
(lambda (f g)
(lambda args
(f (apply g args)))))
((compose sqrt *) 12 75) ; -> within rounding error: 2.99999e1 vs 30
(map cadr '((a b) (d e) (g h)))
(map (lambda (n) (expt n n)) '(1 2 3 4 5)) ; -> within 'rounding' error: (1 3.99999 2.7e1 2.55999e2 3.12498e3)
(map + '(1 2 3) '(4 5 6))
(let ((count 0))
(map (lambda (ignored)
(set! count (+ count 1))
count)
'(a b)))
(let ((v (make-vector 5)))
(for-each (lambda (i)
(vector-set! v i (* i i)))
'(0 1 2 3 4))
v)
(force (delay (+ 1 2)))
(let ((p (delay (+ 1 2))))
(list (force p) (force p)))
(define a-stream
(letrec ((next
(lambda (n)
(cons n (delay (next (+ n 1)))))))
(next 0)))
(define head car)
(define tail
(lambda (stream) (force (cdr stream))))
(head (tail (tail a-stream)))
(define count 0)
(define p
(delay (begin (set! count (+ count 1))
(if (> count x)
count
(force p)))))
(define x 5)
p
(force p)
p
(begin (set! x 10)
(force p))
(call/cc
(lambda (exit)
(for-each (lambda (x)
(if (negative? x)
(exit x)))
'(54 0 37 -3 245 19))
#t))
(define list-length
(lambda (obj)
(call/cc
(lambda (return)
(letrec ((r
(lambda (obj)
(cond ((null? obj) 0)
((pair? obj)
(+ (r (cdr obj)) 1))
(else (return #f))))))
(r obj))))))
(list-length '(1 2 3 4))
(list-length '(a b . c))
(call-with-values (lambda () (values 4 5))
(lambda (a b) b))
(call-with-values * -)
; 6.5. eval
(interaction-environment)
; 6.6 input and output
; no examples provided in r5rs
This section lists code examples from the Revised^5 Report on the Algorithmic Language Scheme (r5rs) for which Armpit Scheme does not produce an output that is similar to that in the report.
; 4.2.6 quasiquotation
`(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) ; -> niet (nested backquote/unquote)
(let ((name1 'x)
(name2 'y))
`(a `(b `name1 ,',name2 d) e)) ; -> nein (nested backquote/unquote)
; 4.3.2 pattern language
(let ((=> #f))
(cond (#t => 'ok))) ; -> nope (may work with let defined as hygienic macro, eg. 00.0098 -- niet with macros defined in 7.3 below)
; 6.2 Numbers
; 6.2.5 numerical operations
(remainder -13 -4.0) ; -> niet (gives nan)
(gcd) ; -> niet (gives nan)
(lcm 32.0 -36) ; -> niet (gives nan)
(lcm) ; -> niet (gives nan)
(round 7/2) ; -> niet (gives 700)
; 6.3 Other Data Types
; 6.3.2 pairs and list
(car '()) ; -> gives a value rather than error
(cdr '()) ; -> gives a value rather than error
(set-car! (g) 3) ; -> gives a value rather than error
; inexact->exact is not implemented
(list-ref '(a b c d)
(inexact->exact (round 1.8)))
; 6.3.3 symbols
; expression below works but returns #f
(eq? 'mISSISSIppi 'mississippi)
(eq? 'bitBlt (string->symbol "bitBlt")) ; -> gives #t
; 6.3.5 strings
(string-set! (g) 0 #\?) ; -> "?**" rather than error
(string-set! (symbol->string 'immutable) 0 #\?) ; -> "?mmutable" rather than error
; 6.3.6 vectors
; errors out because inexact? is not implemented
(vector-ref '#(1 1 2 3 5 8 13 21)
(let ((i (round (* 2 (acos -1)))))
(if (inexact? i)
(inexact->exact i)
i)))
(vector-set! '#(0 1 2) 1 "doe") ; -> executes rather than giving error
; 6.4 control features
; dynamic-wind is not implemented
(let ((path '())
(c #f))
(let ((add (lambda (s)
(set! path (cons s path)))))
(dynamic-wind
(lambda () (add 'connect))
(lambda ()
(add (call/cc
(lambda (c0)
(set! c c0)
'talk1))))
(lambda () (add 'disconnect)))
(if (< (length path) 4)
(c 'talk2)
(reverse path))))
; 6.5. eval
; scheme-report-environment is not implemented
(eval '(* 7 3) (scheme-report-environment 5))
; null-environment is not implemented
(let ((f (eval '(lambda (f x) (f x x))
(null-environment 5))))
(f + 10))
This section lists Armpit Scheme derived expression types (macros) corresponding to those described in Section 7.3 of the Revised^5 Report on the Algorithmic Language Scheme (r5rs). Differences between these definitions and those in r5rs are briefly described.
; armpit scheme working version - difference with r5rs is 1 vs 2 vars before ...
(define-syntax cond
(syntax-rules (else =>)
((_ (else result1 ...))
(begin result1 ...))
((_ (test => result))
(let ((temp test))
(if temp (result temp))))
((_ (test => result) clause1 ...)
(let ((temp test))
(if temp
(result temp)
(cond clause1 ...))))
((_ (test)) test)
((_ (test) clause1 ...)
(let ((temp test))
(if temp
temp
(cond clause1 ...))))
((_ (test result1 ...))
(if test (begin result1 ...)))
((_ (test result1 ...) clause1 ...)
(if test
(begin result1 ...)
(cond clause1 ...)))))
; armpit scheme working version - difference with r5rs is 1 vs 2 vars before ...
(define-syntax case
(syntax-rules (else)
((_ (key ...)
clauses ...)
(let ((atom-key (key ...)))
(case atom-key clauses ...)))
((_ key
(else result1 ...))
(begin result1 ...))
((_ key
((atom ...) result1 ...))
(if (memv key (quote (atom ...)))
(begin result1 ...)))
((_ key
((atoms ...) result1 ...)
clause1 ...)
(if (memv key (quote (atoms ...)))
(begin result1 ...)
(case key clause1 ...)))))
(define-syntax and
(syntax-rules ()
((_) #t)
((_ test) test)
((_ test1 test2 ...)
(if test1 (and test2 ...) #f))))
(define-syntax or
(syntax-rules ()
((_) #f )
((_ test) test)
((_ test1 test2 ...)
(let ((x test1))
(if x x (or test2 ...))))))
; armpit scheme working version - difference with r5rs is 1 vs 2 vars before ...
(define-syntax let
(syntax-rules ()
((_ ((name val) ...) body1 ...)
((lambda (name ...) body1 ...)
val ...))
((_ tag ((name val) ...) body1 ...)
((letrec ((tag (lambda (name ...)
body1 ...)))
tag)
val ...))))
; armpit scheme working version - difference with r5rs:
; 1) 1 vs 2 vars before ...
; 2) new case for single binding (not caught by (bd1 bd2 ...))
(define-syntax let*
(syntax-rules ()
((_ () body1 ...)
(let () body1 ...))
((_ (binding1) body1 ...)
(let (binding1) body1 ...))
((_ (binding1 binding2 ...) body1 ...)
(let (binding1)
(let* (binding2 ...) body1 ...)))))
; armpit scheme working version - difference with r5rs:
; 1) 1 vs 2 vars before ...
; 2) "generate_temp_names" replaced by #t
; 3) (x y ...) changed to (x . y)
(define-syntax letrec
(syntax-rules ()
((_ ((var1 init1) ...) body ...)
(letrec #t
(var1 ...)
()
((var1 init1) ...)
body ...))
((_ #t
()
(temp1 ...)
((var1 init1) ...)
body ...)
(let ((var1 #t ) ...)
(let ((temp1 init1) ...)
(set! var1 temp1) ...
body ...)))
((_ #t
(x . y)
temp
((var1 init1) ...)
body ...)
(letrec #t
y
(newtemp . temp)
((var1 init1) ...)
body ...))))
(define-syntax begin
(syntax-rules ()
((begin exp ...)
((lambda () exp ...)))))
; this form is not cooperating -> (apply error: #t)
(define-syntax begin
(syntax-rules ()
((begin exp)
exp)
((begin exp1 exp2 ...)
(let ((x exp1))
(begin exp2 ...)))))
; armpit scheme working version - difference with r5rs:
; 1) added case with no commands
; 2) changed "step" to #t
; 3) replaced step ... with . step
(define-syntax do
(syntax-rules ()
((_ ((var init . step) ...)
(test expr ...))
(do ((var init . step) ...)
(test expr ...)
()))
((_ ((var init . step) ...)
(test expr ...)
command ...)
(letrec
((loop
(lambda (var ...)
(if test
(begin
(if #f #f )
expr ...)
(begin
command ...
(loop (do #t var . step) ...))))))
(loop init ...)))
((_ #t x) x)
((_ #t x y) y)))