1;;============================================================================
2
3;;; File: "_t-univ-1.scm"
4
5;;; Copyright (c) 2011-2018 by Marc Feeley, All Rights Reserved.
6;;; Copyright (c) 2012 by Eric Thivierge, All Rights Reserved.
7
8(include "generic.scm")
9
10(include-adt "_envadt.scm")
11(include-adt "_gvmadt.scm")
12(include-adt "_ptreeadt.scm")
13(include-adt "_sourceadt.scm")
14(include-adt "_univadt.scm")
15
16;;----------------------------------------------------------------------------
17
18(define deb #t)
19(set! deb #f)
20(define (tt tag . stuff) (if deb (list "/*{" tag "*/" stuff "/*}*/") stuff));;;;;;;;;;;;;;;;;;;;
21
22(define univ-enable-jump-destination-inlining? #f)
23(set! univ-enable-jump-destination-inlining? #t)
24
25(define univ-dyn-load? #f)
26(set! univ-dyn-load? #f)
27
28(define (univ-get-semantics-changing-option ctx name)
29  (let ((x (assq name (ctx-semantics-changing-options ctx))))
30    (and x (pair? (cdr x)) (cadr x))))
31
32(define (univ-module-representation ctx)
33  (or (univ-get-semantics-changing-option ctx 'repr-module)
34      (case (target-name (ctx-target ctx))
35        ((java)
36         'class)
37        (else
38         'global))))
39
40(define (univ-procedure-representation ctx)
41  (or (univ-get-semantics-changing-option ctx 'repr-procedure)
42      (case (target-name (ctx-target ctx))
43        ((java)
44         'class)
45        ((php)
46         (if (univ-php-pre53? ctx)
47             'class
48             'host))
49        (else
50         'host))))
51
52(define (univ-frame-representation ctx)
53  (or (univ-get-semantics-changing-option ctx 'repr-frame)
54      (case (target-name (ctx-target ctx))
55        ((java)
56         'class)
57        (else
58         'host))))
59
60(define (univ-null-representation ctx)
61  (or (univ-get-semantics-changing-option ctx 'repr-null)
62      (case (target-name (ctx-target ctx))
63        ((js)
64         'host)
65        (else
66         'class))))
67
68(define (univ-void-representation ctx)
69  (or (univ-get-semantics-changing-option ctx 'repr-void)
70      'host))
71
72(define (univ-eof-representation ctx)
73  'class)
74
75(define (univ-absent-representation ctx)
76  'class)
77
78(define (univ-deleted-representation ctx)
79  'class)
80
81(define (univ-unused-representation ctx)
82  'class)
83
84(define (univ-unbound-representation ctx)
85  'class)
86
87(define (univ-optional-representation ctx)
88  'class)
89
90(define (univ-key-representation ctx)
91  'class)
92
93(define (univ-rest-representation ctx)
94  'class)
95
96(define (univ-boolean-representation ctx)
97  (or (univ-get-semantics-changing-option ctx 'repr-boolean)
98      (case (target-name (ctx-target ctx))
99        ((java)
100         'class)
101        (else
102         'host))))
103
104(define (univ-char-representation ctx)
105  'class)
106
107(define (univ-fixnum-representation ctx)
108  (or (univ-get-semantics-changing-option ctx 'repr-fixnum)
109      (case (target-name (ctx-target ctx))
110        ((java)
111         'class)
112        (else
113         'host))))
114
115(define (univ-flonum-representation ctx)
116  (or (univ-get-semantics-changing-option ctx 'repr-flonum)
117      'class))
118
119(define (univ-vector-representation ctx)
120  (or (univ-get-semantics-changing-option ctx 'repr-vector)
121      (case (target-name (ctx-target ctx))
122        ((php java)
123         'class)
124        (else
125         'host))))
126
127(define (univ-values-representation ctx)
128  (or (univ-get-semantics-changing-option ctx 'repr-values)
129      'class))
130
131(define (univ-u8vector-representation ctx)
132  (or (univ-get-semantics-changing-option ctx 'repr-u8vector)
133      'class))
134
135(define (univ-u16vector-representation ctx)
136  (or (univ-get-semantics-changing-option ctx 'repr-u16vector)
137      'class))
138
139(define (univ-u32vector-representation ctx)
140  (or (univ-get-semantics-changing-option ctx 'repr-u32vector)
141      'class))
142
143(define (univ-u64vector-representation ctx)
144  (or (univ-get-semantics-changing-option ctx 'repr-u64vector)
145      'class))
146
147(define (univ-s8vector-representation ctx)
148  (or (univ-get-semantics-changing-option ctx 'repr-s8vector)
149      'class))
150
151(define (univ-s16vector-representation ctx)
152  (or (univ-get-semantics-changing-option ctx 'repr-s16vector)
153      'class))
154
155(define (univ-s32vector-representation ctx)
156  (or (univ-get-semantics-changing-option ctx 'repr-s32vector)
157      'class))
158
159(define (univ-s64vector-representation ctx)
160  (or (univ-get-semantics-changing-option ctx 'repr-s64vector)
161      'class))
162
163(define (univ-f32vector-representation ctx)
164  (or (univ-get-semantics-changing-option ctx 'repr-f32vector)
165      'class))
166
167(define (univ-f64vector-representation ctx)
168  (or (univ-get-semantics-changing-option ctx 'repr-f64vector)
169      'class))
170
171(define (univ-structure-representation ctx)
172  'class)
173
174(define (univ-string-representation ctx)
175  (or (univ-get-semantics-changing-option ctx 'repr-string)
176      'class))
177
178(define (univ-symbol-representation ctx)
179  (or (univ-get-semantics-changing-option ctx 'repr-symbol)
180      'class))
181
182(define (univ-keyword-representation ctx)
183  'class)
184
185(define (univ-tostr-method-name ctx)
186  (case (target-name (ctx-target ctx))
187
188    ((js java)
189     'toString)
190
191    ((php)
192     '__toString)
193
194    ((python)
195     '__str__)
196
197    ((ruby)
198     'to_s)
199
200    (else
201     (compiler-internal-error
202      "univ-tostr-method-name, unknown target"))))
203
204(define (univ-proc-name-attrib ctx)
205  (case (target-name (ctx-target ctx))
206
207    ((js)
208     '_name) ;; avoid clash with builtin "name" attribute of functions
209
210    (else
211     'name)))
212
213(define (univ-ns-prefix sem-changing-options)
214  (let ((x (assq 'namespace sem-changing-options)))
215    (or (and x (pair? (cdr x)) (cadr x))
216        "g_")))
217
218(define (univ-ns-prefix-class sem-changing-options)
219  (let ((ns (univ-ns-prefix sem-changing-options)))
220    (if (= (string-length ns) 0)
221        ns
222        (let ((lst (string->list ns)))
223          (list->string (cons (char-upcase (car lst)) (cdr lst)))))))
224
225(define univ-thread-cont-slot 21)
226(define univ-thread-denv-slot 22)
227
228(define (univ-php-pre53? ctx)
229  (assq 'pre53 (ctx-semantics-changing-options ctx)))
230
231(define (univ-python-pre3? ctx)
232  (assq 'pre3 (ctx-semantics-changing-options ctx)))
233
234(define (univ-java-pre7? ctx)
235  (assq 'pre7 (ctx-semantics-changing-options ctx)))
236
237(define (univ-always-return-jump? ctx)
238  (assq 'always-return-jump (ctx-semantics-preserving-options ctx)))
239
240(define (univ-never-return-jump? ctx)
241  (assq 'never-return-jump (ctx-semantics-preserving-options ctx)))
242
243(define (univ-stack-resizable? ctx)
244  (case (target-name (ctx-target ctx))
245    ((java) #f)
246    (else   #t)))
247
248(define univ-tag-bits 2)
249(define univ-word-bits 32)
250
251(define univ-fixnum-max+1
252  (arithmetic-shift 1 (- univ-word-bits (+ 1 univ-tag-bits))))
253
254(define univ-fixnum-max (- univ-fixnum-max+1 1))
255(define univ-fixnum-min (- -1 univ-fixnum-max))
256(define univ-fixnum-max*2+1 (+ (* univ-fixnum-max 2) 1))
257
258;;;----------------------------------------------------------------------------
259;;
260;; "Universal" back-end.
261
262;; Initialization/finalization of back-end.
263
264(define (univ-setup
265         target-language
266         file-extensions
267         semantics-changing-options
268         semantics-preserving-options)
269
270  (define common-semantics-changing-options
271    '((repr-module    symbol)
272      (repr-procedure symbol)
273      (repr-frame     symbol)
274      (repr-null      symbol)
275      (repr-void      symbol)
276      (repr-boolean   symbol)
277      (repr-fixnum    symbol)
278      (repr-flonum    symbol)
279      (repr-vector    symbol)
280      (repr-u8vector  symbol)
281      (repr-u16vector symbol)
282      (repr-u32vector symbol)
283      (repr-u64vector symbol)
284      (repr-s8vector  symbol)
285      (repr-s16vector symbol)
286      (repr-s32vector symbol)
287      (repr-s64vector symbol)
288      (repr-f32vector symbol)
289      (repr-f64vector symbol)
290      (repr-values    symbol)
291      (repr-string    symbol)
292      (repr-symbol    symbol)
293      (namespace      string)))
294
295  (define common-semantics-preserving-options
296    '((always-return-jump)
297      (never-return-jump)))
298
299  (let ((targ
300         (make-target 12
301                      target-language
302                      file-extensions
303                      (append semantics-changing-options
304                              common-semantics-changing-options)
305                      (append semantics-preserving-options
306                              common-semantics-preserving-options)
307                      0)))
308
309    (define (begin! sem-changing-opts
310                    sem-preserving-opts
311                    info-port)
312
313      (target-dump-set!
314       targ
315       (lambda (procs output c-intf module-descr linker-name)
316         (univ-dump targ
317                    procs
318                    output
319                    c-intf
320                    module-descr
321                    linker-name
322                    sem-changing-opts
323                    sem-preserving-opts)))
324
325      (target-link-info-set!
326       targ
327       (lambda (file)
328         (univ-link-info targ file)))
329
330      (target-link-set!
331       targ
332       (lambda (extension? inputs output linker-name warnings?)
333         (univ-link targ extension? inputs output linker-name warnings?)))
334
335      (target-prim-info-set!
336       targ
337       (lambda (name)
338         (univ-prim-info targ name)))
339
340      (target-frame-constraints-set!
341       targ
342       (make-frame-constraints univ-frame-reserve univ-frame-alignment))
343
344      (target-proc-result-set!
345       targ
346       (make-reg 1))
347
348      (target-task-return-set!
349       targ
350       (make-reg 0))
351
352      (target-switch-testable?-set!
353       targ
354       (lambda (obj)
355         (univ-switch-testable? targ obj)))
356
357      (target-eq-testable?-set!
358       targ
359       (lambda (obj)
360         (univ-eq-testable? targ obj)))
361
362      (target-object-type-set!
363       targ
364       (lambda (obj)
365         (univ-object-type targ obj)))
366
367      (univ-set-nb-regs targ sem-changing-opts)
368
369      #f)
370
371    (define (end!)
372      #f)
373
374    (target-begin!-set! targ begin!)
375    (target-end!-set! targ end!)
376    (target-add targ)))
377
378(univ-setup 'js     '((".js"   . JavaScript))  '()        '())
379(univ-setup 'python '((".py"   . Python))      '((pre3))  '())
380(univ-setup 'ruby   '((".rb"   . Ruby))        '()        '())
381(univ-setup 'php    '((".php"  . PHP))         '((pre53)) '())
382
383(univ-setup 'java   '((".java" . Java))        '((pre7))  '())
384;;(univ-setup 'c      '((".c"    . C))           '()       '())
385;;(univ-setup 'c++    '((".cc"   . C++))         '()       '())
386;;(univ-setup 'objc   '((".m"    . Objective-C)) '()       '())
387
388;;;----------------------------------------------------------------------------
389
390;; ***** REGISTERS AVAILABLE
391
392;; The registers available in the virtual machine default to
393;; univ-default-nb-gvm-regs and univ-default-nb-arg-regs but can be
394;; changed with the gsc options -nb-gvm-regs and -nb-arg-regs.
395;;
396;; nb-gvm-regs = total number of registers available
397;; nb-arg-regs = maximum number of arguments passed in registers
398
399(define univ-default-nb-gvm-regs 5)
400(define univ-default-nb-arg-regs 3)
401
402(define (univ-nb-gvm-regs ctx) (target-nb-regs (ctx-target ctx)))
403(define (univ-nb-arg-regs ctx) (target-nb-arg-regs (ctx-target ctx)))
404
405(define (univ-set-nb-regs targ sem-changing-opts)
406  (let ((nb-gvm-regs
407         (get-option sem-changing-opts
408                     'nb-gvm-regs
409                     univ-default-nb-gvm-regs))
410        (nb-arg-regs
411         (get-option sem-changing-opts
412                     'nb-arg-regs
413                     univ-default-nb-arg-regs)))
414
415    (if (not (and (<= 3 nb-gvm-regs)
416                  (<= nb-gvm-regs 25)))
417        (compiler-error "-nb-gvm-regs option must be between 3 and 25"))
418
419    (if (not (and (<= 1 nb-arg-regs)
420                  (<= nb-arg-regs (- nb-gvm-regs 2))))
421        (compiler-error
422         (string-append "-nb-arg-regs option must be between 1 and "
423                        (number->string (- nb-gvm-regs 2)))))
424
425    (target-nb-regs-set! targ nb-gvm-regs)
426    (target-nb-arg-regs-set! targ nb-arg-regs)))
427
428;;;----------------------------------------------------------------------------
429
430;; Generation of textual target code.
431
432(define (univ-indent . rest)
433  (cons '$$indent$$ rest))
434
435(define (univ-constant val)
436  (univ-box val val))
437
438(define (univ-box boxed unboxed)
439  (list '$$box$$ boxed unboxed))
440
441(define (univ-box? x)
442  (and (pair? x)
443       (eq? (car x) '$$box$$)))
444
445(define (univ-unbox x)
446  (and (univ-box? x)
447       (cddr x)))
448
449(define (univ-display x port)
450
451  (define indent-level 0)
452  (define after-newline? #t)
453
454  (define (indent)
455    (if after-newline?
456        (begin
457          (display (make-string (* 2 indent-level) #\space) port)
458          (set! after-newline? #f))))
459
460  (define (disp x)
461
462    (cond ((string? x)
463           (let loop1 ((i 0))
464             (let loop2 ((j i))
465
466               (define (display-substring limit)
467                 (if (< i limit)
468                     (begin
469                       (if (or (> (- limit i) 1)
470                               (not (char=? (string-ref x (- limit 1))
471                                            #\newline)))
472                           (indent))
473                       (if (and (= i 0) (= limit (string-length x)))
474                           (display x port)
475                           (display (substring x i limit) port)))))
476
477               (if (< j (string-length x))
478
479                   (let ((c (string-ref x j))
480                         (j+1 (+ j 1)))
481                       (if (char=? c #\newline)
482                           (begin
483                             (display-substring j+1)
484                             (set! after-newline? #t)
485                             (loop1 j+1))
486                           (loop2 j+1)))
487
488                   (display-substring j)))))
489
490          ((symbol? x)
491           (disp (symbol->string x)))
492
493          ((char? x)
494           (disp (string x)))
495
496          ((null? x))
497
498          ((pair? x)
499           (case (car x)
500             (($$indent$$)
501              (set! indent-level (+ indent-level 1))
502              (disp (cdr x))
503              (set! indent-level (- indent-level 1)))
504             (($$box$$)
505              (disp (cadr x)))
506             (else
507              (disp (car x))
508              (disp (cdr x)))))
509
510          ((vector? x)
511           (disp (vector->list x)))
512
513          (else
514           (indent)
515           (display x port))))
516
517   (disp x))
518
519(define (univ-display-to-file x path)
520  (let ((port (open-output-file-preserving-case path)))
521    (univ-display x port)
522    (close-output-port port)))
523
524;;;----------------------------------------------------------------------------
525
526;; The frame constraints are defined by the parameters
527;; univ-frame-reserve and univ-frame-alignment.
528
529(define univ-frame-reserve 0) ;; no extra slots reserved
530(define univ-frame-alignment 1) ;; no alignment constraint
531
532;;;----------------------------------------------------------------------------
533
534;; ***** PRIMITIVE PROCEDURE DATABASE
535
536(define univ-prim-proc-table
537  (let ((t (make-prim-proc-table)))
538    (for-each
539     (lambda (x) (prim-proc-add! t x))
540     '(("##inline-host-statement" 1 #t 0 0 (#f) extended)
541       ("##inline-host-expression" 1 #t 0 0 (#f) extended)
542       ("##inline-host-declaration" (1) #t 0 0 (#f) extended)
543       ("##univ-table-make-hashtable" (2) #t 0 0 (#f) extended)
544       ("##univ-table-key-exists?" (2) #f 0 0 boolean extended)
545       ("##univ-table-keys" (1) #f 0 0 (#f) extended)
546       ("##univ-table-ref" (2) #f 0 0 (#f) extended)
547       ("##univ-table-set!" (3) #t 0 0 (#f) extended)
548       ("##univ-table-delete" (2) #f 0 0 (#f) extended)
549       ("##univ-table-length" (1) #f 0 0 number extended)))
550    t))
551
552(define (univ-prim-info targ name)
553  (univ-prim-info* name))
554
555(define (univ-prim-info* name)
556  (prim-proc-info univ-prim-proc-table name))
557
558;;;----------------------------------------------------------------------------
559
560;; ***** OBJECT PROPERTIES
561
562(define (univ-switch-testable? targ obj)
563  ;;(pretty-print (list 'univ-switch-testable? 'targ obj))
564  #f);;;;;;;;;;;;;;;;;;;;;;;;;;;;
565
566(define (univ-eq-testable? targ obj)
567  ;;(pretty-print (list 'univ-eq-testable? 'targ obj))
568  #f);;;;;;;;;;;;;;;;;;;;;;;;;;;
569
570(define (univ-object-type targ obj)
571  ;;(pretty-print (list 'univ-object-type 'targ obj))
572  'bignum);;;;;;;;;;;;;;;;;;;;;;;;;
573
574;;;----------------------------------------------------------------------------
575
576(define (univ-emit-popcount! ctx arg)
577
578  (define (popcount arg acc len)
579    (if (>= len univ-word-bits)
580        (^ acc
581           (^assign arg (^bitand arg (^int #x0000003F))))
582        (popcount
583         arg
584         (^ acc
585            (case len
586             ((1)
587              (^assign arg (^- arg
588                               (^parens (^bitand (^parens (^>> arg (^int 1)))
589                                                 (^int #x55555555))))))
590             ((2)
591              (^assign arg (^+ (^parens (^bitand arg (^int #x33333333)))
592                               (^parens (^bitand (^parens (^>> arg (^int 2)))
593                                                 (^int #x33333333))))))
594             ((4)
595              (^assign arg (^bitand (^parens (^+ arg (^parens (^>> arg (^int 4)))))
596                                    (^int #x0F0F0F0F))))
597             (else
598              (^assign arg (^+ arg (^parens (^>> arg len)))))))
599         (* len 2))))
600
601  (popcount arg
602            (^assign arg (^bitand arg (^int univ-fixnum-max*2+1)))
603            1))
604
605(define (univ-emit-map ctx fn array)
606  (case (target-name (ctx-target ctx))
607
608    ((js)
609     (^ array ".map( " fn " )"))
610
611    ((php)
612     (^ "array_map( '" fn "', " array ")"))
613
614    ((python)
615     (^ "map( "fn ", " array " )"))
616
617    ((ruby)
618     (^ array ".map { |x| " fn "(x) } " ))
619
620    (else
621     (compiler-internal-error
622      "univ-emit-map, unknown target"))))
623
624(define (univ-emit-call-with-arg-array ctx fn array)
625  (case (target-name (ctx-target ctx))
626
627    ((js)
628     (^ fn ".apply( null, " array " )"))
629
630    ((php)
631     (^ "call_user_func_array( " fn ", " array " )"))
632
633    ((python)
634     (^ fn "( *" array " )"))
635
636    ((ruby)
637     (^ fn ".( *" array " )"))
638
639    (else
640     (compiler-internal-error
641      "univ-emit-call-with-arg-array, unknown target"))))
642
643(define (univ-emit-var-declaration ctx type name #!optional (init #f))
644  (case (target-name (ctx-target ctx))
645
646    ((js)
647     (^ "var " name (if init (^ " = " init) (^)) ";\n"))
648
649    ((python ruby)
650     (^ name " = " (or init (^obj #f)) "\n"))
651
652    ((php)
653     (^ name " = " (or init (^obj #f)) ";\n"))
654
655    ((java)
656     (^ (^decl type name) (if init (^ " = " init) (^)) ";\n"))
657
658    (else
659     (compiler-internal-error
660      "univ-emit-var-declaration, unknown target"))))
661
662(define (univ-emit-expr-statement ctx expr)
663  (case (target-name (ctx-target ctx))
664
665    ((js php java)
666     (^ expr ";\n"))
667
668    ((python ruby)
669     (^ expr "\n"))
670
671    (else
672     (compiler-internal-error
673      "univ-emit-expr-statement, unknown target"))))
674
675(define (univ-emit-if ctx test true #!optional (false #f))
676  (case (target-name (ctx-target ctx))
677
678    ((js php java)
679     (^ "if (" test ") {\n"
680        (univ-indent true)
681        (if false
682            (^ "} else {\n"
683               (univ-indent false))
684            (^))
685        "}\n"))
686
687    ((python)
688     (^ "if " test ":\n"
689        (univ-indent true)
690        (if false
691            (^ "else:\n"
692                  (univ-indent false))
693            (^))))
694
695    ((ruby)
696     (^ "if " test "\n"
697        (univ-indent true)
698        (if false
699            (^ "else\n"
700               (univ-indent false))
701            (^))
702        "end\n"))
703
704    (else
705     (compiler-internal-error
706      "univ-emit-if, unknown target"))))
707
708(define (univ-emit-if-expr ctx expr1 expr2 expr3)
709  (case (target-name (ctx-target ctx))
710
711    ((js ruby java)
712     (^ expr1 " ? " expr2 " : " expr3))
713
714    ((php)
715     (^parens (^ expr1 " ? " expr2 " : " expr3)))
716
717    ((python)
718     (^ expr2 " if " expr1 " else " expr3))
719
720    (else
721     (compiler-internal-error
722      "univ-emit-if-expr, unknown target"))))
723
724(define (univ-emit-while ctx test body)
725  (case (target-name (ctx-target ctx))
726
727    ((js php java)
728     (^ "while (" test ") {\n"
729        (univ-indent body)
730        "}\n"))
731
732    ((python)
733     (^ "while " test ":\n"
734        (univ-indent body)))
735
736    ((ruby)
737     (^ "while " test "\n"
738        (univ-indent body)
739        "end\n"))
740
741    (else
742     (compiler-internal-error
743      "univ-emit-while, unknown target"))))
744
745(define (univ-emit-eq? ctx expr1 expr2)
746  (case (target-name (ctx-target ctx))
747
748    ((js php)
749     (^ expr1 " === " expr2))
750
751    ((python)
752     (^ expr1 " is " expr2))
753
754    ((ruby)
755     (^ expr1 ".equal?(" expr2 ")"))
756
757    ((java)
758     (^ expr1 " == " expr2))
759
760    (else
761     (compiler-internal-error
762      "univ-emit-eq?, unknown target"))))
763
764(define (univ-emit-+ ctx expr1 #!optional (expr2 #f))
765  (case (target-name (ctx-target ctx))
766
767    ((js php python ruby java)
768     (if expr2
769         (^ expr1 " + " expr2)
770         (^ "+ " expr1)))
771
772    (else
773     (compiler-internal-error
774      "univ-emit-+, unknown target"))))
775
776(define (univ-emit-- ctx expr1 #!optional (expr2 #f))
777  (case (target-name (ctx-target ctx))
778
779    ((js php python ruby java)
780     (if expr2
781         (^ expr1 " - " expr2)
782         (^ "- " expr1)))
783
784    (else
785     (compiler-internal-error
786      "univ-emit--, unknown target"))))
787
788(define (univ-emit-* ctx expr1 expr2)
789  (case (target-name (ctx-target ctx))
790
791    ((js php python ruby java)
792     (^ expr1 " * " expr2))
793
794    (else
795     (compiler-internal-error
796      "univ-emit-*, unknown target"))))
797
798(define (univ-emit-/ ctx expr1 expr2)
799  (case (target-name (ctx-target ctx))
800
801    ((js php python ruby java)
802     (^ expr1 " / " expr2))
803
804    (else
805     (compiler-internal-error
806      "univ-emit-/, unknown target"))))
807
808(define (univ-wrap ctx expr)
809  (case (target-name (ctx-target ctx))
810
811    ((js java)
812     (^>> (^<< (^parens expr)
813               (^int univ-tag-bits))
814          (^int univ-tag-bits)))
815
816    ((python)
817     (^>> (^member (^call-prim
818                    "ctypes.c_int32"
819                    (^<< (^parens expr)
820                         (^int univ-tag-bits)))
821                   'value)
822          (^int univ-tag-bits)))
823
824    ((ruby php)
825     (^- (^parens (^bitand (^parens (^+ (^parens expr)
826                                        (^int univ-fixnum-max+1)))
827                           (^int univ-fixnum-max*2+1)))
828         (^int univ-fixnum-max+1)))
829
830    (else
831     (compiler-internal-error
832      "univ-wrap, unknown target"))))
833
834(define (univ-wrap+ ctx expr1 expr2)
835  (univ-wrap ctx (^+ expr1 expr2)))
836
837(define (univ-wrap- ctx expr1 #!optional (expr2 #f))
838  (univ-wrap ctx (if expr2
839                     (^- expr1 expr2)
840                     (^- expr1))))
841
842(define (univ-wrap* ctx expr1 expr2)
843  (case (target-name (ctx-target ctx))
844
845    ((js)
846     (univ-wrap ctx
847                (^+ (^* (^parens (^bitand expr1 #xffff))
848                        expr2)
849                    (^* (^parens (^bitand expr1 #xffff0000))
850                        (^parens (^bitand expr2 #xffff))))))
851
852    ((php python ruby java)
853     (univ-wrap ctx (^* expr1 expr2)))
854
855    (else
856     (compiler-internal-error
857      "univ-wrap*, unknown target"))))
858
859(define (univ-wrap/ ctx expr1 expr2)
860  (case (target-name (ctx-target ctx))
861
862   ((python php ruby)
863    ;; The default behavior is to round down, but it should round toward 0
864    (univ-wrap ctx (^float-toint (^parens (^/ expr1 (^float-fromint expr2))))))
865
866   (else (univ-wrap ctx (^/ expr1 expr2)))))
867
868(define (univ-emit-<< ctx expr1 expr2)
869  (case (target-name (ctx-target ctx))
870
871    ((js php python ruby java)
872     (^ expr1 " << " expr2))
873
874    (else
875     (compiler-internal-error
876      "univ-emit-<<, unknown target"))))
877
878(define (univ-emit->> ctx expr1 expr2)
879  (case (target-name (ctx-target ctx))
880
881    ((js php python ruby java)
882     (^ expr1 " >> " expr2))
883
884    (else
885     (compiler-internal-error
886      "univ-emit->>, unknown target"))))
887
888(define (univ-emit->>> ctx expr1 expr2)
889  (case (target-name (ctx-target ctx))
890
891    ((js java)
892     (^ expr1 " >>> " expr2))
893
894    ((python ruby php)
895     ;; These targets don't need >>>, but just in case...
896     (^bitand
897      (^>> expr1
898           expr2)
899      (^- (^parens
900           (^<< (^int 1)
901                (^- (^int univ-word-bits) expr2)))
902          (^int 1))))
903
904    (else
905     (compiler-internal-error
906      "univ-emit->>>, unknown target"))))
907
908(define (univ-emit-bitnot ctx expr)
909  (case (target-name (ctx-target ctx))
910
911    ((js php python ruby java)
912     (^ "~ " expr))
913
914    (else
915     (compiler-internal-error
916      "univ-emit-bitnot, unknown target"))))
917
918(define (univ-emit-bitand ctx expr1 expr2)
919  (case (target-name (ctx-target ctx))
920
921    ((js php python ruby java)
922     (^ expr1 " & " expr2))
923
924    (else
925     (compiler-internal-error
926      "univ-emit-bitand, unknown target"))))
927
928(define (univ-emit-bitior ctx expr1 expr2)
929  (case (target-name (ctx-target ctx))
930
931    ((js php python ruby java)
932     (^ expr1 " | " expr2))
933
934    (else
935     (compiler-internal-error
936      "univ-emit-bitior, unknown target"))))
937
938(define (univ-emit-bitxor ctx expr1 expr2)
939  (case (target-name (ctx-target ctx))
940
941    ((js php python ruby java)
942     (^ expr1 " ^ " expr2))
943
944    (else
945     (compiler-internal-error
946      "univ-emit-bitxor, unknown target"))))
947
948(define (univ-emit-= ctx expr1 expr2)
949  (case (target-name (ctx-target ctx))
950
951    ((js)
952     (^ expr1 " === " expr2))
953
954    ((python ruby php java)
955     (^ expr1 " == " expr2))
956
957    (else
958     (compiler-internal-error
959      "univ-emit-=, unknown target"))))
960
961(define (univ-emit-!= ctx expr1 expr2)
962  (case (target-name (ctx-target ctx))
963
964    ((js)
965     (^ expr1 " !== " expr2))
966
967    ((python ruby php java)
968     (^ expr1 " != " expr2))
969
970    (else
971     (compiler-internal-error
972      "univ-emit-!=, unknown target"))))
973
974(define (univ-emit-< ctx expr1 expr2)
975  (univ-emit-comparison ctx " < " expr1 expr2))
976
977(define (univ-emit-<= ctx expr1 expr2)
978  (univ-emit-comparison ctx " <= " expr1 expr2))
979
980(define (univ-emit-> ctx expr1 expr2)
981  (univ-emit-comparison ctx " > " expr1 expr2))
982
983(define (univ-emit->= ctx expr1 expr2)
984  (univ-emit-comparison ctx " >= " expr1 expr2))
985
986(define (univ-emit-comparison ctx comp expr1 expr2)
987  (case (target-name (ctx-target ctx))
988
989    ((js python ruby php java)
990     (^ expr1 comp expr2))
991
992    (else
993     (compiler-internal-error
994      "univ-emit-comparison, unknown target"))))
995
996(define (univ-emit-not ctx expr)
997  (case (target-name (ctx-target ctx))
998
999    ((js php ruby java)
1000     (^ "!" expr))
1001
1002    ((python)
1003     (^ "not " expr))
1004
1005    (else
1006     (compiler-internal-error
1007      "univ-emit-not, unknown target"))))
1008
1009(define (univ-emit-&& ctx expr1 expr2)
1010  (case (target-name (ctx-target ctx))
1011
1012    ((js ruby php java)
1013     (^ expr1 " && " expr2))
1014
1015    ((python)
1016     (^ expr1 " and " expr2))
1017
1018    (else
1019     (compiler-internal-error
1020      "univ-emit-&&, unknown target"))))
1021
1022(define (univ-emit-and ctx expr1 expr2)
1023  (case (target-name (ctx-target ctx))
1024
1025    ((js ruby java)
1026     (^ expr1 " && " expr2))
1027
1028    ((python)
1029     (^ expr1 " and " expr2))
1030
1031    ((php)
1032     (^ expr1 " ? " expr2 " : false"))
1033
1034    (else
1035     (compiler-internal-error
1036      "univ-emit-and, unknown target"))))
1037
1038(define (univ-emit-or ctx expr1 expr2)
1039  (case (target-name (ctx-target ctx))
1040
1041    ((js ruby php java)
1042     (^ expr1 " || " expr2)) ;; TODO: PHP || operator always yields a boolean
1043
1044    ((python)
1045     (^ expr1 " or " expr2))
1046
1047    (else
1048     (compiler-internal-error
1049      "univ-emit-or, unknown target"))))
1050
1051(define (univ-emit-concat ctx expr1 expr2)
1052  (case (target-name (ctx-target ctx))
1053
1054    ((js python ruby java)
1055     (^ expr1 " + " expr2))
1056
1057    ((php)
1058     (^ expr1 " . " expr2))
1059
1060    (else
1061     (compiler-internal-error
1062      "univ-emit-concat, unknown target"))))
1063
1064(define (univ-emit-tostr ctx expr)
1065  (case (target-name (ctx-target ctx))
1066
1067    ((js java)
1068     (^ expr ".toString()"))
1069
1070    ((python)
1071     (^ "str(" expr ")"))
1072
1073    ((php)
1074     (^ "(string)" expr))
1075
1076    ((ruby)
1077     (^ expr ".to_s"))
1078
1079    (else
1080     (compiler-internal-error
1081      "univ-emit-tostr, unknown target"))))
1082
1083(define (univ-emit-cast ctx type expr)
1084  (^parens (^ (^parens type) (^parens expr))))
1085
1086(define (univ-emit-cast* ctx type-name expr)
1087  (case (target-name (ctx-target ctx))
1088    ((java)
1089     (^cast (^type type-name) expr))
1090    (else
1091     expr)))
1092
1093(define (univ-emit-cast*-scmobj ctx expr)
1094  (^cast* 'scmobj expr))
1095
1096(define (univ-emit-cast*-jumpable ctx expr)
1097  (^cast* 'jumpable expr))
1098
1099(define (univ-emit-seq ctx expr1 expr2)
1100  (case (target-name (ctx-target ctx))
1101
1102    ((js java)
1103     (^parens (^ expr1 " , " expr2)))
1104
1105    ((ruby)
1106     (^parens (^ expr1 " ; " expr2)))
1107
1108    (else
1109     (compiler-internal-error
1110      "univ-emit-seq, unknown target"))))
1111
1112(define (univ-emit-parens ctx expr)
1113  (case (target-name (ctx-target ctx))
1114
1115    ((js ruby php python java)
1116     (^ "(" expr ")"))
1117
1118    (else
1119     (compiler-internal-error
1120      "univ-emit-parens, unknown target"))))
1121
1122(define (univ-emit-parens-php ctx expr)
1123  (if (eq? (target-name (ctx-target ctx)) 'php)
1124      (^parens expr)
1125      expr))
1126
1127(define (univ-emit-local-var ctx name)
1128  (case (target-name (ctx-target ctx))
1129
1130    ((js python ruby java)
1131     name)
1132
1133    ((php)
1134     (^ "$" name))
1135
1136    (else
1137     (compiler-internal-error
1138      "univ-emit-local-var, unknown target"))))
1139
1140(define (univ-emit-global-var ctx name)
1141  (case (target-name (ctx-target ctx))
1142
1143    ((js python java)
1144     name)
1145
1146    ((php ruby)
1147     (^ "$" name))
1148
1149    (else
1150     (compiler-internal-error
1151      "univ-emit-global-var, unknown target"))))
1152
1153(define (univ-emit-global-function ctx name)
1154  (case (target-name (ctx-target ctx))
1155
1156    ((js python java)
1157     name)
1158
1159    ((php ruby) name);;TODO: added
1160#;
1161    ((php ruby)
1162     (^ "$" name))
1163
1164    (else
1165     (compiler-internal-error
1166      "univ-emit-global-function, unknown target"))))
1167
1168(define (univ-emit-this-mod-field ctx name)
1169  (^mod-field (ctx-module-name ctx) name))
1170
1171(define (univ-emit-this-mod-method ctx name)
1172  (^mod-method (ctx-module-name ctx) name))
1173
1174(define (univ-emit-this-mod-jumpable ctx name)
1175  (^mod-jumpable (ctx-module-name ctx) name))
1176
1177(define (univ-emit-mod-member ctx mod-name name)
1178  (if (and (case (target-name (ctx-target ctx))
1179             ((js)
1180              #f)
1181             ((python)
1182              (not (eq? (univ-module-representation ctx) 'class)))
1183             (else
1184              #t))
1185           (eq? (ctx-module-name ctx) mod-name)) ;; optimize access to self
1186      name
1187      (case (target-name (ctx-target ctx))
1188
1189        ((js python ruby java)
1190         (^member (^prefix-class mod-name) name))
1191
1192        ((php)
1193         (^ (^prefix-class mod-name) "::" name))
1194
1195        (else
1196         (compiler-internal-error
1197          "univ-emit-mod-member, unknown target")))))
1198
1199(define (univ-emit-mod-field ctx mod-name name)
1200  (case (univ-module-representation ctx)
1201
1202    ((class)
1203     (tt"000"(univ-emit-mod-member ctx mod-name name)))
1204
1205    (else
1206     (tt"111"(^global-var (^prefix name))))))
1207
1208(define (univ-emit-mod-method ctx mod-name name)
1209  (case (univ-module-representation ctx)
1210
1211    ((class)
1212     (tt"222"(univ-emit-mod-member ctx mod-name name)))
1213
1214    (else
1215     (tt"333"(^global-function (^prefix name))))))
1216
1217(define (univ-mod-jumpable-is-field? ctx)
1218  (eq? (target-name (ctx-target ctx)) 'ruby))
1219
1220(define (univ-emit-mod-jumpable ctx mod-name name)
1221  (if (eq? (univ-procedure-representation ctx) 'class)
1222      (let ((x (^mod-field mod-name name)))
1223        (use-global ctx x)
1224        x)
1225      (if (univ-mod-jumpable-is-field? ctx)
1226          (^mod-field mod-name name)
1227          (univ-method-reference
1228           ctx
1229           (^mod-method mod-name name)))))
1230
1231(define (univ-emit-mod-class ctx mod-name name)
1232  (case (univ-module-representation ctx)
1233
1234    ((class)
1235     (tt"444"(univ-emit-mod-member ctx mod-name name)))
1236
1237    (else
1238     (tt"555"(^prefix-class name)))))
1239
1240(define (univ-emit-rts-method ctx name)
1241  (case (univ-module-representation ctx)
1242
1243    ((class)
1244     (tt"666"name))
1245
1246    (else
1247     (tt"777"(^global-function (^prefix name))))))
1248
1249(define (univ-emit-rts-method-ref ctx name)
1250  (case (univ-module-representation ctx)
1251
1252    ((class)
1253     (tt"66"(univ-emit-mod-member ctx (univ-rts-module-name ctx) name)))
1254
1255    (else
1256     (tt"77"(^global-function (^prefix name))))))
1257
1258(define (univ-emit-rts-method-use ctx name)
1259  (univ-use-rtlib ctx name)
1260  (univ-emit-rts-method-ref ctx name))
1261
1262(define (univ-emit-rts-field ctx name)
1263  (case (univ-module-representation ctx)
1264
1265    ((class)
1266     (tt"888"name))
1267
1268    (else
1269     (tt"999"(^global-var (^prefix name))))))
1270
1271(define (univ-emit-rts-field-ref ctx name)
1272  (case (univ-module-representation ctx)
1273
1274    ((class)
1275     (tt"88"(univ-emit-mod-member ctx (univ-rts-module-name ctx) name)))
1276
1277    (else
1278     (tt"99"(^global-var (^prefix name))))))
1279
1280(define (univ-emit-rts-field-use ctx name)
1281  (univ-use-rtlib ctx name)
1282  (let ((x (univ-emit-rts-field-ref ctx name)))
1283    (use-global ctx x)
1284    x))
1285
1286(define (univ-emit-rts-jumpable-use ctx name)
1287  (univ-use-rtlib ctx name)
1288  (^mod-jumpable (univ-rts-module-name ctx) name))
1289
1290(define (univ-emit-rts-class ctx name)
1291  (let ((real-name (univ-rts-type-alias ctx name)))
1292    (case (univ-module-representation ctx)
1293
1294      ((class)
1295       (tt"0"(univ-emit-mod-member ctx (univ-rts-module-name ctx) real-name)))
1296
1297      (else
1298       (tt"1"(^prefix-class real-name))))))
1299
1300(define (univ-emit-rts-class-ref ctx name)
1301  (let ((real-name (univ-rts-type-alias ctx name)))
1302    (case (univ-module-representation ctx)
1303
1304      ((class)
1305       (tt"00"(univ-emit-mod-member ctx (univ-rts-module-name ctx) real-name)))
1306
1307      (else
1308       (tt"11"(^prefix-class real-name))))))
1309
1310(define (univ-emit-rts-class-use ctx name)
1311  (univ-use-rtlib ctx name)
1312  (univ-emit-rts-class-ref ctx name))
1313
1314(define (univ-rts-module-name ctx)
1315  (case (target-name (ctx-target ctx))
1316
1317    ((js php python ruby java)
1318     "RTS")
1319
1320    (else
1321     (compiler-internal-error
1322      "univ-rts-module-name, unknown target"))))
1323
1324(define (univ-emit-prefix ctx name)
1325  (case (univ-module-representation ctx)
1326
1327    ((class)
1328     name)
1329
1330    (else
1331     (^ (ctx-ns-prefix ctx) name))))
1332
1333(define (univ-emit-prefix-class ctx name)
1334  (case (univ-module-representation ctx)
1335
1336;    ((class)
1337;     name)
1338
1339    (else
1340     (^ (ctx-ns-prefix-class ctx) name))))
1341
1342(define (univ-emit-assign-expr ctx loc expr)
1343  (^ loc " = " expr))
1344
1345(define (univ-emit-assign ctx loc expr)
1346  (^expr-statement
1347   (^assign-expr loc expr)))
1348
1349(define (univ-emit-inc-by ctx loc expr #!optional (embed #f))
1350
1351  (define (embed-read x)
1352    (if embed
1353        (embed x)
1354        (^)))
1355
1356  (define (embed-expr x parens?)
1357    (if embed
1358        (embed (if parens? (^parens x) x))
1359        (^expr-statement x)))
1360
1361  (define (inc-general loc expr)
1362    (if (and (number? expr) (< expr 0))
1363        (^ loc " -= " (- expr))
1364        (^ loc " += " expr)))
1365
1366  (if (equal? expr 0)
1367
1368      (embed-read loc)
1369
1370      (case (target-name (ctx-target ctx))
1371
1372        ((js php java)
1373         (cond ((equal? expr 1)
1374                (embed-expr (^ "++" loc) #f))
1375               ((equal? expr -1)
1376                (embed-expr (^ "--" loc) #f))
1377               (else
1378                (embed-expr (inc-general loc expr)
1379                            (eq? (target-name (ctx-target ctx)) 'php)))))
1380
1381        ((python)
1382         (^ (^expr-statement (inc-general loc expr))
1383            (embed-read loc)))
1384
1385        ((ruby)
1386         (embed-expr (inc-general loc expr) #t))
1387
1388        (else
1389         (compiler-internal-error
1390          "univ-emit-inc-by, unknown target")))))
1391
1392(define (univ-emit-alias ctx expr)
1393  (case (target-name (ctx-target ctx))
1394
1395    ((js python ruby java)
1396     expr)
1397
1398    ((php)
1399     (^ "&" expr))
1400
1401    (else
1402     (compiler-internal-error
1403      "univ-emit-alias, unknown target"))))
1404
1405(define (univ-emit-unalias ctx expr)
1406  (case (target-name (ctx-target ctx))
1407
1408    ((js python ruby java)
1409     (^))
1410
1411    ((php)
1412     (^expr-statement
1413      (^ "unset(" expr ")")))
1414
1415    (else
1416     (compiler-internal-error
1417      "univ-emit-unalias, unknown target"))))
1418
1419(define (univ-emit-array? ctx expr)
1420  (case (target-name (ctx-target ctx))
1421
1422    ((js ruby)
1423     (^instanceof "Array" expr))
1424
1425    ((php)
1426     (^call-prim "is_array" expr))
1427
1428    ((python)
1429     (^instanceof "list" expr))
1430
1431    ((java)
1432     (^ expr ".getClass().isArray()"))
1433
1434    (else
1435     (compiler-internal-error
1436      "univ-emit-array?, unknown target"))))
1437
1438(define (univ-emit-array-length ctx expr)
1439  (case (target-name (ctx-target ctx))
1440
1441    ((js ruby java)
1442     (^ expr ".length"))
1443
1444    ((php)
1445     (^ "count(" expr ")"))
1446
1447    ((python)
1448     (^ "len(" expr ")"))
1449
1450    (else
1451     (compiler-internal-error
1452      "univ-emit-array-length, unknown target"))))
1453
1454(define (univ-emit-array-shrink! ctx expr1 expr2)
1455  (case (target-name (ctx-target ctx))
1456
1457    ((js)
1458     (^assign (^ expr1 ".length") expr2))
1459
1460    ((php)
1461     (^expr-statement
1462      (^call-prim 'array_splice expr1 expr2)))
1463
1464    ((python)
1465     (^expr-statement
1466      (^ expr1 "[" expr2 ":] = []")))
1467
1468    ((ruby)
1469     (^expr-statement
1470      (^ expr1 ".slice!(" expr2 "," expr1 ".length)")))
1471
1472    ((java)
1473     ;; assumes expr1 is an lvalue, and creates a copy of the array
1474     (^assign expr1 (^subarray expr1 0 expr2)))
1475
1476    (else
1477     (compiler-internal-error
1478      "univ-emit-array-shrink!, unknown target"))))
1479
1480(define (univ-emit-array-shrink-possibly-copy! ctx expr1 expr2)
1481  (case (target-name (ctx-target ctx))
1482
1483    ((js)
1484     (^seq
1485      (^assign-expr (^member expr1 'length) expr2)
1486      expr1))
1487
1488    ((php)
1489     (^call-prim 'array_splice expr1 (^int 0) expr2))
1490
1491    ((python java)
1492     (^subarray expr1 (^int 0) expr2))
1493
1494    ((ruby)
1495     (^seq
1496      (^call-prim (^member expr1 'slice!) expr2 (^member expr1 'length))
1497      expr1))
1498
1499    (else
1500     (compiler-internal-error
1501      "univ-emit-array-shrink-possibly-copy!, unknown target"))))
1502
1503(define (univ-emit-move-array-to-array ctx array1 srcpos array2 destpos len)
1504  (case (target-name (ctx-target ctx))
1505
1506    ((java)
1507     (^expr-statement
1508      (^call-prim
1509       (^member 'System 'arraycopy)
1510       array1
1511       srcpos
1512       array2
1513       destpos
1514       len)))
1515
1516    (else
1517     (compiler-internal-error
1518      "univ-emit-move-array-to-array, unknown target"))))
1519
1520(define (univ-emit-copy-array-to-extensible-array ctx expr len)
1521  (case (target-name (ctx-target ctx))
1522
1523    ((js php ruby java)
1524     (^subarray expr 0 len))
1525
1526    ((python)
1527     (^ "dict(zip(range(" len ")," expr "))"))
1528
1529    (else
1530     (compiler-internal-error
1531      "univ-emit-array-to-extensible-array, unknown target"))))
1532
1533(define (univ-emit-extensible-array-to-array! ctx var len)
1534  (case (target-name (ctx-target ctx))
1535
1536    ((js php ruby java)
1537     (^))
1538
1539    ((python)
1540     (^assign var (^ "[" var "[i] for i in range(" len ")]")))
1541
1542    (else
1543     (compiler-internal-error
1544      "univ-emit-extensible-array-to-array!, unknown target"))))
1545
1546(define (univ-emit-extensible-subarray ctx expr start len)
1547   (case (target-name (ctx-target ctx))
1548
1549    ((js ruby php java) (^subarray expr start len))
1550
1551    ((python)
1552     (^ "[" expr "[i] for i in range("
1553                  (if (eq? start 0)
1554                      len
1555                      (^ start ", " (^+ start len)))
1556                ")]"))
1557    (else
1558     (compiler-internal-error
1559      "univ-emit-extensible-subarray, unknown target"))))
1560
1561(define (univ-emit-subarray ctx expr1 expr2 expr3)
1562  (case (target-name (ctx-target ctx))
1563
1564    ((js)
1565     (^call-prim (^member expr1 'slice)
1566                 expr2
1567                 (if (equal? expr2 0) expr3 (^+ expr2 expr3))))
1568
1569    ((php)
1570     (^call-prim 'array_slice expr1 expr2 expr3))
1571
1572    ((python)
1573     (^ expr1 "[" expr2 ":" (if (equal? expr2 0) expr3 (^+ expr2 expr3)) "]"))
1574
1575    ((ruby)
1576     (^call-prim (^member expr1 'slice)
1577                 expr2
1578                 (if (equal? expr2 0) expr3 (^+ expr2 expr3))))
1579
1580    ((java)
1581     (^call-prim (^member 'Arrays 'copyOfRange)
1582                 expr1
1583                 expr2
1584                 (if (equal? expr2 0) expr3 (^+ expr2 expr3))))
1585
1586    (else
1587     (compiler-internal-error
1588      "univ-emit-subarray, unknown target"))))
1589
1590(define (univ-emit-array-index ctx expr1 expr2)
1591  (^ expr1 "[" expr2 "]"))
1592
1593(define (univ-emit-prop-index ctx expr1 expr2 expr3)
1594  (if expr3
1595      (^if-expr (^prop-index-exists? expr1 expr2)
1596                (^prop-index expr1 expr2)
1597                expr3)
1598      (^ expr1 "[" expr2 "]")))
1599
1600(define (univ-emit-prop-index-exists? ctx expr1 expr2)
1601  (case (target-name (ctx-target ctx))
1602
1603    ((js)
1604     (^ "Object.prototype.hasOwnProperty.call(" expr1 "," expr2 ")"))
1605
1606    ((php)
1607     (^ "array_key_exists(" expr2 "," expr1 ")"))
1608
1609    ((python)
1610     (^ expr2 " in " expr1))
1611
1612    ((ruby)
1613     (^ expr1 ".has_key?(" expr2 ")"))
1614
1615    (else
1616     (compiler-internal-error
1617      "univ-emit-prop-index-exists?, unknown target"))))
1618
1619(define (univ-emit-get ctx obj name)
1620  (case (target-name (ctx-target ctx))
1621
1622    ((js python ruby)
1623     (^prop-index obj (^str name)))
1624
1625    ((php)
1626     (^call-prim
1627      (^rts-method-use 'get)
1628      obj
1629      (^str name)))
1630
1631    (else
1632     (compiler-internal-error
1633      "univ-emit-get, unknown target"))))
1634
1635(define (univ-emit-set ctx obj name val)
1636  (case (target-name (ctx-target ctx))
1637
1638    ((js python ruby)
1639     (^assign-expr (^prop-index obj (^str name)) val))
1640
1641    ((php)
1642     (^call-prim
1643      (^rts-method-use 'set)
1644      obj
1645      (^str name)
1646      val))
1647
1648    (else
1649     (compiler-internal-error
1650      "univ-emit-set, unknown target"))))
1651
1652(define (univ-emit-attribute-exists? ctx expr1 expr2)
1653  (case (target-name (ctx-target ctx))
1654
1655    ((js)
1656     (^ "Object.prototype.hasOwnProperty.call(" expr1 "," expr2 ")"))
1657
1658    ((php)
1659     (^call-prim 'property_exists expr1 expr2))
1660
1661    ((python)
1662     (^call-prim 'hasattr expr1 expr2))
1663
1664    ((ruby)
1665     (^call-prim
1666      (^member expr1 'instance_variable_defined?) (^ ":@" expr2)))
1667
1668    (else
1669     (compiler-internal-error
1670      "univ-emit-prop-index-exists?, unknown target"))))
1671
1672;; ***** DUMPING OF A COMPILATION MODULE
1673
1674(define (univ-dump targ procs output c-intf module-descr linker-name sem-changing-options sem-preserving-options)
1675  (let ((code
1676         (univ-dump-code targ procs output c-intf module-descr linker-name sem-changing-options sem-preserving-options)))
1677    (univ-display-to-file code output)
1678    (lambda () output)))
1679
1680(define (univ-dump-code targ procs output c-intf module-descr linker-name sem-changing-options sem-preserving-options)
1681  (let* ((module-name-str
1682          (symbol->string (vector-ref module-descr 0)))
1683
1684         (module-name
1685          (scheme-id->c-id module-name-str))
1686
1687         (module-proc
1688          (list-ref procs 0))
1689
1690         (ctx
1691          (make-ctx
1692           targ
1693           sem-changing-options
1694           sem-preserving-options
1695           module-name
1696           (univ-ns-prefix sem-changing-options)
1697           (univ-ns-prefix-class sem-changing-options)
1698           "zzz" ;;;;;;;;;;;;;;;;;
1699           (make-objs-used)
1700           (make-resource-set)
1701           (make-table)
1702           (queue-empty)))
1703
1704         (defs-procs
1705           (univ-dump-procs ctx procs))
1706
1707         (code-module
1708          (univ-defs->code
1709           ctx
1710           (^prefix-class module-name)
1711           (univ-defs-combine
1712            (univ-objs-defs ctx)
1713            (univ-defs-combine
1714             defs-procs
1715             (univ-module-register ctx module-descr)))))
1716
1717         (code-decls
1718          (queue->list (ctx-decls ctx)))
1719
1720         (rtlib-features
1721          (resource-set-stack (ctx-rtlib-features-used ctx))))
1722
1723    (^ (univ-link-info-header
1724        ctx
1725        module-name-str
1726        (list (list module-name-str))
1727        rtlib-features
1728        (ctx-glo-used ctx)
1729        #f)
1730       code-decls
1731       code-module
1732       (univ-link-info-footer ctx))))
1733
1734(define (univ-module-register ctx module-descr)
1735  (univ-add-init
1736   (univ-make-empty-defs)
1737   (lambda (ctx)
1738     (^expr-statement
1739      (^call-prim (^rts-method-use 'module_register)
1740                  (^obj module-descr))))))
1741
1742(define (univ-defs->code ctx root-name defs)
1743  (univ-emit-defs
1744   ctx
1745   #t
1746   (case (univ-module-representation ctx)
1747
1748     ((class)
1749      (let ((class-fields
1750             (reverse (univ-defs-fields defs)))
1751            (instance-fields
1752             '())
1753            (class-methods
1754             (reverse (univ-defs-methods defs)))
1755            (instance-methods
1756             '())
1757            (class-classes
1758             (reverse (univ-defs-classes defs)))
1759            (inits
1760             (reverse (univ-defs-inits defs))))
1761        (univ-add-class
1762         (univ-make-empty-defs)
1763         (univ-class
1764          root-name ;; root-name
1765          '()       ;; properties
1766          #f        ;; extends
1767          class-fields
1768          '() ;; instance-fields
1769          class-methods
1770          '() ;; instance-methods
1771          class-classes
1772          #f ;; constructor
1773          inits))))
1774
1775     (else
1776      defs))))
1777
1778(define (univ-link-info-header ctx name mods-and-flags rtlib-features-used glo-used module-meta-info)
1779  (let ((glos (table->list glo-used)))
1780    (^ (univ-link-info-prefix (target-name (ctx-target ctx)))
1781       (object->string
1782        (list (compiler-version)
1783              (list (target-name (ctx-target ctx))
1784                    (ctx-semantics-changing-options ctx))
1785              name
1786              mods-and-flags
1787              rtlib-features-used
1788              (map car (keep (lambda (x) (not (eq? (cdr x) 'wr))) glos))
1789              (map car (keep (lambda (x) (not (eq? (cdr x) 'rd))) glos))
1790              (map car (keep (lambda (x) (eq? (cdr x) 'rdwr)) glos))
1791              module-meta-info))
1792       "\n\n"
1793       (univ-external-libs ctx))))
1794
1795(define (univ-link-info-footer ctx)
1796  (univ-source-file-footer (target-name (ctx-target ctx))))
1797
1798(define (univ-link-info targ file)
1799  (let ((in (open-input-file*-preserving-case file)))
1800    (and in
1801         (let* ((pref
1802                 (univ-link-info-prefix (target-name targ)))
1803                (info
1804                 (let loop ((i 0))
1805                   (if (< i (string-length pref))
1806                       (let ((c (read-char in)))
1807                         (if (or (eof-object? c)
1808                                 (not (char=? c (string-ref pref i))))
1809                             #f
1810                             (loop (+ i 1))))
1811                       (read in)))))
1812           (close-input-port in)
1813           (and (pair? info)
1814                (pair? (cdr info))
1815                (pair? (cadr info))
1816                (equal? (car info) (compiler-version))
1817                (equal? (car (cadr info)) (target-name targ))
1818                info)))))
1819
1820(define (univ-link-semantics-changing-options inputs warnings?)
1821
1822  (define (sem-changing-opts x)
1823    (let ((info (caddr x)))
1824      (cadr (list-ref info 1))))
1825
1826  (let* ((rev-inputs (reverse inputs))
1827         (first (car rev-inputs)))
1828    (if warnings?
1829        (let loop ((lst (cdr rev-inputs)))
1830          (if (pair? lst)
1831              (let ((input (car inputs)))
1832                (if (not (equal? (sem-changing-opts first)
1833                                 (sem-changing-opts input)))
1834                    (compiler-user-warning #f "inconsistent semantics changing options for files" (car first) (car input)))
1835                (loop (cdr lst))))))
1836    (sem-changing-opts first)))
1837
1838(define (univ-link-mods-and-flags inputs)
1839
1840  (define (m-and-f x)
1841    (let ((info (caddr x)))
1842      (list-ref info 3)))
1843
1844  (let ((rev-inputs (reverse inputs)))
1845    (let loop ((lst rev-inputs) (mods-and-flags '()))
1846      (if (pair? lst)
1847          (let ((info (caddr (car lst))))
1848            (loop (cdr lst)
1849                  (append (list-ref info 3) mods-and-flags)))
1850          mods-and-flags))))
1851
1852(define (univ-link-features-used ctx inputs warnings?)
1853
1854  (for-each (lambda (x)
1855              (let ((info (caddr x)))
1856                (for-each (lambda (feature)
1857                            (univ-use-rtlib ctx feature))
1858                          (list-ref info 4))
1859                (for-each (lambda (name)
1860                            (univ-glo-use ctx name 'rd))
1861                          (list-ref info 5))
1862                (for-each (lambda (name)
1863                            (univ-glo-use ctx name 'wr))
1864                          (list-ref info 6))
1865                (for-each (lambda (name)
1866                            (univ-glo-use ctx name 'rd)
1867                            (univ-glo-use ctx name 'wr))
1868                          (list-ref info 7))))
1869            (reverse inputs))
1870
1871  (if warnings?
1872
1873      (let ((undefs (make-table)))
1874
1875        (for-each (lambda (x)
1876                    (let ((info (caddr x))
1877                          (t (ctx-glo-used ctx)))
1878                      (for-each (lambda (name)
1879                                  (let ((dir (table-ref t name 'rd)))
1880                                    (if (eq? dir 'rd)
1881                                        (let ((files (table-ref undefs name '())))
1882                                          (table-set! undefs name (cons (car x) files))))))
1883                                (list-ref info 5))))
1884                  (reverse inputs))
1885
1886        (for-each (lambda (x)
1887                    (let ((name (car x))
1888                          (files (cdr x)))
1889                      (display "*** WARNING -- \"")
1890                      (display (symbol->string name))
1891                      (display "\" is not defined,")
1892                      (newline)
1893                      (display "***            referenced in: ")
1894                      (write files)
1895                      (newline)))
1896                  (table->list undefs))))
1897
1898  (if (and warnings? univ-all-warnings)
1899
1900      (let ((unrefs (make-table)))
1901
1902        (for-each (lambda (x)
1903                    (let ((info (caddr x))
1904                          (t (ctx-glo-used ctx)))
1905                      (for-each (lambda (name)
1906                                  (let ((dir (table-ref t name 'wr)))
1907                                    (if (eq? dir 'wr)
1908                                        (let ((files (table-ref unrefs name '())))
1909                                          (table-set! unrefs name (cons (car x) files))))))
1910                                (list-ref info 6))))
1911                  (reverse inputs))
1912
1913        (for-each (lambda (x)
1914                    (let ((name (car x))
1915                          (files (cdr x)))
1916                      (display "*** WARNING -- \"")
1917                      (display (symbol->string name))
1918                      (display "\" is defined but not referenced,")
1919                      (newline)
1920                      (display "***            defined in: ")
1921                      (write files)
1922                      (newline)))
1923                  (table->list unrefs)))))
1924
1925(define univ-all-warnings #t)
1926(set! univ-all-warnings #f)
1927
1928(define (univ-link targ extension? inputs output linker-name warnings?)
1929  (let* ((root
1930          (path-strip-extension output))
1931
1932         (name
1933          (path-strip-directory root))
1934
1935         (sem-changing-options
1936          (univ-link-semantics-changing-options inputs warnings?))
1937
1938         (mods-and-flags
1939          (univ-link-mods-and-flags inputs))
1940
1941         (ctx
1942          (make-ctx
1943           targ
1944           sem-changing-options
1945           '() ;; semantics-preserving-options
1946           ""  ;; module-name filled in later
1947           (univ-ns-prefix sem-changing-options)
1948           (univ-ns-prefix-class sem-changing-options)
1949           "zzz" ;;;;;;;;;;;;
1950           (make-objs-used)
1951           (make-resource-set)
1952           (make-table)
1953           (queue-empty)))
1954
1955         (_
1956          (ctx-module-name-set! ctx (univ-rts-module-name ctx)))
1957
1958         (rtlib-init
1959          (univ-rtlib-init ctx mods-and-flags))
1960
1961         (_
1962          (univ-link-features-used ctx inputs warnings?))
1963
1964         (features-used
1965          (resource-set-stack (ctx-rtlib-features-used ctx)))
1966
1967         (code-entry
1968          (case (target-name targ)
1969            ((java)
1970             (univ-defs->code
1971              ctx
1972              name
1973              (univ-entry-defs ctx mods-and-flags)))
1974            (else
1975             (^))))
1976
1977         (code-rtlib
1978          (univ-defs->code
1979           ctx
1980           (^prefix-class (univ-rts-module-name ctx))
1981           (univ-rtlib-defs ctx rtlib-init)))
1982
1983         (code-decls
1984          (queue->list (ctx-decls ctx)))
1985
1986         (code
1987          (^ (univ-link-info-header
1988              ctx
1989              name
1990              mods-and-flags
1991              features-used
1992              (ctx-glo-used ctx)
1993              #f)
1994             code-entry
1995             code-rtlib
1996             code-decls
1997             (univ-link-info-footer ctx))))
1998
1999    (univ-display-to-file code output)
2000
2001    output))
2002
2003;;TODO: add constants
2004#;
2005(define (univ-module-header ctx)
2006  (^ (^var-declaration 'scmobj (gvm-state-cst ctx) (^extensible-array-literal 'scmobj '()))
2007     "\n"))
2008
2009(define (univ-objs-defs ctx)
2010  (let* ((objs-used (ctx-objs-used ctx))
2011         (stack (reverse (objs-used-stack objs-used)))
2012         (table (objs-used-table objs-used)))
2013    (let loop ((lst stack) (defs (univ-make-empty-defs)))
2014      (if (pair? lst)
2015          (loop (cdr lst)
2016                (let ((obj (car lst)))
2017                  (if (proc-obj? obj)
2018                      defs
2019                      (let ((state (table-ref table obj)))
2020                        (if (or (> (vector-ref state 0) 1) ;; use a variable?
2021                                (eq? (target-name (ctx-target ctx)) 'python)) ;; Python can't handle deep nestings
2022                            (let ((cst
2023                                   (vector-ref state 2))
2024                                  (val
2025                                   (car (vector-ref state 1))))
2026                              ;;(pp (list cst obj));;;;;;;;;;;;;;;
2027                              (set-car! (vector-ref state 1)
2028                                        (^this-mod-field cst))
2029                              (univ-add-field
2030                               defs
2031                               (univ-field
2032                                cst
2033                                'scmobj ;; (univ-obj-type obj)
2034                                val
2035                                '(public))))
2036                            defs)))))
2037          defs))))
2038
2039(define (univ-obj-use ctx obj force-var? gen-expr)
2040
2041  (define (use-cst cst)
2042    (if (not (eq? (univ-module-representation ctx) 'class))
2043        (use-global ctx (^this-mod-field cst))))
2044
2045  (let* ((objs-used (ctx-objs-used ctx))
2046         (table (objs-used-table objs-used))
2047         (state (table-ref table obj #f)))
2048    (if state ;; don't add to table if obj was added before
2049
2050        (begin
2051          (use-cst (vector-ref state 2))
2052          (vector-set! state 0 (+ (vector-ref state 0) 1)) ;; increment reference count
2053          (vector-ref state 1))
2054
2055        (let* ((code
2056                (list #f))
2057               (cst
2058                (string->symbol
2059                 (string-append
2060                  "cst"
2061                  (number->string (table-length table))
2062                  (if (eq? (univ-module-representation ctx) 'class)
2063                      ""
2064                      (string-append "_" (ctx-module-name ctx))))))
2065               (state
2066                (vector (if force-var? 2 1) code cst)))
2067          (use-cst cst)
2068          (table-set! table obj state)
2069          (set-car! code (gen-expr))
2070          (let ((stack (objs-used-stack objs-used)))
2071            (objs-used-stack-set! objs-used (cons obj stack)))
2072          code))))
2073
2074(define (make-objs-used)
2075  (vector '()
2076          (make-table test: eq?)))
2077
2078(define (objs-used-stack ou)        (vector-ref ou 0))
2079(define (objs-used-stack-set! ou x) (vector-set! ou 0 x))
2080
2081(define (objs-used-table ou)        (vector-ref ou 1))
2082(define (objs-used-table-set! ou x) (vector-set! ou 1 x))
2083
2084(define (univ-dump-procs global-ctx procs)
2085
2086  (let ((proc-seen (queue-empty))
2087        (proc-left (queue-empty)))
2088
2089    (define (scan-obj obj)
2090      (if (and (proc-obj? obj)
2091               (proc-obj-code obj)
2092               (not (memq obj (queue->list proc-seen))))
2093          (begin
2094            (queue-put! proc-seen obj)
2095            (queue-put! proc-left obj))))
2096
2097    (define (dump-proc p)
2098
2099      (define ctrlpts
2100        (make-stretchable-vector #f))
2101
2102      (define ctrlpts-init
2103        (list #f))
2104
2105      (define (scan-bbs ctx bbs)
2106        (let* ((bb-done (make-stretchable-vector #f))
2107               (bb-todo (queue-empty)))
2108
2109          (define (todo-lbl-num! n)
2110            (queue-put! bb-todo (lbl-num->bb n bbs)))
2111
2112          (define (scan-bb ctx bb)
2113            (if (stretchable-vector-ref bb-done (bb-lbl-num bb))
2114                (univ-make-empty-defs)
2115                (begin
2116                  (stretchable-vector-set! bb-done (bb-lbl-num bb) #t)
2117                  (scan-bb-all ctx bb))))
2118
2119          (define (scan-bb-all ctx bb)
2120            (scan-gvm-label
2121             ctx
2122             (bb-label-instr bb)
2123             (lambda (ctx)
2124               (scan-bb-all-except-label ctx bb))))
2125
2126          (define (scan-bb-all-except-label ctx bb)
2127            (let loop ((lst (bb-non-branch-instrs bb))
2128                       (rev-res '()))
2129              (if (pair? lst)
2130                  (loop (cdr lst)
2131                        (cons (scan-gvm-instr ctx (car lst))
2132                              rev-res))
2133                  (reverse
2134                   (cons (scan-gvm-instr ctx (bb-branch-instr bb))
2135                         rev-res)))))
2136
2137          (define (scan-gvm-label ctx gvm-instr proc)
2138
2139            (define (frame-info gvm-instr)
2140              (let* ((frame
2141                      (gvm-instr-frame gvm-instr))
2142                     (fs
2143                      (frame-size frame))
2144                     (vars
2145                      (reverse (frame-slots frame)))
2146                     (link
2147                      (pos-in-list ret-var vars)))
2148                (vector fs link)))
2149
2150            (with-stack-base-offset
2151             ctx
2152             (- (frame-size (gvm-instr-frame gvm-instr)))
2153             (lambda (ctx)
2154               (let* ((id
2155                       (gvm-bb-use ctx (label-lbl-num gvm-instr) (ctx-ns ctx)))
2156                      (header
2157                       (case (label-type gvm-instr)
2158
2159                         ((simple)
2160                          (^ "\n"))
2161
2162                         ((entry)
2163                          (if (label-entry-rest? gvm-instr)
2164                              (^ " "
2165                                 (univ-emit-comment
2166                                  ctx
2167                                  (if (label-entry-closed? gvm-instr)
2168                                      "closure-entry-point (+rest)\n"
2169                                      "entry-point (+rest)\n")))
2170                              (^ " "
2171                                 (univ-emit-comment
2172                                  ctx
2173                                  (if (label-entry-closed? gvm-instr)
2174                                      "closure-entry-point\n"
2175                                      "entry-point\n")))))
2176
2177                         ((return)
2178                          (^ " "
2179                             (univ-emit-comment ctx "return-point\n")))
2180
2181                         ((task-entry)
2182                          (^ " "
2183                             (univ-emit-comment ctx "task-entry-point\n")))
2184
2185                         ((task-return)
2186                          (^ " "
2187                             (univ-emit-comment ctx "task-return-point\n")))
2188
2189                         (else
2190                          (compiler-internal-error
2191                           "scan-gvm-label, unknown label type"))))
2192                      (gen-body
2193                       (lambda (ctx)
2194                         (^ (case (label-type gvm-instr)
2195
2196                              ((entry)
2197                               (univ-label-entry ctx
2198                                                 gvm-instr
2199                                                 (^mod-jumpable
2200                                                  (ctx-module-name ctx)
2201                                                  id)))
2202
2203                              (else
2204                               (^)))
2205
2206                            (proc ctx))))
2207                      (entry
2208                       (bbs-entry-lbl-num bbs))
2209                      (lbl-num
2210                       (label-lbl-num gvm-instr)))
2211
2212                 (univ-jumpable-declaration-defs
2213
2214                  ctx
2215
2216                  ;; global?
2217                  #t
2218
2219                  ;; name
2220                  id
2221
2222                  ;; jumpable-type
2223                  (case (label-type gvm-instr)
2224                    ((entry)  (if (= lbl-num entry)
2225                                  'parententrypt
2226                                  'entrypt))
2227                    ((return) 'returnpt)
2228                    (else     'ctrlpt))
2229
2230                  ;; params
2231                  '()
2232
2233                  ;; attribs
2234                  (if (memq (label-type gvm-instr) '(entry return))
2235
2236                      (append
2237
2238                       (let ((ctrlpt-id
2239                              (stretchable-vector-length ctrlpts)))
2240                         (stretchable-vector-set!
2241                          ctrlpts
2242                          ctrlpt-id
2243                          lbl-num)
2244                         (list (univ-field 'id
2245                                           'int
2246                                           (^int ctrlpt-id)
2247                                           '(inherited))
2248                               (univ-field 'parent
2249                                           'parententrypt
2250                                           (let ((entry? (= lbl-num entry)))
2251                                             (cond ((and entry?
2252                                                         (univ-parent-entry-point-has-null-parent? ctx))
2253                                                    (^null))
2254                                                   ((and entry?
2255                                                         (eq? (univ-procedure-representation ctx) 'class))
2256                                                    (^this))
2257                                                   (else
2258                                                    (let ((the-ns (ctx-ns ctx)))
2259                                                      (lambda (ctx2)
2260                                                        (let ((ns (ctx-ns ctx2)))
2261                                                          (ctx-ns-set! ctx2 the-ns)
2262                                                          (let ((x (univ-ctrlpt-reference
2263                                                                    ctx2
2264                                                                    entry)))
2265                                                            (ctx-ns-set! ctx2 ns)
2266                                                            x)))))))
2267                                           '(inherited))))
2268
2269                       (if (eq? (label-type gvm-instr) 'return)
2270
2271                           (let ((info (frame-info gvm-instr)))
2272                             (list (univ-field 'fs
2273                                               'int
2274                                               (^int (vector-ref info 0))
2275                                               '(inherited))
2276                                   (univ-field 'link
2277                                               'int
2278                                               (^int (+ (vector-ref info 1) 1))
2279                                               '(inherited))))
2280
2281                           (append
2282                            (list (univ-field
2283                                   'nfree
2284                                   'int
2285                                   (if (label-entry-closed? gvm-instr)
2286                                       (let* ((frame (gvm-instr-frame gvm-instr))
2287                                              (nfree (length (frame-closed frame))))
2288                                         (^int nfree))
2289                                       (^int -1))
2290                                   '(inherited)))
2291                            (if (= lbl-num entry)
2292                                (list (univ-field (univ-proc-name-attrib ctx)
2293                                                  'symbol
2294                                                  (lambda (ctx)
2295                                                    (univ-prm-name ctx (proc-obj-name p)))
2296                                                  '(inherited))
2297                                      (univ-field 'ctrlpts
2298                                                  '(array ctrlpt)
2299                                                  ctrlpts-init
2300                                                  '(inherited))
2301                                      (univ-field 'info
2302                                                  'scmobj
2303                                                  (^obj #f) ;; TODO
2304                                                  '(inherited)))
2305                                '()))))
2306
2307                      '())
2308
2309                  ;; body
2310                  (univ-emit-fn-body ctx header gen-body))))))
2311
2312          (define (unwind-stack? gvm-instr)
2313            (let ((node (comment-get (gvm-instr-comment gvm-instr) 'node)))
2314              (and node (not (intrs-enabled? (node-env node))) 'unwind)))
2315
2316          (define (scan-gvm-instr ctx gvm-instr)
2317
2318            ;; TODO: combine with scan-gvm-opnd
2319            (define (scan-opnd gvm-opnd)
2320              (cond ((not gvm-opnd))
2321                    ((lbl? gvm-opnd)
2322                     (todo-lbl-num! (lbl-num gvm-opnd)))
2323                    ((obj? gvm-opnd)
2324                     (scan-obj (obj-val gvm-opnd)))
2325                    ((clo? gvm-opnd)
2326                     (scan-opnd (clo-base gvm-opnd)))))
2327
2328            ;;(write-gvm-instr gvm-instr ##stderr-port)(newline ##stderr-port);;;;;;;;;;;;;;;;;;
2329
2330            ;; TODO: combine with scan-gvm-opnd
2331            (case (gvm-instr-type gvm-instr)
2332
2333              ((apply)
2334               (for-each scan-opnd (apply-opnds gvm-instr))
2335               (if (apply-loc gvm-instr)
2336                   (scan-opnd (apply-loc gvm-instr))))
2337
2338              ((copy)
2339               (scan-opnd (copy-opnd gvm-instr))
2340               (scan-opnd (copy-loc gvm-instr)))
2341
2342              ((close)
2343               (for-each (lambda (parms)
2344                           (scan-opnd (closure-parms-loc parms))
2345                           (scan-opnd (make-lbl (closure-parms-lbl parms)))
2346                           (for-each scan-opnd (closure-parms-opnds parms)))
2347                         (close-parms gvm-instr)))
2348
2349              ((ifjump)
2350               (for-each scan-opnd (ifjump-opnds gvm-instr)))
2351
2352              ((switch)
2353               (scan-opnd (switch-opnd gvm-instr))
2354               (for-each (lambda (c) (scan-obj (switch-case-obj c)))
2355                         (switch-cases gvm-instr)))
2356
2357              ((jump)
2358               (scan-opnd (jump-opnd gvm-instr))
2359               (if (jump-ret gvm-instr)
2360                   (todo-lbl-num! (jump-ret gvm-instr)))))
2361
2362            (case (gvm-instr-type gvm-instr)
2363
2364              ((apply)
2365               (let ((loc (apply-loc gvm-instr))
2366                     (prim (apply-prim gvm-instr))
2367                     (opnds (apply-opnds gvm-instr)))
2368                 (let ((proc (proc-obj-inline prim)))
2369                   (if (not proc)
2370
2371                       (compiler-internal-error
2372                        "scan-gvm-instr, unknown 'prim'" prim)
2373
2374                       (proc
2375                        ctx
2376                        (lambda (result)
2377                          (cond (loc ;; result is needed?
2378                                 (^setloc loc (or result (^void-obj))))
2379                                ;; if result is not needed, don't generate expression
2380                                ;;(result
2381                                ;; (^expr-statement result))
2382                                (else
2383                                 (^))))
2384                        opnds)))))
2385
2386              ((copy)
2387               (let ((loc (copy-loc gvm-instr))
2388                     (opnd (copy-opnd gvm-instr)))
2389                 (if opnd
2390                     (begin
2391                       (scan-gvm-opnd ctx loc);;;;;;;;;;;;;;;; needed?
2392                       (scan-gvm-opnd ctx opnd)
2393                       (^setloc loc (^getopnd opnd)))
2394                     (^))))
2395
2396              ((close)
2397               (let ()
2398
2399                 (define (alloc lst rev-loc-names)
2400                   (if (pair? lst)
2401
2402                       (let* ((parms (car lst))
2403                              (lbl (closure-parms-lbl parms))
2404                              (loc (closure-parms-loc parms))
2405                              (opnds (closure-parms-opnds parms)))
2406                         (univ-closure-alloc
2407                          ctx
2408                          lbl
2409                          (map (lambda (opnd)
2410                                 (cond ((assv opnd rev-loc-names) => cdr)
2411                                       ((memv opnd (map closure-parms-loc lst))
2412                                        (^null))
2413                                       (else
2414                                        (^getopnd opnd))))
2415                               opnds)
2416                          (lambda (name)
2417                            (alloc (cdr lst)
2418                                   (cons (cons loc name)
2419                                         rev-loc-names)))))
2420
2421                       (init (close-parms gvm-instr) (reverse rev-loc-names))))
2422
2423                 (define (init lst loc-names)
2424                   (if (pair? lst)
2425
2426                       (let* ((parms (car lst))
2427                              (loc (closure-parms-loc parms))
2428                              (opnds (closure-parms-opnds parms))
2429                              (loc-name (assv loc loc-names)))
2430                         (let loop ((i 1) ;; 0
2431                                    (opnds opnds) ;; (cons (make-lbl lbl) opnds)
2432                                    (rev-code '()))
2433                           (if (pair? opnds)
2434                               (let ((opnd (car opnds)))
2435                                 (loop (+ i 1)
2436                                       (cdr opnds)
2437                                       (cons (if (and (assv opnd loc-names)
2438                                                      (memv opnd (map closure-parms-loc lst)))
2439                                                 (^setclo
2440                                                  (cdr loc-name)
2441                                                  i
2442                                                  (cdr (assv opnd loc-names)))
2443                                                 (^))
2444                                             rev-code)))
2445                               (^ (reverse rev-code)
2446                                  (init (cdr lst) loc-names)))))
2447
2448                       (map
2449                        (lambda (loc-name)
2450                          (let* ((loc (car loc-name))
2451                                 (name (cdr loc-name)))
2452                            (^setloc loc name)))
2453                        loc-names)))
2454
2455                 (alloc (close-parms gvm-instr) '())))
2456
2457              ((ifjump)
2458               (let ((test (ifjump-test gvm-instr))
2459                     (opnds (ifjump-opnds gvm-instr))
2460                     (true (ifjump-true gvm-instr))
2461                     (false (ifjump-false gvm-instr))
2462                     (fs (frame-size (gvm-instr-frame gvm-instr)))
2463                     (poll? (or (ifjump-poll? gvm-instr)
2464                                (unwind-stack? gvm-instr))))
2465
2466                 (let ((proc (proc-obj-test test)))
2467                   (if (not proc)
2468
2469                       (compiler-internal-error
2470                        "scan-gvm-instr, unknown 'test'" test)
2471
2472                       (proc
2473                        ctx
2474                        (lambda (result)
2475                          (^if result
2476                               (jump-to-label ctx true fs poll?)
2477                               (jump-to-label ctx false fs poll?)))
2478                        opnds)))))
2479
2480              ((switch)
2481               ;; TODO
2482               ;; (switch-opnd gvm-instr)
2483               ;; (switch-cases gvm-instr)
2484               ;; (switch-poll? gvm-instr)
2485               ;; (switch-default gvm-instr)
2486               (univ-throw ctx "\"switch GVM instruction unimplemented\""))
2487
2488              ((jump)
2489               ;; TODO
2490               ;; (jump-safe? gvm-instr)
2491               ;; test: (jump-poll? gvm-instr)
2492
2493               (let ((nb-args (jump-nb-args gvm-instr))
2494                     (safe? (jump-safe? gvm-instr))
2495                     (opnd (jump-opnd gvm-instr))
2496                     (ret (jump-ret gvm-instr))
2497                     (fs (frame-size (gvm-instr-frame gvm-instr)))
2498                     (poll? (or (jump-poll? gvm-instr)
2499                                (unwind-stack? gvm-instr))))
2500
2501                 (or (and (obj? opnd)
2502                          (proc-obj? (obj-val opnd))
2503                          nb-args
2504                          (let* ((proc (obj-val opnd))
2505                                 (jump-inliner (proc-obj-jump-inline proc)))
2506                            (and jump-inliner
2507                                 (jump-inliner ctx ret nb-args poll? safe? fs))))
2508
2509                     (^ (if ret
2510                            (^setloc (make-reg 0) (^getopnd (make-lbl ret)))
2511                            (^))
2512
2513                        (if nb-args
2514                            (^setnargs nb-args)
2515                            (^))
2516
2517                        (or (and (lbl? opnd)
2518                                 (jump-to-label ctx (lbl-num opnd) fs poll?))
2519
2520                            (with-stack-pointer-adjust
2521                             ctx
2522                             (+ fs
2523                                (ctx-stack-base-offset ctx))
2524                             (lambda (ctx)
2525                               (^return-poll
2526                                (if (jump-safe? gvm-instr)
2527                                    (if (glo? opnd)
2528                                        (^call-prim
2529                                         (^rts-method-use 'check_procedure_glo)
2530                                         (scan-gvm-opnd ctx opnd)
2531                                         (^obj (glo-name opnd)))
2532                                        (^call-prim
2533                                         (^rts-method-use 'check_procedure)
2534                                         (scan-gvm-opnd ctx opnd)))
2535                                    (let ((o (scan-gvm-opnd ctx opnd)))
2536                                      (if (or (lbl? opnd) (obj? opnd))
2537                                          o
2538                                          (^cast*-jumpable o))))
2539                                poll?
2540                                (and
2541
2542                                 ;; avoid call optimization on globals
2543                                 ;; because some VMs, such as V8 and PyPy,
2544                                 ;; use a counterproductive speculative
2545                                 ;; optimization (which slows
2546                                 ;; down fib by an order of magnitude!)
2547                                 (not (reg? opnd))
2548
2549                                 (case (target-name (ctx-target ctx))
2550                                   ((php)
2551                                    ;; avoid call optimization on PHP
2552                                    ;; because it generates syntactically
2553                                    ;; incorrect code (PHP grammar issue)
2554                                    #f)
2555                                   (else
2556                                    #t)))))))))))
2557
2558              (else
2559               (compiler-internal-error
2560                "scan-gvm-instr, unknown 'gvm-instr':"
2561                gvm-instr))))
2562
2563          (define (jump-to-label ctx n jump-fs poll?)
2564            (with-stack-pointer-adjust
2565             ctx
2566             (+ jump-fs
2567                (ctx-stack-base-offset ctx))
2568             (lambda (ctx)
2569
2570               (define (cont)
2571                 (cond ((and (ctx-allow-jump-destination-inlining? ctx)
2572                             (let* ((bb (lbl-num->bb n bbs))
2573                                    (label-instr (bb-label-instr bb)))
2574                               (and (eq? (label-type label-instr) 'simple)
2575                                    (or (= (length (bb-precedents bb)) 1)
2576                                        (= (length (bb-non-branch-instrs bb)) 0))))) ;; very short destination bb?
2577                        (let* ((bb (lbl-num->bb n bbs))
2578                               (label-instr (bb-label-instr bb))
2579                               (label-fs (frame-size (gvm-instr-frame label-instr))))
2580                          (with-stack-base-offset
2581                           ctx
2582                           (- label-fs)
2583                           (lambda (ctx)
2584                             (with-allow-jump-destination-inlining?
2585                              ctx
2586                              (= (length (bb-precedents bb)) 1) ;; #f
2587                              (lambda (ctx)
2588                                (scan-bb-all-except-label ctx bb)))))))
2589
2590                       (else
2591                        (^return-jump
2592                         (scan-gvm-opnd ctx (make-lbl n))))))
2593
2594               (univ-emit-poll-or-continue ctx (scan-gvm-opnd ctx (make-lbl n)) poll? cont))))
2595
2596          (define (scan-gvm-opnd ctx gvm-opnd)
2597            (if (lbl? gvm-opnd)
2598                (todo-lbl-num! (lbl-num gvm-opnd)))
2599            (^getopnd gvm-opnd));;;;;;;;;;;;;;;;;;;;;;;scan-gvm-loc ?
2600
2601          (todo-lbl-num! (bbs-entry-lbl-num bbs))
2602
2603          (let* ((bbs-defs
2604                  (let loop ((defs (univ-make-empty-defs)))
2605                    (if (queue-empty? bb-todo)
2606                        defs
2607                        (loop (univ-defs-combine
2608                               defs
2609                               (scan-bb ctx (queue-get! bb-todo)))))))
2610                 (init1
2611                  (let* ((lbl
2612                          (make-lbl (bbs-entry-lbl-num bbs)))
2613                         (entry-id
2614                          (gvm-lbl-use ctx lbl))
2615                         (ctrlpts-array
2616                          (^array-literal
2617                           (univ-ctrlpt-reference-type ctx)
2618                           (map (lambda (n)
2619                                  (univ-ctrlpt-reference ctx n))
2620                                (stretchable-vector->list ctrlpts)))))
2621                    (if (eq? (univ-ctrlpt-reference-type ctx) 'str)
2622
2623                        (begin
2624                          (set-car! ctrlpts-init ctrlpts-array)
2625                          (lambda (ctx) (^)))
2626
2627                        (begin
2628                          (set-car! ctrlpts-init (^null))
2629                          (lambda (ctx)
2630                            (^ "\n"
2631                               (univ-with-ctrlpt-attribs
2632                                ctx
2633                                #f
2634                                entry-id
2635                                (lambda ()
2636                                  (univ-set-ctrlpt-attrib
2637                                   ctx
2638                                   entry-id
2639                                   'ctrlpts
2640                                   ctrlpts-array)))))))))
2641                 (init2
2642                  (lambda (ctx)
2643                    (let ((name (string->symbol (proc-obj-name p))))
2644                      (^ "\n"
2645                         (^setpeps name (^obj p))
2646                         (if (proc-obj-primitive? p)
2647                             (^setglo name (^obj p))
2648                             (^)))))))
2649            (univ-add-init (univ-add-init bbs-defs init1) init2))))
2650
2651      (let ((ctx (make-ctx
2652                  (ctx-target global-ctx)
2653                  (ctx-semantics-changing-options global-ctx)
2654                  (ctx-semantics-preserving-options global-ctx)
2655                  (ctx-module-name global-ctx)
2656                  (ctx-ns-prefix global-ctx)
2657                  (ctx-ns-prefix-class global-ctx)
2658                  (scheme-id->c-id (proc-obj-name p))
2659                  (ctx-objs-used global-ctx)
2660                  (ctx-rtlib-features-used global-ctx)
2661                  (ctx-glo-used global-ctx)
2662                  (ctx-decls global-ctx))))
2663        (let ((x (proc-obj-code p)))
2664          (if (bbs? x)
2665              (scan-bbs ctx x)
2666              (univ-make-empty-defs)))))
2667
2668    (for-each scan-obj procs)
2669
2670    (let loop ((defs (univ-make-empty-defs)))
2671      (if (queue-empty? proc-left)
2672          defs
2673          (loop (univ-defs-combine defs (dump-proc (queue-get! proc-left))))))))
2674
2675(define (univ-label-entry ctx gvm-instr id)
2676  (let* ((nb-parms (label-entry-nb-parms gvm-instr))
2677         (opts (label-entry-opts gvm-instr))
2678         (keys (label-entry-keys gvm-instr))
2679         (rest? (label-entry-rest? gvm-instr))
2680         (closed? (label-entry-closed? gvm-instr))
2681         (nb-parms-except-rest
2682          (- nb-parms (if rest? 1 0)))
2683         (nb-keys
2684          (if keys (length keys) 0))
2685         (nb-req-and-opt
2686          (- nb-parms-except-rest nb-keys))
2687         (nb-opts
2688          (length opts))
2689         (nb-req
2690          (- nb-req-and-opt nb-opts))
2691         (defaults
2692           (append opts (map cdr (or keys '())))))
2693
2694    (define (dispatch-on-nb-args nb-args)
2695      (if (> nb-args (- nb-req-and-opt (if rest? 0 1)))
2696
2697          (cond
2698           ((and keys rest?)
2699            (let ((error (^local-var 'error)))
2700              (^
2701               (^var-declaration 'jumpable error
2702                                 (^call-prim (^rts-method-use 'build_key_rest)
2703                                             (^int nb-req-and-opt)
2704                                             (^int nb-parms)
2705                                             (^array-literal 'scmobj
2706                                                             (apply append
2707                                                                    (map (lambda (x)
2708                                                                           (list (^obj (car x)) (^obj (obj-val (cdr x)))))
2709                                                                         keys)))))
2710               (^if (^not (^parens (^eq? error (^null))))
2711                    (^return-call-prim
2712                     (^rts-method-use 'wrong_key_args)
2713                     (if closed?
2714                         (^cast*-jumpable (^getreg (+ (univ-nb-arg-regs ctx) 1)))
2715                         id)
2716                     error)))))
2717           (keys
2718            (let ((error (^local-var 'error)))
2719              (^
2720               (^var-declaration 'jumpable error
2721                                 (^call-prim (^rts-method-use 'build_key)
2722                                             (^int nb-req-and-opt)
2723                                             (^int nb-parms)
2724                                             (^array-literal 'scmobj
2725                                                             (apply append
2726                                                                    (map (lambda (x)
2727                                                                           (list (^obj (car x)) (^obj (obj-val (cdr x)))))
2728                                                                         keys)))))
2729               (^if (^not (^parens (^eq? error (^null))))
2730                    (^return-call-prim
2731                     (^rts-method-use 'wrong_key_args)
2732                     (if closed?
2733                         (^cast*-jumpable (^getreg (+ (univ-nb-arg-regs ctx) 1)))
2734                         id)
2735                     error)))))
2736           (else
2737            (^if (if rest?
2738                     (^not (^call-prim
2739                            (^rts-method-use 'build_rest)
2740                            (^int nb-parms-except-rest)))
2741                     (^!= (^getnargs)
2742                          (^int nb-parms-except-rest)))
2743                 (^return-call-prim
2744                  (^rts-method-use 'wrong_nargs)
2745                  (if closed?
2746                      (^cast*-jumpable (^getreg (+ (univ-nb-arg-regs ctx) 1)))
2747                      id)))))
2748
2749          (let ((nb-stacked (max 0 (- nb-args (univ-nb-arg-regs ctx))))
2750                (nb-stacked* (max 0 (- nb-parms (univ-nb-arg-regs ctx)))))
2751
2752            (define (setup-parameter i)
2753              (if (<= i nb-parms)
2754                  (let* ((rest (setup-parameter (+ i 1)))
2755                         (src-reg (- i nb-stacked))
2756                         (src (cond ((<= i nb-args)
2757                                     (^getreg src-reg))
2758                                    ((and rest? (= i nb-parms))
2759                                     (^obj '()))
2760                                    (else
2761                                     (^obj
2762                                      (obj-val (list-ref defaults (- i nb-req 1))))))))
2763                    (if (<= i nb-stacked*)
2764                        (^ (^push src)
2765                           rest)
2766                        (if (and (<= i nb-args) (= nb-stacked nb-stacked*))
2767                            rest
2768                            (let ((dst-reg (- i nb-stacked*)))
2769                              (^ (^setreg dst-reg src)
2770                                 rest)))))
2771                  (^)))
2772
2773            (let ((x (setup-parameter (+ nb-stacked 1))))
2774              (^if (^= (^getnargs)
2775                       (^int nb-args))
2776                   x
2777                   (dispatch-on-nb-args (+ nb-args 1)))))))
2778
2779    (dispatch-on-nb-args nb-req)))
2780
2781(define closure-count 0)
2782
2783(define (univ-separated-list sep lst)
2784  (if (pair? lst)
2785      (if (pair? (cdr lst))
2786          (list (car lst) sep (univ-separated-list sep (cdr lst)))
2787          (car lst))
2788      '()))
2789
2790(define (univ-map-index f lst)
2791
2792  (define (mp f lst i)
2793    (if (pair? lst)
2794        (cons (f (car lst) i)
2795              (mp f (cdr lst) (+ i 1)))
2796        '()))
2797
2798  (mp f lst 0))
2799
2800(define (univ-gensym ctx name)
2801  (let ((count (ctx-serial-num ctx)))
2802    (ctx-serial-num-set! ctx (+ count 1))
2803    (string->symbol
2804     (string-append
2805      (symbol->string name)
2806      (number->string count)))))
2807
2808(define (univ-closure-alloc ctx lbl exprs cont)
2809  (let ((closure-var (^local-var (univ-gensym ctx 'closure))))
2810    (^ (^var-declaration
2811        'closure
2812        closure-var
2813        (^call-prim
2814         (^rts-method-use 'closure_alloc)
2815         (^array-literal
2816          'scmobj
2817          (cons (gvm-lbl-use ctx (make-lbl lbl))
2818                exprs))))
2819       (cont closure-var))))
2820
2821(define (make-ctx
2822         target
2823         semantics-changing-options
2824         semantics-preserving-options
2825         module-name
2826         ns-prefix
2827         ns-prefix-class
2828         ns
2829         objs-used
2830         rtlib-features-used
2831         glo-used
2832         decls)
2833  (vector target
2834          semantics-changing-options
2835          semantics-preserving-options
2836          module-name
2837          ns-prefix
2838          ns-prefix-class
2839          ns
2840          0
2841          0
2842          univ-enable-jump-destination-inlining?
2843          (make-resource-set)
2844          (make-resource-set)
2845          (make-resource-set)
2846          objs-used
2847          rtlib-features-used
2848          glo-used
2849          decls))
2850
2851(define (ctx-target ctx)                   (vector-ref ctx 0))
2852(define (ctx-target-set! ctx x)            (vector-set! ctx 0 x))
2853
2854(define (ctx-semantics-changing-options ctx)        (vector-ref ctx 1))
2855(define (ctx-semantics-changing-options-set! ctx x) (vector-set! ctx 1 x))
2856
2857(define (ctx-semantics-preserving-options ctx)        (vector-ref ctx 2))
2858(define (ctx-semantics-preserving-options-set! ctx x) (vector-set! ctx 2 x))
2859
2860(define (ctx-module-name ctx)              (vector-ref ctx 3))
2861(define (ctx-module-name-set! ctx x)       (vector-set! ctx 3 x))
2862
2863(define (ctx-ns-prefix ctx)                (vector-ref ctx 4))
2864(define (ctx-ns-prefix-set! ctx x)         (vector-set! ctx 4 x))
2865
2866(define (ctx-ns-prefix-class ctx)          (vector-ref ctx 5))
2867(define (ctx-ns-prefix-class-set! ctx x)   (vector-set! ctx 5 x))
2868
2869(define (ctx-ns ctx)                       (vector-ref ctx 6))
2870(define (ctx-ns-set! ctx x)                (vector-set! ctx 6 x))
2871
2872(define (ctx-stack-base-offset ctx)        (vector-ref ctx 7))
2873(define (ctx-stack-base-offset-set! ctx x) (vector-set! ctx 7 x))
2874
2875(define (ctx-serial-num ctx)               (vector-ref ctx 8))
2876(define (ctx-serial-num-set! ctx x)        (vector-set! ctx 8 x))
2877
2878(define (ctx-allow-jump-destination-inlining? ctx)        (vector-ref ctx 9))
2879(define (ctx-allow-jump-destination-inlining?-set! ctx x) (vector-set! ctx 9 x))
2880
2881(define (ctx-resources-used-rd ctx)        (vector-ref ctx 10))
2882(define (ctx-resources-used-rd-set! ctx x) (vector-set! ctx 10 x))
2883
2884(define (ctx-resources-used-wr ctx)        (vector-ref ctx 11))
2885(define (ctx-resources-used-wr-set! ctx x) (vector-set! ctx 11 x))
2886
2887(define (ctx-globals-used ctx)             (vector-ref ctx 12))
2888(define (ctx-globals-used-set! ctx x)      (vector-set! ctx 12 x))
2889
2890(define (ctx-objs-used ctx)                (vector-ref ctx 13))
2891(define (ctx-objs-used-set! ctx x)         (vector-set! ctx 13 x))
2892
2893(define (ctx-rtlib-features-used ctx)        (vector-ref ctx 14))
2894(define (ctx-rtlib-features-used-set! ctx x) (vector-set! ctx 14 x))
2895
2896(define (ctx-glo-used ctx)                 (vector-ref ctx 15))
2897(define (ctx-glo-used-set! ctx x)          (vector-set! ctx 15 x))
2898
2899(define (ctx-decls ctx)                    (vector-ref ctx 16))
2900(define (ctx-decls-set! ctx x)             (vector-set! ctx 16 x))
2901
2902(define (with-stack-base-offset ctx n proc)
2903  (let ((save (ctx-stack-base-offset ctx)))
2904    (ctx-stack-base-offset-set! ctx n)
2905    (let ((result (proc ctx)))
2906      (ctx-stack-base-offset-set! ctx save)
2907      result)))
2908
2909(define (with-stack-pointer-adjust ctx n proc)
2910  (^ (if (equal? n 0)
2911         (^)
2912         (^inc-by (gvm-state-sp-use ctx 'rdwr)
2913                  n))
2914     (with-stack-base-offset
2915      ctx
2916      (- (ctx-stack-base-offset ctx) n)
2917      proc)))
2918
2919(define (with-allow-jump-destination-inlining? ctx allow? proc)
2920  (let ((save (ctx-allow-jump-destination-inlining? ctx)))
2921    (ctx-allow-jump-destination-inlining?-set! ctx allow?)
2922    (let ((result (proc ctx)))
2923      (ctx-allow-jump-destination-inlining?-set! ctx save)
2924      result)))
2925
2926(define (with-new-resources-used ctx proc)
2927  (let ((save-rsrc-rd (ctx-resources-used-rd ctx))
2928        (save-rsrc-wr (ctx-resources-used-wr ctx))
2929        (save-glob-rd (ctx-globals-used ctx)))
2930    (ctx-resources-used-rd-set! ctx (make-resource-set))
2931    (ctx-resources-used-wr-set! ctx (make-resource-set))
2932    (ctx-globals-used-set! ctx (make-resource-set))
2933    (let ((result (proc ctx)))
2934      (ctx-resources-used-rd-set! ctx save-rsrc-rd)
2935      (ctx-resources-used-wr-set! ctx save-rsrc-wr)
2936      (ctx-globals-used-set! ctx save-glob-rd)
2937      result)))
2938
2939(define (make-resource-set)
2940  (cons (make-table) '()))
2941
2942(define (resource-set-add! set element)
2943  (let ((t (car set)))
2944    (if (not (table-ref t element #f))
2945        (begin
2946          (table-set! t element #t)
2947          (set-cdr! set (cons element (cdr set)))))))
2948
2949(define (resource-set-member? set element)
2950  (table-ref (car set) element #f))
2951
2952(define (resource-set-stack set)
2953  (cdr set))
2954
2955(define (resource-set-pop set)
2956  (let ((s (cdr set)))
2957    (if (pair? s)
2958        (begin
2959          (set-cdr! set (cdr s))
2960          (car s))
2961        #f)))
2962
2963(define (use-resource-rd ctx resource)
2964  (resource-set-add! (ctx-resources-used-rd ctx) resource))
2965
2966(define (use-resource-wr ctx resource)
2967  (resource-set-add! (ctx-resources-used-wr ctx) resource))
2968
2969(define (use-global ctx global)
2970  (resource-set-add! (ctx-globals-used ctx) global))
2971
2972(define (univ-use-rtlib ctx feature)
2973  ;;(pp (list 'use-rtlib feature));;;;;;;;;;;;
2974  (resource-set-add! (ctx-rtlib-features-used ctx) feature)
2975  (symbol->string feature))
2976
2977(define (use-resource ctx dir resource)
2978  (if (or (eq? dir 'rd) (eq? dir 'rdwr))
2979      (use-resource-rd ctx resource))
2980  (if (or (eq? dir 'wr) (eq? dir 'rdwr))
2981      (use-resource-wr ctx resource)))
2982
2983(define (gvm-state-pollcount ctx)
2984  (^rts-field-use 'pollcount))
2985
2986(define (gvm-state-nargs ctx)
2987  (^rts-field-use 'nargs))
2988
2989(define (gvm-state-reg ctx num)
2990  (^rts-field-use (string->symbol (string-append "r" (number->string num)))))
2991
2992(define (gvm-state-stack ctx)
2993  (^rts-field-use 'stack))
2994
2995(define (gvm-state-sp ctx)
2996  (^rts-field-use 'sp))
2997
2998(define (gvm-state-peps ctx)
2999  (^rts-field-use 'peps))
3000
3001(define (gvm-state-glo ctx)
3002  (^rts-field-use 'glo))
3003
3004(define (gvm-state-pollcount-use ctx dir)
3005  (use-resource ctx dir 'pollcount)
3006  (gvm-state-pollcount ctx))
3007
3008(define (gvm-state-nargs-use ctx dir)
3009  (use-resource ctx dir 'nargs)
3010  (gvm-state-nargs ctx))
3011
3012(define (gvm-state-reg-use ctx dir num)
3013  (use-resource ctx dir num)
3014  (gvm-state-reg ctx num))
3015
3016(define (gvm-state-stack-use ctx dir)
3017  (use-resource ctx dir 'stack)
3018  (gvm-state-stack ctx))
3019
3020(define (gvm-state-sp-use ctx dir)
3021  (use-resource ctx dir 'sp)
3022  (gvm-state-sp ctx))
3023
3024(define (gvm-state-peps-use ctx dir)
3025  (use-resource ctx dir 'peps)
3026  (gvm-state-peps ctx))
3027
3028(define (gvm-state-glo-use ctx dir)
3029  (use-resource ctx dir 'glo)
3030  (gvm-state-glo ctx))
3031
3032(define (univ-emit-tos ctx)
3033  (^array-index
3034   (gvm-state-stack-use ctx 'rd)
3035   (gvm-state-sp-use ctx 'rd)))
3036
3037(define (univ-emit-pop ctx receiver)
3038  (^ (receiver (^tos))
3039     (^inc-by (gvm-state-sp-use ctx 'rdwr)
3040              -1)))
3041
3042(define (univ-emit-push ctx val)
3043  (^inc-by (gvm-state-sp-use ctx 'rdwr)
3044           1
3045           (lambda (x)
3046             (^assign
3047              (^array-index
3048               (gvm-state-stack-use ctx 'rd)
3049               x)
3050              val))))
3051
3052(define (univ-emit-getnargs ctx)
3053  (gvm-state-nargs-use ctx 'rd))
3054
3055(define (univ-emit-setnargs ctx nb-args)
3056  (^assign
3057   (gvm-state-nargs-use ctx 'wr)
3058   nb-args))
3059
3060(define (univ-emit-getreg ctx num)
3061  (gvm-state-reg-use ctx 'rd num))
3062
3063(define (univ-emit-setreg ctx num val)
3064  (^assign
3065   (gvm-state-reg-use ctx 'wr num)
3066   val))
3067
3068(define (univ-stk-slot-from-tos ctx offset)
3069  (^array-index
3070   (gvm-state-stack-use ctx 'rd)
3071   (^- (gvm-state-sp-use ctx 'rd)
3072       offset)))
3073
3074(define (univ-stk-location ctx offset)
3075  (^array-index
3076   (gvm-state-stack-use ctx 'rd)
3077   (^ (gvm-state-sp-use ctx 'rd)
3078      (cond ((= offset 0)
3079             (^))
3080            ((< offset 0)
3081             (^ offset))
3082            (else
3083             (^ "+" offset))))))
3084
3085(define (univ-emit-getstk ctx offset)
3086  (univ-stk-location ctx offset))
3087
3088(define (univ-emit-setstk ctx offset val)
3089  (^assign
3090   (univ-stk-location ctx offset)
3091   val))
3092
3093(define (univ-clo-slots ctx closure)
3094  (case (univ-procedure-representation ctx)
3095
3096    ((class)
3097     (^member (^cast* 'closure closure) 'slots))
3098
3099    (else
3100     (case (target-name (ctx-target ctx))
3101       ((php)
3102        ;;(^member (^cast* 'closure closure) 'slots)
3103        (^member closure 'slots))
3104       (else
3105        (^jump closure (^bool #t)))))))
3106
3107(define (univ-emit-getclo ctx closure index)
3108  (^closure-ref closure index))
3109
3110(define (univ-emit-setclo ctx closure index val)
3111  (^closure-set! closure index val))
3112
3113(define (univ-glo-dependency ctx name dir)
3114  (univ-glo-use ctx name dir)
3115  (gvm-state-glo-use ctx 'rd)
3116  (if (member name
3117              '(println
3118                real-time-milliseconds
3119                ##exit-process))
3120      (begin
3121        (univ-glo-use ctx name 'wr) ;; automatically defined primitives
3122        (univ-use-rtlib
3123         ctx
3124         (string->symbol (string-append "glo-" (symbol->string name)))))))
3125
3126(define (univ-glo-use ctx name dir)
3127  (let* ((t (ctx-glo-used ctx))
3128         (x (table-ref t name #f)))
3129    (table-set! t name (if (or (not x) (eq? dir x)) dir 'rdwr))))
3130
3131(define (univ-emit-getpeps ctx name)
3132  (^dict-get (gvm-state-peps-use ctx 'rd)
3133             (^str (symbol->string name))))
3134
3135(define (univ-emit-setpeps ctx name val)
3136  (^dict-set (gvm-state-peps-use ctx 'rd)
3137             (^str (symbol->string name))
3138             val))
3139
3140(define (univ-emit-getglo ctx name)
3141  (univ-glo-dependency ctx name 'rd)
3142  (^dict-get (gvm-state-glo-use ctx 'rd)
3143             (^str (symbol->string name))))
3144
3145(define (univ-emit-setglo ctx name val)
3146  (univ-glo-dependency ctx name 'wr)
3147  (^dict-set (gvm-state-glo-use ctx 'rd)
3148             (^str (symbol->string name))
3149             val))
3150
3151(define (univ-emit-glo-var-ref ctx sym)
3152  (^dict-get (gvm-state-glo-use ctx 'rd)
3153             (^symbol-unbox sym)))
3154
3155(define (univ-emit-glo-var-primitive-ref ctx sym)
3156  (^dict-get (gvm-state-peps-use ctx 'rd)
3157             (^symbol-unbox sym)))
3158
3159(define (univ-emit-glo-var-set! ctx sym val)
3160  (^dict-set (gvm-state-glo-use ctx 'rd)
3161             (^symbol-unbox sym)
3162             val))
3163
3164(define (univ-emit-glo-var-primitive-set! ctx sym val)
3165  (^dict-set (gvm-state-peps-use ctx 'rd)
3166             (^symbol-unbox sym)
3167             val))
3168
3169(define (univ-emit-getopnd ctx gvm-opnd)
3170
3171  (cond ((reg? gvm-opnd)
3172         (^getreg (reg-num gvm-opnd)))
3173
3174        ((stk? gvm-opnd)
3175         (^getstk (+ (stk-num gvm-opnd) (ctx-stack-base-offset ctx))))
3176
3177        ((glo? gvm-opnd)
3178         (^getglo (glo-name gvm-opnd)))
3179
3180        ((clo? gvm-opnd)
3181         (^getclo (^getopnd (clo-base gvm-opnd))
3182                  (clo-index gvm-opnd)))
3183
3184        ((lbl? gvm-opnd)
3185         (gvm-lbl-use ctx gvm-opnd))
3186
3187        ((obj? gvm-opnd)
3188         (^obj (obj-val gvm-opnd)))
3189
3190        (else
3191         (compiler-internal-error
3192          "univ-emit-getopnd, unknown 'gvm-opnd':"
3193          gvm-opnd))))
3194
3195(define (univ-emit-getopnds ctx gvm-opnds)
3196  (map (lambda (gvm-opnd) (univ-emit-getopnd ctx gvm-opnd))
3197       gvm-opnds))
3198
3199(define (univ-emit-setloc ctx gvm-loc val)
3200
3201  (cond ((reg? gvm-loc)
3202         (^setreg (reg-num gvm-loc)
3203                  val))
3204
3205        ((stk? gvm-loc)
3206         (^setstk (+ (stk-num gvm-loc) (ctx-stack-base-offset ctx))
3207                  val))
3208
3209        ((glo? gvm-loc)
3210         (^setglo (glo-name gvm-loc)
3211                  val))
3212
3213        ((clo? gvm-loc)
3214         (^setclo (^getopnd (clo-base gvm-loc))
3215                  (clo-index gvm-loc)
3216                  val))
3217
3218        (else
3219         (compiler-internal-error
3220          "univ-emit-setloc, unknown 'gvm-loc':"
3221          gvm-loc))))
3222
3223(define (univ-emit-obj* ctx obj force-var?)
3224
3225  (cond ((or (false-object? obj)
3226             (boolean? obj))
3227         (^boolean-obj obj))
3228
3229        ((number? obj)
3230         (cond ((not (real? obj)) ;; non-real complex number
3231                (univ-obj-use
3232                 ctx
3233                 obj
3234                 force-var?
3235                 (lambda ()
3236                   (^cpxnum-make (univ-emit-obj* ctx (real-part obj) #f)
3237                                 (univ-emit-obj* ctx (imag-part obj) #f)))))
3238
3239               ((not (exact? obj)) ;; floating-point number
3240                (^flonum-box (^float obj)))
3241
3242               ((not (integer? obj)) ;; non-integer rational number
3243                (univ-obj-use
3244                 ctx
3245                 obj
3246                 force-var?
3247                 (lambda ()
3248                   (^ratnum-make (univ-emit-obj* ctx (numerator obj) #f)
3249                                 (univ-emit-obj* ctx (denominator obj) #f)))))
3250
3251               (else ;; exact integer
3252                (if (and (>= obj univ-fixnum-min)
3253                         (<= obj univ-fixnum-max))
3254
3255                    (^fixnum-box (^int obj))
3256
3257                    (univ-obj-use
3258                     ctx
3259                     obj
3260                     force-var?
3261                     (lambda ()
3262                       (^new (^type 'bignum)
3263                             (^array-literal
3264                              'bigdigit
3265                              (univ-bignum->digits obj)))))))))
3266
3267        ((char? obj)
3268         (^char-obj obj force-var?))
3269
3270        ((string? obj)
3271         (^string-obj obj force-var?))
3272
3273        ((symbol-object? obj)
3274         (^symbol-obj obj force-var?))
3275
3276        ((keyword-object? obj)
3277         (^keyword-obj obj force-var?))
3278
3279        ((null? obj)
3280         (^null-obj))
3281
3282        ((void-object? obj)
3283         (^void-obj))
3284
3285        ((end-of-file-object? obj)
3286         (^eof))
3287
3288        ((absent-object? obj)
3289         (^absent))
3290
3291        ((deleted-object? obj)
3292         (^deleted))
3293
3294        ((unused-object? obj)
3295         (^unused))
3296
3297        ((unbound1-object? obj)
3298         (^unbound1))
3299
3300        ((unbound2-object? obj)
3301         (^unbound2))
3302
3303        ((optional-object? obj)
3304         (^optional))
3305
3306        ((key-object? obj)
3307         (^key))
3308
3309        ((rest-object? obj)
3310         (^rest))
3311
3312        ((proc-obj? obj)
3313         (let ((name (proc-obj-name obj)))
3314           (if (proc-obj-code obj) ;; procedure defined in this module?
3315               (^this-mod-jumpable (gvm-proc-use ctx name))
3316               (^getpeps (string->symbol name)))))
3317
3318        ((pair? obj)
3319         (univ-obj-use
3320          ctx
3321          obj
3322          force-var?
3323          (lambda ()
3324            (^cons (univ-emit-obj* ctx (car obj) #f)
3325                   (univ-emit-obj* ctx (cdr obj) #f)))))
3326
3327        ((vector-object? obj)
3328         (univ-obj-use
3329          ctx
3330          obj
3331          force-var?
3332          (lambda ()
3333            (^vector-box
3334             (^array-literal
3335              'scmobj
3336              (map (lambda (x) (univ-emit-obj* ctx x #f))
3337                   (vector->list obj)))))))
3338
3339        ((u8vect? obj)
3340         (univ-obj-use
3341          ctx
3342          obj
3343          force-var?
3344          (lambda ()
3345            (^u8vector-box
3346             (^array-literal
3347              'u8
3348              (map (lambda (x) (^num-of-type 'u8 x))
3349                   (u8vect->list obj)))))))
3350
3351        ((u16vect? obj)
3352         (univ-obj-use
3353          ctx
3354          obj
3355          force-var?
3356          (lambda ()
3357            (^u16vector-box
3358             (^array-literal
3359              'u16
3360              (map (lambda (x) (^num-of-type 'u16 x))
3361                   (u16vect->list obj)))))))
3362
3363        ((u32vect? obj)
3364         (univ-obj-use
3365          ctx
3366          obj
3367          force-var?
3368          (lambda ()
3369            (^u32vector-box
3370             (^array-literal
3371              'u32
3372              (map (lambda (x) (^num-of-type 'u32 x))
3373                   (u32vect->list obj)))))))
3374
3375        ((u64vect? obj)
3376         (univ-obj-use
3377          ctx
3378          obj
3379          force-var?
3380          (lambda ()
3381            (^u64vector-box
3382             (^array-literal
3383              'u64
3384              (map (lambda (x) (^num-of-type 'u64 x))
3385                   (u64vect->list obj)))))))
3386
3387        ((s8vect? obj)
3388         (univ-obj-use
3389          ctx
3390          obj
3391          force-var?
3392          (lambda ()
3393            (^s8vector-box
3394             (^array-literal
3395              's8
3396              (map (lambda (x) (^num-of-type 's8 x))
3397                   (s8vect->list obj)))))))
3398
3399        ((s16vect? obj)
3400         (univ-obj-use
3401          ctx
3402          obj
3403          force-var?
3404          (lambda ()
3405            (^s16vector-box
3406             (^array-literal
3407              's16
3408              (map (lambda (x) (^num-of-type 's16 x))
3409                   (s16vect->list obj)))))))
3410
3411        ((s32vect? obj)
3412         (univ-obj-use
3413          ctx
3414          obj
3415          force-var?
3416          (lambda ()
3417            (^s32vector-box
3418             (^array-literal
3419              's32
3420              (map (lambda (x) (^num-of-type 's32 x))
3421                   (s32vect->list obj)))))))
3422
3423        ((s64vect? obj)
3424         (univ-obj-use
3425          ctx
3426          obj
3427          force-var?
3428          (lambda ()
3429            (^s64vector-box
3430             (^array-literal
3431              's64
3432              (map (lambda (x) (^num-of-type 's64 x))
3433                   (s64vect->list obj)))))))
3434
3435        ((f32vect? obj)
3436         (univ-obj-use
3437          ctx
3438          obj
3439          force-var?
3440          (lambda ()
3441            (^f32vector-box
3442             (^array-literal
3443              'f32
3444              (map (lambda (x) (^num-of-type 'f32 x))
3445                   (f32vect->list obj)))))))
3446
3447        ((f64vect? obj)
3448         (univ-obj-use
3449          ctx
3450          obj
3451          force-var?
3452          (lambda ()
3453            (^f64vector-box
3454             (^array-literal
3455              'f64
3456              (map (lambda (x) (^num-of-type 'f64 x))
3457                   (f64vect->list obj)))))))
3458
3459        ((structure-object? obj)
3460         (univ-obj-use
3461          ctx
3462          obj
3463          force-var?
3464          (lambda ()
3465            (let* ((slots
3466                    (##vector-copy obj)) ;;TODO: replace call of ##vector-copy
3467                   (cyclic?
3468                    (eq? (vector-ref slots 0) obj)))
3469              (^structure-box
3470               (^array-literal
3471                'scmobj
3472                (cons (if cyclic? ;; the root type descriptor is cyclic
3473                          (^null) ;; handle this specially
3474                          (univ-emit-obj* ctx (vector-ref slots 0) #f))
3475                      (map (lambda (x) (univ-emit-obj* ctx x #f))
3476                           (cdr (vector->list slots))))))))))
3477
3478        (else
3479         (compiler-user-warning #f "UNIMPLEMENTED OBJECT:" obj)
3480         (^str
3481          (string-append
3482           "UNIMPLEMENTED OBJECT: "
3483           (object->string obj))))))
3484
3485(define (univ-emit-obj ctx obj)
3486  (univ-emit-obj* ctx obj #t))
3487
3488(define (univ-obj-type obj)
3489
3490  (cond ((or (false-object? obj)
3491             (boolean? obj))
3492         'boolean)
3493
3494        ((number? obj)
3495         (cond ((not (real? obj)) ;; non-real complex number
3496                'cpxnum)
3497
3498               ((not (exact? obj)) ;; floating-point number
3499                'flonum)
3500
3501               ((not (integer? obj)) ;; non-integer rational number
3502                'ratnum)
3503
3504               (else ;; exact integer
3505                (if (and (>= obj univ-fixnum-min)
3506                         (<= obj univ-fixnum-max))
3507                    'fixnum
3508                    'bignum))))
3509
3510        ((char? obj)
3511         'char)
3512
3513        ((string? obj)
3514         'string)
3515
3516        ((symbol-object? obj)
3517         'symbol)
3518
3519        ((keyword-object? obj)
3520         'keyword)
3521
3522        ((null? obj)
3523         'null)
3524
3525        ((void-object? obj)
3526         'void)
3527
3528        ((end-of-file-object? obj)
3529         'eof)
3530
3531        ((absent-object? obj)
3532         'absent)
3533
3534        ((deleted-object? obj)
3535         'deleted)
3536
3537        ((unused-object? obj)
3538         'unused)
3539
3540        ((or (unbound1-object? obj)
3541             (unbound2-object? obj))
3542         'unbound)
3543
3544        ((optional-object? obj)
3545         'optional)
3546
3547        ((key-object? obj)
3548         'key)
3549
3550        ((rest-object? obj)
3551         'rest)
3552
3553        ((proc-obj? obj)
3554         (if (proc-obj-code obj) ;; procedure defined in this module?
3555             'jumpable
3556             'parententrypoint))
3557
3558        ((pair? obj)
3559         'pair)
3560
3561        ((vector-object? obj)
3562         'vector)
3563
3564        ((u8vect? obj)
3565         'u8vector)
3566
3567        ((u16vect? obj)
3568         'u16vector)
3569
3570        ((u32vect? obj)
3571         'u32vector)
3572
3573        ((u64vect? obj)
3574         'u64vector)
3575
3576        ((s8vect? obj)
3577         's8vector)
3578
3579        ((s16vect? obj)
3580         's16vector)
3581
3582        ((s32vect? obj)
3583         's32vector)
3584
3585        ((s64vect? obj)
3586         's64vector)
3587
3588        ((f32vect? obj)
3589         'f32vector)
3590
3591        ((f64vect? obj)
3592         'f64vector)
3593
3594        ((structure-object? obj)
3595         'structure)
3596
3597        (else
3598         ;;TODO: handle these types better
3599         ;;  box
3600         ;;  closure
3601         ;;  continuation
3602         ;;  foreign
3603         ;;  promise
3604         ;;  values
3605         ;;  will
3606         'scmobj)))
3607
3608(define univ-mdigit-width 14)
3609(define univ-mdigit-base (expt 2 univ-mdigit-width))
3610(define univ-mdigit-base-minus-1 (- univ-mdigit-base 1))
3611
3612(define (univ-bignum->digits obj)
3613
3614  (define (dig n len rest)
3615    (cond ((= len 1)
3616           (cons n rest))
3617          (else
3618           (let* ((hi-len (quotient len 2))
3619                  (lo-len (- len hi-len))
3620                  (lo-len-bits (* univ-mdigit-width lo-len)))
3621             (let* ((hi (arithmetic-shift n (- lo-len-bits)))
3622                    (lo (- n (arithmetic-shift hi lo-len-bits))))
3623               (dig lo
3624                    lo-len
3625                    (dig hi
3626                         hi-len
3627                         rest)))))))
3628
3629  (let* ((width (integer-length obj))
3630         (len (+ (quotient width univ-mdigit-width) 1)))
3631    (dig (if (< obj 0)
3632           (+ (arithmetic-shift 1 (* univ-mdigit-width len)) obj)
3633           obj)
3634         len
3635         '())))
3636
3637(define (univ-js-typed-array-constructor ctx type)
3638  (case type
3639    ((s8)  "Int8Array")
3640    ((u8)  "Uint8Array")
3641    ((s16) "Int16Array")
3642    ((u16) "Uint16Array")
3643    ((s32) "Int32Array")
3644    ((u32) "Uint32Array")
3645    ((f32) "Float32Array")
3646    ((f64) "Float64Array")
3647    (else  #f)))
3648
3649(define (univ-array-constructor ctx type)
3650  (case (target-name (ctx-target ctx))
3651
3652    ((js)
3653     (or (univ-js-typed-array-constructor ctx type)
3654         "Array"))
3655
3656    (else
3657     #f)))
3658
3659(define (univ-emit-array-literal ctx type elems)
3660  (case (target-name (ctx-target ctx))
3661
3662    ((js)
3663     (let ((array (^ "[" (univ-separated-list "," elems) "]"))
3664           (typed-array-constructor (univ-js-typed-array-constructor ctx type)))
3665       (if typed-array-constructor
3666           (^new typed-array-constructor array)
3667           array)))
3668
3669    ((python ruby)
3670     (^ "[" (univ-separated-list "," elems) "]"))
3671
3672    ((php)
3673     (^apply "array" elems))
3674
3675    ((java)
3676     (^ "new " (^type (list 'array type)) "{" (univ-separated-list "," elems) "}"))
3677
3678    (else
3679     (compiler-internal-error
3680      "univ-emit-array-literal, unknown target"))))
3681
3682(define (univ-emit-extensible-array-literal ctx type elems)
3683  (case (target-name (ctx-target ctx))
3684
3685    ((python)
3686     (let ((key-vals
3687            (let loop ((i 0) (lst elems) (rev-kv '()))
3688              (if (pair? lst)
3689                  (loop (+ i 1)
3690                        (cdr lst)
3691                        (cons (^ i ":" (car lst)) rev-kv))
3692                  (reverse rev-kv)))))
3693       (^ "{" (univ-separated-list "," key-vals) "}")))
3694
3695    (else
3696     (univ-emit-array-literal ctx type elems))))
3697
3698(define (univ-emit-make-stack ctx)
3699  (case (target-name (ctx-target ctx))
3700
3701    ((js php python ruby)
3702     (^extensible-array-literal 'scmobj '()))
3703
3704    ((java)
3705     (^new-array 'scmobj 10000));;TODO: fix size
3706
3707    (else
3708     (compiler-internal-error
3709      "univ-emit-make-stack, unknown target"))))
3710
3711(define (univ-emit-new-array ctx type len)
3712  (case (target-name (ctx-target ctx))
3713
3714    ((js)
3715     (^new (^type (list 'array type)) len))
3716
3717    ((php)
3718     (^if-expr (^= len (^int 0)) ;; array_fill does not like len=0
3719               (^array-literal type '())
3720               (^call-prim
3721                "array_fill"
3722                (^int 0)
3723                len
3724                (^int 0))))
3725
3726    ((python)
3727     (^* (^ "[" (^int 0) "]") len))
3728
3729    ((ruby)
3730     (^call-prim (^member "Array" 'new) len))
3731
3732    ((java)
3733     (^ "new " (^type type) "[" len "]"))
3734
3735    (else
3736     (compiler-internal-error
3737      "univ-emit-new-array, unknown target"))))
3738
3739(define (univ-emit-make-array ctx type return len init)
3740  (case (target-name (ctx-target ctx))
3741
3742    ((js)
3743     ;; TODO: add for loop constructor
3744     (let ((elems (^local-var 'elems)))
3745       (^ (^var-declaration
3746           (list 'array type)
3747           elems
3748           (^new-array type len))
3749          "
3750          for (var i=0; i<" len "; i++) {
3751            " elems "[i] = " init ";
3752          }
3753          "
3754          (return elems))))
3755
3756    ((php)
3757     (return
3758      (^if-expr (^= len (^int 0)) ;; array_fill does not like len=0
3759                (^array-literal type '())
3760                (^call-prim
3761                 "array_fill"
3762                 (^int 0)
3763                 len
3764                 init))))
3765
3766    ((python)
3767     ;; TODO: add literal array constructor
3768     (return
3769      (^* (^ "[" init "]") len)))
3770
3771    ((ruby)
3772     (return
3773      (^call-prim (^member "Array" 'new) len init)))
3774
3775    ((java)
3776     ;; TODO: add for loop constructor
3777     (let ((elems (^local-var 'elems)))
3778       (^ (^var-declaration
3779           (list 'array type)
3780           elems
3781           (^new-array type len))
3782          "
3783          for (int i=0; i<" len "; i++) {
3784            " elems "[i] = " init ";
3785          }
3786          "
3787          (return elems))))
3788
3789    (else
3790     (compiler-internal-error
3791      "univ-emit-make-array, unknown target"))))
3792
3793;; =============================================================================
3794
3795(define (gvm-lbl-use ctx lbl)
3796  (^this-mod-jumpable (gvm-lbl-use-aux ctx lbl)))
3797
3798(define (gvm-lbl-use-aux ctx lbl)
3799  (gvm-bb-use ctx (lbl-num lbl) (ctx-ns ctx)))
3800
3801(define (gvm-proc-use ctx name)
3802  (gvm-bb-use ctx 1 (scheme-id->c-id name)))
3803
3804(define (gvm-bb-use ctx num ns)
3805  (let ((id (lbl->id ctx num ns)))
3806    ;;TODO: remove?
3807    ;;(use-global ctx (^mod-field "AAA" id))
3808    id))
3809
3810(define (lbl->id ctx num ns)
3811  (^ univ-bb-prefix num "_" ns))
3812
3813(define univ-bb-prefix "bb")
3814(define univ-capitalized-bb-prefix "Bb")
3815
3816(define (univ-foldr-range lo hi rest fn)
3817  (if (<= lo hi)
3818      (univ-foldr-range
3819       lo
3820       (- hi 1)
3821       (fn hi rest)
3822       fn)
3823      rest))
3824
3825(define (univ-pop-args-to-vars ctx nb-args)
3826  (let ((nb-stacked (max 0 (- nb-args (univ-nb-arg-regs ctx)))))
3827    (univ-foldr-range
3828     1
3829     nb-args
3830     (^)
3831     (lambda (i rest)
3832       (^ rest
3833          (let ((x (- i nb-stacked)))
3834            (if (>= x 1)
3835                (^var-declaration
3836                 'scmobj
3837                 (^local-var (^ 'arg i))
3838                 (^getreg x))
3839                (^pop (lambda (expr)
3840                        (^var-declaration
3841                         'scmobj
3842                         (^local-var (^ 'arg i))
3843                         expr))))))))))
3844
3845(define (univ-push-args ctx)
3846  (univ-foldr-range
3847   0
3848   (- (univ-nb-arg-regs ctx) 1)
3849   (^)
3850   (lambda (i rest)
3851     (^if (^> (^getnargs) i)
3852          (^ (^push (^getreg (+ i 1)))
3853             rest)))))
3854
3855(define (univ-pop-args-to-regs ctx lo)
3856  (univ-foldr-range
3857   0
3858   (- (univ-nb-arg-regs ctx) 1)
3859   (^)
3860   (lambda (i rest)
3861     (let ((x
3862            (^ rest
3863               (^pop (lambda (expr)
3864                       (^setreg (+ i 1) expr))))))
3865       (if (< i lo)
3866           x
3867           (^if (^> (^getnargs) (- i lo))
3868                x))))))
3869
3870(define (univ-min-memoized-fixnum ctx) 0)
3871(define (univ-max-memoized-fixnum ctx) 256)
3872
3873;;;============================================================================
3874