X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/3b91e017e32e1fb6b911f456c61aea6386075095..ea6b18e82f3ac2122d07c80bc0f320ea839a25b6:/module/language/glil.scm diff --git a/module/language/glil.scm b/module/language/glil.scm index 01b680194..9c238547d 100644 --- a/module/language/glil.scm +++ b/module/language/glil.scm @@ -1,21 +1,20 @@ ;;; Guile Low Intermediate Language -;; Copyright (C) 2001 Free Software Foundation, Inc. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program 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 General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Copyright (C) 2001, 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: @@ -25,8 +24,19 @@ #:use-module ((srfi srfi-1) #:select (fold)) #:export ( make-glil-program glil-program? - glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts - glil-program-meta glil-program-body glil-program-closure-level + glil-program-meta glil-program-body + + make-glil-std-prelude glil-std-prelude? + glil-std-prelude-nreq glil-std-prelude-nlocs glil-std-prelude-else-label + + make-glil-opt-prelude glil-opt-prelude? + glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest + glil-opt-prelude-nlocs glil-opt-prelude-else-label + + make-glil-kw-prelude glil-kw-prelude? + glil-kw-prelude-nreq glil-kw-prelude-nopt glil-kw-prelude-kw + glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest + glil-kw-prelude-nlocs glil-kw-prelude-else-label make-glil-bind glil-bind? glil-bind-vars @@ -44,14 +54,8 @@ make-glil-const glil-const? glil-const-obj - make-glil-argument glil-argument? - glil-argument-op glil-argument-index - - make-glil-local glil-local? - glil-local-op glil-local-index - - make-glil-external glil-external? - glil-external-op glil-external-depth glil-external-index + make-glil-lexical glil-lexical? + glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index make-glil-toplevel glil-toplevel? glil-toplevel-op glil-toplevel-name @@ -71,6 +75,8 @@ make-glil-mv-call glil-mv-call? glil-mv-call-nargs glil-mv-call-ra + make-glil-prompt glil-prompt? glil-prompt-label glil-prompt-escape-only? + parse-glil unparse-glil)) (define (print-glil x port) @@ -78,7 +84,10 @@ (define-type ( #:printer print-glil) ;; Meta operations - ( nargs nrest nlocs nexts meta body (closure-level #f)) + ( meta body) + ( nreq nlocs else-label) + ( nreq nopt rest nlocs else-label) + ( nreq nopt rest kw allow-other-keys? nlocs else-label) ( vars) ( vars rest) () @@ -87,61 +96,57 @@ () ( obj) ;; Variables - ( op index) - ( op index) - ( op depth index) + ( local? boxed? op index) ( op name) ( op mod name public?) ;; Controls ( label) ( inst label) ( inst nargs) - ( nargs ra)) - -(define (compute-closure-level body) - (fold (lambda (x ret) - (record-case x - (( closure-level) (max ret closure-level)) - (( depth) (max ret depth)) - (else ret))) - 0 body)) - -(define %make-glil-program make-glil-program) -(define (make-glil-program . args) - (let ((prog (apply %make-glil-program args))) - (if (not (glil-program-closure-level prog)) - (set! (glil-program-closure-level prog) - (compute-closure-level (glil-program-body prog)))) - prog)) + ( nargs ra) + ( label escape-only?)) + (define (parse-glil x) (pmatch x - ((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body) - (make-glil-program nargs nrest nlocs nexts meta (map parse-glil body))) + ((program ,meta . ,body) + (make-glil-program meta (map parse-glil body))) + ((std-prelude ,nreq ,nlocs ,else-label) + (make-glil-std-prelude nreq nlocs else-label)) + ((opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label) + (make-glil-opt-prelude nreq nopt rest nlocs else-label)) + ((kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label) + (make-glil-kw-prelude nreq nopt rest kw allow-other-keys? nlocs else-label)) ((bind . ,vars) (make-glil-bind vars)) ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest)) ((unbind) (make-glil-unbind)) ((source ,props) (make-glil-source props)) ((void) (make-glil-void)) ((const ,obj) (make-glil-const obj)) - ((argument ,op ,index) (make-glil-argument op index)) - ((local ,op ,index) (make-glil-local op index)) - ((external ,op ,depth ,index) (make-glil-external op depth index)) + ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index)) ((toplevel ,op ,name) (make-glil-toplevel op name)) ((module public ,op ,mod ,name) (make-glil-module op mod name #t)) ((module private ,op ,mod ,name) (make-glil-module op mod name #f)) - ((label ,label) (make-label ,label)) + ((label ,label) (make-glil-label label)) ((branch ,inst ,label) (make-glil-branch inst label)) ((call ,inst ,nargs) (make-glil-call inst nargs)) ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra)) + ((prompt ,label ,escape-only?) + (make-glil-prompt label escape-only?)) (else (error "invalid glil" x)))) (define (unparse-glil glil) (record-case glil ;; meta - (( nargs nrest nlocs nexts meta body) - `(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body))) + (( meta body) + `(program ,meta ,@(map unparse-glil body))) + (( nreq nlocs else-label) + `(std-prelude ,nreq ,nlocs ,else-label)) + (( nreq nopt rest nlocs else-label) + `(opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label)) + (( nreq nopt rest kw allow-other-keys? nlocs else-label) + `(kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label)) (( vars) `(bind ,@vars)) (( vars rest) `(mv-bind ,vars ,rest)) (() `(unbind)) @@ -150,12 +155,8 @@ (() `(void)) (( obj) `(const ,obj)) ;; variables - (( op index) - `(argument ,op ,index)) - (( op index) - `(local ,op ,index)) - (( op depth index) - `(external ,op ,depth ,index)) + (( local? boxed? op index) + `(lexical ,local? ,boxed? ,op ,index)) (( op name) `(toplevel ,op ,name)) (( op mod name public?) @@ -164,4 +165,6 @@ (( label) `(label ,label)) (( inst label) `(branch ,inst ,label)) (( inst nargs) `(call ,inst ,nargs)) - (( nargs ra) `(mv-call ,nargs ,ra)))) + (( nargs ra) `(mv-call ,nargs ,ra)) + (( label escape-only?) + `(prompt ,label escape-only?))))