diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index 8599d99fc..e379f722e 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -183,7 +183,7 @@ (if (eq? (car clause) 'else) clause `(($ ,@(car clause)) ,@(cdr clause)))) - `(match ,record ,@(map process-clause clauses))) + `(,match ,record ,@(map process-clause clauses))) (define (record? x) (and (vector? x) diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm index 549dd2e80..43b5d6cd0 100644 --- a/module/system/il/compile.scm +++ b/module/system/il/compile.scm @@ -23,7 +23,6 @@ :use-syntax (system base syntax) :use-module (system il glil) :use-module (system il ghil) - :use-module (ice-9 match) :use-module (ice-9 common-list) :export (compile)) @@ -37,31 +36,31 @@ ;;; (define (optimize x) - (match x - (($ env var val) + (record-case x + (( env var val) (make-ghil-set env var (optimize val))) - (($ test then else) + (( test then else) (make-ghil-if (optimize test) (optimize then) (optimize else))) - (($ exps) + (( exps) (make-ghil-begin (map optimize exps))) - (($ env vars vals body) + (( env vars vals body) (make-ghil-bind env vars (map optimize vals) (optimize body))) - (($ env vars rest body) + (( env vars rest body) (make-ghil-lambda env vars rest (optimize body))) ;; FIXME: does not exist. -- Ludo'. ; (($ inst args) ; (make-ghil-inst inst (map optimize args))) - (($ env proc args) - (match proc + (( env proc args) + (record-case proc ;; ((@lambda (VAR...) BODY...) ARG...) => ;; (@let ((VAR ARG) ...) BODY...) - (($ lambda-env vars #f body) + (( lambda-env vars #f body) (for-each (lambda (v) (if (eq? v.kind 'argument) (set! v.kind 'local)) (set! v.env env) @@ -135,48 +134,50 @@ (return-code! (make-glil-const obj))) ;; ;; dispatch - (match tree - (($ ) + (record-case tree + (() (return-void!)) - (($ env loc obj) + (( env loc obj) (return-object! obj)) - (($ env loc exp) + (( env loc exp) (let loop ((x exp)) - (match x - ((? list? ls) - (push-call! #f 'mark '()) - (for-each loop ls) - (push-call! #f 'list-mark '())) - ((? pair? pp) - (loop (car pp)) - (loop (cdr pp)) - (push-code! (make-glil-call 'cons 2))) - (($ env loc exp) - (comp-push exp)) - (($ env loc exp) - (comp-push exp) - (push-call! #f 'list-break '())) - (else - (push-code! (make-glil-const x))))) + (cond + ((list? x) + (push-call! #f 'mark '()) + (for-each loop x) + (push-call! #f 'list-mark '())) + ((pair? x) + (loop (car x)) + (loop (cdr x)) + (push-code! (make-glil-call 'cons 2))) + ((record? x) + (record-case x + (( env loc exp) + (comp-push exp)) + (( env loc exp) + (comp-push exp) + (push-call! #f 'list-break '())))) + (else + (push-code! (make-glil-const x))))) (maybe-drop) (maybe-return)) - (($ env loc var) + (( env loc var) (return-code! (make-glil-var 'ref env var))) - (($ env loc var val) + (( env loc var val) (comp-push val) (push-code! (make-glil-var 'set env var)) (return-void!)) - (($ env loc var val) + (( env loc var val) (comp-push val) (push-code! (make-glil-var 'set env var)) (return-void!)) - (($ env loc test then else) + (( env loc test then else) ;; TEST ;; (br-if-not L1) ;; THEN @@ -192,7 +193,7 @@ (comp-tail else) (if (not tail) (push-label! L2)))) - (($ env loc exps) + (( env loc exps) ;; EXP ;; (br-if-not L1) ;; ... @@ -215,7 +216,7 @@ (comp-push (car exps)) (push-branch! 'br-if-not L1))))) - (($ env loc exps) + (( env loc exps) ;; EXP ;; (dup) ;; (br-if L1) @@ -237,7 +238,7 @@ (push-branch! 'br-if L1) (push-call! #f 'drop '()))))) - (($ env loc exps) + (( env loc exps) ;; EXPS... ;; TAIL (if (null? exps) @@ -247,7 +248,7 @@ (comp-tail (car exps))) (comp-drop (car exps))))) - (($ env loc vars vals body) + (( env loc vars vals body) ;; VALS... ;; (set VARS)... ;; BODY @@ -259,17 +260,17 @@ (comp-tail body) (push-code! (make-glil-unbind))) - (($ env loc vars rest body) + (( env loc vars rest body) (return-code! (codegen tree))) - (($ env loc inst args) + (( env loc inst args) ;; ARGS... ;; (INST NARGS) (push-call! loc inst args) (maybe-drop) (maybe-return)) - (($ env loc proc args) + (( env loc proc args) ;; PROC ;; ARGS... ;; ([tail-]call NARGS) @@ -278,8 +279,8 @@ (maybe-drop)))) ;; ;; main - (match ghil - (($ env loc args rest body) + (record-case ghil + (( env loc args rest body) (let* ((vars env.variables) (locs (pick (lambda (v) (eq? v.kind 'local)) vars)) (exts (pick (lambda (v) (eq? v.kind 'external)) vars))) diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm index 8b10c4b4b..c7fba8592 100644 --- a/module/system/il/glil.scm +++ b/module/system/il/glil.scm @@ -21,7 +21,6 @@ (define-module (system il glil) :use-syntax (system base syntax) - :use-module (ice-9 match) :export (pprint-glil make-glil-vars @@ -143,30 +142,30 @@ ;;; (define (unparse glil) - (match glil + (record-case glil ;; meta - (($ vars body) + (( vars body) `(@asm (,vars.nargs ,vars.nrest ,vars.nlocs ,vars.nexts) ,@(map unparse body))) - (($ vars) `(@bind ,@vars)) - (($ ) `(@unbind)) - (($ loc) `(@source ,(car loc) ,(cdr loc))) + (( vars) `(@bind ,@vars)) + (() `(@unbind)) + (( loc) `(@source ,(car loc) ,(cdr loc))) ;; constants - (($ ) `(void)) - (($ obj) `(const ,obj)) + (() `(void)) + (( obj) `(const ,obj)) ;; variables - (($ op index) + (( op index) `(,(symbol-append 'argument- op) ,index)) - (($ op index) + (( op index) `(,(symbol-append 'local- op) ,index)) - (($ op depth index) + (( op depth index) `(,(symbol-append 'external- op) ,depth ,index)) - (($ op module name) + (( op module name) `(,(symbol-append 'module- op) ,module ,name)) ;; controls - (($ label) label) - (($ inst label) `(,inst ,label)) - (($ inst nargs) `(,inst ,nargs)))) + (( label) label) + (( inst label) `(,inst ,label)) + (( inst nargs) `(,inst ,nargs)))) ;;;