Home |  Conforming |  Non-Conforming |  Macros


A Scheme Interpreter for ARM Microcontrollers:
Conformance to R5RS for Version 00.0152

SourceForge.net Logo
 

Conforming:


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




 

Non-Conforming:


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



 

Macros:


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



Last updated November 2, 2008

bioe-hubert-at-sourceforge.net