From 6659c46bb7ad71e2df90d426a557c6ec8c4996ec Mon Sep 17 00:00:00 2001 From: Itamar Ben Zaken Date: Sat, 14 Mar 2009 18:35:01 +0200 Subject: [PATCH] added some builtins, fixed string-constant generation (it led to seg-fault on string-set) --- compiler.sml | 2 +- src/c/builtins.c | 184 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- src/c/scheme.c | 10 ++- src/c/strings.h | 2 + src/sml/cg.sml | 21 ++++++- 5 files changed, 211 insertions(+), 8 deletions(-) diff --git a/compiler.sml b/compiler.sml index 1342680..cff755e 100644 --- a/compiler.sml +++ b/compiler.sml @@ -89,7 +89,7 @@ struct fun compileSchemeFile (infile:string, outfile:string) : unit = stringToFile ( outfile, - (compile ( (fileToString "./src/scm/support-code.scm")^ + (compile ((fileToString "./src/scm/support-code.scm")^ (fileToString infile)))); end; (* of struct CodeGen *) diff --git a/src/c/builtins.c b/src/c/builtins.c index 409d262..67b0595 100644 --- a/src/c/builtins.c +++ b/src/c/builtins.c @@ -59,7 +59,16 @@ Lset_car: r[1] = BI_ST_ARG(1); ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR ); SOB_PAIR_CAR(r[0]) = (SchemeObject*)r[1]; - r_res = r[1]; + r_res = (int)&sc_void; + BI_RETURN(); + +Lset_cdr: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("set-cdr!",2) ); + r[0] = BI_ST_ARG(0); + r[1] = BI_ST_ARG(1); + ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR ); + SOB_PAIR_CDR(r[0]) = (SchemeObject*)r[1]; + r_res = (int)&sc_void; BI_RETURN(); Lmake_vector: @@ -155,6 +164,7 @@ LbinaryDIV: r[1] = BI_ST_ARG(1); ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), ""); r[1] = SOB_INT_VALUE((SchemeObject*)r[1]); + ASSERT_ALWAYS( (int)r[1]!=0, MSG_ERR_DIVZERO ); r_res = (int)r[0] / (int)r[1]; /* divide as signed integers */ r_res = (int)makeSchemeInt( r_res ); BI_RETURN(); @@ -199,6 +209,14 @@ Lchar_to_integer: r_res = (int)makeSchemeInt( (int)r[0] ); BI_RETURN(); +Linteger_to_char: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("integer->char",1) ); + r[0] = BI_ST_ARG(0); + ASSERT_ALWAYS( IS_SOB_INT(r[0]), "" ); + r[0] = SOB_INT_VALUE(r[0]); + r_res = (int)makeSchemeChar( (char)r[0] ); + BI_RETURN(); + Lapply: push( fp ); fp = sp; @@ -218,12 +236,161 @@ Lapply: /* branch */ goto *SOB_CLOSURE_CODE(r[0]); +Lboolean: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("boolean?",1) ); + r[0] = BI_ST_ARG(0); + r_res = (IS_SOB_BOOL(r[0])) ? (int)&sc_true : (int)&sc_false; + BI_RETURN(); + +Lchar: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("char?",1) ); + r[0] = BI_ST_ARG(0); + r_res = (IS_SOB_CHAR(r[0])) ? (int)&sc_true : (int)&sc_false; + BI_RETURN(); + +Linteger: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("integer?",1) ); + r[0] = BI_ST_ARG(0); + r_res = (IS_SOB_INT(r[0])) ? (int)&sc_true : (int)&sc_false; + BI_RETURN(); + +Lpair: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("pair?",1) ); + r[0] = BI_ST_ARG(0); + r_res = (IS_SOB_PAIR(r[0])) ? (int)&sc_true : (int)&sc_false; + BI_RETURN(); + +Lprocedure: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("procedure?",1) ); + r[0] = BI_ST_ARG(0); + r_res = (IS_SOB_CLOSURE(r[0])) ? (int)&sc_true : (int)&sc_false; + BI_RETURN(); + +Lcons: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("cons",2) ); + r[0] = BI_ST_ARG(0); + r[1] = BI_ST_ARG(1); + r_res = (int)makeSchemePair( (SchemeObject*)r[0], (SchemeObject*)r[1] ); + BI_RETURN(); + +Leq: + /* The eq? procedure compare the + VALUES of booleans, + chars, + integers, + symbols, + and the ADDRESSES of pairs, + strings, and + vectors. + */ + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("eq?",2) ); + r[0] = BI_ST_ARG(0); + r[1] = BI_ST_ARG(1); + if ( IS_SOB_BOOL(r[0]) ) goto Leq_boolval; + if ( IS_SOB_CHAR(r[0]) ) goto Leq_charval; + if ( IS_SOB_INT(r[0]) ) goto Leq_intval; + if ( IS_SOB_SYMBOL(r[0]) ) goto Leq_symval; + if ( r[0]==r[1] ) goto Leq_true; + goto Leq_false; +Leq_boolval: + if ( !IS_SOB_BOOL(r[1]) ) goto Leq_false; + if ( SOB_BOOL_VALUE(r[0])==SOB_BOOL_VALUE(r[1]) ) goto Leq_true; + goto Leq_false; +Leq_charval: + if ( !IS_SOB_CHAR(r[1]) ) goto Leq_false; + if ( SOB_CHAR_VALUE(r[0])==SOB_CHAR_VALUE(r[1]) ) goto Leq_true; + goto Leq_false; +Leq_intval: + if ( !IS_SOB_INT(r[1]) ) goto Leq_false; + if ( SOB_INT_VALUE(r[0])==SOB_INT_VALUE(r[1]) ) goto Leq_true; + goto Leq_false; +Leq_symval: + if ( !IS_SOB_SYMBOL(r[1]) ) goto Leq_false; + if ( SOB_SYMBOL_ENTRY(r[0])==SOB_SYMBOL_ENTRY(r[1]) ) goto Leq_true; + goto Leq_false; +Leq_true: + r_res = (int)&sc_true; + BI_RETURN(); +Leq_false: + r_res = (int)&sc_false; + BI_RETURN(); + +Lmake_string: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("make-string",2) ); + r[0] = BI_ST_ARG(0); + ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), ""); + r[0] = SOB_INT_VALUE(r[0]); + r[1] = BI_ST_ARG(1); + ASSERT_ALWAYS(IS_SOB_CHAR((SchemeObject*)r[1]), ""); + r[1] = (int)SOB_CHAR_VALUE(r[1]); + r_res = (int)makeSchemeString(r[0],(char)r[1]); + BI_RETURN(); + +Lremainder: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("remainder",2) ); + r[0] = BI_ST_ARG(0); + ASSERT_ALWAYS( IS_SOB_INT(r[0]), "" ); + r[0] = SOB_INT_VALUE(r[0]); + r[1] = BI_ST_ARG(1); + ASSERT_ALWAYS( IS_SOB_INT(r[1]), "" ); + r[1] = SOB_INT_VALUE(r[1]); + ASSERT_ALWAYS( (int)r[1]!=0, MSG_ERR_DIVZERO ); + r_res = (int)r[0] % (int)r[1]; /* divide as signed integers */ + r_res = (int)makeSchemeInt( r_res ); + BI_RETURN(); + +Lstring_to_symbol: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("string->symbol",1) ); + r[0] = BI_ST_ARG(0); + ASSERT_ALWAYS( IS_SOB_STRING(r[0]), "" ); + r[0] = (int)SOB_STRING_VALUE(r[0]); + r_res = (int)makeSchemeSymbol((char*)r[0]); + BI_RETURN(); + +Lstring_length: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("string-length",1) ); + r[0] = BI_ST_ARG(0); + ASSERT_ALWAYS( IS_SOB_STRING(r[0]), "" ); + r_res = SOB_STRING_LENGTH(r[0]); + r_res = (int)makeSchemeInt(r_res); + BI_RETURN(); + +Lstring_ref: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("string-ref",2) ); + r[0] = BI_ST_ARG(0); + ASSERT_ALWAYS( IS_SOB_STRING(r[0]), "" ); + r[1] = BI_ST_ARG(1); + ASSERT_ALWAYS( IS_SOB_INT(r[1]), "" ); + r[1] = SOB_INT_VALUE( r[1] ); + ASSERT_ALWAYS( (r[1]>=0) & (r[1]=0) & (r[1]integer" ,&&Lchar_to_integer); + CREATE_BUILTIN_CLOS("integer->char" ,&&Linteger_to_char); CREATE_BUILTIN_CLOS("apply" ,&&Lapply); + CREATE_BUILTIN_CLOS("boolean?" ,&&Lboolean); + CREATE_BUILTIN_CLOS("char?" ,&&Lchar); + CREATE_BUILTIN_CLOS("cons" ,&&Lcons); + CREATE_BUILTIN_CLOS("eq?" ,&&Leq); + CREATE_BUILTIN_CLOS("integer?" ,&&Linteger); + CREATE_BUILTIN_CLOS("make-string" ,&&Lmake_string); + CREATE_BUILTIN_CLOS("number?" ,&&Linteger); /* same as integer? */ + CREATE_BUILTIN_CLOS("pair?" ,&&Lpair); + CREATE_BUILTIN_CLOS("procedure?" ,&&Lprocedure); + CREATE_BUILTIN_CLOS("remainder" ,&&Lremainder); + CREATE_BUILTIN_CLOS("string->symbol",&&Lstring_to_symbol); + CREATE_BUILTIN_CLOS("string-length" ,&&Lstring_length); + CREATE_BUILTIN_CLOS("string-ref" ,&&Lstring_ref); + CREATE_BUILTIN_CLOS("string-set!" ,&&Lstring_set); /* */ diff --git a/src/c/scheme.c b/src/c/scheme.c index 962e408..e5f57c5 100644 --- a/src/c/scheme.c +++ b/src/c/scheme.c @@ -260,7 +260,8 @@ char *sobIntToString(SchemeObject *sob) char *sobCharToString(SchemeObject *sob) { - char c, buf[MAX_CHAR_LENGTH], *res; + unsigned char c; + char buf[MAX_CHAR_LENGTH], *res; c = SOB_CHAR_VALUE(sob); @@ -276,13 +277,16 @@ char *sobCharToString(SchemeObject *sob) else if (c == '\f') { sprintf(buf, "#\\page"); } + else if (c == '\0') { + sprintf(buf, "#\\nul"); + } else if (c < ' ') { - int o1, o2, o3; + unsigned int o1, o2, o3; o3 = c % 8; c = c >> 3; o2 = c % 8; c = c >> 3; o1 = c % 8; /* not needed; just for good luck :) */ - sprintf(buf, "#\\%d%d%d", o1, o2, o3); + sprintf(buf, "#\\%u%u%u", o1, o2, o3); } else { sprintf(buf, "#\\%c", c); diff --git a/src/c/strings.h b/src/c/strings.h index 14e3d51..ecff15b 100644 --- a/src/c/strings.h +++ b/src/c/strings.h @@ -6,5 +6,7 @@ #define MSG_ERR_NOTPAIR "not a pair" #define MSG_ERR_NOTLIST "not a proper list" #define MSG_ERR_APPNONPROC "attempt to apply non-procedure" +#define MSG_ERR_DIVZERO "division by zero" +#define MSG_ERR_NDXOUTOFBOUNDS "index out of bounds" #endif diff --git a/src/sml/cg.sml b/src/sml/cg.sml index 0e962e2..218a330 100644 --- a/src/sml/cg.sml +++ b/src/sml/cg.sml @@ -140,10 +140,25 @@ end = struct "&"^syment_name)) end + and stringToCArray s = + if String.size s = 0 then + "{0}" + else + "{"^ + (String.concatWith "," + (List.map (Int.toString o Char.ord) + (String.explode s)))^ + ",0}" + and emit_string (name, s) = - let val data_name = new_name (name ^ "_data") - in (const_code (name, "SCHEME_STRING", data_name, "ssd", - (Int.toString (String.size s))^", \""^(String.toCString s)^"\"")) + let + val data_name = new_name (name ^ "_data") + val arr_name = new_name (name ^ "_arr") + val arr_stmt = "char "^arr_name^"[] = "^(stringToCArray s)^";\n" + in + arr_stmt^ + (const_code (name, "SCHEME_STRING", data_name, "ssd", + (Int.toString (String.size s))^", "^arr_name)) end and emit_number (name, i) = -- 2.11.4.GIT