mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 04:40:29 +02:00
118 lines
4 KiB
Scheme
118 lines
4 KiB
Scheme
(define-module (language js-il)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (srfi srfi-9 gnu)
|
|
#:use-module (ice-9 match)
|
|
#:export (make-program program
|
|
make-function function
|
|
make-params params
|
|
make-continuation continuation
|
|
make-local local
|
|
make-continue continue
|
|
make-const const
|
|
make-primcall primcall
|
|
make-call call
|
|
make-closure closure
|
|
make-branch branch
|
|
make-id id
|
|
make-kid kid
|
|
make-seq seq
|
|
make-prompt prompt
|
|
))
|
|
|
|
;; Copied from (language cps)
|
|
;; Should put in a srfi 99 module
|
|
(define-syntax define-record-type*
|
|
(lambda (x)
|
|
(define (id-append ctx . syms)
|
|
(datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
|
|
(syntax-case x ()
|
|
((_ name field ...)
|
|
(and (identifier? #'name) (and-map identifier? #'(field ...)))
|
|
(with-syntax ((cons (id-append #'name #'make- #'name))
|
|
(pred (id-append #'name #'name #'?))
|
|
((getter ...) (map (lambda (f)
|
|
(id-append f #'name #'- f))
|
|
#'(field ...))))
|
|
#'(define-record-type name
|
|
(cons field ...)
|
|
pred
|
|
(field getter)
|
|
...))))))
|
|
|
|
;; TODO: add type predicates to fields so I can only construct valid
|
|
;; objects
|
|
(define-syntax-rule (define-js-type name field ...)
|
|
(begin
|
|
(define-record-type* name field ...)
|
|
(set-record-type-printer! name print-js)))
|
|
|
|
(define (print-js exp port)
|
|
(format port "#<js-il ~S>" (unparse-js exp)))
|
|
|
|
(define-js-type program body)
|
|
(define-js-type function self tail clauses)
|
|
(define-js-type params self req opt rest kw allow-other-keys?)
|
|
(define-js-type continuation params body)
|
|
(define-js-type local bindings body) ; local scope
|
|
(define-js-type continue cont args)
|
|
(define-js-type const value)
|
|
(define-js-type primcall name args)
|
|
(define-js-type call name k args)
|
|
(define-js-type closure label num-free)
|
|
(define-js-type branch test consequence alternate)
|
|
(define-js-type id name)
|
|
(define-js-type kid name)
|
|
(define-js-type seq body)
|
|
(define-js-type prompt escape? tag handler)
|
|
|
|
(define (unparse-js exp)
|
|
(match exp
|
|
(($ program body)
|
|
`(program . ,(map (match-lambda
|
|
((($ kid k) . fun)
|
|
(cons k (unparse-js fun))))
|
|
body)))
|
|
(($ continuation params body)
|
|
`(continuation ,(map unparse-js params) ,(unparse-js body)))
|
|
(($ function ($ id self) ($ kid tail) clauses)
|
|
`(function ,self
|
|
,tail
|
|
,@(map (match-lambda
|
|
((($ kid id) params kont)
|
|
(list id
|
|
(unparse-js params)
|
|
(unparse-js kont))))
|
|
clauses)))
|
|
(($ params ($ id self) req opt rest kws allow-other-keys?)
|
|
`(params ,self
|
|
,(map unparse-js req)
|
|
,(map unparse-js opt)
|
|
,(and rest (unparse-js rest))
|
|
,(map (match-lambda
|
|
((kw ($ id name) ($ id sym))
|
|
(list kw name sym)))
|
|
kws)
|
|
,allow-other-keys?))
|
|
(($ local bindings body)
|
|
`(local ,(map (match-lambda
|
|
((a . d)
|
|
(cons (unparse-js a)
|
|
(unparse-js d))))
|
|
bindings)
|
|
,(unparse-js body)))
|
|
(($ continue ($ kid k) args)
|
|
`(continue ,k ,(map unparse-js args)))
|
|
(($ branch test then else)
|
|
`(if ,(unparse-js test) ,(unparse-js then) ,(unparse-js else)))
|
|
(($ const c)
|
|
`(const ,c))
|
|
(($ primcall name args)
|
|
`(primcall ,name ,(map unparse-js args)))
|
|
(($ call ($ id name) ($ kid k) args)
|
|
`(call ,name ,k ,(map unparse-js args)))
|
|
(($ closure ($ kid label) nfree)
|
|
`(closure ,label ,nfree))
|
|
(($ id name)
|
|
`(id . ,name))
|
|
(($ kid name)
|
|
`(kid . ,name))))
|