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

working on apply

Browse Source
This commit is contained in:
Danny Yoo 2011-07-28 14:46:32 -04:00
parent 50dbc2319a
commit a3c9b7c732
9 changed files with 533 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
js-assembler/runtime-src/baselib-chars.js
View File

@ -71,5 +71,8 @@
exports.Char = Char;
exports.makeChar = Char.makeInstance;
exports.isChar = plt.baselib.makeClassPredicate(Char);
})(this['plt'].baselib);

16
js-assembler/runtime-src/baselib-equality.js
View File

@ -4,6 +4,22 @@
baselib.equality = exports;
var eqv = function(x, y) {
if (x === y) { return true; }
if (plt.baselib.numbers.isNumber(x) && plt.baselib.numbers.isNumber(y)) {
return jsnums.eqv(x, y);
} else if (plt.baselib.chars.isChar(x) && plt.baselib.chars.isChar(y)) {
return x.val === y.val;
} else {
return false;
}
};
// equals: X Y -> boolean
// Returns true if the objects are equivalent; otherwise, returns false.
var equals = function(x, y, aUnionFind) {

4
js-assembler/runtime-src/baselib-functions.js
View File

@ -58,7 +58,7 @@
return;
}
var result = v.call(null, MACHINE);
var result = v(MACHINE);
MACHINE.argcount = oldArgcount;
for (var i = 0; i < arguments.length - 2; i++) {
MACHINE.env.pop();
@ -149,7 +149,7 @@
for (var i = 0; i < arguments.length - 4; i++) {
MACHINE.env.push(arguments[arguments.length - 1 - i]);
}
var result = proc.call(null, MACHINE);
var result = proc(MACHINE);
for (var i = 0; i < arguments.length - 4; i++) {
MACHINE.env.pop();
}

69
js-assembler/runtime-src/runtime.js
View File

@ -1170,6 +1170,17 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
return firstArg === secondArg;
});
installPrimitiveProcedure(
'eqv?',
2,
function(MACHINE) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
var secondArg = MACHINE.env[MACHINE.env.length-2];
return plt.baselib.equality.eqv(firstArg, secondArg);
});
installPrimitiveProcedure(
'equal?',
2,
@ -1180,6 +1191,48 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
});
installPrimitiveClosure(
'apply',
plt.baselib.arity.makeArityAtLeast(2),
function(MACHINE) {
if(--MACHINE.callsBeforeTrampoline < 0) {
throw arguments.callee;
}
var proc = checkProcedure(MACHINE, 'apply', 0);
MACHINE.env.pop();
MACHINE.argcount--;
checkList(MACHINE, 'apply', MACHINE.argcount - 1);
spliceListIntoStack(MACHINE, MACHINE.argcount - 1);
if (plt.baselib.arity.isArityMatching(proc.arity, MACHINE.argcount)) {
MACHINE.proc = proc;
if (plt.baselib.functions.isPrimitiveProcedure(proc)) {
return finalizeClosureCall(MACHINE, proc(MACHINE));
} else {
return proc.label(MACHINE);
}
} else {
raiseArityMismatchError(MACHINE, proc, proc.arity, MACHINE.argcount);
}
});
installPrimitiveProcedure(
'procedure?',
1,
function(MACHINE) {
return plt.baselib.functions.isProcedure(MACHINE.env[MACHINE.env.length - 1]);
});
installPrimitiveProcedure(
'procedure-arity-includes?',
2,
function(MACHINE) {
var proc = checkProcedure(MACHINE, 'procedure-arity-includes?', 0);
var argcount = checkNatural(MACHINE, 'procedure-arity-includes?', 1);
return plt.baselib.arity.isArityMatching(proc.arity, argcount);
});
installPrimitiveProcedure(
'member',
@ -1629,6 +1682,22 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
});
installPrimitiveProcedure(
'raise-mismatch-error',
3,
function(MACHINE) {
var name = checkSymbol(MACHINE, 'raise-mismatch-error', 0);
var message = checkString(MACHINE, 'raise-mismatch-error', 0);
var val = MACHINE.env[MACHINE.env.length - 1 - 2];
raise(MACHINE, plt.baselib.exceptions.makeExnFail
(plt.baselib.format.format("~a: ~a~e",
[name,
message,
val]),
undefined));
});
installPrimitiveProcedure(
'raise-type-error',
plt.baselib.arity.makeArityAtLeast(3),

11
lang/kernel.rkt
View File

@ -180,7 +180,7 @@
;; make-arity-at-least
;; arity-at-least?
;; arity-at-least-value
;; apply
apply
;; call-with-values
;; compose
@ -191,8 +191,10 @@
;; sleep
;; (identity -identity)
;; raise
error
raise-type-error
raise-mismatch-error
;; make-exn
;; make-exn:fail
@ -250,7 +252,8 @@ raise-type-error
;; exact->inexact
number->string
string->number
;; procedure?
procedure?
procedure-arity-includes?
pair?
list?
;; (undefined? -undefined?)
@ -279,8 +282,10 @@ exact?
;; negative?
;; box?
;; hash?
;; eqv?
equal?
eqv?
caar
;; cadr
;; cdar

411
lang/private/list.rkt Normal file
View File

@ -0,0 +1,411 @@
#lang s-exp "../kernel.rkt"
;; This is taken from collects/racket/private/list.rkt. The hope is that, eventually,
;; once I can support #%kernel, I won't need to do this fork to get at these...
(provide foldl
foldr
remv
remq
remove
remv*
remq*
remove*
memf
assf
findf
assq
assv
assoc
filter
;; sort
build-vector
build-string
build-list
compose
compose1)
;;(#%require (rename "sort.rkt" raw-sort sort)
;; (for-syntax "stxcase-scheme.rkt")
;; (only '#%unsafe unsafe-car unsafe-cdr))
;; (provide sort)
;; (define (sort lst less? #:key [getkey #f] #:cache-keys? [cache-keys? #f])
;; (unless (list? lst) (raise-type-error 'sort "proper list" lst))
;; (unless (and (procedure? less?) (procedure-arity-includes? less? 2))
;; (raise-type-error 'sort "procedure of arity 2" less?))
;; (when (and getkey (not (and (procedure? getkey)
;; (procedure-arity-includes? getkey 1))))
;; (raise-type-error 'sort "procedure of arity 1" getkey))
;; ;; don't provide the extra args if not needed, it's a bit faster
;; (if getkey (raw-sort lst less? getkey cache-keys?) (raw-sort lst less?)))
(define (do-remove who item list equal?)
(unless (list? list)
(raise-type-error who "list" list))
(let loop ([list list])
(cond [(null? list) null]
[(equal? item (car list)) (cdr list)]
[else (cons (car list) (loop (cdr list)))])))
(define remove
(case-lambda
[(item list) (do-remove 'remove item list equal?)]
[(item list equal?)
(unless (and (procedure? equal?)
(procedure-arity-includes? equal? 2))
(raise-type-error 'remove "procedure (arity 2)" equal?))
(do-remove 'remove item list equal?)]))
(define (remq item list)
(do-remove 'remq item list eq?))
(define (remv item list)
(do-remove 'remv item list eqv?))
(define (do-remove* who l r equal?)
(unless (list? l)
(raise-type-error who "list" l))
(unless (list? r)
(raise-type-error who "list" r))
(let rloop ([r r])
(cond
[(null? r) null]
[else (let ([first-r (car r)])
(let loop ([l-rest l])
(cond
[(null? l-rest) (cons first-r (rloop (cdr r)))]
[(equal? (car l-rest) first-r) (rloop (cdr r))]
[else (loop (cdr l-rest))])))])))
(define remove*
(case-lambda
[(l r) (do-remove* 'remove* l r equal?)]
[(l r equal?)
(unless (and (procedure? equal?)
(procedure-arity-includes? equal? 2))
(raise-type-error 'remove* "procedure (arity 2)" equal?))
(do-remove* 'remove* l r equal?)]))
(define (remq* l r)
(do-remove* 'remq* l r eq?))
(define (remv* l r)
(do-remove* 'remv* l r eqv?))
(define (memf f list)
(unless (and (procedure? f) (procedure-arity-includes? f 1))
(raise-type-error 'memf "procedure (arity 1)" f))
(let loop ([l list])
(cond
[(null? l) #f]
[(not (pair? l))
(raise-mismatch-error 'memf
"not a proper list: "
list)]
[else (if (f (car l)) l (loop (cdr l)))])))
(define (findf f list)
(unless (and (procedure? f) (procedure-arity-includes? f 1))
(raise-type-error 'findf "procedure (arity 1)" f))
(let loop ([l list])
(cond
[(null? l) #f]
[(not (pair? l))
(raise-mismatch-error 'findf
"not a proper list: "
list)]
[else (let ([a (car l)])
(if (f a)
a
(loop (cdr l))))])))
(define (bad-list who orig-l)
(raise-mismatch-error who
"not a proper list: "
orig-l))
(define (bad-item who a orig-l)
(raise-mismatch-error who
"non-pair found in list: "
a
" in "
orig-l))
(define-values (assq assv assoc assf)
(let ()
(define-syntax-rule (assoc-loop who x orig-l is-equal?)
(let loop ([l orig-l][t orig-l])
(cond
[(pair? l)
(let ([a (car #;unsafe-car l)])
(if (pair? a)
(if (is-equal? x (car #;unsafe-car a))
a
(let ([l (cdr #;unsafe-cdr l)])
(cond
;; [(eq? l t) (bad-list who orig-l)]
[(pair? l)
(let ([a (car #;unsafe-car l)])
(if (pair? a)
(if (is-equal? x (car #;unsafe-car a))
a
(let ([t (cdr #;unsafe-cdr t)]
[l (cdr #;unsafe-cdr l)])
(if (eq? l t)
(bad-list who orig-l)
(loop l t))))
(bad-item who a orig-l)))]
[(null? l) #f]
[else (bad-list who orig-l)])))
(bad-item who a orig-l)))]
[(null? l) #f]
[else (bad-list who orig-l)])))
(let ([assq
(lambda (x l)
(assoc-loop 'assq x l eq?))]
[assv
(lambda (x l)
(assoc-loop 'assv x l eqv?))]
[assoc
(case-lambda
[(x l) (assoc-loop 'assoc x l equal?)]
[(x l is-equal?)
(unless (and (procedure? is-equal?)
(procedure-arity-includes? is-equal? 2))
(raise-type-error 'assoc "procedure (arity 2)" is-equal?))
(assoc-loop 'assoc x l is-equal?)])]
[assf
(lambda (f l)
(unless (and (procedure? f) (procedure-arity-includes? f 1))
(raise-type-error 'assf "procedure (arity 1)" f))
(assoc-loop 'assf #f l (lambda (_ a) (f a))))])
(values assq assv assoc assf))))
;; fold : ((A B -> B) B (listof A) -> B)
;; fold : ((A1 ... An B -> B) B (listof A1) ... (listof An) -> B)
;; foldl builds "B" from the beginning of the list to the end of the
;; list and foldr builds the "B" from the end of the list to the
;; beginning of the list.
(define (mapadd f l last)
(let loop ([l l])
(if (null? l)
(list last)
(cons (f (car l)) (loop (cdr l))))))
(define (check-fold name proc init l more)
(unless (procedure? proc)
(apply raise-type-error name "procedure" 0 proc init l more))
(unless (list? l)
(apply raise-type-error name "list" 2 proc init l more))
(if (null? more)
(unless (procedure-arity-includes? proc 2)
(raise-mismatch-error name "given procedure does not accept 2 arguments: " proc))
(let ([len (length l)])
(let loop ([more more][n 3])
(unless (null? more)
(unless (list? (car more))
(apply raise-type-error name "list" n proc init l more))
(unless (= len (length (car more)))
(raise-mismatch-error name
"given list does not have the same size as the first list: "
(car more)))
(loop (cdr more) (add1 n))))
(unless (procedure-arity-includes? proc (+ 2 (length more)))
(raise-mismatch-error name
(format "given procedure does not accept ~a arguments: "
(+ 2 (length more)))
proc)))))
(define foldl
(case-lambda
[(f init l)
(check-fold 'foldl f init l null)
(let loop ([init init] [l l])
(if (null? l) init (loop (f (car l) init) (cdr l))))]
[(f init l . ls)
(check-fold 'foldl f init l ls)
(let loop ([init init] [ls (cons l ls)])
(if (pair? (car ls)) ; `check-fold' ensures all lists have equal length
(loop (apply f (mapadd car ls init)) (map cdr ls))
init))]))
(define foldr
(case-lambda
[(f init l)
(check-fold 'foldr f init l null)
(let loop ([init init] [l l])
(if (null? l)
init
(f (car l) (loop init (cdr l)))))]
[(f init l . ls)
(check-fold 'foldr f init l ls)
(let loop ([ls (cons l ls)])
(if (pair? (car ls)) ; `check-fold' ensures all lists have equal length
(apply f (mapadd car ls (loop (map cdr ls))))
init))]))
(define (filter f list)
(unless (and (procedure? f)
(procedure-arity-includes? f 1))
(raise-type-error 'filter "procedure (arity 1)" f))
(unless (list? list)
(raise-type-error 'filter "proper list" list))
;; accumulating the result and reversing it is currently slightly
;; faster than a plain loop
(let loop ([l list] [result null])
(if (null? l)
(reverse result)
(loop (cdr l) (if (f (car l)) (cons (car l) result) result)))))
;; (build-vector n f) returns a vector 0..n-1 where the ith element is (f i).
;; The eval order is guaranteed to be: 0, 1, 2, ..., n-1.
;; eg: (build-vector 4 (lambda (i) i)) ==> #4(0 1 2 3)
(define (build-vector n fcn)
(unless (exact-nonnegative-integer? n)
(raise-type-error 'build-vector "exact-nonnegative-integer" n))
(unless (and (procedure? fcn)
(procedure-arity-includes? fcn 1))
(raise-type-error 'build-vector "procedure (arity 1)" fcn))
(let ([vec (make-vector n)])
(let loop ((i 0))
(if (= i n)
vec
(begin (vector-set! vec i (fcn i)) (loop (add1 i)))))))
(define (build-string n fcn)
(unless (exact-nonnegative-integer? n)
(raise-type-error 'build-string "exact-nonnegative-integer" n))
(unless (and (procedure? fcn)
(procedure-arity-includes? fcn 1))
(raise-type-error 'build-string "procedure (arity 1)" fcn))
(let ([str (make-string n)])
(let loop ((i 0))
(if (= i n)
str
(begin (string-set! str i (fcn i)) (loop (add1 i)))))))
(define (build-list n fcn)
(unless (exact-nonnegative-integer? n)
(raise-type-error 'build-list "exact-nonnegative-integer" n))
(unless (and (procedure? fcn)
(procedure-arity-includes? fcn 1))
(raise-type-error 'build-list "procedure (arity 1)" fcn))
(let recr ([j 0] [i n])
(cond [(zero? i) null]
[else (cons (fcn j)
(recr (add1 j) (sub1 i)))])))
(define-values [compose1 compose]
(let ()
(define-syntax-rule (app1 E1 E2) (E1 E2))
(define-syntax-rule (app* E1 E2) (call-with-values (lambda () E2) E1))
(define-syntax-rule (mk-simple-compose app f g)
(let*-values
([(arity) (procedure-arity g)]
[(required-kwds allowed-kwds) (procedure-keywords g)]
[(composed)
;; FIXME: would be nice to use `procedure-reduce-arity' and
;; `procedure-reduce-keyword-arity' in the places marked below,
;; but they currently add a significant overhead.
(if (eq? 1 arity)
(lambda (x) (app f (g x)))
(case-lambda ; <--- here
[(x) (app f (g x))]
[(x y) (app f (g x y))]
[args (app f (apply g args))]))])
(if (null? allowed-kwds)
composed
(make-keyword-procedure ; <--- and here
(lambda (kws kw-args . xs)
(app f (keyword-apply g kws kw-args xs)))
composed))))
(define-syntax-rule (can-compose* name n g f fs)
(unless (null? (let-values ([(req _) (procedure-keywords g)]) req))
(apply raise-type-error 'name "procedure (no required keywords)"
n f fs)))
(define-syntax-rule (can-compose1 name n g f fs)
(begin (unless (procedure-arity-includes? g 1)
(apply raise-type-error 'name "procedure (arity 1)" n f fs))
;; need to check this too (see PR 11978)
(can-compose* name n g f fs)))
(define (pipeline1 f rfuns)
;; (very) slightly slower alternative:
;; (if (null? rfuns)
;; f
;; (pipeline1 (let ([fst (car rfuns)]) (lambda (x) (fst (f x))))
;; (cdr rfuns)))
(lambda (x)
(let loop ([x x] [f f] [rfuns rfuns])
(if (null? rfuns)
(f x)
(loop (f x) (car rfuns) (cdr rfuns))))))
(define (pipeline* f rfuns)
;; use the other composition style in this case, to optimize an
;; occasional arity-1 procedure in the pipeline
(if (eqv? 1 (procedure-arity f))
;; if `f' is single arity, then going in reverse they will *all* be
;; single arities
(let loop ([f f] [rfuns rfuns])
(if (null? rfuns)
f
(loop (let ([fst (car rfuns)])
(if (eqv? 1 (procedure-arity fst))
(lambda (x) (fst (f x)))
(lambda (x) (app* fst (f x)))))
(cdr rfuns))))
;; otherwise, going in reverse means that they're all n-ary, which
;; means that the list of arguments will be built for each stage, so
;; to avoid that go forward in this case
(let ([funs (reverse (cons f rfuns))])
(let loop ([f (car funs)] [funs (cdr funs)])
(if (null? funs)
f
(loop (let ([fst (car funs)])
(if (eqv? 1 (procedure-arity f))
(if (eqv? 1 (procedure-arity fst))
(lambda (x) (f (fst x)))
(lambda xs (f (apply fst xs))))
(if (eqv? 1 (procedure-arity fst))
(lambda (x) (app* f (fst x)))
(lambda xs (app* f (apply fst xs))))))
(cdr funs)))))))
(define-syntax-rule (mk name app can-compose pipeline mk-simple-compose)
(define name
(let ([simple-compose mk-simple-compose])
(case-lambda
[(f)
(if (procedure? f) f (raise-type-error 'name "procedure" 0 f))]
[(f g)
(unless (procedure? f)
(raise-type-error 'name "procedure" 0 f g))
(unless (procedure? g)
(raise-type-error 'name "procedure" 1 f g))
(can-compose name 0 f f '())
(simple-compose f g)]
[() values]
[(f0 . fs0)
(let loop ([f f0] [fs fs0] [i 0] [rfuns '()])
(unless (procedure? f)
(apply raise-type-error 'name "procedure" i f0 fs0))
(if (pair? fs)
(begin (can-compose name i f f0 fs0)
(loop (car fs) (cdr fs) (add1 i) (cons f rfuns)))
(simple-compose (pipeline (car rfuns) (cdr rfuns)) f)))]))))
(mk compose1 app1 can-compose1 pipeline1
(lambda (f g) (mk-simple-compose app1 f g)))
(mk compose app* can-compose* pipeline*
(lambda (f g)
(if (eqv? 1 (procedure-arity f))
(mk-simple-compose app1 f g)
(mk-simple-compose app* f g))))
(values compose1 compose)))

5
tests/more-tests/simple-apply.expected Normal file
View File

@ -0,0 +1,5 @@
14
'(2 3 4 5)
"now factorial"
6
144

17
tests/more-tests/simple-apply.rkt Normal file
View File

@ -0,0 +1,17 @@
#lang planet dyoo/whalesong
(apply + 2 3 4 5 '())
(apply (lambda args args) 2 3 4 5 '())
"now factorial"
(define (f x)
(cond
[(apply = `(,x 0))
1]
[else
(apply * `(,x ,(apply f (apply sub1 (apply list x '())) '())))]))
(f 3)
(+ (f 4) (f 5))

3
tests/run-more-tests.rkt
View File

@ -16,4 +16,5 @@
(test "more-tests/images.rkt")
(test "more-tests/lists.rkt")
(test "more-tests/earley.rkt")
(test "more-tests/hello-bf.rkt")
(test "more-tests/hello-bf.rkt")
(test "more-tests/simple-apply.rkt")