module/language/scheme/inline.scm

   1 ;;; GHIL macros
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 (define-module (language scheme inline)
  23   #:use-module (system base syntax)
  24   #:use-module (language ghil)
  25   #:use-module (srfi srfi-16)
  26   #:export (*inline-table* define-inline try-inline try-inline-with-env))
  27
  28 (define *inline-table* '())
  29
  30 (define-macro (define-inline sym . clauses)
  31   (define (inline-args args)
  32     (let lp ((in args) (out '()))
  33       (cond ((null? in) `(list ,@(reverse out)))
  34             ((symbol? in) `(cons* ,@(reverse out) ,in))
  35             ((pair? (car in))
  36              (lp (cdr in)
  37                  (cons `(or (try-inline ,(caar in) ,(inline-args (cdar in)))
  38                             (error "what" ',(car in)))
  39                        out)))
  40             ((symbol? (car in))
  41              ;; assume it's locally bound
  42              (lp (cdr in) (cons (car in) out)))
  43             ((number? (car in))
  44              (lp (cdr in) (cons `(make-ghil-quote #f #f ,(car in)) out)))
  45             (else
  46              (error "what what" (car in))))))
  47   (define (consequent exp)
  48     (cond
  49      ((pair? exp)
  50       `(make-ghil-inline #f #f ',(car exp) ,(inline-args (cdr exp))))
  51      ((symbol? exp)
  52       ;; assume locally bound
  53       exp)
  54      ((number? exp)
  55       `(make-ghil-quote #f #f ,exp))
  56      (else (error "bad consequent yall" exp))))
  57   `(set! (@ (language scheme inline) *inline-table*)
  58          (assq-set! (@ (language scheme inline) *inline-table*)
  59                     ,sym
  60                     (let ((make-ghil-inline (@ (language ghil) make-ghil-inline))
  61                           (make-ghil-quote (@ (language ghil) make-ghil-quote))
  62                           (try-inline (@ (language scheme inline) try-inline)))
  63                       (case-lambda
  64                        ,@(let lp ((in clauses) (out '()))
  65                            (if (null? in)
  66                                (reverse (cons '(else #f) out))
  67                                (lp (cddr in)
  68                                    (cons `(,(car in)
  69                                            ,(consequent (cadr in))) out)))))))))
  70
  71 (define (try-inline head-value args)
  72   (and=> (assq-ref *inline-table* head-value)
  73          (lambda (proc) (apply proc args))))
  74
  75
  76 (define (try-inline-with-env env loc exp)
  77   (let ((sym (car exp)))
  78     (let loop ((e env))
  79       (record-case e
  80         ((<ghil-toplevel-env> table)
  81          (let ((mod (current-module)))
  82            (and (not (assoc-ref table (cons (module-name mod) sym)))
  83                 (module-bound? mod sym)
  84                 (try-inline (module-ref mod sym) (cdr exp)))))
  85         ((<ghil-env> parent table variables)
  86          (and (not (assq-ref table sym))
  87               (loop parent)))))))
  88
  89 (define-inline eq? (x y)
  90   (eq? x y))
  91
  92 (define-inline eqv? (x y)
  93   (eqv? x y))
  94
  95 (define-inline equal? (x y)
  96   (equal? x y))
  97
  98 (define-inline = (x y)
  99   (ee? x y))
 100
 101 (define-inline < (x y)
 102   (lt? x y))
 103
 104 (define-inline > (x y)
 105   (gt? x y))
 106
 107 (define-inline <= (x y)
 108   (le? x y))
 109
 110 (define-inline >= (x y)
 111   (ge? x y))
 112
 113 (define-inline zero? (x)
 114   (ee? x 0))
 115
 116 (define-inline +
 117   () 0
 118   (x) x
 119   (x y) (add x y)
 120   (x y . rest) (add x (+ y . rest)))
 121
 122 (define-inline *
 123   () 1
 124   (x) x
 125   (x y) (mul x y)
 126   (x y . rest) (mul x (* y . rest)))
 127
 128 (define-inline -
 129   (x) (sub 0 x)
 130   (x y) (sub x y)
 131   (x y . rest) (sub x (+ y . rest)))
 132
 133 (define-inline 1-
 134   (x) (sub x 1))
 135
 136 (define-inline /
 137   (x) (div 1 x)
 138   (x y) (div x y)
 139   (x y . rest) (div x (* y . rest)))
 140
 141 (define-inline quotient (x y)
 142   (quo x y))
 143
 144 (define-inline remainder (x y)
 145   (rem x y))
 146
 147 (define-inline modulo (x y)
 148   (mod x y))
 149
 150 (define-inline not (x)
 151   (not x))
 152
 153 (define-inline pair? (x)
 154   (pair? x))
 155
 156 (define-inline cons (x y)
 157   (cons x y))
 158
 159 (define-inline car (x) (car x))
 160 (define-inline cdr (x) (cdr x))
 161
 162 (define-inline set-car! (x y) (set-car! x y))
 163 (define-inline set-cdr! (x y) (set-cdr! x y))
 164
 165 (define-inline caar (x) (car (car x)))
 166 (define-inline cadr (x) (car (cdr x)))
 167 (define-inline cdar (x) (cdr (car x)))
 168 (define-inline cddr (x) (cdr (cdr x)))
 169 (define-inline caaar (x) (car (car (car x))))
 170 (define-inline caadr (x) (car (car (cdr x))))
 171 (define-inline cadar (x) (car (cdr (car x))))
 172 (define-inline caddr (x) (car (cdr (cdr x))))
 173 (define-inline cdaar (x) (cdr (car (car x))))
 174 (define-inline cdadr (x) (cdr (car (cdr x))))
 175 (define-inline cddar (x) (cdr (cdr (car x))))
 176 (define-inline cdddr (x) (cdr (cdr (cdr x))))
 177 (define-inline caaaar (x) (car (car (car (car x)))))
 178 (define-inline caaadr (x) (car (car (car (cdr x)))))
 179 (define-inline caadar (x) (car (car (cdr (car x)))))
 180 (define-inline caaddr (x) (car (car (cdr (cdr x)))))
 181 (define-inline cadaar (x) (car (cdr (car (car x)))))
 182 (define-inline cadadr (x) (car (cdr (car (cdr x)))))
 183 (define-inline caddar (x) (car (cdr (cdr (car x)))))
 184 (define-inline cadddr (x) (car (cdr (cdr (cdr x)))))
 185 (define-inline cdaaar (x) (cdr (car (car (car x)))))
 186 (define-inline cdaadr (x) (cdr (car (car (cdr x)))))
 187 (define-inline cdadar (x) (cdr (car (cdr (car x)))))
 188 (define-inline cdaddr (x) (cdr (car (cdr (cdr x)))))
 189 (define-inline cddaar (x) (cdr (cdr (car (car x)))))
 190 (define-inline cddadr (x) (cdr (cdr (car (cdr x)))))
 191 (define-inline cdddar (x) (cdr (cdr (cdr (car x)))))
 192 (define-inline cddddr (x) (cdr (cdr (cdr (cdr x)))))
 193
 194 (define-inline null? (x)
 195   (null? x))
 196
 197 (define-inline list? (x)
 198   (list? x))
 199
 200 (define-inline cons*
 201   (x) x
 202   (x y) (cons x y)
 203   (x y . rest) (cons x (cons* y . rest)))
 204
 205 (define-inline acons
 206   (x y z) (cons (cons x y) z))