Step 14-17 complete: advanced type system (occurrence typing, row polymorphism, refinement types, type-directed compilation)
ober
eaa068b6c351b1436f5efa58de2e85d11aa59b0d
--- a/Makefile +++ b/Makefile @@ -81,6 +81,7 @@ test-features: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-channel2.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-task.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed-advanced.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-cache.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-effect.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-async.ss --- a/lib/std/typed.sls +++ b/lib/std/typed.sls @@ -17,6 +17,8 @@ *typed-mode* register-type-predicate! type-predicate + check-type! + check-return-type! ;; Phase 3: op specialization with-fixnum-ops with-flonum-ops ;; Phase 4 (Step 10): effect type annotations @@ -205,27 +207,15 @@ ;; ;; (with-fixnum-ops body ...) ;; Recursively replaces generic arithmetic operators in body with fixnum - ;; variants: + → fx+, - → fx-, * → fx*, < → fx<, etc. - ;; The programmer takes responsibility for ensuring the values are fixnums. - ;; This allows Chez's cp0/cptypes to see the specialized ops directly. + ;; variants: + -> fx+, - -> fx-, * -> fx*, < -> fx<, etc. + ;; Walks the syntax tree directly to preserve lexical scopes of all + ;; non-operator identifiers (e.g., function arguments a, b). ;; ;; (with-flonum-ops body ...) - ;; Like with-fixnum-ops but replaces + → fl+, - → fl-, * → fl*, / → fl/, etc. - - ;; ========== Phase 3: Op Specialization ========== - ;; - ;; (with-fixnum-ops body ...) - ;; Recursively replaces generic arithmetic operators in body with fixnum - ;; variants: + → fx+, - → fx-, * → fx*, < → fx<, etc. - ;; The programmer takes responsibility for ensuring the values are fixnums. - ;; This allows Chez's cp0/cptypes to see the specialized ops directly. - ;; - ;; (with-flonum-ops body ...) - ;; Like with-fixnum-ops but replaces + → fl+, - → fl-, * → fl*, / → fl/, etc. + ;; Like with-fixnum-ops but replaces + -> fl+, etc. (define-syntax with-fixnum-ops (lambda (stx) - ;; Map of generic op → fixnum op (both as symbols) (define fx-map '((+ . fx+) (- . fx-) @@ -246,31 +236,32 @@ (max . fxmax) (add1 . fx1+) (sub1 . fx1-))) - ;; Special forms whose head must not be transformed (define special-heads '(quote if begin let let* letrec letrec* cond case when unless and or lambda define set! do guard with-syntax define-syntax let-syntax letrec-syntax syntax-rules define-record-type library import export)) - (define (transform datum) - (cond - [(pair? datum) - (let ([head (car datum)]) - (cond - ;; Special forms: preserve head, recurse into subforms - [(memq head special-heads) - (cons head (map transform (cdr datum)))] - ;; Known arithmetic op: replace with fixnum version - [(assq head fx-map) => - (lambda (pair) (cons (cdr pair) (map transform (cdr datum))))] - ;; Other applications: recurse everywhere - [else (map transform datum)]))] - [else datum])) + ;; Walk syntax tree; use let* to avoid deep paren nesting. + (define (transform s) + (if (not (pair? (syntax->datum s))) + s + (let* ([lst (syntax->list s)] + [head (and lst (not (null? lst)) (car lst))] + [tail (and lst (not (null? lst)) (cdr lst))] + [head-sym (and head (identifier? head) (syntax->datum head))]) + (cond + [(not lst) s] + [(null? lst) s] + [(and head-sym (memq head-sym special-heads)) + #`(#,head #,@(map transform tail))] + [(and head-sym (assq head-sym fx-map)) + => (lambda (p) + (let ([new-head (datum->syntax head (cdr p))]) + #`(#,new-head #,@(map transform tail))))] + [else #`(#,@(map transform lst))])))) (syntax-case stx () [(kw body ...) - (let ([transformed (map (lambda (b) (transform (syntax->datum b))) - (syntax->list #'(body ...)))]) - (datum->syntax #'kw `(begin ,@transformed)))]))) + #`(begin #,@(map transform (syntax->list #'(body ...))))]))) (define-syntax with-flonum-ops (lambda (stx) @@ -305,22 +296,26 @@ and or lambda define set! do guard with-syntax define-syntax let-syntax letrec-syntax syntax-rules define-record-type library import export)) - (define (transform datum) - (cond - [(pair? datum) - (let ([head (car datum)]) - (cond - [(memq head special-heads) - (cons head (map transform (cdr datum)))] - [(assq head fl-map) => - (lambda (pair) (cons (cdr pair) (map transform (cdr datum))))] - [else (map transform datum)]))] - [else datum])) + (define (transform s) + (if (not (pair? (syntax->datum s))) + s + (let* ([lst (syntax->list s)] + [head (and lst (not (null? lst)) (car lst))] + [tail (and lst (not (null? lst)) (cdr lst))] + [head-sym (and head (identifier? head) (syntax->datum head))]) + (cond + [(not lst) s] + [(null? lst) s] + [(and head-sym (memq head-sym special-heads)) + #`(#,head #,@(map transform tail))] + [(and head-sym (assq head-sym fl-map)) + => (lambda (p) + (let ([new-head (datum->syntax head (cdr p))]) + #`(#,new-head #,@(map transform tail))))] + [else #`(#,@(map transform lst))])))) (syntax-case stx () [(kw body ...) - (let ([transformed (map (lambda (b) (transform (syntax->datum b))) - (syntax->list #'(body ...)))]) - (datum->syntax #'kw `(begin ,@transformed)))]))) + #`(begin #,@(map transform (syntax->list #'(body ...))))]))) ;; ========== Step 10: Effect Type Annotations ========== ;; new file mode 100644 --- /dev/null +++ b/lib/std/typed/advanced.sls @@ -0,0 +1,474 @@ +#!chezscheme +;;; (std typed advanced) — Advanced type system features +;;; +;;; Step 14: Occurrence typing — type narrowing in branches +;;; Step 15: Row polymorphism — structural subtyping for records +;;; Step 16: Refinement types — types with predicates +;;; Step 17: Type-directed compilation — emit specialized ops from types +;;; +;;; API: +;;; ;; Step 14: Occurrence typing +;;; (cond/t ([test body ...] ...) — narrowing cond +;;; (if/t test then else) — narrowing if +;;; (when/t test body ...) — narrowing when +;;; +;;; ;; Step 15: Row polymorphism +;;; (defrow Name (field : Type) ...) — define a row type +;;; (row-check obj (field : Type) ...) — check fields exist and have types +;;; (Row field: Type ...) — row type specifier +;;; +;;; ;; Step 16: Refinement types +;;; (Refine Type pred) — type + predicate specifier +;;; (refine-check val type pred) — runtime refinement check +;;; +;;; ;; Step 17: Type-directed compilation +;;; (define/tc (name [arg : type] ...) : ret-type body ...) +;;; — like define/t but emits specialized ops based on known types + +(library (std typed advanced) + (export + ;; Step 14: Occurrence typing + cond/t + if/t + when/t + unless/t + + ;; Step 15: Row polymorphism + defrow + row? + row-check + row-type? + + ;; Step 16: Refinement types + make-refinement-type + refinement-type? + refinement-type-base + refinement-type-pred + check-refinement! + assert-refined + + ;; Step 17: Type-directed compilation + define/tc + lambda/tc + + ;; Type specs + Union + Intersection) + + (import (chezscheme) (std typed)) + + ;; ========== Step 14: Occurrence Typing ========== + ;; + ;; After (string? x) in a test, x is narrowed to String in the branch. + ;; We implement this via macro expansion that annotates the branch body. + ;; + ;; Supported predicate → type narrowings: + ;; string? → string fixnum? → fixnum flonum? → flonum + ;; pair? → pair list? → list null? → null + ;; vector? → vector symbol? → symbol char? → char + ;; boolean? → boolean number? → number procedure? → procedure + + (meta define *predicate->type* + '((string? . string) + (fixnum? . fixnum) + (flonum? . flonum) + (number? . number) + (integer? . integer) + (real? . real) + (pair? . pair) + (list? . list) + (null? . null) + (vector? . vector) + (symbol? . symbol) + (char? . char) + (boolean? . boolean) + (procedure? . procedure) + (bytevector? . bytevector) + (hashtable? . hashtable))) + + ;; Extract narrowed type from a predicate applied to a variable. + ;; Returns (var-sym . type-sym) or #f. + (meta define (extract-narrowing test-datum) + (and (pair? test-datum) + (= (length test-datum) 2) + (let ([pred (car test-datum)] + [arg (cadr test-datum)]) + (and (symbol? arg) + (assq pred *predicate->type*) + (cons arg (cdr (assq pred *predicate->type*))))))) + + ;; (if/t test then else) + ;; Emits type assertions in the branches based on the test predicate. + (define-syntax if/t + (lambda (stx) + (syntax-case stx () + [(k test then else) + (let ([narrowing (extract-narrowing (syntax->datum #'test))]) + (if narrowing + (let ([var-sym (car narrowing)] + [type-sym (cdr narrowing)]) + (with-syntax ([var (datum->syntax #'k var-sym)] + [type (datum->syntax #'k type-sym)]) + #'(if test + (let ([var (begin (assert-type var type) var)]) + then) + else))) + #'(if test then else)))]))) + + ;; (when/t test body ...) + (define-syntax when/t + (lambda (stx) + (syntax-case stx () + [(k test body ...) + (let ([narrowing (extract-narrowing (syntax->datum #'test))]) + (if narrowing + (let ([var-sym (car narrowing)] + [type-sym (cdr narrowing)]) + (with-syntax ([var (datum->syntax #'k var-sym)] + [type (datum->syntax #'k type-sym)]) + #'(when test + (let ([var (begin (assert-type var type) var)]) + body ...)))) + #'(when test body ...)))]))) + + ;; (unless/t test body ...) + (define-syntax unless/t + (lambda (stx) + (syntax-case stx () + [(k test body ...) + #'(when/t (not test) body ...)]))) + + ;; (cond/t ([test body ...] ...) [else body ...]) + ;; Narrows in each branch based on the test predicate. + ;; Uses pattern-variable decomposition to preserve use-site lexical scope. + (define-syntax cond/t + (lambda (stx) + (syntax-case stx (else) + [(k [else body ...]) + #'(begin body ...)] + ;; Test is a 2-element predicate application (pred var-ref) + [(k [(pred var-ref) body ...] rest ...) + (let* ([pred-sym (syntax->datum #'pred)] + [type-entry (assq pred-sym *predicate->type*)]) + (if (and type-entry (identifier? #'var-ref)) + (with-syntax ([type (datum->syntax #'k (cdr type-entry))]) + ;; var-ref is the actual use-site syntax object for the variable + ;; Using it as both the let binding name and in body preserves scope + #'(if (pred var-ref) + (let ([var-ref (begin (assert-type var-ref type) var-ref)]) + body ...) + (cond/t rest ...))) + #'(if (pred var-ref) (begin body ...) (cond/t rest ...))))] + ;; Fallback: test is not a simple predicate application + [(k [test body ...] rest ...) + #'(if test (begin body ...) (cond/t rest ...))] + [(k) #'(void)]))) + + ;; ========== Step 15: Row Polymorphism ========== + ;; + ;; A row type matches "any object with at least these fields". + ;; At runtime: checks that the object has the required accessors. + ;; + ;; (defrow Printable + ;; (to-string : procedure)) + ;; + ;; (row-check obj Printable) -- verifies obj satisfies Printable row + + ;; Row type descriptor + (define-record-type row-type + (fields + (immutable name) + (immutable fields)) ;; list of (field-name . type-spec) + (sealed #t)) + + ;; Registry of defined row types + (define *row-types* (make-eq-hashtable)) + + (define (row? name) + (hashtable-ref *row-types* name #f)) + + ;; (defrow Name (field : Type) ...) + ;; Defines a row type and a checker predicate. + (define-syntax defrow + (lambda (stx) + (syntax-case stx () + [(_ name (field-name colon field-type) ...) + (and (identifier? #'name) + (for-all (lambda (c) (eq? (syntax->datum c) ':)) + (syntax->list #'(colon ...)))) + (with-syntax ([checker-name + (datum->syntax #'name + (string->symbol + (string-append + (symbol->string (syntax->datum #'name)) + "?")))] + [check-name + (datum->syntax #'name + (string->symbol + (string-append + "check-" + (symbol->string (syntax->datum #'name)) + "!")))]) + #'(begin + ;; Register row type + (define %row-type% + (make-row-type 'name + '((field-name . field-type) ...))) + (hashtable-set! *row-types* 'name %row-type%) + ;; Predicate: checks field existence via accessor naming + (define (checker-name obj) + (row-satisfies? obj '((field-name . field-type) ...))) + ;; Check function: raises on failure + (define (check-name obj) + (unless (checker-name obj) + (error 'check-name + (format "object does not satisfy row ~a" 'name) + obj)))))]))) + + ;; Check if obj satisfies a row spec (field-name . type-spec) ... + ;; Uses Jerboa's struct-field-ref to check field accessibility. + (define (row-satisfies? obj fields) + (for-all + (lambda (field-spec) + (let* ([fname (symbol->string (car field-spec))] + [accessor-sym (string->symbol fname)]) + ;; Try to access the field; if it works, the row is satisfied + (guard (exn [#t #f]) + (let ([accessor (eval accessor-sym (interaction-environment))]) + (if (procedure? accessor) + (begin (accessor obj) #t) + #f))))) + fields)) + + ;; (row-check obj (field : Type) ...) + ;; Runtime check that obj satisfies a row type. + (define-syntax row-check + (lambda (stx) + (syntax-case stx () + [(_ obj-expr row-name) + #'(let ([obj obj-expr]) + (let ([row (hashtable-ref *row-types* 'row-name #f)]) + (if row + (row-satisfies? obj (row-type-fields row)) + (error 'row-check "unknown row type" 'row-name))))] + [(_ obj-expr (field-name colon field-type) ...) + (for-all (lambda (c) (eq? (syntax->datum c) ':)) + (syntax->list #'(colon ...))) + #'(row-satisfies? obj-expr '((field-name . field-type) ...))]))) + + ;; ========== Step 16: Refinement Types ========== + ;; + ;; (Refine Type pred) — type + predicate + ;; (assert-refined val type pred) — check base type then predicate + + (define-record-type refinement-type + (fields + (immutable base) ;; base type name (symbol) + (immutable pred)) ;; predicate (procedure or symbol) + (sealed #t)) + + (define (check-refinement! who name val base pred-spec) + (when (eq? (*typed-mode*) 'debug) + ;; Check base type + (let ([base-pred (type-predicate base)]) + (when (and base-pred (not (eq? base 'any))) + (unless (base-pred val) + (error who + (format "~a: expected ~a, got ~a" name base val) + val)))) + ;; Check refinement predicate + (let ([pred (if (procedure? pred-spec) + pred-spec + (eval pred-spec (interaction-environment)))]) + (unless (pred val) + (error who + (format "~a: refinement predicate failed for ~a" name val) + val))))) + + ;; (assert-refined expr base pred) + (define-syntax assert-refined + (lambda (stx) + (syntax-case stx () + [(_ expr base-type pred-expr) + #'(let ([v expr]) + (check-refinement! 'assert-refined 'expr v 'base-type pred-expr) + v)]))) + + ;; Extend type-predicate to handle Refine types. + ;; (Refine base pred) — both checked at runtime + ;; We handle this in define/tc below by recognizing the Refine form. + + ;; ========== Step 17: Type-Directed Compilation ========== + ;; + ;; (define/tc (name [arg : type] ...) : ret-type body ...) + ;; + ;; Like define/t but additionally: + ;; - If arg type is fixnum/flonum, wraps body in with-fixnum-ops/with-flonum-ops + ;; - If a type is (Refine base pred), checks the refinement in debug mode + ;; - If return type is fixnum/flonum, the body is wrapped accordingly + ;; + ;; Type-directed specialization rules: + ;; all-fixnum args + fixnum return → wrap body in (with-fixnum-ops ...) + ;; all-flonum args + flonum return → wrap body in (with-flonum-ops ...) + ;; mixed → no specialization (generic ops) + + (define-syntax define/tc + (lambda (stx) + (define (parse-typed-args args) + (let loop ([rest (syntax->list args)] [result '()]) + (if (null? rest) + (reverse result) + (let ([item (car rest)]) + (syntax-case item () + [(arg-name sep type-name) + (eq? (syntax->datum #'sep) ':) + (loop (cdr rest) + (cons (list #'arg-name #'type-name) result))] + [arg-name + (identifier? #'arg-name) + (loop (cdr rest) + (cons (list #'arg-name (datum->syntax #'arg-name 'any)) result))]))))) + + (define (all-type? parsed type-sym) + (for-all (lambda (p) + (eq? (syntax->datum (cadr p)) type-sym)) + parsed)) + + (define (is-refine? type-stx) + (let ([d (syntax->datum type-stx)]) + (and (pair? d) (eq? (car d) 'Refine)))) + + (define (emit-arg-checks who-stx parsed) + ;; For each arg, emit a check (handling Refine specially). + ;; who-stx must be a syntax object (e.g. #'name) to avoid raw-symbol errors. + (map (lambda (p) + (let ([arg (car p)] + [type (cadr p)]) + (let ([td (syntax->datum type)]) + (cond + [(and (pair? td) (eq? (car td) 'Refine)) + ;; (Refine base pred) — use who-stx (an identifier) as datum->syntax ctx + (let ([base (datum->syntax who-stx (cadr td))] + [pred (datum->syntax who-stx (caddr td))]) + #`(check-refinement! '#,who-stx '#,arg #,arg '#,base #,pred))] + [else + #`(check-type! '#,who-stx '#,arg #,arg '#,type)])))) + parsed)) + + (syntax-case stx () + ;; With return type + [(k (name typed-arg ...) colon ret-type body ...) + (eq? (syntax->datum #'colon) ':) + (let* ([parsed (parse-typed-args #'(typed-arg ...))] + [args (map car parsed)] + [all-fix? (and (all-type? parsed 'fixnum) + (eq? (syntax->datum #'ret-type) 'fixnum))] + [all-flo? (and (all-type? parsed 'flonum) + (eq? (syntax->datum #'ret-type) 'flonum))] + [arg-checks (emit-arg-checks #'name parsed)]) + (with-syntax ([(arg ...) args] + [(check ...) arg-checks]) + (cond + [all-fix? + #'(define (name arg ...) + (when (eq? (*typed-mode*) 'debug) check ...) + (with-fixnum-ops body ...))] + [all-flo? + #'(define (name arg ...) + (when (eq? (*typed-mode*) 'debug) check ...) + (with-flonum-ops body ...))] + [else + #'(define (name arg ...) + (when (eq? (*typed-mode*) 'debug) check ...) + (let ([result (begin body ...)]) + (check-return-type! 'name result 'ret-type) + result))])))] + ;; Without return type + [(k (name typed-arg ...) body ...) + (let* ([parsed (parse-typed-args #'(typed-arg ...))] + [args (map car parsed)] + [arg-checks (emit-arg-checks #'name parsed)]) + (with-syntax ([(arg ...) args] + [(check ...) arg-checks]) + #'(define (name arg ...) + (when (eq? (*typed-mode*) 'debug) check ...) + body ...)))]))) + + ;; lambda/tc: like define/tc but for lambdas + (define-syntax lambda/tc + (lambda (stx) + (define (parse-typed-args args) + (let loop ([rest (syntax->list args)] [result '()]) + (if (null? rest) + (reverse result) + (let ([item (car rest)]) + (syntax-case item () + [(arg-name sep type-name) + (eq? (syntax->datum #'sep) ':) + (loop (cdr rest) + (cons (list #'arg-name #'type-name) result))] + [arg-name + (identifier? #'arg-name) + (loop (cdr rest) + (cons (list #'arg-name (datum->syntax #'arg-name 'any)) result))]))))) + + (define (all-type? parsed type-sym) + (for-all (lambda (p) (eq? (syntax->datum (cadr p)) type-sym)) parsed)) + + (syntax-case stx () + [(k (typed-arg ...) colon ret-type body ...) + (eq? (syntax->datum #'colon) ':) + (let* ([parsed (parse-typed-args #'(typed-arg ...))] + [args (map car parsed)] + [all-fix? (and (all-type? parsed 'fixnum) + (eq? (syntax->datum #'ret-type) 'fixnum))] + [all-flo? (and (all-type? parsed 'flonum) + (eq? (syntax->datum #'ret-type) 'flonum))]) + (with-syntax ([(arg ...) args] + [((aname atype) ...) parsed]) + (cond + [all-fix? + #'(lambda (arg ...) + (when (eq? (*typed-mode*) 'debug) + (check-type! 'lambda 'aname arg 'atype) ...) + (with-fixnum-ops body ...))] + [all-flo? + #'(lambda (arg ...) + (when (eq? (*typed-mode*) 'debug) + (check-type! 'lambda 'aname arg 'atype) ...) + (with-flonum-ops body ...))] + [else + #'(lambda/t (typed-arg ...) : ret-type body ...)])))] + [(k (typed-arg ...) body ...) + #'(lambda/t (typed-arg ...) body ...)]))) + + ;; ========== Union / Intersection type specs ========== + ;; These are type spec constructors for use in type annotations. + ;; Runtime checking: Union checks any, Intersection checks all. + + ;; (Union T1 T2 ...) — value satisfies at least one type + ;; Used in type-predicate lookup via register-type-predicate! + (define-syntax Union + (lambda (stx) + (syntax-case stx () + [(_ type ...) + #'(let ([preds (filter values (map type-predicate '(type ...)))]) + (lambda (x) + (any (lambda (p) (p x)) preds)))]))) + + ;; (Intersection T1 T2 ...) — value satisfies all types + (define-syntax Intersection + (lambda (stx) + (syntax-case stx () + [(_ type ...) + #'(let ([preds (filter values (map type-predicate '(type ...)))]) + (lambda (x) + (for-all (lambda (p) (p x)) preds)))]))) + + ;; Helper: any (like SRFI-1 any) + (define (any pred lst) + (and (not (null? lst)) + (or (pred (car lst)) + (any pred (cdr lst))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-typed-advanced.ss @@ -0,0 +1,208 @@ +#!chezscheme +;;; Tests for (std typed advanced) — Steps 14-17 + +(import (chezscheme) (std typed) (std typed advanced)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(printf "--- (std typed advanced) tests ---~%") + +;;;; Step 14: Occurrence Typing + +(printf "~%-- Occurrence Typing --~%") + +;; if/t narrows type in true branch +(test "if/t string narrowing" + (parameterize ([*typed-mode* 'debug]) + (let ([x "hello"]) + (if/t (string? x) + (string-length x) + -1))) + 5) + +;; if/t passes when type is wrong (release mode — no assertion) +(test "if/t false branch" + (parameterize ([*typed-mode* 'debug]) + (let ([x 42]) + (if/t (string? x) + 'string + 'not-string))) + 'not-string) + +;; when/t +(test "when/t" + (let ([result '()]) + (let ([x "test"]) + (when/t (string? x) + (set! result (list 'string (string-length x))))) + result) + '(string 4)) + +;; cond/t with multiple branches +(test "cond/t narrowing" + (parameterize ([*typed-mode* 'debug]) + (define (classify x) + (cond/t + [(string? x) (list 'string (string-length x))] + [(fixnum? x) (list 'fixnum x)] + [(pair? x) (list 'pair (length x))] + [else (list 'unknown)])) + (list (classify "hi") + (classify 42) + (classify '(1 2 3)) + (classify #t))) + '((string 2) (fixnum 42) (pair 3) (unknown))) + +;;;; Step 15: Row Polymorphism + +(printf "~%-- Row Polymorphism --~%") + +;; Define a record type for testing +(define-record-type point (fields x y)) +(define-record-type named (fields name)) + +;; defrow +(defrow Positionable + (point-x : number) + (point-y : number)) + +(test "defrow creates predicate" + (procedure? Positionable?) + #t) + +(test "row-check with Positionable" + (let ([p (make-point 3 4)]) + (Positionable? p)) + #t) + +(test "row-check fails on non-matching" + (let ([n (make-named "Alice")]) + (Positionable? n)) + #f) + +;; row-check inline +(test "row-check inline" + (let ([p (make-point 10 20)]) + (row-check p (point-x : number) (point-y : number))) + #t) + +;;;; Step 16: Refinement Types + +(printf "~%-- Refinement Types --~%") + +;; assert-refined: base type + predicate +(test "assert-refined/pass" + (parameterize ([*typed-mode* 'debug]) + (assert-refined 5 number positive?)) + 5) + +(test "assert-refined/base-fail" + (guard (exn [#t 'caught]) + (parameterize ([*typed-mode* 'debug]) + (assert-refined "hello" number positive?)) + 'missed) + 'caught) + +(test "assert-refined/pred-fail" + (guard (exn [#t 'caught]) + (parameterize ([*typed-mode* 'debug]) + (assert-refined -5 number positive?)) + 'missed) + 'caught) + +(test "assert-refined/release-no-check" + (parameterize ([*typed-mode* 'release]) + (assert-refined -5 number positive?)) ;; no check in release mode + -5) + +;; refinement-type record +(test "make-refinement-type" + (let ([rt (make-refinement-type 'number positive?)]) + (and (refinement-type? rt) + (eq? (refinement-type-base rt) 'number) + (procedure? (refinement-type-pred rt)))) + #t) + +;;;; Step 17: Type-Directed Compilation + +(printf "~%-- Type-Directed Compilation --~%") + +;; define/tc with fixnum args should use fx+ internally +(test "define/tc fixnum specialization" + (parameterize ([*typed-mode* 'debug]) + (define/tc (add-fx [a : fixnum] [b : fixnum]) : fixnum + (+ a b)) + (add-fx 3 4)) + 7) + +;; define/tc with flonum args +(test "define/tc flonum specialization" + (parameterize ([*typed-mode* 'debug]) + (define/tc (add-fl [a : flonum] [b : flonum]) : flonum + (+ a b)) + (add-fl 1.5 2.5)) + 4.0) + +;; define/tc type checks still work in debug mode +(test "define/tc type check" + (guard (exn [#t 'caught]) + (parameterize ([*typed-mode* 'debug]) + (define/tc (need-fix [x : fixnum]) : fixnum x) + (need-fix "bad") + 'missed) + 'caught) + 'caught) + +;; define/tc with refinement type +(test "define/tc refinement" + (parameterize ([*typed-mode* 'debug]) + (define/tc (sqrt-safe [x : (Refine number (lambda (n) (>= n 0)))]) : number + (sqrt x)) + (sqrt-safe 4.0)) + 2.0) + +(test "define/tc refinement fails" + (guard (exn [#t 'caught]) + (parameterize ([*typed-mode* 'debug]) + (define/tc (sqrt-safe2 [x : (Refine number (lambda (n) (>= n 0)))]) : number + (sqrt x)) + (sqrt-safe2 -1.0) + 'missed) + 'caught) + 'caught) + +;; lambda/tc +(test "lambda/tc fixnum" + (parameterize ([*typed-mode* 'debug]) + (let ([f (lambda/tc ([x : fixnum] [y : fixnum]) : fixnum + (* x y))]) + (f 6 7))) + 42) + +;; Performance: type-directed fixnum ops should be fast +(test "define/tc fixnum/perf" + (parameterize ([*typed-mode* 'release]) + (define/tc (sum-fx [n : fixnum]) : fixnum + (let loop ([i 0] [acc 0]) + (if (= i n) + acc + (loop (+ i 1) (+ acc i))))) + (sum-fx 100)) + 4950) + +(printf "~%~a tests: ~a passed, ~a failed~%" + (+ pass fail) pass fail) +(when (> fail 0) (exit 1))