diff options
Diffstat (limited to 'module/language/scheme')
| -rw-r--r-- | module/language/scheme/compile-ghil.scm | 494 | ||||
| -rw-r--r-- | module/language/scheme/compile-tree-il.scm | 63 | ||||
| -rw-r--r-- | module/language/scheme/decompile-tree-il.scm | 26 | ||||
| -rw-r--r-- | module/language/scheme/inline.scm | 205 | ||||
| -rw-r--r-- | module/language/scheme/spec.scm | 45 |
5 files changed, 833 insertions, 0 deletions
diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm new file mode 100644 index 000000000..dc03af6cf --- /dev/null +++ b/module/language/scheme/compile-ghil.scm @@ -0,0 +1,494 @@ +;;; Guile Scheme specification + +;; 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 compile-ghil) + #:use-module (system base pmatch) + #:use-module (system base language) + #:use-module (language ghil) + #:use-module (language scheme inline) + #:use-module (system vm objcode) + #:use-module (ice-9 receive) + #:use-module (ice-9 optargs) + #:use-module (language tree-il) + #:use-module ((system base compile) #:select (syntax-error)) + #:export (compile-ghil translate-1 + *translate-table* define-scheme-translator)) + +;;; environment := #f +;;; | MODULE +;;; | COMPILE-ENV +;;; compile-env := (MODULE LEXICALS|GHIL-ENV . EXTERNALS) +(define (cenv-module env) + (cond ((not env) #f) + ((module? env) env) + ((and (pair? env) (module? (car env))) (car env)) + (else (error "bad environment" env)))) + +(define (cenv-ghil-env env) + (cond ((not env) (make-ghil-toplevel-env)) + ((module? env) (make-ghil-toplevel-env)) + ((pair? env) + (if (struct? (cadr env)) + (cadr env) + (ghil-env-dereify (cadr env)))) + (else (error "bad environment" env)))) + +(define (cenv-externals env) + (cond ((not env) '()) + ((module? env) '()) + ((pair? env) (cddr env)) + (else (error "bad environment" env)))) + +(define (make-cenv module lexicals externals) + (cons module (cons lexicals externals))) + + + +(define (compile-ghil x e opts) + (save-module-excursion + (lambda () + (and=> (cenv-module e) set-current-module) + (call-with-ghil-environment (cenv-ghil-env e) '() + (lambda (env vars) + (let ((x (tree-il->scheme + (sc-expand x 'c '(compile load eval))))) + (let ((x (make-ghil-lambda env #f vars #f '() + (translate-1 env #f x))) + (cenv (make-cenv (current-module) + (ghil-env-parent env) + (if e (cenv-externals e) '())))) + (values x cenv cenv)))))))) + + +;;; +;;; Translator +;;; + +(define *forbidden-primitives* + ;; Guile's `procedure->macro' family is evil because it crosses the + ;; compilation boundary. One solution might be to evaluate calls to + ;; `procedure->memoizing-macro' at compilation time, but it may be more + ;; compicated than that. + '(procedure->syntax procedure->macro)) + +;; Looks up transformers relative to the current module at +;; compilation-time. See also the discussion of ghil-lookup in ghil.scm. +;; +;; FIXME shadowing lexicals? +(define (lookup-transformer head retrans) + (define (module-ref/safe mod sym) + (and mod + (and=> (module-variable mod sym) + (lambda (var) + ;; unbound vars can happen if the module + ;; definition forward-declared them + (and (variable-bound? var) (variable-ref var)))))) + (let* ((mod (current-module)) + (val (cond + ((symbol? head) (module-ref/safe mod head)) + ((pmatch head + ((@ ,modname ,sym) + (module-ref/safe (resolve-interface modname) sym)) + ((@@ ,modname ,sym) + (module-ref/safe (resolve-module modname) sym)) + (else #f))) + (else #f)))) + (cond + ((hashq-ref *translate-table* val)) + + ((macro? val) + (syntax-error #f "unknown kind of macro" head)) + + (else #f)))) + +(define (translate-1 e l x) + (let ((l (or l (location x)))) + (define (retrans x) (translate-1 e #f x)) + (define (retrans/loc x) (translate-1 e (or (location x) l) x)) + (cond ((pair? x) + (let ((head (car x)) (tail (cdr x))) + (cond + ((lookup-transformer head retrans/loc) + => (lambda (t) (t e l x))) + + ;; FIXME: lexical/module overrides of forbidden primitives + ((memq head *forbidden-primitives*) + (syntax-error l (format #f "`~a' is forbidden" head) + (cons head tail))) + + (else + (let ((tail (map retrans tail))) + (or (and (symbol? head) + (try-inline-with-env e l (cons head tail))) + (make-ghil-call e l (retrans head) tail))))))) + + ((symbol? x) + (make-ghil-ref e l (ghil-var-for-ref! e x))) + + ;; fixme: non-self-quoting objects like #<foo> + (else + (make-ghil-quote e l x))))) + +(define (valid-bindings? bindings . it-is-for-do) + (define (valid-binding? b) + (pmatch b + ((,sym ,var) (guard (symbol? sym)) #t) + ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t) + (else #f))) + (and (list? bindings) (and-map valid-binding? bindings))) + +(define *translate-table* (make-hash-table)) + +(define-macro (-> form) + `(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form))) + +(define-macro (define-scheme-translator sym . clauses) + `(hashq-set! (@ (language scheme compile-ghil) *translate-table*) + (module-ref (current-module) ',sym) + (lambda (e l exp) + (define (retrans x) + ((@ (language scheme compile-ghil) translate-1) + e + (or ((@@ (language scheme compile-ghil) location) x) l) + x)) + (define syntax-error (@ (system base compile) syntax-error)) + (pmatch (cdr exp) + ,@clauses + ,@(if (assq 'else clauses) '() + `((else + (syntax-error l (format #f "bad ~A" ',sym) exp)))))))) + +(define-scheme-translator quote + ;; (quote OBJ) + ((,obj) + (-> (quote obj)))) + +(define-scheme-translator quasiquote + ;; (quasiquote OBJ) + ((,obj) + (-> (quasiquote (trans-quasiquote e l obj 0))))) + +(define-scheme-translator define + ;; (define NAME VAL) + ((,name ,val) (guard (symbol? name) + (ghil-toplevel-env? (ghil-env-parent e))) + (-> (define (ghil-var-define! (ghil-env-parent e) name) + (maybe-name-value! (retrans val) name)))) + ;; (define (NAME FORMALS...) BODY...) + (((,name . ,formals) . ,body) (guard (symbol? name)) + ;; -> (define NAME (lambda FORMALS BODY...)) + (retrans `(define ,name (lambda ,formals ,@body))))) + +(define-scheme-translator set! + ;; (set! NAME VAL) + ((,name ,val) (guard (symbol? name)) + (-> (set (ghil-var-for-set! e name) (retrans val)))) + + ;; FIXME: Would be nice to verify the values of @ and @@ relative + ;; to imported modules... + (((@ ,modname ,name) ,val) (guard (symbol? name) + (list? modname) + (and-map symbol? modname) + (not (ghil-var-is-bound? e '@))) + (-> (set (ghil-var-at-module! e modname name #t) (retrans val)))) + + (((@@ ,modname ,name) ,val) (guard (symbol? name) + (list? modname) + (and-map symbol? modname) + (not (ghil-var-is-bound? e '@@))) + (-> (set (ghil-var-at-module! e modname name #f) (retrans val)))) + + ;; (set! (NAME ARGS...) VAL) + (((,name . ,args) ,val) (guard (symbol? name)) + ;; -> ((setter NAME) ARGS... VAL) + (retrans `((setter ,name) . (,@args ,val))))) + +(define-scheme-translator if + ;; (if TEST THEN [ELSE]) + ((,test ,then) + (-> (if (retrans test) (retrans then) (retrans '(begin))))) + ((,test ,then ,else) + (-> (if (retrans test) (retrans then) (retrans else))))) + +(define-scheme-translator and + ;; (and EXPS...) + (,tail + (-> (and (map retrans tail))))) + +(define-scheme-translator or + ;; (or EXPS...) + (,tail + (-> (or (map retrans tail))))) + +(define-scheme-translator begin + ;; (begin EXPS...) + (,tail + (-> (begin (map retrans tail))))) + +(define-scheme-translator let + ;; (let NAME ((SYM VAL) ...) BODY...) + ((,name ,bindings . ,body) (guard (symbol? name) + (valid-bindings? bindings)) + ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...)) + (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body))) + (,name ,@(map cadr bindings))))) + + ;; (let () BODY...) + ((() . ,body) + ;; Note: this differs from `begin' + (-> (begin (list (trans-body e l body))))) + + ;; (let ((SYM VAL) ...) BODY...) + ((,bindings . ,body) (guard (valid-bindings? bindings)) + (let ((vals (map (lambda (b) + (maybe-name-value! (retrans (cadr b)) (car b))) + bindings))) + (call-with-ghil-bindings e (map car bindings) + (lambda (vars) + (-> (bind vars vals (trans-body e l body)))))))) + +(define-scheme-translator let* + ;; (let* ((SYM VAL) ...) BODY...) + ((() . ,body) + (retrans `(let () ,@body))) + ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym)) + (retrans `(let ((,sym ,val)) (let* ,rest ,@body))))) + +(define-scheme-translator letrec + ;; (letrec ((SYM VAL) ...) BODY...) + ((,bindings . ,body) (guard (valid-bindings? bindings)) + (call-with-ghil-bindings e (map car bindings) + (lambda (vars) + (let ((vals (map (lambda (b) + (maybe-name-value! + (retrans (cadr b)) (car b))) + bindings))) + (-> (bind vars vals (trans-body e l body)))))))) + +(define-scheme-translator cond + ;; (cond (CLAUSE BODY...) ...) + (() (retrans '(begin))) + (((else . ,body)) (retrans `(begin ,@body))) + (((,test) . ,rest) (retrans `(or ,test (cond ,@rest)))) + (((,test => ,proc) . ,rest) + ;; FIXME hygiene! + (retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest))))) + (((,test . ,body) . ,rest) + (retrans `(if ,test (begin ,@body) (cond ,@rest))))) + +(define-scheme-translator case + ;; (case EXP ((KEY...) BODY...) ...) + ((,exp . ,clauses) + (retrans + ;; FIXME hygiene! + `(let ((_t ,exp)) + ,(let loop ((ls clauses)) + (cond ((null? ls) '(begin)) + ((eq? (caar ls) 'else) `(begin ,@(cdar ls))) + (else `(if (memv _t ',(caar ls)) + (begin ,@(cdar ls)) + ,(loop (cdr ls)))))))))) + +(define-scheme-translator do + ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...) + ((,bindings (,test . ,result) . ,body) + (let ((sym (map car bindings)) + (val (map cadr bindings)) + (update (map cddr bindings))) + (define (next s x) (if (pair? x) (car x) s)) + (retrans + ;; FIXME hygiene! + `(letrec ((_l (lambda ,sym + (if ,test + (begin ,@result) + (begin ,@body + (_l ,@(map next sym update))))))) + (_l ,@val)))))) + +(define-scheme-translator lambda + ;; (lambda FORMALS BODY...) + ((,formals . ,body) + (receive (syms rest) (parse-formals formals) + (call-with-ghil-environment e syms + (lambda (e vars) + (receive (meta body) (parse-lambda-meta body) + (-> (lambda vars rest meta (trans-body e l body))))))))) + +(define-scheme-translator delay + ;; FIXME not hygienic + ((,expr) + (retrans `(make-promise (lambda () ,expr))))) + +(define-scheme-translator @ + ((,modname ,sym) + (-> (ref (ghil-var-at-module! e modname sym #t))))) + +(define-scheme-translator @@ + ((,modname ,sym) + (-> (ref (ghil-var-at-module! e modname sym #f))))) + +(define *the-compile-toplevel-symbol* 'compile-toplevel) +(define-scheme-translator eval-when + ((,when . ,body) (guard (list? when) (and-map symbol? when)) + (if (memq 'compile when) + (primitive-eval `(begin . ,body))) + (if (memq 'load when) + (retrans `(begin . ,body)) + (retrans `(begin))))) + +(define-scheme-translator apply + ;; FIXME: not hygienic, relies on @apply not being shadowed + (,args (retrans `(@apply ,@args)))) + +;; FIXME: we could add inliners for `list' and `vector' + +(define-scheme-translator @apply + ((,proc ,arg1 . ,args) + (let ((args (cons (retrans arg1) (map retrans args)))) + (cond ((and (symbol? proc) + (not (ghil-var-is-bound? e proc)) + (and=> (module-variable (current-module) proc) + (lambda (var) + (and (variable-bound? var) + (lookup-apply-transformer (variable-ref var)))))) + ;; that is, a variable, not part of this compilation + ;; unit, but defined in the toplevel environment, and has + ;; an apply transformer registered + => (lambda (t) (t e l args))) + (else + (-> (inline 'apply (cons (retrans proc) args)))))))) + +(define-scheme-translator call-with-values + ;; FIXME: not hygienic, relies on @call-with-values not being shadowed + ((,producer ,consumer) + (retrans `(@call-with-values ,producer ,consumer))) + (else #f)) + +(define-scheme-translator @call-with-values + ((,producer ,consumer) + (-> (mv-call (retrans producer) (retrans consumer))))) + +(define-scheme-translator call-with-current-continuation + ;; FIXME: not hygienic, relies on @call-with-current-continuation + ;; not being shadowed + ((,proc) + (retrans `(@call-with-current-continuation ,proc))) + (else #f)) + +(define-scheme-translator @call-with-current-continuation + ((,proc) + (-> (inline 'call/cc (list (retrans proc)))))) + +(define-scheme-translator receive + ((,formals ,producer-exp . ,body) + ;; Lovely, self-referential usage. Not strictly necessary, the + ;; macro would do the trick; but it's good to test the mv-bind + ;; code. + (receive (syms rest) (parse-formals formals) + (let ((producer (retrans `(lambda () ,producer-exp)))) + (call-with-ghil-bindings e syms + (lambda (vars) + (-> (mv-bind producer vars rest + (trans-body e l body))))))))) + +(define-scheme-translator values + ((,x) (retrans x)) + (,args + (-> (values (map retrans args))))) + +(define (lookup-apply-transformer proc) + (cond ((eq? proc values) + (lambda (e l args) + (-> (values* args)))) + (else #f))) + +(define (trans-quasiquote e l x level) + (cond ((not (pair? x)) x) + ((memq (car x) '(unquote unquote-splicing)) + (let ((l (location x))) + (pmatch (cdr x) + ((,obj) + (cond + ((zero? level) + (if (eq? (car x) 'unquote) + (-> (unquote (translate-1 e l obj))) + (-> (unquote-splicing (translate-1 e l obj))))) + (else + (list (car x) (trans-quasiquote e l obj (1- level)))))) + (else (syntax-error l (format #f "bad ~A" (car x)) x))))) + ((eq? (car x) 'quasiquote) + (let ((l (location x))) + (pmatch (cdr x) + ((,obj) (list 'quasiquote (trans-quasiquote e l obj (1+ level)))) + (else (syntax-error l (format #f "bad ~A" (car x)) x))))) + (else (cons (trans-quasiquote e l (car x) level) + (trans-quasiquote e l (cdr x) level))))) + +(define (trans-body e l body) + (define (define->binding df) + (pmatch (cdr df) + ((,name ,val) (guard (symbol? name)) (list name val)) + (((,name . ,formals) . ,body) (guard (symbol? name)) + (list name `(lambda ,formals ,@body))) + (else (syntax-error (location df) "bad define" df)))) + ;; main + (let loop ((ls body) (ds '())) + (pmatch ls + (() (syntax-error l "bad body" body)) + (((define . _) . _) + (loop (cdr ls) (cons (car ls) ds))) + (else + (if (null? ds) + (translate-1 e l `(begin ,@ls)) + (translate-1 e l `(letrec ,(map define->binding ds) ,@ls))))))) + +(define (parse-formals formals) + (cond + ;; (lambda x ...) + ((symbol? formals) (values (list formals) #t)) + ;; (lambda (x y z) ...) + ((list? formals) (values formals #f)) + ;; (lambda (x y . z) ...) + ((pair? formals) + (let loop ((l formals) (v '())) + (if (pair? l) + (loop (cdr l) (cons (car l) v)) + (values (reverse! (cons l v)) #t)))) + (else (syntax-error (location formals) "bad formals" formals)))) + +(define (parse-lambda-meta body) + (cond ((or (null? body) (null? (cdr body))) (values '() body)) + ((string? (car body)) + (values `((documentation . ,(car body))) (cdr body))) + (else (values '() body)))) + +(define (maybe-name-value! val name) + (cond + ((ghil-lambda? val) + (if (not (assq-ref (ghil-lambda-meta val) 'name)) + (set! (ghil-lambda-meta val) + (acons 'name name (ghil-lambda-meta val)))))) + val) + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (not (null? props)) + props)))) diff --git a/module/language/scheme/compile-tree-il.scm b/module/language/scheme/compile-tree-il.scm new file mode 100644 index 000000000..4ac33d77e --- /dev/null +++ b/module/language/scheme/compile-tree-il.scm @@ -0,0 +1,63 @@ +;;; Guile Scheme specification + +;; 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 compile-tree-il) + #:use-module (language tree-il) + #:export (compile-tree-il)) + +;;; environment := #f +;;; | MODULE +;;; | COMPILE-ENV +;;; compile-env := (MODULE LEXICALS . EXTERNALS) +(define (cenv-module env) + (cond ((not env) #f) + ((module? env) env) + ((and (pair? env) (module? (car env))) (car env)) + (else (error "bad environment" env)))) + +(define (cenv-lexicals env) + (cond ((not env) '()) + ((module? env) '()) + ((pair? env) (cadr env)) + (else (error "bad environment" env)))) + +(define (cenv-externals env) + (cond ((not env) '()) + ((module? env) '()) + ((pair? env) (cddr env)) + (else (error "bad environment" env)))) + +(define (make-cenv module lexicals externals) + (cons module (cons lexicals externals))) + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (not (null? props)) + props)))) + +(define (compile-tree-il x e opts) + (save-module-excursion + (lambda () + (and=> (cenv-module e) set-current-module) + (let* ((x (sc-expand x 'c '(compile load eval))) + (cenv (make-cenv (current-module) + (cenv-lexicals e) (cenv-externals e)))) + (values x cenv cenv))))) diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm new file mode 100644 index 000000000..9243f4e6a --- /dev/null +++ b/module/language/scheme/decompile-tree-il.scm @@ -0,0 +1,26 @@ +;;; Guile VM code converters + +;; Copyright (C) 2001,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 scheme decompile-tree-il) + #:use-module (language tree-il) + #:export (decompile-tree-il)) + +(define (decompile-tree-il x env opts) + (values (tree-il->scheme x) env)) diff --git a/module/language/scheme/inline.scm b/module/language/scheme/inline.scm new file mode 100644 index 000000000..b178b2adc --- /dev/null +++ b/module/language/scheme/inline.scm @@ -0,0 +1,205 @@ +;;; 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)) diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm new file mode 100644 index 000000000..df618581f --- /dev/null +++ b/module/language/scheme/spec.scm @@ -0,0 +1,45 @@ +;;; Guile Scheme specification + +;; Copyright (C) 2001, 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 scheme spec) + #:use-module (system base language) + #:use-module (language scheme compile-tree-il) + #:use-module (language scheme decompile-tree-il) + #:export (scheme)) + +;;; +;;; Reader +;;; + +(read-enable 'positions) + +;;; +;;; Language definition +;;; + +(define-language scheme + #:title "Guile Scheme" + #:version "0.5" + #:reader read + #:compilers `((tree-il . ,compile-tree-il)) + #:decompilers `((tree-il . ,decompile-tree-il)) + #:evaluator (lambda (x module) (primitive-eval x)) + #:printer write + ) |