english version "1.0" identify "%Z%%M% %I% %E%" #: Copyright (c) 1995-2005 by Wayne C. Gramlich. #, All rights reserved. module c_import #: This module implements functionality that allows the importing of #, C code into STIPPLE program. If the C code is well written and #, this module is used properly, the result is safe and proper STIPPLE #, code; otherwise, you can get some extremely strange behavior using #, this module. import character command_types command_parse format in_stream logical null out_stream string system vector unsigned define c_bind #: C/STIPPLE name binding record c_name string #: The C name stipple_comment string #: The STIPPLE comment stipple_name string #: The STIPPLE type name generate allocate, erase, print define c_define #: C #define record c_name string #: Name of #define value string #: Value of #define generate allocate, erase, print define c_enumeration #: C/STIPPLE enumeration record c_name string #: C name of type exact_match logical #: ({true}=>exact;{false}=>loose) match kind c_kind #: Kind of C enumeration items vector[c_bind] #: List of item names stipple_co_type string #: STIPPLE type name for C enum values stipple_comment string #: STIPPLE comment string stipple_name string #: STIPPLE type name for STIPPLE values generate allocate, erase, print define c_field #: One field of a record/struct record c_name string #: The C name for the field stipple_comment string #: The STIPPLE comment for the field stipple_name string #: The STIPPLE name for the field type c_sub_type #: The type of the field generate_get logical #: {true} generate a get routine generate_set logical #: {true} generate a set routine generate allocate, erase, print define c_kind #: Kind of C structure definition enumeration defines #: enum is a bunch of #define's enum #: enum name {...}; struct #: struct name {...}; typedef_enum #: typedef enum {...} name; typedef_struct #: typedef struct {...} name; typedef_struct_pointer #: typedef struct {...} *name; generate print define c_import #: Top-level C import object record defines vector[c_define] #: List of #define directives enumerations vector[c_enumeration] #: List of enumeration types import_logical logical #: {true}=>import logical module import_out_stream logical #: {true}=>import out_stream module import_string logical #: {true}=>import string module import_system logical #: {true}=>import system module import_table logical #: {true}=>import table module imports vector[string] #: List of imported modules includes vector[string] #: Included strings include_paths vector[string] #: Include directory paths module_name string #: STIPPLE module name records vector[c_record] #: All defined records type_character c_sub_type #: Character type type_logical c_sub_type #: Logical type type_integer c_sub_type #: Integer type type_short_integer c_sub_type #: Short integer type type_short_unsigned c_sub_type #: Short unsigned integer type type_string c_sub_type #: C string type type_unsigned c_sub_type #: Unsigned type generate allocate, erase, print define c_options #: Options used record includes vector[string] #: -I output_file_name string #: -o c_generate logical #: -c (generate C file) stipple_generate logical #: -s (generate STIPPLE file) generate allocate, erase, print define c_record #: C/STIPPLE struct/record record c_name string #: The C name of the struct external logical #: {true}=>emit an extern record fields vector[c_field] #: The fields of the struct/record generate_print logical #: {true}=>generate print procedure generate_new logical #: {true}=>generate new procedure kind c_kind #: Kind of C struct/typedef records vector[c_record] #: Records defined stipple_comment string #: The STIPPLE comment for the record stipple_name string #: The STIPPLE name of the record generate allocate, erase, print define c_sub_type #: C/STIPPLE type variant kind c_type_kind character null #: 8-bit unsigned character integer null #: Signed integer logical null #: Logical/bool type opaque c_bind #: Type is opque pointer c_bind #: Type is a pointer short_integer null #: Short integer short_unsigned null #: Unsigend short string null #: Type is a C string unsigned null #: Unsigned integer generate allocate, erase, print #: {c_enumeration} routines: procedure c_initial_generate@c_enumeration takes enumeration c_enumeration c_stream out_stream returns_nothing #: This procedure will generate the initial object declaration #, for the C type associated with {enumeration}. format@format1[string](c_stream, "unsigned %s%___initial = 0;\n\", enumeration.stipple_co_type) put@("\n\", c_stream) procedure c_initialize_generate@c_enumeration takes enumeration c_enumeration c_stream out_stream returns_nothing #: This procedure will generate the initialization routine for #: the C type associated with {enumeration}. put@("void\n\", c_stream) format@format1[string](c_stream, "%s%__external__initialize(void)\n\", enumeration.stipple_co_type) put@("{\n\", c_stream) put@("}\n\", c_stream) put@("\n\", c_stream) procedure c_unsigned_convert_generate@c_enumeration takes enumeration c_enumeration c_stream out_stream returns_nothing #: This procedure will generate the unsigned converstion routine #, for the C type associated with {enumeration}. put@("unsigned\n\", c_stream) format@format1[string](c_stream, "%s%__unsigned_convert(\n\", enumeration.stipple_co_type) put@("\t\unsigned value)\n\", c_stream) put@("{\n\", c_stream) put@("\t\return value;\n\", c_stream) put@("}\n\", c_stream) put@("\n\", c_stream) procedure c_value_get_generate@c_enumeration takes enumeration c_enumeration c_stream out_stream returns_nothing #: This procedure will generate the c_value_get routine for {enumeration} #, to {c_stream}. put@("unsigned\n\", c_stream) format@format2[string, string](c_stream, "%s%__%s%_get(\n\", enumeration.stipple_name, enumeration.stipple_co_type) put@("\t\unsigned stipple__value)\n\", c_stream) put@("{\n\", c_stream) put@("\t\static unsigned c__values[] = {\n\", c_stream) items :@= enumeration.items size :@= items.size index :@= 0 loop while index < size item :@= items[index] index :+= 1 format@format3[string, string, string](c_stream, "\t,t\%s%%s%\t\/* %s% */\n\", item.c_name, (index = size) ? "" : ",", item.stipple_name) put@("\t\};\n\", c_stream) put@("\t\return c__values[stipple__value];\n\", c_stream) put@("}\n\", c_stream) put@("\n\", c_stream) procedure format@c_enumeration takes enumeration c_enumeration out_stream out_stream format string offset unsigned returns_nothing #: This procedure will output {enumeration} to {out_stream}. chr :@= format[offset] if chr = "s"[0] put@(enumeration.stipple_name, out_stream) else_if chr = "c"[0] put@(enumeration.c_name, out_stream) else_if chr = "t"[0] switch enumeration.kind case enum format@format1[string](out_stream, "enum %s%", enumeration.c_name) case typedef_enum format@format1[string](out_stream, "%s%", enumeration.c_name) default assert false procedure item_append@c_enumeration takes enumeration c_enumeration c_name string stipple_name string stipple_comment string returns_nothing #: This procedure will add the enumeration item binding of {c_name} #, {stipple_name} to {enumeration}. {stipple_comment} will appear #, in the generated STIPPLE code next to the item name. initialize item:: c_bind := allocate@c_bind() item.c_name := c_name item.stipple_comment := stipple_comment item.stipple_name := stipple_name append@(enumeration.items, item) procedure stipple_convert_generate@c_enumeration takes enumeration c_enumeration stipple_stream out_stream returns_nothing #: This procedure will output a procedure for convert the C enumeration #, co-type into the STIPPLE co-type. # Output the declarations for the cotype procedures: stipple_co_type :@= enumeration.stipple_co_type stipple_name :@= enumeration.stipple_name format@format2[string, string](stipple_stream, "procedure %s%_get@%s%\n\", stipple_co_type, stipple_name) put@(" takes\n\", stipple_stream) format@format1[string](stipple_stream, "\t\value %s%\n\", stipple_name) format@format1[string](stipple_stream, " returns %s%\n\", stipple_co_type) format@format2[string, string](stipple_stream, " external %s%__%s%_get\n\", stipple_name, stipple_co_type) put@("\n\", stipple_stream) format@format1[string](stipple_stream, ' #: This procedure returns the {%s%} associated with {value}.\n\', stipple_co_type) put@("\n\", stipple_stream) put@("\n\", stipple_stream) # Output the conversion procedure: items :@= enumeration.items size :@= items.size format@format2[string, string](stipple_stream, "procedure %s%_convert@%s%\n\", stipple_name, stipple_co_type) put@(" takes\n\", stipple_stream) format@format1[string](stipple_stream, "\t\c_value %s%\n\", stipple_co_type) format@format1[string](stipple_stream, " returns %s%\n\", stipple_name) put@("\n\", stipple_stream) format@format1[string](stipple_stream, ' #: This procedure will convert {value} to a {%s%} type.\n\', stipple_name) put@("\n\", stipple_stream) format@format1[string](stipple_stream, " helper:: %s%_helper := ??\n\", stipple_co_type) put@(" c2stipple_convert :@= helper.c2stipple_convert\n\", stipple_stream) put@(" if !(helper.initialized)\n\", stipple_stream) put@("\t\system :@= standard@system()\n\", stipple_stream) format@format3[string, string, unsigned](stipple_stream, "\t\c2stipple_convert := xcreate@table[%s%, %s%](%d%)\n\", stipple_co_type, stipple_name, size) index :@= 0 loop while index < size item :@= items[index] put@("\t\assert !(insert@(c2stipple_convert,\n\", stipple_stream) format@format4[string, string, string, string](stipple_stream, "\t\ %s%_get@%s%(%s%), %s%))\n\", stipple_co_type, stipple_name, item.stipple_name, item.stipple_name) index :+= 1 put@("\t\helper.c2stipple_convert := c2stipple_convert\n\", stipple_stream) put@("\t\helper.initialized := true\n\", stipple_stream) put@(" return lookup@(c2stipple_convert, c_value)\n\", stipple_stream) put@("\n\", stipple_stream) put@("\n\", stipple_stream) procedure stipple_define_generate@c_enumeration takes enumeration c_enumeration stipple_stream out_stream returns_nothing #: This procedure will output a declaration for {enumeration} to #, {stipple_stream). format@format2[string, string](stipple_stream, "define %lw24s%\t\%s%\n\", enumeration.stipple_name, enumeration.stipple_comment) put@(" enumeration\n\", stipple_stream) items :@= enumeration.items size :@= items.size index :@= 0 loop while index < size item :@= items[index] format@format2[string, string](stipple_stream, "\t\%lw23s%\t\%s%\n\", item.stipple_name, item.stipple_comment) index :+= 1 put@(" generate equal, print\n\", stipple_stream) put@("\n\", stipple_stream) if !(enumeration.exact_match) stipple_co_type :@= enumeration.stipple_co_type stipple_name :@= enumeration.stipple_name format@format1[string](stipple_stream, "define %s%\n\", stipple_co_type) put@(" external\n\", stipple_stream) put@("\n\", stipple_stream) format@format1[string](stipple_stream, "define %s%_helper\n\", stipple_co_type) put@(" record\n\", stipple_stream) format@format2[string, string](stipple_stream, "\t\c2stipple_convert table[%s%, %s%]\n\", stipple_co_type, stipple_name) put@("\t\initialized logical\n\", stipple_stream) put@(" generate allocate, erase, identical, print\n\", stipple_stream) put@("\n\", stipple_stream) procedure stipple_equal_generate@c_enumeration takes enumeration c_enumeration stipple_stream out_stream returns_nothing #: This procedure will output the equal procedure for the C enumeration #, co-type associated with {enumeration} to {stipple_stream}. stipple_co_type :@= enumeration.stipple_co_type format@format1[string](stipple_stream, "procedure equal@%s%\n\", stipple_co_type) put@(" takes\n\", stipple_stream) format@format1[string](stipple_stream, "\t\value1 %s%\n\", stipple_co_type) format@format1[string](stipple_stream, "\t\value2 %s%\n\", stipple_co_type) put@(" returns logical\n\", stipple_stream) put@("\n\", stipple_stream) put@(" #: This procedure will return {true} if {value1} equals\n\", stipple_stream) put@(" #, {value2} and {false} otherwise.\n\", stipple_stream) put@("\n\", stipple_stream) put@(" return unsigned_convert@(value1) = unsigned_convert@(value2)\n\", stipple_stream) put@("\n\", stipple_stream) put@("\n\", stipple_stream) procedure stipple_hash_generate@c_enumeration takes enumeration c_enumeration stipple_stream out_stream returns_nothing #: This procedure will output the hash procedure for the C enumeration #, co-type associated with {enumeration} to {stipple_stream}. stipple_co_type :@= enumeration.stipple_co_type format@format1[string](stipple_stream, "procedure hash@%s%\n\", stipple_co_type) put@(" takes\n\", stipple_stream) format@format1[string](stipple_stream, "\t\value %s%\n\", stipple_co_type) put@(" returns unsigned\n\", stipple_stream) put@("\n\", stipple_stream) put@(" #: This procedure returns a hash computed from {value}.\n\", stipple_stream) put@("\n\", stipple_stream) put@(" return unsigned_convert@(value)\n\", stipple_stream) put@("\n\", stipple_stream) put@("\n\", stipple_stream) procedure stipple_print_generate@c_enumeration takes enumeration c_enumeration stipple_stream out_stream returns_nothing #: This procedure will output a procedure for printing the C enumeration #, co-type associated with {enumeration} to {stipple_stream}. stipple_co_type :@= enumeration.stipple_co_type format@format1[string](stipple_stream, "procedure print@%s%\n\", stipple_co_type) put@(" takes\n\", stipple_stream) format@format1[string](stipple_stream, "\t\value %s%\n\", stipple_co_type) put@("\t\out_stream out_stream\n\", stipple_stream) put@(" returns_nothing\n\", stipple_stream) put@("\n\", stipple_stream) put@(" #: This procedure will print {value} to {out_stream}.\n\", stipple_stream) put@("\n\", stipple_stream) put@(" name :@= \q,q,n\", stipple_stream) format@format1[string](stipple_stream, " switch %s%_convert@(value)\n\", enumeration.stipple_name) items :@= enumeration.items size :@= items.size index :@= 0 loop while index < size item :@= items[index] format@format1[string](stipple_stream, "\t\case %s%\n\", item.stipple_name) format@format1[string](stipple_stream, "\t\ name := \q\%s%\q,n\", item.c_name) index :+= 1 put@(" put@(name, out_stream)\n\", stipple_stream) put@("\n\", stipple_stream) put@("\n\", stipple_stream) procedure stipple_unsigned_convert_generate@c_enumeration takes enumeration c_enumeration stipple_stream out_stream returns_nothing #: This procedure will output the {unsigned_convert} declaration for #, the C enumeration co-type associated with {enumeration} to #, {stipple_stream}. stipple_co_type :@= enumeration.stipple_co_type format@format1[string](stipple_stream, "procedure unsigned_convert@%s%\n\", stipple_co_type) put@(" takes\n\", stipple_stream) format@format1[string](stipple_stream, "\t\value %s%\n\", stipple_co_type) put@(" returns unsigned\n\", stipple_stream) format@format1[string](stipple_stream, " external %s%__unsigned_convert\n\", stipple_co_type) put@("\n\", stipple_stream) put@(" #: This procedure will convert {value} into an {unsigned}.\n\", stipple_stream) put@("\n\", stipple_stream) put@("\n\", stipple_stream) #: {c_field} routines: procedure stipple_get_generate@c_field takes field c_field record c_record stipple_stream out_stream returns_nothing #: This procedure will output the STIPPLE procedure declaration for #, the for {field}_get procedure. format@format2[string, c_record](stipple_stream, "procedure %s%_get@%s%\n\", field.stipple_name, record) put@(" takes\n\", stipple_stream) format@format1[c_record](stipple_stream, "\t\record %s%\n\", record) format@format1[c_sub_type](stipple_stream, " returns %s%\n\", field.type) # FIXME: Should be one statement; not two (compiler bug): format@format1[c_record](stipple_stream, " external %s%__", record) format@format1[string](stipple_stream, "%s%_get\n\", field.stipple_name) put@("\n\", stipple_stream) format@format1[string](stipple_stream, " #: This procedure returns {record}.{%s%}.\n\", field.stipple_name) put@("\n\", stipple_stream) put@("\n\", stipple_stream) procedure stipple_set_generate@c_field takes field c_field record c_record stipple_stream out_stream returns_nothing #: This procedure will output the STIPPLE procedure declaration for #, the for {field}_set procedure. format@format2[string, c_record](stipple_stream, "procedure %s%_set@%s%\n\", field.stipple_name, record) put@(" takes\n\", stipple_stream) format@format1[c_record](stipple_stream, "\t\record %s%\n\", record) format@format1[c_sub_type](stipple_stream, "\t\value %s%\n\", field.type) put@(" returns_nothing\n\", stipple_stream) # FIXME: Should be one statement; not two (compiler bug): format@format1[c_record](stipple_stream, " external %s%__", record) format@format1[string](stipple_stream, "%s%_set\n\", field.stipple_name) put@("\n\", stipple_stream) format@format1[string](stipple_stream, " #: This procedure sets {record}.{%s%} to {value}.\n\", field.stipple_name) put@("\n\", stipple_stream) put@("\n\", stipple_stream) #: {c_import} routines: procedure c_generate@c_import takes c_import c_import c_stream out_stream returns_nothing #: This procedure will output the C code associated with {c_import} #, to {c_stream}. # Emit any #define directives: defines :@= c_import.defines size :@= defines.size index :@= 0 loop while index < size define :@= defines[index] format@format2[string, string](c_stream, "#define %s% %s%\n\", define.c_name, define.value) index :+= 1 # Emit any #include statements: includes :@= c_import.includes size :@= includes.size index :@= 0 less_than :@= "<"[0] loop while index < size include :@= includes[index] if include[0] = less_than format@format1[string](c_stream, "#include %s%\n\", include) else format@format1[string](c_stream, "#include %ds%\n\", include) index :+= 1 put@("\n\", c_stream) # Emit any structure declarations: records :@= c_import.records size :@= records.size index := 0 loop while index < size record :@= records[index] if !(record.external) c_struct_generate@(record, c_stream) index :+= 1 # Emit any enumeration initial objects: enumerations :@= c_import.enumerations size :@= enumerations.size index :@= 0 loop while index < size enumeration :@= enumerations[index] if !(enumeration.exact_match) c_initial_generate@(enumeration, c_stream) index :+= 1 # Emit any initial objects: size :@= records.size index := 0 loop while index < size record :@= records[index] if record.external format@format2[c_record, c_record](c_stream, "%t% %s%___initial;\n\", record, record) index :+= 1 put@("\n\", c_stream) # Emit the initialization routine: put@("void\n\", c_stream) format@format1[string](c_stream, "%s%__external__initialize(void)\n\", c_import.module_name) put@("{\n\", c_stream) put@("}\n\", c_stream) put@("\n\", c_stream) # Emit the enumeration routines: size := enumerations.size index := 0 loop while index < size enumeration :@= enumerations[index] if !(enumeration.exact_match) c_initialize_generate@(enumeration, c_stream) c_value_get_generate@(enumeration, c_stream) c_unsigned_convert_generate@(enumeration, c_stream) index :+= 1 # Emit the get/set/new/print routines: size := records.size index := 0 loop while index < size record :@= records[index] if record.generate_print c_print_generate@(record, c_stream) if record.generate_new c_allocate_generate@(record, c_stream) if record.external c_get_set_generate@(record, c_stream) index :+= 1 # Emit the main routine enclosed in #ifdef VERIFY: put@("#ifdef VERIFY\n\", c_stream) put@("#include \n\", c_stream) put@("#include \n\", c_stream) put@("\n\", c_stream) put@("int\n\", c_stream) put@("main(void)\n\", c_stream) put@("{\n\", c_stream) # Verify that the field offsets match: size :@= records.size index :@= 0 loop while index < size record :@= records[index] if !(record.external) c_offset_verify_generate@(record, c_stream) index :+= 1 # Wrap up the main routine and return: put@("\t\return 0;\n\", c_stream) put@("}\n\", c_stream) put@("#endif /* VERIFY */\n\", c_stream) put@("\n\", c_stream) procedure create@c_import takes module_name string returns c_import #: This procedure will create and return a {c_import} object #, with a module name of {module_name}. type_character :@= allocate@c_sub_type() type_character.character := nil type_integer :@= allocate@c_sub_type() type_integer.integer := nil type_logical :@= allocate@c_sub_type() type_logical.logical := nil type_short_integer :@= allocate@c_sub_type() type_short_integer.short_integer := nil type_short_unsigned :@= allocate@c_sub_type() type_short_unsigned.short_integer := nil type_string :@= allocate@c_sub_type() type_string.string := nil type_unsigned :@= allocate@c_sub_type() type_unsigned.unsigned := nil initialize c_import:: c_import := allocate@c_import() c_import.defines := allocate@vector[c_define]() c_import.enumerations := allocate@vector[c_enumeration]() c_import.import_logical := false c_import.import_out_stream := false c_import.import_string := false c_import.import_system := false c_import.import_table := false c_import.imports := allocate@vector[string]() c_import.includes := allocate@vector[string]() c_import.include_paths := allocate@vector[string]() c_import.module_name := module_name c_import.records := allocate@vector[c_record]() c_import.type_character := type_character c_import.type_integer := type_integer c_import.type_logical := type_logical c_import.type_short_integer := type_short_integer c_import.type_short_unsigned := type_short_unsigned c_import.type_string := type_string c_import.type_unsigned := type_unsigned return c_import procedure define_append@c_import takes c_import c_import c_name string value string returns_nothing #: This procedure will append a #define directive the the #define #, directive list in {c_import}. THe #define will have a name of #, {c_name} and a value of {value}. initialize c_define:: c_define := allocate@c_define() c_define.c_name := c_name c_define.value := value append@(c_import.defines, c_define) procedure import_append@c_import takes c_import c_import import_name string returns_nothing #: This procedure will add {import_name} to the imports list in {c_import}. if import_name = "logical" c_import.import_logical := true else_if import_name = "out_stream" c_import.import_out_stream := true else_if import_name = "string" c_import.import_string := true else_if import_name = "system" c_import.import_system := true else_if import_name = "table" c_import.import_table := true else append@(c_import.imports, import_name) procedure import_standard@c_import takes c_import c_import returns_nothing #: This procedure will append a bunch of standard modules to imports list #, {c_import}. import_append@(c_import, "string") import_append@(c_import, "out_stream") import_append@(c_import, "unsigned") procedure include_append@c_import takes c_import c_import include_name string returns_nothing #: This procedure will append {include_name} to the inlcude list in #, {c_import}. In ANSI-C, there are two syntaxes for include statements -- #, file names enclosed in double quotes and file names enclosed in #, angle brackets. An angle bracket include file is specified by #, making the first and last character of {include_name} be "<" and #, ">", respectively; otherwise the include name will be enclosed #, in double quotes. It is incorrect to add double quotes to #, {include_name}. append@(c_import.includes, include_name) procedure include_path_append@c_import takes c_import c_import include_path string returns_nothing #: This procedure will append {include_path} to the include directory #, path list in {c_import}. append@(c_import.include_paths, include_path) procedure procedure0_append@c_import takes c_import c_import c_name string stipple_name string stipple_type string return_type c_sub_type comment string returns_nothing #: This procedure will ... assert false procedure procedure1_append@c_import takes c_import c_import c_name string stipple_name string stipple_type string return_type c_sub_type argument1_name string argument1_type c_sub_type comment string returns_nothing #: This procedure will ... assert false procedure procedure2_append@c_import takes c_import c_import c_name string stipple_name string stipple_type string return_type c_sub_type argument1_name string argument1_type c_sub_type argument2_name string argument2_type c_sub_type comment string returns_nothing #: This procedure will ... assert false procedure process@c_import takes c_import c_import program_name string system system returns logical #: This procedure will process any command line options in {system} and #, output any files requested by the options using {c_import}. {true} #, is returned if there are any errors; otherwise, {false} is returned. # Parse the options: error_stream :@= system.error_out_stream command_parse :@= create@command_parse[c_options](program_name) option_logical@(command_parse, '-c', 'Produce a C file', c_generate_set@c_options) option_logical@(command_parse, '-s', 'Produce a STIPPLE file', stipple_generate_set@c_options) option_argument_optional@(command_parse, '-o ', 'Store output into ', output_file_name_set@c_options) options :@= parse@(command_parse, system.arguments, error_stream, true, true) # Check the options: c_generate :@= options.c_generate stipple_generate :@= options.stipple_generate if c_generate && stipple_generate put@('Specify either -c or -s, but not both!\n\', error_stream) return true if !c_generate && !stipple_generate put@('Either -c or -s must be specified!\n\', error_stream) return true # Prepare the output stream: out_stream:: out_stream := system.standard_out_stream do_close:: logical := false output_file_name :@= options.output_file_name if output_file_name != "" out_stream :@= open@out_stream(output_file_name) if !(out_stream.is_open) format@format1[string](error_stream, 'Could not open %ds% for writing!\n\', output_file_name) return true do_close := true # Do the work: if c_generate c_generate@(c_import, out_stream) else_if stipple_generate stipple_generate@(c_import, out_stream) # Wrate everything up: if do_close close@(out_stream) return false procedure stipple_generate@c_import takes c_import c_import stipple_stream out_stream returns_nothing #: This procedure will output the C code associated with {c_import} #, to {stipple_stream}. put@("english\n\", stipple_stream) put@("version \q\1.0\q,n\", stipple_stream) put@("\n\", stipple_stream) format@format1[string](stipple_stream, "module %s%\n\", c_import.module_name) put@("\n\", stipple_stream) # Output the import list: put@("import\n\", stipple_stream) imports :@= c_import.imports size :@= imports.size index :@= 0 loop while index < size import :@= imports[index] format@format1[string](stipple_stream, " %s%\n\", import) index :+= 1 if c_import.import_logical put@(" logical\n\", stipple_stream) if c_import.import_out_stream put@(" out_stream\n\", stipple_stream) if c_import.import_string put@(" string\n\", stipple_stream) if c_import.import_system put@(" system\n\", stipple_stream) if c_import.import_table put@(" table\n\", stipple_stream) put@("\n\", stipple_stream) # Emit any enumeration declarations: enumerations :@= c_import.enumerations size := enumerations.size index := 0 loop while index < size enumeration :@= enumerations[index] stipple_define_generate@(enumeration, stipple_stream) index :+= 1 # Emit any enumeration procedures: size := enumerations.size index := 0 loop while index < size enumeration :@= enumerations[index] if !(enumeration.exact_match) stipple_convert_generate@(enumeration, stipple_stream) stipple_equal_generate@(enumeration, stipple_stream) stipple_hash_generate@(enumeration, stipple_stream) stipple_print_generate@(enumeration, stipple_stream) stipple_unsigned_convert_generate@(enumeration, stipple_stream) index :+= 1 # Emit any record declarations: records :@= c_import.records size := records.size index := 0 loop while index < size record :@= records[index] stipple_define_generate@(record, stipple_stream) index :+= 1 put@("\n\", stipple_stream) # Emit the get/set routine definitions: size := records.size index := 0 loop while index < size record :@= records[index] if record.external fields :@= record.fields fields_size :@= fields.size fields_index :@= 0 loop while fields_index < fields_size field :@= fields[fields_index] if field.generate_get stipple_get_generate@(field, record, stipple_stream) if field.generate_set stipple_set_generate@(field, record, stipple_stream) fields_index :+= 1 # Emit an empty procedure to work around a compiler bug: format@format1[c_record](stipple_stream, "procedure zilch@%s%\n\", record) put@(" takes_nothing\n\", stipple_stream) put@(" returns_nothing\n\", stipple_stream) put@("\n\", stipple_stream) put@(" #: This procedure works around a compiler bug.\n\", stipple_stream) put@("\n\", stipple_stream) index :+= 1 #: {c_record} routines: procedure c_get_set_generate@c_record takes record c_record c_stream out_stream returns_nothing #: This procedure will generate the C get/set procedure declarations #, for each field in {record} and output them to {c_stream}. fields :@= record.fields size :@= fields.size index :@= 0 loop while index < size field :@= fields[index] if field.generate_get format@format1[c_sub_type](c_stream, "%c%\n\", field.type) format@format2[string, string](c_stream, "%s%__%s%_get(\n\", record.stipple_name, field.stipple_name) format@format1[c_record](c_stream, "\t\%t% record___pointer)\n\", record) put@("{\n\", c_stream) format@format1[string](c_stream, "\t\return record___pointer->%s%;\n\", field.c_name) put@("}\n\", c_stream) put@("\n\", c_stream) if field.generate_set put@("void\n\", c_stream) format@format2[string, string](c_stream, "%s%__%s%_set(\n\", record.stipple_name, field.stipple_name) format@format1[c_record](c_stream, "\t\%t% record___pointer,\n\", record) format@format1[c_sub_type](c_stream, "\t\%c% new___value)\n\", field.type) put@("{\n\", c_stream) format@format1[string](c_stream, "\t\record___pointer->%s% = new___value;\n\", field.c_name) put@("}\n\", c_stream) put@("\n\", c_stream) index :+= 1 procedure c_allocate_generate@c_record takes record c_record c_stream out_stream returns_nothing #: This procedure will generate the C allocation routine for {record} #, and output it to {c_stream}. format@format1[c_record](c_stream, "%t%\n\", record) format@format1[c_record](c_stream, "%c%__allocate()\n\", record) put@("{\n\", c_stream) format@format1[c_record](c_stream, "\t\%t% new;\n\", record) put@("\t\extern void *malloc(void *);\n\", c_stream) put@("\n\", c_stream) format@format1[c_record](c_stream, "\t\new = (%t%)malloc(sizeof *new);\n\", record) put@("\t\return new;\n\", c_stream) put@("}\n\", c_stream) put@("\n\", c_stream) procedure c_offset_verify_generate@c_record takes record c_record c_stream out_stream returns_nothing #: This procedure will output verification code to {c_stream} that will #, verify that each field in the C version of {record} has the exact #, same offset as the the STIPPLE version of {record}. c_name :@= record.c_name stipple_name :@= record.stipple_name format@format2[string, string](c_stream, "\t\assert(sizeof(struct %s%) == sizeof(struct %s%));\n\", c_name, stipple_name) fields :@= record.fields size :@= fields.size index :@= 0 loop while index < size field :@= fields[index] format@format4[string, string, string, string](c_stream, "\t\assert(offsetof(%s%, %s%) == offsetof(%s%, %s%));\n\", c_name, field.c_name, stipple_name, field.stipple_name) index :+= 1 put@("\n\", c_stream) procedure c_print_generate@c_record takes record c_record c_stream out_stream returns_nothing #: This procedure will generate the C print routine for {record} #, and output it to {c_stream}. put@("void\n\", c_stream) format@format1[c_record](c_stream, "%c%__print(){}\n\", record) put@("\n\", c_stream) procedure c_struct_generate@c_record takes record c_record c_stream out_stream returns_nothing #: This procedure will output the C structure for {record} to {c_stream}. format@format1[string](c_stream, "struct %s% {\n\", record.stipple_name) fields :@= record.fields size :@= fields.size index :@= 0 loop while index < size field :@= fields[index] format@format2[c_sub_type, string](c_stream, "\t\%s% %s%;\n\", field.type, field.c_name) index :+= 1 put@("};\n\", c_stream) put@("\n\", c_stream) procedure enumeration_create@c_import takes c_import c_import kind c_kind c_name string stipple_name string stipple_comment string stipple_co_type string returns c_enumeration #: This procedure will create and return a {c_enumeration} object #, allocated from {c_import}. The C type name will be {c_name} #, and be of {kind} {enum}, {typedef_eum}, or {defines}. There will #, be either one or two STIPPLE types depending upon whether there #, is an exact match between the STIPPLE item values and the C item #, values. If there is an exact match of item values, the C enum type #, is indistinguishable from the STIPPLE enumeration type and only #, one STIPPLE type is needed. The one type case is specified by #, having {stipple_co_type} be the empty string. Conversely, if the #, item values do not exactly match, two STIPPLE types are needed. #, One type represents the C enum values ({stipple_co_type}) and the #, other type represents the the enumeration value after it has been #, converted to the {stipple_name} type. exact_match :@= (stipple_co_type = "") if !exact_match c_import.import_logical := true c_import.import_out_stream := true c_import.import_string := true c_import.import_system := true c_import.import_table := true # Make sure that the right kind has come in. switch kind case enum, typedef_enum, defines kind := kind #: FIXME: do_nothing default assert false initialize enumeration:: c_enumeration := allocate@c_enumeration() enumeration.c_name := c_name enumeration.exact_match := exact_match enumeration.kind := kind enumeration.items := allocate@vector[c_bind]() enumeration.stipple_co_type := stipple_co_type enumeration.stipple_name := stipple_name enumeration.stipple_comment := stipple_comment append@(c_import.enumerations, enumeration) return enumeration procedure format@c_record takes record c_record out_stream out_stream format string offset unsigned returns_nothing #: This procedure will output {record} to {out_stream}. chr :@= format[offset] if chr = "s"[0] put@(record.stipple_name, out_stream) else_if chr = "c"[0] put@(record.c_name, out_stream) else_if chr = "t"[0] switch record.kind case struct format@format1[string](out_stream, "struct %s% *", record.c_name) case typedef_struct format@format1[string](out_stream, "%s% *", record.c_name) case typedef_struct_pointer put@(record.c_name, out_stream) default assert false procedure record_create@c_import takes c_import c_import kind c_kind c_name string stipple_name string stipple_comment string external logical generate_print logical generate_new logical returns c_record #: This procedure will create and return a {c_record} object allocated #, from {c_import} of type {kind}. The struct name in the ANSI-C code #, will be {c_name} and the record name in STIPPLE will be #, {stipple}. If {stipple_comment} is not empty and starts with #, a "#" character, {stipple_comment} will be appended as a comment #, to the end of {define} clause. If {external} is {true}, all #, accesses to the C structure are done through get and set procedures; #, otherwise, if {external} is {false}, both the order and size #, of the field names in the C struct exactly match corresponding #, field names in the STIPPLE record. If {generate_print} is {true} #, a print procedure is generated. If {generate_new} is {true} an #, allocation procedure is generated. initialize record:: c_record := allocate@c_record() record.c_name := c_name record.external := external record.fields := allocate@vector[c_field]() record.generate_print := generate_print record.generate_new := generate_new record.kind := kind record.stipple_comment := stipple_comment record.stipple_name := stipple_name append@(c_import.records, record) return record procedure field_append@c_record takes record c_record c_name string c_sub_type c_sub_type stipple_name string stipple_comment string generate_get logical generate_set logical returns_nothing #: This procedure will add a field to {record} with a ANSI-C name #, of {c_name} and an ANSI-C type extracted from {c_sub_type}. The #, corresponding field name in the STIPPLE code will be {stipple_name}. #, If {stipple_name} is empty, {c_name} is used in its stead. #, If the first character in {stipple_comment} is a "#", {stipple_comment} #, will be output immediately after the field name in the STIPPLE code. #, If {generate_get} is {true}, a get routine will be generated. #, If {generate_set} is {true}, a set routine will be generated. if stipple_name = "" stipple_name := c_name initialize field:: c_field := allocate@c_field() field.c_name := c_name field.type := c_sub_type field.stipple_name := stipple_name field.stipple_comment := stipple_comment field.generate_get := generate_get field.generate_set := generate_set append@(record.fields, field) procedure stipple_define_generate@c_record takes record c_record stipple_stream out_stream returns_nothing #: This procedure will output the {define} declaration for {record} #, to {stipple_stream}. format@format1[string](stipple_stream, "define %s%\n\", record.stipple_name) if record.external put@(" external\n\", stipple_stream) else put@(" record\n\", stipple_stream) # Now emit each field: fields :@= record.fields size :@= fields.size index :@= 0 loop while index < size field :@= fields[index] format@format2[string, c_sub_type](stipple_stream, "\t\%s% %s%\n\", field.c_name, field.type) index :+= 1 put@(" generate allocate, erase, print\n\", stipple_stream) put@("\n\", stipple_stream) #: {c_sub_type} routines: procedure pointer_create@c_sub_type takes c_name string stipple_name string returns c_sub_type #: This procedure will create and return a {c_sub_type} containing #, the {c_name} to {stipple_name} binding. initialize bind:: c_bind := allocate@c_bind() bind.c_name := c_name bind.stipple_comment := "" bind.stipple_name := stipple_name c_sub_type :@= allocate@c_sub_type() c_sub_type.pointer := bind return c_sub_type procedure format@c_sub_type takes c_sub_type c_sub_type out_stream out_stream format string offset unsigned returns_nothing #: This procedure will output {c_sub_type} to {out_stream}. if format[offset] = "s"[0] extract c_sub_type tag character:: null := character put@("character", out_stream) tag integer:: null := integer put@("integer", out_stream) tag logical:: null := logical put@("logical", out_stream) tag opaque:: c_bind := opaque put@(opaque.stipple_name, out_stream) tag pointer:: c_bind := pointer put@(pointer.stipple_name, out_stream) tag short_integer:: null := short_integer put@("integer", out_stream) tag short_unsigned:: null := short_unsigned put@("unsigned", out_stream) tag string:: null := string put@("string", out_stream) tag unsigned:: null := unsigned put@("unsigned", out_stream) else extract c_sub_type tag character:: null := character put@("char", out_stream) tag integer:: null := integer put@("int", out_stream) tag logical:: null := logical put@("int", out_stream) tag opaque:: c_bind := opaque put@(opaque.c_name, out_stream) tag pointer:: c_bind := pointer format@format1[string](out_stream, "%s% *", pointer.c_name) tag short_integer:: null := short_integer put@("int", out_stream) tag short_unsigned:: null := short_unsigned put@("unsigned", out_stream) tag string:: null := string put@("char *", out_stream) tag unsigned:: null := unsigned put@("unsigned", out_stream)