├── Makefile ├── README ├── alexpander.scm ├── bit.c ├── bit.h ├── bit.scm ├── eiod.scm ├── librairie.scm ├── read-all.scm ├── reader-fail.scm ├── reader.scm ├── show-char.scm └── test-expander.scm /Makefile: -------------------------------------------------------------------------------- 1 | SHELL=/bin/bash 2 | 3 | %.c: %.scm 4 | cat $^ | csi -e '(load "bit.scm") (byte-compile)' > $*.c 5 | 6 | %: %.c 7 | gcc $^ bit.c -o $@ 8 | 9 | %-ex.scm: %.scm 10 | cat alexpander.scm $^ > $@ 11 | 12 | test-reader: reader 13 | for i in *.scm; do echo $$i; diff <(cat $$i | ./reader) <(cat $$i | csi -q read-all.scm); done 14 | 15 | test-reader-fail: reader 16 | cat reader-fail.scm | ./reader 17 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Copyright (C) 1995 Danny Dube, Universite de Montreal. All rights reserved. 2 | 3 | OVERVIEW 4 | 5 | This is my implementation of a compact programmation system for 6 | Scheme. It is composed of a byte-compiler and a run-time module. The 7 | run-time module and the output of the byte-compiler are compact and 8 | allow the creation of very small executables. 9 | 10 | FILES 11 | 12 | The tar file contains the following files: 13 | README This file. 14 | bit.c Run-time module. 15 | bit.h Header of the run-time module. 16 | bit.scm Byte-compiler. 17 | librairie.scm Scheme library source file. 18 | 19 | USE 20 | 21 | To compile a Scheme source file, load the byte-compiler in your 22 | favorite Scheme interpreter and use the function "byte-compile". 23 | Ex: (byte-compile "prog.scm" "prog.c") 24 | 25 | To generate the executable, use your C compiler on the produced 26 | file and the run-time module. 27 | Ex: my-cc prog.c bit.c 28 | 29 | FEATURES 30 | 31 | The implementation was originally created to show that it is possible 32 | to program a micro-controler (such as the 68HC11) in Scheme. Because 33 | of this, the implementation is not fully R4RS compliant. I list here 34 | what is or is not included: 35 | 36 | - All the syntax forms are implemented, even the optional ones. 37 | 38 | - The library doesn't cover the I/O ports section, since it makes 39 | little sense in the context of a processor without terminal or file 40 | system. Nevertheless, some I/O functions are implemented, but they 41 | refer only to "standard input" and "standard output". 42 | 43 | - The numbers are restricted to exact bounded integers (fixnums). 44 | 45 | - Absolutely NO error detection is done. The program is assumed to be 46 | bug-free. 47 | 48 | - The remaining of the R4RS is implemented correctly, even high level 49 | features such as first-class continuations and tail-recursion in 50 | constant space are present. 51 | 52 | The implementation produces C code. The run-time module is fairly 53 | small and the byte-code produced from a Scheme source file is very 54 | compact. It's up to the C compiler to produce small executable code 55 | with it. 56 | 57 | - For example, the byte-compilation of all the library file (~25 58 | Kbytes) produces about 5.5 Kbytes of byte-code. 59 | 60 | - My tests with a modified GCC for the 68HC11 produced an executable 61 | of ~22 Kbytes (all the Scheme library functions included). I guess 62 | that a translation by hand in the 68HC11 assembler could give even 63 | better results (say 10 to 14 Kbytes). 64 | 65 | The garbage collector used in the run-time module is a real-time one. 66 | 67 | The implementation is optimized for space, and not at all for speed. 68 | The resulting executables are quite slow. They're about 30 times 69 | slower than the SCM interpreter. 70 | 71 | PAPERS 72 | 73 | Some documentation related to the implementation can be found in my 74 | Web page: 75 | http://www.iro.umontreal.ca/~dube/ 76 | The documentation is in french. 77 | 78 | There is an article about the real-time garbage collector: 79 | "Un GC temps re'el semi-compactant" 80 | 81 | There is my masters thesis: 82 | "Un syste`me de programmation Scheme pour micro-contro^leur" 83 | 84 | WARNING 85 | 86 | I decided to make my implementation accessible because there were many 87 | persons that asked for it. 88 | 89 | - I do not pretend this implementation is complete and can be used as 90 | is (even on the 68HC11). 91 | 92 | - The implementation is not well commented and when there are 93 | comments, they are in french. 94 | 95 | - Everybody is free to modify and use it for educational or research 96 | purposes, but no real support should be expected from me. 97 | 98 | AUTHOR 99 | 100 | Danny Dube' 101 | Universite' de Montre'al 102 | E-mail: dube@iro.umontreal.ca 103 | -------------------------------------------------------------------------------- /bit.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 1995 Danny Dube, Universite de Montreal. */ 2 | /* All rights reserved. */ 3 | 4 | /* Mini interprete Scheme. Troisieme d'une serie. */ 5 | /* Ne traite pas: */ 6 | /* les ports, */ 7 | /* les points flottants, */ 8 | /* les entiers de taille illimitee, */ 9 | /* l'entree de nombres non-decimaux. */ 10 | 11 | #include "bit.h" 12 | 13 | 14 | 15 | 16 | /* Variables globales C ----------------------------------------- */ 17 | 18 | int *mem; 19 | int mem_len, nb_handles, nb_obj, handle1, mem_next, mem_free, mem_stack; 20 | int gc_mark, gc_compact, gc_ratio, gc_time, gc_trav, gc_vecting, gc_cut; 21 | int gc_old, gc_new, gc_len, gc_src, gc_dst, gc_state; 22 | 23 | int nb_symbols; 24 | 25 | int eval_pc; 26 | 27 | int (*cprim0[NBCPRIM0])(void) = 28 | { 29 | peek_char, 30 | read_char, 31 | quit, 32 | return_current_continuation 33 | }; 34 | 35 | int (*cprim1[NBCPRIM1])(int) = 36 | { 37 | pred_boolean, 38 | pred_pair, 39 | car, 40 | cdr, 41 | pred_char, 42 | integer_to_char, 43 | char_to_integer, 44 | pred_string, 45 | make_string, 46 | string_length, 47 | string_copy, 48 | pred_symbol, 49 | symbol_to_string, 50 | string_to_symbol, 51 | pred_number, 52 | pred_vector, 53 | make_vector, 54 | vector_length, 55 | pred_procedure, 56 | write_char, 57 | introspection 58 | }; 59 | 60 | int (*cprim2[NBCPRIM2])(int, int) = 61 | { 62 | cons, 63 | set_car, 64 | set_cdr, 65 | string_ref, 66 | string_equal, 67 | cppoe2, 68 | cplus2, 69 | cmoins2, 70 | cfois2, 71 | cdivise2, 72 | vector_ref, 73 | apply, 74 | eq, 75 | return_there_with_this 76 | }; 77 | 78 | int (*cprim3[NBCPRIM3])(int, int, int) = 79 | { 80 | string_set, 81 | vector_set 82 | }; 83 | 84 | 85 | 86 | 87 | /* Variables globales SCM --------------------------------------- */ 88 | 89 | /* Les variables contenues dans stack */ 90 | /* doivent etre mises a jour par le gc */ 91 | int globs[NBGLOBS]; 92 | 93 | 94 | 95 | 96 | /* Allocation du monceau ---------------------------------------- */ 97 | 98 | void alloc_heap(int taille) 99 | { 100 | int j; 101 | 102 | mem_len = taille; 103 | mem = malloc(mem_len * (sizeof (int))); 104 | if (mem == NULL) 105 | { 106 | fprintf(stderr, "Incapable d'allouer le monceau\n"); 107 | exit(1); 108 | } 109 | nb_handles = (mem_len + 4) / 5; 110 | nb_obj = 0; 111 | handle1 = 0; 112 | for (j=0 ; j= 3) 155 | { 156 | gc_time += size; 157 | if (gc_ratio >= 4) 158 | { 159 | gc_time += size; 160 | if (gc_ratio >=5) 161 | gc_time += size * (gc_ratio - 4); 162 | } 163 | } 164 | 165 | while (gc_time > 0) 166 | switch (gc_state) 167 | { 168 | case 0: 169 | { 170 | if (mem_free == 0) 171 | gc_ratio = mem_len; 172 | else 173 | gc_ratio = (2 * (mem_next - nb_handles) + 174 | 2 * nb_obj + 175 | 2 * nb_scm_globs + 176 | (5 * mem_free + 1) / 2 - 177 | 1) / mem_free; 178 | gc_time += size * gc_ratio; /* Car le ratio etait insuffisant */ 179 | gc_time -= (gc_ratio * 180 | (((2 * gc_ratio - 3) * mem_free - 181 | 4 * (mem_next - nb_handles) - 182 | 4 * nb_obj - 183 | 4 * nb_scm_globs) / 184 | (2 * gc_ratio + 1))); 185 | gc_time += 50; /* Securite! */ 186 | gc_state = 1; 187 | break; 188 | } 189 | case 1: 190 | { 191 | mem_stack = mem_len; 192 | gc_mark = TRUE; 193 | gc_cut = 0; 194 | gc_state = 2; 195 | break; 196 | } 197 | case 2: 198 | { 199 | nbcases = ((nb_scm_globs - gc_cut <= gc_time) ? 200 | nb_scm_globs - gc_cut : 201 | gc_time); 202 | for (j=gc_cut ; j> 2); 244 | gc_len = start; 245 | } 246 | else /* VECTOR */ 247 | { 248 | gc_len = 249 | 2 + vector_len_to_int_vector_len(subnlen >> 2); 250 | gc_cut = 2; 251 | gc_time -= 3; 252 | gc_state = 4; 253 | goto label001; 254 | } 255 | } 256 | } 257 | for (j=start ; j> 2); 326 | break; 327 | } 328 | else /* VECTOR */ 329 | { 330 | court = FALSE; 331 | gc_len = 332 | 2 + vector_len_to_int_vector_len(subnlen >> 2); 333 | break; 334 | } 335 | } 336 | } 337 | handle = SCM_TO_HANDLE(d); 338 | if (!marque) 339 | { 340 | mem[handle] = handle1; 341 | handle1 = handle; 342 | gc_time -= gc_len + 1; 343 | gc_src += gc_len; 344 | gc_state = 7; 345 | } 346 | else if (court) 347 | { 348 | mem[handle] = gc_dst; 349 | for (j=0 ; j> LOGCPI) + 2; 600 | if (intpos >= gc_cut) 601 | return (char *) (&mem[gc_old + 2]); 602 | else 603 | return (char *) (&mem[gc_new + 2]); 604 | } 605 | } 606 | 607 | int c_string_ref(int s, int pos) 608 | { 609 | char *base; 610 | 611 | base = find_string_base(s, pos); 612 | return (int) (*(base + pos)); 613 | } 614 | 615 | int string_ref(int s, int pos) 616 | { 617 | return TO_SCM_CHAR(c_string_ref(s, to_c_number(pos))); 618 | } 619 | 620 | void c_string_set(int s, int pos, int c) 621 | { 622 | char *base; 623 | 624 | base = find_string_base(s, pos); 625 | *(base + pos) = (char) c; 626 | } 627 | 628 | int string_set(int s, int pos, int c) 629 | { 630 | c_string_set(s, to_c_number(pos), TO_C_CHAR(c)); 631 | return scm_true; 632 | } 633 | 634 | int string_length(int s) 635 | { 636 | return TO_SCM_NUMBER(C_STRING_LEN(s)); 637 | } 638 | 639 | int string_len_to_int_string_len(int len) 640 | { 641 | int intlen; 642 | 643 | intlen = (len + CHARSPERINT - 1) >> LOGCPI; 644 | return (intlen == 0) ? 1 : intlen; 645 | } 646 | 647 | int c_string_int_len(int s) 648 | { 649 | return string_len_to_int_string_len(C_STRING_LEN(s)); 650 | } 651 | 652 | int to_scm_string(char *cs, int len) 653 | { 654 | int i, scms; 655 | 656 | scms = c_make_string(len); 657 | for (i=0 ; isymbol */ 721 | int make_symbol(int nom) 722 | { 723 | int numero; 724 | 725 | if (nb_symbols == C_VECTOR_LEN(scm_symbol_names)) 726 | stretch_symbol_vector(); 727 | 728 | numero = nb_symbols; 729 | nb_symbols ++; 730 | c_vector_set(scm_symbol_names, numero, nom); 731 | 732 | return NUMBER_TO_SYMBOL(numero); 733 | } 734 | 735 | int symbol_to_string(int s) 736 | { 737 | return c_vector_ref(scm_symbol_names, SYMBOL_NUMBER(s)); 738 | } 739 | 740 | int string_to_symbol(int string) 741 | { 742 | int j; 743 | 744 | for (j=0 ; j> 1) | BITH1; 765 | else 766 | return n >> 1; 767 | } 768 | 769 | /* Les op. se font AVEC les tags */ 770 | int cppoe2(int n1, int n2) 771 | { 772 | return (n1 <= n2) ? scm_true : scm_false; 773 | } 774 | 775 | int cplus2(int n1, int n2) 776 | { 777 | return n1 + n2 - NUMVAL; 778 | } 779 | 780 | int cmoins2(int n1, int n2) 781 | { 782 | return n1 - n2 + NUMVAL; 783 | } 784 | 785 | int cfois2(int n1, int n2) 786 | { 787 | return TO_SCM_NUMBER(to_c_number(n1) * to_c_number(n2)); 788 | } 789 | 790 | int cdivise2(int n1, int n2) 791 | { 792 | return TO_SCM_NUMBER(to_c_number(n1) / to_c_number(n2)); 793 | } 794 | 795 | 796 | 797 | 798 | /* Fonctions relatives a VECTOR --------------------------------- */ 799 | 800 | int c_pred_vector(int d) 801 | { 802 | return (C_PRED_OTHER(d) && 803 | ((mem[mem[SCM_TO_HANDLE(d)] + 1] & VECTINGMASK) == VECTORVAL)); 804 | } 805 | 806 | int pred_vector(int d) 807 | { 808 | return c_pred_vector(d) ? scm_true : scm_false; 809 | } 810 | 811 | int c_make_vector(int len) 812 | { 813 | int intlen, j; 814 | int cell, handle, vector; 815 | 816 | intlen = vector_len_to_int_vector_len(len); 817 | vector = alloc_cell(2 + intlen, TYPEOTHER); 818 | handle = SCM_TO_HANDLE(vector); 819 | cell = mem[handle]; 820 | mem[cell + 1] = (len << 2) | VECTORVAL; 821 | for (j=0 ; j= gc_cut) 836 | return gc_old; 837 | else 838 | return gc_new; 839 | } 840 | 841 | int c_vector_ref(int v, int pos) 842 | { 843 | int location; 844 | 845 | location = find_vector_location(v, pos); 846 | return mem[location + 2 + pos]; 847 | } 848 | 849 | int vector_ref(int v, int pos) 850 | { 851 | return c_vector_ref(v, to_c_number(pos)); 852 | } 853 | 854 | void c_vector_set(int v, int pos, int val) 855 | { 856 | int location; 857 | 858 | if (gc_mark && IS_MARKED(v)) 859 | mark_it(val); 860 | location = find_vector_location(v, pos); 861 | mem[location + 2 + pos] = val; 862 | } 863 | 864 | int vector_set(int v, int pos, int val) 865 | { 866 | c_vector_set(v, to_c_number(pos), val); 867 | return scm_true; 868 | } 869 | 870 | int vector_length(int v) 871 | { 872 | return TO_SCM_NUMBER(C_VECTOR_LEN(v)); 873 | } 874 | 875 | int vector_len_to_int_vector_len(int len) 876 | { 877 | return (len == 0) ? 1 : len; 878 | } 879 | 880 | int c_vector_int_len(int v) 881 | { 882 | return vector_len_to_int_vector_len(C_VECTOR_LEN(v)); 883 | } 884 | 885 | 886 | 887 | 888 | /* Fonctions relatives a PROCEDURE ------------------------------ */ 889 | 890 | int pred_procedure(int d) 891 | { 892 | return (C_PRED_CPRIM(d) || C_PRED_CLOSURE(d)) ? scm_true : scm_false; 893 | } 894 | 895 | int make_closure(int entry, int env) 896 | { 897 | int cell, handle, closure; 898 | 899 | make_clos_env = env; 900 | closure = alloc_cell(3, TYPECLOS); 901 | handle = SCM_TO_HANDLE(closure); 902 | cell = mem[handle]; 903 | mem[cell + 1] = entry; 904 | mem[cell + 2] = make_clos_env; 905 | return closure; 906 | } 907 | 908 | int closure_entry(int c) 909 | { 910 | return CHAMP(c, 0); 911 | } 912 | 913 | int closure_env(int c) 914 | { 915 | return CHAMP(c, 1); 916 | } 917 | 918 | /* Cette fonction ne peut appeler direct. c_apply */ 919 | /* Note: elle utilise le apply-hook a la fin du bytecode */ 920 | int apply(int c, int args) 921 | { 922 | eval_pc = bytecode_len - 1; 923 | eval_args = cons(c, args); 924 | return scm_false; 925 | } 926 | 927 | 928 | 929 | 930 | /* Fonctions relatives a CONT ----------------------------------- */ 931 | 932 | int c_pred_cont(int d) 933 | { 934 | return (C_PRED_OTHER(d) && 935 | ((mem[mem[SCM_TO_HANDLE(d)] + 1] & CONTMASK) == CONTVAL)); 936 | } 937 | 938 | int make_cont(void) 939 | { 940 | int cell, handle, k; 941 | 942 | k = alloc_cell(5, TYPEOTHER); 943 | handle = SCM_TO_HANDLE(k); 944 | cell = mem[handle]; 945 | mem[cell + 1] = PC_TO_PCTAG(eval_pc); 946 | mem[cell + 2] = eval_env; 947 | mem[cell + 3] = eval_args; 948 | mem[cell + 4] = eval_cont; 949 | return k; 950 | } 951 | 952 | void set_cont_pc(int k, int dest) 953 | { 954 | CHAMP(k, 0) = PC_TO_PCTAG(dest); 955 | } 956 | 957 | void restore_cont(int k) 958 | { 959 | int cell; 960 | 961 | cell = mem[SCM_TO_HANDLE(k)]; 962 | eval_pc = PCTAG_TO_PC(mem[cell + 1]); 963 | eval_env = mem[cell + 2]; 964 | eval_args = mem[cell + 3]; 965 | eval_cont = mem[cell + 4]; 966 | } 967 | 968 | 969 | 970 | 971 | /* Fonctions d'entree/sortie ------------------------------------ */ 972 | 973 | int ll_input(void) 974 | { 975 | int c; 976 | 977 | c = getchar(); 978 | /* 979 | if (c == EOF) 980 | { 981 | printf("EOF\nQuit\n"); 982 | exit(0); 983 | } 984 | */ 985 | return c; 986 | } 987 | 988 | static int look_ahead; 989 | static int look_ahead_valide; 990 | 991 | int c_peek_char(void) 992 | { 993 | if (!look_ahead_valide) 994 | { 995 | look_ahead = ll_input(); 996 | look_ahead_valide = TRUE; 997 | } 998 | return look_ahead; 999 | } 1000 | 1001 | int peek_char(void) 1002 | { 1003 | return TO_SCM_CHAR(c_peek_char()); 1004 | } 1005 | 1006 | int c_read_char(void) 1007 | { 1008 | if (look_ahead_valide) 1009 | { 1010 | look_ahead_valide = FALSE; 1011 | return look_ahead; 1012 | } 1013 | else 1014 | return ll_input(); 1015 | } 1016 | 1017 | int read_char(void) 1018 | { 1019 | return TO_SCM_CHAR(c_read_char()); 1020 | } 1021 | 1022 | int write_char(int c) 1023 | { 1024 | printf("%c", TO_C_CHAR(c)); 1025 | return scm_true; 1026 | } 1027 | 1028 | 1029 | 1030 | 1031 | /* Autres fonctions de la librairie ----------------------------- */ 1032 | 1033 | int eq(int d1, int d2) 1034 | { 1035 | return (d1 == d2) ? scm_true : scm_false; 1036 | } 1037 | 1038 | int quit(void) 1039 | { 1040 | printf("Quit\n"); 1041 | exit(0); 1042 | } 1043 | 1044 | int return_current_continuation(void) 1045 | { 1046 | int temp; 1047 | 1048 | temp = make_cont(); 1049 | return cons(temp, eval_prev_args); 1050 | } 1051 | 1052 | int return_there_with_this(int complete_cont, int val) 1053 | { 1054 | eval_prev_args = cdr(complete_cont); 1055 | restore_cont(car(complete_cont)); 1056 | return val; 1057 | } 1058 | 1059 | 1060 | 1061 | 1062 | /* Fonctions relatives au coeur de l'interprete ----------------- */ 1063 | 1064 | static int intro_state; 1065 | 1066 | int introspection(int arg) 1067 | { 1068 | if (intro_state == 0) 1069 | { 1070 | intro_state = 1; 1071 | return scm_constants; 1072 | } 1073 | else 1074 | { 1075 | scm_constants = arg; 1076 | return scm_false; 1077 | } 1078 | } 1079 | 1080 | 1081 | 1082 | 1083 | /* Le coeur de l'interprete ------------------------------------- */ 1084 | 1085 | void init_bc_reader(void) 1086 | { 1087 | eval_pc = 0; 1088 | return; 1089 | } 1090 | 1091 | int read_bc_byte(void) 1092 | { 1093 | int b; 1094 | 1095 | b = (int) bytecode[eval_pc]; 1096 | eval_pc ++; 1097 | return b; 1098 | } 1099 | 1100 | int read_bc_int(void) 1101 | { 1102 | int msb; 1103 | 1104 | msb = read_bc_byte(); 1105 | return (256 * msb + read_bc_byte()); 1106 | } 1107 | 1108 | int get_frame(int step) 1109 | { 1110 | int frame; 1111 | 1112 | frame = eval_env; 1113 | while (step > 0) 1114 | { 1115 | if (C_PRED_PAIR(frame)) 1116 | frame = car(frame); 1117 | else 1118 | frame = c_vector_ref(frame, 0); 1119 | step --; 1120 | } 1121 | return frame; 1122 | } 1123 | 1124 | int get_var(int frame, int offset) 1125 | { 1126 | int f; 1127 | 1128 | f = get_frame(frame); 1129 | if (C_PRED_PAIR(f)) 1130 | return cdr(f); 1131 | else 1132 | return c_vector_ref(f, 1 + offset); 1133 | } 1134 | 1135 | void set_var(int frame, int offset, int val) 1136 | { 1137 | int f; 1138 | 1139 | f = get_frame(frame); 1140 | if (C_PRED_PAIR(f)) 1141 | set_cdr(f, val); 1142 | else 1143 | c_vector_set(f, 1 + offset, val); 1144 | } 1145 | 1146 | void make_normal_frame(int size) 1147 | { 1148 | int pos; 1149 | int larg, frame; 1150 | 1151 | if (size == 1) 1152 | eval_env = cons(eval_env, car(eval_args)); 1153 | else 1154 | { 1155 | frame = c_make_vector(size + 1); 1156 | c_vector_set(frame, 0, eval_env); 1157 | larg = eval_args; 1158 | for (pos=1 ; pos<=size ; pos++) 1159 | { 1160 | c_vector_set(frame, pos, car(larg)); 1161 | larg = cdr(larg); 1162 | } 1163 | eval_env = frame; 1164 | } 1165 | } 1166 | 1167 | void make_rest_frame(int size) 1168 | { 1169 | int pos; 1170 | int larg; 1171 | int temp; 1172 | 1173 | if (size == 1) 1174 | { 1175 | temp = list_copy(eval_args); 1176 | eval_env = cons(eval_env, temp); 1177 | } 1178 | else 1179 | { 1180 | make_rest_frame_frame = c_make_vector(1 + size); 1181 | c_vector_set(make_rest_frame_frame, 0, eval_env); 1182 | larg = eval_args; 1183 | for (pos=1 ; pos> 1; /* Et non pas to_c_number(code) */ 1644 | return make_closure(entry, scm_empty); 1645 | } 1646 | else 1647 | return code; 1648 | } 1649 | 1650 | int main(int argc, char *argv[]) 1651 | { 1652 | int i; 1653 | 1654 | if ((1 << LOGCPI) != CHARSPERINT) 1655 | { 1656 | fprintf(stderr, "Verifier LOGCPI."); 1657 | exit(1); 1658 | } 1659 | 1660 | alloc_heap(DEFAULTHEAPSIZE); 1661 | 1662 | /* Attention, l'ordre est important! GC, scm_false, etc. */ 1663 | scm_false = FALSEVAL; 1664 | for (i=0 ; i 5 | #include 6 | #include 7 | 8 | /* Personnalisation */ 9 | #define TRUE 1 10 | #define FALSE 0 11 | 12 | /* Configuration */ 13 | #define CHARSPERINT (sizeof (int)) 14 | #define LOGCPI 2 15 | #define DEFAULTHEAPSIZE 65536 16 | 17 | /* Variables globales C */ 18 | extern int *mem; 19 | extern int mem_len, nb_handles, nb_obj, handle1; 20 | extern int mem_next, mem_free, mem_stack; 21 | extern int gc_mark, gc_compact, gc_ratio, gc_time; 22 | extern int gc_trav, gc_vecting, gc_cut; 23 | extern int gc_old, gc_new, gc_len, gc_src, gc_dst, gc_state; 24 | extern int nb_symbols; 25 | extern int eval_pc; 26 | extern int (*cprim0[])(void); 27 | extern int (*cprim1[])(int); 28 | extern int (*cprim2[])(int, int); 29 | extern int (*cprim3[])(int, int, int); 30 | 31 | /* Variables globales SCM */ 32 | #define NBTEMPS 6 33 | #define cons_car (globs[0]) 34 | #define cons_cdr (globs[1]) 35 | #define string_copy_s1 (globs[0]) 36 | #define make_clos_env (globs[0]) 37 | #define list_copy_tete (globs[2]) 38 | #define list_copy_courant (globs[3]) 39 | #define list_copy_l (globs[4]) 40 | #define make_rest_frame_frame (globs[5]) 41 | 42 | #define NBSINGLES 10 43 | #define scm_empty (globs[NBTEMPS + 0]) 44 | #define scm_false (globs[NBTEMPS + 1]) 45 | #define scm_true (globs[NBTEMPS + 2]) 46 | #define scm_symbol_names (globs[NBTEMPS + 3]) 47 | #define scm_constants (globs[NBTEMPS + 4]) 48 | 49 | #define eval_val (globs[NBTEMPS + 5]) 50 | #define eval_env (globs[NBTEMPS + 6]) 51 | #define eval_args (globs[NBTEMPS + 7]) 52 | #define eval_prev_args (globs[NBTEMPS + 8]) 53 | #define eval_cont (globs[NBTEMPS + 9]) 54 | 55 | #define NBGLOBS (NBTEMPS + NBSINGLES) 56 | extern int globs[]; 57 | 58 | /* Description des types et macros du GC */ 59 | #define BITH1 0x80000000 60 | #define BITH2 0x40000000 61 | #define BITB4 0x8 62 | #define BITB3 0x4 63 | #define BITB2 0x2 64 | #define BITB1 0x1 65 | 66 | #define NUMMASK BITB1 67 | #define NUMVAL BITB1 68 | #define TYPEMASK (BITH1 | BITH2 | BITB1) 69 | #define TYPEPAIR 0 70 | #define TYPECLOS BITH2 71 | #define TYPEOTHER BITH1 72 | #define TYPESPEC (BITH1 | BITH2) 73 | #define CONTMASK BITB1 74 | #define CONTVAL BITB1 75 | #define VECTINGMASK (BITB2 | BITB1) 76 | #define VECTORVAL 0 77 | #define STRINGVAL BITB2 78 | #define SYMBMASK (BITH1 | BITH2 | BITB2 | BITB1) 79 | #define SYMBVAL (BITH1 | BITH2 | BITB2) 80 | #define SPECMASK (BITH1 | BITH2 | BITB4 | BITB3 | BITB2 | BITB1) 81 | #define SPECCHAR (BITH1 | BITH2) 82 | #define SPECCPRIM (BITH1 | BITH2 | BITB3) 83 | #define SPECBOOL (BITH1 | BITH2 | BITB4) 84 | #define NULLVAL 0xfffffffc 85 | #define FALSEVAL 0xffffffe8 86 | #define TRUEVAL 0xfffffff8 87 | #define HANDLEMASK (~TYPEMASK) 88 | 89 | #define C_PRED_NUMBER(d) (((d) & NUMMASK) == NUMVAL) 90 | #define C_PRED_PAIR(d) (((d) & TYPEMASK) == TYPEPAIR) 91 | #define C_PRED_CLOSURE(d) (((d) & TYPEMASK) == TYPECLOS) 92 | #define C_PRED_OTHER(d) (((d) & TYPEMASK) == TYPEOTHER) 93 | #define C_PRED_SPECIAL(d) (((d) & TYPEMASK) == TYPESPEC) 94 | #define C_PRED_SYMBOL(d) (((d) & SYMBMASK) == SYMBVAL) 95 | #define C_PRED_CHAR(d) (((d) & SPECMASK) == SPECCHAR) 96 | #define C_PRED_CPRIM(d) (((d) & SPECMASK) == SPECCPRIM) 97 | #define C_PRED_BOOLEAN(d) (((d) & SPECMASK) == SPECBOOL) 98 | 99 | #define GC_MARK 1 100 | #define IS_MARKED(data) (mem[mem[SCM_TO_HANDLE(data)]] & GC_MARK) 101 | 102 | /* Fonctions de manipulation des donnees */ 103 | 104 | #define SCM_TO_HANDLE(d) (((d) & HANDLEMASK) >> 1) 105 | #define HANDLE_TO_PAIR(i) (((i) << 1) | TYPEPAIR) 106 | #define HANDLE_TO_CLOSURE(i) (((i) << 1) | TYPECLOS) 107 | #define HANDLE_TO_OTHER(i) (((i) << 1) | TYPEOTHER) 108 | #define TO_SCM_CHAR(c) (((c) << 4) | SPECCHAR) 109 | #define TO_C_CHAR(c) (((c) >> 4) & 0xff) 110 | #define C_STRING_LEN(s) (mem[mem[SCM_TO_HANDLE(s)] + 1] >> 2) 111 | #define SYMBOL_NUMBER(s) (((s) & ~SYMBMASK) >> 2) 112 | #define NUMBER_TO_SYMBOL(n) (((n) << 2) | SYMBVAL) 113 | #define TO_SCM_NUMBER(n) (((n) << 1) | NUMVAL) 114 | #define C_VECTOR_LEN(v) (mem[mem[SCM_TO_HANDLE(v)] + 1] >> 2) 115 | #define C_MAKE_CPRIM(n) (((n) << 4) | SPECCPRIM) 116 | #define CPRIM_NUMBER(c) (((c) & ~SPECMASK) >> 4) 117 | #define PC_TO_PCTAG(p) (((p) << 1) | CONTVAL) 118 | #define PCTAG_TO_PC(p) ((p) >> 1) 119 | #define CHAMP(d,champ) (mem[mem[SCM_TO_HANDLE(d)] + 1 + (champ)]) 120 | 121 | /* Description des primitives C */ 122 | #define NBCPRIM0 4 123 | #define FIRSTCPRIM0 0 124 | #define NBCPRIM1 21 125 | #define FIRSTCPRIM1 (FIRSTCPRIM0 + NBCPRIM0) 126 | #define NBCPRIM2 14 127 | #define FIRSTCPRIM2 (FIRSTCPRIM1 + NBCPRIM1) 128 | #define NBCPRIM3 2 129 | #define FIRSTCPRIM3 (FIRSTCPRIM2 + NBCPRIM2) 130 | #define APPLY_CPRIM_NO 36 131 | 132 | /* Variables du module Scheme compile */ 133 | extern int bytecode_len; 134 | extern unsigned char bytecode[]; 135 | extern int const_desc_len; 136 | extern unsigned char const_desc[]; 137 | extern int nb_scm_globs; 138 | extern int scm_globs[]; 139 | 140 | /* Prototypes de bit.c */ 141 | void alloc_heap(int taille); 142 | int is_allocated(int d); 143 | void mark_it(int d); 144 | void gc(int size); 145 | int alloc_cell(int len, int bitpattern); 146 | int pred_boolean(int d); 147 | int pred_pair(int d); 148 | int cons(int car, int cdr); 149 | int car(int p); 150 | int cdr(int p); 151 | int set_car(int p, int d); 152 | int set_cdr(int p, int d); 153 | int list_copy(int l); 154 | int pred_char(int d); 155 | int integer_to_char(int n); 156 | int char_to_integer(int c); 157 | int c_pred_string(int d); 158 | int pred_string(int d); 159 | int c_make_string(int len); 160 | int make_string(int len); 161 | char *find_string_base(int s, int pos); 162 | int c_string_ref(int s, int pos); 163 | int string_ref(int s, int pos); 164 | void c_string_set(int s, int pos, int c); 165 | int string_set(int s, int pos, int c); 166 | int string_length(int s); 167 | int string_len_to_int_string_len(int len); 168 | int c_string_int_len(int s); 169 | int to_scm_string(char *cs, int len); 170 | int c_string_equal(int s1, int s2); 171 | int string_equal(int s1, int s2); 172 | int string_copy(int s1); 173 | int pred_symbol(int d); 174 | void stretch_symbol_vector(void); 175 | int make_symbol(int nom); 176 | int symbol_to_string(int s); 177 | int string_to_symbol(int string); 178 | int pred_number(int d); 179 | int to_c_number(int n); 180 | int cppoe2(int n1, int n2); 181 | int cplus2(int n1, int n2); 182 | int cmoins2(int n1, int n2); 183 | int cfois2(int n1, int n2); 184 | int cdivise2(int n1, int n2); 185 | int c_pred_vector(int d); 186 | int pred_vector(int d); 187 | int c_make_vector(int len); 188 | int make_vector(int len); 189 | int find_vector_location(int v, int pos); 190 | int c_vector_ref(int v, int pos); 191 | int vector_ref(int v, int pos); 192 | void c_vector_set(int v, int pos, int val); 193 | int vector_set(int v, int pos, int val); 194 | int vector_length(int v); 195 | int vector_len_to_int_vector_len(int len); 196 | int c_vector_int_len(int v); 197 | int pred_procedure(int d); 198 | int make_closure(int entry, int env); 199 | int closure_entry(int c); 200 | int closure_env(int c); 201 | int apply(int c, int args); 202 | int c_pred_cont(int d); 203 | int make_cont(void); 204 | void set_cont_pc(int k, int dest); 205 | void restore_cont(int k); 206 | int ll_input(void); 207 | int c_peek_char(void); 208 | int peek_char(void); 209 | int c_read_char(void); 210 | int read_char(void); 211 | int write_char(int c); 212 | int eq(int d1, int d2); 213 | int quit(void); 214 | int return_current_continuation(void); 215 | int return_there_with_this(int complete_cont, int val); 216 | int introspection(int arg); 217 | void init_bc_reader(void); 218 | int read_bc_byte(void); 219 | int read_bc_int(void); 220 | int get_frame(int step); 221 | int get_var(int frame, int offset); 222 | void set_var(int frame, int offset, int val); 223 | void make_normal_frame(int size); 224 | void make_rest_frame(int size); 225 | void push_arg(int arg); 226 | int pop_arg(void); 227 | void pop_n_args(int n); 228 | int apply_cprim(int cprim_no, int args); 229 | int apply_closure(int c, int args); 230 | void c_apply(int c, int args); 231 | void execute_bc(void); 232 | int init_scm_glob_1(int code); 233 | int init_scm_glob_2(int code); 234 | int main(int argc, char *argv[]); 235 | -------------------------------------------------------------------------------- /bit.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (C) 1995 Danny Dube, Universite de Montreal. All rights reserved. 2 | 3 | ; Les fonctions utilitaires generales 4 | 5 | ; Suppose que les deux arguments sont deja des ensembles de symboles 6 | (define symbol-set-union 7 | (lambda (ss1 ss2) 8 | (cond ((null? ss1) 9 | ss2) 10 | ((memq (car ss1) ss2) 11 | (symbol-set-union (cdr ss1) ss2)) 12 | (else 13 | (cons (car ss1) (symbol-set-union (cdr ss1) ss2)))))) 14 | 15 | (define symbol-set-intersection 16 | (lambda (ss1 ss2) 17 | (cond ((null? ss1) 18 | '()) 19 | ((memq (car ss1) ss2) 20 | (cons (car ss1) (symbol-set-intersection (cdr ss1) ss2))) 21 | (else 22 | (symbol-set-intersection (cdr ss1) ss2))))) 23 | 24 | (define foldr 25 | (lambda (binop start l) 26 | (if (null? l) 27 | start 28 | (binop (car l) (foldr binop start (cdr l)))))) 29 | 30 | (define foldr1 31 | (lambda (binop l) 32 | (if (null? (cdr l)) 33 | (car l) 34 | (binop (car l) (foldr1 binop (cdr l)))))) 35 | 36 | (define filter 37 | (lambda (pred? l) 38 | (cond ((null? l) '()) 39 | ((pred? (car l)) (cons (car l) (filter pred? (cdr l)))) 40 | (else (filter pred? (cdr l)))))) 41 | 42 | (define formals->varlist 43 | (lambda (formals) 44 | (cond ((symbol? formals) 45 | (list formals)) 46 | ((null? formals) 47 | '()) 48 | (else 49 | (cons (car formals) (formals->varlist (cdr formals))))))) 50 | 51 | (define prefix? 52 | (lambda (s1 s2) 53 | (let ((l1 (string-length s1)) 54 | (l2 (string-length s2))) 55 | (if (> l1 l2) 56 | #f 57 | (let loop ((i 0)) 58 | (cond ((= i l1) 59 | #t) 60 | ((char=? (string-ref s1 i) (string-ref s2 i)) 61 | (loop (+ i 1))) 62 | (else 63 | #f))))))) 64 | 65 | (define unprefix 66 | (lambda (s1 s2) 67 | (let ((l1 (string-length s1))) 68 | (cond ((= l1 (string-length s2)) 69 | (string-append s1 "a")) 70 | ((char=? #\a (string-ref s2 l1)) 71 | (string-append s1 "b")) 72 | (else 73 | (string-append s1 "a")))))) 74 | 75 | 76 | 77 | 78 | ; Initialiser les variables globales du programme 79 | 80 | (define init-glob-vars 81 | (lambda () 82 | (set! safe-name-memv ') 83 | (set! safe-name-make-promise ') 84 | (set! safe-name-list->vector 'vector>) 85 | (set! safe-name-list ') 86 | (set! safe-name-append2 ') 87 | (set! safe-name-cons ') 88 | (set! gen-sym-pref #f) 89 | (set! gen-sym-number 0) 90 | (set! libcprims #f) 91 | (set! libalias #f) 92 | (set! libclos #f) 93 | (set! libpublics #f) 94 | (set! libnames #f) 95 | (set! apply1-cprim-no #f) 96 | (set! dirreq #f) 97 | (set! allreq #f) 98 | (set! req-clos-nodes #f) 99 | (set! const-counter 0) 100 | (set! const-alist '()) 101 | (set! top-counter 0) 102 | (set! top-alist '()) 103 | (set! const-desc-string #f) 104 | (set! glob-counter 0) 105 | (set! glob-hidden '()) 106 | (set! glob-public '()) 107 | (set! glob-source '()) 108 | (set! glob-v '#()) 109 | (set! glob-v-len 0) 110 | (set! phys-glob-no 0) 111 | (set! program-bytecode #f) 112 | (set! label-counter 0) 113 | (set! label-v '#()) 114 | (set! label-v-len 0) 115 | (set! flat-program-bytecode #f) 116 | (set! final-program-bytecode #f) 117 | (set! glob-var-init-codes #f))) 118 | 119 | 120 | 121 | 122 | ; Lire le programme source 123 | 124 | (define read-source 125 | (lambda () 126 | (let loop () 127 | (let ((exp (read))) 128 | (if (eof-object? exp) '() 129 | (cons exp (loop))))))) 130 | 131 | 132 | 133 | 134 | ; Trouver des noms pour memv, make-promise, list->vector, list, 135 | ; append2 et cons. De cette facon, trans-case & cie plus loin 136 | ; pourront inserer un symbole representant une fonction 137 | ; du systeme aux endroits generes par les macros-expansion 138 | 139 | (define safe-name-memv ') 140 | (define safe-name-make-promise ') 141 | (define safe-name-list->vector 'vector>) 142 | (define safe-name-list ') 143 | (define safe-name-append2 ') 144 | (define safe-name-cons ') 145 | 146 | ; Cette fonction ne fonctionne que pour les struc. non-circ. 147 | (define find-all-symbols 148 | (lambda (d) 149 | (cond ((symbol? d) 150 | (list d)) 151 | ((pair? d) 152 | (symbol-set-union (find-all-symbols (car d)) 153 | (find-all-symbols (cdr d)))) 154 | ((vector? d) 155 | (let loop ((pos (- (vector-length d) 1))) 156 | (if (< pos 0) 157 | '() 158 | (symbol-set-union (find-all-symbols (vector-ref d pos)) 159 | (loop (- pos 1)))))) 160 | (else 161 | '())))) 162 | 163 | ; Trouver un prefixe unique pour avoir un gen-sym correct 164 | (define find-uniq-prefix 165 | (lambda (ss) 166 | (let loop ((pref "") (names (map symbol->string ss))) 167 | (if (null? names) 168 | pref 169 | (let ((name (car names))) 170 | (if (prefix? pref name) 171 | (loop (unprefix pref name) (cdr names)) 172 | (loop pref (cdr names)))))))) 173 | 174 | ; La fonction gen-sym 175 | (define gen-sym-pref #f) 176 | (define gen-sym-number 0) 177 | 178 | (define gen-sym 179 | (lambda () 180 | (let* ((str-num (number->string gen-sym-number)) 181 | (sym-name (string-append gen-sym-pref str-num)) 182 | (sym (string->symbol sym-name))) 183 | (set! gen-sym-number (+ gen-sym-number 1)) 184 | sym))) 185 | 186 | 187 | 188 | 189 | ; Traduction des expressions Scheme en expressions plus simples 190 | ; Il ne reste que des references de var., des quotes, des literaux 191 | ; s'evaluant a eux-memes, des appels de procedure, des lambda exp., 192 | ; des if, des set!, des begins, des defines se rapportant a des 193 | ; var. glob. uniquement 194 | 195 | ; A ne pas inserer dans la liste des translators 196 | (define trans-define 197 | (lambda (l) 198 | (if (symbol? (cadr l)) 199 | l 200 | (let ((procname (caadr l)) 201 | (formals (cdadr l)) 202 | (exps (cddr l))) 203 | `(define ,procname (lambda ,formals ,@exps)))))) 204 | 205 | ; A ne pas inserer dans la liste des translators 206 | (define flatten-begin 207 | (lambda (expbegin) 208 | (cons 'begin 209 | (let loop ((l (cdr expbegin)) (flat '())) 210 | (if (null? l) 211 | flat 212 | (let ((tete (car l)) 213 | (queue (cdr l))) 214 | (if (and (pair? tete) (eq? (car tete) 'begin)) 215 | (loop (cdr tete) (loop queue flat)) 216 | (cons tete (loop queue flat))))))))) 217 | 218 | ; A ne pas inserer dans la liste des translators 219 | (define extract-define 220 | (lambda (lexp) 221 | (let ((tete (car lexp)) 222 | (reste (cdr lexp))) 223 | (if (and (pair? tete) (eq? (car tete) 'define)) 224 | (let ((result (extract-define reste))) 225 | (cons (cons tete (car result)) (cdr result))) 226 | (cons '() lexp))))) 227 | 228 | ; A ne pas inserer dans la liste des translators 229 | (define trans-body 230 | (lambda (l) 231 | (let* ((flatbody (flatten-begin l)) 232 | (result (extract-define (cdr flatbody))) 233 | (rawdefines (car result)) 234 | (exps (cdr result)) 235 | (defines (map trans-define rawdefines)) 236 | (decls (map cdr defines)) 237 | (body `(begin ,@exps))) 238 | (if (null? decls) 239 | body 240 | `(letrec ,decls ,body))))) 241 | 242 | ; A ne pas inserer dans la liste des translators 243 | (define trans-lambda 244 | (lambda (l) 245 | (list 'lambda 246 | (cadr l) 247 | (trans-body (cons 'begin (cddr l)))))) 248 | 249 | ; A ne pas inserer dans la liste des translators 250 | (define trans-begin 251 | (lambda (l) 252 | (let ((flat (flatten-begin l))) 253 | (if (null? (cddr flat)) 254 | (cadr flat) 255 | flat)))) 256 | 257 | ; A ne pas inserer dans la liste des translators 258 | (define trans-normal-let 259 | (lambda (l) 260 | (let* ((bindings (cadr l)) 261 | (body (cddr l)) 262 | (vars (map car bindings)) 263 | (inits (map cadr bindings))) 264 | `((lambda ,vars ,@body) ,@inits)))) 265 | 266 | ; A ne pas inserer dans la liste des translators 267 | (define trans-let-loop 268 | (lambda (l) 269 | (let* ((loop-name (cadr l)) 270 | (bindings (caddr l)) 271 | (body (cdddr l)) 272 | (vars (map car bindings)) 273 | (inits (map cadr bindings))) 274 | `((letrec ((,loop-name (lambda ,vars ,@body))) 275 | ,loop-name) 276 | ,@inits)))) 277 | 278 | (define trans-let 279 | (lambda (l) 280 | (if (symbol? (cadr l)) 281 | (trans-let-loop l) 282 | (trans-normal-let l)))) 283 | 284 | (define trans-let* 285 | (lambda (l) 286 | (let ((bindings (cadr l)) 287 | (body (cddr l))) 288 | (if (or (null? bindings) (null? (cdr bindings))) 289 | `(let ,bindings ,@body) 290 | (let ((prem (car bindings)) 291 | (reste (cdr bindings))) 292 | `(let (,prem) (let* ,reste ,@body))))))) 293 | 294 | (define trans-letrec 295 | (lambda (l) 296 | (let ((bindings (cadr l)) 297 | (body (cddr l))) 298 | (if (null? bindings) 299 | `(let () ,@body) 300 | (let* ((vars (map car bindings)) 301 | (inits (map cadr bindings)) 302 | (falsebind (map (lambda (v) `(,v #f)) vars)) 303 | (set!s (map (lambda (v i) `(set! ,v ,i)) vars inits))) 304 | `(let ,falsebind 305 | ,@set!s 306 | (let () ,@body))))))) 307 | 308 | (define trans-and 309 | (lambda (l) 310 | (cond ((null? (cdr l)) 311 | #t) 312 | ((null? (cddr l)) 313 | (cadr l)) 314 | (else 315 | `(if ,(cadr l) (and ,@(cddr l)) #f))))) 316 | 317 | (define trans-or 318 | (lambda (l) 319 | (cond ((null? (cdr l)) 320 | #f) 321 | ((null? (cddr l)) 322 | (cadr l)) 323 | (else 324 | (let* ((e-hd (cadr l)) 325 | (e-tl (cddr l)) 326 | (tmp (gen-sym))) 327 | `(let ((,tmp ,e-hd)) 328 | (if ,tmp 329 | ,tmp 330 | (or ,@e-tl)))))))) 331 | 332 | (define trans-cond 333 | (lambda (l) 334 | (if (null? (cdr l)) 335 | #f 336 | (let* ((clause (cadr l)) 337 | (autres (cddr l)) 338 | (newcond (cons 'cond autres))) 339 | (cond ((eq? (car clause) 'else) 340 | (cons 'begin (cdr clause))) 341 | ((null? (cdr clause)) 342 | (list 'or (car clause) newcond)) 343 | ((eq? (cadr clause) '=>) 344 | (let* ((test (car clause)) 345 | (recipient (caddr clause)) 346 | (tmp (gen-sym))) 347 | `(let ((,tmp ,test)) 348 | (if ,tmp 349 | (,recipient ,tmp) 350 | ,newcond)))) 351 | (else 352 | (let* ((test (car clause)) 353 | (actions (cdr clause)) 354 | (conseq (cons 'begin actions))) 355 | `(if ,test ,conseq ,newcond)))))))) 356 | 357 | (define trans-case 358 | (lambda (l) 359 | (let* ((tmp-key (gen-sym)) 360 | (trans-test 361 | (lambda (test) 362 | (if (eq? test 'else) 'else `(,safe-name-memv ,tmp-key ',test)))) 363 | (key (cadr l)) 364 | (clauses (cddr l)) 365 | (tests (map car clauses)) 366 | (expr-lists (map cdr clauses)) 367 | (memv-tests (map trans-test tests)) 368 | (cond-clauses (map cons memv-tests expr-lists))) 369 | `(let ((,tmp-key ,key)) (cond ,@cond-clauses))))) 370 | 371 | (define trans-do 372 | (lambda (l) 373 | (let* ((normalize-step (lambda (v sf) 374 | (if (null? sf) v (car sf)))) 375 | (bindings (cadr l)) 376 | (testnsequence (caddr l)) 377 | (commands (cdddr l)) 378 | (vars (map car bindings)) 379 | (inits (map cadr bindings)) 380 | (steps-fac (map cddr bindings)) 381 | (steps (map normalize-step vars steps-fac)) 382 | (test (car testnsequence)) 383 | (sequence (cdr testnsequence)) 384 | (loop-var (gen-sym)) 385 | (loop-call (cons loop-var steps)) 386 | (loop-bindings (map list vars inits))) 387 | `(let ,loop-var ,loop-bindings 388 | (if ,test 389 | (begin 390 | #f 391 | ,@sequence) 392 | (begin 393 | ,@commands 394 | ,loop-call)))))) 395 | 396 | (define trans-delay 397 | (lambda (exp) 398 | (let ((delexp (cadr exp))) 399 | `(,safe-name-make-promise (lambda () ,delexp))))) 400 | 401 | ; A ne pas inclure dans la liste des translators 402 | (define detect-unquote 403 | (lambda (exp level) 404 | (cond ((vector? exp) 405 | (let loop ((pos (- (vector-length exp) 1))) 406 | (cond ((< pos 0) 407 | #f) 408 | ((detect-unquote (vector-ref exp pos) level) 409 | #t) 410 | (else 411 | (loop (- pos 1)))))) 412 | ((pair? exp) 413 | (let ((tete (car exp))) 414 | (cond ((eq? tete 'quasiquote) 415 | (detect-unquote (cadr exp) (+ level 1))) 416 | ((or (eq? tete 'unquote) (eq? tete 'unquote-splicing)) 417 | (if (= level 1) 418 | #t 419 | (detect-unquote (cadr exp) (- level 1)))) 420 | (else 421 | (or (detect-unquote tete level) 422 | (detect-unquote (cdr exp) level)))))) 423 | (else 424 | #f)))) 425 | 426 | (define trans-quasiquote 427 | (lambda (l) 428 | (let loop ((exp (cadr l)) (level 1)) 429 | (cond ((not (detect-unquote exp level)) 430 | (list 'quote exp)) 431 | ((vector? exp) 432 | (list safe-name-list->vector 433 | (loop (vector->list exp) level))) 434 | ((pair? exp) 435 | (let ((tete (car exp))) 436 | (cond ((eq? tete 'quasiquote) 437 | (list safe-name-list 438 | ''quasiquote 439 | (loop (cadr exp) (+ level 1)))) 440 | ((eq? tete 'unquote) 441 | (if (= level 1) 442 | (cadr exp) 443 | (list safe-name-list 444 | ''unquote 445 | (loop (cadr exp) (- level 1))))) 446 | ((and (pair? tete) 447 | (eq? (car tete) 'unquote-splicing) 448 | (= level 1)) 449 | (if (null? (cdr exp)) 450 | (cadr tete) 451 | (list safe-name-append2 452 | (cadr tete) 453 | (loop (cdr exp) level)))) 454 | ((eq? tete 'unquote-splicing) 455 | (list safe-name-list 456 | ''unquote-splicing 457 | (loop (cadr exp) (- level 1)))) 458 | (else 459 | (list safe-name-cons 460 | (loop (car exp) level) 461 | (loop (cdr exp) level)))))))))) 462 | 463 | (define translators 464 | (list (cons 'let trans-let) 465 | (cons 'let* trans-let*) 466 | (cons 'letrec trans-letrec) 467 | (cons 'and trans-and) 468 | (cons 'or trans-or) 469 | (cons 'cond trans-cond) 470 | (cons 'case trans-case) 471 | (cons 'do trans-do) 472 | (cons 'delay trans-delay) 473 | (cons 'quasiquote trans-quasiquote))) 474 | 475 | (define trans-sub 476 | (lambda (exp) 477 | (if (or (boolean? exp) 478 | (symbol? exp) 479 | (char? exp) 480 | (number? exp) 481 | (string? exp)) 482 | exp 483 | (let ((tete (car exp))) 484 | (cond ((eq? tete 'quote) 485 | exp) 486 | ((eq? tete 'lambda) 487 | (let ((new-lambda (trans-lambda exp))) 488 | (list 'lambda 489 | (cadr new-lambda) 490 | (trans-sub (caddr new-lambda))))) 491 | ((eq? tete 'if) 492 | (cons 'if (map trans-sub (cdr exp)))) 493 | ((eq? tete 'set!) 494 | (list 'set! (cadr exp) (trans-sub (caddr exp)))) 495 | ((eq? tete 'begin) 496 | (trans-begin (cons 'begin (map trans-sub (cdr exp))))) 497 | ((eq? tete 'define) 498 | (let ((new-define (trans-define exp))) 499 | (list 'define 500 | (cadr new-define) 501 | (trans-sub (caddr new-define))))) 502 | (else 503 | (let ((ass (assq tete translators))) 504 | (if ass 505 | (trans-sub ((cdr ass) exp)) 506 | (let ((new-exp (map trans-sub exp))) 507 | (if (and (pair? (car new-exp)) 508 | (eq? (caar new-exp) 'lambda) 509 | (null? (cadar new-exp))) 510 | (caddar new-exp) 511 | new-exp)))))))))) 512 | 513 | 514 | 515 | 516 | ; Operations sur les nodes 517 | 518 | (define make-cte-node 519 | (lambda (cte) (vector 0 cte #f))) 520 | (define make-ref-node 521 | (lambda (symbol) (vector 1 symbol #f #f #f))) 522 | (define make-ref-node-full 523 | (lambda (symbol loc val glob?) (vector 1 symbol loc val glob?))) 524 | (define make-lambda-node 525 | (lambda (formals body) (vector 2 formals #f body #f))) 526 | (define make-if-node 527 | (lambda (test conseq altern) (vector 3 test conseq altern))) 528 | (define make-set!-node 529 | (lambda (symbol exp) (vector 4 symbol #f exp #f))) 530 | (define make-begin-node 531 | (lambda (lexp) (vector 5 lexp))) 532 | (define make-def-node 533 | (lambda (symbol exp) (vector 6 symbol #f exp))) 534 | (define make-call-node 535 | (lambda (op larg) (vector 7 op larg))) 536 | (define make-globdesc-node 537 | (lambda (symbol lib? nbaff) (vector 8 symbol lib? nbaff #f #f #f))) 538 | 539 | (define node-type 540 | (lambda (node) 541 | (vector-ref node 0))) 542 | 543 | (define cte-node? (lambda (node) (= (node-type node) 0))) 544 | (define ref-node? (lambda (node) (= (node-type node) 1))) 545 | (define lambda-node? (lambda (node) (= (node-type node) 2))) 546 | (define if-node? (lambda (node) (= (node-type node) 3))) 547 | (define set!-node? (lambda (node) (= (node-type node) 4))) 548 | (define begin-node? (lambda (node) (= (node-type node) 5))) 549 | (define def-node? (lambda (node) (= (node-type node) 6))) 550 | (define call-node? (lambda (node) (= (node-type node) 7))) 551 | (define globdesc-node? (lambda (node) (= (node-type node) 8))) 552 | 553 | (define getter1 (lambda (node) (vector-ref node 1))) 554 | (define getter2 (lambda (node) (vector-ref node 2))) 555 | (define getter3 (lambda (node) (vector-ref node 3))) 556 | (define getter4 (lambda (node) (vector-ref node 4))) 557 | (define getter5 (lambda (node) (vector-ref node 5))) 558 | (define getter6 (lambda (node) (vector-ref node 6))) 559 | 560 | (define get-cte getter1) 561 | (define get-no getter2) 562 | (define get-symbol getter1) 563 | (define get-loc getter2) 564 | (define get-val getter3) 565 | (define get-glob? getter4) 566 | (define get-formals getter1) 567 | (define get-fdesc getter2) 568 | (define get-body getter3) 569 | (define get-label getter4) 570 | (define get-test getter1) 571 | (define get-conseq getter2) 572 | (define get-altern getter3) 573 | (define get-exp getter3) 574 | (define get-lexp getter1) 575 | (define get-op getter1) 576 | (define get-larg getter2) 577 | (define get-lib? getter2) 578 | (define get-nbaff getter3) 579 | (define get-init getter4) 580 | (define get-libno getter5) 581 | (define get-srcno getter6) 582 | 583 | (define setter1 (lambda (node val) (vector-set! node 1 val))) 584 | (define setter2 (lambda (node val) (vector-set! node 2 val))) 585 | (define setter3 (lambda (node val) (vector-set! node 3 val))) 586 | (define setter4 (lambda (node val) (vector-set! node 4 val))) 587 | (define setter5 (lambda (node val) (vector-set! node 5 val))) 588 | (define setter6 (lambda (node val) (vector-set! node 6 val))) 589 | 590 | (define set-no! setter2) 591 | (define set-glob?! setter4) 592 | (define set-loc! setter2) 593 | (define set-fdesc! setter2) 594 | (define set-nbaff! setter3) 595 | (define set-init! setter4) 596 | (define set-op! setter1) 597 | (define set-val! setter3) 598 | (define set-libno! setter5) 599 | (define set-srcno! setter6) 600 | (define set-label! setter4) 601 | 602 | 603 | 604 | 605 | ; Transformation du code source en noeuds fonctionnels. 606 | 607 | (define lnode #f) 608 | 609 | (define exp->node 610 | (lambda (exp) 611 | (cond ((or (boolean? exp) (char? exp) (number? exp) (string? exp)) 612 | (make-cte-node exp)) 613 | ((symbol? exp) 614 | (make-ref-node exp)) 615 | (else ; pair 616 | (let ((tete (car exp))) 617 | (cond ((eq? tete 'quote) 618 | (make-cte-node (cadr exp))) 619 | ((eq? tete 'lambda) 620 | (make-lambda-node (cadr exp) (exp->node (caddr exp)))) 621 | ((eq? tete 'if) 622 | (make-if-node (exp->node (cadr exp)) 623 | (exp->node (caddr exp)) 624 | (exp->node 625 | (if (null? (cdddr exp)) #f (cadddr exp))))) 626 | ((eq? tete 'set!) 627 | (make-set!-node (cadr exp) (exp->node (caddr exp)))) 628 | ((eq? tete 'begin) 629 | (make-begin-node (map exp->node (cdr exp)))) 630 | ((eq? tete 'define) 631 | (make-def-node (cadr exp) (exp->node (caddr exp)))) 632 | (else ; procedure call 633 | (make-call-node (exp->node (car exp)) 634 | (map exp->node (cdr exp)))))))))) 635 | 636 | 637 | 638 | 639 | ; Ramassage des variables globales definies, modifiees ou lues 640 | 641 | (define extract-glob-names 642 | (let ((action-v 643 | (vector 644 | (lambda (node loop env) ; cte 645 | '()) 646 | (lambda (node loop env) ; ref 647 | (let ((refsym (get-symbol node))) 648 | (if (memq refsym env) 649 | '() 650 | (list refsym)))) 651 | (lambda (node loop env) ; lambda 652 | (loop (get-body node) 653 | (symbol-set-union env (formals->varlist 654 | (get-formals node))))) 655 | (lambda (node loop env) ; if 656 | (let ((test-globs (loop (get-test node) env)) 657 | (conseq-globs (loop (get-conseq node) env)) 658 | (altern-globs (loop (get-altern node) env))) 659 | (symbol-set-union (symbol-set-union test-globs conseq-globs) 660 | altern-globs))) 661 | (lambda (node loop env) ; set! 662 | (let* ((set!sym (get-symbol node)) 663 | (l (if (memq set!sym env) '() (list set!sym)))) 664 | (symbol-set-union l (loop (get-exp node) env)))) 665 | (lambda (node loop env) ; begin 666 | (let* ((lnode (get-lexp node)) 667 | (llglob (map (lambda (node) (loop node env)) lnode))) 668 | (foldr1 symbol-set-union llglob))) 669 | (lambda (node loop env) ; def 670 | (symbol-set-union (list (get-symbol node)) 671 | (loop (get-exp node) env))) 672 | (lambda (node loop env) ; call 673 | (let* ((lnode (cons (get-op node) (get-larg node))) 674 | (llglob (map (lambda (node) (loop node env)) lnode))) 675 | (foldr1 symbol-set-union llglob)))))) 676 | (lambda (node) 677 | (let loop ((node node) (env '())) 678 | ((vector-ref action-v (node-type node)) node loop env))))) 679 | 680 | 681 | 682 | 683 | ; Chargement de la librairie 684 | 685 | (define libcprims #f) 686 | (define libalias #f) 687 | (define libclos #f) 688 | (define libpublics #f) 689 | (define libnames #f) 690 | (define apply1-cprim-no #f) 691 | 692 | (define read-lib 693 | (lambda (libname) 694 | (let ((port (open-input-file libname))) 695 | (let loop1 ((n 0)) 696 | (if (= n 4) 697 | (begin 698 | (close-input-port port) 699 | '()) 700 | (let loop2 () 701 | (let* ((datum (read port))) 702 | (if datum 703 | (let ((reste (loop2))) 704 | (cons (cons datum (car reste)) (cdr reste))) 705 | (cons '() (loop1 (+ n 1))))))))))) 706 | 707 | (define get-lib-cprims 708 | (lambda (libpart1) 709 | (map (lambda (def) 710 | (let ((name (car def)) 711 | (no (cdr def))) 712 | (if (eq? name 'apply1) 713 | (set! apply1-cprim-no no)) 714 | (cons name no))) 715 | libpart1))) 716 | 717 | (define get-lib-alias 718 | (lambda (libpart2 libpart3 libpart4) 719 | (let* ((defs (append libpart2 libpart3 libpart4)) 720 | (defals (filter (lambda (def) 721 | (and (not (symbol? def)) 722 | (symbol? (caddr def)))) 723 | defs))) 724 | (map (lambda (defal) (cons (cadr defal) (caddr defal))) defals)))) 725 | 726 | (define get-lib-clos 727 | (lambda (libpart2 libpart3 libpart4) 728 | (let* ((defs (append libpart2 libpart3 libpart4)) 729 | (defcls (filter (lambda (def) 730 | (and (not (symbol? def)) 731 | (not (symbol? (caddr def))))) 732 | defs))) 733 | (map (lambda (defcl) (cons (cadr defcl) (caddr defcl))) defcls)))) 734 | 735 | (define get-lib-publics 736 | (lambda (libpart3 libpart4) 737 | (map (lambda (sym-or-def) 738 | (if (symbol? sym-or-def) 739 | sym-or-def 740 | (cadr sym-or-def))) 741 | (append libpart3 libpart4)))) 742 | 743 | (define get-lib-names 744 | (lambda (libpart1 libpart2 libpart3 libpart4) 745 | (let* ((cprim-names (map car libpart1)) 746 | (defs (append libpart2 libpart3 libpart4)) 747 | (truedefs (filter (lambda (def) (not (symbol? def))) defs))) 748 | (append cprim-names (map cadr truedefs))))) 749 | 750 | (define load-lib 751 | (lambda () 752 | (let* ((alllib (read-lib "librairie.scm")) 753 | (libpart1 (list-ref alllib 0)) 754 | (libpart2 (list-ref alllib 1)) 755 | (libpart3 (list-ref alllib 2)) 756 | (libpart4 (list-ref alllib 3))) 757 | (set! libcprims (get-lib-cprims libpart1)) 758 | (set! libalias (get-lib-alias libpart2 libpart3 libpart4)) 759 | (set! libclos (get-lib-clos libpart2 libpart3 libpart4)) 760 | (set! libpublics (get-lib-publics libpart3 libpart4)) 761 | (set! libnames (get-lib-names libpart1 libpart2 libpart3 libpart4))))) 762 | 763 | 764 | 765 | 766 | ; Capture de la librairie necessaire 767 | 768 | (define dirreq #f) 769 | (define allreq #f) 770 | (define req-clos-nodes #f) 771 | 772 | (define grab-lib 773 | (lambda (dirreq) 774 | (let loop ((toadd dirreq) (added '()) (clos-nodes '())) 775 | (cond ((null? toadd) 776 | (set! allreq added) 777 | (set! req-clos-nodes clos-nodes)) 778 | ((memq (car toadd) added) 779 | (loop (cdr toadd) added clos-nodes)) 780 | (else 781 | (let* ((newfun (car toadd)) 782 | (ass-cprim (assq newfun libcprims))) 783 | (if ass-cprim 784 | (loop (cdr toadd) 785 | (cons newfun added) 786 | clos-nodes) 787 | (let ((ass-alias (assq newfun libalias))) 788 | (if ass-alias 789 | (loop (cons (cdr ass-alias) (cdr toadd)) 790 | (cons newfun added) 791 | clos-nodes) 792 | (let ((ass-clos (assq newfun libclos))) 793 | (let* ((code (cdr ass-clos)) 794 | (sub-code (trans-sub code)) 795 | (node (exp->node sub-code)) 796 | (node-globs (extract-glob-names node)) 797 | (new-clos (cons newfun node))) 798 | (loop (append node-globs (cdr toadd)) 799 | (cons newfun added) 800 | (cons new-clos clos-nodes))))))))))))) 801 | 802 | 803 | 804 | 805 | ; Ramassage et codage des constantes du programme source 806 | 807 | (define const-counter 0) 808 | (define const-alist '()) 809 | ; Chaque ass: (original numero . desc) 810 | (define top-counter 0) 811 | (define top-alist '()) 812 | ; Chaque ass: (const-no . top-const-no) 813 | (define const-desc-string #f) 814 | 815 | (define const-no 816 | (lambda (d) 817 | (let ((ass (assoc d const-alist))) 818 | (if ass 819 | (cadr ass) 820 | (begin 821 | (cond ((or (null? d) (boolean? d) (char? d) (number? d)) 822 | (set! const-alist 823 | (cons (cons d (cons const-counter d)) const-alist))) 824 | ((pair? d) 825 | (let* ((leftno (const-no (car d))) 826 | (rightno (const-no (cdr d))) 827 | (desc (cons leftno rightno))) 828 | (set! const-alist (cons (cons d (cons const-counter desc)) 829 | const-alist)))) 830 | ((string? d) 831 | (set! const-alist 832 | (cons (cons d (cons const-counter d)) const-alist))) 833 | ((symbol? d) 834 | (let* ((nom (symbol->string d)) 835 | (nomno (const-no nom)) 836 | (desc (string->symbol (number->string nomno)))) 837 | (set! const-alist (cons (cons d (cons const-counter desc)) 838 | const-alist)))) 839 | ((vector? d) 840 | (let* ((listd (vector->list d)) 841 | (listno (map const-no listd)) 842 | (desc (list->vector listno))) 843 | (set! const-alist (cons (cons d (cons const-counter desc)) 844 | const-alist))))) 845 | (set! const-counter (+ const-counter 1)) 846 | (- const-counter 1)))))) 847 | 848 | (define top-const-no 849 | (lambda (d) 850 | (if (or (null? d) (boolean? d) (char? d) (number? d)) 851 | #f 852 | (let* ((cno (const-no d)) 853 | (ass (assv cno top-alist))) 854 | (if ass 855 | (cdr ass) 856 | (begin 857 | (set! top-alist (cons (cons cno top-counter) top-alist)) 858 | (set! top-counter (+ top-counter 1)) 859 | (- top-counter 1))))))) 860 | 861 | (define code-abs-number 862 | (lambda (n) 863 | (let* ((msb (quotient n 256)) 864 | (lsb (modulo n 256)) 865 | (msc (integer->char msb)) 866 | (lsc (integer->char lsb))) 867 | (string msc lsc)))) 868 | 869 | (define code-one-const 870 | (lambda (desc) 871 | (cond ((null? desc) 872 | "0") ; 0 pour EMPTY 873 | ((pair? desc) 874 | (string-append "1" ; 1 pour PAIR 875 | (code-abs-number (car desc)) 876 | (code-abs-number (cdr desc)))) 877 | ((boolean? desc) 878 | (if desc "2t" "2f")) ; 2 pour BOOLEAN 879 | ((char? desc) 880 | (string #\3 desc)) ; 3 pour CHAR 881 | ((string? desc) 882 | (string-append "4" ; 4 pour STRING 883 | (code-abs-number (string-length desc)) 884 | desc)) 885 | ((symbol? desc) 886 | (string-append "5" ; 5 pour SYMBOL 887 | (code-abs-number 888 | (string->number (symbol->string desc))))) 889 | ((number? desc) 890 | (string-append "6" ; 6 pour NUMBER 891 | (if (< desc 0) "-" "+") 892 | (code-abs-number (abs desc)))) 893 | ((vector? desc) 894 | (let* ((listref (vector->list desc)) 895 | (listcodes (map code-abs-number listref)) 896 | (listallcodes 897 | (cons "7" ; 7 pour VECTOR 898 | (cons (code-abs-number (vector-length desc)) 899 | listcodes)))) 900 | (apply string-append listallcodes)))))) 901 | 902 | (define code-in-const 903 | (lambda (nbconst const-alist) 904 | (let* ((right-alist (reverse const-alist)) 905 | (listdesc (map cddr right-alist)) 906 | (listcodes (map code-one-const listdesc)) 907 | (listallcodes (cons (code-abs-number nbconst) listcodes))) 908 | (apply string-append listallcodes)))) 909 | 910 | (define code-top-const 911 | (lambda (nbtop top-alist) 912 | (let* ((right-alist (reverse top-alist)) 913 | (listtop (map car right-alist)) 914 | (listcodes (map code-abs-number listtop)) 915 | (listallcodes (cons (code-abs-number nbtop) listcodes))) 916 | (apply string-append listallcodes)))) 917 | 918 | (define code-const 919 | (lambda () 920 | (string-append (code-in-const const-counter const-alist) 921 | (code-top-const top-counter top-alist)))) 922 | 923 | 924 | 925 | 926 | ; Enregistrement des variables globales 927 | 928 | (define glob-counter 0) 929 | (define glob-hidden '()) ; Variables cachees de la librairie 930 | (define glob-public '()) ; Variables visibles de la librairie 931 | (define glob-source '()) ; Variables introduites par le source 932 | ; Chaque assoc: (nom . numero) 933 | (define glob-v '#()) 934 | (define glob-v-len 0) 935 | 936 | (define glob-var-no 937 | (lambda (name lib?) 938 | (or 939 | (cond ((memq name libpublics) 940 | (let ((ass (assq name glob-public))) 941 | (if ass 942 | (cdr ass) 943 | (let ((newass (cons name glob-counter))) 944 | (set! glob-public (cons newass glob-public)) 945 | #f)))) 946 | (lib? 947 | (let ((ass (assq name glob-hidden))) 948 | (if ass 949 | (cdr ass) 950 | (let ((newass (cons name glob-counter))) 951 | (set! glob-hidden (cons newass glob-hidden)) 952 | #f)))) 953 | (else 954 | (let ((ass (assq name glob-source))) 955 | (if ass 956 | (cdr ass) 957 | (let ((newass (cons name glob-counter))) 958 | (set! glob-source (cons newass glob-source)) 959 | #f))))) 960 | (begin 961 | (if (= glob-counter glob-v-len) 962 | (let* ((newlen (+ (* 2 glob-v-len) 1)) 963 | (newv (make-vector newlen))) 964 | (let loop ((pos 0)) 965 | (if (< pos glob-v-len) 966 | (begin 967 | (vector-set! newv pos (vector-ref glob-v pos)) 968 | (loop (+ pos 1))))) 969 | (set! glob-v newv) 970 | (set! glob-v-len newlen))) 971 | (vector-set! glob-v glob-counter (make-globdesc-node name lib? 0)) 972 | (set! glob-counter (+ glob-counter 1)) 973 | (- glob-counter 1))))) 974 | 975 | 976 | 977 | 978 | ; Localisation des variables 979 | 980 | ; Un resultat (glob . name) signifie que name est globale 981 | ; Un resultat (lex #frame . #offset) donne le numero de frame et la 982 | ; position sur ce frame 983 | ; Un resultat (lex #frame . #f) indique que name est seule sur son frame 984 | (define where-var 985 | (lambda (name env) 986 | (if (null? env) 987 | (cons 'glob name) 988 | (let* ((locals (car env)) 989 | (membership (memq name locals))) 990 | (if membership 991 | (let* ((nblocals (length locals)) 992 | (pos (- nblocals (length membership))) 993 | (declpos (if (= nblocals 1) #f pos))) 994 | (cons 'lex (cons 0 declpos))) 995 | (let ((result (where-var name (cdr env)))) 996 | (if (eq? (car result) 'glob) 997 | result 998 | (let ((frame (cadr result)) 999 | (offset (cddr result))) 1000 | (cons 'lex (cons (+ frame 1) offset)))))))))) 1001 | 1002 | 1003 | 1004 | 1005 | ; Parcours des noeuds pour: 1006 | ; Numeroter les constantes si nec. 1007 | ; Identifier chaque variable 1008 | ; Compter les definitions et affectations des var. glob 1009 | ; Resumer les parametres formels 1010 | 1011 | (define traverse1-cte-node 1012 | (lambda (node env lib?) 1013 | (set-no! node (top-const-no (get-cte node))))) 1014 | 1015 | (define traverse1-ref-node 1016 | (lambda (node env lib?) 1017 | (let* ((name (get-symbol node)) 1018 | (pos (where-var name env)) 1019 | (glob? (eq? (car pos) 'glob)) 1020 | (loc (if glob? (glob-var-no name lib?) (cdr pos)))) 1021 | (set-glob?! node glob?) 1022 | (set-loc! node loc)))) 1023 | 1024 | (define formals->fdesc 1025 | (lambda (formals) 1026 | (let loop ((nbreq 0) (formals formals)) 1027 | (cond ((null? formals) 1028 | (cons nbreq #f)) 1029 | ((symbol? formals) 1030 | (cons nbreq #t)) 1031 | (else 1032 | (loop (+ nbreq 1) (cdr formals))))))) 1033 | 1034 | (define traverse1-lambda-node 1035 | (lambda (node env lib?) 1036 | (let* ((formals (get-formals node)) 1037 | (varlist (formals->varlist formals)) 1038 | (newenv (if (null? varlist) env (cons varlist env))) 1039 | (fdesc (formals->fdesc formals))) 1040 | (set-fdesc! node fdesc) 1041 | (traverse1-node (get-body node) newenv lib?)))) 1042 | 1043 | (define traverse1-if-node 1044 | (lambda (node env lib?) 1045 | (traverse1-node (get-test node) env lib?) 1046 | (traverse1-node (get-conseq node) env lib?) 1047 | (traverse1-node (get-altern node) env lib?))) 1048 | 1049 | (define traverse1-set!-node 1050 | (lambda (node env lib?) 1051 | (let* ((name (get-symbol node)) 1052 | (pos (where-var name env)) 1053 | (glob? (eq? (car pos) 'glob)) 1054 | (loc (if glob? (glob-var-no name lib?) (cdr pos)))) 1055 | (set-glob?! node glob?) 1056 | (set-loc! node loc) 1057 | (if glob? 1058 | (let* ((desc (vector-ref glob-v loc)) 1059 | (oldnb (get-nbaff desc))) 1060 | (set-nbaff! desc (+ oldnb 2))))) ; Declare la var. mut. 1061 | (traverse1-node (get-exp node) env lib?))) 1062 | 1063 | (define traverse1-begin-node 1064 | (lambda (node env lib?) 1065 | (let ((lnode (get-lexp node))) 1066 | (for-each (lambda (node) (traverse1-node node env lib?)) lnode)))) 1067 | 1068 | (define traverse1-def-node 1069 | (lambda (node env lib?) 1070 | (let* ((loc (glob-var-no (get-symbol node) lib?)) 1071 | (desc (vector-ref glob-v loc)) 1072 | (oldnb (get-nbaff desc))) 1073 | (set-loc! node loc) 1074 | (set-nbaff! desc (+ oldnb 1))) 1075 | (traverse1-node (get-exp node) env lib?))) 1076 | 1077 | (define traverse1-call-node 1078 | (lambda (node env lib?) 1079 | (let ((lnode (get-larg node))) 1080 | (traverse1-node (get-op node) env lib?) 1081 | (for-each (lambda (node) (traverse1-node node env lib?)) lnode)))) 1082 | 1083 | (define traverse1-node 1084 | (let ((action-v 1085 | (vector 1086 | traverse1-cte-node 1087 | traverse1-ref-node 1088 | traverse1-lambda-node 1089 | traverse1-if-node 1090 | traverse1-set!-node 1091 | traverse1-begin-node 1092 | traverse1-def-node 1093 | traverse1-call-node))) 1094 | (lambda (node env lib?) 1095 | ((vector-ref action-v (node-type node)) node env lib?)))) 1096 | 1097 | (define traverse1 1098 | (lambda () 1099 | (for-each 1100 | (lambda (name) 1101 | (let* ((no (glob-var-no name #t)) 1102 | (desc (vector-ref glob-v no))) 1103 | (set-nbaff! desc 1))) 1104 | allreq) 1105 | (for-each (lambda (node) (traverse1-node node '() #t)) 1106 | (map cdr req-clos-nodes)) 1107 | (for-each (lambda (node) (traverse1-node node '() #f)) 1108 | lnode))) 1109 | 1110 | 1111 | 1112 | 1113 | ; Determiner la valeur initiale des fonctions de la librairie 1114 | 1115 | (define find-an-init 1116 | (lambda (name) 1117 | (let ((asscprim (assq name libcprims))) 1118 | (if asscprim 1119 | (cons 'cprim (cdr asscprim)) 1120 | (let ((assalias (assq name libalias))) 1121 | (if assalias 1122 | (find-an-init (cdr assalias)) 1123 | (let ((node (cdr (assq name req-clos-nodes)))) 1124 | (if (lambda-node? node) 1125 | (cons 'clos node) 1126 | (begin 1127 | (display "Error: fonct. de la lib. a env. non-vide: ") 1128 | (write name) 1129 | (newline) 1130 | (cons 'clos 0)))))))))) 1131 | 1132 | (define find-inits 1133 | (lambda () 1134 | (let loop ((no 0)) 1135 | (if (< no glob-counter) 1136 | (let ((desc (vector-ref glob-v no))) 1137 | (if (get-lib? desc) 1138 | (let* ((name (get-symbol desc)) 1139 | (init (find-an-init name))) 1140 | (set-init! desc init))) 1141 | (loop (+ no 1))))))) 1142 | 1143 | 1144 | 1145 | 1146 | ; Parcours des noeuds pour: 1147 | ; Resoudre a priori certaines references 1148 | ; "Inliner" lorsque possible 1149 | 1150 | (define reduce-list 1151 | '((append 2 append2) 1152 | (= 2 math=2) 1153 | (< 2 math<2) 1154 | (> 2 math>2) 1155 | (<= 2 math<=2) 1156 | (>= 2 math>=2) 1157 | (max 2 max2) 1158 | (min 2 min2) 1159 | (+ 2 math+2) 1160 | (* 2 math*2) 1161 | (- 2 math-2) 1162 | (/ 2 quotient) 1163 | (gcd 2 mathgcd2) 1164 | (lcm 2 mathlcm2) 1165 | (make-string 1 make-string1) 1166 | (make-vector 1 make-vector1) 1167 | (apply 2 apply1) 1168 | (map 2 map1))) 1169 | 1170 | (define reduced-function 1171 | (lambda (name nbargs) 1172 | (let ((rule (assq name reduce-list))) 1173 | (if (not rule) 1174 | #f 1175 | (if (= nbargs (cadr rule)) 1176 | (caddr rule) 1177 | #f))))) 1178 | 1179 | (define optimize-call 1180 | (lambda (node match) 1181 | (let* ((symbol-field match) 1182 | (glob?-field #t) 1183 | (loc-field (glob-var-no match #t)) 1184 | (var-desc (vector-ref glob-v loc-field)) 1185 | (val-field (get-init var-desc)) 1186 | (new-op (make-ref-node-full symbol-field 1187 | loc-field 1188 | val-field 1189 | glob?-field))) 1190 | (set-op! node new-op)))) 1191 | 1192 | (define reduce-call 1193 | (lambda (node) 1194 | (let* ((op (get-op node)) 1195 | (name (get-symbol op)) 1196 | (nbargs (length (get-larg node))) 1197 | (match (reduced-function name nbargs))) 1198 | (if match (optimize-call node match))))) 1199 | 1200 | (define traverse2-cte-node 1201 | (lambda (node lib?) 1202 | #t)) 1203 | 1204 | (define traverse2-ref-node 1205 | (lambda (node lib?) 1206 | (if (get-glob? node) 1207 | (set-val! node 1208 | (let* ((vardesc (vector-ref glob-v (get-loc node))) 1209 | (varinit (get-init vardesc))) 1210 | (if lib? 1211 | varinit 1212 | (if (not (get-lib? vardesc)) 1213 | #f 1214 | (if (> (get-nbaff vardesc) 1) 1215 | #f 1216 | varinit)))))))) 1217 | 1218 | (define traverse2-lambda-node 1219 | (lambda (node lib?) 1220 | (traverse2-node (get-body node) lib?))) 1221 | 1222 | (define traverse2-if-node 1223 | (lambda (node lib?) 1224 | (traverse2-node (get-test node) lib?) 1225 | (traverse2-node (get-conseq node) lib?) 1226 | (traverse2-node (get-altern node) lib?))) 1227 | 1228 | (define traverse2-set!-node 1229 | (lambda (node lib?) 1230 | (traverse2-node (get-exp node) lib?))) 1231 | 1232 | (define traverse2-begin-node 1233 | (lambda (node lib?) 1234 | (for-each (lambda (node) (traverse2-node node lib?)) 1235 | (get-lexp node)))) 1236 | 1237 | (define traverse2-def-node 1238 | (lambda (node lib?) 1239 | (traverse2-node (get-exp node) lib?))) 1240 | 1241 | (define traverse2-call-node 1242 | (lambda (node lib?) 1243 | (let ((op (get-op node))) 1244 | (traverse2-node op lib?) 1245 | (for-each (lambda (node) (traverse2-node node lib?)) 1246 | (get-larg node)) 1247 | (if (and (ref-node? op) (get-glob? op) (get-val op)) 1248 | (reduce-call node))))) 1249 | 1250 | (define traverse2-node 1251 | (let ((action-v 1252 | (vector 1253 | traverse2-cte-node 1254 | traverse2-ref-node 1255 | traverse2-lambda-node 1256 | traverse2-if-node 1257 | traverse2-set!-node 1258 | traverse2-begin-node 1259 | traverse2-def-node 1260 | traverse2-call-node))) 1261 | (lambda (node lib?) 1262 | ((vector-ref action-v (node-type node)) node lib?)))) 1263 | 1264 | (define traverse2 1265 | (lambda () 1266 | (for-each (lambda (node) (traverse2-node node #t)) 1267 | (map cdr req-clos-nodes)) 1268 | (for-each (lambda (node) (traverse2-node node #f)) 1269 | lnode))) 1270 | 1271 | 1272 | 1273 | 1274 | ; Assigner des numeros physiques aux variables 1275 | 1276 | (define phys-glob-no 0) 1277 | 1278 | (define gen-phys-no 1279 | (lambda () 1280 | (set! phys-glob-no (+ phys-glob-no 1)) 1281 | (- phys-glob-no 1))) 1282 | 1283 | (define assign-phys-no 1284 | (lambda () 1285 | (let loop ((no 0)) 1286 | (if (< no glob-counter) 1287 | (let* ((desc (vector-ref glob-v no)) 1288 | (libvar? (get-lib? desc)) 1289 | (mutvar? (> (get-nbaff desc) 1))) 1290 | (cond ((not libvar?) 1291 | (let ((phys-no (gen-phys-no))) 1292 | (set-libno! desc phys-no) 1293 | (set-srcno! desc phys-no))) 1294 | (mutvar? 1295 | (set-libno! desc (gen-phys-no)) 1296 | (set-srcno! desc (gen-phys-no))) 1297 | (else 1298 | (let ((phys-no (gen-phys-no))) 1299 | (set-libno! desc phys-no) 1300 | (set-srcno! desc phys-no)))) 1301 | (loop (+ no 1))))))) 1302 | 1303 | 1304 | 1305 | 1306 | ; Gestion des labels 1307 | 1308 | (define label-counter 0) 1309 | (define label-v '#()) 1310 | (define label-v-len 0) 1311 | 1312 | (define make-label 1313 | (lambda () 1314 | (if (= label-counter label-v-len) 1315 | (let* ((newlen (+ (* label-v-len 2) 1)) 1316 | (newv (make-vector newlen))) 1317 | (let loop ((pos 0)) 1318 | (if (< pos label-counter) 1319 | (begin 1320 | (vector-set! newv pos (vector-ref label-v pos)) 1321 | (loop (+ pos 1))))) 1322 | (set! label-v newv) 1323 | (set! label-v-len newlen))) 1324 | (set! label-counter (+ label-counter 1)) 1325 | (- label-counter 1))) 1326 | 1327 | 1328 | 1329 | 1330 | ; Generation du byte-code 1331 | 1332 | (define program-bytecode #f) 1333 | (define flat-program-bytecode #f) 1334 | (define final-program-bytecode #f) 1335 | 1336 | (define bcompile-no 1337 | (lambda (no) 1338 | (let ((msb (quotient no 256)) 1339 | (lsb (modulo no 256))) 1340 | (list msb lsb)))) 1341 | 1342 | (define bcompile-cte-null ; 27 pour () 1343 | (lambda () 1344 | '(27))) 1345 | 1346 | (define bcompile-cte-boolean ; 28 pour #f, 29 pour #t 1347 | (lambda (b) 1348 | (if b '(29) '(28)))) 1349 | 1350 | (define bcompile-cte-char ; 30 pour char 1351 | (lambda (c) 1352 | (list 30 (char->integer c)))) 1353 | 1354 | (define bcompile-cte-number ; courts: + 31 - 32, longs: + 33 - 34 1355 | (lambda (n) 1356 | (if (>= n 0) 1357 | (if (< n 256) 1358 | (list 31 n) 1359 | (list 33 (bcompile-no n))) 1360 | (if (< (- n) 256) 1361 | (list 32 (- n)) 1362 | (list 34 (bcompile-no (- n))))))) 1363 | 1364 | (define bcompile-cte-imm 1365 | (lambda (cte) 1366 | (cond ((null? cte) 1367 | (bcompile-cte-null)) 1368 | ((boolean? cte) 1369 | (bcompile-cte-boolean cte)) 1370 | ((char? cte) 1371 | (bcompile-cte-char cte)) 1372 | (else 1373 | (bcompile-cte-number cte))))) 1374 | 1375 | (define bcompile-cte-built 1376 | (lambda (no) 1377 | (if (< no 256) 1378 | (list 0 no) 1379 | (list 1 (bcompile-no no))))) 1380 | 1381 | (define bcompile-cte 1382 | (lambda (node tail? lib?) 1383 | (let* ((const-no (get-no node)) 1384 | (get-cte-bc (if const-no 1385 | (bcompile-cte-built const-no) 1386 | (bcompile-cte-imm (get-cte node))))) 1387 | (if tail? (list get-cte-bc 14) get-cte-bc)))) 1388 | 1389 | (define special-lex-pos 1390 | (lambda (frame offset) 1391 | (case frame 1392 | ((0) (case offset ((0) 0) ((1) 1) ((2) 2) (else #f))) 1393 | ((1) (case offset ((0) 3) ((1) 4) (else #f))) 1394 | ((2) (case offset ((0) 5) (else #f))) 1395 | (else #f)))) 1396 | 1397 | (define bcompile-ref-lex 1398 | (lambda (node) 1399 | (let* ((loc (get-loc node)) 1400 | (frame (car loc)) 1401 | (offset (cdr loc)) 1402 | (spec (special-lex-pos frame (if offset offset 0)))) 1403 | (cond (spec 1404 | (list (+ spec 36))) 1405 | (offset 1406 | (if (and (< frame 256) (< offset 256)) 1407 | (list 2 frame offset) 1408 | (list 3 (bcompile-no frame) (bcompile-no offset)))) 1409 | (else 1410 | (if (< frame 256) 1411 | (list 2 frame) 1412 | (list 3 (bcompile-no frame)))))))) 1413 | 1414 | (define bcompile-ref-glob 1415 | (lambda (node lib?) 1416 | (let* ((loc (get-loc node)) 1417 | (vardesc (vector-ref glob-v loc)) 1418 | (phys-no (if lib? (get-libno vardesc) (get-srcno vardesc)))) 1419 | (if (< phys-no 256) 1420 | (list 4 phys-no) 1421 | (list 5 (bcompile-no phys-no)))))) 1422 | 1423 | (define bcompile-ref 1424 | (lambda (node tail? lib?) 1425 | (let ((result (if (get-glob? node) 1426 | (bcompile-ref-glob node lib?) 1427 | (bcompile-ref-lex node)))) 1428 | (if tail? (list result 14) result)))) 1429 | 1430 | (define bcompile-set!-lex 1431 | (lambda (node) 1432 | (let* ((loc (get-loc node)) 1433 | (frame (car loc)) 1434 | (offset (cdr loc))) 1435 | (if offset 1436 | (if (and (< frame 256) (< offset 256)) 1437 | (list 6 frame offset) 1438 | (list 7 (bcompile-no frame) (bcompile-no offset))) 1439 | (if (< frame 256) 1440 | (list 6 frame) 1441 | (list 7 (bcompile-no frame))))))) 1442 | 1443 | (define bcompile-set!-glob 1444 | (lambda (node lib?) 1445 | (let* ((loc (get-loc node)) 1446 | (vardesc (vector-ref glob-v loc)) 1447 | (phys-no (if lib? (get-libno vardesc) (get-srcno vardesc)))) 1448 | (if (< phys-no 256) 1449 | (list 8 phys-no) 1450 | (list 9 (bcompile-no phys-no)))))) 1451 | 1452 | (define bcompile-set! 1453 | (lambda (node tail? lib?) 1454 | (let* ((exp (get-exp node)) 1455 | (exp-bc (bcompile exp #f lib?)) 1456 | (aff-bc (if (get-glob? node) 1457 | (bcompile-set!-glob node lib?) 1458 | (bcompile-set!-lex node))) 1459 | (set!-bc (list exp-bc aff-bc))) 1460 | (if tail? (list set!-bc 14) set!-bc)))) 1461 | 1462 | (define bcompile-def 1463 | (lambda (node tail? lib?) 1464 | (let* ((exp (get-exp node)) 1465 | (exp-bc (bcompile exp #f lib?)) 1466 | (aff-bc (bcompile-set!-glob node lib?)) 1467 | (def-bc (list exp-bc aff-bc))) 1468 | (if tail? (list def-bc 14) def-bc)))) 1469 | 1470 | (define bcompile-pop-n 1471 | (lambda (n) 1472 | (cond ((= n 1) 1473 | '(51)) 1474 | ((< n 256) 1475 | (list 49 n)) 1476 | (else 1477 | (list 50 (bcompile-no n)))))) 1478 | 1479 | (define bcompile-begin 1480 | (lambda (node tail? lib?) 1481 | (let loop ((lexp (get-lexp node)) (nb-prev 0)) 1482 | (if (null? (cdr lexp)) 1483 | (list (bcompile-pop-n nb-prev) 1484 | (bcompile (car lexp) tail? lib?)) 1485 | (list (bcompile (car lexp) #f lib?) 1486 | (loop (cdr lexp) (+ nb-prev 1))))))) 1487 | 1488 | (define bcompile-label-def 1489 | (lambda (no) 1490 | (list 'def no))) 1491 | 1492 | (define bcompile-label-ref 1493 | (lambda (no) 1494 | (list 'ref no))) 1495 | 1496 | (define bcompile-if 1497 | (lambda (node tail? lib?) 1498 | (let* ((debut-altern (make-label)) 1499 | (fin-altern (if tail? #f (make-label))) 1500 | (test-bc (bcompile (get-test node) #f lib?)) 1501 | (cjump-bc (list 11 (bcompile-label-ref debut-altern))) 1502 | (conseq-bc (bcompile (get-conseq node) tail? lib?)) 1503 | (ujump-bc (if tail? 1504 | '() 1505 | (list 12 (bcompile-label-ref fin-altern)))) 1506 | (debut-altern-bc (bcompile-label-def debut-altern)) 1507 | (altern-bc (bcompile (get-altern node) tail? lib?)) 1508 | (fin-altern-bc (if tail? 1509 | '() 1510 | (bcompile-label-def fin-altern)))) 1511 | (list test-bc cjump-bc conseq-bc ujump-bc 1512 | debut-altern-bc altern-bc fin-altern-bc)))) 1513 | 1514 | (define bcompile-make-frame 1515 | (lambda (fdesc) 1516 | (let* ((nbreq (car fdesc)) 1517 | (fac? (cdr fdesc)) 1518 | (frame-size (+ nbreq (if fac? 1 0)))) 1519 | (cond ((= frame-size 0) 1520 | '()) 1521 | ((and (= frame-size 1) (not fac?)) 1522 | '(42)) 1523 | ((and (= frame-size 2) (not fac?)) 1524 | '(43)) 1525 | ((and (= frame-size 1) fac?) 1526 | '(44)) 1527 | (fac? 1528 | (if (< frame-size 256) 1529 | (list 22 frame-size) 1530 | (list 23 (bcompile-no frame-size)))) 1531 | (else 1532 | (if (< frame-size 256) 1533 | (list 20 frame-size) 1534 | (list 21 (bcompile-no frame-size)))))))) 1535 | 1536 | (define bcompile-closure 1537 | (lambda (node lib?) 1538 | (let* ((fdesc (get-fdesc node)) 1539 | (make-frame-bc (bcompile-make-frame fdesc)) 1540 | (body-bc (bcompile (get-body node) #t lib?))) 1541 | (list make-frame-bc body-bc)))) 1542 | 1543 | (define bcompile-lambda 1544 | (lambda (node tail? lib?) 1545 | (let ((clos-bc (bcompile-closure node lib?))) 1546 | (if tail? 1547 | (list 10 clos-bc) 1548 | (let* ((suite (make-label)) 1549 | (make-clos-bc (list 48 (bcompile-label-ref suite))) 1550 | (suite-bc (bcompile-label-def suite))) 1551 | (list make-clos-bc clos-bc suite-bc)))))) 1552 | 1553 | (define bcompile-calc-args 1554 | (lambda (larg lib?) 1555 | (let loop ((larg larg) (prev-args-bc '())) 1556 | (if (null? larg) 1557 | prev-args-bc 1558 | (let* ((arg (car larg)) 1559 | (reste (cdr larg)) 1560 | (calc-arg-bc (bcompile arg #f lib?))) 1561 | (loop reste (list calc-arg-bc prev-args-bc))))))) 1562 | 1563 | (define bcompile-call-C 1564 | (lambda (node tail? lib?) 1565 | (let ((cprim-no (cdr (get-val (get-op node))))) 1566 | (if (= cprim-no apply1-cprim-no) 1567 | (bcompile-call-I node tail? lib?) ; Le cas apply 1568 | (let* ((larg (get-larg node)) 1569 | (calc-args-bc (bcompile-calc-args larg lib?)) 1570 | (apply-bc (list (- 255 cprim-no))) 1571 | (call-bc (list calc-args-bc apply-bc))) 1572 | (if tail? 1573 | (list 15 call-bc 14) 1574 | (list 25 call-bc 26))))))) 1575 | 1576 | (define bcompile-call-Fi 1577 | (lambda (node tail? lib?) 1578 | (let* ((op (get-op node)) 1579 | (larg (get-larg node)) 1580 | (calc-args-bc (bcompile-calc-args larg lib?)) 1581 | (fdesc (get-fdesc op)) 1582 | (make-frame-bc (bcompile-make-frame fdesc)) 1583 | (body (get-body op)) 1584 | (body-bc (bcompile body tail? lib?))) 1585 | (if tail? 1586 | (list 15 calc-args-bc make-frame-bc body-bc) 1587 | (list 25 calc-args-bc make-frame-bc body-bc 26 35))))) 1588 | 1589 | (define bcompile-call-I 1590 | (lambda (node tail? lib?) 1591 | (let ((op (get-op node))) 1592 | (if (and (ref-node? op) (get-glob? op)) 1593 | (let* ((larg (get-larg node)) 1594 | (calc-args-bc (bcompile-calc-args larg lib?)) 1595 | (var-desc (vector-ref glob-v (get-loc op))) 1596 | (phys-no (if lib? (get-libno var-desc) (get-srcno var-desc)))) 1597 | (if (< phys-no 256) 1598 | (if tail? 1599 | (list 15 calc-args-bc 52 phys-no) 1600 | (list 45 calc-args-bc 54 phys-no)) 1601 | (if tail? 1602 | (list 15 calc-args-bc 53 (bcompile-no phys-no)) 1603 | (list 45 calc-args-bc 55 (bcompile-no phys-no))))) 1604 | (let* ((larg (get-larg node)) 1605 | (allarg (cons op larg)) 1606 | (allarg-bc (bcompile-calc-args allarg lib?))) 1607 | (if tail? 1608 | (list 15 allarg-bc 17) 1609 | (list 45 allarg-bc 46))))))) 1610 | 1611 | (define bcompile-call 1612 | (lambda (node tail? lib?) 1613 | (let ((op (get-op node))) 1614 | (cond ((ref-node? op) 1615 | (let ((val (get-val op))) 1616 | (if (and val (eq? (car val) 'cprim)) 1617 | (bcompile-call-C node tail? lib?) 1618 | (bcompile-call-I node tail? lib?)))) 1619 | ((lambda-node? op) 1620 | (bcompile-call-Fi node tail? lib?)) 1621 | (else 1622 | (bcompile-call-I node tail? lib?)))))) 1623 | 1624 | (define bcompile 1625 | (let ((action-v 1626 | (vector 1627 | bcompile-cte 1628 | bcompile-ref 1629 | bcompile-lambda 1630 | bcompile-if 1631 | bcompile-set! 1632 | bcompile-begin 1633 | bcompile-def 1634 | bcompile-call))) 1635 | (lambda (node tail? lib?) 1636 | ((vector-ref action-v (node-type node)) node tail? lib?)))) 1637 | 1638 | (define bcompile-program 1639 | (lambda () 1640 | (map (lambda (ass) (set-label! (cdr ass) (make-label))) 1641 | req-clos-nodes) 1642 | (let* ((source-bc (map (lambda (node) (list (bcompile node #f #f) 51)) 1643 | lnode)) 1644 | (fin-bc (list 24)) 1645 | (lib-bc (map (lambda (ass) 1646 | (let ((node (cdr ass))) 1647 | (list (bcompile-label-def (get-label node)) 1648 | (bcompile-closure node #t)))) 1649 | req-clos-nodes)) 1650 | (apply-hook-bc (list 17))) 1651 | (list source-bc fin-bc lib-bc apply-hook-bc)))) 1652 | 1653 | (define flatten-bytecode 1654 | (lambda (hierarcode) 1655 | (let loop ((h hierarcode) (rest '())) 1656 | (if (pair? h) 1657 | (loop (car h) (loop (cdr h) rest)) 1658 | (if (null? h) 1659 | rest 1660 | (cons h rest)))))) 1661 | 1662 | (define link-bytecode 1663 | (lambda (flat-reloc-bc) 1664 | (let loop ((bc flat-reloc-bc) (pos 0)) 1665 | (if (not (null? bc)) 1666 | (let ((head (car bc))) 1667 | (cond ((number? head) 1668 | (loop (cdr bc) (+ pos 1))) 1669 | ((eq? head 'ref) 1670 | (loop (cddr bc) (+ pos 2))) 1671 | (else ; (eq? head 'def) 1672 | (let ((label-no (cadr bc))) 1673 | (vector-set! label-v label-no pos) 1674 | (loop (cddr bc) pos))))))) 1675 | (let loop ((bc flat-reloc-bc)) 1676 | (if (null? bc) 1677 | '() 1678 | (let ((head (car bc))) 1679 | (cond ((number? head) 1680 | (cons head (loop (cdr bc)))) 1681 | ((eq? head 'ref) 1682 | (let* ((label-no (cadr bc)) 1683 | (pos (vector-ref label-v label-no))) 1684 | (append (bcompile-no pos) (loop (cddr bc))))) 1685 | (else ; (eq? head 'def) 1686 | (loop (cddr bc))))))))) 1687 | 1688 | 1689 | 1690 | 1691 | ; Codage de la valeur initiale des variables globales 1692 | 1693 | (define glob-var-init-codes #f) 1694 | 1695 | (define code-init 1696 | (lambda (init) 1697 | (cond ((not init) 1698 | -1) 1699 | ((eq? (car init) 'cprim) 1700 | (- -2 (cdr init))) 1701 | (else ; (eq? (car init) 'clos) 1702 | (let* ((lambda-node (cdr init)) 1703 | (label-no (get-label lambda-node))) 1704 | (vector-ref label-v label-no)))))) 1705 | 1706 | (define code-glob-inits 1707 | (lambda () 1708 | (let loop ((var-no (- glob-counter 1)) (codes '())) 1709 | (if (< var-no 0) 1710 | codes 1711 | (let* ((var-desc (vector-ref glob-v var-no)) 1712 | (var-init (get-init var-desc)) 1713 | (init-code (code-init var-init)) 1714 | (newcodes (if (= (get-libno var-desc) 1715 | (get-srcno var-desc)) 1716 | (cons init-code codes) 1717 | (cons init-code (cons init-code codes))))) 1718 | (loop (- var-no 1) newcodes)))))) 1719 | 1720 | 1721 | 1722 | 1723 | ; Impression des resultats 1724 | 1725 | (define byte-strings 1726 | (vector 1727 | " 0" " 1" " 2" " 3" " 4" " 5" " 6" " 7" " 8" " 9" 1728 | " 10" " 11" " 12" " 13" " 14" " 15" " 16" " 17" " 18" " 19" 1729 | " 20" " 21" " 22" " 23" " 24" " 25" " 26" " 27" " 28" " 29" 1730 | " 30" " 31" " 32" " 33" " 34" " 35" " 36" " 37" " 38" " 39" 1731 | " 40" " 41" " 42" " 43" " 44" " 45" " 46" " 47" " 48" " 49" 1732 | " 50" " 51" " 52" " 53" " 54" " 55" " 56" " 57" " 58" " 59" 1733 | " 60" " 61" " 62" " 63" " 64" " 65" " 66" " 67" " 68" " 69" 1734 | " 70" " 71" " 72" " 73" " 74" " 75" " 76" " 77" " 78" " 79" 1735 | " 80" " 81" " 82" " 83" " 84" " 85" " 86" " 87" " 88" " 89" 1736 | " 90" " 91" " 92" " 93" " 94" " 95" " 96" " 97" " 98" " 99" 1737 | " 100" " 101" " 102" " 103" " 104" " 105" " 106" " 107" " 108" " 109" 1738 | " 110" " 111" " 112" " 113" " 114" " 115" " 116" " 117" " 118" " 119" 1739 | " 120" " 121" " 122" " 123" " 124" " 125" " 126" " 127" " 128" " 129" 1740 | " 130" " 131" " 132" " 133" " 134" " 135" " 136" " 137" " 138" " 139" 1741 | " 140" " 141" " 142" " 143" " 144" " 145" " 146" " 147" " 148" " 149" 1742 | " 150" " 151" " 152" " 153" " 154" " 155" " 156" " 157" " 158" " 159" 1743 | " 160" " 161" " 162" " 163" " 164" " 165" " 166" " 167" " 168" " 169" 1744 | " 170" " 171" " 172" " 173" " 174" " 175" " 176" " 177" " 178" " 179" 1745 | " 180" " 181" " 182" " 183" " 184" " 185" " 186" " 187" " 188" " 189" 1746 | " 190" " 191" " 192" " 193" " 194" " 195" " 196" " 197" " 198" " 199" 1747 | " 200" " 201" " 202" " 203" " 204" " 205" " 206" " 207" " 208" " 209" 1748 | " 210" " 211" " 212" " 213" " 214" " 215" " 216" " 217" " 218" " 219" 1749 | " 220" " 221" " 222" " 223" " 224" " 225" " 226" " 227" " 228" " 229" 1750 | " 230" " 231" " 232" " 233" " 234" " 235" " 236" " 237" " 238" " 239" 1751 | " 240" " 241" " 242" " 243" " 244" " 245" " 246" " 247" " 248" " 249" 1752 | " 250" " 251" " 252" " 253" " 254" " 255")) 1753 | 1754 | (define write-bytecode 1755 | (lambda (bc) 1756 | (display "int bytecode_len = ") 1757 | (let ((len (length bc))) 1758 | (write len) 1759 | (if (> len 32768) 1760 | (begin 1761 | (display "Warning: bytecode too long.") 1762 | (newline)))) 1763 | (display ";") 1764 | (newline) 1765 | (display "unsigned char bytecode[] = {") 1766 | (let ((virgule "")) 1767 | (let loop ((bc bc) (mod 0)) 1768 | (if (not (null? bc)) 1769 | (begin 1770 | (display virgule) 1771 | (set! virgule ",") 1772 | (if (= mod 0) 1773 | (begin 1774 | (newline) 1775 | (display " ") 1776 | (set! mod -12))) 1777 | (display (vector-ref byte-strings (car bc))) 1778 | (loop (cdr bc) (+ mod 1)))))) 1779 | (display "};") 1780 | (newline))) 1781 | 1782 | (define write-const-desc 1783 | (lambda (cd) 1784 | (let ((cd (map char->integer (string->list cd)))) 1785 | (display "int const_desc_len = ") 1786 | (write (length cd)) 1787 | (display ";") 1788 | (newline) 1789 | (display "unsigned char const_desc[] = {") 1790 | (let ((virgule "")) 1791 | (let loop ((cd cd) (mod 0)) 1792 | (if (not (null? cd)) 1793 | (begin 1794 | (display virgule) 1795 | (set! virgule ",") 1796 | (if (= mod 0) 1797 | (begin 1798 | (newline) 1799 | (display " ") 1800 | (set! mod -12))) 1801 | (display (vector-ref byte-strings (car cd))) 1802 | (loop (cdr cd) (+ mod 1)))))) 1803 | (display "};") 1804 | (newline)))) 1805 | 1806 | (define pretty-signed-int 1807 | (lambda (int) 1808 | (let* ((sint (number->string int)) 1809 | (lpadding (- 6 (string-length sint))) 1810 | (padding (substring " " 0 lpadding))) 1811 | (string-append padding sint)))) 1812 | 1813 | (define write-glob-init-codes 1814 | (lambda (glob-var-init-codes) 1815 | (display "int nb_scm_globs = ") 1816 | (write (length glob-var-init-codes)) 1817 | (display ";") 1818 | (newline) 1819 | (display "int scm_globs[] = {") 1820 | (let ((virgule "")) 1821 | (let loop ((gi glob-var-init-codes) (mod 0)) 1822 | (if (not (null? gi)) 1823 | (begin 1824 | (display virgule) 1825 | (set! virgule ",") 1826 | (if (= mod 0) 1827 | (begin 1828 | (newline) 1829 | (display " ") 1830 | (set! mod -8))) 1831 | (display (pretty-signed-int (car gi))) 1832 | (loop (cdr gi) (+ mod 1)))))) 1833 | (display "};") 1834 | (newline))) 1835 | 1836 | (define write-output 1837 | (lambda (final-program-bytecode const-desc-string glob-var-init-codes) 1838 | (begin 1839 | (write-bytecode final-program-bytecode) (newline) 1840 | (write-const-desc const-desc-string ) (newline) 1841 | (write-glob-init-codes glob-var-init-codes ) 1842 | ))) 1843 | 1844 | 1845 | 1846 | 1847 | ; Programme principal 1848 | 1849 | (define byte-compile 1850 | (lambda () 1851 | (init-glob-vars) 1852 | (let* ((source (read-source)) 1853 | (source-symbols (find-all-symbols source)) 1854 | (uniq-pref (find-uniq-prefix source-symbols))) 1855 | (set! gen-sym-pref uniq-pref) 1856 | (set! safe-name-memv (gen-sym)) 1857 | (set! safe-name-make-promise (gen-sym)) 1858 | (set! safe-name-list->vector (gen-sym)) 1859 | (set! safe-name-list (gen-sym)) 1860 | (set! safe-name-append2 (gen-sym)) 1861 | (set! safe-name-cons (gen-sym)) 1862 | (let* ((source++ 1863 | (append 1864 | (list 1865 | (list 'define safe-name-memv 'memv) 1866 | (list 'define safe-name-make-promise 'make-promise) 1867 | (list 'define safe-name-list->vector 'list->vector) 1868 | (list 'define safe-name-list 'list) 1869 | (list 'define safe-name-append2 'append2) 1870 | (list 'define safe-name-cons 'cons) 1871 | '(install-const)) 1872 | source)) 1873 | (simple (map trans-sub source++))) 1874 | (set! lnode (map exp->node simple)) 1875 | (let* ((llglob (map extract-glob-names lnode)) 1876 | (lglob (foldr symbol-set-union '() llglob))) 1877 | (load-lib) 1878 | (set! dirreq (symbol-set-intersection lglob libpublics)) 1879 | (grab-lib dirreq) 1880 | (traverse1) 1881 | (find-inits) 1882 | (traverse2) 1883 | (assign-phys-no) 1884 | (set! program-bytecode (bcompile-program)) 1885 | (set! flat-program-bytecode (flatten-bytecode program-bytecode)) 1886 | (set! final-program-bytecode (link-bytecode flat-program-bytecode)) 1887 | (set! const-desc-string (code-const)) 1888 | (set! glob-var-init-codes (code-glob-inits)) 1889 | (write-output final-program-bytecode const-desc-string glob-var-init-codes)))))) 1890 | -------------------------------------------------------------------------------- /eiod.scm: -------------------------------------------------------------------------------- 1 | ;; eiod.scm: eval-in-one-define 2 | ;; $Id: eiod.scm,v 1.17 2005/03/26 19:57:44 al Exp $ 3 | 4 | ;; A minimal implementation of r5rs eval, null-environment, and 5 | ;; scheme-report-environment. (And SRFI-46 extensions, too.) 6 | 7 | ;; Copyright 2002, 2004, 2005 Al Petrofsky 8 | 9 | ;; You may redistribute and/or modify this software under the terms of 10 | ;; the GNU General Public License as published by the Free Software 11 | ;; Foundation (fsf.org); either version 2, or (at your option) any 12 | ;; later version. 13 | 14 | ;; Feel free to ask me for different licensing terms. 15 | 16 | ;; DISCLAIMER: 17 | 18 | ;; This is only intended as a demonstration of the minimum 19 | ;; implementation effort required for an r5rs eval. It serves as a 20 | ;; simple, working example of one way to implement the r5rs macro 21 | ;; system (and SRFI-46) . Among the reasons that it is ill-suited for 22 | ;; production use is the complete lack of error-checking. 23 | 24 | ;; DATA STRUCTURES: 25 | 26 | ;; An environment is a procedure that accepts any identifier and 27 | ;; returns a denotation. The denotation of an unbound identifier is 28 | ;; its name (as a symbol). A bound identifier's denotation is its 29 | ;; binding, which is a list of the current value, the binding's type 30 | ;; (keyword or variable), and the identifier's name (needed by quote). 31 | 32 | ;; identifier: [symbol | thunk] 33 | ;; denotation: [symbol | binding] 34 | ;; binding: [variable-binding | keyword-binding] 35 | ;; variable-binding: (value #f symbol) 36 | ;; keyword-binding: (special-form #t symbol) 37 | ;; special-form: [builtin | transformer] 38 | 39 | ;; A value is any arbitrary scheme value. Special forms are either a 40 | ;; symbol naming a builtin, or a transformer procedure that takes two 41 | ;; arguments: a macro use and the environment of the macro use. 42 | 43 | ;; An explicit-renaming low-level macro facility is supported, upon 44 | ;; which syntax-rules is implemented. When a syntax-rules template 45 | ;; containing a literal identifier is transcribed, the output will 46 | ;; contain a fresh identifier, which is an eq?-unique thunk that when 47 | ;; invoked returns the old identifier's denotation in the environment 48 | ;; of the macro's definition. When one of these "renamed" identifiers 49 | ;; is looked up in an environment that has no binding for it, the 50 | ;; thunk is invoked and the old denotation is returned. (The thunk 51 | ;; actually returns the old denotation wrapped inside a unique pair, 52 | ;; which is immediately unwrapped. This is necessary to ensure that 53 | ;; different rename thunks of the same denotation do not compare eq?.) 54 | 55 | ;; This environment and denotation model is similar to the one 56 | ;; described in the 1991 paper "Macros that Work" by Clinger and Rees. 57 | 58 | ;; The base environment contains eight keyword bindings and two 59 | ;; variable bindings: 60 | ;; lambda, set!, and begin are as in the standard. 61 | ;; q is like quote, but it does not handle pairs or vectors. 62 | ;; def is like define, but it does not handle the (f . args) format. 63 | ;; define-syntax makes internal syntax definitions. 64 | ;; (get-env) returns the local environment. 65 | ;; (syntax x) is like quote, but does not convert identifiers to symbols. 66 | ;; The id? procedure is a predicate for identifiers. 67 | ;; The new-id procedure takes a denotation and returns a fresh identifier. 68 | 69 | 70 | ;; Quote-and-evaluate captures all the code into the list eiod-source 71 | ;; so that we can have fun feeding eval to itself, as in 72 | ;; ((eval `(let () ,@eiod-source repl) (scheme-report-environment 5))). 73 | ;; [Note: using (and even starting) a doubly evaled repl will be *very* slow.] 74 | (define-syntax quote-and-evaluate 75 | (syntax-rules () ((quote-and-evaluate var . x) (begin (define var 'x) . x)))) 76 | 77 | ;; The matching close parenthesis is at the end of the file. 78 | (quote-and-evaluate eiod-source 79 | 80 | (define (eval sexp env) 81 | (define (new-id den) (define p (list den)) (lambda () p)) 82 | (define (old-den id) (car (id))) 83 | (define (id? x) (or (symbol? x) (procedure? x))) 84 | (define (id->sym id) (if (symbol? id) id (den->sym (old-den id)))) 85 | (define (den->sym den) (if (symbol? den) den (get-sym den))) 86 | 87 | (define (empty-env id) (if (symbol? id) id (old-den id))) 88 | (define (extend env id binding) (lambda (i) (if (eq? id i) binding (env i)))) 89 | (define (add-var var val env) (extend env var (list val #f (id->sym var)))) 90 | (define (add-key key val env) (extend env key (list val #t (id->sym key)))) 91 | 92 | (define (get-val binding) (car binding)) 93 | (define (special? binding) (cadr binding)) 94 | (define (get-sym binding) (caddr binding)) 95 | (define (set-val! binding val) (set-car! binding val)) 96 | 97 | (define (make-builtins-env) 98 | (do ((specials '(lambda set! begin q def define-syntax syntax get-env) 99 | (cdr specials)) 100 | (env empty-env (add-key (car specials) (car specials) env))) 101 | ((null? specials) (add-var 'new-id new-id (add-var 'id? id? env))))) 102 | 103 | (define (eval sexp env) 104 | (let eval-here ((sexp sexp)) 105 | (cond ((id? sexp) (get-val (env sexp))) 106 | ((not (pair? sexp)) sexp) 107 | (else (let ((head (car sexp)) (tail (cdr sexp))) 108 | (let ((head-binding (and (id? head) (env head)))) 109 | (if (and head-binding (special? head-binding)) 110 | (let ((special (get-val head-binding))) 111 | (case special 112 | ((get-env) env) 113 | ((syntax) (car tail)) 114 | ((lambda) (eval-lambda tail env)) 115 | ((begin) (eval-seq tail env)) 116 | ((set!) (set-val! (env (car tail)) 117 | (eval-here (cadr tail)))) 118 | ((q) (let ((x (car tail))) 119 | (if (id? x) (id->sym x) x))) 120 | (else (eval-here (special sexp env))))) 121 | (apply (eval-here head) 122 | (map1 eval-here tail))))))))) 123 | 124 | ;; Don't use standard map because it might not be continuationally correct. 125 | (define (map1 f l) 126 | (if (null? l) 127 | '() 128 | (cons (f (car l)) (map1 f (cdr l))))) 129 | 130 | (define (eval-seq tail env) 131 | ;; Don't use for-each because we must tail-call the last expression. 132 | (do ((sexps tail (cdr sexps))) 133 | ((null? (cdr sexps)) (eval (car sexps) env)) 134 | (eval (car sexps) env))) 135 | 136 | (define (eval-lambda tail env) 137 | (lambda args 138 | (define ienv (do ((args args (cdr args)) 139 | (vars (car tail) (cdr vars)) 140 | (ienv env (add-var (car vars) (car args) ienv))) 141 | ((not (pair? vars)) 142 | (if (null? vars) ienv (add-var vars args ienv))))) 143 | (let loop ((ienv ienv) (ids '()) (inits '()) (body (cdr tail))) 144 | (let ((first (car body)) (rest (cdr body))) 145 | (let* ((head (and (pair? first) (car first))) 146 | (binding (and (id? head) (ienv head))) 147 | (special (and binding (special? binding) (get-val binding)))) 148 | (if (procedure? special) 149 | (loop ienv ids inits (cons (special first ienv) rest)) 150 | (case special 151 | ((begin) (loop ienv ids inits (append (cdr first) rest))) 152 | ((def define-syntax) 153 | (let ((id (cadr first)) (init (caddr first))) 154 | (let* ((adder (if (eq? special 'def) add-var add-key)) 155 | (ienv (adder id 'undefined ienv))) 156 | (loop ienv (cons id ids) (cons init inits) rest)))) 157 | (else (let ((ieval (lambda (init) (eval init ienv)))) 158 | (for-each set-val! (map ienv ids) (map1 ieval inits)) 159 | (eval-seq body ienv)))))))))) 160 | 161 | ;; We make a copy of the initial input to ensure that subsequent 162 | ;; mutation of it does not affect eval's result. [1] 163 | (eval (let copy ((x sexp)) 164 | (cond ((string? x) (string-copy x)) 165 | ((pair? x) (cons (copy (car x)) (copy (cdr x)))) 166 | ((vector? x) (list->vector (copy (vector->list x)))) 167 | (else x))) 168 | (or env (make-builtins-env)))) 169 | 170 | 171 | (define null-environment 172 | (let () 173 | ;; Syntax-rules is implemented as a macro that expands into a call 174 | ;; to the syntax-rules* procedure, which returns a transformer 175 | ;; procedure. The arguments to syntax-rules* are the arguments to 176 | ;; syntax-rules plus the current environment, which is captured 177 | ;; with get-env. Syntax-rules** is called once with some basics 178 | ;; from the base environment. It creates and returns 179 | ;; syntax-rules*. 180 | (define (syntax-rules** id? new-id denotation-of-default-ellipsis) 181 | (define (syntax-rules* mac-env ellipsis pat-literals rules) 182 | (define (pat-literal? id) (memq id pat-literals)) 183 | (define (not-pat-literal? id) (not (pat-literal? id))) 184 | (define (ellipsis-pair? x) (and (pair? x) (ellipsis? (car x)))) 185 | (define (ellipsis? x) 186 | (if ellipsis 187 | (eq? x ellipsis) 188 | (and (id? x) 189 | (eq? (mac-env x) denotation-of-default-ellipsis)))) 190 | 191 | ;; List-ids returns a list of the non-ellipsis ids in a 192 | ;; pattern or template for which (pred? id) is true. If 193 | ;; include-scalars is false, we only include ids that are 194 | ;; within the scope of at least one ellipsis. 195 | (define (list-ids x include-scalars pred?) 196 | (let collect ((x x) (inc include-scalars) (l '())) 197 | (cond ((id? x) (if (and inc (pred? x)) (cons x l) l)) 198 | ((vector? x) (collect (vector->list x) inc l)) 199 | ((pair? x) 200 | (if (ellipsis-pair? (cdr x)) 201 | (collect (car x) #t (collect (cddr x) inc l)) 202 | (collect (car x) inc (collect (cdr x) inc l)))) 203 | (else l)))) 204 | 205 | ;; Returns #f or an alist mapping each pattern var to a part of 206 | ;; the input. Ellipsis vars are mapped to lists of parts (or 207 | ;; lists of lists ...). 208 | (define (match-pattern pat use use-env) 209 | (call-with-current-continuation 210 | (lambda (return) 211 | (define (fail) (return #f)) 212 | (let match ((pat (cdr pat)) (sexp (cdr use)) (bindings '())) 213 | (define (continue-if condition) (if condition bindings (fail))) 214 | (cond 215 | ((id? pat) 216 | (if (pat-literal? pat) 217 | (continue-if (and (id? sexp) 218 | (eq? (use-env sexp) (mac-env pat)))) 219 | (cons (cons pat sexp) bindings))) 220 | ((vector? pat) 221 | (or (vector? sexp) (fail)) 222 | (match (vector->list pat) (vector->list sexp) bindings)) 223 | ((not (pair? pat)) (continue-if (equal? pat sexp))) 224 | ((ellipsis-pair? (cdr pat)) 225 | (let* ((tail-len (length (cddr pat))) 226 | (sexp-len (if (list? sexp) (length sexp) (fail))) 227 | (seq-len (- sexp-len tail-len)) 228 | (sexp-tail (begin (if (negative? seq-len) (fail)) 229 | (list-tail sexp seq-len))) 230 | (seq (reverse (list-tail (reverse sexp) tail-len))) 231 | (vars (list-ids (car pat) #t not-pat-literal?))) 232 | (define (match1 sexp) (map cdr (match (car pat) sexp '()))) 233 | (append (apply map list vars (map match1 seq)) 234 | (match (cddr pat) sexp-tail bindings)))) 235 | ((pair? sexp) (match (car pat) (car sexp) 236 | (match (cdr pat) (cdr sexp) bindings))) 237 | (else (fail))))))) 238 | 239 | (define (expand-template pat tmpl top-bindings) 240 | ;; New-literals is an alist mapping each literal id in the 241 | ;; template to a fresh id for inserting into the output. It 242 | ;; might have duplicate entries mapping an id to two different 243 | ;; fresh ids, but that's okay because when we go to retrieve a 244 | ;; fresh id, assq will always retrieve the first one. 245 | (define new-literals 246 | (map (lambda (id) (cons id (new-id (mac-env id)))) 247 | (list-ids tmpl #t (lambda (id) 248 | (not (assq id top-bindings)))))) 249 | (define ellipsis-vars (list-ids (cdr pat) #f not-pat-literal?)) 250 | (define (list-ellipsis-vars subtmpl) 251 | (list-ids subtmpl #t (lambda (id) (memq id ellipsis-vars)))) 252 | (let expand ((tmpl tmpl) (bindings top-bindings)) 253 | (let expand-part ((tmpl tmpl)) 254 | (cond 255 | ((id? tmpl) (cdr (or (assq tmpl bindings) 256 | (assq tmpl top-bindings) 257 | (assq tmpl new-literals)))) 258 | ((vector? tmpl) 259 | (list->vector (expand-part (vector->list tmpl)))) 260 | ((pair? tmpl) 261 | (if (ellipsis-pair? (cdr tmpl)) 262 | (let ((vars-to-iterate (list-ellipsis-vars (car tmpl)))) 263 | (define (lookup var) (cdr (assq var bindings))) 264 | (define (expand-using-vals . vals) 265 | (expand (car tmpl) (map cons vars-to-iterate vals))) 266 | (let ((val-lists (map lookup vars-to-iterate))) 267 | (append (apply map expand-using-vals val-lists) 268 | (expand-part (cddr tmpl))))) 269 | (cons (expand-part (car tmpl)) (expand-part (cdr tmpl))))) 270 | (else tmpl))))) 271 | 272 | (lambda (use use-env) 273 | (let loop ((rules rules)) 274 | (let* ((rule (car rules)) (pat (car rule)) (tmpl (cadr rule))) 275 | (cond ((match-pattern pat use use-env) => 276 | (lambda (bindings) (expand-template pat tmpl bindings))) 277 | (else (loop (cdr rules)))))))) 278 | syntax-rules*) 279 | (define macro-defs 280 | '((define-syntax quote 281 | (syntax-rules () 282 | ('(x . y) (cons 'x 'y)) 283 | ('#(x ...) (list->vector '(x ...))) 284 | ('x (q x)))) 285 | (define-syntax quasiquote 286 | (syntax-rules (unquote unquote-splicing quasiquote) 287 | (`,x x) 288 | (`(,@x . y) (append x `y)) 289 | ((_ `x . d) (cons 'quasiquote (quasiquote (x) d))) 290 | ((_ ,x d) (cons 'unquote (quasiquote (x) . d))) 291 | ((_ ,@x d) (cons 'unquote-splicing (quasiquote (x) . d))) 292 | ((_ (x . y) . d) 293 | (cons (quasiquote x . d) (quasiquote y . d))) 294 | ((_ #(x ...) . d) 295 | (list->vector (quasiquote (x ...) . d))) 296 | ((_ x . d) 'x))) 297 | (define-syntax do 298 | (syntax-rules () 299 | ((_ ((var init . step) ...) 300 | ending 301 | expr ...) 302 | (let loop ((var init) ...) 303 | (cond ending (else expr ... (loop (begin var . step) ...))))))) 304 | (define-syntax letrec 305 | (syntax-rules () 306 | ((_ ((var init) ...) . body) 307 | (let () (def var init) ... (let () . body))))) 308 | (define-syntax letrec-syntax 309 | (syntax-rules () 310 | ((_ ((key trans) ...) . body) 311 | (let () (define-syntax key trans) ... (let () . body))))) 312 | (define-syntax let-syntax 313 | (syntax-rules () 314 | ((_ () . body) (let () . body)) 315 | ((_ ((key trans) . bindings) . body) 316 | (letrec-syntax ((temp trans)) 317 | (let-syntax bindings (letrec-syntax ((key temp)) . body)))))) 318 | (define-syntax let* 319 | (syntax-rules () 320 | ((_ () . body) (let () . body)) 321 | ((_ (first . more) . body) 322 | (let (first) (let* more . body))))) 323 | (define-syntax let 324 | (syntax-rules () 325 | ((_ ((var init) ...) . body) 326 | ((lambda (var ...) . body) 327 | init ...)) 328 | ((_ name ((var init) ...) . body) 329 | ((letrec ((name (lambda (var ...) . body))) 330 | name) 331 | init ...)))) 332 | (define-syntax case 333 | (syntax-rules () 334 | ((_ x (test . exprs) ...) 335 | (let ((key x)) 336 | (cond ((case-test key test) . exprs) 337 | ...))))) 338 | (define-syntax case-test 339 | (syntax-rules (else) ((_ k else) #t) ((_ k atoms) (memv k 'atoms)))) 340 | (define-syntax cond 341 | (syntax-rules (else =>) 342 | ((_) #f) 343 | ((_ (else . exps)) (begin #f . exps)) 344 | ((_ (x) . rest) (or x (cond . rest))) 345 | ((_ (x => proc) . rest) 346 | (let ((tmp x)) (cond (tmp (proc tmp)) . rest))) 347 | ((_ (x . exps) . rest) 348 | (if x (begin . exps) (cond . rest))))) 349 | (define-syntax and 350 | (syntax-rules () 351 | ((_) #t) 352 | ((_ test) test) 353 | ((_ test . tests) (if test (and . tests) #f)))) 354 | (define-syntax or 355 | (syntax-rules () 356 | ((_) #f) 357 | ((_ test) test) 358 | ((_ test . tests) (let ((x test)) (if x x (or . tests)))))) 359 | (define-syntax define 360 | (syntax-rules () 361 | ((_ (var . args) . body) 362 | (define var (lambda args . body))) 363 | ((_ var init) (def var init)))) 364 | (define-syntax if 365 | (syntax-rules () ((_ x y ...) (if* x (lambda () y) ...)))) 366 | (define-syntax delay 367 | (syntax-rules () ((_ x) (delay* (lambda () x))))))) 368 | (define (if* a b . c) (if a (b) (if (pair? c) ((car c))))) 369 | (define (delay* thunk) (delay (thunk))) 370 | (define (null-env) 371 | ((eval `(lambda (cons append list->vector memv delay* if* syntax-rules**) 372 | ((lambda (syntax-rules*) 373 | (define-syntax syntax-rules 374 | (syntax-rules* (get-env) #f (syntax ()) 375 | (syntax (((_ (lit ...) . rules) 376 | (syntax-rules #f (lit ...) . rules)) 377 | ((_ ellipsis lits . rules) 378 | (syntax-rules* (get-env) (syntax ellipsis) 379 | (syntax lits) (syntax rules))))))) 380 | ((lambda () ,@macro-defs (get-env)))) 381 | (syntax-rules** id? new-id ((get-env) (syntax ...))))) 382 | #f) 383 | cons append list->vector memv delay* if* syntax-rules**)) 384 | (define promise (delay (null-env))) 385 | (lambda (version) 386 | (if (= version 5) 387 | (force promise) 388 | (open-input-file "sheep-herders/r^-1rs.ltx"))))) 389 | 390 | 391 | (define scheme-report-environment 392 | (let-syntax 393 | ((extend-env 394 | (syntax-rules () 395 | ((extend-env env . names) 396 | ((eval '(lambda names (get-env)) env) 397 | . names))))) 398 | (let () 399 | (define (r5-env) 400 | (extend-env (null-environment 5) 401 | eqv? eq? equal? 402 | number? complex? real? rational? integer? exact? inexact? 403 | = < > <= >= zero? positive? negative? odd? even? 404 | max min + * - / 405 | abs quotient remainder modulo gcd lcm numerator denominator 406 | floor ceiling truncate round rationalize 407 | exp log sin cos tan asin acos atan sqrt expt 408 | make-rectangular make-polar real-part imag-part magnitude angle 409 | exact->inexact inexact->exact 410 | number->string string->number 411 | not boolean? 412 | pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr 413 | caaar caadr cadar caddr cdaar cdadr cddar cdddr 414 | caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr 415 | cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr 416 | null? list? list length append reverse list-tail list-ref 417 | memq memv member assq assv assoc 418 | symbol? symbol->string string->symbol 419 | char? char=? char? char<=? char>=? 420 | char-ci=? char-ci? char-ci<=? char-ci>=? 421 | char-alphabetic? char-numeric? char-whitespace? 422 | char-upper-case? char-lower-case? 423 | char->integer integer->char char-upcase char-downcase 424 | string? make-string string string-length string-ref string-set! 425 | string=? string-ci=? string? string<=? string>=? 426 | string-ci? string-ci<=? string-ci>=? 427 | substring string-append string->list list->string 428 | string-copy string-fill! 429 | vector? make-vector vector vector-length vector-ref vector-set! 430 | vector->list list->vector vector-fill! 431 | procedure? apply map for-each force 432 | call-with-current-continuation 433 | values call-with-values dynamic-wind 434 | eval scheme-report-environment null-environment 435 | call-with-input-file call-with-output-file 436 | input-port? output-port? current-input-port current-output-port 437 | with-input-from-file with-output-to-file 438 | open-input-file open-output-file close-input-port close-output-port 439 | read read-char peek-char eof-object? char-ready? 440 | write display newline write-char)) 441 | (define promise (delay (r5-env))) 442 | (lambda (version) 443 | (if (= version 5) 444 | (force promise) 445 | (open-input-file "sheep-herders/r^-1rs.ltx")))))) 446 | 447 | ;; [1] Some claim that this is not required, and that it is compliant for 448 | ;; 449 | ;; (let* ((x (string #\a)) 450 | ;; (y (eval x (null-environment 5)))) 451 | ;; (string-set! x 0 #\b) 452 | ;; y) 453 | ;; 454 | ;; to return "b", but I say that's as bogus as if 455 | ;; 456 | ;; (let* ((x (string #\1)) 457 | ;; (y (string->number x))) 458 | ;; (string-set! x 0 #\2) 459 | ;; y) 460 | ;; 461 | ;; returned 2. Most implementations disagree with me, however. 462 | ;; 463 | ;; Note: it would be fine to pass through those strings (and pairs and 464 | ;; vectors) that are immutable, but we can't portably detect them. 465 | 466 | 467 | ;; Repl provides a simple read-eval-print loop. It semi-supports 468 | ;; top-level definitions and syntax definitions, but each one creates 469 | ;; a new binding whose region does not include anything that came 470 | ;; before the definition, so if you want mutually recursive top-level 471 | ;; procedures, you have to do it the hard way: 472 | ;; (define f #f) 473 | ;; (define (g) (f)) 474 | ;; (set! f (lambda () (g))) 475 | ;; Repl does not support macro uses that expand into top-level definitions. 476 | (define (repl) 477 | (let repl ((env (scheme-report-environment 5))) 478 | (display "eiod> ") 479 | (let ((exp (read))) 480 | (if (not (eof-object? exp)) 481 | (case (and (pair? exp) (car exp)) 482 | ((define define-syntax) (repl (eval `(let () ,exp (get-env)) 483 | env))) 484 | (else 485 | (for-each (lambda (val) (write val) (newline)) 486 | (call-with-values (lambda () (eval exp env)) 487 | list)) 488 | (repl env))))))) 489 | 490 | (define (tests noisy) 491 | (define env (scheme-report-environment 5)) 492 | (for-each 493 | (lambda (x) 494 | (let* ((exp (car x)) 495 | (expected (cadr x))) 496 | (if noisy (begin (display "Trying: ") (write exp) (newline))) 497 | (let* ((result (eval exp env)) 498 | (success (equal? result expected))) 499 | (if (not success) 500 | (begin (display "Failed: ") 501 | (if (not noisy) (write exp)) 502 | (display " returned ") 503 | (write result) 504 | (display ", not ") 505 | (write expected) 506 | (newline)))))) 507 | '((1 1) 508 | (#t #t) 509 | ("hi" "hi") 510 | (#\a #\a) 511 | ('1 1) 512 | ('foo foo) 513 | ('(a b) (a b)) 514 | ('#(a b) #(a b)) 515 | (((lambda (x) x) 1) 1) 516 | ((+ 1 2) 3) 517 | (((lambda (x) (set! x 2) x) 1) 2) 518 | (((lambda () (define x 1) x)) 1) 519 | (((lambda () (define (x) 1) (x))) 1) 520 | ((begin 1 2) 2) 521 | (((lambda () (begin (define x 1)) x)) 1) 522 | (((lambda () (begin) 1)) 1) 523 | ((let-syntax ((f (syntax-rules () ((_) 1)))) (f)) 1) 524 | ((letrec-syntax ((f (syntax-rules () ((_) (f 1)) ((_ x) x)))) (f)) 1) 525 | ((let-syntax ((f (syntax-rules () ((_ x ...) '(x ...))))) (f 1 2)) (1 2)) 526 | ((let-syntax ((f (syntax-rules () 527 | ((_ (x y) ...) '(x ... y ...)) 528 | ((_ x ...) '(x ...))))) 529 | (f (x1 y1) (x2 y2))) 530 | (x1 x2 y1 y2)) 531 | ((let-syntax ((let (syntax-rules () 532 | ((_ ((var init) ...) . body) 533 | '((lambda (var ...) . body) init ...))))) 534 | (let ((x 1) (y 2)) (+ x y))) 535 | ((lambda (x y) (+ x y)) 1 2)) 536 | ((let ((x 1)) x) 1) 537 | ((let* ((x 1) (x (+ x 1))) x) 2) 538 | ((let ((call/cc call-with-current-continuation)) 539 | (letrec ((x (call/cc list)) (y (call/cc list))) 540 | (if (procedure? x) (x (pair? y))) 541 | (if (procedure? y) (y (pair? x))) 542 | (let ((x (car x)) (y (car y))) 543 | (and (call/cc x) (call/cc y) (call/cc x))))) 544 | #t) 545 | ((if 1 2) 2) 546 | ((if #f 2 3) 3) 547 | ((and 1 #f 2) #f) 548 | ((force (delay 1)) 1) 549 | ((let* ((x 0) (p (delay (begin (set! x (+ x 1)) x)))) (force p) (force p)) 550 | 1) 551 | ((let-syntax 552 | ((foo (syntax-rules () 553 | ((_ (x ...) #(y z ...) ...) 554 | '((z ...) ... #((x y) ...)))))) 555 | (foo (a b c) #(1 i j) #(2 k l) #(3 m n))) 556 | ((i j) (k l) (m n) #((a 1) (b 2) (c 3)))) 557 | ((do ((vec (make-vector 5)) 558 | (i 0 (+ i 1))) 559 | ((= i 5) vec) 560 | (vector-set! vec i i)) 561 | #(0 1 2 3 4)) 562 | ((let-syntax ((f (syntax-rules (x) ((_ x) 1) ((_ y) 2)))) 563 | (define x (f x)) 564 | x) 565 | 2) 566 | ((let-syntax ((f (syntax-rules () ((_) 'x)))) (f)) 567 | x) 568 | ((let-syntax ((f (syntax-rules () 569 | ((_) (let ((x 1)) 570 | (let-syntax ((f (syntax-rules () ((_) 'x)))) 571 | (f))))))) 572 | (f)) 573 | x) 574 | ((let-syntax 575 | ((f (syntax-rules () 576 | ((f e a ...) 577 | (let-syntax 578 | ((g (syntax-rules ::: () 579 | ((g n :::) '((a e n :::) ...))))) 580 | (g 1 2 3)))))) 581 | (f ::: x y z)) 582 | ((x ::: 1 2 3) (y ::: 1 2 3) (z ::: 1 2 3))) 583 | ((let-syntax ((m (syntax-rules () ((m x ... y) (y x ...))))) 584 | (m 1 2 3 -)) 585 | -4)))) 586 | 587 | ;; matching close paren for quote-and-evaluate at beginning of file. 588 | ) 589 | 590 | -------------------------------------------------------------------------------- /librairie.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (C) 1995 Danny Dube, Universite de Montreal. All rights reserved. 2 | 3 | ; 4 | ; Fonctions implantees dans le noyau. Pour savoir lesquelles 5 | ; sont visibles, voir sections plus bas 6 | ; 7 | 8 | (peek-char . 0) 9 | (read-char . 1) 10 | (quit . 2) 11 | (return-current-continuation . 3) 12 | (boolean? . 4) 13 | (pair? . 5) 14 | (car . 6) 15 | (cdr . 7) 16 | (char? . 8) 17 | (integer->char . 9) 18 | (char->integer . 10) 19 | (string? . 11) 20 | (make-string1 . 12) 21 | (string-length . 13) 22 | (string-copy . 14) 23 | (symbol? . 15) 24 | (symbol->string . 16) 25 | (string->symbol . 17) 26 | (number? . 18) 27 | (vector? . 19) 28 | (make-vector1 . 20) 29 | (vector-length . 21) 30 | (procedure? . 22) 31 | (write-char . 23) 32 | (introspection . 24) 33 | (cons . 25) 34 | (set-car! . 26) 35 | (set-cdr! . 27) 36 | (string-ref . 28) 37 | (string=? . 29) 38 | (cppoe2 . 30) 39 | (cplus2 . 31) 40 | (cmoins2 . 32) 41 | (cfois2 . 33) 42 | (cdivise2 . 34) 43 | (vector-ref . 35) 44 | (apply1 . 36) 45 | (eq? . 37) 46 | (return-there-with-this . 38) 47 | (string-set! . 39) 48 | (vector-set! . 40) 49 | 50 | #f ; Fin des definitions des primitives C 51 | 52 | ; 53 | ; Fonctions cachees de la librairie 54 | ; 55 | 56 | (define foldl 57 | (lambda (binop start l) 58 | (if (null? l) 59 | start 60 | (foldl binop (binop start (car l)) (cdr l))))) 61 | (define foldl1 62 | (lambda (binop l) 63 | (if (null? (cdr l)) 64 | (car l) 65 | (foldl1 binop (cons (binop (car l) (cadr l)) 66 | (cddr l)))))) 67 | (define foldr1 68 | (lambda (binop l) 69 | (if (null? (cdr l)) 70 | (car l) 71 | (binop (car l) (foldr1 binop (cdr l)))))) 72 | 73 | (define generic-member 74 | (lambda (releq obj list) 75 | (if (null? list) 76 | #f 77 | (if (releq (car list) obj) 78 | list 79 | (generic-member releq obj (cdr list)))))) 80 | 81 | (define generic-assoc 82 | (lambda (releq obj alist) 83 | (cond ((null? alist) 84 | #f) 85 | ((releq (car (car alist)) obj) 86 | (car alist)) 87 | (else 88 | (generic-assoc releq obj (cdr alist)))))) 89 | 90 | (define math=2 91 | (lambda (x y) 92 | (if (math<=2 x y) (math<=2 y x) #f))) 93 | 94 | (define math<2 95 | (lambda (x y) 96 | (not (math<=2 y x)))) 97 | 98 | (define math>2 99 | (lambda (x y) 100 | (not (math<=2 x y)))) 101 | 102 | (define math<=2 cppoe2) 103 | 104 | (define math>=2 (lambda (x y) (math<=2 y x))) 105 | 106 | (define generic-compare 107 | (lambda (binrel l) 108 | (if (null? (cddr l)) 109 | (binrel (car l) (cadr l)) 110 | (and (binrel (car l) (cadr l)) 111 | (generic-compare binrel (cdr l)))))) 112 | 113 | (define max2 (lambda (x y) (if (> x y) x y))) 114 | (define min2 (lambda (x y) (if (< x y) x y))) 115 | 116 | (define math+2 cplus2) 117 | 118 | (define math*2 cfois2) 119 | 120 | (define math-2 cmoins2) 121 | 122 | (define math/2 cdivise2) 123 | 124 | (define math%2 125 | (lambda (num den) 126 | (math-2 num (math*2 den (math/2 num den))))) 127 | 128 | (define mathgcd2 129 | (lambda (n1 n2) 130 | (let loop ((n1 (abs n1)) (n2 (abs n2))) 131 | (cond ((zero? n1) n2) 132 | ((zero? n2) n1) 133 | (else 134 | (let ((grand (max n1 n2)) 135 | (petit (min n1 n2))) 136 | (loop petit (modulo grand petit)))))))) 137 | 138 | (define mathlcm2 139 | (lambda (n1 n2) 140 | (cond ((zero? n1) (abs n2)) 141 | ((zero? n2) (abs n1)) 142 | (else 143 | (let ((n1 (abs n1)) 144 | (n2 (abs n2))) 145 | (/ (* n1 n2) (mathgcd2 n1 n2))))))) 146 | 147 | (define string-compare 148 | (lambda (rel len 0) 197 | (begin 198 | (parent (vector-ref d 0)) 199 | (let loop ((pos 1)) 200 | (if (< pos len) 201 | (begin 202 | (write-char #\space) 203 | (parent (vector-ref d pos)) 204 | (loop (+ pos 1))))))) 205 | (write-char #\))))) 206 | 207 | (define make-byte-reader 208 | (lambda (s) 209 | (let ((pos 0)) 210 | (lambda () 211 | (let ((c (string-ref s pos))) 212 | (set! pos (+ pos 1)) 213 | c))))) 214 | (define make-number-reader 215 | (lambda (read-const-byte) 216 | (lambda () 217 | (let* ((msc (read-const-byte)) 218 | (lsc (read-const-byte)) 219 | (msb (char->integer msc)) 220 | (lsb (char->integer lsc))) 221 | (+ (* msb 256) lsb))))) 222 | (define read-const-desc 223 | (lambda (const-v pos read-const-byte read-const-number) 224 | (let ((type (read-const-byte))) 225 | (cond 226 | ((char=? type #\0) ; EMPTY 227 | '()) 228 | ((char=? type #\1) ; PAIR 229 | (let* ((incar (vector-ref const-v (read-const-number))) 230 | (incdr (vector-ref const-v (read-const-number)))) 231 | (cons incar incdr))) 232 | ((char=? type #\2) ; BOOLEAN 233 | (char=? (read-const-byte) #\t)) 234 | ((char=? type #\3) ; CHAR 235 | (read-const-byte)) 236 | ((char=? type #\4) ; STRING 237 | (let* ((len (read-const-number)) 238 | (s (make-string len))) 239 | (let loop ((pos 0)) 240 | (if (< pos len) 241 | (begin 242 | (string-set! s pos (read-const-byte)) 243 | (loop (+ pos 1))))) 244 | s)) 245 | ((char=? type #\5) ; SYMBOL 246 | (string->symbol (vector-ref const-v (read-const-number)))) 247 | ((char=? type #\6) ; NUMBER 248 | (let* ((sign (read-const-byte)) 249 | (valabs (read-const-number))) 250 | (if (char=? sign #\+) 251 | valabs 252 | (- valabs)))) 253 | ((char=? type #\7) ; VECTOR 254 | (let* ((len (read-const-number)) 255 | (v (make-vector len))) 256 | (let loop ((pos 0)) 257 | (if (< pos len) 258 | (begin 259 | (vector-set! v pos (vector-ref const-v (read-const-number))) 260 | (loop (+ pos 1))))) 261 | v)))))) 262 | (define extract-top-const 263 | (lambda (const-v read-const-number) 264 | (let* ((nbtop (read-const-number)) 265 | (top-v (make-vector nbtop))) 266 | (let loop ((pos 0)) 267 | (if (< pos nbtop) 268 | (begin 269 | (vector-set! top-v pos (vector-ref const-v (read-const-number))) 270 | (loop (+ pos 1))))) 271 | top-v))) 272 | 273 | #f ; Fin des definitions des fonctions internes 274 | 275 | ; 276 | ; Les fonctions non-standard mais visibles tout 277 | ; de meme pour les programmes compiles 278 | ; 279 | 280 | (define append2 281 | (lambda (l1 l2) 282 | (if (null? l1) 283 | l2 284 | (let ((tete (cons (car l1) l2))) 285 | (let loop ((cur tete) (l1 (cdr l1))) 286 | (if (null? l1) 287 | tete 288 | (begin 289 | (set-cdr! cur (cons (car l1) l2)) 290 | (loop (cdr cur) (cdr l1))))))))) 291 | 292 | quit 293 | 294 | (define make-promise 295 | (lambda (proc) 296 | (let ((result-ready? #f) 297 | (result #f)) 298 | (lambda () 299 | (if result-ready? 300 | result 301 | (let ((x (proc))) 302 | (if result-ready? 303 | result 304 | (begin (set! result-ready? #t) 305 | (set! result x) 306 | result)))))))) 307 | 308 | ; Note tres importante: cette fonction sert a reconstituer les constantes 309 | ; du programme avant le debut de son execution. Toute fonction appelee 310 | ; durant l'execution de celle-ci ne doit pas comporter de constantes etant 311 | ; donne qu'elles ne sont pas encore baties. 312 | (define install-const 313 | (lambda () 314 | (let* ((const-string (introspection #f)) ; Porte secrete! 315 | (read-const-byte (make-byte-reader const-string)) 316 | (read-const-number (make-number-reader read-const-byte)) 317 | (nbconst (read-const-number)) 318 | (const-v (make-vector nbconst))) 319 | (let loop ((pos 0)) 320 | (if (< pos nbconst) 321 | (begin 322 | (vector-set! const-v 323 | pos 324 | (read-const-desc const-v 325 | pos 326 | read-const-byte 327 | read-const-number)) 328 | (loop (+ pos 1))))) 329 | (let ((top-v (extract-top-const const-v read-const-number))) 330 | (introspection top-v))))) ; Porte secrete! 331 | 332 | #f ; Fin des definitions des fonctions non-standard visibles 333 | 334 | ; 335 | ; Debut des fonctions Scheme standard de la librairie 336 | ; 337 | 338 | ; 6.1 339 | (define not (lambda (x) (if x #f #t))) 340 | boolean? 341 | 342 | ; 6.2 343 | (define eqv? 344 | (lambda (d1 d2) 345 | (cond ((and (number? d1) (number? d2)) 346 | (= d1 d2)) 347 | ((and (char? d1) (char? d2)) 348 | (char=? d1 d2)) 349 | (else 350 | (eq? d1 d2))))) 351 | eq? 352 | (define equal? 353 | (lambda (d1 d2) 354 | (cond ((eqv? d1 d2) 355 | #t) 356 | ((and (pair? d1) (pair? d2)) 357 | (and (equal? (car d1) (car d2)) (equal? (cdr d1) (cdr d2)))) 358 | ((and (vector? d1) (vector? d2)) 359 | (let ((len (vector-length d1))) 360 | (if (not (= len (vector-length d2))) 361 | #f 362 | (let loop ((pos 0)) 363 | (cond ((>= pos len) 364 | #t) 365 | ((equal? (vector-ref d1 pos) (vector-ref d2 pos)) 366 | (loop (+ pos 1))) 367 | (else 368 | #f)))))) 369 | ((and (string? d1) (string? d2)) 370 | (string=? d1 d2)) 371 | (else 372 | #f)))) 373 | 374 | ; 6.3 375 | pair? 376 | cons 377 | car 378 | cdr 379 | set-car! 380 | set-cdr! 381 | (define caar (lambda (p) (car (car p)))) 382 | (define cadr (lambda (p) (car (cdr p)))) 383 | (define cdar (lambda (p) (cdr (car p)))) 384 | (define cddr (lambda (p) (cdr (cdr p)))) 385 | (define caaar (lambda (p) (caar (car p)))) 386 | (define caadr (lambda (p) (caar (cdr p)))) 387 | (define cadar (lambda (p) (cadr (car p)))) 388 | (define caddr (lambda (p) (cadr (cdr p)))) 389 | (define cdaar (lambda (p) (cdar (car p)))) 390 | (define cdadr (lambda (p) (cdar (cdr p)))) 391 | (define cddar (lambda (p) (cddr (car p)))) 392 | (define cdddr (lambda (p) (cddr (cdr p)))) 393 | (define caaaar (lambda (p) (caaar (car p)))) 394 | (define caaadr (lambda (p) (caaar (cdr p)))) 395 | (define caadar (lambda (p) (caadr (car p)))) 396 | (define caaddr (lambda (p) (caadr (cdr p)))) 397 | (define cadaar (lambda (p) (cadar (car p)))) 398 | (define cadadr (lambda (p) (cadar (cdr p)))) 399 | (define caddar (lambda (p) (caddr (car p)))) 400 | (define cadddr (lambda (p) (caddr (cdr p)))) 401 | (define cdaaar (lambda (p) (cdaar (car p)))) 402 | (define cdaadr (lambda (p) (cdaar (cdr p)))) 403 | (define cdadar (lambda (p) (cdadr (car p)))) 404 | (define cdaddr (lambda (p) (cdadr (cdr p)))) 405 | (define cddaar (lambda (p) (cddar (car p)))) 406 | (define cddadr (lambda (p) (cddar (cdr p)))) 407 | (define cdddar (lambda (p) (cdddr (car p)))) 408 | (define cddddr (lambda (p) (cdddr (cdr p)))) 409 | (define null? 410 | (lambda (x) (eq? x '()))) 411 | (define list? 412 | (lambda (l) 413 | (cond ((null? l) 414 | #t) 415 | ((not (pair? l)) 416 | #f) 417 | (else 418 | (let loop ((slow l) (fast (cdr l)) (phase 2)) 419 | (cond ((null? fast) 420 | #t) 421 | ((not (pair? fast)) 422 | #f) 423 | ((eq? slow fast) 424 | #f) 425 | ((= phase 1) 426 | (loop slow (cdr fast) 2)) 427 | (else 428 | (loop (cdr slow) (cdr fast) 1)))))))) 429 | (define list (lambda l l)) 430 | (define length 431 | (lambda (l) 432 | (let loop ((l l) (len 0)) 433 | (if (null? l) 434 | len 435 | (loop (cdr l) (+ len 1)))))) 436 | (define append 437 | (lambda ll 438 | (foldr1 append2 (cons '() ll)))) 439 | (define reverse 440 | (lambda (l) 441 | (let loop ((l l) (rl '())) 442 | (if (null? l) 443 | rl 444 | (loop (cdr l) (cons (car l) rl)))))) 445 | (define list-tail 446 | (lambda (l pos) 447 | (if (= pos 0) 448 | l 449 | (list-tail (cdr l) (- pos 1))))) 450 | (define list-ref (lambda (l pos) (car (list-tail l pos)))) 451 | (define memq 452 | (lambda (obj list) 453 | (generic-member eq? obj list))) 454 | (define memv 455 | (lambda (obj list) 456 | (generic-member eqv? obj list))) 457 | (define member 458 | (lambda (obj list) 459 | (generic-member equal? obj list))) 460 | (define assq (lambda (obj alist) (generic-assoc eq? obj alist))) 461 | (define assv (lambda (obj alist) (generic-assoc eqv? obj alist))) 462 | (define assoc (lambda (obj alist) (generic-assoc equal? obj alist))) 463 | 464 | ; 6.4 465 | symbol? 466 | symbol->string 467 | string->symbol 468 | 469 | ; 6.5 470 | number? 471 | (define complex? number?) 472 | (define real? number?) 473 | (define rational? number?) 474 | (define integer? number?) 475 | (define exact? (lambda (n) #t)) 476 | (define inexact? (lambda (n) #f)) 477 | (define = (lambda l (generic-compare math=2 l))) 478 | (define < (lambda l (generic-compare math<2 l))) 479 | (define > (lambda l (generic-compare math>2 l))) 480 | (define <= (lambda l (generic-compare math<=2 l))) 481 | (define >= (lambda l (generic-compare math>=2 l))) 482 | (define zero? (lambda (n) (= n 0))) 483 | (define positive? (lambda (n) (> n 0))) 484 | (define negative? (lambda (n) (< n 0))) 485 | (define odd? (lambda (n) (= (math%2 (abs n) 2) 1))) 486 | (define even? (lambda (n) (= (math%2 (abs n) 2) 0))) 487 | (define max (lambda l (foldl1 max2 l))) 488 | (define min (lambda l (foldl1 min2 l))) 489 | (define + (lambda l (foldl math+2 0 l))) 490 | (define * (lambda l (foldl math*2 1 l))) 491 | (define - (lambda l (if (null? (cdr l)) (math-2 0 (car l)) (foldl1 math-2 l)))) 492 | (define / 493 | (lambda l (if (null? (cdr l)) (quotient 1 (car l)) (foldl1 quotient l)))) 494 | (define abs (lambda (n) (if (negative? n) (- n) n))) 495 | (define quotient 496 | (lambda (n d) 497 | (if (= d 0) 498 | 1 499 | (if (>= n 0) 500 | (if (> d 0) 501 | (math/2 n d) 502 | (- (math/2 n (- d)))) 503 | (if (> d 0) 504 | (- (math/2 (- n) d)) 505 | (math/2 (- n) (- d))))))) 506 | (define remainder (lambda (n d) (- n (* d (quotient n d))))) 507 | (define modulo 508 | (lambda (n d) 509 | (if (= d 0) 510 | n 511 | (if (> d 0) 512 | (if (>= n 0) 513 | (remainder n d) 514 | (remainder (+ (remainder n d) d) d)) 515 | (- (modulo (- n) (- d))))))) 516 | (define gcd (lambda l (foldl mathgcd2 0 l))) 517 | (define lcm (lambda l (foldl mathlcm2 1 l))) 518 | (define numerator (lambda (q) q)) 519 | (define denominator (lambda (q) 1)) 520 | (define floor numerator) 521 | (define ceiling numerator) 522 | (define truncate numerator) 523 | (define round numerator) 524 | (define rationalize (lambda (x y) x)) 525 | (define sqrt 526 | (lambda (x) 527 | (cond ((not (positive? x)) 528 | 0) 529 | ((= x 1) 530 | 1) 531 | (else 532 | (let loop ((sous 1) (sur x)) 533 | (if (<= (- sur sous) 1) 534 | sous 535 | (let* ((new (/ (+ sous sur) 2))) 536 | (if (<= (* new new) x) 537 | (loop new sur) 538 | (loop sous new))))))))) 539 | (define expt 540 | (lambda (base exp) 541 | (if (not (positive? exp)) 542 | 1 543 | (let* ((facteur (if (odd? exp) base 1)) 544 | (reste (expt (* base base) (/ exp 2)))) 545 | (* facteur reste))))) 546 | (define exact->inexact (lambda (z) z)) 547 | (define inexact->exact (lambda (z) z)) 548 | (define number->string 549 | (lambda (n . lradix) 550 | (let* ((radix (if (null? lradix) 10 (car lradix))) 551 | (negative (negative? n)) 552 | (absn (abs n))) 553 | (if (= n 0) 554 | (string-copy "0") 555 | (letrec ((decomp (lambda (n digits) 556 | (if (= n 0) 557 | digits 558 | (decomp (/ n radix) 559 | (cons (modulo n radix) digits)))))) 560 | (let* ((nd->ad (lambda (n) 561 | (if (< n 10) 562 | (+ n (char->integer #\0)) 563 | (+ (- n 10) (char->integer #\a))))) 564 | (digits (decomp absn '())) 565 | (adigits (map nd->ad digits)) 566 | (cdigits (map integer->char adigits)) 567 | (signedchars (if negative 568 | (cons #\- cdigits) 569 | cdigits))) 570 | (list->string signedchars))))))) 571 | (define string->number 572 | (lambda (str . lradix) 573 | (let* ((radix (if (null? lradix) 10 (car lradix))) 574 | (maxnum (if (<= radix 10) 575 | (integer->char (+ (- radix 1) (char->integer #\0))) 576 | #\9)) 577 | (len (string-length str))) 578 | (letrec ((checkdigit 579 | (lambda (d) 580 | (if (<= radix 10) 581 | (and (char<=? #\0 d) (char<=? d maxnum)) 582 | (or (and (char<=? #\0 d) (char<=? d maxnum)) 583 | (and (char<=? #\a (char-downcase d)) 584 | (char<=? (char-downcase d) #\f)))))) 585 | (checksyntax 586 | (lambda (min pos) 587 | (if (>= pos len) 588 | (>= pos min) 589 | (let ((d (string-ref str pos))) 590 | (cond ((checkdigit d) 591 | (checksyntax min (+ pos 1))) 592 | ((or (char=? d #\+) (char=? d #\-)) 593 | (and (= pos 0) (checksyntax 2 1))) 594 | (else #f)))))) 595 | (recomp (lambda (acc digits) 596 | (if (null? digits) 597 | acc 598 | (recomp (+ (* acc radix) (car digits)) 599 | (cdr digits))))) 600 | (cd->nd (lambda (c) 601 | (if (char-numeric? c) 602 | (- (char->integer c) (char->integer #\0)) 603 | (+ (- (char->integer (char-downcase c)) 604 | (char->integer #\a)) 605 | 10))))) 606 | (and (checksyntax 1 0) 607 | (let* ((signedchars (string->list str)) 608 | (negative (char=? (car signedchars) #\-)) 609 | (positive (char=? (car signedchars) #\+)) 610 | (cdigits (if (or negative positive) 611 | (cdr signedchars) 612 | signedchars)) 613 | (digits (map cd->nd cdigits)) 614 | (absn (recomp 0 digits))) 615 | (if negative (- absn) absn))))))) 616 | 617 | ; 6.6 618 | char? 619 | (define char=? (lambda (c1 c2) (= (char->integer c1) (char->integer c2)))) 620 | (define char? (lambda (c1 c2) (not (char<=? c1 c2)))) 622 | (define char<=? (lambda (c1 c2) (<= (char->integer c1) (char->integer c2)))) 623 | (define char>=? (lambda (c1 c2) (char<=? c2 c1))) 624 | (define char-ci=? 625 | (lambda (c1 c2) (char=? (char-downcase c1) (char-downcase c2)))) 626 | (define char-ci? 629 | (lambda (c1 c2) (char>? (char-downcase c1) (char-downcase c2)))) 630 | (define char-ci<=? 631 | (lambda (c1 c2) (char<=? (char-downcase c1) (char-downcase c2)))) 632 | (define char-ci>=? 633 | (lambda (c1 c2) (char>=? (char-downcase c1) (char-downcase c2)))) 634 | (define char-alphabetic? 635 | (lambda (c) (and (char-ci<=? #\a c) (char-ci<=? c #\z)))) 636 | (define char-numeric? (lambda (c) (and (char<=? #\0 c) (char<=? c #\9)))) 637 | (define char-whitespace? 638 | (lambda (c) 639 | (or (char=? c #\space) 640 | (char=? c (integer->char 9)) ; Tab 641 | (char=? c #\newline) 642 | (char=? c (integer->char 12)) ; FF 643 | (char=? c (integer->char 13))))) ; CR 644 | (define char-upper-case? (lambda (c) (and (char<=? #\A c) (char<=? c #\Z)))) 645 | (define char-lower-case? (lambda (c) (and (char<=? #\a c) (char<=? c #\z)))) 646 | char->integer 647 | integer->char 648 | (define char-upcase 649 | (lambda (c) 650 | (if (char-lower-case? c) 651 | (integer->char (+ (char->integer c) 652 | (- (char->integer #\A) (char->integer #\a)))) 653 | c))) 654 | (define char-downcase 655 | (lambda (c) 656 | (if (char-upper-case? c) 657 | (integer->char (+ (char->integer c) 658 | (- (char->integer #\a) (char->integer #\A)))) 659 | c))) 660 | 661 | ; 6.7 662 | string? 663 | (define make-string 664 | (lambda (len . lfill) 665 | (let ((str (make-string1 len))) 666 | (if (not (null? lfill)) 667 | (string-fill! str (car lfill))) 668 | str))) 669 | (define string (lambda l (list->string l))) 670 | string-length 671 | string-ref 672 | string-set! 673 | string=? 674 | (define string? 677 | (lambda (s1 s2) (> (string-compare char=? 681 | (lambda (s1 s2) (>= (string-compare char? 687 | (lambda (s1 s2) (> (string-compare char-ci=? 691 | (lambda (s1 s2) (>= (string-compare char-cilist 719 | (lambda (str) 720 | (let loop ((pos (- (string-length str) 1)) (l '())) 721 | (if (< pos 0) 722 | l 723 | (loop (- pos 1) (cons (string-ref str pos) l)))))) 724 | (define list->string 725 | (lambda (l) 726 | (let* ((len (length l)) 727 | (newstring (make-string1 len)) 728 | (iter (lambda (iter l to) 729 | (if (< to len) 730 | (begin 731 | (string-set! newstring to (car l)) 732 | (iter iter (cdr l) (+ to 1))))))) 733 | (iter iter l 0) 734 | newstring))) 735 | string-copy 736 | (define string-fill! 737 | (lambda (str fill) 738 | (let loop ((pos (- (string-length str) 1))) 739 | (if (>= pos 0) 740 | (begin 741 | (string-set! str pos fill) 742 | (loop (- pos 1))))))) 743 | 744 | ; 6.8 745 | vector? 746 | (define make-vector 747 | (lambda (len . lfill) 748 | (let ((v (make-vector1 len))) 749 | (if (not (null? lfill)) 750 | (vector-fill! v (car lfill))) 751 | v))) 752 | (define vector (lambda l (list->vector l))) 753 | vector-length 754 | vector-ref 755 | vector-set! 756 | (define vector->list 757 | (lambda (v) 758 | (let loop ((pos (- (vector-length v) 1)) (l '())) 759 | (if (< pos 0) 760 | l 761 | (loop (- pos 1) (cons (vector-ref v pos) l)))))) 762 | (define list->vector 763 | (lambda (l) 764 | (let* ((len (length l)) 765 | (v (make-vector len))) 766 | (let loop ((l l) (pos 0)) 767 | (if (not (null? l)) 768 | (begin 769 | (vector-set! v pos (car l)) 770 | (loop (cdr l) (+ pos 1))))) 771 | v))) 772 | (define vector-fill! 773 | (lambda (v fill) 774 | (let loop ((pos (- (vector-length v) 1))) 775 | (if (>= pos 0) 776 | (begin 777 | (vector-set! v pos fill) 778 | (loop (- pos 1))))))) 779 | 780 | ; 6.9 781 | procedure? 782 | (define apply 783 | (lambda (proc . llargs) 784 | (let ((largs (if (null? (cdr llargs)) 785 | (car llargs) 786 | (foldr1 cons llargs)))) 787 | (apply1 proc largs)))) 788 | (define map 789 | (lambda (proc . ll) 790 | (if (null? (car ll)) 791 | '() 792 | (let ((tetes (map1 car ll)) 793 | (queues (map1 cdr ll))) 794 | (cons (apply proc tetes) 795 | (apply map (cons proc queues))))))) 796 | (define for-each 797 | (lambda (proc . ll) 798 | (if (null? (car ll)) 799 | #f 800 | (let* ((tetes (map car ll)) 801 | (queues (map cdr ll))) 802 | (apply proc tetes) 803 | (apply for-each (cons proc queues)))))) 804 | (define force (lambda (promise) (promise))) 805 | (define call-with-current-continuation 806 | (lambda (proc) 807 | (let ((cc (return-current-continuation))) 808 | (if (vector? cc) 809 | (vector-ref cc 0) 810 | (let ((escape-proc (lambda (val) 811 | (let ((v (vector val))) 812 | (return-there-with-this cc v))))) 813 | (proc escape-proc)))))) 814 | (define call/cc call-with-current-continuation) 815 | 816 | ; 6.10 817 | read-char 818 | peek-char 819 | (define eof-object? (lambda (ch) (and (char? ch) (= (char->integer ch) 255)))) 820 | (define write 821 | (lambda (d) 822 | (cond ((eq? d #f) 823 | (write-many-chars #\# #\f)) 824 | ((eq? d #t) 825 | (write-many-chars #\# #\t)) 826 | ((symbol? d) 827 | (apply write-many-chars (string->list (symbol->string d)))) 828 | ((eqv? d #\space) 829 | (write-many-chars #\# #\\ #\s #\p #\a #\c #\e)) 830 | ((eqv? d #\newline) 831 | (write-many-chars #\# #\\ #\n #\e #\w #\l #\i #\n #\e)) 832 | ((eqv? d #\tab) 833 | (write-many-chars #\# #\\ #\t #\a #\b)) 834 | ((char? d) 835 | (write-many-chars #\# #\\ d)) 836 | ((vector? d) 837 | (write-vector d write)) 838 | ((pair? d) 839 | (write-char #\() 840 | (write (car d)) 841 | (write-cdr (cdr d) write)) 842 | ((number? d) 843 | (apply write-many-chars (string->list (number->string d)))) 844 | ((string? d) 845 | (write-char #\") 846 | (let ((len (string-length d))) 847 | (let loop ((pos 0)) 848 | (if (< pos len) 849 | (let ((c (string-ref d pos))) 850 | (cond 851 | ((char=? c #\") (write-many-chars #\\ #\") (loop (+ pos 1))) 852 | ((char=? c #\\) (write-many-chars #\\ #\\) (loop (+ pos 1))) 853 | (else (write-char c) (loop (+ pos 1)))))))) 854 | (write-char #\")) 855 | ((procedure? d) 856 | (write-many-chars #\# #\< #\p #\r #\o #\c #\e #\d #\u #\r #\e #\>)) 857 | ((null? d) 858 | (write-many-chars #\( #\))) 859 | (else 860 | #f)))) 861 | (define display 862 | (lambda (d) 863 | (cond ((char? d) 864 | (write-char d)) 865 | ((vector? d) 866 | (write-vector d display)) 867 | ((pair? d) 868 | (write-char #\() 869 | (display (car d)) 870 | (write-cdr (cdr d) display)) 871 | ((string? d) 872 | (apply write-many-chars (string->list d))) 873 | (else 874 | (write d))))) 875 | (define newline (lambda () (write-char #\newline))) 876 | write-char 877 | 878 | #f ; Fin des definitions des fonctions standard 879 | -------------------------------------------------------------------------------- /read-all.scm: -------------------------------------------------------------------------------- 1 | (define (read-all) 2 | (let ((datum (read))) 3 | (if (eof-object? datum) 4 | (begin 5 | (display "EOF reached")) 6 | (begin 7 | (write datum) 8 | (newline) 9 | (read-all))))) 10 | 11 | (read-all) 12 | -------------------------------------------------------------------------------- /reader-fail.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (C) 1995 Danny Dube, Universite de Montreal. All rights reserved. 2 | 3 | ; Les fonctions utilitaires generales 4 | 5 | ; Suppose que les deux arguments sont deja des ensembles de symboles 6 | (define symbol-set-union 7 | (lambda (ss1 ss2) 8 | (cond ((null? ss1) 9 | ss2) 10 | ((memq (car ss1) ss2) 11 | (symbol-set-union (cdr ss1) ss2)) 12 | (else 13 | )))) 14 | -------------------------------------------------------------------------------- /reader.scm: -------------------------------------------------------------------------------- 1 | (define (char-left-paren? ch) (char=? ch #\()) 2 | (define (char-right-paren? ch) (char=? ch #\))) 3 | (define (char-comment? ch) (char=? ch #\;)) 4 | (define (char-string? ch) (char=? ch #\")) 5 | (define (char-newline? ch) (char=? ch #\newline)) 6 | (define (char-dot? ch) (char=? ch #\.)) 7 | (define (char-quote? ch) (char=? ch #\')) 8 | (define (char-quasiquote? ch) (char=? ch #\`)) 9 | (define (char-unquote? ch) (char=? ch #\,)) 10 | (define (char-backslash? ch) (char=? ch #\\)) 11 | (define (char-character? ch) (char=? ch #\#)) 12 | (define (char-minus? ch) (char=? ch #\-)) 13 | (define (identifier-end? ch) (or (char-left-paren? ch) 14 | (char-right-paren? ch) 15 | (char-whitespace? ch))) 16 | 17 | (define (read) 18 | (read-with-char (read-char))) 19 | 20 | (define (read-with-char ch) 21 | (cond ((eof-object? ch) ch) 22 | ((char-left-paren? ch) (read-list)) 23 | ((char-whitespace? ch) (read)) 24 | ((char-comment? ch) (read-comment) (read)) 25 | ((char-quote? ch) (cons 'quote (cons (read) '()))) 26 | ((char-quasiquote? ch) (cons 'quasiquote (cons (read) '()))) 27 | ((char-unquote? ch) 28 | (if (char=? #\@ (peek-char)) 29 | (begin (read-char) (cons 'unquote-splicing (cons (read) '()))) 30 | (cons 'unquote (cons (read) '())))) 31 | ((char-string? ch) (read-string)) 32 | ((char-character? ch) (read-char-literal)) 33 | ((char-numeric? ch) (read-number ch)) 34 | ((and (char-minus? ch) (char-numeric? (peek-char))) (read-number ch)) 35 | (else (read-identifier ch)))) 36 | 37 | (define (read-char-literal) 38 | (define ch (read-char)) 39 | ;(display "read-char-literal:") 40 | ;(write ch) 41 | ;(newline) 42 | (cond ((char-backslash? ch) (read-char-backslash)) 43 | ((char-left-paren? ch) (list->vector (read-list))) 44 | (else (let ((id (symbol->string (read-identifier ch)))) 45 | (cond ((string=? id "t") #t) 46 | ((string=? id "f") #f) 47 | (else (display "ERROR! Unknown character constant #") 48 | (display id) 49 | (newline))))))) 50 | 51 | (define (read-char-backslash) 52 | (let ((id (symbol->string (read-identifier (read-char))))) 53 | (cond ((string=? id "newline") #\newline) 54 | ((string=? id "space") #\space) 55 | ((string=? id "tab") (integer->char 9)) 56 | ((= (string-length id) 1) (car (string->list id))) 57 | (else (display "ERROR! Unknown character constant #\\") 58 | (display id) 59 | (newline))))) 60 | 61 | (define (read-comment) 62 | (if (not (char-newline? (read-char))) (read-comment))) 63 | 64 | (define (read-list) 65 | (define ch (read-char)) 66 | ;(display "read-list:") 67 | ;(write ch) 68 | ;(newline) 69 | (cond ((char-right-paren? ch) '()) 70 | ((and (char-dot? ch) (identifier-end? (peek-char))) (car (read-list))) 71 | ((char-whitespace? ch) (read-list)) 72 | ((char-comment? ch) (read-comment) (read-list)) 73 | (else (let ((elem (read-with-char ch))) (cons elem (read-list)))))) 74 | 75 | (define (char-list->number lst) 76 | (string->number (list->string lst))) 77 | 78 | (define (read-number ch) 79 | ;(display "read-number:") 80 | ;(write ch) 81 | ;(newline) 82 | (define (read-nmb) 83 | (define peek (peek-char)) 84 | (if (char-numeric? peek) 85 | (let ((ch (read-char))) (cons ch (read-nmb))) '())) 86 | (char-list->number (cons ch (read-nmb)))) 87 | 88 | (define (read-identifier ch) 89 | (define (read-id) 90 | (if (identifier-end? (peek-char)) '() 91 | (let ((ch (read-char))) (cons ch (read-id))))) 92 | (string->symbol (list->string (cons ch (read-id))))) 93 | 94 | (define (interpret-escape ch) 95 | (cond ((char=? ch #\n) #\newline) ;\n is newline 96 | ((char=? ch #\t) (integer->char 9)) ;\t is tab 97 | (else ch))) 98 | 99 | (define (read-string) 100 | ;(display "read-string:") 101 | ;(newline) 102 | (define (read-str) 103 | (define ch (read-char)) 104 | ;(display "read-str:") 105 | ;(write ch) 106 | ;(newline) 107 | (cond ((char-backslash? ch) (let ((ch (interpret-escape (read-char)))) (cons ch (read-str)))) 108 | ((char-string? ch) '()) 109 | (else (cons ch (read-str))))) 110 | (list->string (read-str))) 111 | 112 | (define (read-all) 113 | (let ((datum (read))) 114 | (if (eof-object? datum) 115 | (begin 116 | (display "EOF reached") 117 | (newline)) 118 | (begin 119 | (write datum) 120 | (newline) 121 | (read-all))))) 122 | 123 | (read-all) 124 | -------------------------------------------------------------------------------- /show-char.scm: -------------------------------------------------------------------------------- 1 | (define (loop) 2 | (let ((ch (read-char))) 3 | (if (eof-object? ch) #f 4 | (begin 5 | (display "char: ") 6 | (write ch) 7 | (display " ") 8 | (display "int: ") 9 | (write (char->integer ch)) 10 | (newline) 11 | (loop))))) 12 | 13 | (loop) 14 | -------------------------------------------------------------------------------- /test-expander.scm: -------------------------------------------------------------------------------- 1 | (write (expand-program (list 2 | '(let-syntax ((x append)) ((x x))) 3 | '(let ((n 0)) 4 | (let-syntax ((x (set! n (+ n 1)))) 5 | (begin x x x n))) 6 | '(let-syntax ((q quote)) (q x)) 7 | '((syntax-rules () 8 | ((let ((var init) ...) . body) 9 | ((lambda (var ...) . body) 10 | init ...))) 11 | ((x 1) (y 2)) 12 | (+ x y)) 13 | ))) 14 | (newline) 15 | --------------------------------------------------------------------------------