mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
d4ef33f6cf
* module/language/javascript.scm (assign): new js-type (print-exp, unparse-js): Handle case. * module/language/javascript/simplify.scm (flatten-blocks): Handle case.
58 lines
1.8 KiB
Scheme
58 lines
1.8 KiB
Scheme
(define-module (language javascript simplify)
|
|
#:use-module (language javascript)
|
|
#:use-module (ice-9 match)
|
|
#:use-module ((srfi srfi-1) #:select (fold-right))
|
|
#:export (flatten-blocks))
|
|
|
|
(define (flatten-blocks exp)
|
|
(define (flatten exp rest)
|
|
(match exp
|
|
(($ block statements)
|
|
(fold-right flatten rest statements))
|
|
(else
|
|
(cons (flatten-exp exp) rest))))
|
|
(define (flatten-block stmts)
|
|
(fold-right flatten '() stmts))
|
|
(define (flatten-exp exp)
|
|
(match exp
|
|
(($ assign id exp)
|
|
(make-assign id (flatten-exp exp)))
|
|
(($ const c) exp)
|
|
(($ new exp)
|
|
(make-new (flatten-exp exp)))
|
|
(($ return exp)
|
|
(make-return (flatten-exp exp)))
|
|
(($ id name) exp)
|
|
(($ var id exp)
|
|
(make-var id (flatten-exp exp)))
|
|
(($ refine id field)
|
|
(make-refine (flatten-exp id)
|
|
(flatten-exp field)))
|
|
(($ binop op arg1 arg2)
|
|
(make-binop op
|
|
(flatten-exp arg1)
|
|
(flatten-exp arg2)))
|
|
(($ function args body)
|
|
(make-function args (flatten-block body)))
|
|
(($ block statements)
|
|
(maybe-make-block (flatten-block statements)))
|
|
(($ branch test then else)
|
|
(make-branch (flatten-exp test)
|
|
(flatten-block then)
|
|
(flatten-block else)))
|
|
(($ call function args)
|
|
(make-call (flatten-exp function)
|
|
(map flatten-exp args)))
|
|
|
|
(($ ternary test then else)
|
|
(make-ternary (flatten-exp test)
|
|
(flatten-exp then)
|
|
(flatten-exp else)))
|
|
(($ prefix op exp)
|
|
(make-prefix op (flatten-exp exp)))
|
|
))
|
|
(define (maybe-make-block exp)
|
|
(match exp
|
|
((exp) exp)
|
|
(exps (make-block exps))))
|
|
(maybe-make-block (flatten exp '())))
|