Simplify the define-primitive-expander macro

* module/language/tree-il/primitives.scm (primitive-expander):
(define-primitive-expander!): New helpers.
(define-primitive-expander): Rewrite in terms of syntax-case.
(error, make-vector, eqv?, equal?, call-with-prompt)
(abort-to-prompt*, abort-to-prompt): Use new helper.

module/language/tree-il/primitives.scm

@@ -1,6 +1,6 @@
 ;;; open-coding primitive procedures
 
-;; Copyright (C) 2009-2015, 2017-2018 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2015, 2017-2019 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -331,58 +331,37 @@
 (define (expand-primitives x)
   (pre-order expand-primcall x))
 
-;;; I actually did spend about 10 minutes trying to redo this with
+(define-syntax-rule (define-primitive-expander! sym proc)
-;;; syntax-rules. Patches appreciated.
+  (hashq-set! *primitive-expand-table* sym proc))
-;;;
+
-(define-macro (define-primitive-expander sym . clauses)
+(define-syntax primitive-expander
-  (define (inline-args args)
+  (lambda (stx)
-    (let lp ((in args) (out '()))
+    (define (expand-args args)
-      (cond ((null? in) `(list ,@(reverse out)))
+      (syntax-case args ()
-            ((symbol? in) `(cons* ,@(reverse out) ,in))
+        (() #''())
-            ((pair? (car in))
+        ((a . b) #`(cons #,(expand-expr #'a) #,(expand-args #'b)))
-             (lp (cdr in)
+        (a (expand-expr #'a))))
-                 (cons (if (eq? (caar in) 'quote)
+    (define (expand-expr body)
-                           `(make-const src ,@(cdar in))
+      (syntax-case body (quote)
-                           `(make-primcall src ',(caar in)
+        (id (identifier? #'id) #'id)
-                                           ,(inline-args (cdar in))))
+        ((quote x) #'(make-const src 'x))
-                       out)))
+        ((op . args) #`(make-primcall src 'op #,(expand-args #'args)))
-            ((symbol? (car in))
+        (x (self-evaluating? (syntax->datum #'x)) #'(make-const src x))))
-             ;; assume it's locally bound
+    (define (match-clauses args+body)
-             (lp (cdr in) (cons (car in) out)))
+      (syntax-case args+body (if)
-            ((self-evaluating? (car in))
+        (() '())
-             (lp (cdr in) (cons `(make-const src ,(car in)) out)))
+        ((args body . args+body)
-            (else
+         (cons #`(args #,(expand-expr #'body))
-             (error "what what" (car in))))))
+               (match-clauses #'args+body)))))
-  (define (consequent exp)
+    (syntax-case stx ()
-    (cond
+      ((_ args+body ...)
-     ((pair? exp)
+       #`(lambda (src . args)
-      (pmatch exp
+           (match args
-        ((if ,test ,then ,else)
+             #,@(match-clauses #'(args+body ...))
-         `(if ,test
+             (_ #f)))))))
-              ,(consequent then)
+
-              ,(consequent else)))
+(define-syntax-rule (define-primitive-expander sym . clauses)
-        (else
+  (define-primitive-expander! 'sym (primitive-expander . clauses)))
-         `(make-primcall src ',(car exp)
-                         ,(inline-args (cdr exp))))))
-     ((symbol? exp)
-      ;; assume locally bound
-      exp)
-     ((number? exp)
-      `(make-const src ,exp))
-     ((not exp)
-      ;; failed match
-      #f)
-     (else (error "bad consequent yall" exp))))
-  `(hashq-set! *primitive-expand-table*
-               ',sym
-               (match-lambda*
-                ,@(let lp ((in clauses) (out '()))
-                    (if (null? in)
-                        (reverse (cons '(_ #f) out))
-                        (lp (cddr in)
-                            (cons `((src . ,(car in))
-                                    ,(consequent (cadr in)))
-                                  out)))))))
 
 ;; Oddly, scm-error is just an explicitly 5-argument `throw'.  Weird.
 (define-primitive-expander scm-error (key who message args data)
@@ -391,9 +370,7 @@
 (define (escape-format-directives str)
   (string-join (string-split str #\~) "~~"))
 
-(hashq-set!
+(define-primitive-expander! 'error
- *primitive-expand-table*
- 'error
   (match-lambda*
    ((src)
     (make-primcall src 'throw
@@ -470,9 +447,7 @@
   (x y) (logand x y)
   (x y z ... last) (logand (logand x y . z) last))
 
-(hashq-set!
+(define-primitive-expander! 'make-vector
- *primitive-expand-table*
- 'make-vector
   (match-lambda*
    ((src len)
     (make-primcall src 'make-vector (list len (make-const src *unspecified*))))
@@ -593,7 +568,7 @@
                                    (make-const src #f)))))))
 
 (for-each (lambda (prim-name)
-            (hashq-set! *primitive-expand-table* prim-name
+            (define-primitive-expander! prim-name
               (chained-comparison-expander prim-name)))
           '(< > <= >= =))
 
@@ -607,7 +582,7 @@
 
 (for-each (match-lambda
             ((char< . <)
-             (hashq-set! *primitive-expand-table* char<
+             (define-primitive-expander! char<
                (character-comparison-expander char< <))))
           '((char<? . <)
             (char>? . >)
@@ -639,8 +614,8 @@
                        (make-const src #f)))
     (else #f)))
 
-(hashq-set! *primitive-expand-table* 'eqv?   (maybe-simplify-to-eq 'eqv?))
+(define-primitive-expander! 'eqv?   (maybe-simplify-to-eq 'eqv?))
-(hashq-set! *primitive-expand-table* 'equal? (maybe-simplify-to-eq 'equal?))
+(define-primitive-expander! 'equal? (maybe-simplify-to-eq 'equal?))
 
 (define (expand-chained-comparisons prim)
   (case-lambda
@@ -659,25 +634,22 @@
     (else #f)))
 
 (for-each (lambda (prim)
-            (hashq-set! *primitive-expand-table* prim
+            (define-primitive-expander! prim
               (expand-chained-comparisons prim)))
  '(< <= = >= > eq?))
 
-(hashq-set! *primitive-expand-table*
+(define-primitive-expander! 'call-with-prompt
-            'call-with-prompt
   (case-lambda
    ((src tag thunk handler)
     (make-prompt src #f tag thunk handler))
    (else #f)))
 
-(hashq-set! *primitive-expand-table*
+(define-primitive-expander! 'abort-to-prompt*
-            'abort-to-prompt*
   (case-lambda
    ((src tag tail-args)
     (make-abort src tag '() tail-args))
    (else #f)))
-(hashq-set! *primitive-expand-table*
+(define-primitive-expander! 'abort-to-prompt
-            'abort-to-prompt
   (case-lambda
    ((src tag . args)
     (make-abort src tag args (make-const #f '())))