Skip to content
This repository
  • 3 commits
  • 6 files changed
  • 0 comments
  • 1 contributor
8  misc/vim/syntax/amber.vim
... ...
@@ -1,6 +1,6 @@
1 1
 " Language:	Amber
2 2
 " Maintainer:	nineties <nineties48@gmail.com>
3  
-" $Id: amber.vim 2013-02-06 12:18:32 nineties $
  3
+" $Id: amber.vim 2013-03-18 23:59:01 nineties $
4 4
 
5 5
 if exists("b:current_syntax")
6 6
 "    finish
@@ -8,10 +8,10 @@ endif
8 8
 
9 9
 syn case match " case sensitive
10 10
 
11  
-syn keyword amberConstant    true false
  11
+syn keyword amberConstant    true false nil undef
12 12
 syn keyword amberStatement   module return import open
13  
-syn keyword amberConditional if else where and or not
14  
-syn keyword amberRepeat      while
  13
+syn keyword amberConditional if else where and or not case of
  14
+syn keyword amberRepeat      while for reverse_for
15 15
 
16 16
 syn match   amberStandardConstant    "stdin\|stdout\|stderr"
17 17
 
4  rowl1/Makefile
@@ -3,7 +3,7 @@
3 3
 # Copyright (C) 2010 nineties
4 4
 #
5 5
 
6  
-# $Id: Makefile 2013-03-16 17:27:33 nineties $
  6
+# $Id: Makefile 2013-03-18 22:11:05 nineties $
7 7
 
8 8
 TOPDIR = ..
9 9
 ROWL0DIR = $(TOPDIR)/rowl0
@@ -135,7 +135,7 @@ rowl1-base.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo r
135 135
 rowl1-symbol.rlo: $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-compile.rlo
136 136
 rowl1-numeric.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-compile.rlo rowl1-error.rlo rowl1-module.rlo rowl1-bigint.rlo rowl1-float.rlo
137 137
 rowl1-bigint.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-compile.rlo
138  
-rowl1-float.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-assemble.rlo rowl1-error.rlo
  138
+rowl1-float.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-assemble.rlo rowl1-error.rlo rowl1-base.rlo rowl1-numeric.rlo rowl1-bigint.rlo
139 139
 rowl1-random.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-assemble.rlo rowl1-error.rlo rowl1-numeric.rlo rowl1-bigint.rlo rowl1-float.rlo
140 140
 rowl1-math.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-float.rlo rowl1-numeric.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-assemble.rlo rowl1-error.rlo
141 141
 rowl1-string.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-error.rlo
4  rowl1/rowl1-base.rlc
@@ -2,7 +2,7 @@
2 2
 ; rowl - 1st generation
3 3
 ; Copyright (C) 2010 nineties
4 4
 ;
5  
-; $Id: rowl1-base.rlc 2013-02-14 03:45:29 nineties $
  5
+; $Id: rowl1-base.rlc 2013-03-18 22:10:24 nineties $
6 6
 ;
7 7
 
8 8
 (import "rlvm-compile")
@@ -76,7 +76,7 @@
76 76
     (return v)
77 77
     ))
78 78
 
79  
-(fun _id (obj) (
  79
+(export fun _id (obj) (
80 80
     (return obj)
81 81
     ))
82 82
 
10  rowl1/rowl1-float.rlc
@@ -2,7 +2,7 @@
2 2
 ; rowl - 1st generation
3 3
 ; Copyright (C) 2012 nineties
4 4
 ;
5  
-; $Id: rowl1-float.rlc 2013-03-16 17:26:28 nineties $
  5
+; $Id: rowl1-float.rlc 2013-03-18 22:10:43 nineties $
6 6
 ;
7 7
 
8 8
 (import "rlvm-compile")
@@ -18,6 +18,7 @@
18 18
 (import "rowl1-compile")
19 19
 (import "rowl1-assemble")
20 20
 (import "rowl1-error")
  21
+(import "rowl1-base")
21 22
 (import "rowl1-numeric")
22 23
 (import "rowl1-bigint")
23 24
 
@@ -28,15 +29,15 @@
28 29
     ))
