suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adding more definitions

Browse Source
This commit is contained in:
dyoo 2011-03-15 15:55:32 -04:00
parent 9a527d48d4
commit 0c7a04f6ed
3 changed files with 118 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
bootstrapped-primitives.rkt
View File

@ -85,18 +85,69 @@
(define (get-bootstrapping-code) (define (get-bootstrapping-code)
(append (append
(make-bootstrapped-primitive-code 'double
'(lambda (x)
(* x x)))
(make-bootstrapped-primitive-code 'map (make-bootstrapped-primitive-code
'(letrec ([map (lambda (f l) 'map
(if (null? l) '(letrec ([map (lambda (f l)
null (if (null? l)
(cons (f (car l)) null
(map f (cdr l)))))]) (cons (f (car l))
map)) (map f (cdr l)))))])
map))
(make-bootstrapped-primitive-code
'for-each
'(letrec ([for-each (lambda (f l)
(if (null? l)
null
(begin (f (car l))
(for-each f (cdr l)))))])
for-each))
(make-bootstrapped-primitive-code
'caar
'(lambda (x)
(car (car x))))
(make-bootstrapped-primitive-code
'memq
'(letrec ([memq (lambda (x l)
(if (null? l)
#f
(if (eq? x (car l))
l
(memq x (cdr l)))))])
memq))
(make-bootstrapped-primitive-code
'assq
'(letrec ([assq (lambda (x l)
(if (null? l)
#f
(if (eq? x (caar l))
(car l)
(assq x (cdr l)))))])
assq))
(make-bootstrapped-primitive-code
'length
'(letrec ([length-iter (lambda (l i)
(if (null? l)
i
(length-iter (cdr l) (add1 i))))])
(lambda (l) (length-iter l 0))))
(make-bootstrapped-primitive-code
'append
'(letrec ([append (lambda (l1 l2)
(if (null? l1)
l2
(cons (car l1) (append (cdr l1) l2))))])
append))
;; The call/cc code is special: ;; The call/cc code is special:
(let ([after-call/cc-code (make-label 'afterCallCCImplementation)]) (let ([after-call/cc-code (make-label 'afterCallCCImplementation)])

24
test-conform-browser.rkt Normal file
View File

@ -0,0 +1,24 @@
#lang racket
(require "browser-evaluate.rkt"
"package.rkt")
(define evaluate (make-evaluate package-anonymous))
(define-syntax (test stx)
(syntax-case stx ()
[(_ s exp)
(with-syntax ([stx stx])
(syntax/loc #'stx
(begin
(printf "running test...")
(let ([result (evaluate s)])
(let ([output (evaluated-stdout result)])
(unless (string=? output exp)
(printf " error!\n")
(raise-syntax-error #f (format "Expected ~s, got ~s" exp output)
#'stx)))
(printf " ok (~a milliseconds)\n" (evaluated-t result))))))]))
(test (read (open-input-file "tests/conform/program0.sch"))
(port->string (open-input-file "tests/conform/expected0.txt")))

64
tests/conform/program0.sch
View File

@ -1,46 +1,46 @@
(begin (begin
(define (caar l) ;; (define (caar l)
(car (car l))) ;; (car (car l)))
(define (map f l) ;; (define (map f l)
(if (null? l) ;; (if (null? l)
null ;; null
(cons (f (car l)) ;; (cons (f (car l))
(map f (cdr l))))) ;; (map f (cdr l)))))
(define (for-each f l) ;; (define (for-each f l)
(if (null? l) ;; (if (null? l)
null ;; null
(begin (f (car l)) ;; (begin (f (car l))
(for-each f (cdr l))))) ;; (for-each f (cdr l)))))
(define (memq x l) ;; (define (memq x l)
(if (null? l) ;; (if (null? l)
#f ;; #f
(if (eq? x (car l)) ;; (if (eq? x (car l))
l ;; l
(memq x (cdr l))))) ;; (memq x (cdr l)))))
(define (assq x l) ;; (define (assq x l)
(if (null? l) ;; (if (null? l)
#f ;; #f
(if (eq? x (caar l)) ;; (if (eq? x (caar l))
(car l) ;; (car l)
(assq x (cdr l))))) ;; (assq x (cdr l)))))
(define (length l) ;; (define (length l)
(if (null? l) ;; (if (null? l)
0 ;; 0
(add1 (length (cdr l))))) ;; (add1 (length (cdr l)))))
(define (append l1 l2) ;; (define (append l1 l2)
(if (null? l1) ;; (if (nullb? l1)
l2 ;; l2
(cons (car l1) (append (cdr l1) l2)))) ;; (cons (car l1) (append (cdr l1) l2))))
(define vector-copy (define vector-copy