diff --git a/src/ikarus.apply.ss b/src/ikarus.apply.ss new file mode 100644 index 0000000..435b891 --- /dev/null +++ b/src/ikarus.apply.ss @@ -0,0 +1,39 @@ + +(library (ikarus apply) + (export apply) + (import + (except (ikarus) apply) + (only (scheme) $$apply $car $cdr $set-cdr!)) + + (define apply + (let () + (define (err f ls) + (if (procedure? f) + (error 'apply "not a list") + (error 'apply "~s is not a procedure" f))) + (define (fixandgo f a0 a1 ls p d) + (cond + [(null? ($cdr d)) + (let ([last ($car d)]) + ($set-cdr! p last) + (if (and (procedure? f) (list? last)) + ($$apply f a0 a1 ls) + (err f last)))] + [else (fixandgo f a0 a1 ls d ($cdr d))])) + (define apply + (case-lambda + [(f ls) + (if (and (procedure? f) (list? ls)) + ($$apply f ls) + (err f ls))] + [(f a0 ls) + (if (and (procedure? f) (list? ls)) + ($$apply f a0 ls) + (err f ls))] + [(f a0 a1 ls) + (if (and (procedure? f) (list? ls)) + ($$apply f a0 a1 ls) + (err f ls))] + [(f a0 a1 . ls) + (fixandgo f a0 a1 ls ls ($cdr ls))])) + apply))) diff --git a/src/ikarus.boot b/src/ikarus.boot index 7ed8046..6aba592 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.core.ss b/src/ikarus.core.ss index 53f719b..6e9c031 100644 --- a/src/ikarus.core.ss +++ b/src/ikarus.core.ss @@ -15,38 +15,6 @@ (lambda () (eof-object))) -(primitive-set! 'apply - (let () - (define (err f ls) - (if (procedure? f) - (error 'apply "not a list") - (error 'apply "~s is not a procedure" f))) - (define (fixandgo f a0 a1 ls p d) - (cond - [(null? ($cdr d)) - (let ([last ($car d)]) - ($set-cdr! p last) - (if (and (procedure? f) (list? last)) - ($$apply f a0 a1 ls) - (err f last)))] - [else (fixandgo f a0 a1 ls d ($cdr d))])) - (define apply - (case-lambda - [(f ls) - (if (and (procedure? f) (list? ls)) - ($$apply f ls) - (err f ls))] - [(f a0 ls) - (if (and (procedure? f) (list? ls)) - ($$apply f a0 ls) - (err f ls))] - [(f a0 a1 ls) - (if (and (procedure? f) (list? ls)) - ($$apply f a0 a1 ls) - (err f ls))] - [(f a0 a1 . ls) - (fixandgo f a0 a1 ls ls ($cdr ls))])) - apply)) diff --git a/src/makefile.ss b/src/makefile.ss index 183a666..313918a 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -26,6 +26,7 @@ "ikarus.control.ss" "ikarus.collect.ss" "ikarus.void.ss" + "ikarus.apply.ss" "ikarus.predicates.ss" "ikarus.pairs.ss" "ikarus.lists.ss"