-
Notifications
You must be signed in to change notification settings - Fork 4
/
Copy pathcompiler.patch
1657 lines (1609 loc) · 75.4 KB
/
compiler.patch
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
diff --git a/code-gen.ml b/code-gen.ml
index dd80017..576aa73 100644
--- a/code-gen.ml
+++ b/code-gen.ml
@@ -20,20 +20,399 @@ module type CODE_GEN = sig
- The keys are the fvar names as strings
- The values are the offsets from the base fvars_table address in bytes
For example: [("boolean?", 0)]
- *)
+ *)
val make_fvars_tbl : expr' list -> (string * int) list
(* If you change the types of the constants and fvars tables, you will have to update
- this signature to match: The first argument is the constants table type, the second
- argument is the fvars table type, and the third is an expr' that has been annotated
+ this signature to match: The first argument is the constants table type, the second
+ argument is the fvars table type, and the third is an expr' that has been annotated
by the semantic analyser.
*)
val generate : (constant * (int * string)) list -> (string * int) list -> expr' -> string
end;;
module Code_Gen : CODE_GEN = struct
- let make_consts_tbl asts = raise X_not_yet_implemented;;
- let make_fvars_tbl asts = raise X_not_yet_implemented;;
- let generate consts fvars e = raise X_not_yet_implemented;;
-end;;
+ (* ================================ CONST TABLE ================================= *)
+
+ let remove_duplicates lst =
+ let rec acc_only_first_appearance lst new_lst=
+ match lst with
+ | e::es -> if (List.mem e new_lst) then acc_only_first_appearance es new_lst else acc_only_first_appearance es (new_lst@[e])
+ | [] -> new_lst in
+ acc_only_first_appearance lst [];;
+
+ let rec collect_sexp asts =
+ match asts with
+ | Const'(e)-> [e]
+ | Var'(e)-> []
+ | BoxSet'(v, e) -> collect_sexp e
+ | If'(test,thn,els) -> (collect_sexp test) @ (collect_sexp thn) @ (collect_sexp els)
+ | Seq'(exp_list) -> List.flatten (List.map collect_sexp exp_list)
+ | Set'(v, e) -> collect_sexp e
+ | Def'(v, e) -> collect_sexp e
+ | Or'(exp_list) -> List.flatten (List.map collect_sexp exp_list)
+ | LambdaSimple'(args, e) -> collect_sexp e
+ | LambdaOpt'(args, opt_arg, e) -> collect_sexp e
+ | Applic'(op, exp_list) | ApplicTP'(op, exp_list) -> List.flatten (List.map collect_sexp ([op]@exp_list))
+ | _ -> []
+
+ and expand_list const_list =
+ let rec expand sexp = ( match sexp with
+ | Sexpr(Symbol(str)) -> [Sexpr (String (str)); sexp]
+ | Sexpr(Pair(e,es)) -> (expand (Sexpr(e)))@(expand (Sexpr(es)))@[Sexpr(e); Sexpr(es); sexp]
+ | _ -> [sexp] ) in
+ let expanded_list = List.flatten (List.map expand const_list) in
+ expanded_list
+
+ and sexps_array asts =
+ let collected_list = (List.flatten (List.map collect_sexp asts)) in
+ let const_list_after_set_2 = remove_duplicates ([Void; Sexpr(Nil); Sexpr (Bool (false)); Sexpr (Bool (true))]@collected_list) in
+ let expanded_list = expand_list const_list_after_set_2 in
+ let const_list_after_set_4 = remove_duplicates expanded_list in
+ const_list_after_set_4
+
+ and size sexp =
+ (match sexp with
+ | Void -> 1
+ | Sexpr(Bool(x)) -> 2
+ | Sexpr(Nil) -> 1
+ | Sexpr(Number(Fraction(x,y))) -> 17
+ | Sexpr(Number(Float(x))) -> 9
+ | Sexpr(Char(x)) -> 2
+ | Sexpr(String(x)) -> 9+(String.length x)
+ | Sexpr(Symbol(x)) -> 9
+ | Sexpr(Pair(e,es)) -> 17)
+
+ and stage_5_first const_array =
+ let f str = (String.concat "," (List.map (fun c -> string_of_int (int_of_char c)) (string_to_list str))) in
+ (* f "abc" -> string = "97,98,99" *)
+ let offset = ref 0 in
+ let offset_old = ref 0 in
+ let create_tuple sexp offset_old =
+ (match sexp with
+ | Void -> (sexp, (offset_old, "db T_VOID"))
+ | Sexpr(Bool(false)) ->(sexp, (offset_old, "db T_BOOL, 0"))
+ | Sexpr(Bool(true)) ->(sexp, (offset_old, "db T_BOOL, 1"))
+ | Sexpr(Nil) -> (sexp, (offset_old, "db T_NIL"))
+ | Sexpr(Number(Float(x))) -> (sexp, (offset_old, "MAKE_LITERAL_FLOAT("^(string_of_float(x))^")"))
+ | Sexpr(Number(Fraction(x,y))) -> (sexp, (offset_old,"MAKE_LITERAL_RATIONAL("^(string_of_int(x))^","^(string_of_int(y))^")"))
+ | Sexpr(Char(x)) -> (sexp, (offset_old, "MAKE_LITERAL_CHAR("^(string_of_int(int_of_char x))^")"))
+ | Sexpr(String(x)) -> (sexp, (offset_old, "MAKE_LITERAL_STRING "^(f x)))
+ | Sexpr(Symbol(x)) -> (sexp, (offset_old, "TODO"))
+ | Sexpr(Pair(e,es)) -> (sexp, (offset_old, "TODO"))) in
+ let increase_offset = (fun (sexp) -> offset := (!offset+(size sexp))) in
+ let create_list cons_array = List.map (fun (sexp) -> offset_old := !offset; increase_offset(sexp); create_tuple sexp !offset_old) cons_array in
+ create_list const_array
+
+ and find_offset sexp lst=
+ match lst with
+ | (Sexpr(e),(offset,_))::es -> if sexpr_eq e sexp then string_of_int(offset) else find_offset sexp es
+ | (Void,(_,_))::es -> find_offset sexp es
+ | _ -> raise X_this_should_not_happen
+
+ and stage_5_second tuple_3_list =
+ let f lst tuple =
+ (match tuple with
+ | (Sexpr(Symbol(str)),(offset,_)) -> (Sexpr(Symbol(str)),(offset, "MAKE_LITERAL_SYMBOL(const_tbl+"^(find_offset (String(str)) lst)^")"))
+ | (Sexpr(Pair(car,cdr)),(offset,_)) -> (Sexpr(Pair(car,cdr)),(offset, "MAKE_LITERAL_PAIR(const_tbl+"^(find_offset car lst)^", const_tbl+"^(find_offset cdr lst)^")"))
+ | _ -> tuple
+ ) in
+ List.map (f tuple_3_list) tuple_3_list;;
+
+ (* ====================== FREE VAR TABLE ================== *)
+
+ let known_free_vars = [
+ (* Type queries *)
+ "boolean?"; "flonum?"; "rational?";
+ "pair?"; "null?"; "char?"; "string?";
+ "procedure?"; "symbol?";
+ (* String procedures *)
+ "string-length"; "string-ref"; "string-set!";
+ "make-string"; "symbol->string";
+ (* Type conversions *)
+ "char->integer"; "integer->char"; "exact->inexact";
+ (* Identity test *)
+ "eq?";
+ (* Arithmetic ops *)
+ "+"; "*"; "/"; "="; "<";
+ (* Additional rational numebr ops *)
+ "numerator"; "denominator"; "gcd";
+ (* List ops *)
+ "car"; "cdr"; "cons"; "apply"; "set-car!"; "set-cdr!"
+ ]
+
+ let isVarFree var =
+ match var with
+ | VarFree(v) -> [v]
+ | _ -> [];;
+
+ let collect_varfrees asts =
+ let rec collect_varfrees_rec ast =
+ match ast with
+ | Const'(e)-> []
+ | Var'(v)-> (isVarFree v)
+ | If'(test,thn,els) -> (collect_varfrees_rec test) @ (collect_varfrees_rec thn) @ (collect_varfrees_rec els)
+ | Seq'(exp_list) -> List.flatten (List.map collect_varfrees_rec exp_list)
+ | Set'(v, e) -> (isVarFree v) @ (collect_varfrees_rec e)
+ | Def'(v, e) -> (isVarFree v) @ (collect_varfrees_rec e)
+ | Or'(exp_list) -> List.flatten (List.map collect_varfrees_rec exp_list)
+ | LambdaSimple'(args, e) -> collect_varfrees_rec e
+ | LambdaOpt'(args, opt_arg, e) -> collect_varfrees_rec e
+ | Applic'(op, exp_list) | ApplicTP'(op, exp_list) -> List.flatten (List.map collect_varfrees_rec ([op] @ exp_list))
+ | _ -> [] in
+ List.flatten (List.map (fun ast -> collect_varfrees_rec ast) asts);;
+
+ let lst_to_table lst =
+ let rec name_index_lst lst i =
+ match lst with
+ | v::rest -> [(v,i)] @ (name_index_lst rest (i+1))
+ | _ -> [] in
+ name_index_lst lst 0;;
+
+
+ (* =================================== GENERATE ================================*)
+
+ let counter = ref 0;;
+ let inc_and_get = (fun () -> counter := (!counter +1); (string_of_int !counter));;
+
+ let rec generate_helper consts fvars exp depth =
+ match exp with
+ | Const'(sexp) -> (match sexp with
+ | Void -> "\nmov rax, const_tbl\n"
+ | Sexpr(s) -> "\nmov rax, const_tbl + "^(find_offset s consts)^"\n")
+ | Var'(VarFree(x)) -> let location = string_of_int (get_fvar_location x fvars) in
+ "mov rax, qword [fvar_tbl + 8*" ^ location ^ "]\n"
+ | Var'(VarParam(_, minor)) -> "mov rax, qword [rbp + 8 * (4 + "^(string_of_int minor) ^")]\n"
+ | Var'(VarBound(_, major, minor)) -> "mov rax, qword [rbp + 8*2]\n"^
+ "mov rax, qword [rax + 8*"^(string_of_int major) ^"]\n"^
+ "mov rax, qword [rax + 8*"^(string_of_int minor) ^"]\n"
+ | Box'(v) -> "\n"^(generate_helper consts fvars (Var'(v)) depth)^"\n"^
+ "MALLOC r8, 8\n"^
+ "mov qword[r8], rax\n"^
+ "mov rax, r8\n"
+ | BoxGet'(v) -> "\n"^(generate_helper consts fvars (Var'(v)) depth)^"\n"^
+ "mov rax, qword [rax]\n"
+ | BoxSet'(v, e) -> "\n"^(generate_helper consts fvars e depth)^"\n"^
+ "push rax\n"^
+ (generate_helper consts fvars (Var'(v)) depth)^"\n"^
+ "pop qword [rax]\n"^
+ "mov rax, SOB_VOID_ADDRESS\n"
+ | If'(tst, th, el) -> let lelse_num = inc_and_get() in
+ let lexit_num = inc_and_get() in
+ "\n"^(generate_helper consts fvars tst depth)^"\n"^
+ "cmp rax, SOB_FALSE_ADDRESS\n"^
+ "je Lelse"^lelse_num^"\n"^
+ (generate_helper consts fvars th depth)^"\n"^
+ "jmp Lexit"^lexit_num^"\n"^
+ "Lelse"^lelse_num^":\n"^
+ (generate_helper consts fvars el depth)^"\n"^
+ "Lexit"^lexit_num^":\n"
+ | Seq'(lst) -> List.fold_left (fun acc e -> acc^(generate_helper consts fvars e depth)) "\n" lst
+ | Set'(VarFree(x), e) -> let location = string_of_int (get_fvar_location x fvars) in
+ "\n" ^ (generate_helper consts fvars e depth) ^
+ "mov qword [fvar_tbl + 8*" ^ location ^ "], rax\n" ^
+ "mov rax, SOB_VOID_ADDRESS\n"
+ | Set'(VarParam(_, minor), e) -> "\n"^(generate_helper consts fvars e depth)^"\n"^
+ "mov qword [rbp + 8 * (4 + "^(string_of_int minor)^")], rax\n"^
+ "mov rax, SOB_VOID_ADDRESS\n"
+ | Set'(VarBound(_, major, minor),e) -> "\n"^(generate_helper consts fvars e depth)^"\n"^
+ "mov rbx, qword [rbp + 8 * 2]\n"^
+ "mov rbx, qword [rbx + 8 * "^(string_of_int major) ^"]\n"^
+ "mov qword [rbx + 8 * "^(string_of_int minor)^"], rax\n"^
+ "mov rax, SOB_VOID_ADDRESS\n"
+ | Def'(VarFree(x), e) -> let location = string_of_int (get_fvar_location x fvars) in
+ (generate_helper consts fvars e depth) ^ "\n" ^
+ "mov qword [fvar_tbl + 8*" ^ location ^ "], rax\n" ^
+ "mov rax, SOB_VOID_ADDRESS\n"
+ | Or'(lst) -> let lexit = "Lexit" ^ inc_and_get() in
+ "\n" ^ (or_code consts fvars depth lst lexit)
+ | LambdaSimple'(args, body) -> let lambda_index = inc_and_get() in
+ let lcode = "Lcode" ^ lambda_index in
+ let lcont = "Lcont" ^ lambda_index in
+ "; LambdaSimple\n" ^
+ "\n" ^ (env_code depth lambda_index) ^
+ lcode ^ ":\n" ^
+ "push rbp\n" ^
+ "mov rbp, rsp\n" ^
+ (generate_helper consts fvars body (depth + 1)) ^ "\n" ^
+ "leave\n" ^
+ "ret\n" ^
+ lcont ^ ":\n"
+ | LambdaOpt'(args, opt, body) -> let lambda_index = inc_and_get() in
+ let lcode = "Lcode" ^ lambda_index in
+ let lcont = "Lcont" ^ lambda_index in
+ "; LambdaOpt\n" ^
+ "\n" ^ (env_code depth lambda_index) ^
+ lcode ^ ":\n" ^
+ "; Adjust the stack for the optional arguments\n" ^
+ (fix_stack_opt depth lambda_index (args@[opt])) ^
+ "push rbp\n" ^
+ "mov rbp, rsp\n" ^
+ (generate_helper consts fvars body (depth + 1)) ^ "\n" ^
+ "leave\n" ^
+ "ret\n" ^
+ lcont ^ ":\n"
+ | Applic'(op, lst) -> let args = List.fold_right (fun e acc -> acc^(generate_helper consts fvars e depth)^"\n push rax \n") lst "\n" in
+ let n = string_of_int (List.length lst) in
+ let proc = (generate_helper consts fvars op depth) in
+ "; Applic\n" ^
+ args^"\n push "^n^"\n"^proc^"\n"^
+ "push qword[ rax + 1 ] ;;push env (rax is all the closure, skip tag = +1)\n"^
+ "call qword[ rax + 1 + 8 ] ;;call code (rax is all the closure, skip tag = +1, skip env = +8)\n"^
+ "add rsp, 8 ;;pop env\n"^
+ "pop rbx ;;pop arg count\n"^
+ "shl rbx, 3 ;;rbx = rbx*8\n"^
+ "add rsp, rbx ;;pop args\n"
+ | ApplicTP'(op, lst) -> let args = List.fold_right (fun e acc -> acc^(generate_helper consts fvars e depth)^"\n push rax \n") lst "\n" in
+ let n = string_of_int (List.length lst) in
+ let n4 = string_of_int ((List.length lst)+4) in
+ let proc = (generate_helper consts fvars op depth) in
+ args^"\n push "^n^"\n"^proc^"\n"^
+ "push qword[ rax + 1 ] ;;push env (rax is all the closure, skip tag = +1)\n"^
+ "push qword[ rbp + 8 ] ;;old ret address)\n"^
+ "push qword[rbp] ;;backup old rbp\n"^
+ "mov r9, qword[rbp + 8*3] ;;get old args num\n"^
+ "add r9, 4\n"^
+ "shl r9, 3 ;;set new r9 = (x+4)*8\n"^
+ ";;fix the stack\n"^
+ "SHIFT_FRAME "^n4^" ;;args_count + 4 = n + env + ret addrs +old rbp\n"^
+ "add rsp, r9 ;;set new stack pointer\n"^
+ "pop rbp ;;restore old rbp\n"^
+ "jmp qword[rax + 1 + 8] ;;jmp to code (rax is all the closure, skip tag = +1, skip env = +8)\n"
+ | _ -> ""
+
+ and env_code depth lambda_index =
+ let lcode = "Lcode" ^ lambda_index in
+ let lcont = "Lcont" ^ lambda_index in
+ if depth == 0 then "MAKE_CLOSURE(rax, SOB_NIL_ADDRESS, " ^ lcode ^ ")\n" ^
+ "jmp " ^ lcont ^ "\n"
+ else "MALLOC rbx, " ^ (string_of_int ((depth+1)*8)) ^ " ; rbx = pointer to ExtEnv\n" ^
+ "mov qword r8, [rbp + 8*2] ; r8 is a pointer to lexical env\n" ^
+ "; rbx[i+1] <- r8[i] using r9\n" ^
+ "mov rcx, 0 ; rcx is the loop var\n" ^
+ "mov rdx, " ^ (string_of_int depth) ^ "\n" ^
+ "simple_ext_loop" ^ lambda_index ^ ":\n" ^
+ "mov r9, qword [r8 + 8*rcx]\n" ^
+ "mov qword [rbx + 8*(rcx+1)], r9\n" ^
+ "inc rcx\n" ^
+ "cmp rcx, rdx\n" ^
+ "jne simple_ext_loop" ^ lambda_index ^ "\n" ^
+ "mov r10, qword [rbp + 8 * 3] ; r10 is the number of params in previous env\n" ^
+ "mov r11, r10 ; save the amount of params\n" ^
+ "shl r10, 3 ; r10 = r10 * 8 - the real size that we should save\n" ^
+ "MALLOC rdx, r10\n" ^
+ "mov rcx, 0 ; rcx is the loop var, r11 is the limit, doing the exchange using r14\n" ^
+ "cmp r11, 0 ; there is no parameters\n" ^
+ "je simple_param_end_loop" ^ lambda_index ^ "\n" ^
+ "simple_param_loop" ^ lambda_index ^ ":\n" ^
+ "mov r14, PVAR(rcx)\n" ^
+ "mov qword [rdx + 8*(rcx)], r14\n" ^
+ "inc rcx\n" ^
+ "cmp rcx, r11\n" ^
+ "jne simple_param_loop" ^ lambda_index ^ "\n" ^
+ "simple_param_end_loop" ^ lambda_index ^ ":\n" ^
+ "mov qword [rbx], rdx ; put this env in ExtEnv[0]\n" ^
+ "MAKE_CLOSURE(rax, rbx, " ^ lcode ^ ")\n" ^
+ "jmp " ^ lcont ^ "\n"
+
+ and fix_stack_opt depth lambda_index args =
+ let new_n = List.length args in
+ "mov rbx, qword [rsp + 8*2] ; rbx = actual_n\n" ^
+ "cmp rbx, " ^ (string_of_int new_n) ^ "\n" ^
+ "jne not_eq" ^ lambda_index ^ "\n" ^ (* have to make the last elemnt a Pair *)
+ "mov r8, qword [rsp + 8*(2 + rbx)]\n" ^
+ "mov r10, r8 ; r10 = address of element\n" ^
+ "MAKE_PAIR (r9, r10, SOB_NIL_ADDRESS) ; r9 = Pair(r10, Nil)\n" ^
+ "mov qword [rsp + 8*(2 + rbx)], r9 ; stack[n-1] = Pair(element, Nil)\n" ^
+ "jmp end_of_fix" ^ lambda_index ^ "\n" ^
+ "not_eq" ^ lambda_index ^ ":\n" ^
+ "; rbx have the actual n\n" ^
+ "cmp rbx, " ^ (string_of_int new_n) ^ "\n" ^
+ "jl enlarge_stack" ^ lambda_index ^ "\n" ^
+ "; new_n < old_n\n" ^
+ "; create list of rest element\n" ^
+ "mov rcx, rbx\n" ^
+ "sub rcx, " ^ (string_of_int new_n) ^ "\n" ^
+ "inc rcx ; Need to Pair the last element as well\n" ^
+ "mov r9, SOB_NIL_ADDRESS\n" ^
+ "pair_cons_loop" ^ lambda_index ^ ":\n" ^
+ "; rcx is the loop counter\n" ^
+ "; r8 = element from the end of stack to the position of the pair\n" ^
+ "mov r8, qword [rsp + 8*(2 + " ^ (string_of_int new_n) ^ " + rcx - 1)]\n" ^
+ "MAKE_PAIR (rdx, r8, r9) ; rdx = Pair(r8, r9)\n" ^
+ "; update r9\n" ^
+ "mov r9, rdx\n" ^
+ "dec rcx\n" ^
+ "jnz pair_cons_loop" ^ lambda_index ^ "\n" ^
+ "; r9 has the list\n" ^
+ "mov qword [rsp + 8 * (2 + " ^ (string_of_int new_n) ^ ")], r9\n" ^
+ "; adjust the stack size from n to " ^ (string_of_int new_n) ^ "\n" ^
+ "mov r8, " ^ (string_of_int new_n) ^ " ; r8 = new_n\n" ^
+ "add r8, 3 ; r8 = new_stack_size\n" ^
+ "; We want that rdx will point to the last element\n" ^
+ "mov rdx, r8\n" ^
+ "; We want that r10 will point to the last element of old stack\n" ^
+ "mov r8, rbx ; r8 = old_n\n" ^
+ "add r8, 3 ; r8 = old_stack_size\n" ^
+ "mov r10, r8\n" ^
+ "shift_stack_up" ^ lambda_index ^ ":\n" ^
+ "; stack[r10-1] <- stack[rdx-1] using r11\n" ^
+ "dec r10\n" ^
+ "dec rdx ; it is the smaller\n" ^
+ "mov r11, qword [rsp + 8*rdx]\n" ^
+ "mov qword [rsp + 8*r10], r11\n" ^
+ "jnz shift_stack_up" ^ lambda_index ^ "\n" ^
+ "; Fix rsp to point right\n" ^
+ "; r10 hold the diff between this two pointers\n" ^
+ "mul_small_stack_loop" ^ lambda_index ^ ":\n" ^
+ "add rsp, 8\n" ^
+ "dec r10\n" ^
+ "jnz mul_small_stack_loop" ^ lambda_index ^ "\n" ^
+ "jmp fix_n" ^ lambda_index ^ "\n" ^
+ "enlarge_stack" ^ lambda_index ^ ":\n" ^
+ "; old_n < new_n\n" ^
+ "; shift down the stack\n" ^
+ "mov r8, " ^ (string_of_int new_n) ^ " ; r8 = new_n\n" ^
+ "add r8, 3 ; r8 = new_stack_size\n" ^
+ "mov rdx, r8 ; rdx = new_stack_size\n" ^
+ "mov r8, rbx ; r8 = old_n\n" ^
+ "add r8, 3 ; r8 = old_stack_size\n" ^
+ "mov r10, r8 ; r10 = old_stack_size\n" ^
+ "mov r9, 0\n" ^
+ "sub rsp, 8 ; we need to take down the hole stack\n" ^
+ "shift_stack_down" ^ lambda_index ^ ":\n" ^
+ "; stack[r9] <- stack[r9+1] using r11\n" ^
+ "mov r11, qword [rsp + 8*(r9+1)]\n" ^
+ "mov qword [rsp + 8*r9], r11\n" ^
+ "inc r9\n" ^
+ "dec r10 ; it is the smaller\n" ^
+ "jnz shift_stack_down" ^ lambda_index ^ "\n" ^
+ "; rsp is already fixed\n" ^
+ "; put in the cleared element NIL\n" ^
+ "mov qword [rsp + 8*(rdx - 1)], SOB_NIL_ADDRESS\n" ^
+ "fix_n" ^ lambda_index ^ ":\n" ^
+ "mov qword [rsp + 2*8], " ^ (string_of_int new_n) ^ "\n" ^
+ "end_of_fix" ^ lambda_index ^ ":\n"
+
+ and or_code consts fvars depth lst lexit =
+ let or_exp_code exp =
+ (generate_helper consts fvars exp depth) ^ "\n" ^
+ "cmp rax, SOB_FALSE_ADDRESS\n" ^
+ "jne " ^ lexit ^ "\n" in
+ match lst with
+ | e::[] -> (generate_helper consts fvars e depth) ^ "\n" ^ lexit ^ ":\n"
+ | e::rest -> (or_exp_code e) ^ (or_code consts fvars depth rest lexit)
+ | _ -> raise X_this_should_not_happen
+
+ and get_fvar_location x rest_fvars =
+ match rest_fvars with
+ | (v,i)::rest -> if v = x then i else get_fvar_location x rest
+ | [] -> raise X_this_should_not_happen;;
+
+ (* ================================= END ===================================== *)
+
+ let make_consts_tbl asts = stage_5_second (stage_5_first (sexps_array asts));;
+ let make_fvars_tbl asts = lst_to_table (remove_duplicates (known_free_vars @ (collect_varfrees asts)));;
+ let generate consts fvars e = generate_helper consts fvars e 0;;
+end;;
diff --git a/compiler.ml b/compiler.ml
index fbf0ad5..3725321 100644
--- a/compiler.ml
+++ b/compiler.ml
@@ -1,9 +1,9 @@
#use "code-gen.ml";;
#use "prims.ml";;
-(*
+(*
Auxiliary function to load the contents of a file into a string in memory.
- Note: exceptions are not handled here, and are expected to be handled
+ Note: exceptions are not handled here, and are expected to be handled
by the caller. We already took care of this in main code block below.
*)
let file_to_string f =
@@ -15,7 +15,7 @@ let file_to_string f =
(* This procedure creates the assembly code to set up the runtime environment for the compiled
Scheme code. *)
let make_prologue consts_tbl fvars_tbl =
- (* The table defines a mapping from the names of primitive procedures in scheme to their labels in
+ (* The table defines a mapping from the names of primitive procedures in scheme to their labels in
the assembly implementation. *)
let primitive_names_to_labels =
[
@@ -35,13 +35,14 @@ let make_prologue consts_tbl fvars_tbl =
(* Additional rational numebr ops *)
"numerator", "numerator"; "denominator", "denominator"; "gcd", "gcd";
(* you can add yours here *)
+ "car", "car"; "cdr" , "cdr"; "cons" , "cons"; "set-car!", "setcar"; "set-cdr!", "setcdr"; "apply","apply";
] in
let make_primitive_closure (prim, label) =
(* This implementation assumes fvars are addressed by an offset from the label `fvar_tbl`.
- If you use a different addressing scheme (e.g., a label for each fvar), change the
+ If you use a different addressing scheme (e.g., a label for each fvar), change the
addressing here to match. *)
"MAKE_CLOSURE(rax, SOB_NIL_ADDRESS, " ^ label ^ ")\n" ^
- "mov [fvar_tbl+" ^ (string_of_int (List.assoc prim fvars_tbl)) ^ "], rax" in
+ "mov [fvar_tbl+ 8*" ^ (string_of_int (List.assoc prim fvars_tbl)) ^ "], rax" in
let constant_bytes (c, (a, s)) =
(* Adapt the deconstruction here to your constants data generation scheme.
This implementation assumes the bytes representing the constants are pre-computed in
@@ -88,7 +89,7 @@ main:
push 0 ; argument count
push SOB_NIL_ADDRESS ; lexical environment address
push T_UNDEFINED ; return address
- push rbp
+ push rbp
mov rbp, rsp ; anchor the dummy frame
;; Set up the primitive stdlib fvars:
@@ -100,11 +101,11 @@ main:
user_code_fragment:
;;; The code you compiled will be added here.
-;;; It will be executed immediately after the closures for
+;;; It will be executed immediately after the closures for
;;; the primitive procedures are set up.\n";;
let clean_exit =
- ";;; Clean up the dummy frame, set the exit status to 0 (\"success\"),
+ ";;; Clean up the dummy frame, set the exit status to 0 (\"success\"),
;;; and return from main
pop rbp
add rsp, 3*8
@@ -114,10 +115,10 @@ let clean_exit =
exception X_missing_input_file;;
-(*
+(*
This is the bit that makes stuff happen. It will try to read a filename from the command line arguments
and compile that file, along with the contents of stdlib.scm.
- The result is printed to stduot. This implementation assumes the compiler user redirects the output to a
+ The result is printed to stduot. This implementation assumes the compiler user redirects the output to a
file (i.e. "ocaml compiler.ml some_file.scm > output.s").
This assumption is already handled correctly in the provided makefile.
*)
@@ -128,7 +129,7 @@ try
(Reader.read_sexprs s)) in
(* get the filename to compile from the command line args *)
- let infile = Sys.argv.(1) in
+ let infile = Sys.argv.(1) in
(* load the input file and stdlib *)
let code = (file_to_string "stdlib.scm") ^ (file_to_string infile) in
@@ -140,17 +141,17 @@ try
let consts_tbl = Code_Gen.make_consts_tbl asts in
(* generate the fvars table *)
- let fvars_tbl = Code_Gen.make_fvars_tbl asts in
+ let fvars_tbl = Code_Gen.make_fvars_tbl asts in
(* Generate assembly code for each ast and merge them all into a single string *)
- let generate = Code_Gen.generate consts_tbl fvars_tbl in
+ let generate = Code_Gen.generate consts_tbl fvars_tbl in
let code_fragment = String.concat "\n\n"
(List.map
(fun ast -> (generate ast) ^ "\n\tcall write_sob_if_not_void")
asts) in
(* merge everything into a single large string and print it out *)
- print_string ((make_prologue consts_tbl fvars_tbl) ^
+ print_string ((make_prologue consts_tbl fvars_tbl) ^
code_fragment ^ clean_exit ^
"\n" ^ Prims.procs)
diff --git a/compiler.s b/compiler.s
index fb7d307..ee2b59f 100644
--- a/compiler.s
+++ b/compiler.s
@@ -17,6 +17,7 @@
%define MB(n) 1024*KB(n)
%define GB(n) 1024*MB(n)
+%define PARAM_COUNT qword[ rbp + 3 * WORD_SIZE ]
%macro SKIP_TYPE_TAG 2
mov %1, qword [%2+TYPE_SIZE]
@@ -123,6 +124,11 @@
dq %3
%endmacro
+%macro MAKE_LITERAL 2
+ db %1
+ %2
+%endmacro
+
%define MAKE_RATIONAL(r, num, den) \
MAKE_TWO_WORDS r, T_RATIONAL, num, den
@@ -138,6 +144,19 @@
%define MAKE_CLOSURE(r, env, body) \
MAKE_TWO_WORDS r, T_CLOSURE, env, body
+%define MAKE_LITERAL_CHAR(val) MAKE_LITERAL T_CHAR, db val
+
+%define MAKE_LITERAL_FLOAT(val) MAKE_LITERAL T_FLOAT, dq val
+
+%define MAKE_LITERAL_SYMBOL(val) MAKE_LITERAL T_SYMBOL, dq val
+
+%macro MAKE_LITERAL_STRING 1+
+ db T_STRING
+ dq (%%end_str- %%str)
+%%str:
+ db %1
+%%end_str:
+%endmacro
;;; Macros and routines for printing Scheme OBjects to STDOUT
%define CHAR_NUL 0
@@ -148,6 +167,20 @@
%define CHAR_SPACE 32
%define CHAR_DOUBLEQUOTE 34
%define CHAR_BACKSLASH 92
+
+%macro SHIFT_FRAME 1
+ push rax
+ mov rax, PARAM_COUNT
+ add rax, 4
+%assign i 1
+%rep %1
+ dec rax
+ push qword [rbp-WORD_SIZE*i]
+ pop qword [rbp+WORD_SIZE*rax]
+%assign i i+1
+%endrep
+ pop rax
+%endmacro
extern printf, malloc
global write_sob, write_sob_if_not_void
diff --git a/prims.ml b/prims.ml
index 22f10bb..e3bb390 100644
--- a/prims.ml
+++ b/prims.ml
@@ -128,7 +128,7 @@ module Prims : PRIMS = struct
and not 64 bits.
- `lt.flt` does not handle NaN, +inf and -inf correctly. This allows us to use `return_boolean jl` for both the
floating-point and the fraction cases. For a fully correct implementation, `lt.flt` should make use of
- the `ucomisd` opcode and `return_boolean jb` instead (see https://www.felixcloutier.com/x86/ucomisd for more information).
+ `return_boolean jb` instead (see https://www.felixcloutier.com/x86/ucomisd for more information).
*)
let numeric_ops =
let numeric_op name flt_body rat_body body_wrapper =
@@ -199,9 +199,7 @@ module Prims : PRIMS = struct
movq xmm0, rsi
FLOAT_VAL rdi, rdi
movq xmm1, rdi
- cmpltpd xmm0, xmm1
- movq rsi, xmm0
- cmp rsi, 0", "lt";
+ ucomisd xmm0, xmm1", "lt";
] in
let comparator comp_wrapper name flt_body rat_body = numeric_op name flt_body rat_body comp_wrapper in
(String.concat "\n\n" (List.map (fun (a, b, c) -> arith c b a (fun x -> x)) arith_map)) ^
@@ -307,11 +305,108 @@ module Prims : PRIMS = struct
.end_loop:
mov rdx, rax
MAKE_RATIONAL(rax, rdx, 1)", make_binary, "gcd";
+
+ "CAR rax, rsi", make_unary, "car";
+ "CDR rax, rsi", make_unary, "cdr";
+ "mov qword [rsi+TYPE_SIZE], rdi\n mov rax, SOB_VOID_ADDRESS", make_binary, "setcar";
+ "mov qword [rsi+TYPE_SIZE+WORD_SIZE], rdi\n mov rax, SOB_VOID_ADDRESS", make_binary, "setcdr";
+ "MAKE_PAIR(rax, rsi, rdi)", make_binary, "cons";
] in
String.concat "\n\n" (List.map (fun (a, b, c) -> (b c a)) misc_parts);;
+ (* in the frame that came in here there is:
+ arg n = list
+ arg n-1
+ ...
+ arg2
+ arg1 = proc
+ n
+ env
+ ret add
+ old rbp*)
+ let apply_op = "apply:\n" ^
+ "push rbp\n" ^
+ "mov rbp, rsp\n" ^
+ "mov r8, 0 ; counter of arguments in list\n" ^
+ "mov r9, qword [rbp + 8*3] ; r9 have the number of args\n" ^
+ "dec r9 ; we want the position of the last arg (the list)\n" ^
+ "mov rbx, PVAR(r9)\n" ^
+ "; now we going to push the list args to the stack\n" ^
+ "apply_push_list:\n" ^
+ "cmp rbx, SOB_NIL_ADDRESS\n" ^
+ "je apply_end_of_push_list\n" ^
+ "CAR rdx, rbx ; rdx = car(lst)\n" ^
+ "CDR rbx, rbx ; rbx = cdr(lst)\n" ^
+ "push rdx\n" ^
+ "inc r8\n" ^
+ "jmp apply_push_list\n" ^
+ "apply_end_of_push_list:\n" ^
+ "; we need to swap so the last arg will be the uppest\n" ^
+ "mov r9, 0\n" ^
+ "mov r10, r8 ; the amount of args in list\n" ^
+ "dec r10 ; starting from n-1\n" ^
+ "; swap stack[r9] with stack[r10] using r11 and r12 (cause cannot mov mem to mem)\n" ^
+ "apply_swap_list_args:\n" ^
+ "cmp r9, r10\n" ^
+ "jge apply_end_of_swap_list_args\n" ^
+ "mov r11, qword [rsp + 8*r9]\n" ^
+ "mov r12, qword [rsp + 8*r10]\n" ^
+ "mov qword [rsp + 8*r9], r12\n" ^
+ "mov qword [rsp + 8*r10], r11\n" ^
+ "inc r9\n" ^
+ "dec r10\n" ^
+ "jmp apply_swap_list_args\n" ^
+ "apply_end_of_swap_list_args:\n" ^
+ "; now we going to push all of the rest args, from the end to the beginning\n" ^
+ "mov r9, qword [rbp + 8*3] ; r9 have the number of args, rsp still point the stack when calls\n" ^
+ "sub r9, 2 ; 1 for list and 1 for proc\n" ^
+ "mov r10, r9 ; save the number of args\n" ^
+ "apply_push_args:\n" ^
+ "cmp r9, 0\n" ^
+ "je apply_end_of_push_args\n" ^
+ "push PVAR(r9) ; starting from the end, dont want to push the proc in PVAR(0)\n" ^
+ "dec r9\n" ^
+ "jmp apply_push_args\n" ^
+ "apply_end_of_push_args:\n" ^
+ "; we should push the rest of frame (n, env, return address and old rbp)\n" ^
+ "; r10 have the number of arguments not in list, and r8 have the number in list\n" ^
+ "mov r9, r10 ; r9 will hold the new n\n" ^
+ "add r9, r8\n" ^
+ "mov rbx, r9 ; save the new n\n" ^
+ "push r9 ; push new n\n" ^
+ "; to push the env we need to take it out from closure\n" ^
+ "mov rax, qword [rbp + 8*4] ; rax = closure of proc\n" ^
+ "CLOSURE_ENV r9, rax\n" ^
+ "push r9 ; push new env\n" ^
+ "push qword [rbp + 8*1] ; push return address\n" ^
+ "push qword [rbp] ; push old rsp\n" ^
+ "mov rdx, qword [rbp] ; save old rbp\n" ^
+ "add r10, 6 ; r10 holds the number of args in old frame, adding 2 for proc and list and 4 for the rest frame\n" ^
+ "; r10 = old frame size\n" ^
+ "mov r9, rbx ; r9 is the new n\n" ^
+ "add r9, 4 ; r9 = size of new frame\n" ^
+ "mov r11, r10 ; save r10\n" ^
+ "; shift the stack upward\n" ^
+ (* "SHIFT_FRAME r10\n" ^ *)
+ "mov rcx, r9 ; rcx is the counter\n" ^
+ "apply_shift_stack:\n" ^
+ "; doing the shift using r8\n" ^
+ "; rcx is the pointer to the new frame, and r10 is the pointer to new position\n" ^
+ "dec r10\n" ^
+ "dec rcx\n" ^
+ "mov r8, qword [rsp + 8*rcx]\n" ^
+ "mov qword [rbp + 8*r10], r8\n" ^
+ "cmp rcx, 0 ; r9 times times\n" ^
+ "jne apply_shift_stack\n" ^
+
+ "shl r11, 3 ; r11 is the real size of shift\n" ^
+ "add rsp, r11 ; fix rsp\n" ^
+ "pop rbp ; restore old rbp\n" ^
+ "jmp qword [rax + 1 + 8]; jmp to code in tail call, 1 for type and 8 for env"
+
+
(* This is the interface of the module. It constructs a large x86 64-bit string using the routines
defined above. The main compiler pipline code (in compiler.ml) calls into this module to get the
string of primitive procedures. *)
- let procs = String.concat "\n\n" [type_queries ; numeric_ops; misc_ops];;
+ let procs = String.concat "\n\n" [type_queries ; numeric_ops; misc_ops; apply_op];;
end;;
diff --git a/reader.ml b/reader.ml
index 32445c2..9e1d38e 100644
--- a/reader.ml
+++ b/reader.ml
@@ -1,13 +1,14 @@
#use "pc.ml";;
+open PC;;
exception X_not_yet_implemented;;
exception X_this_should_not_happen;;
-
+
type number =
| Fraction of int * int
| Float of float;;
-
+
type sexpr =
| Bool of bool
| Nil
@@ -31,6 +32,7 @@ let rec sexpr_eq s1 s2 =
module Reader: sig
val read_sexprs : string -> sexpr list
+ val parser: char list -> sexpr * char list
end
= struct
let normalize_scheme_symbol str =
@@ -40,7 +42,225 @@ let normalize_scheme_symbol str =
s) then str
else Printf.sprintf "|%s|" str;;
+let make_paired nt_left nt_right nt =
+ let nt = caten nt_left nt in
+ let nt = pack nt (function (_, e) -> e) in
+ let nt = caten nt nt_right in
+ let nt = pack nt (function (e, _) -> e) in
+ nt;;
+
+(* Generics *)
+let letters = range_ci 'a' 'z';;
+let digit = range '0' '9';;
+let lparen = char '(';;
+let rparen = char ')';;
+let hash = char '#';;
+
+(* Char *)
+let char_prefix = caten hash (char '\\')
+let visible_simple_char = guard nt_any (fun ch -> ch > ' ')
+
+let list_to_lowercase char_list = List.map lowercase_ascii char_list
+
+let name_to_char = fun (char_list) ->
+ match (list_to_lowercase char_list) with
+ | ['t';'a';'b'] -> '\t'
+ | ['r';'e';'t';'u';'r';'n'] -> '\r'
+ | ['s';'p';'a';'c';'e'] -> '\032'
+ | ['n';'e';'w';'l';'i';'n';'e'] -> '\n'
+ | ['n';'u';'l'] -> '\000'
+ | ['p';'a';'g';'e'] -> '\012'
+ | _ -> raise X_no_match;;
+
+let named_char = disj_list [word_ci "newline"; word_ci "nul"; word_ci "page"; word_ci "return"; word_ci "space"; word_ci "tab"]
+let named_char_packed = pack named_char name_to_char
+
+let nt_char = caten char_prefix (disj named_char_packed visible_simple_char)
+
+let char_parser s =
+ let (((hash, slash),ch), rest) = (nt_char s) in
+ (Char ch, rest);;
+
+
+(* Symbol *)
+let symbol_char_no_dot = disj_list [digit; letters; char '!'; char '$'; char '^'; char '*'; char '-'; char '_'; char '='; char '+'; char '<'; char '>'; char '?'; char '/'; char ':'];;
+let dot = char '.';;
+let dot_to_string = pack dot (fun (ch) -> ("."))
+let symbol_char = disj dot symbol_char_no_dot;;
+
+let at_least_two_symbol_char_packed = pack (caten symbol_char (plus symbol_char)) (fun (ch, char_list) ->
+ (list_to_string ((lowercase_ascii ch)::(list_to_lowercase char_list))))
+let symbol_no_dot_packed = pack symbol_char_no_dot (fun (ch) -> list_to_string ((lowercase_ascii ch)::[]))
+
+let nt_symbol = disj at_least_two_symbol_char_packed symbol_no_dot_packed;;
+
+let symbol_parser s =
+ let (symbol,rest) = (nt_symbol s) in
+ (Symbol symbol, rest);;
+
+(* Boolean *)
+let nt_boolean_true = caten hash (char_ci 't')
+let nt_boolean_false = caten hash (char_ci 'f')
+let nt_boolean = disj_list [nt_boolean_true; nt_boolean_false]
+let boolean_parser = pack nt_boolean (fun (hash,letter) ->
+ match (lowercase_ascii letter) with
+ | 't' -> Bool true
+ | 'f' -> Bool false
+ | _ -> raise X_no_match
+ );;
+
+(* Number *)
+let natural =
+ let digits = plus digit in
+ pack digits (fun (ds) -> (list_to_string ds));;
+let sign_adder = fun (sign,num) ->
+ match sign with
+ | None -> num
+ | Some(result) -> if result = '-' then "-"^num else num;;
+
+let integer = pack (caten (maybe (disj (char '+') (char '-'))) natural) sign_adder;;
+let integer_parse s =
+ let (num, rest) = (integer s) in
+ (Number (Fraction (int_of_string num, 1)), rest);;
+
+let rec gcd a b =
+ if a = 0 then b else gcd (b mod a) a ;;
+let fraction = (caten (caten integer (char '/')) natural);;
+let fraction_parse s =
+ let (((up, frac),down), rest) = (fraction s) in
+ let d = (gcd (abs (int_of_string up)) (int_of_string down)) in
+ (Number (Fraction ((int_of_string up)/d, (int_of_string down)/d)), rest);;
+
+let float = (caten (caten integer (char '.')) natural);;
+let float_parse s =
+ let (((left, dot),right), rest) = (float s) in
+ (Number (Float (float_of_string (left^"."^right))), rest);;
+
+let nt_number = disj_list [fraction_parse; float_parse; integer_parse];;
+let number_parser = not_followed_by nt_number (disj nt_symbol dot_to_string)
+
+(* String *)
+let quotes = char '\"'
+let backslash = char '\\'
+let meta_char = disj_list[char '\\'; char '\"'; char_ci 't'; char_ci 'n'; char_ci 'r' ; char_ci 'f']
+let string_meta_char = caten backslash meta_char
+let meta_string_to_lower = fun ch ->
+ if ('A' <= ch && 'Z' >= ch) then (lowercase_ascii ch) else ch
+let two_to_meta = fun (bs, ch) ->
+ match (meta_string_to_lower ch) with
+ | '\\' -> '\\'
+ | '\"' -> '\"'
+ | 't' -> '\t'
+ | 'n' -> '\n'
+ | 'r' -> '\r'
+ | 'f' -> '\012'
+ | _ -> raise X_no_match;;
+let string_meta_char_packed = pack string_meta_char two_to_meta
+let string_literal_char = guard nt_any (fun ch -> ch != '\"' && ch != '\\')
+let string_char = disj string_meta_char_packed string_literal_char
+
+let nt_string = (caten (caten quotes (star string_char)) quotes);;
+let string_parser s =
+ let (((quote1, str),quote2), rest) = (nt_string s) in
+ (String (list_to_string str), rest);;
+
+(* Scientific notation *)
+let scientific_parser =
+ let float_helper = pack float (fun ((left, dot),right) -> (float_of_string (left^"."^right))) in
+ let integer_helper = pack integer (fun (num) -> (float_of_string num)) in
+ let left_side = disj float_helper integer_helper in
+ let nt_e = (char_ci 'e') in
+ let pack_fun = (fun ((num, e),exp) -> Number(Float(num*.(10.**exp)))) in
+ let scientific_str = caten (caten left_side nt_e) integer_helper in
+ let scientific_num = pack scientific_str pack_fun in
+ scientific_num;;
+
+(* Comments and whitespaces *)
+let whitespaces = pack nt_whitespace (fun _ -> Nil);;
+let line_comment_parser =
+ let line_comment_start = char ';' in
+ let backslash_n = pack (char '\n') (fun _ -> "") in
+ let double_backslash_n = pack (word "\\n") (fun _ -> "") in
+ let end_of_in = pack nt_end_of_input (fun _ -> "") in
+ let line_comment_end = disj_list [double_backslash_n; backslash_n; end_of_in;] in
+ let line_comment_content = diff nt_any (disj double_backslash_n backslash_n) in
+ let line_comment = caten line_comment_start (caten (star line_comment_content) line_comment_end) in
+ let line_comment_packed = pack line_comment (fun _ -> Nil) in
+ line_comment_packed;;
+
+let rec parser string = ignore_parser (disj_list [list_parser; dotted_list_parser; nil_parser; string_parser; char_parser; boolean_parser; scientific_parser; number_parser; sexpr_comment_parser; quoted_parser; qquoted_parser; unquoted_parser;
+unquoted_sliced_parser ;symbol_parser]) string
+
+and dotted_list_parser string =
+ let (lparen, rest_string) = (char '(' ) string in
+ rec_parser_dotted rest_string
+
+and rec_parser_dotted data =
+ let (sexp, rest) = parser data in
+ let dot_maybe = maybe (char '.') rest in
+ match dot_maybe with
+ | Some(d), es -> (let ((next_sexp, r), d_rest) = caten parser (char ')') es in
+ Pair(sexp, next_sexp), d_rest)
+ | (None,es) -> (let (next_sexp, r_rest) = rec_parser_dotted es in
+ Pair(sexp, next_sexp), r_rest)
+
+and list_parser string =
+ let (lparen, rest_string) = (char '(' ) string in
+ rec_parser rest_string
+
+and rec_parser data =
+ let (sexp, rest) = parser data in
+ let rparen_maybe = maybe (char ')') rest in
+ match rparen_maybe with
+ | Some(r), es -> Pair(sexp, Nil), es
+ | (None,es) -> (let (next_sexp, r_rest) = rec_parser es in
+ Pair(sexp, next_sexp), r_rest)
+
+and nil_parser string =
+ let ignore_list = disj_list [whitespaces; line_comment_parser; sexpr_comment_parser;] in
+ let nil = caten (caten lparen (star ignore_list)) rparen in
+ let packed = pack nil (fun _ -> Nil) in
+ packed string
+
+and ignore_parser nt =
+ let ignore_list = disj_list [whitespaces; line_comment_parser; sexpr_comment_parser;] in
+ let ignore nt1 = make_paired (star ignore_list) (star ignore_list) nt1 in
+ ignore nt
+
+and sexpr_comment_parser string =
+ let comment = (caten (word "#;") parser) in
+ let packed = pack comment (fun _ -> Nil) in
+ packed string
+
+and quoted_parser string =
+ let q = (char (char_of_int 39)) in
+ let qouta = caten q (ignore_parser parser) in
+ let packed = pack qouta (fun (ch, sexp) -> Pair(Symbol("quote"), Pair(sexp, Nil))) in
+ packed string
+
+and qquoted_parser string =
+ let q = (char '`') in
+ let qouta = caten q (ignore_parser parser) in
+ let packed = pack qouta (fun (ch, sexp) -> Pair(Symbol("quasiquote"), Pair(sexp, Nil))) in
+ packed string
+
+and unquoted_parser string =
+ let q = (char ',') in
+ let qouta = caten q (ignore_parser parser) in
+ let packed = pack qouta (fun (ch, sexp) -> Pair(Symbol("unquote"), Pair(sexp, Nil))) in
+ packed string
+
+and unquoted_sliced_parser string =
+ let q = (word ",@") in
+ let qouta = caten q (ignore_parser parser) in
+ let packed = pack qouta (fun (ch, sexp) -> Pair(Symbol("unquote-splicing"), Pair(sexp, Nil))) in
+ packed string;;
+
+let read_sexprs string =
+ let (parsed, rest) = star parser (string_to_list string) in
+ match rest with
+ | [] -> parsed
+ | _ -> raise PC.X_no_match;;
+
-let read_sexprs string = raise X_not_yet_implemented;;
-
end;; (* struct Reader *)
diff --git a/readme.txt b/readme.txt
index e69de29..d6046cf 100644
--- a/readme.txt
+++ b/readme.txt
@@ -0,0 +1,4 @@
+Darya Koval, 328965058. Ben Gindi, 205874142. We assert that the work we submitted is 100% our own.
+We have not received anypart from any other student in the class, nor have we give parts of it for use to others.
+Nor have we used code from other sources: Courses taught previously at this university,courses taught at other universities, various bits of code found on the Internet, etc.
+We realize that should our code be found to contain code from other sources, that aformal case shall be opened against us withva’adat mishma’at, in pursuit of disciplinaryaction.
\ No newline at end of file
diff --git a/semantic-analyser.ml b/semantic-analyser.ml
index 8e684f0..28c0888 100644
--- a/semantic-analyser.ml
+++ b/semantic-analyser.ml
@@ -1,6 +1,6 @@
#use "tag-parser.ml";;
-type var =
+type var =
| VarFree of string
| VarParam of string * int
| VarBound of string * int * int;;
@@ -56,8 +56,8 @@ let rec expr'_eq e1 e2 =
| ApplicTP'(e1, args1), ApplicTP'(e2, args2) ->
(expr'_eq e1 e2) &&