diff options
Diffstat (limited to 'module/language/scheme/inline.scm')
-rw-r--r-- | module/language/scheme/inline.scm | 205 |
1 files changed, 0 insertions, 205 deletions
diff --git a/module/language/scheme/inline.scm b/module/language/scheme/inline.scm deleted file mode 100644 index b178b2adc..000000000 --- a/module/language/scheme/inline.scm +++ /dev/null @@ -1,205 +0,0 @@ -;;; GHIL macros - -;; Copyright (C) 2001 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 scheme inline) - #:use-module (system base syntax) - #:use-module (language ghil) - #:use-module (srfi srfi-16) - #:export (*inline-table* define-inline try-inline try-inline-with-env)) - -(define *inline-table* '()) - -(define-macro (define-inline 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 `(or (try-inline ,(caar in) ,(inline-args (cdar in))) - (error "what" ',(car in))) - out))) - ((symbol? (car in)) - ;; assume it's locally bound - (lp (cdr in) (cons (car in) out))) - ((number? (car in)) - (lp (cdr in) (cons `(make-ghil-quote #f #f ,(car in)) out))) - (else - (error "what what" (car in)))))) - (define (consequent exp) - (cond - ((pair? exp) - `(make-ghil-inline #f #f ',(car exp) ,(inline-args (cdr exp)))) - ((symbol? exp) - ;; assume locally bound - exp) - ((number? exp) - `(make-ghil-quote #f #f ,exp)) - (else (error "bad consequent yall" exp)))) - `(set! (@ (language scheme inline) *inline-table*) - (assq-set! (@ (language scheme inline) *inline-table*) - ,sym - (let ((make-ghil-inline (@ (language ghil) make-ghil-inline)) - (make-ghil-quote (@ (language ghil) make-ghil-quote)) - (try-inline (@ (language scheme inline) try-inline))) - (case-lambda - ,@(let lp ((in clauses) (out '())) - (if (null? in) - (reverse (cons '(else #f) out)) - (lp (cddr in) - (cons `(,(car in) - ,(consequent (cadr in))) out))))))))) - -(define (try-inline head-value args) - (and=> (assq-ref *inline-table* head-value) - (lambda (proc) (apply proc args)))) - - -(define (try-inline-with-env env loc exp) - (let ((sym (car exp))) - (let loop ((e env)) - (record-case e - ((<ghil-toplevel-env> table) - (let ((mod (current-module))) - (and (not (assoc-ref table (cons (module-name mod) sym))) - (module-bound? mod sym) - (try-inline (module-ref mod sym) (cdr exp))))) - ((<ghil-env> parent table variables) - (and (not (assq-ref table sym)) - (loop parent))))))) - -(define-inline eq? (x y) - (eq? x y)) - -(define-inline eqv? (x y) - (eqv? x y)) - -(define-inline equal? (x y) - (equal? x y)) - -(define-inline = (x y) - (ee? x y)) - -(define-inline < (x y) - (lt? x y)) - -(define-inline > (x y) - (gt? x y)) - -(define-inline <= (x y) - (le? x y)) - -(define-inline >= (x y) - (ge? x y)) - -(define-inline zero? (x) - (ee? x 0)) - -(define-inline + - () 0 - (x) x - (x y) (add x y) - (x y . rest) (add x (+ y . rest))) - -(define-inline * - () 1 - (x) x - (x y) (mul x y) - (x y . rest) (mul x (* y . rest))) - -(define-inline - - (x) (sub 0 x) - (x y) (sub x y) - (x y . rest) (sub x (+ y . rest))) - -(define-inline 1- - (x) (sub x 1)) - -(define-inline / - (x) (div 1 x) - (x y) (div x y) - (x y . rest) (div x (* y . rest))) - -(define-inline quotient (x y) - (quo x y)) - -(define-inline remainder (x y) - (rem x y)) - -(define-inline modulo (x y) - (mod x y)) - -(define-inline not (x) - (not x)) - -(define-inline pair? (x) - (pair? x)) - -(define-inline cons (x y) - (cons x y)) - -(define-inline car (x) (car x)) -(define-inline cdr (x) (cdr x)) - -(define-inline set-car! (x y) (set-car! x y)) -(define-inline set-cdr! (x y) (set-cdr! x y)) - -(define-inline caar (x) (car (car x))) -(define-inline cadr (x) (car (cdr x))) -(define-inline cdar (x) (cdr (car x))) -(define-inline cddr (x) (cdr (cdr x))) -(define-inline caaar (x) (car (car (car x)))) -(define-inline caadr (x) (car (car (cdr x)))) -(define-inline cadar (x) (car (cdr (car x)))) -(define-inline caddr (x) (car (cdr (cdr x)))) -(define-inline cdaar (x) (cdr (car (car x)))) -(define-inline cdadr (x) (cdr (car (cdr x)))) -(define-inline cddar (x) (cdr (cdr (car x)))) -(define-inline cdddr (x) (cdr (cdr (cdr x)))) -(define-inline caaaar (x) (car (car (car (car x))))) -(define-inline caaadr (x) (car (car (car (cdr x))))) -(define-inline caadar (x) (car (car (cdr (car x))))) -(define-inline caaddr (x) (car (car (cdr (cdr x))))) -(define-inline cadaar (x) (car (cdr (car (car x))))) -(define-inline cadadr (x) (car (cdr (car (cdr x))))) -(define-inline caddar (x) (car (cdr (cdr (car x))))) -(define-inline cadddr (x) (car (cdr (cdr (cdr x))))) -(define-inline cdaaar (x) (cdr (car (car (car x))))) -(define-inline cdaadr (x) (cdr (car (car (cdr x))))) -(define-inline cdadar (x) (cdr (car (cdr (car x))))) -(define-inline cdaddr (x) (cdr (car (cdr (cdr x))))) -(define-inline cddaar (x) (cdr (cdr (car (car x))))) -(define-inline cddadr (x) (cdr (cdr (car (cdr x))))) -(define-inline cdddar (x) (cdr (cdr (cdr (car x))))) -(define-inline cddddr (x) (cdr (cdr (cdr (cdr x))))) - -(define-inline null? (x) - (null? x)) - -(define-inline list? (x) - (list? x)) - -(define-inline cons* - (x) x - (x y) (cons x y) - (x y . rest) (cons x (cons* y . rest))) - -(define-inline acons - (x y z) (cons (cons x y) z)) |