boot2

Playing with the boostrap
git clone https://git.ryansepassi.com/git/boot2.git
Log | Files | Refs | README

097-pmatch-record.scm (3462B)

      1 ; pmatch record-destructuring patterns: ($ <pred> (<field> <pat>) ...).
      2 ; The pattern names the record's predicate (e.g. tok?), and each field
      3 ; clause is matched against the value at that field. Listed fields only;
      4 ; missing fields are unconstrained. Order of (field pat) clauses doesn't
      5 ; matter. Subject of a different record type, or a non-record value, falls
      6 ; through to the next clause.
      7 ;
      8 ; Inside a record clause's <pat>, the standard pmatch literal/binder rules
      9 ; apply: bare symbols (IDENT, lparen) are literal-symbol patterns, ,x is a
     10 ; binder, and ($ ...) nests for record fields.
     11 
     12 (define-record-type tok
     13   (%tok kind value loc)
     14   tok?
     15   (kind  tok-kind)
     16   (value tok-value)
     17   (loc   tok-loc))
     18 
     19 (define-record-type loc
     20   (%loc file line)
     21   loc?
     22   (file loc-file)
     23   (line loc-line))
     24 
     25 ;; Subset matching: bind two of three fields; ignore loc.
     26 (define t1 (%tok 'IDENT "x" (%loc "a.c" 12)))
     27 (if (eq? 'ok
     28          (pmatch t1
     29            (($ tok? (kind IDENT) (value ,v)) (if (equal? v "x") 'ok 'wrong-v))
     30            (else (sys-exit 91))))
     31     0 (sys-exit 1))
     32 
     33 ;; Field clauses can appear in any order.
     34 (if (eq? 'reordered
     35          (pmatch t1
     36            (($ tok? (value ,v) (kind IDENT)) 'reordered)
     37            (else (sys-exit 92))))
     38     0 (sys-exit 2))
     39 
     40 ;; A pattern with no field clauses is a pure type-check.
     41 (if (eq? 'just-tok
     42          (pmatch t1
     43            (($ tok?) 'just-tok)
     44            (else (sys-exit 93))))
     45     0 (sys-exit 3))
     46 
     47 ;; Type mismatch: subject isn't a tok, falls through.
     48 (define l1 (%loc "b.c" 7))
     49 (if (eq? 'fell-through
     50          (pmatch l1
     51            (($ tok? (kind ,_)) (sys-exit 94))
     52            (else 'fell-through)))
     53     0 (sys-exit 4))
     54 
     55 ;; Non-record subject (a fixnum) also falls through cleanly.
     56 (if (eq? 'not-a-record
     57          (pmatch 42
     58            (($ tok? (kind ,_)) (sys-exit 95))
     59            (else 'not-a-record)))
     60     0 (sys-exit 5))
     61 
     62 ;; Field-pat fails -> clause fails -> next clause runs.
     63 (define t2 (%tok 'PUNCT 'lparen (%loc "c.c" 1)))
     64 (if (eq? 'punct
     65          (pmatch t2
     66            (($ tok? (kind IDENT)) (sys-exit 96))
     67            (($ tok? (kind PUNCT)) 'punct)
     68            (else (sys-exit 97))))
     69     0 (sys-exit 6))
     70 
     71 ;; Nested record pattern: destructure the loc inside the tok.
     72 (if (eq? 'nested-ok
     73          (pmatch t1
     74            (($ tok? (loc ($ loc? (file ,f) (line ,n))))
     75             (if (and (equal? f "a.c") (= n 12)) 'nested-ok 'nested-bad))
     76            (else (sys-exit 98))))
     77     0 (sys-exit 7))
     78 
     79 ;; Combined with guard: the record must type-check first, then guards run.
     80 (if (eq? 'short-name
     81          (pmatch t1
     82            (($ tok? (value ,v))
     83             (guard (< (string-length v) 3))
     84             'short-name)
     85            (else (sys-exit 99))))
     86     0 (sys-exit 8))
     87 
     88 ;; Guard rejection falls through.
     89 (define t3 (%tok 'IDENT "longer-name" (%loc "d.c" 2)))
     90 (if (eq? 'long-fallthrough
     91          (pmatch t3
     92            (($ tok? (value ,v))
     93             (guard (< (string-length v) 3))
     94             (sys-exit 100))
     95            (else 'long-fallthrough)))
     96     0 (sys-exit 9))
     97 
     98 ;; Nested binder inside a record clause: ,x captures the field value.
     99 (if (eq? 'IDENT
    100          (pmatch t1
    101            (($ tok? (kind ,k)) k)
    102            (else (sys-exit 101))))
    103     0 (sys-exit 10))
    104 
    105 ;; Match against a literal punct value (bare symbol pattern, not quoted).
    106 (if (eq? 'open-paren
    107          (pmatch t2
    108            (($ tok? (kind PUNCT) (value lparen)) 'open-paren)
    109            (else (sys-exit 102))))
    110     0 (sys-exit 11))
    111 
    112 (sys-exit 0)