29 30
 
30 31
 (export fun float_sign (f) (
31  
-    (if (< (field_get f 0) 0)
  32
+    (if (< (field_get f 1) 0)
32 33
         (return @TRUE)
33 34
         (return @FALSE)
34 35
         )
35 36
     ))
36 37
 
37 38
 (export fun float_is_zero (f) (
38  
-    (if (&& (== (& (field_get f 0) 0x7fffffff) 0)
39  
-            (== (field_get f 1) 0))
  39
+    (if (&& (== (& (field_get f 1) 0x7fffffff) 0)
  40
+            (== (field_get f 0) 0))
40 41
         (return @TRUE)
41 42
         (return @FALSE)
42 43
         )
@@ -512,6 +513,7 @@
512 513
     (add_function1 std (to_sym "hash") floatT float_hash 0)
513 514
     (add_function1 std (to_sym "to_i") stringT float_to_i 0)
514 515
     (add_function1 std (to_sym "to_f") intT int_to_f 0)
  516
+    (add_function1 std (to_sym "to_f") floatT _id 0)
515 517
     
516 518
     (add_function2 std (to_sym "add") floatT floatT float_add 0)
517 519
     (add_function2 std (to_sym "sub") floatT floatT float_sub 0)
112  rowl1/rowl1-matching.rlc
@@ -2,7 +2,7 @@
2 2
 ; rowl - 1st generation
3 3
 ; Copyright (C) 2010 nineties
4 4
 ;
5  
-; $Id: rowl1-matching.rlc 2013-03-05 06:57:44 nineties $
  5
+; $Id: rowl1-matching.rlc 2013-03-18 21:21:05 nineties $
6 6
 ;
7 7
 
8 8
 (import "rlvm-compile")
@@ -52,13 +52,16 @@
52 52
     (if cache (return cache))
53 53
 
54 54
     (var asm (make_assembler))
  55
+    (var exit_lbl (fresh_label asm))
55 56
 
56 57
     (if (!= (node_type def) @DelegateFunctionE)
57  
-        (compile_matching_single_function asm loc obj def)
  58
+        (compile_matching_single_function asm loc obj def exit_lbl)
58 59
         (do
59 60
             (var fun (field_get def 2))
60 61
             (var delegatee (field_get def 3))
61  
-            (compile_matching_single_function asm loc obj fun)
  62
+            (var exit_lbl2 (fresh_label asm))
  63
+            (compile_matching_single_function asm loc obj fun exit_lbl2)
  64
+            (set_label asm exit_lbl2)
62 65
             (while delegatee (do
63 66
                 (var disp (car delegatee))
64 67
                 (var failed (fresh_label asm))
@@ -80,6 +83,7 @@
80 83
                 ))
81 84
         ))
82 85
 
  86
+    (set_label asm exit_lbl)
83 87
     (put_undef asm)
84 88
     (put_ireturn asm)
85 89
 
@@ -88,7 +92,7 @@
88 92
     (return code)
89 93
     ))
90 94
 
91  
-(fun compile_matching_single_function (asm loc obj def) (
  95
+(fun compile_matching_single_function (asm loc obj def exit) (
92 96
     (if (! (is_function def))
93 97
         (throw (type_error loc (string "function") obj))
94 98
         )
@@ -106,7 +110,7 @@
106 110
         ))
107 111
     (= args (cons (get_arity) args))
108 112
 
109  
-    (compile_matching_main asm args mat)
  113
+    (compile_matching_main asm args mat exit)
110 114
     ))
111 115
 
112 116
 (fun construct_pattern_matrix (def) (
@@ -260,7 +264,7 @@
260 264
     (return pat)
261 265
     ))
262 266
 
263  
-(fun compile_matching_main (asm args pats) (
  267
+(fun compile_matching_main (asm args pats exit) (
264 268
     (if (== (caar pats) 0) (do
265 269
         (label compile_matching_main_loop)
266 270
         (var func (car pats))
@@ -283,90 +287,87 @@
283 287
             (do
284 288
                 (put_push asm code)
285 289
                 (put_jjump asm)
  290
+                return
286 291
             ))
  292
+        (put_goto asm exit)
287 293
         return
288 294
         ))
289 295
     (var x (split_pattern_matrix pats)) ; (single . remain)
290  
-    (compile_matching_single asm args (car x))
  296
+
291 297
     (if (cdr x)
292  
-        (compile_matching_main asm args (cdr x))
  298
+        (do
  299
+            (var exit2 (fresh_label asm))
  300
+            (compile_matching_single asm args (car x) exit2)
  301
+            (set_label asm exit2)
  302
+            (compile_matching_main asm args (cdr x) exit)
  303
+        )
  304
+        (compile_matching_single asm args (car x) exit)
293 305
         )
294 306
     ))
295 307
 
296  
-(fun compile_matching_single (asm args pats) (
  308
+(fun compile_matching_single (asm args pats exit) (
297 309
     (var p (caaar pats))
298 310
     (if (== p dontcareP) (do
299 311
         (= pats (shift_pat pats))
300  
-        (compile_matching_main asm (cdr args) pats)
  312
+        (compile_matching_main asm (cdr args) pats exit)
301 313
         return
302 314
         ))
303 315
     (if (== p varP) (do
304 316
         (= pats (shift_pat pats))
305  
-        (compile_matching_main asm (cdr args) pats)
  317
+        (compile_matching_main asm (cdr args) pats exit)
306 318
         return
307 319
         ))
308 320
     (if (== p ellipsisP) (do
309 321
         (= pats (shift_pat pats))
310  
-        (compile_matching_main asm args pats)
  322
+        (compile_matching_main asm args pats exit)
311 323
         return
312 324
         ))
313 325
     (if (is_special p) (do
314  
-        (var check_failed (fresh_label asm))
315 326
         (compile_operand asm (car args) @C_NIL)
316 327
         (put_imm_int16 asm p)
317  
-        (put_if_ne asm check_failed)
  328
+        (put_if_ne asm exit)
318 329
         (= pats (shift_pat pats))
319  
-        (compile_matching_main asm (cdr args) pats)
320  
-        (set_label asm check_failed)
  330
+        (compile_matching_main asm (cdr args) pats exit)
321 331
         return
322 332
         ))
323 333
     (var hd (node_bhead p))
324 334
     (if (== hd BSymbol) (do
325  
-        (var check_failed (fresh_label asm))
326 335
         (compile_operand asm (car args) @C_NIL)
327 336
         (put_push asm p)
328  
-        (put_if_ne asm check_failed)
  337
+        (put_if_ne asm exit)
329 338
         (= pats (shift_pat pats))
330  
-        (compile_matching_main asm (cdr args) pats)
331  
-        (set_label asm check_failed)
  339
+        (compile_matching_main asm (cdr args) pats exit)
332 340
         return
333 341
         ))
334 342
     (if (== hd BInt) (do
335  
-        (var check_failed (fresh_label asm))
336 343
         (compile_operand asm (car args) @C_NIL)
337  
-        (put_check_int asm check_failed)
338  
-        (compile_matching_intlit asm args pats)
339  
-        (set_label asm check_failed)
  344
+        (put_check_int asm exit)
  345
+        (compile_matching_intlit asm args pats exit)
340 346
         return
341 347
         ))
342 348
     (if (== hd BString) (do
343  
-        (var check_failed (fresh_label asm))
344 349
         (compile_operand asm (car args) @C_NIL)
345  
-        (put_check_string asm check_failed)
  350
+        (put_check_string asm exit)
346 351
         (compile_operand asm (car args) @C_NIL)
347  
-        (compile_matching_string_lit asm p check_failed)
  352
+        (compile_matching_string_lit asm p exit)
348 353
         (= pats (shift_pat pats))
349  
-        (compile_matching_main asm (cdr args) pats)
350  
-        (set_label asm check_failed)
  354
+        (compile_matching_main asm (cdr args) pats exit)
351 355
         return
352 356
         ))
353 357
     (if (== hd domP) (do
354 358
         (var pat (node_arg_symbol p 1))
355  
-        (var check_failed (fresh_label asm))
356 359
         (compile_operand asm (car args) @C_NIL)
357  
-        (compile_head_check asm pat check_failed)
  360
+        (compile_head_check asm pat exit)
358 361
         (= pats (shift_pat pats))
359  
-        (compile_matching_main asm (cdr args) pats)
360  
-        (set_label asm check_failed)
  362
+        (compile_matching_main asm (cdr args) pats exit)
361 363
         return
362 364
         ))
363 365
     (if (== hd List) (do
364 366
         (if (is_ellipsis_list p)
365 367
             (do
366 368
                 (var len (- (list_len p) 1))
367  
-                (var check_failed (fresh_label asm))
368 369
                 (compile_operand asm (car args) @C_NIL)
369  
-                (put_check_list2 asm check_failed len)
  370
+                (put_check_list2 asm exit len)
370 371
 
371 372
                 ; flatten list pattern
372 373
                 (= pats (expand_list_pat pats))
@@ -379,14 +380,12 @@
379 380
                     (= args (cons (make_list_at ls len) args))
380 381
                     ))
381 382
 
382  
-                (compile_matching_main asm args pats)
383  
-                (set_label asm check_failed)
  383
+                (compile_matching_main asm args pats exit)
384 384
             )
385 385
             (do
386 386
                 (var len (list_len p))
387  
-                (var check_failed (fresh_label asm))
388 387
                 (compile_operand asm (car args) @C_NIL)
389  
-                (put_check_list asm check_failed len)
  388
+                (put_check_list asm exit len)
390 389
 
391 390
                 ; flatten list pattern
392 391
                 (= pats (expand_list_pat pats))
@@ -399,29 +398,27 @@
399 398
                     (= args (cons (make_list_at ls len) args))
400 399
                     ))
401 400
 
402  
-                (compile_matching_main asm args pats)
403  
-                (set_label asm check_failed)
  401
+                (compile_matching_main asm args pats exit)
404 402
             ))
405 403
         return
406 404
         ))
407 405
 
408  
-    (var check_failed (fresh_label asm))
409 406
     (var size (node_size p))
410 407
     (compile_operand asm (car args) @C_NIL)
411  
-    (compile_head_check asm hd check_failed)
  408
+    (compile_head_check asm hd exit)
412 409
 
413 410
     (if (is_ellipsis_node p size)
414 411
         (if (> size 1) (do
415 412
             (compile_operand asm (car args) @C_NIL)
416 413
             (compile_simple_call asm 1 node_size)
417 414
             (put_imm_int asm (- size 1))
418  
-            (put_if_lt asm check_failed)
  415
+            (put_if_lt asm exit)
419 416
             ))
420 417
         (do
421 418
             (compile_operand asm (car args) @C_NIL)
422 419
             (compile_simple_call asm 1 node_size)
423 420
             (put_imm_int asm size)
424  
-            (put_if_ne asm check_failed)
  421
+            (put_if_ne asm exit)
425 422
         ))
426 423
 
427 424
     ; flatten expression pattern
@@ -432,8 +429,7 @@
432 429
     (rfor i 0 size
433 430
         (= args (cons (make_object_at p expr i) args))
434 431
         )
435  
-    (compile_matching_main asm args pats)
436  
-    (set_label asm check_failed)
  432
+    (compile_matching_main asm args pats exit)
437 433
     ))
438 434
 
439 435
 (fun is_ellipsis_list (pats) (
@@ -479,21 +475,20 @@
479 475
     (put_if_ne asm exit_lbl)
480 476
     ))
481 477
 
482  
-(fun compile_matching_intlit (asm args pats) (
  478
+(fun compile_matching_intlit (asm args pats exit) (
483 479
     (= pats (sort_int_pat pats))
484 480
     (var r (scan_int_cases pats))
485 481
     (var continues (unbox (car r)))
486 482
     (var cases (cdr r))
487 483
 
488 484
     (if continues
489  
-        (compile_matching_intlit_tswitch asm args pats cases)
490  
-        (compile_matching_intlit_lswitch asm args pats cases)
  485
+        (compile_matching_intlit_tswitch asm args pats cases exit)
  486
+        (compile_matching_intlit_lswitch asm args pats cases exit)
491 487
         )
492 488
     ))
493 489
 
494  
-(fun compile_matching_intlit_tswitch (asm args pats cases) (
  490
+(fun compile_matching_intlit_tswitch (asm args pats cases exit) (
495 491
     (var ncases (list_len cases))
496  
-    (var end_lbl (fresh_label asm))
497 492
     (var case_lbls (array int ncases))
498 493
     (for i 0 ncases
499 494
         (array_set int case_lbls i (fresh_label asm))
@@ -508,19 +503,18 @@
508 503
     (for i 0 ncases
509 504
         (emit_tswitch_label asm (array_get int case_lbls i))
510 505
         )
511  
-    (emit_tswitch_label asm end_lbl)
  506
+    (emit_tswitch_label asm exit)
512 507
     (for i 0 ncases (do
513 508
         (var n (unbox (cdar cases)))
514 509
         (var r (list_split pats n))
515 510
         (= pats (cdr r))
516 511
         (set_label asm (array_get int case_lbls i))
517  
-        (compile_matching_main asm (cdr args) (shift_pat (car r)))
  512
+        (compile_matching_main asm (cdr args) (shift_pat (car r)) exit)
518 513
         (= cases (cdr cases))
519 514
         ))
520  
-    (set_label asm end_lbl)
521 515
     ))
522 516
 
523  
-(fun compile_matching_intlit_lswitch (asm args pats cases) (
  517
+(fun compile_matching_intlit_lswitch (asm args pats cases exit) (
524 518
     (var ncases 0)
525 519
     (var max (caar cases))
526 520
     (var cases_copy cases)
@@ -533,7 +527,6 @@
533 527
         ))
534 528
     (= max (+ (unbox max) 1))
535 529
 
536  
-    (var end_lbl (fresh_label asm))
537 530
     (var case_lbls (array int ncases))
538 531
     (for i 0 ncases
539 532
         (array_set int case_lbls i (fresh_label asm))
@@ -552,16 +545,15 @@
552 545
         (= cases_copy (cdr cases_copy))
553 546
         ))
554 547
     (emit_int asm max)
555  
-    (emit_lswitch_label asm end_lbl)
  548
+    (emit_lswitch_label asm exit)
556 549
     (for i 0 ncases (do
557 550
         (var n (unbox (cdar cases)))
558 551
         (var r (list_split pats n))
559 552
         (= pats (cdr r))
560 553
         (set_label asm (array_get int case_lbls i))
561  
-        (compile_matching_main asm (cdr args) (shift_pat (car r)))
  554
+        (compile_matching_main asm (cdr args) (shift_pat (car r)) exit)
562 555
         (= cases (cdr cases))
563 556
         ))
564  
-    (set_label asm end_lbl)
565 557
     ))
566 558
 
567 559
 (fun sort_int_pat (pats) (
47  rowl1/rowl1-math.rlc
@@ -2,7 +2,7 @@
2 2
 ; rowl - 1st generation
3 3
 ; Copyright (C) 2012 nineties
4 4
 ;
5  
-; $Id: rowl1-math.rlc 2013-02-16 04:09:51 nineties $
  5
+; $Id: rowl1-math.rlc 2013-03-18 21:40:26 nineties $
6 6
 ;
7 7
 
8 8
 (import "rlvm-compile")
@@ -51,6 +51,10 @@
51 51
     (return (fpow x y))
52 52
     ))
53 53
 
  54
+(var napier (float_from_s "2.7182818284590452"))
  55
+(var two    (itof 2))
  56
+(var ten    (itof 10))
  57
+
54 58
 (fun float_log (x y) (
55 59
     (if (! (float_positive x))
56 60
         (throw (out_of_domain current_loc (to_sym "log") x)))
@@ -59,43 +63,56 @@
59 63
     (return (flog x y))
60 64
     ))
61 65
 
  66
+(fun float_logE (x) ((return (float_log x napier))))
  67
+(fun float_log2 (x) ((return (float_log x two))))
  68
+(fun float_log10 (x) ((return (float_log x ten))))
  69
+
62 70
 (var to_f (to_sym "to_f"))
63  
-(fun do_to_f (v) (
64  
-    (= v (byterun (lookup_func current_mod to_f) v))
65  
-    (if (!= (node_type v) @FloatE)
66  
-        (throw (exception current_loc (string "to_f must returns floating-point value")))
  71
+(fun to_float (v) (
  72
+    (var r (byterun (lookup_func current_mod to_f) v))
  73
+    (if (== r @C_UNDEF)
  74
+        (throw (make_object3 Exception current_loc
  75
+            (string "Can't convert to floating-point number")
  76
+            v)))
  77
+    (if (!= (node_type r) @FloatE)
  78
+        (throw (exception current_loc (string "to_f must returns floating-point number")))
67 79
         )
68  
-    (return v)
  80
+    (return r)
69 81
     ))
70 82
 
71 83
 (fun sqrt (v) (
72  
-    (return (float_sqrt (do_to_f v)))
  84
+    (return (float_sqrt (to_float v)))
73 85
     ))
74 86
 
75 87
 (fun sin (v) (
76  
-    (return (float_sin (do_to_f v)))
  88
+    (return (float_sin (to_float v)))
77 89
     ))
78 90
 
79 91
 (fun cos (v) (
80  
-    (return (float_cos (do_to_f v)))
  92
+    (return (float_cos (to_float v)))
81 93
     ))
82 94
 
83 95
 (fun tan (v) (
84  
-    (return (float_tan (do_to_f v)))
  96
+    (return (float_tan (to_float v)))
85 97
     ))
86 98
 
87 99
 (fun tan (v) (
88  
-    (return (float_tan (do_to_f v)))
  100
+    (return (float_tan (to_float v)))
89 101
     ))
90 102
 
91 103
 (fun pow (x y) (
92  
-    (return (binary_coerce (to_sym "pow") x y))
  104
+    (return (call2 (to_sym "pow") (to_float x) (to_float y)))
93 105
     ))
94 106
 
95 107
 (fun log (x y) (
96  
-    (return (binary_coerce (to_sym "log") x y))
  108
+    (return (call2 (to_sym "log") (to_float x) (to_float y)))
  109
+    ))
  110
+
  111
+(fun log1 (x) (
  112
+    (return (call1 (to_sym "log") (to_float x)))
97 113
     ))
98 114
 
  115
+(extern fun compile_matching)
99 116
 (export fun setup_math (std) (
100 117
     (add_function1 std (to_sym "sqrt") DontCare sqrt 0)
101 118
     (add_function1 std (to_sym "sin") DontCare sin 0)
@@ -103,6 +120,7 @@
103 120
     (add_function1 std (to_sym "tan") DontCare tan 0)
104 121
     (add_function2 std (to_sym "pow") DontCare DontCare pow 0)
105 122
     (add_function2 std (to_sym "log") DontCare DontCare log 0)
  123
+    (add_function1 std (to_sym "log") DontCare log1 0)
106 124
 
107 125
     (add_function1 std (to_sym "sqrt") floatT float_sqrt 0)
108 126
     (add_function1 std (to_sym "sin") floatT float_sin 0)
@@ -110,6 +128,9 @@
110 128
     (add_function1 std (to_sym "tan") floatT float_tan 0)
111 129
     (add_function2 std (to_sym "pow") floatT floatT float_pow 0)
112 130
     (add_function2 std (to_sym "log") floatT floatT float_log 0)
  131
+    (add_function1 std (to_sym "log") floatT float_logE 0)
  132
+    (add_function1 std (to_sym "log2") floatT float_log2 0)
  133
+    (add_function1 std (to_sym "log10") floatT float_log10 0)
113 134
     ))
114 135
 
115 136
    ))

No commit comments for this range

Something went wrong with that request. Please try again.