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)
(append
(make-bootstrapped-primitive-code 'double
'(lambda (x)
(* x x)))
(make-bootstrapped-primitive-code 'map
'(letrec ([map (lambda (f l)
(if (null? l)
null
(cons (f (car l))
(map f (cdr l)))))])
map))
(make-bootstrapped-primitive-code
'map
'(letrec ([map (lambda (f l)
(if (null? l)
null
(cons (f (car l))
(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:
(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
(define (caar l)
(car (car l)))
;; (define (caar l)
;; (car (car l)))
(define (map f l)
(if (null? l)
null
(cons (f (car l))
(map f (cdr l)))))
;; (define (map f l)
;; (if (null? l)
;; null
;; (cons (f (car l))
;; (map f (cdr l)))))
(define (for-each f l)
(if (null? l)
null
(begin (f (car l))
(for-each f (cdr l)))))
;; (define (for-each f l)
;; (if (null? l)
;; null
;; (begin (f (car l))
;; (for-each f (cdr l)))))
(define (memq x l)
(if (null? l)
#f
(if (eq? x (car l))
l
(memq x (cdr l)))))
;; (define (memq x l)
;; (if (null? l)
;; #f
;; (if (eq? x (car l))
;; l
;; (memq x (cdr l)))))
(define (assq x l)
(if (null? l)
#f
(if (eq? x (caar l))
(car l)
(assq x (cdr l)))))
;; (define (assq x l)
;; (if (null? l)
;; #f
;; (if (eq? x (caar l))
;; (car l)
;; (assq x (cdr l)))))
(define (length l)
(if (null? l)
0
(add1 (length (cdr l)))))
;; (define (length l)
;; (if (null? l)
;; 0
;; (add1 (length (cdr l)))))
(define (append l1 l2)
(if (null? l1)
l2
(cons (car l1) (append (cdr l1) l2))))
;; (define (append l1 l2)
;; (if (nullb? l1)
;; l2
;; (cons (car l1) (append (cdr l1) l2))))
(define vector-copy