code:
;;; transformation of letrec into simpler forms

;; Copyright (C) 2009, 2010 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (language tree-il fix-letrec)
  #:use-module (system base syntax)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (language tree-il)
  #:use-module (language tree-il primitives)
  #:export (fix-letrec!))

;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
;; Efficient Implementation of Scheme’s Recursive Binding Construct", by
;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig.

(define fix-fold
  (make-tree-il-folder unref ref set simple lambda complex))

(define (simple-expression? x bound-vars simple-primitive?)
  (record-case x
    ((<void>) #t)
    ((<const>) #t)
    ((<lexical-ref> gensym)
     (not (memq gensym bound-vars)))
    ((<conditional> test consequent alternate)
     (and (simple-expression? test bound-vars simple-primitive?)
          (simple-expression? consequent bound-vars simple-primitive?)
          (simple-expression? alternate bound-vars simple-primitive?)))
    ((<sequence> exps)
     (and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?))
              exps))
    ((<application> proc args)
     (and (primitive-ref? proc)
          (simple-primitive? (primitive-ref-name proc))
          ;; FIXME: check arity?
          (and-map (lambda (x)
                     (simple-expression? x bound-vars simple-primitive?))
                   args)))
    (else #f)))

(define (partition-vars x)
  (let-values
      (((unref ref set simple lambda* complex)
        (fix-fold x
                  (lambda (x unref ref set simple lambda* complex)
                    (record-case x
                      ((<lexical-ref> gensym)
                       (values (delq gensym unref)
                               (lset-adjoin eq? ref gensym)
                               set
                               simple
                               lambda*
                               complex))
                      ((<lexical-set> gensym)
                       (values unref
                               ref
                               (lset-adjoin eq? set gensym)
                               simple
                               lambda*
                               complex))
                      ((<letrec> gensyms)
                       (values (append gensyms unref)
                               ref
                               set
                               simple
                               lambda*
                               complex))
                      ((<let> gensyms)
                       (values (append gensyms unref)
                               ref
                               set
                               simple
                               lambda*
                               complex))
                      (else
                       (values unref ref set simple lambda* complex))))
                  (lambda (x unref ref set simple lambda* complex)
                    (record-case x
                      ((<letrec> in-order? (orig-gensyms gensyms) vals)
                       (let lp ((gensyms orig-gensyms) (vals vals)
                                (s '()) (l '()) (c '()))
                         (cond
                          ((null? gensyms)
                           ;; Unreferenced vars are still complex for letrec*.
                           ;; We need to update our algorithm to "Fixing letrec
                           ;; reloaded" to fix this.
                           (values (if in-order?
                                       (lset-difference eq? unref c)
                                       unref)
                                   ref
                                   set
                                   (append s simple)
                                   (append l lambda*)
                                   (append c complex)))
                          ((memq (car gensyms) unref)
                           ;; See above note about unref and letrec*.
                           (if in-order?
                               (lp (cdr gensyms) (cdr vals)
                                   s l (cons (car gensyms) c))
                               (lp (cdr gensyms) (cdr vals)
                                   s l c)))
                          ((memq (car gensyms) set)
                           (lp (cdr gensyms) (cdr vals)
                               s l (cons (car gensyms) c)))
                          ((lambda? (car vals))
                           (lp (cdr gensyms) (cdr vals)
                               s (cons (car gensyms) l) c))
                          ((simple-expression?
                            (car vals) orig-gensyms
                            (if in-order?
                                effect+exception-free-primitive?
                                effect-free-primitive?))
                           ;; For letrec*, we can't consider e.g. `car' to be
                           ;; "simple", as it could raise an exception. Hence
                           ;; effect+exception-free-primitive? above.
                           (lp (cdr gensyms) (cdr vals)
                               (cons (car gensyms) s) l c))
                          (else
                           (lp (cdr gensyms) (cdr vals)
                               s l (cons (car gensyms) c))))))
                      ((<let> (orig-gensyms gensyms) vals)
                       ;; The point is to compile let-bound lambdas as
                       ;; efficiently as we do letrec-bound lambdas, so
                       ;; we use the same algorithm for analyzing the
                       ;; gensyms. There is no problem recursing into the
                       ;; bindings after the let, because all variables
                       ;; have been renamed.
                       (let lp ((gensyms orig-gensyms) (vals vals)
                                (s '()) (l '()) (c '()))
                         (cond
                          ((null? gensyms)
                           (values unref
                                   ref
                                   set
                                   (append s simple)
                                   (append l lambda*)
                                   (append c complex)))
                          ((memq (car gensyms) unref)
                           (lp (cdr gensyms) (cdr vals)
                               s l c))
                          ((memq (car gensyms) set)
                           (lp (cdr gensyms) (cdr vals)
                               s l (cons (car gensyms) c)))
                          ((and (lambda? (car vals))
                                (not (memq (car gensyms) set)))
                           (lp (cdr gensyms) (cdr vals)
                               s (cons (car gensyms) l) c))
                          ;; There is no difference between simple and
                          ;; complex, for the purposes of let. Just lump
                          ;; them all into complex.
                          (else
                           (lp (cdr gensyms) (cdr vals)
                               s l (cons (car gensyms) c))))))
                      (else
                       (values unref ref set simple lambda* complex))))
                  '()
                  '()
                  '()
                  '()
                  '()
                  '())))
    (values unref simple lambda* complex)))

(define (fix-letrec! x)
  (let-values (((unref simple lambda* complex) (partition-vars x)))
    (post-order!
     (lambda (x)
       (record-case x

         ;; Sets to unreferenced variables may be replaced by their
         ;; expression, called for effect.
         ((<lexical-set> gensym exp)
          (if (memq gensym unref)
              (make-sequence #f (list exp (make-void #f)))
              x))

         ((<letrec> src in-order? names gensyms vals body)
          (let ((binds (map list gensyms names vals)))
            ;; The bindings returned by this function need to appear in the same
            ;; order that they appear in the letrec.
            (define (lookup set)
              (let lp ((binds binds))
                (cond
                 ((null? binds) '())
                 ((memq (caar binds) set)
                  (cons (car binds) (lp (cdr binds))))
                 (else (lp (cdr binds))))))
            (let ((u (lookup unref))
                  (s (lookup simple))
                  (l (lookup lambda*))
                  (c (lookup complex)))
              ;; Bind "simple" bindings, and locations for complex
              ;; bindings.
              (make-let
               src
               (append (map cadr s) (map cadr c))
               (append (map car s) (map car c))
               (append (map caddr s) (map (lambda (x) (make-void #f)) c))
               ;; Bind lambdas using the fixpoint operator.
               (make-fix
                src (map cadr l) (map car l) (map caddr l)
                (make-sequence
                 src
                 (append
                  ;; The right-hand-sides of the unreferenced
                  ;; bindings, for effect.
                  (map caddr u)
                  (cond
                   ((null? c)
                    ;; No complex bindings, just emit the body.
                    (list body))
                   (in-order?
                    ;; For letrec*, assign complex bindings in order, then the
                    ;; body.
                    (append
                     (map (lambda (c)
                            (make-lexical-set #f (cadr c) (car c) (caddr c)))
                          c)
                     (list body)))
                   (else
                    ;; Otherwise for plain letrec, evaluate the the "complex"
                    ;; bindings, in a `let' to indicate that order doesn't
                    ;; matter, and bind to their variables.
                    (list
                     (let ((tmps (map (lambda (x) (gensym)) c)))
                       (make-let
                        #f (map cadr c) tmps (map caddr c)
                        (make-sequence
                         #f
                         (map (lambda (x tmp)
                                (make-lexical-set
                                 #f (cadr x) (car x)
                                 (make-lexical-ref #f (cadr x) tmp)))
                              c tmps))))
                     body))))))))))

         ((<let> src names gensyms vals body)
          (let ((binds (map list gensyms names vals)))
            (define (lookup set)
              (map (lambda (v) (assq v binds))
                   (lset-intersection eq? gensyms set)))
            (let ((u (lookup unref))
                  (l (lookup lambda*))
                  (c (lookup complex)))
              (make-sequence
               src
               (append
                ;; unreferenced bindings, called for effect.
                (map caddr u)
                (list
                 ;; unassigned lambdas use fix.
                 (make-fix src (map cadr l) (map car l) (map caddr l)
                           ;; and the "complex" bindings.
                           (make-let src (map cadr c) (map car c) (map caddr c)
                                     body))))))))

         (else x)))
     x)))


code:
;;; a simple inliner

;; Copyright (C) 2009, 2010 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (language tree-il inline)
  #:use-module (system base pmatch)
  #:use-module (system base syntax)
  #:use-module (language tree-il)
  #:export (inline!))

;; Possible optimizations:
;; * constant folding, propagation
;; * procedure inlining
;;   * always when single call site
;;   * always for "trivial" procs
;;   * otherwise who knows
;; * dead code elimination
;; * degenerate case optimizations
;; * "fixing letrec"

(define (boolean-value x)
  (let ((src (tree-il-src x)))
    (record-case x
      ((<void>)
       (make-const src #t))

      ((<conditional> test consequent alternate)
       (record-case (boolean-value test)
         ((<const> exp)
          (case exp
            ((#t) (boolean-value consequent))
            ((#f) (boolean-value alternate))
            (else x)))
         (else x)))

      ((<lambda> meta body)
       (make-const src #t))

      ((<const> exp)
       (make-const src (not (not exp))))

      (else
       x))))

;; This is a completely brain-dead optimization pass whose sole claim to
;; fame is ((lambda () x)) => x.
(define (inline! x)
  (define (inline1 x)
    (record-case x
      ((<application> src proc args)
       (record-case proc
         ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
         ((<lambda> body)
          (let lp ((lcase body))
            (and lcase
                 (record-case lcase
                   ((<lambda-case> req opt rest kw inits gensyms body alternate)
                    (if (and (= (length gensyms) (length req) (length args)))
                        (let ((x (make-let src req gensyms args body)))
                          (or (inline1 x) x))
                        (lp alternate)))))))

         ((<primitive-ref> name)
          (case name
            ((@call-with-values)
             (pmatch args
               ;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
               ;; => (let-values (((a b . c) foo)) bar)
               ;;
               ;; Note that this is a singly-binding form of let-values.
               ;; Also note that Scheme's let-values expands into
               ;; call-with-values, then here we reduce it to tree-il's
               ;; let-values.
               ((,producer ,consumer)
                (guard (lambda? consumer)
                       (lambda-case? (lambda-body consumer))
                       (not (lambda-case-opt (lambda-body consumer)))
                       (not (lambda-case-kw (lambda-body consumer)))
                       (not (lambda-case-alternate (lambda-body consumer))))
                (make-let-values
                 src
                 (let ((x (make-application src producer '())))
                   (or (inline1 x) x))
                 (lambda-body consumer)))
               (else #f)))

            ((memq memv)
             (pmatch args
               ((,k ,l) (guard (const? l) (list? (const-exp l)))
                (if (null? (const-exp l))
                    (make-const #f #f)
                    (let lp ((elts (const-exp l)))
                      (let ((test (make-application
                                   #f
                                   (make-primitive-ref #f (case name
                                                            ((memq) 'eq?)
                                                            ((memv) 'eqv?)
                                                            (else (error "what"))))
                                   (list k (make-const #f (car elts))))))
                        (if (null? (cdr elts))
                            test
                            (make-conditional
                             src
                             test
                             (make-const #f #t)
                             (lp (cdr elts))))))))

               (else #f)))

            (else #f)))

         (else #f)))

      ((<conditional> test consequent alternate)
       (let ((btest (boolean-value test)))
         (or (record-case btest
               ((<const> exp)
                (case exp
                  ((#t) consequent)
                  ((#f) alternate)
                  (else #f)))
               (else #f))
             (if (eq? test btest)
                 x
                 (make-conditional (conditional-src x)
                                   btest consequent alternate)))))

      ((<let> gensyms body)
       (if (null? gensyms) body x))

      ((<letrec> gensyms body)
       (if (null? gensyms) body x))

      ((<fix> gensyms body)
       (if (null? gensyms) body x))

      ((<lambda-case> req opt rest kw gensyms body alternate)
       (define (args-compatible? args gensyms)
         (let lp ((args args) (gensyms gensyms))
           (cond
            ((null? args) (null? gensyms))
            ((null? gensyms) #f)
            ((and (lexical-ref? (car args))
                  (eq? (lexical-ref-gensym (car args)) (car gensyms)))
             (lp (cdr args) (cdr gensyms)))
            (else #f))))

       (and (not opt) (not kw) rest (not alternate)
            (record-case body
              ((<application> proc args)
               ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
               (and (primitive-ref? proc)
                    (eq? (primitive-ref-name proc) '@apply)
                    (pair? args)
                    (lambda? (car args))
                    (args-compatible? (cdr args) gensyms)
                    (lambda-body (car args))))
              (else #f))))

      ;; Actually the opposite of inlining -- if the prompt cannot be proven to
      ;; be escape-only, ensure that its body is the application of a thunk.
      ((<prompt> src tag body handler)
       (define (escape-only? handler)
         (and (pair? (lambda-case-req handler))
              (let ((cont (car (lambda-case-gensyms handler))))
                (tree-il-fold (lambda (leaf escape-only?)
                                (and escape-only?
                                     (not
                                      (and (lexical-ref? leaf)
                                           (eq? (lexical-ref-gensym leaf) cont)))))
                              (lambda (down escape-only?) escape-only?)
                              (lambda (up escape-only?) escape-only?)
                              #t
                              (lambda-case-body handler)))))
       (define (make-thunk body)
         (make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body #f)))

       (if (or (and (application? body)
                    (lambda? (application-proc body))
                    (null? (application-args body)))
               (escape-only? handler))
           x
           (make-prompt src tag
                        (make-application #f (make-thunk body) '())
                        handler)))

      (else #f)))
  (post-order! inline1 x))

license: mit


code:
;;; Tree-il optimizer

;; Copyright (C) 2009 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language tree-il optimize)
  #:use-module (language tree-il)
  #:use-module (language tree-il primitives)
  #:use-module (language tree-il inline)
  #:use-module (language tree-il fix-letrec)
  #:export (optimize!))

(define (optimize! x env opts)
  (inline!
   (fix-letrec!
    (expand-primitives!
     (resolve-primitives! x env)))))


code:
;;; open-coding primitive procedures

;; Copyright (C) 2009, 2010 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language tree-il primitives)
  #:use-module (system base pmatch)
  #:use-module (rnrs bytevectors)
  #:use-module (system base syntax)
  #:use-module (language tree-il)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-16)
  #:export (resolve-primitives! add-interesting-primitive!
            expand-primitives!
            effect-free-primitive? effect+exception-free-primitive?))

(define *interesting-primitive-names*
  '(apply @apply
    call-with-values @call-with-values
    call-with-current-continuation @call-with-current-continuation
    call/cc
    dynamic-wind
    @dynamic-wind
    values
    eq? eqv? equal?
    memq memv
    = < > <= >= zero?
    + * - / 1- 1+ quotient remainder modulo
    ash logand logior logxor
    not
    pair? null? list? acons cons cons*

    list vector

    car cdr
    set-car! set-cdr!

    caar cadr cdar cddr

    caaar caadr cadar caddr cdaar cdadr cddar cdddr

    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr

    vector-ref vector-set!
    variable-ref variable-set!
    variable-bound?

    fluid-ref fluid-set!

    @prompt call-with-prompt @abort abort-to-prompt
    make-prompt-tag

    struct? struct-vtable make-struct struct-ref struct-set!

    bytevector-u8-ref bytevector-u8-set!
    bytevector-s8-ref bytevector-s8-set!
    u8vector-ref u8vector-set! s8vector-ref s8vector-set!

    bytevector-u16-ref bytevector-u16-set!
    bytevector-u16-native-ref bytevector-u16-native-set!
    bytevector-s16-ref bytevector-s16-set!
    bytevector-s16-native-ref bytevector-s16-native-set!
    u16vector-ref u16vector-set! s16vector-ref s16vector-set!

    bytevector-u32-ref bytevector-u32-set!
    bytevector-u32-native-ref bytevector-u32-native-set!
    bytevector-s32-ref bytevector-s32-set!
    bytevector-s32-native-ref bytevector-s32-native-set!
    u32vector-ref u32vector-set! s32vector-ref s32vector-set!

    bytevector-u64-ref bytevector-u64-set!
    bytevector-u64-native-ref bytevector-u64-native-set!
    bytevector-s64-ref bytevector-s64-set!
    bytevector-s64-native-ref bytevector-s64-native-set!
    u64vector-ref u64vector-set! s64vector-ref s64vector-set!

    bytevector-ieee-single-ref bytevector-ieee-single-set!
    bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
    bytevector-ieee-double-ref bytevector-ieee-double-set!
    bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
    f32vector-ref f32vector-set! f64vector-ref f64vector-set!))

(define (add-interesting-primitive! name)
  (hashq-set! *interesting-primitive-vars*
              (or (module-variable (current-module) name)
                  (error "unbound interesting primitive" name))
              name))

(define *interesting-primitive-vars* (make-hash-table))

(for-each add-interesting-primitive! *interesting-primitive-names*)

(define *effect-free-primitives*
  '(values
    eq? eqv? equal?
    = < > <= >= zero?
    + * - / 1- 1+ quotient remainder modulo
    not
    pair? null? list? acons cons cons*
    list vector
    car cdr
    caar cadr cdar cddr
    caaar caadr cadar caddr cdaar cdadr cddar cdddr
    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
    vector-ref
    struct? struct-vtable make-struct make-struct/no-tail struct-ref
    bytevector-u8-ref bytevector-s8-ref
    bytevector-u16-ref bytevector-u16-native-ref
    bytevector-s16-ref bytevector-s16-native-ref
    bytevector-u32-ref bytevector-u32-native-ref
    bytevector-s32-ref bytevector-s32-native-ref
    bytevector-u64-ref bytevector-u64-native-ref
    bytevector-s64-ref bytevector-s64-native-ref
    bytevector-ieee-single-ref bytevector-ieee-single-native-ref
    bytevector-ieee-double-ref bytevector-ieee-double-native-ref))

;; Like *effect-free-primitives* above, but further restricted in that they
;; cannot raise exceptions.
(define *effect+exception-free-primitives*
  '(values
    eq? eqv? equal?
    not
    pair? null? list? acons cons cons*
    list vector
    struct?))

(define *effect-free-primitive-table* (make-hash-table))
(define *effect+exceptions-free-primitive-table* (make-hash-table))

(for-each (lambda (x)
            (hashq-set! *effect-free-primitive-table* x #t))
          *effect-free-primitives*)
(for-each (lambda (x)
            (hashq-set! *effect+exceptions-free-primitive-table* x #t))
          *effect+exception-free-primitives*)

(define (effect-free-primitive? prim)
  (hashq-ref *effect-free-primitive-table* prim))
(define (effect+exception-free-primitive? prim)
  (hashq-ref *effect+exceptions-free-primitive-table* prim))

(define (resolve-primitives! x mod)
  (post-order!
   (lambda (x)
     (record-case x
       ((<toplevel-ref> src name)
        (and=> (hashq-ref *interesting-primitive-vars*
                          (module-variable mod name))
               (lambda (name) (make-primitive-ref src name))))
       ((<module-ref> src mod name public?)
        ;; for the moment, we're disabling primitive resolution for
        ;; public refs because resolve-interface can raise errors.
        (let ((m (and (not public?) (resolve-module mod))))
          (and m
               (and=> (hashq-ref *interesting-primitive-vars*
                                 (module-variable m name))
                      (lambda (name) (make-primitive-ref src name))))))
       (else #f)))
   x))

(define *primitive-expand-table* (make-hash-table))

(define (expand-primitives! x)
  (pre-order!
   (lambda (x)
     (record-case x
       ((<application> src proc args)
        (and (primitive-ref? proc)
             (let ((expand (hashq-ref *primitive-expand-table*
                                      (primitive-ref-name proc))))
               (and expand (apply expand src args)))))
       (else #f)))
   x))

;;; I actually did spend about 10 minutes trying to redo this with
;;; syntax-rules. Patches appreciated.
;;;
(define-macro (define-primitive-expander sym . clauses)
  (define (inline-args args)
    (let lp ((in args) (out '()))
      (cond ((null? in) `(list ,@(reverse out)))
            ((symbol? in) `(cons* ,@(reverse out) ,in))
            ((pair? (car in))
             (lp (cdr in)
                 (cons (if (eq? (caar in) 'quote)
                           `(make-const src ,@(cdar in))
                           `(make-application src (make-primitive-ref src ',(caar in))
                                              ,(inline-args (cdar in))))
                       out)))
            ((symbol? (car in))
             ;; assume it's locally bound
             (lp (cdr in) (cons (car in) out)))
            ((self-evaluating? (car in))
             (lp (cdr in) (cons `(make-const src ,(car in)) out)))
            (else
             (error "what what" (car in))))))
  (define (consequent exp)
    (cond
     ((pair? exp)
      (pmatch exp
        ((if ,test ,then ,else)
         `(if ,test
              ,(consequent then)
              ,(consequent else)))
        (else
         `(make-application src (make-primitive-ref 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
               (case-lambda
                ,@(let lp ((in clauses) (out '()))
                    (if (null? in)
                        (reverse (cons '(else #f) out))
                        (lp (cddr in)
                            (cons `((src . ,(car in))
                                    ,(consequent (cadr in))) out)))))))

(define-primitive-expander zero? (x)
  (= x 0))

(define-primitive-expander +
  () 0
  (x) x
  (x y) (if (and (const? y)
                 (let ((y (const-exp y)))
                   (and (number? y) (exact? y) (= y 1))))
            (1+ x)
            (if (and (const? y)
                     (let ((y (const-exp y)))
                       (and (number? y) (exact? y) (= y -1))))
                (1- x)
                (if (and (const? x)
                         (let ((x (const-exp x)))
                           (and (number? x) (exact? x) (= x 1))))
                    (1+ y)
                    (+ x y))))
  (x y z . rest) (+ x (+ y z . rest)))

(define-primitive-expander *
  () 1
  (x) x
  (x y z . rest) (* x (* y z . rest)))

(define-primitive-expander -
  (x) (- 0 x)
  (x y) (if (and (const? y)
                 (let ((y (const-exp y)))
                   (and (number? y) (exact? y) (= y 1))))
            (1- x)
            (- x y))
  (x y z . rest) (- x (+ y z . rest)))

(define-primitive-expander /
  (x) (/ 1 x)
  (x y z . rest) (/ x (* y z . rest)))

(define-primitive-expander caar (x) (car (car x)))
(define-primitive-expander cadr (x) (car (cdr x)))
(define-primitive-expander cdar (x) (cdr (car x)))
(define-primitive-expander cddr (x) (cdr (cdr x)))
(define-primitive-expander caaar (x) (car (car (car x))))
(define-primitive-expander caadr (x) (car (car (cdr x))))
(define-primitive-expander cadar (x) (car (cdr (car x))))
(define-primitive-expander caddr (x) (car (cdr (cdr x))))
(define-primitive-expander cdaar (x) (cdr (car (car x))))
(define-primitive-expander cdadr (x) (cdr (car (cdr x))))
(define-primitive-expander cddar (x) (cdr (cdr (car x))))
(define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
(define-primitive-expander caaaar (x) (car (car (car (car x)))))
(define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
(define-primitive-expander caadar (x) (car (car (cdr (car x)))))
(define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
(define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
(define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
(define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
(define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
(define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
(define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
(define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
(define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
(define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
(define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
(define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
(define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))

(define-primitive-expander cons*
  (x) x
  (x y) (cons x y)
  (x y . rest) (cons x (cons* y . rest)))

(define-primitive-expander acons (x y z)
  (cons (cons x y) z))

(define-primitive-expander apply (f a0 . args)
  (@apply f a0 . args))

(define-primitive-expander call-with-values (producer consumer)
  (@call-with-values producer consumer))

(define-primitive-expander call-with-current-continuation (proc)
  (@call-with-current-continuation proc))

(define-primitive-expander call/cc (proc)
  (@call-with-current-continuation proc))

(define-primitive-expander values (x) x)

(define-primitive-expander make-struct (vtable tail-size . args)
  (if (and (const? tail-size)
           (let ((n (const-exp tail-size)))
             (and (number? n) (exact? n) (zero? n))))
      (make-struct/no-tail vtable . args)
      #f))

(define-primitive-expander u8vector-ref (vec i)
  (bytevector-u8-ref vec i))
(define-primitive-expander u8vector-set! (vec i x)
  (bytevector-u8-set! vec i x))
(define-primitive-expander s8vector-ref (vec i)
  (bytevector-s8-ref vec i))
(define-primitive-expander s8vector-set! (vec i x)
  (bytevector-s8-set! vec i x))

(define-primitive-expander u16vector-ref (vec i)
  (bytevector-u16-native-ref vec (* i 2)))
(define-primitive-expander u16vector-set! (vec i x)
  (bytevector-u16-native-set! vec (* i 2) x))
(define-primitive-expander s16vector-ref (vec i)
  (bytevector-s16-native-ref vec (* i 2)))
(define-primitive-expander s16vector-set! (vec i x)
  (bytevector-s16-native-set! vec (* i 2) x))

(define-primitive-expander u32vector-ref (vec i)
  (bytevector-u32-native-ref vec (* i 4)))
(define-primitive-expander u32vector-set! (vec i x)
  (bytevector-u32-native-set! vec (* i 4) x))
(define-primitive-expander s32vector-ref (vec i)
  (bytevector-s32-native-ref vec (* i 4)))
(define-primitive-expander s32vector-set! (vec i x)
  (bytevector-s32-native-set! vec (* i 4) x))

(define-primitive-expander u64vector-ref (vec i)
  (bytevector-u64-native-ref vec (* i 8)))
(define-primitive-expander u64vector-set! (vec i x)
  (bytevector-u64-native-set! vec (* i 8) x))
(define-primitive-expander s64vector-ref (vec i)
  (bytevector-s64-native-ref vec (* i 8)))
(define-primitive-expander s64vector-set! (vec i x)
  (bytevector-s64-native-set! vec (* i 8) x))

(define-primitive-expander f32vector-ref (vec i)
  (bytevector-ieee-single-native-ref vec (* i 4)))
(define-primitive-expander f32vector-set! (vec i x)
  (bytevector-ieee-single-native-set! vec (* i 4) x))
(define-primitive-expander f32vector-ref (vec i)
  (bytevector-ieee-single-native-ref vec (* i 4)))
(define-primitive-expander f32vector-set! (vec i x)
  (bytevector-ieee-single-native-set! vec (* i 4) x))

(define-primitive-expander f64vector-ref (vec i)
  (bytevector-ieee-double-native-ref vec (* i 8)))
(define-primitive-expander f64vector-set! (vec i x)
  (bytevector-ieee-double-native-set! vec (* i 8) x))
(define-primitive-expander f64vector-ref (vec i)
  (bytevector-ieee-double-native-ref vec (* i 8)))
(define-primitive-expander f64vector-set! (vec i x)
  (bytevector-ieee-double-native-set! vec (* i 8) x))

(hashq-set! *primitive-expand-table*
            'dynamic-wind
            (case-lambda
              ((src pre thunk post)
               ;; Here we will make concessions to the fact that our inliner is
               ;; lame, and add a hack.
               (cond
                ((lambda? thunk)
                 (let ((PRE (gensym " pre"))
                       (POST (gensym " post")))
                   (make-let
                    src
                    '(pre post)
                    (list PRE POST)
                    (list pre post)
                    (make-dynwind
                     src
                     (make-lexical-ref #f 'pre PRE)
                     (make-application #f thunk '())
                     (make-lexical-ref #f 'post POST)))))
                (else
                 (let ((PRE (gensym " pre"))
                       (THUNK (gensym " thunk"))
                       (POST (gensym " post")))
                   (make-let
                    src
                    '(pre thunk post)
                    (list PRE THUNK POST)
                    (list pre thunk post)
                    (make-dynwind
                     src
                     (make-lexical-ref #f 'pre PRE)
                     (make-application #f (make-lexical-ref #f 'thunk THUNK) '())
                     (make-lexical-ref #f 'post POST)))))))
              (else #f)))

(hashq-set! *primitive-expand-table*
            '@dynamic-wind
            (case-lambda
              ((src pre expr post)
               (let ((PRE (gensym " pre"))
                     (POST (gensym " post")))
                 (make-let
                  src
                  '(pre post)
                  (list PRE POST)
                  (list pre post)
                  (make-dynwind
                   src
                   (make-lexical-ref #f 'pre PRE)
                   expr
                   (make-lexical-ref #f 'post POST)))))))

(hashq-set! *primitive-expand-table*
            'fluid-ref
            (case-lambda
              ((src fluid) (make-dynref src fluid))
              (else #f)))

(hashq-set! *primitive-expand-table*
            'fluid-set!
            (case-lambda
              ((src fluid exp) (make-dynset src fluid exp))
              (else #f)))

(hashq-set! *primitive-expand-table*
            '@prompt
            (case-lambda
              ((src tag exp handler)
               (let ((args-sym (gensym)))
                 (make-prompt
                  src tag exp
                  ;; If handler itself is a lambda, the inliner can do some
                  ;; trickery here.
                  (make-lambda-case
                   (tree-il-src handler) '() #f 'args #f '() (list args-sym)
                   (make-application #f (make-primitive-ref #f 'apply)
                                     (list handler
                                           (make-lexical-ref #f 'args args-sym)))
                   #f))))
              (else #f)))

(hashq-set! *primitive-expand-table*
            'call-with-prompt
            (case-lambda
              ((src tag thunk handler)
               ;; Sigh. Until the inliner does its job, manually inline
               ;; (let ((h (lambda ...))) (prompt k x h))
               (cond
                ((lambda? handler)
                 (let ((args-sym (gensym)))
                   (make-prompt
                    src tag (make-application #f thunk '())
                    ;; If handler itself is a lambda, the inliner can do some
                    ;; trickery here.
                    (make-lambda-case
                     (tree-il-src handler) '() #f 'args #f '() (list args-sym)
                     (make-application #f (make-primitive-ref #f 'apply)
                                       (list handler
                                             (make-lexical-ref #f 'args args-sym)))
                     #f))))
                (else #f)))
              (else #f)))

(hashq-set! *primitive-expand-table*
            '@abort
            (case-lambda
              ((src tag tail-args)
               (make-abort src tag '() tail-args))
              (else #f)))
(hashq-set! *primitive-expand-table*
            'abort-to-prompt
            (case-lambda
              ((src tag . args)
               (make-abort src tag args (make-const #f '())))
              (else #f)))


code:
;;; Tree Intermediate Language

;; Copyright (C) 2009, 2010 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language tree-il spec)
  #:use-module (system base language)
  #:use-module (system base pmatch)
  #:use-module (language glil)
  #:use-module (language tree-il)
  #:use-module (language tree-il compile-glil)
  #:export (tree-il))

(define (write-tree-il exp . port)
  (apply write (unparse-tree-il exp) port))

(define (join exps env)
  (pmatch exps
    (() (make-void #f))
    ((,x) x)
    (else (make-sequence #f exps))))

(define-language tree-il
  #:title	"Tree Intermediate Language"
  #:reader	(lambda (port env) (read port))
  #:printer	write-tree-il
  #:parser      parse-tree-il
  #:joiner      join
  #:compilers   `((glil . ,compile-glil))
  )


code:
;;; Guile Lowlevel Intermediate Language

;; Copyright (C) 2001, 2010 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language value spec)
  #:use-module (system base language)
  #:export (value))

(define-language value
  #:title	"Values"
  #:reader	#f
  #:printer	write
  )


code:
2008-03-18  Ludovic Courtès  <ludo@gnu.org>

	* goops/util.scm (mapappend): Now an alias for SRFI-1's
	`append-map', which is more efficient.
	(every, any): Used and re-exported from SRFI-1.

2008-03-12  Ludovic Courtès  <ludo@gnu.org>

	* goops/describe.scm (describe): Provide `describe' (symbol),
	not `"describe"' (string).  Reported by David Pirotte
	<david@altosw.be>.

2007-05-05  Ludovic Courtès  <ludo@chbouib.org>

	* goops/internal.scm: Use the public module API rather than hack
	with `%module-public-interface', `nested-ref', et al.

2005-03-24  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* accessors.scm, simple.scm: New files.

	* goops.scm (standard-define-class): Removed; Export
	define-class as standard-define-class.

2005-01-18  Marius Vollmer  <marius.vollmer@uni-dortmund.de>

	* goops.scm (class-of): Changed from being re-exported to just
	being exported.

2004-02-08  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* Makefile.am, goops/Makefile.am (TAGS_FILES): Use this variable
	instead of ETAGS_ARGS so that TAGS can be built using separate
	build directory.

2004-01-12  Marius Vollmer  <mvo@zagadka.de>

	* goops.scm (compute-get-n-set): Use '#:' in error message instead
	of ':'.  Thanks to Richard Todd!

2003-04-20  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (compute-getters-n-setters): Allow for primitive
	procedure thunks.  (Thanks to Neil W. Van Dyke.)

2003-04-19  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops/dispatch.scm (cache-hashval): Corrected termination
	condition for hashval computation.  (Previously, it made erroneous
	assumptions about the representation of environments; Thanks to
	Andreas Rottmann.)

2003-04-17  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (compute-getters-n-setters): Check for bad init-thunk.
	(eqv?): Added default method.
	(equal?): New default method which uses eqv?.

2003-04-15  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (compute-getter-method): For custom getter: Check
	boundness even if there is an init-thunk.  (The getter can return
	#<unbound> even if the slot has been set before.)
	(remove-class-accessors!): Also remove accessor-method from its
	accessor.

2003-04-13  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (compute-getters-n-setters/verify-accessors): Better
	check of format of value returned by compute-get-n-set.
	(compute-getters-n-setters): Extended format of slot
	getters-n-setters to indicate position and size of slot memory
	allocated in instances.

2003-04-05  Marius Vollmer  <mvo@zagadka.de>

        * Changed license terms to the plain LGPL thru-out.

2003-03-19  Mikael Djurfeldt  <mdj@kvast.blakulla.net>

	* goops.scm (process-class-pre-define-accessor): Temporary kludge
	to fix a problem introduced by my previous change.

2003-03-17  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (process-class-pre-define-generic,
	process-class-pre-define-accessor, process-define-generic,
	process-define-accessor): New functions.
	(define-class-pre-definition): Use
	process-class-pre-define-generic and
	process-class-pre-define-accessor; Make sure not to create a new
	local variable if the variable has been imported.
	(define-generic): Use process-define-generic.
	(define-accessor): Use process-define-accessor.

2003-03-12  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (merge-generics): Make sure not to merge a gf with
	itself.  That would be the cause of a real binding collision.

2003-03-11  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops/util.scm (filter): Removed.  (Now supplied by core.)

	* goops.scm (define-extended-generics): New syntax.
	(<class> <operator-class> <entity-class> <entity>): Marked as
	replacements.
	(upgrade-accessor): Renamed from upgrade-generic-with-setter.
	(ensure-accessor, upgrade-accessor): Rewritten to accomodate the
	new <accessor> class.
	(merge-accessors): Provide for merging of accessors imported from
	different modules under the same name.

2003-03-07  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (equal?): Define default method.
	(merge-generics): Provide for merging of generic functions
	imported into a module under the same name.

2003-01-18  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (method): Construct a new copy of the constant '('())
	for every macro invocation.

2003-01-08  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (upgrade-generic-with-setter,
	compute-new-list-of-methods): Use methods slot directly instead of
	generic-function-methods.
	(upgrade-generic-with-setter): Handle <extended-generic>:s.
	(define-extended-generic): New syntax.
	(make-extended-generic): New function.

2002-12-08  Rob Browning  <rlb@defaultvalue.org>

	* Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.

	* goops/Makefile.am (subpkgdatadir): VERSION ->
	GUILE_EFFECTIVE_VERSION.

2002-11-16  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* goops.scm (standard-define-class):  Changed definition to form
	a 'real' macro definition.

2002-07-13  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* goops.scm (define-generic, define-accessor):  Make sure that
	define-generic and define-accessor will continue to work when
	mmacros are expanded before execution.

2002-07-13  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* goops.scm (define-class):  Make sure that define-class will
	continue to work when mmacros are expanded before execution.

2002-07-08  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* goops.scm (define-generic, define-accessor):  Make sure that
	implicit redefines only happen on top level.

	* goops.scm (define-class, define-generic, define-accessor),
	goops/stklos.scm (define-class):  Use mmacros instead of macros.

2002-07-07  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* goops/save.scm (restore): Replaced "macro" by	mmacro.

2001-10-21  Mikael Djurfeldt  <mdj@linnaeus>

	* goops.scm, goops/active-slot.scm, goops/compile.scm,
	goops/composite-slot.scm, goops/describe.scm, goops/dispatch.scm,
	goops/old-define-method.scm, goops/save.scm, goops/util.scm: Move
	module the system directives `export', `export-syntax',
	`re-export' and `re-export-syntax' into the `define-module' form.
	This is the recommended way of exporting bindings.

2001-08-25  Marius Vollmer  <mvo@zagadka.ping.de>

	* Makefile.am, goops/Makefile.am: (AUTOMAKE_OPTIONS): Change
	"foreign" to "gnu".

2001-07-29  Marius Vollmer  <mvo@zagadka.ping.de>

	* goops/dispatch.scm (hashset-index): Renumbered, since the vcell
	slot of structs has been removed.

2001-07-18  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* goops/util.scm: Updated copyright notice.

2001-07-17  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* goops/save.scm: Use `re-export' instead of `export' when
	re-exporting `make-unbound'.

2001-06-05  Marius Vollmer  <mvo@zagadka.ping.de>

	* goops.scm: Use `re-export' instead of `export' when re-exporting
	`class-of'.

2001-05-19  Marius Vollmer  <mvo@zagadka.ping.de>

	* goops.scm: Call `%init-goops-builtins' instead of using the
	`(oop goops goopscore)' module.

2001-05-10  Marius Vollmer  <mvo@zagadka.ping.de>

	* goops/compile.scm (compile-method): Insert comment that
	`procedure-source' can not be guaranteed to be reliable or
	efficient.

2001-05-05  Marius Vollmer  <mvo@zagadka.ping.de>

	* goops.scm (initialize-object-procedure): Use
	`valid-object-procedure?' instead of explicit tag magic.
	(object-procedure-tags): Removed.

	* goops/util.scm (top-level-env): Use `current-module' instead of
	the deprecated *top-level-lookup-closure*.

2001-04-28  Rob Browning  <rlb@cs.utexas.edu>

	* goops/save.scm (write-readably): rename list* to cons*.

	* goops.scm (method): rename list* to cons*.

2001-04-10  Mikael Djurfeldt  <mdj@linnaeus.mit.edu>

	* goops/Makefile.am, goops/goopscore.scm: Reverted changes of
	2001-04-03, 2001-03-09.

2001-04-03  Keisuke Nishida  <kxn30@po.cwru.edu>

	* goops/Makefile.am (goops_sources): Include goopscore.scm.
	Thanks to Dale P. Smith.

2001-03-29  Keisuke Nishida  <kxn30@po.cwru.edu>

	* goops/goopscore.scm: New file.

2001-03-09  Mikael Djurfeldt  <mdj@linnaeus.mit.edu>

	* goops.scm (define-method): Only accept new syntax.

	* Makefile.am: Added old-define-method.scm.

	* goops/old-define-method.scm: New file.

	* goops.scm, goops/save.scm, goops/composite-slot.scm,
	goops/active-slot.scm: Use new method syntax.

2001-03-04  Mikael Djurfeldt  <mdj@linnaeus.mit.edu>

	* goops/compile.scm (compile-method): Tag method closure for body
	expansion.

	* goops.scm (change-object-class): Quote empty list constants.
	(method): Reverted previous change (enclosing body);
	Quote empty list.
	(initialize <method>): Supply `dummy-procedure' as default instead
	of creating a new closure.

	* goops/internal.scm: Re-export (oop goops) without copying
	bindings.

2001-02-23  Keisuke Nishida  <kxn30@po.cwru.edu>

	* goops.scm (method): Enclosed BODY by `(let () ...)'.
	This allows local defines at the beginning of methods.

2000-12-15  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* goops/save.scm (load-objects):  eval-in-module is deprecated.
	Use eval instead.

2000-11-24  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* goops.scm:  Don't export removed %logand any more.

	* goops/dispatch.scm (cache-try-hash!):  Use logand instead of
	%logand.

2000-11-06  Mikael Djurfeldt  <mdj@linnaeus.mit.edu>

	* goops.scm (internal-add-method!): Set n-specialized of a generic
	function to the number of specializers regardless if it has rest
	args or not.

	* goops/dispatch.scm (method-cache-install!): Use n-specialized +
	1 args for type matching.  (Thanks to Lars J. Aas.)

2000-10-23  Mikael Djurfeldt  <mdj@linnaeus.mit.edu>

	* goops.scm (goops-error): Removed use of oldfmt.

;; Local Variables:
;; coding: utf-8
;; End: