From a3c9b7c7321ce0bfd2903c2035f885e28ea26a9f Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Thu, 28 Jul 2011 14:46:32 -0400 Subject: [PATCH] working on apply --- js-assembler/runtime-src/baselib-chars.js | 3 + js-assembler/runtime-src/baselib-equality.js | 16 + js-assembler/runtime-src/baselib-functions.js | 4 +- js-assembler/runtime-src/runtime.js | 69 +++ lang/kernel.rkt | 11 +- lang/private/list.rkt | 411 ++++++++++++++++++ tests/more-tests/simple-apply.expected | 5 + tests/more-tests/simple-apply.rkt | 17 + tests/run-more-tests.rkt | 3 +- 9 files changed, 533 insertions(+), 6 deletions(-) create mode 100644 lang/private/list.rkt create mode 100644 tests/more-tests/simple-apply.expected create mode 100644 tests/more-tests/simple-apply.rkt diff --git a/js-assembler/runtime-src/baselib-chars.js b/js-assembler/runtime-src/baselib-chars.js index 9b42db8..7e555cf 100644 --- a/js-assembler/runtime-src/baselib-chars.js +++ b/js-assembler/runtime-src/baselib-chars.js @@ -71,5 +71,8 @@ exports.Char = Char; + exports.makeChar = Char.makeInstance; + exports.isChar = plt.baselib.makeClassPredicate(Char); + })(this['plt'].baselib); \ No newline at end of file diff --git a/js-assembler/runtime-src/baselib-equality.js b/js-assembler/runtime-src/baselib-equality.js index 2404687..e4b6dd0 100644 --- a/js-assembler/runtime-src/baselib-equality.js +++ b/js-assembler/runtime-src/baselib-equality.js @@ -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) { diff --git a/js-assembler/runtime-src/baselib-functions.js b/js-assembler/runtime-src/baselib-functions.js index da71ce9..47bd9d3 100644 --- a/js-assembler/runtime-src/baselib-functions.js +++ b/js-assembler/runtime-src/baselib-functions.js @@ -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(); } diff --git a/js-assembler/runtime-src/runtime.js b/js-assembler/runtime-src/runtime.js index 56a3abd..0bc9f17 100644 --- a/js-assembler/runtime-src/runtime.js +++ b/js-assembler/runtime-src/runtime.js @@ -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), diff --git a/lang/kernel.rkt b/lang/kernel.rkt index d8b3708..18e2bec 100644 --- a/lang/kernel.rkt +++ b/lang/kernel.rkt @@ -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 diff --git a/lang/private/list.rkt b/lang/private/list.rkt new file mode 100644 index 0000000..4442bf6 --- /dev/null +++ b/lang/private/list.rkt @@ -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))) diff --git a/tests/more-tests/simple-apply.expected b/tests/more-tests/simple-apply.expected new file mode 100644 index 0000000..0672173 --- /dev/null +++ b/tests/more-tests/simple-apply.expected @@ -0,0 +1,5 @@ +14 +'(2 3 4 5) +"now factorial" +6 +144 diff --git a/tests/more-tests/simple-apply.rkt b/tests/more-tests/simple-apply.rkt new file mode 100644 index 0000000..3309f58 --- /dev/null +++ b/tests/more-tests/simple-apply.rkt @@ -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)) \ No newline at end of file diff --git a/tests/run-more-tests.rkt b/tests/run-more-tests.rkt index 91ea765..bdab7ad 100644 --- a/tests/run-more-tests.rkt +++ b/tests/run-more-tests.rkt @@ -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") \ No newline at end of file +(test "more-tests/hello-bf.rkt") +(test "more-tests/simple-apply.rkt")