From ae3e42654225119e29376c6b3942ab2dac88cfe8 Mon Sep 17 00:00:00 2001 From: dvanhorn Date: Sat, 1 Nov 2025 16:46:30 +0000 Subject: [PATCH] crook --- iniquity-plus/compile.rkt | 14 +--- iniquity-plus/interp.rkt | 34 +++----- iniquity-plus/parse.rkt | 18 ----- iniquity-plus/test/test-runner.rkt | 120 ++--------------------------- knock-plus/compile.rkt | 4 + knock-plus/test/test-runner.rkt | 6 ++ 6 files changed, 33 insertions(+), 163 deletions(-) diff --git a/iniquity-plus/compile.rkt b/iniquity-plus/compile.rkt index ae05bf5..dc85e4f 100644 --- a/iniquity-plus/compile.rkt +++ b/iniquity-plus/compile.rkt @@ -51,7 +51,8 @@ (match fun [(FunPlain xs e) (seq (Label (symbol->label f)) - ;; TODO: check arity + (Cmp r8 (length xs)) + (Jne 'err) (compile-e e (reverse xs)) (Add rsp (* 8 (length xs))) (Ret))] @@ -74,9 +75,7 @@ [(If e1 e2 e3) (compile-if e1 e2 e3 c)] [(Begin e1 e2) (compile-begin e1 e2 c)] [(Let x e1 e2) (compile-let x e1 e2 c)] - [(App f es) (compile-app f es c)] - [(Apply f es e) - (compile-apply f es e c)])) + [(App f es) (compile-app f es c)])) ;; Datum -> Asm (define (compile-datum d) @@ -168,15 +167,10 @@ (seq (Lea rax r) (Push rax) (compile-es es (cons #f c)) - ;; TODO: communicate argument count to called function + (Mov r8 (length es)) ; pass arity info (Jmp (symbol->label f)) (Label r)))) -;; Id [Listof Expr] Expr CEnv -> Asm -(define (compile-apply f es e c) - ;; TODO: implement apply - (seq)) - ;; [Listof Expr] CEnv -> Asm (define (compile-es es c) (match es diff --git a/iniquity-plus/interp.rkt b/iniquity-plus/interp.rkt index f55cbc9..a70e7d7 100644 --- a/iniquity-plus/interp.rkt +++ b/iniquity-plus/interp.rkt @@ -61,15 +61,7 @@ (let ((vs (interp-e* es r ds))) (match (defns-lookup ds f) [(Defn _ fun) - (apply-fun fun vs ds)]))] - [(Apply f es e) - (let ((vs (interp-e* es r ds)) - (ws (interp-e e r ds))) - (if (list? ws) - (match (defns-lookup ds f) - [(Defn _ fun) - (apply-fun fun (append vs ws) ds)]) - (raise 'err)))])) + (apply-fun fun vs ds)]))])) ;; (Listof Expr) REnv Defns -> (Listof Value) { raises 'err } (define (interp-e* es r ds) @@ -79,32 +71,30 @@ (cons (interp-e e r ds) (interp-e* es r ds))])) -;; Fun [Listof Values] Defns -> Answer +;; Fun [Listof Values] Defns -> Value { raises 'err } (define (apply-fun f vs ds) (match f [(FunPlain xs e) ; check arity matches-arity-exactly? (if (= (length xs) (length vs)) (interp-e e (zip xs vs) ds) - 'err)] + (raise 'err))] [(FunRest xs x e) ; check arity is acceptable (if (< (length vs) (length xs)) - 'err - (interp-e e - (zip (cons x xs) - (cons (drop vs (length xs)) - (take vs (length xs)))) - ds))] + (raise 'err) + (interp-e e + (zip (cons x xs) + (cons (drop vs (length xs)) + (take vs (length xs)))) + ds))] [(FunCase cs) - (match (select-case-lambda cs (length vs)) - ['err 'err] - [f (apply-fun f vs ds)])])) + (apply-fun (select-case-lambda cs (length vs)) vs ds)])) -;; [Listof FunCaseClause] Nat -> Fun | 'err +;; [Listof FunCaseClause] Nat -> Fun { raises 'err } (define (select-case-lambda cs n) (match cs - ['() 'err] + ['() (raise 'err)] [(cons (and (FunPlain xs e) f) cs) (if (= (length xs) n) f diff --git a/iniquity-plus/parse.rkt b/iniquity-plus/parse.rkt index e366f2b..571f80b 100644 --- a/iniquity-plus/parse.rkt +++ b/iniquity-plus/parse.rkt @@ -150,10 +150,6 @@ [(list ys gs e2) (list ys gs (Let x e1 e2))])])] [_ (error "let: bad syntax" s)])] - ['apply - (match sr - [(list-rest (? symbol? f) sr) - (parse-apply/acc sr f fs xs ys (if (memq f fs) gs (cons f gs)))])] [_ (match (parse-es/acc sr fs xs ys gs) [(list ys gs es) @@ -180,20 +176,6 @@ (error "parse error" s)])) (rec s xs ys gs)) -;; S-Expr Id [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] [Listof Id] Apply) -(define (parse-apply/acc s f fs xs ys gs) - (match s - [(list s) - (match (parse-e/acc s fs xs ys gs) - [(list ys gs e) - (list ys gs (Apply f '() e))])] - [(cons s sr) - (match (parse-e/acc s fs xs ys gs) - [(list ys gs e) - (match (parse-apply/acc sr f fs xs ys gs) - [(list ys gs (Apply f es e0)) - (list ys gs (Apply f (cons e es) e0))])])])) - ;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] [Listof Id] [Listof Expr]) ;; s: list of expressions shaped s-expr to be parsed ;; fs: defined function names diff --git a/iniquity-plus/test/test-runner.rkt b/iniquity-plus/test/test-runner.rkt index 3d3aaee..aa12655 100644 --- a/iniquity-plus/test/test-runner.rkt +++ b/iniquity-plus/test/test-runner.rkt @@ -201,6 +201,12 @@ '(2 3 4)) (check-equal? (run '(define (f x y) y) '(f 1 (add1 #f))) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1)) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1 2 3)) 'err)) (begin ;; Iniquity+ @@ -280,36 +286,6 @@ (cons (f 1 2 3) '())))) '(() 2 (3))) - - (check-equal? (run '(define (f) 1) - '(apply f '())) - 1) - (check-equal? (run '(define (f . xs) 1) - '(apply f '())) - 1) - (check-equal? (run '(define (f . xs) xs) - '(apply f '())) - '()) - (check-equal? (run '(define (f . xs) xs) - '(apply f (cons 1 (cons 2 (cons 3 '()))))) - '(1 2 3)) - (check-equal? (run '(define (f . xs) xs) - '(apply f 1 2 (cons 3 '()))) - '(1 2 3)) - (check-equal? (run '(define (append . xss) - (if (empty? xss) - '() - (if (empty? (car xss)) - (apply append (cdr xss)) - (cons (car (car xss)) - (apply append (cdr (car xss)) (cdr xss)))))) - '(define (list . xs) xs) - '(define (flatten xs) - (apply append xs)) - '(flatten (list (append) (append (list 1 2 3) (list 4 5) (list 6)) (list 7)))) - '(1 2 3 4 5 6 7)) - - ;; Extra tests (check-equal? (run '(define f (case-lambda)) '(if #f (f) 1)) 1) @@ -321,67 +297,6 @@ '(let ((x (f 1 2 3))) (f x))) '()) - (check-equal? (run '(define (f x . xs) - (let ((ys xs)) - (if (empty? xs) - x - (apply f ys)))) - '(let ((z 1)) - (f 1 2 3))) - 3) - (check-equal? (run '(define (f x . xs) - (let ((ys xs)) - (if (empty? xs) - x - (apply f ys)))) - '(let ((z 1)) - (f (f 1 2 3)))) - 3) - (check-equal? (run '(define f - (case-lambda - [(x . xs) - (let ((ys xs)) - (if (empty? xs) - x - (apply f xs)))])) - '(let ((z 1)) - (f (f 1 2 3)))) - 3) - (check-equal? (run '(define f - (case-lambda - [(x) x] - [(x . xs) - (apply f xs)])) - '(f 1 2 3)) - 3) - (check-equal? (run '(define f - (case-lambda - [(x) x] - [(x . xs) - (apply f xs)])) - '(f)) - 'err) - (check-equal? (run '(define f - (case-lambda - [(x y) x] - [(x y . xs) - (apply f xs)])) - '(f 1 2 3)) - 'err) - (check-equal? (run '(define f - (case-lambda - [(x y) x] - [(x y . xs) - (apply f xs)])) - '(f 1 2 (cons 3 (cons 4 '())))) - 'err) - (check-equal? (run '(define f - (case-lambda - [(x) (char->integer (car x))] - [(x y . xs) - (apply f xs)])) - '(f 1 2 (cons #\A 4))) - 65) (check-equal? (run '(define f (case-lambda [(x y) x] @@ -390,28 +305,7 @@ [(x y z . xs) (char->integer z)])) '(f 1 #\a 3)) - 97) - (check-equal? (run '(define plus - (case-lambda - [() 0] - [(n . ns) (+ n (apply plus ns))])) - '(define (cars xss) - (if (empty? xss) - '() - (cons (car (car xss)) (cars (cdr xss))))) - '(define (cdrs xss) - (if (empty? xss) - '() - (cons (cdr (car xss)) (cdrs (cdr xss))))) - '(define (mapplus ns . nss) - (if (cons? ns) - (cons (apply plus (car ns) (cars nss)) - (apply mapplus (cdr ns) (cdrs nss))) - '())) - '(mapplus (cons 1 (cons 2 '())) - (cons 3 (cons 4 '())) - (cons 5 (cons 6 '())))) - '(9 12)))) + 97))) (define (test/io run) (begin ;; Evildoer diff --git a/knock-plus/compile.rkt b/knock-plus/compile.rkt index 8b732af..944da65 100644 --- a/knock-plus/compile.rkt +++ b/knock-plus/compile.rkt @@ -47,6 +47,8 @@ (match d [(Defn f xs e) (seq (Label (symbol->label f)) + (Cmp r8 (length xs)) ; arity check + (Jne 'err) (compile-e e (reverse xs) #t) (Add rsp (* 8 (length xs))) ; pop args (Ret))])) @@ -169,6 +171,7 @@ (seq (compile-es es c) (move-args (length es) (length c)) (Add rsp (* 8 (length c))) + (Mov r8 (length es)) ; pass arity info (Jmp (symbol->label f)))) ;; Integer Integer -> Asm @@ -185,6 +188,7 @@ (seq (Lea rax r) (Push rax) (compile-es es (cons #f c)) + (Mov r8 (length es)) ; pass arity info (Jmp (symbol->label f)) (Label r)))) diff --git a/knock-plus/test/test-runner.rkt b/knock-plus/test/test-runner.rkt index c26075c..e44d60f 100644 --- a/knock-plus/test/test-runner.rkt +++ b/knock-plus/test/test-runner.rkt @@ -201,6 +201,12 @@ '(2 3 4)) (check-equal? (run '(define (f x y) y) '(f 1 (add1 #f))) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1)) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1 2 3)) 'err)) (begin ;; Knock