compile-tree-il.scm 23 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577
  1. ;;; ECMAScript for Guile
  2. ;; Copyright (C) 2009, 2011, 2016 Free Software Foundation, Inc.
  3. ;;;; This library is free software; you can redistribute it and/or
  4. ;;;; modify it under the terms of the GNU Lesser General Public
  5. ;;;; License as published by the Free Software Foundation; either
  6. ;;;; version 3 of the License, or (at your option) any later version.
  7. ;;;;
  8. ;;;; This library is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. ;;;; Lesser General Public License for more details.
  12. ;;;;
  13. ;;;; You should have received a copy of the GNU Lesser General Public
  14. ;;;; License along with this library; if not, write to the Free Software
  15. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;; Code:
  17. (define-module (language ecmascript compile-tree-il)
  18. #:use-module (language tree-il)
  19. #:use-module (ice-9 receive)
  20. #:use-module (system base pmatch)
  21. #:use-module (srfi srfi-1)
  22. #:export (compile-tree-il))
  23. (define-syntax-rule (-> (type arg ...))
  24. `(type ,arg ...))
  25. (define-syntax-rule (@implv sym)
  26. (-> (@ '(language ecmascript impl) 'sym)))
  27. (define-syntax-rule (@impl sym arg ...)
  28. (-> (call (@implv sym) arg ...)))
  29. (define (empty-lexical-environment)
  30. '())
  31. (define (econs name gensym env)
  32. (acons name (-> (lexical name gensym)) env))
  33. (define (lookup name env)
  34. (or (assq-ref env name)
  35. (-> (toplevel name))))
  36. (define (compile-tree-il exp env opts)
  37. (values
  38. (parse-tree-il
  39. (-> (begin (@impl js-init)
  40. (comp exp (empty-lexical-environment)))))
  41. env
  42. env))
  43. (define (location x)
  44. (and (pair? x)
  45. (let ((props (source-properties x)))
  46. (and (not (null? props))
  47. props))))
  48. ;; for emacs:
  49. ;; (put 'pmatch/source 'scheme-indent-function 1)
  50. (define-syntax-rule (pmatch/source x clause ...)
  51. (let ((x x))
  52. (let ((res (pmatch x
  53. clause ...)))
  54. (let ((loc (location x)))
  55. (if loc
  56. (set-source-properties! res (location x))))
  57. res)))
  58. (define current-return-tag (make-parameter #f))
  59. (define (return expr)
  60. (-> (abort (or (current-return-tag) (error "return outside function"))
  61. (list expr)
  62. (-> (const '())))))
  63. (define (with-return-prompt body-thunk)
  64. (let ((tag (gensym "return")))
  65. (parameterize ((current-return-tag
  66. (-> (lexical 'return tag))))
  67. (-> (let '(return) (list tag)
  68. (list (-> (primcall 'make-prompt-tag)))
  69. (-> (prompt #t
  70. (current-return-tag)
  71. (body-thunk)
  72. (let ((val (gensym "val")))
  73. (-> (lambda '()
  74. (-> (lambda-case
  75. `(((k val) #f #f #f () (,(gensym) ,val))
  76. ,(-> (lexical 'val val)))))))))))))))
  77. (define (comp x e)
  78. (let ((l (location x)))
  79. (define (let1 what proc)
  80. (let ((sym (gensym)))
  81. (-> (let (list sym) (list sym) (list what)
  82. (proc sym)))))
  83. (define (begin1 what proc)
  84. (let1 what (lambda (v)
  85. (-> (begin (proc v)
  86. (-> (lexical v v)))))))
  87. (pmatch/source x
  88. (null
  89. ;; FIXME, null doesn't have much relation to EOL...
  90. (-> (const '())))
  91. (true
  92. (-> (const #t)))
  93. (false
  94. (-> (const #f)))
  95. ((number ,num)
  96. (-> (const num)))
  97. ((string ,str)
  98. (-> (const str)))
  99. (this
  100. (@impl get-this))
  101. ((+ ,a)
  102. (-> (call (-> (primitive '+))
  103. (@impl ->number (comp a e))
  104. (-> (const 0)))))
  105. ((- ,a)
  106. (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
  107. ((~ ,a)
  108. (@impl bitwise-not (comp a e)))
  109. ((! ,a)
  110. (@impl logical-not (comp a e)))
  111. ((+ ,a ,b)
  112. (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
  113. ((- ,a ,b)
  114. (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
  115. ((/ ,a ,b)
  116. (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
  117. ((* ,a ,b)
  118. (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
  119. ((% ,a ,b)
  120. (@impl mod (comp a e) (comp b e)))
  121. ((<< ,a ,b)
  122. (@impl shift (comp a e) (comp b e)))
  123. ((>> ,a ,b)
  124. (@impl shift (comp a e) (comp `(- ,b) e)))
  125. ((< ,a ,b)
  126. (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
  127. ((<= ,a ,b)
  128. (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
  129. ((> ,a ,b)
  130. (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
  131. ((>= ,a ,b)
  132. (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
  133. ((in ,a ,b)
  134. (@impl has-property? (comp a e) (comp b e)))
  135. ((== ,a ,b)
  136. (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
  137. ((!= ,a ,b)
  138. (-> (call (-> (primitive 'not))
  139. (-> (call (-> (primitive 'equal?))
  140. (comp a e) (comp b e))))))
  141. ((=== ,a ,b)
  142. (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
  143. ((!== ,a ,b)
  144. (-> (call (-> (primitive 'not))
  145. (-> (call (-> (primitive 'eqv?))
  146. (comp a e) (comp b e))))))
  147. ((& ,a ,b)
  148. (@impl band (comp a e) (comp b e)))
  149. ((^ ,a ,b)
  150. (@impl bxor (comp a e) (comp b e)))
  151. ((bor ,a ,b)
  152. (@impl bior (comp a e) (comp b e)))
  153. ((and ,a ,b)
  154. (-> (if (@impl ->boolean (comp a e))
  155. (comp b e)
  156. (-> (const #f)))))
  157. ((or ,a ,b)
  158. (let1 (comp a e)
  159. (lambda (v)
  160. (-> (if (@impl ->boolean (-> (lexical v v)))
  161. (-> (lexical v v))
  162. (comp b e))))))
  163. ((if ,test ,then ,else)
  164. (-> (if (@impl ->boolean (comp test e))
  165. (comp then e)
  166. (comp else e))))
  167. ((if ,test ,then)
  168. (-> (if (@impl ->boolean (comp test e))
  169. (comp then e)
  170. (@implv *undefined*))))
  171. ((postinc (ref ,foo))
  172. (begin1 (comp `(ref ,foo) e)
  173. (lambda (var)
  174. (-> (set! (lookup foo e)
  175. (-> (call (-> (primitive '+))
  176. (-> (lexical var var))
  177. (-> (const 1)))))))))
  178. ((postinc (pref ,obj ,prop))
  179. (let1 (comp obj e)
  180. (lambda (objvar)
  181. (begin1 (@impl pget
  182. (-> (lexical objvar objvar))
  183. (-> (const prop)))
  184. (lambda (tmpvar)
  185. (@impl pput
  186. (-> (lexical objvar objvar))
  187. (-> (const prop))
  188. (-> (call (-> (primitive '+))
  189. (-> (lexical tmpvar tmpvar))
  190. (-> (const 1))))))))))
  191. ((postinc (aref ,obj ,prop))
  192. (let1 (comp obj e)
  193. (lambda (objvar)
  194. (let1 (comp prop e)
  195. (lambda (propvar)
  196. (begin1 (@impl pget
  197. (-> (lexical objvar objvar))
  198. (-> (lexical propvar propvar)))
  199. (lambda (tmpvar)
  200. (@impl pput
  201. (-> (lexical objvar objvar))
  202. (-> (lexical propvar propvar))
  203. (-> (call (-> (primitive '+))
  204. (-> (lexical tmpvar tmpvar))
  205. (-> (const 1))))))))))))
  206. ((postdec (ref ,foo))
  207. (begin1 (comp `(ref ,foo) e)
  208. (lambda (var)
  209. (-> (set (lookup foo e)
  210. (-> (call (-> (primitive '-))
  211. (-> (lexical var var))
  212. (-> (const 1)))))))))
  213. ((postdec (pref ,obj ,prop))
  214. (let1 (comp obj e)
  215. (lambda (objvar)
  216. (begin1 (@impl pget
  217. (-> (lexical objvar objvar))
  218. (-> (const prop)))
  219. (lambda (tmpvar)
  220. (@impl pput
  221. (-> (lexical objvar objvar))
  222. (-> (const prop))
  223. (-> (call (-> (primitive '-))
  224. (-> (lexical tmpvar tmpvar))
  225. (-> (const 1))))))))))
  226. ((postdec (aref ,obj ,prop))
  227. (let1 (comp obj e)
  228. (lambda (objvar)
  229. (let1 (comp prop e)
  230. (lambda (propvar)
  231. (begin1 (@impl pget
  232. (-> (lexical objvar objvar))
  233. (-> (lexical propvar propvar)))
  234. (lambda (tmpvar)
  235. (@impl pput
  236. (-> (lexical objvar objvar))
  237. (-> (lexical propvar propvar))
  238. (-> (inline
  239. '- (-> (lexical tmpvar tmpvar))
  240. (-> (const 1))))))))))))
  241. ((preinc (ref ,foo))
  242. (let ((v (lookup foo e)))
  243. (-> (begin
  244. (-> (set! v
  245. (-> (call (-> (primitive '+))
  246. v
  247. (-> (const 1))))))
  248. v))))
  249. ((preinc (pref ,obj ,prop))
  250. (let1 (comp obj e)
  251. (lambda (objvar)
  252. (begin1 (-> (call (-> (primitive '+))
  253. (@impl pget
  254. (-> (lexical objvar objvar))
  255. (-> (const prop)))
  256. (-> (const 1))))
  257. (lambda (tmpvar)
  258. (@impl pput (-> (lexical objvar objvar))
  259. (-> (const prop))
  260. (-> (lexical tmpvar tmpvar))))))))
  261. ((preinc (aref ,obj ,prop))
  262. (let1 (comp obj e)
  263. (lambda (objvar)
  264. (let1 (comp prop e)
  265. (lambda (propvar)
  266. (begin1 (-> (call (-> (primitive '+))
  267. (@impl pget
  268. (-> (lexical objvar objvar))
  269. (-> (lexical propvar propvar)))
  270. (-> (const 1))))
  271. (lambda (tmpvar)
  272. (@impl pput
  273. (-> (lexical objvar objvar))
  274. (-> (lexical propvar propvar))
  275. (-> (lexical tmpvar tmpvar))))))))))
  276. ((predec (ref ,foo))
  277. (let ((v (lookup foo e)))
  278. (-> (begin
  279. (-> (set! v
  280. (-> (call (-> (primitive '-))
  281. v
  282. (-> (const 1))))))
  283. v))))
  284. ((predec (pref ,obj ,prop))
  285. (let1 (comp obj e)
  286. (lambda (objvar)
  287. (begin1 (-> (call (-> (primitive '-))
  288. (@impl pget
  289. (-> (lexical objvar objvar))
  290. (-> (const prop)))
  291. (-> (const 1))))
  292. (lambda (tmpvar)
  293. (@impl pput
  294. (-> (lexical objvar objvar))
  295. (-> (const prop))
  296. (-> (lexical tmpvar tmpvar))))))))
  297. ((predec (aref ,obj ,prop))
  298. (let1 (comp obj e)
  299. (lambda (objvar)
  300. (let1 (comp prop e)
  301. (lambda (propvar)
  302. (begin1 (-> (call (-> (primitive '-))
  303. (@impl pget
  304. (-> (lexical objvar objvar))
  305. (-> (lexical propvar propvar)))
  306. (-> (const 1))))
  307. (lambda (tmpvar)
  308. (@impl pput
  309. (-> (lexical objvar objvar))
  310. (-> (lexical propvar propvar))
  311. (-> (lexical tmpvar tmpvar))))))))))
  312. ((ref ,id)
  313. (lookup id e))
  314. ((var . ,forms)
  315. `(begin
  316. ,@(map (lambda (form)
  317. (pmatch form
  318. ((,x ,y)
  319. (-> (define x (comp y e))))
  320. ((,x)
  321. (-> (define x (@implv *undefined*))))
  322. (else (error "bad var form" form))))
  323. forms)))
  324. ((begin)
  325. (-> (void)))
  326. ((begin ,form)
  327. (comp form e))
  328. ((begin . ,forms)
  329. `(begin ,@(map (lambda (x) (comp x e)) forms)))
  330. ((lambda ,formals ,body)
  331. (let ((syms (map (lambda (x)
  332. (gensym (string-append (symbol->string x) " ")))
  333. formals)))
  334. `(lambda ()
  335. (lambda-case
  336. ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms)
  337. ,(with-return-prompt
  338. (lambda ()
  339. (comp-body e body formals syms))))))))
  340. ((call/this ,obj ,prop . ,args)
  341. (@impl call/this*
  342. obj
  343. (-> (lambda '()
  344. `(lambda-case
  345. ((() #f #f #f () ())
  346. (call ,(@impl pget obj prop) ,@args)))))))
  347. ((call (pref ,obj ,prop) ,args)
  348. (comp `(call/this ,(comp obj e)
  349. ,(-> (const prop))
  350. ,@(map (lambda (x) (comp x e)) args))
  351. e))
  352. ((call (aref ,obj ,prop) ,args)
  353. (comp `(call/this ,(comp obj e)
  354. ,(comp prop e)
  355. ,@(map (lambda (x) (comp x e)) args))
  356. e))
  357. ((call ,proc ,args)
  358. `(call ,(comp proc e)
  359. ,@(map (lambda (x) (comp x e)) args)))
  360. ((return ,expr)
  361. (return (comp expr e)))
  362. ((array . ,args)
  363. `(call ,(@implv new-array)
  364. ,@(map (lambda (x) (comp x e)) args)))
  365. ((object . ,args)
  366. `(call ,(@implv new-object)
  367. ,@(map (lambda (x)
  368. (pmatch x
  369. ((,prop ,val)
  370. (-> (call (-> (primitive 'cons))
  371. (-> (const prop))
  372. (comp val e))))
  373. (else
  374. (error "bad prop-val pair" x))))
  375. args)))
  376. ((pref ,obj ,prop)
  377. (@impl pget
  378. (comp obj e)
  379. (-> (const prop))))
  380. ((aref ,obj ,index)
  381. (@impl pget
  382. (comp obj e)
  383. (comp index e)))
  384. ((= (ref ,name) ,val)
  385. (let ((v (lookup name e)))
  386. (-> (begin
  387. (-> (set! v (comp val e)))
  388. v))))
  389. ((= (pref ,obj ,prop) ,val)
  390. (@impl pput
  391. (comp obj e)
  392. (-> (const prop))
  393. (comp val e)))
  394. ((= (aref ,obj ,prop) ,val)
  395. (@impl pput
  396. (comp obj e)
  397. (comp prop e)
  398. (comp val e)))
  399. ((+= ,what ,val)
  400. (comp `(= ,what (+ ,what ,val)) e))
  401. ((-= ,what ,val)
  402. (comp `(= ,what (- ,what ,val)) e))
  403. ((/= ,what ,val)
  404. (comp `(= ,what (/ ,what ,val)) e))
  405. ((*= ,what ,val)
  406. (comp `(= ,what (* ,what ,val)) e))
  407. ((%= ,what ,val)
  408. (comp `(= ,what (% ,what ,val)) e))
  409. ((>>= ,what ,val)
  410. (comp `(= ,what (>> ,what ,val)) e))
  411. ((<<= ,what ,val)
  412. (comp `(= ,what (<< ,what ,val)) e))
  413. ((>>>= ,what ,val)
  414. (comp `(= ,what (>>> ,what ,val)) e))
  415. ((&= ,what ,val)
  416. (comp `(= ,what (& ,what ,val)) e))
  417. ((bor= ,what ,val)
  418. (comp `(= ,what (bor ,what ,val)) e))
  419. ((^= ,what ,val)
  420. (comp `(= ,what (^ ,what ,val)) e))
  421. ((new ,what ,args)
  422. `(call ,(@implv new)
  423. ,(comp what e)
  424. ,@(map (lambda (x) (comp x e)) args)))
  425. ((delete (pref ,obj ,prop))
  426. (@impl pdel
  427. (comp obj e)
  428. (-> (const prop))))
  429. ((delete (aref ,obj ,prop))
  430. (@impl pdel
  431. (comp obj e)
  432. (comp prop e)))
  433. ((void ,expr)
  434. (-> (begin
  435. (comp expr e)
  436. (@implv *undefined*))))
  437. ((typeof ,expr)
  438. (@impl typeof
  439. (comp expr e)))
  440. ((do ,statement ,test)
  441. (let ((%loop (gensym "%loop "))
  442. (%continue (gensym "%continue ")))
  443. (let ((e (econs '%loop %loop (econs '%continue %continue e))))
  444. (-> (letrec '(%loop %continue) (list %loop %continue)
  445. (list (-> (lambda '()
  446. (-> (lambda-case
  447. `((() #f #f #f () ())
  448. ,(-> (begin
  449. (comp statement e)
  450. (-> (call (-> (lexical '%continue %continue)))))))))))
  451. (-> (lambda '()
  452. (-> (lambda-case
  453. `((() #f #f #f () ())
  454. ,(-> (if (@impl ->boolean (comp test e))
  455. (-> (call (-> (lexical '%loop %loop))))
  456. (@implv *undefined*)))))))))
  457. (-> (call (-> (lexical '%loop %loop)))))))))
  458. ((while ,test ,statement)
  459. (let ((%continue (gensym "%continue ")))
  460. (let ((e (econs '%continue %continue e)))
  461. (-> (letrec '(%continue) (list %continue)
  462. (list (-> (lambda '()
  463. (-> (lambda-case
  464. `((() #f #f #f () ())
  465. ,(-> (if (@impl ->boolean (comp test e))
  466. (-> (begin (comp statement e)
  467. (-> (call (-> (lexical '%continue %continue))))))
  468. (@implv *undefined*)))))))))
  469. (-> (call (-> (lexical '%continue %continue)))))))))
  470. ((for ,init ,test ,inc ,statement)
  471. (let ((%continue (gensym "%continue ")))
  472. (let ((e (econs '%continue %continue e)))
  473. (-> (letrec '(%continue) (list %continue)
  474. (list (-> (lambda '()
  475. (-> (lambda-case
  476. `((() #f #f #f () ())
  477. ,(-> (if (if test
  478. (@impl ->boolean (comp test e))
  479. (comp 'true e))
  480. (-> (begin (comp statement e)
  481. (comp (or inc '(begin)) e)
  482. (-> (call (-> (lexical '%continue %continue))))))
  483. (@implv *undefined*)))))))))
  484. (-> (begin (comp (or init '(begin)) e)
  485. (-> (call (-> (lexical '%continue %continue)))))))))))
  486. ((for-in ,var ,object ,statement)
  487. (let ((%enum (gensym "%enum "))
  488. (%continue (gensym "%continue ")))
  489. (let ((e (econs '%enum %enum (econs '%continue %continue e))))
  490. (-> (letrec '(%enum %continue) (list %enum %continue)
  491. (list (@impl make-enumerator (comp object e))
  492. (-> (lambda '()
  493. (-> (lambda-case
  494. `((() #f #f #f () ())
  495. (-> (if (@impl ->boolean
  496. (@impl pget
  497. (-> (lexical '%enum %enum))
  498. (-> (const 'length))))
  499. (-> (begin
  500. (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
  501. ,(-> (const 'pop))))
  502. e)
  503. (comp statement e)
  504. (-> (call (-> (lexical '%continue %continue))))))
  505. (@implv *undefined*)))))))))
  506. (-> (call (-> (lexical '%continue %continue)))))))))
  507. ((block ,x)
  508. (comp x e))
  509. (else
  510. (error "compilation not yet implemented:" x)))))
  511. (define (comp-body e body formals formal-syms)
  512. (define (process)
  513. (let lp ((in body) (out '()) (rvars '()))
  514. (pmatch in
  515. (((var (,x) . ,morevars) . ,rest)
  516. (lp `((var . ,morevars) . ,rest)
  517. out
  518. (if (or (memq x rvars) (memq x formals))
  519. rvars
  520. (cons x rvars))))
  521. (((var (,x ,y) . ,morevars) . ,rest)
  522. (lp `((var . ,morevars) . ,rest)
  523. `((= (ref ,x) ,y) . ,out)
  524. (if (or (memq x rvars) (memq x formals))
  525. rvars
  526. (cons x rvars))))
  527. (((var) . ,rest)
  528. (lp rest out rvars))
  529. ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
  530. (lp rest
  531. (cons x out)
  532. rvars))
  533. ((,x . ,rest) (guard (pair? x))
  534. (receive (sub-out rvars)
  535. (lp x '() rvars)
  536. (lp rest
  537. (cons sub-out out)
  538. rvars)))
  539. ((,x . ,rest)
  540. (lp rest
  541. (cons x out)
  542. rvars))
  543. (()
  544. (values (reverse! out)
  545. rvars)))))
  546. (receive (out rvars)
  547. (process)
  548. (let* ((names (reverse rvars))
  549. (syms (map (lambda (x)
  550. (gensym (string-append (symbol->string x) " ")))
  551. names))
  552. (e (fold econs (fold econs e formals formal-syms) names syms)))
  553. (-> (let names syms (map (lambda (x) (@implv *undefined*)) names)
  554. (comp out e))))))