diff options
| -rw-r--r-- | csc/encoding.csc | 38 | ||||
| -rw-r--r-- | csc/linker.csc | 8 | ||||
| -rw-r--r-- | csc/match-test.csc | 42 | ||||
| -rw-r--r-- | csc/match.csc | 58 |
4 files changed, 75 insertions, 71 deletions
diff --git a/csc/encoding.csc b/csc/encoding.csc index 5c06bec..8dbd89c 100644 --- a/csc/encoding.csc +++ b/csc/encoding.csc @@ -35,25 +35,25 @@ (define (opcode-switch opcode) (match opcode - (((! 'const) n) (append (64->le-bytes 1010) (64->le-bytes n))) - ((! 'add) (64->le-bytes 1020)) - ((! 'sub) (64->le-bytes 1030)) - ((! 'mul) (64->le-bytes 1040)) - ((! 'div) (64->le-bytes 1050)) - ((! 'mod) (64->le-bytes 1060)) - ((! 'alloc) (64->le-bytes 2010)) - (((! 'peek) n) (append (64->le-bytes 2020) (list n))) - (((! 'poke) n) (append (64->le-bytes 2030) (list n))) - ((! 'peekbyte) (64->le-bytes 2040)) - ((! 'pokebyte) (64->le-bytes 2050)) - ((! 'pop) (64->le-bytes 3010)) - (((! 'local) n) (append (64->le-bytes 3020) (list n))) - (((! 'if) n) (append (64->le-bytes 4010) (64->le-bytes n))) - (((! 'call) n) (append (64->le-bytes 4020) (list n))) - ((! 'ret) (64->le-bytes 4030)) - ((! 'exit) (64->le-bytes 4040)) - ((! 'putc) (64->le-bytes 5010)) - ((! 'getc) (64->le-bytes 5020)) + (('const n) (append (64->le-bytes 1010) (64->le-bytes n))) + ('add (64->le-bytes 1020)) + ('sub (64->le-bytes 1030)) + ('mul (64->le-bytes 1040)) + ('div (64->le-bytes 1050)) + ('mod (64->le-bytes 1060)) + ('alloc (64->le-bytes 2010)) + (('peek n) (append (64->le-bytes 2020) (list n))) + (('poke n) (append (64->le-bytes 2030) (list n))) + ('peekbyte (64->le-bytes 2040)) + ('pokebyte (64->le-bytes 2050)) + ('pop (64->le-bytes 3010)) + (('local n) (append (64->le-bytes 3020) (list n))) + (('if n) (append (64->le-bytes 4010) (64->le-bytes n))) + (('call n) (append (64->le-bytes 4020) (list n))) + ('ret (64->le-bytes 4030)) + ('exit (64->le-bytes 4040)) + ('putc (64->le-bytes 5010)) + ('getc (64->le-bytes 5020)) (_ (error "invalid opcode" opcode)))) diff --git a/csc/linker.csc b/csc/linker.csc index b840c15..feec289 100644 --- a/csc/linker.csc +++ b/csc/linker.csc @@ -22,12 +22,12 @@ (map (lambda (x) (match x - ((i . ((! 'if) label)) + ((i . ('if label)) ; Compute offset from the current position. Subtract 1 ; because the instruction pointer is incremented each ; time already. (list 'if (- (lookup label-map label) i 1))) - ((_ . ((! 'call) label)) + ((_ . ('call label)) (list 'call (lookup label-map label))) ((_ . opcode) opcode))) (enumerate program))) @@ -43,7 +43,7 @@ (i 0)) (match program ('() m) - ((((! 'label) name) . tail) + ((('label name) . tail) (loop (insert m name i) tail i)) ; N.b.: i instead of (+ 1 i) because we're going to remove the labels later. ((_ . tail) (loop m tail (+ 1 i)))))) @@ -52,7 +52,7 @@ (filter (lambda (opcode) (match opcode - (((! 'label) _) #f) + (('label _) #f) (_ #t))) program)) diff --git a/csc/match-test.csc b/csc/match-test.csc index bcd0d35..8323952 100644 --- a/csc/match-test.csc +++ b/csc/match-test.csc @@ -7,11 +7,11 @@ (assert-equal 3 (match 3 - ((! 0) 0) - ((! 1) 1) - ((! 2) 2) - ((! 3) 3) - (_ 4)))) + ('0 0) + ('1 1) + ('2 2) + ('3 3) + ('4 4)))) (test match-list @@ -19,9 +19,9 @@ 2 (match '(1 2 3) ('() 0) - (((! 1) (! 2)) 1) - (((! 1) (! 2) (! 3)) 2) - (((! 1) (! 2) (! 3) (! 4)) 3) + (('1 '2) 1) + (('1 '2 '3) 2) + (('1 '2 '3 '4) 3) (_ 4)))) @@ -29,7 +29,7 @@ (assert-equal 2 (match '(1 2 3) - (((! 1) x (! 3)) x)))) + (('1 x '3) x)))) (test match-destructuring @@ -45,8 +45,8 @@ 2 (match '(1 2 3) ((_ _ _ _) 0) - (((! 2) _ _) 1) - (((! 1) _ _) 2) + (('2 _ _) 1) + (('1 _ _) 2) (_ 3)))) @@ -54,8 +54,8 @@ (assert-equal 2 (match '(1 2 3) - (((! 2) . _) 1) - (((! 1) . x) (car x)) + (('2 . _) 1) + (('1 . x) (car x)) (_ 3)))) @@ -63,8 +63,8 @@ (assert-equal 2 (match 'b - ((! 'a) 1) - ((! 'b) 2) + ('a 1) + ('b 2) (_ 3)))) @@ -72,9 +72,9 @@ (assert-equal 3 (match 'b - ((! 'a) 1) - ((! 'b) when #f 2) - ((! 'b) when #t 3) + ('a 1) + ('b when #f 2) + ('b when #t 3) (_ 4)))) @@ -105,7 +105,7 @@ (test match-record-type-any (assert-equal - #t + 2 (match '(1 2 3) - ((% %test-record-type . _) #f) - ((! '(1 2 3)) #t)))) + ((% %test-record-type . _) 1) + ('(1 2 3) 2)))) diff --git a/csc/match.csc b/csc/match.csc index 96ec4d3..4db0d07 100644 --- a/csc/match.csc +++ b/csc/match.csc @@ -29,39 +29,43 @@ (define-syntax match-pattern - (syntax-rules (_ ! when %) + (syntax-rules (% _ quote when) ((match-pattern x pattern when condition result result* ...) - (match-pattern x pattern - (if condition - (let () result result* ...) - (raise *no-match*)))) + (match-pattern x pattern + (unless condition + (raise *no-match*)) + result result* ...)) ((match-pattern x _ result result* ...) - (let () result result* ...)) - ((match-pattern x '() result result* ...) - (if (null? x) - (let () result result* ...) - (raise *no-match*))) - ((match-pattern x (! constant) result result* ...) - (if (equal? x constant) - (let () result result* ...) - (raise *no-match*))) - ((match-pattern x (pattern) result result* ...) - (let ((y x)) - (if (= 1 (length y)) - (match-pattern (car y) pattern result result* ...) - (raise *no-match*)))) + (let () result result* ...)) + ((match-pattern x (quote constant) result result* ...) + (let () + (unless (equal? x (quote constant)) + (raise *no-match*)) + result result* ...)) + ((match-pattern x (% record-matcher) result result* ...) + (let () + (record-matcher x) + result result* ...)) ((match-pattern x (% record-matcher . patterns) result result* ...) (let ((x* (record-matcher x))) - (match-pattern (map cdr (cdr (record-matcher x))) patterns result result* ...))) + (match-pattern (map cdr (cdr x*)) patterns result result* ...))) + ((match-pattern x () result* ...) + (syntax-error "Unexpected pattern (). Use '() to match nil.")) + ((match-pattern x (pattern) result result* ...) + (let ((y x)) + (unless (and (pair? y) + (null? (cdr y))) + (raise *no-match*)) + (match-pattern (car y) pattern result result* ...))) ((match-pattern x (pattern . rest) result result* ...) - (let ((y x)) - (if (pair? y) - (match-pattern (car y) pattern - (match-pattern (cdr y) rest result result* ...)) - (raise *no-match*)))) + (let ((y x)) + (unless (pair? y) + (raise *no-match*)) + (match-pattern (car y) pattern + (match-pattern (cdr y) rest result result* ...)))) ((match-pattern x identifier result result* ...) - (let ((identifier x)) - result result* ...)))) + (let ((identifier x)) + result result* ...)))) (define-syntax match |