ikarus/scheme/psyntax.builders.ss

163 lines
6.4 KiB
Scheme
Raw Normal View History

;;; Copyright (c) 2006, 2007 Abdulaziz Ghuloum and Kent Dybvig
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a
;;; copy of this software and associated documentation files (the "Software"),
;;; to deal in the Software without restriction, including without limitation
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;; and/or sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(library (psyntax builders)
(export build-lexical-assignment build-global-reference
build-application build-conditional build-lexical-reference
build-global-assignment build-global-definition build-lambda
build-case-lambda build-let build-primref build-foreign-call
build-data build-sequence build-void build-letrec build-letrec*
build-global-define build-library-letrec*)
(import (rnrs) (psyntax compat) (psyntax config))
(define (build-global-define x)
(if-wants-global-defines
`(define ,x '#f)
(build-void)))
(define build-application
(lambda (ae fun-exp arg-exps)
(if ae
`(annotated-call ,ae ,fun-exp . ,arg-exps)
(cons fun-exp arg-exps))))
(define-syntax build-conditional
(syntax-rules ()
((_ ae test-exp then-exp else-exp)
`(if ,test-exp ,then-exp ,else-exp))))
(define-syntax build-lexical-reference
(syntax-rules ()
((_ ae var) var)))
(define-syntax build-lexical-assignment
(syntax-rules ()
((_ ae var exp) `(set! ,var ,exp))))
(define-syntax build-global-reference
(syntax-rules ()
((_ ae var) var)))
(define-syntax build-global-assignment
(syntax-rules ()
((_ ae var exp) `(set! ,var ,exp))))
(define-syntax build-global-definition
(syntax-rules ()
((_ ae var exp) (build-global-assignment ae var exp))))
(define build-lambda
(lambda (ae vars exp)
(if-wants-case-lambda
(build-case-lambda ae (list vars) (list exp))
`(lambda ,vars ,exp))))
(define build-case-lambda
(if-wants-case-lambda
(lambda (ae vars* exp*)
(if ae
`(annotated-case-lambda ,ae . ,(map list vars* exp*))
`(case-lambda . ,(map list vars* exp*))))
(lambda (ae vars* exp*)
(define (build-error ae)
(build-application ae
(build-primref ae 'error)
(list (build-data ae 'apply)
(build-data ae "invalid arg count"))))
(define (build-pred ae n vars)
(let-values (((count pred)
(let f ((vars vars) (count 0))
(cond
((pair? vars) (f (cdr vars) (+ count 1)))
((null? vars) (values count '=))
(else (values count '>=))))))
(build-application ae (build-primref ae pred)
(list (build-lexical-reference ae n)
(build-data ae count)))))
(define (build-apply ae g vars exp)
(build-application ae (build-primref ae 'apply)
(list (build-lambda ae vars exp)
(build-lexical-reference ae g))))
(define (expand-case-lambda ae vars exp*)
(let ((g (gensym)) (n (gensym)))
`(lambda ,g
,(build-let ae
(list n) (list (build-application ae
(build-primref ae 'length)
(list (build-lexical-reference ae g))))
(let f ((vars* vars*) (exp* exp*))
(if (null? vars*)
(build-error ae)
(build-conditional ae
(build-pred ae n (car vars*))
(build-apply ae g (car vars*) (car exp*))
(f (cdr vars*) (cdr exp*)))))))))
(if (= (length exp*) 1)
(build-lambda ae (car vars*) (car exp*))
(expand-case-lambda ae vars* exp*)))))
(define build-let
(lambda (ae lhs* rhs* body)
(build-application ae (build-lambda ae lhs* body) rhs*)))
(define-syntax build-primref
(syntax-rules ()
((_ ae name) (build-primref ae 1 name))
((_ ae level name) `(primitive ,name))))
(define-syntax build-foreign-call
(syntax-rules ()
((_ ae name arg*) `(foreign-call ,name . ,arg*))))
(define-syntax build-data
(syntax-rules ()
((_ ae exp) `',exp)))
(define build-sequence
(lambda (ae exps)
(let loop ((exps exps))
(if (null? (cdr exps))
(car exps)
(if (equal? (car exps) (build-void))
(loop (cdr exps))
`(begin ,@exps))))))
(define build-void
(lambda () '((primitive void))))
(define build-letrec
(lambda (ae vars val-exps body-exp)
(if (null? vars) body-exp `(letrec ,(map list vars val-exps) ,body-exp))))
(define build-letrec*
(lambda (ae vars val-exps body-exp)
(cond
((null? vars) body-exp)
(else
(if-wants-letrec*
`(letrec* ,(map list vars val-exps) ,body-exp)
(build-let ae vars (map (lambda (x) (build-data ae #f)) vars)
(build-sequence ae
(append
(map (lambda (lhs rhs)
(build-lexical-assignment ae lhs rhs))
vars val-exps)
(list body-exp)))))))))
(define build-library-letrec*
(lambda (ae top? vars locs val-exps body-exp)
(if-wants-library-letrec*
`(library-letrec* ,(map list vars locs val-exps) ,body-exp)
(build-letrec* ae vars val-exps
(if top?
body-exp
(build-sequence ae
(cons body-exp
(map (lambda (var loc)
(build-global-assignment ae loc var))
vars locs))))))))
)