no keyword arguments in GHIL / GLIL, just optional args -- faster compiles

* module/system/base/syntax.scm (define-record): So, in the generated
  constructors, allow optional arguments, but not keyword arguments.
  Conses much less in the constructors.
  (define-record/keywords): And the old define-record is here.

* module/language/ghil.scm (parse-ghil):
* module/language/ghil/compile-glil.scm (codegen):
* module/language/scheme/compile-ghil.scm (translate-1, quote)
  (quasiquote): Don't use keywords in this compiler hotpath.

* module/system/base/language.scm (<language>):
* module/system/repl/common.scm (<repl>):
* module/system/vm/debug.scm (<debugger>): Use define-record/keywords.

module/language/ghil.scm

@@ -352,7 +352,7 @@
      ((ref ,sym) (guard (symbol? sym))
       (make-ghil-ref env #f (ghil-var-for-ref! env sym)))
 
-     (('quote ,exp) (make-ghil-quote #:env env #:loc loc #:obj exp))
+     (('quote ,exp) (make-ghil-quote env loc exp))
 
      ((void) (make-ghil-void env loc))
 
@@ -417,7 +417,7 @@
       (make-ghil-reified-env env loc))
 
      ((quasiquote ,exp)
-      (make-ghil-quasiquote env loc #:exp (parse-quasiquote env exp 0)))
+      (make-ghil-quasiquote env loc (parse-quasiquote env exp 0)))
 
      (else
       (error "unrecognized GHIL" exp)))))

module/language/ghil/compile-glil.scm

@@ -178,7 +178,7 @@
 	(return-code! #f *ia-void*))
       ;; return object if necessary
       (define (return-object! loc obj)
-	(return-code! loc (make-glil-const #:obj obj)))
+	(return-code! loc (make-glil-const obj)))
       ;;
       ;; dispatch
       (record-case tree
@@ -210,7 +210,7 @@
                (comp-push exp)
                (push-call! #f 'list-break '()))))
             ((constant? x)
-             (push-code! #f (make-glil-const #:obj x)))
+             (push-code! #f (make-glil-const x)))
             (else
              (error "element of quasiquote can't be compiled" x))))
 	 (maybe-drop)
@@ -330,7 +330,7 @@
          (let ((MV (make-label)))
            (comp-push producer)
            (push-code! loc (make-glil-mv-call 0 MV))
-           (push-code! #f (make-glil-const #:obj 1))
+           (push-code! #f (make-glil-const 1))
            (push-label! MV)
            (push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
            (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
@@ -361,9 +361,9 @@
                (drop ;; (lambda () (values 1 2) 3)
                 (for-each comp-drop values))
                (else ;; (lambda () (list (values 10 12) 1))
-                (push-code! #f (make-glil-const #:obj 'values))
+                (push-code! #f (make-glil-const 'values))
-                (push-code! #f (make-glil-call #:inst 'link-now #:nargs 1))
+                (push-code! #f (make-glil-call 'link-now 1))
-                (push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0))
+                (push-code! #f (make-glil-call 'variable-ref 0))
                 (push-call! loc 'call values))))
                 
         ((<ghil-values*> env loc values)
@@ -372,9 +372,9 @@
                (drop ;; (lambda () (apply values '(1 2)) 3)
                 (for-each comp-drop values))
                (else ;; (lambda () (list (apply values '(10 12)) 1))
-                (push-code! #f (make-glil-const #:obj 'values))
+                (push-code! #f (make-glil-const 'values))
-                (push-code! #f (make-glil-call #:inst 'link-now #:nargs 1))
+                (push-code! #f (make-glil-call 'link-now 1))
-                (push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0))
+                (push-code! #f (make-glil-call 'variable-ref 0))
                 (push-call! loc 'apply values))))
                 
 	((<ghil-call> env loc proc args)

module/language/scheme/compile-ghil.scm

@@ -150,7 +150,7 @@
 
           ;; fixme: non-self-quoting objects like #<foo>
           (else
-           (make-ghil-quote e l #:obj x)))))
+           (make-ghil-quote e l x)))))
 
 (define (valid-bindings? bindings . it-is-for-do)
   (define (valid-binding? b)
@@ -179,11 +179,11 @@
 
 (define-scheme-translator quote
   ;; (quote OBJ)
-  ((,obj) (make-ghil-quote e l #:obj obj)))
+  ((,obj) (make-ghil-quote e l obj)))
     
 (define-scheme-translator quasiquote
   ;; (quasiquote OBJ)
-  ((,obj) (make-ghil-quasiquote e l #:exp (trans-quasiquote e l obj 0))))
+  ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj 0))))
 
 (define-scheme-translator define
   ;; (define NAME VAL)

module/system/base/language.scm

@@ -34,7 +34,7 @@
 ;;; Language class
 ;;;
 
-(define-record <language>
+(define-record/keywords <language>
   name
   title
   version

module/system/base/syntax.scm

@@ -21,7 +21,8 @@
 
 (define-module (system base syntax)
   #:export (%compute-initargs)
-  #:export-syntax (define-type define-record record-case))
+  #:export-syntax (define-type define-record define-record/keywords
+                   record-case))
 
 
 ;;;
@@ -48,6 +49,39 @@
   (string->symbol (string-trim-both (symbol->string sym) pred)))
 
 (define-macro (define-record name-form . slots)
+  (let* ((name (if (pair? name-form) (car name-form) name-form))
+         (printer (and (pair? name-form) (cadr name-form)))
+         (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
+                          slots))
+         (stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
+    `(begin
+       (define ,name (make-record-type ,(symbol->string name) ',slot-names
+                                       ,@(if printer (list printer) '())))
+       ,(let* ((reqs (let lp ((slots slots))
+                       (if (or (null? slots) (not (symbol? (car slots))))
+                           '()
+                           (cons (car slots) (lp (cdr slots))))))
+               (opts (list-tail slots (length reqs)))
+               (tail (gensym)))
+          `(define (,(symbol-append 'make- stem) ,@reqs . ,tail)
+             (let ,(map (lambda (o)
+                          `(,(car o) (cond ((null? ,tail) ,(cadr o))
+                                           (else (let ((_x (car ,tail)))
+                                                   (set! ,tail (cdr ,tail))
+                                                   _x)))))
+                        opts)
+               (make-struct ,name 0 ,@slot-names))))
+       (define ,(symbol-append stem '?) (record-predicate ,name))
+       ,@(map (lambda (sname)
+                `(define ,(symbol-append stem '- sname)
+                   (make-procedure-with-setter
+                    (record-accessor ,name ',sname)
+                    (record-modifier ,name ',sname))))
+              slot-names))))
+
+;; like the former, but accepting keyword arguments in addition to
+;; optional arguments
+(define-macro (define-record/keywords name-form . slots)
   (let* ((name (if (pair? name-form) (car name-form) name-form))
          (printer (and (pair? name-form) (cadr name-form)))
          (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))

module/system/repl/common.scm

@@ -35,7 +35,7 @@
 ;;; Repl type
 ;;;
 
-(define-record <repl> vm language options tm-stats gc-stats vm-stats)
+(define-record/keywords <repl> vm language options tm-stats gc-stats vm-stats)
 
 (define repl-default-options
   '((trace . #f)

module/system/vm/debug.scm

@@ -31,7 +31,7 @@
 ;;; Debugger
 ;;;
 
-(define-record <debugger> vm chain index)
+(define-record/keywords <debugger> vm chain index)
 
 (define (vm-debugger vm)
   (let ((chain (vm-last-frame-chain vm)))