#! /bin/sh # # part 1: The script renames a file with a name that is over 14 chars # and gives instructions how to run the patch program # # part 2: The rest of the file contains the patches required to upgrade # gpc-1.02 to gpc-1.03. Feed this file to the "patch" program as # instructed when you execute this file (with /bin/sh) # # Author: Juki # Date: Thu Jan 20 18:28:43 1994 # if [ ! -f gpc-parse.y ]; then echo "Please cd to the source directory of GPC distribution first" exit 1 fi cat << HERE_IS This patch kit updates your GPC 1.02 snapshot-1jan94 to the GPC 1.03 snapshot-20jan94. Do *not* apply this patch to any earlier gpc snapshot! You need Larry Wall's "patch" program to apply this patch. Please run the patch program as follows: patch -p0 < gpc-1jan-20jan.diff If you have not modified your sources, or installed other patches there should be no rejections, fuzzes or offsets when applying the patch hunks. After running this runme.first shell scipt and applying the patch file gpc-1jan-20jan.diff your gpc is identical with the complete Jan 20 snapshot in kampi.hut.fi. Juki jtv@hut.fi ps. After the patch program has successfully executed, you may want to remove the "*.orig" files where patch has saved the unmodified contents of the files. pps. If patch creates any ".rej" files, the patch did not succeed, which means that your snapshot was not an unmodified gpc snapshot from 1 Jan 1994. If so, you need to check manually that the context diff code in the "*.rej" files matches the code in the gpc source tree. HERE_IS if [ -f DOCONF.kampi ]; then echo "You don't need to run this script many times" exit 1 fi echo mv DOCONF.example.kampi DOCONF.kampi echo "Renamed file DOCONF.example.kampi to DOCONF.kampi" echo "Please apply to patch file to gpc now as specified." echo exit 0 Diffs between snapshot-1jan94 and snapshot-20jan94: *** 1.3 1993/10/29 00:05:17 --- DOCONF.example 1994/01/10 22:15:19 *************** *** 13,19 **** # GCC binaries and objects at HUT binary tree GCCBIN=../../gcc/${VERSION} ! SRC=`echo $0 | sed "s+/DOCONF.example++"` # Use automatic prefix rather than this --prefix=/v/mach3_i386/gnu/gcc/$VERSION sh ${SRC}/configure --gccs=${GCCSRC} --gccd=${GCCBIN} --- 13,19 ---- # GCC binaries and objects at HUT binary tree GCCBIN=../../gcc/${VERSION} ! SRC=`echo $0 | sed "s+/DOCONF\..*++"` # Use automatic prefix rather than this --prefix=/v/mach3_i386/gnu/gcc/$VERSION sh ${SRC}/configure --gccs=${GCCSRC} --gccd=${GCCBIN} *** 1.3 1993/11/14 19:33:51 --- DOCONF.kampi 1994/01/10 22:14:33 *************** *** 13,19 **** # GCC binaries and objects at HUT binary tree GCCBIN=../gcc-${VERSION} ! SRC=`echo $0 | sed "s+/DOCONF.example.*++"` # Use automatic prefix rather than this --prefix=/v/mach3_i386/gnu/gcc/$VERSION sh ${SRC}/configure --gccs=${GCCSRC} --gccd=${GCCBIN} --- 13,19 ---- # GCC binaries and objects at HUT binary tree GCCBIN=../gcc-${VERSION} ! SRC=`echo $0 | sed "s+/DOCONF\..*++"` # Use automatic prefix rather than this --prefix=/v/mach3_i386/gnu/gcc/$VERSION sh ${SRC}/configure --gccs=${GCCSRC} --gccd=${GCCBIN} *** 1.39 1994/01/01 20:10:52 --- GPC.GUIDE 1994/01/20 09:30:29 *************** *** 1,4 **** ! Last modified: Sat Jan 1 22:10:16 1994 /* Copyright (C) 1993 Free Software Foundation, Inc. --- 1,4 ---- ! Last modified: Thu Jan 20 11:30:47 1994 /* Copyright (C) 1993 Free Software Foundation, Inc. *************** *** 20,26 **** Author: Juki ! Gpc version 1.02 (2.5.7) Notes On GNU Pascal (GPC) --- 20,26 ---- Author: Juki ! Gpc version 1.03 (2.5.7) Notes On GNU Pascal (GPC) *************** *** 47,53 **** programming tasks without learning a completely different language. GNU Pascal compiler is part of the GNU Compiler family ! combining a language independed part of the GNU Compiler with a Pascal specific front end. Other compilers of the family currently include compilers for --- 47,53 ---- programming tasks without learning a completely different language. GNU Pascal compiler is part of the GNU Compiler family ! combining a language independent part of the GNU Compiler with a Pascal specific front end. Other compilers of the family currently include compilers for *************** *** 59,65 **** Pascal is a well-known programming language and hardly needs to be described here. Notice, however, that some people's idea of ! Pascal is affected by acquintance with such products as Turbo Pascal which differ from the Pascal standard and provide a lot of nonstandard extensions (some of which are compatible with the Extended Pascal standard). Moreover, it is worth mentioning --- 59,65 ---- Pascal is a well-known programming language and hardly needs to be described here. Notice, however, that some people's idea of ! Pascal is affected by acquaintance with such products as Turbo Pascal which differ from the Pascal standard and provide a lot of nonstandard extensions (some of which are compatible with the Extended Pascal standard). Moreover, it is worth mentioning *************** *** 92,98 **** standard yet, but they will be checked and developed with the aim of full conformance, plus some extensions to Extended Pascal. ! Unfortunately, the current version still contains deviances from the Pascal standard, so GNU Pascal is not yet a valid Pascal compiler, but not very far from it. The biggest problems are: --- 92,98 ---- standard yet, but they will be checked and developed with the aim of full conformance, plus some extensions to Extended Pascal. ! Unfortunately, the current version still contains deviations from the Pascal standard, so GNU Pascal is not yet a valid Pascal compiler, but not very far from it. The biggest problems are: *************** *** 153,158 **** --- 153,162 ---- ----- For this snapshot: + I did not notice that E.P. syntax for EXPORT-clauses requires + an equal sign after the export-identifier. This gpc snapshot + gives a warning if the '=' is not present. + EOLN is not implicitely set when reset(input) is done. If I have to use constructs that affect the syntax of the language *************** *** 164,180 **** is no longer a "reserved" word; to compile routines inline, use __inline__ instead.) - Completely untested new features (done 1.1.94 in a hurry :-) - The __cstring__ formal parameter type should convert a VALUE string-type parameter (not a char_type) to a pointer and pass that. If the actual parameter is a string schema, the address of the character array is passed, not the address of the schema object. Use with care. ! If a formal parameter is of 'type voidptr = ^void;' any pointer ! value is accepted as the actual parameter. Use with care. EXTENSIONS TO ISO-7185 PASCAL LANGUAGE: --------------------------------------- --- 168,186 ---- is no longer a "reserved" word; to compile routines inline, use __inline__ instead.) The __cstring__ formal parameter type should convert a VALUE string-type parameter (not a char_type) to a pointer and pass that. If the actual parameter is a string schema, the address of the character array is passed, not the address of the schema object. Use with care. ! If a formal parameter is a pointer to a VOID type, e.g. ! ! type voidptr = ^void; + any pointer value is accepted as the actual parameter. + Use with care. + EXTENSIONS TO ISO-7185 PASCAL LANGUAGE: --------------------------------------- *************** *** 220,227 **** - short circuit logical operators (AND_THEN, OR_ELSE) - standard numeric input (ISO 6093) - string and char values are compatible ! - string functions (trim,substr,index,length) - string comparisons with and without padding - string schema (variable length strings) - string schema discriminant 'Capacity' dynamically set with NEW - type inquiry --- 226,234 ---- - short circuit logical operators (AND_THEN, OR_ELSE) - standard numeric input (ISO 6093) - string and char values are compatible ! - string catenations with "+" - string comparisons with and without padding + - string functions (trim,substr,index,length) - string schema (variable length strings) - string schema discriminant 'Capacity' dynamically set with NEW - type inquiry *************** *** 254,260 **** EXTENDED PASCAL FEATURES STILL MISSING FROM GPC: ------------------------------------------------ - - string catenation with "+" - set member iteration (FOR ch IN [ 'a'..'z','0'..'9' ] DO...) - set types with variable bounds - substring variables (str[5..7] := 'foo';) --- 261,266 ---- *************** *** 335,340 **** --- 341,349 ---- "string" contains the chars in the string. + The "string" and "length" fields can not be directly referenced + by a user program. + References to the schema discriminants are allowed, and the WITH statement is also allowed, so one can say: *************** *** 834,840 **** MODULE foobar Interface; (* INTERFACE *) ! EXPORT catch22 (footype,setfoo,getfoo); TYPE footype = integer; --- 843,849 ---- MODULE foobar Interface; (* INTERFACE *) ! EXPORT catch22 = (footype,setfoo,getfoo); TYPE footype = integer; *************** *** 886,892 **** MODULE foobar; (* ALTERNATIVE METHOD *) ! EXPORT catch22 (footype,setfoo,getfoo); TYPE footype = integer; --- 895,901 ---- MODULE foobar; (* ALTERNATIVE METHOD *) ! EXPORT catch22 = (footype,setfoo,getfoo); TYPE footype = integer; *************** *** 1108,1113 **** --- 1117,1148 ---- end. + STRING CATENATION: + ------------------ + + Gpc supports string catenation with the '+' operator. + All string-types are compatible, so you may catenate any chars, + fixed length strings and variable length strings with each other. + + program scat (input, output); + + var + ch : char; + str : string(100); + str2 : string(50); + fstr : packed array [ 1 .. 20 ] of char; + + begin + ch := '$'; + fstr := 'demo'; { padded with blanks } + write ('Give me some chars to play with: '); + readln (str); + str := '^' + 'prefix:' + str + ':suffix:' + fstr + ch; + writeln ('Len' + 'gth = ', length (str)); + writeln (str); + end. + + TYPE QUALIFIERS: ---------------- *************** *** 1185,1191 **** MODULE command_line interface; ! EXPORT cmdline (Max_length, Arg_type, ParamStr, ParamCount); CONST Max_length = 255; { Max length of each argument. --- 1220,1226 ---- MODULE command_line interface; ! EXPORT cmdline = (Max_length, Arg_type, ParamStr, ParamCount); CONST Max_length = 255; { Max length of each argument. *** 1.20 1994/01/01 20:31:11 --- Makefile.in 1994/01/20 17:59:39 *************** *** 23,29 **** # of GCC $(gccsrc) to the directory $(gccdir), which should contain # necessary object files ! GPCVERSION=1.02 # GPC source directory # configure can change this --- 23,29 ---- # of GCC $(gccsrc) to the directory $(gccdir), which should contain # necessary object files ! GPCVERSION=1.03 # GPC source directory # configure can change this *************** *** 302,308 **** #gpc-gperf.c: $(srcdir)/gpc-gperf.c rts/Makefile: $(srcdir)/rts/Makefile ! -mkdir rts cp $(srcdir)/rts/Makefile rts/Makefile -ln -s $(srcdir) srcdir -ln -s $(gccsrc) gccsrc --- 302,308 ---- #gpc-gperf.c: $(srcdir)/gpc-gperf.c rts/Makefile: $(srcdir)/rts/Makefile ! -if [ ! -d rts ]; then mkdir rts; else; true; fi cp $(srcdir)/rts/Makefile rts/Makefile -ln -s $(srcdir) srcdir -ln -s $(gccsrc) gccsrc *************** *** 322,328 **** $(rts)/rts-readsub.c $(rts)/rts-bind.c library: - -mkdir rts cd rts ; $(MAKE) CC="$(RTS_GCC)" RTSFLAGS="$(COMMON_CFLAGS)" library-clean: --- 322,327 ---- *** 1.2 1993/11/03 23:23:23 --- configure 1994/01/10 22:26:28 *************** *** 257,263 **** cd $p # Copy run time system Makefile.in ! mkdir rts cat $srcdir/rts/Makefile.in | \ sed -e "s@^CC =.*@CC = $cdir/xgcc@" > rts/Makefile --- 257,263 ---- cd $p # Copy run time system Makefile.in ! if [ ! -d rts ]; then mkdir rts; fi cat $srcdir/rts/Makefile.in | \ sed -e "s@^CC =.*@CC = $cdir/xgcc@" > rts/Makefile *** 1.9 1993/12/15 21:42:38 --- expr.c 1994/01/20 02:33:53 *************** *** 1885,1896 **** #ifdef GPC /* ! * Pad the STRING with BYTES spaces. */ void ! emit_string_pad (string, bytes) rtx string; ! rtx bytes; { rtx loop = gen_label_rtx (); rtx done = gen_label_rtx (); --- 1885,1897 ---- #ifdef GPC /* ! * Pad the STRING with COUNT bytes of PAD. */ void ! emit_string_pad (string, count, pad) rtx string; ! rtx count; ! int pad; { rtx loop = gen_label_rtx (); rtx done = gen_label_rtx (); *************** *** 1898,1906 **** rtx last; rtx temp; NO_DEFER_POP; emit_move_insn (ptr, string); ! last = expand_binop (Pmode, add_optab, ptr, bytes, NULL_RTX, 0, OPTAB_LIB_WIDEN); emit_label (loop); --- 1899,1910 ---- rtx last; rtx temp; + if (count == const0_rtx) + return; + NO_DEFER_POP; emit_move_insn (ptr, string); ! last = expand_binop (Pmode, add_optab, ptr, count, NULL_RTX, 0, OPTAB_LIB_WIDEN); emit_label (loop); *************** *** 1908,1914 **** emit_cmp_insn (ptr, last, GTU, NULL_RTX, Pmode, 0, 0); emit_jump_insn (gen_bgtu (done)); ! emit_move_insn (gen_rtx (MEM, QImode, ptr), GEN_INT (' ')); temp = expand_binop (Pmode, add_optab, ptr, const1_rtx, ptr, 0, OPTAB_LIB_WIDEN); --- 1912,1918 ---- emit_cmp_insn (ptr, last, GTU, NULL_RTX, Pmode, 0, 0); emit_jump_insn (gen_bgtu (done)); ! emit_move_insn (gen_rtx (MEM, QImode, ptr), GEN_INT (pad & 0xff)); temp = expand_binop (Pmode, add_optab, ptr, const1_rtx, ptr, 0, OPTAB_LIB_WIDEN); *** 1.10 1993/12/30 23:16:05 --- gpc-common.c 1994/01/20 08:46:15 *************** *** 1362,1367 **** --- 1362,1370 ---- 1); } + if (TREE_CODE (exp1) == FUNCTION_DECL) + exp1 = probably_call_function (exp1); + t1 = TREE_CODE (TREE_TYPE (exp1)); /* Convert a set constructor to a set modelled after exp1 if that *************** *** 1377,1382 **** --- 1380,1388 ---- 1); } + if (TREE_CODE (exp2) == FUNCTION_DECL) + exp2 = probably_call_function (exp2); + t2 = TREE_CODE (TREE_TYPE (exp2)); if (t1 == ERROR_MARK || t2 == ERROR_MARK) *************** *** 1396,1404 **** return build_binary_op (IN_EXPR, exp2, exp1, 0); /* All string and char types are compatible in Extended Pascal */ ! if (is_string_type (exp1) ! && is_string_type (exp2) && (TREE_TYPE (exp1) != TREE_TYPE (exp2) || is_variable_string_type (TREE_TYPE (exp1)) || is_variable_string_type (TREE_TYPE (exp2)))) { --- 1402,1411 ---- return build_binary_op (IN_EXPR, exp2, exp1, 0); /* All string and char types are compatible in Extended Pascal */ ! if ((is_string_type (exp1) || t1 == CHAR_TYPE) ! && (is_string_type (exp2) || t2 == CHAR_TYPE) && (TREE_TYPE (exp1) != TREE_TYPE (exp2) + || code == PLUS_EXPR || is_variable_string_type (TREE_TYPE (exp1)) || is_variable_string_type (TREE_TYPE (exp2)))) { *************** *** 1420,1425 **** --- 1427,1486 ---- chainon (build_tree_list (NULL_TREE, exp1), build_tree_list (NULL_TREE, exp2))); } + + /* All string catenations are handled here */ + if (code == PLUS_EXPR) + { + /* Length of the combined strings */ + tree len1 = PASCAL_STRING_LENGTH (exp1); + tree len2 = PASCAL_STRING_LENGTH (exp2); + tree length = build_binary_op (PLUS_EXPR, len1, len2, 0); + + /* Create a new schema type that can hold both strings */ + tree ntype = build_pascal_string_schema (length); + + /* Create a new string object */ + tree nstr = make_new_variable ("GPC_STR_CAT", ntype); + tree sval = PASCAL_STRING_VALUE (nstr); + tree str_addr = build_unary_op (ADDR_EXPR, sval, 0); + + /* Assign the first string to the new object */ + if (t1 == CHAR_TYPE) + expand_expr_stmt + (build_modify_expr (build_array_ref (sval, integer_one_node), + NOP_EXPR, + exp1)); + else + emit_string_move (str_addr, + build1 (ADDR_EXPR, + string_type_node, + PASCAL_STRING_VALUE (exp1)), + len1); + + /* Catenate the second string to the first */ + if (t2 == CHAR_TYPE) + expand_expr_stmt + (build_modify_expr (build_array_ref (sval, + build_binary_op (PLUS_EXPR, + len1, + integer_one_node, + 0)), + NOP_EXPR, + exp2)); + else + emit_string_move (build (PLUS_EXPR, string_type_node, str_addr, len1, 0), + build1(ADDR_EXPR, + string_type_node, + PASCAL_STRING_VALUE (exp2)), + len2); + + /* Save the combined length of strings */ + expand_expr_stmt + (build_modify_expr (PASCAL_STRING_LENGTH (nstr), + NOP_EXPR, + length)); + return nstr; + } } if ((t1 == SET_TYPE || t1 == CONSTRUCTOR) *************** *** 1467,1472 **** --- 1528,1536 ---- { if (PASCAL_TYPE_RESTRICTED (TREE_TYPE (xarg))) error ("Illegal unary operation with restricted type"); + + if (TREE_CODE (xarg) == FUNCTION_DECL) + xarg = probably_call_function (xarg); return build_unary_op (code, xarg, noconvert); } *** 1.16 1993/12/19 07:17:03 --- gpc-decl.c 1994/01/14 19:13:05 *************** *** 6346,6353 **** --- 6346,6360 ---- if (temp && temp->directive) { tree args = TREE_OPERAND (heading, 1); + #if 0 + /* This must not warn about declarations in the + * inner level -> disabled. (@@@ Should check if + * the name is found at the same binding level + * than this definition is going to) + */ if (temp->directive != get_identifier ("Forward")) warning ("Wrong directive specified -- `Forward' assumed"); + #endif if (pedantic) { *** 1.19 1994/01/01 20:19:02 --- gpc-defs.h 1994/01/20 05:56:54 *************** *** 139,147 **** build_component_ref (decl, get_identifier ("string")) : \ decl) ! /* Each variable length string has a "current length" field. ! */ ! #define PASCAL_STRING_LENGTH(decl) build_component_ref (decl, get_identifier ("length")) /* Each variable length string has a "Capacity" field. */ --- 139,156 ---- build_component_ref (decl, get_identifier ("string")) : \ decl) ! /* Each variable length string has a "current length" field, ! * CHAR_TYPE length is always 1, ! * fixed-length-string length is the domain max value. ! */ ! #define PASCAL_STRING_LENGTH(decl) \ ! (PASCAL_TYPE_STRING(TREE_TYPE(decl)) ? \ ! build_component_ref (decl,get_identifier ("length")) : \ ! ((TREE_CODE (TREE_TYPE(decl)) == CHAR_TYPE) ? \ ! integer_one_node : \ ! ((TREE_CODE (decl) == STRING_CST) ? \ ! build_int_2 (TREE_STRING_LENGTH (decl) - 1, 0) : \ ! TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (decl)))))) /* Each variable length string has a "Capacity" field. */ *************** *** 338,343 **** --- 347,353 ---- */ tree convert_type_to_range PROTO((tree)); + tree probably_call_function PROTO((tree)); tree maybe_call_function PROTO((tree, tree)); int suspend_function_calls PROTO((void)); *************** *** 409,415 **** /* * Returns the base type of a SET_TYPE node TYPE */ ! extern tree set_base_type PROTO((tree)); extern tree get_identifier_with_blank PROTO((char *)); --- 419,425 ---- /* * Returns the base type of a SET_TYPE node TYPE */ ! extern tree base_type PROTO((tree)); extern tree get_identifier_with_blank PROTO((char *)); *** 1.31 1994/01/01 20:18:36 --- gpc-parse.y 1994/01/11 22:38:07 *************** *** 1229,1242 **** */ subrange_type : constant TWODOTS expression ! { if (pedantic && ! TREE_CONSTANT ($3)) warning ("ISO Pascal does not allow non-constant range bounds\n"); if (TREE_TYPE ($1) != TREE_TYPE ($3)) { error ("subrange bounds are not of the same type"); $$ = error_mark_node; ! } ! /* @@@ Changed in 2.4.3.1 */ ! $$ = build_range_type (TREE_TYPE ($1), $1, $3); } ; --- 1229,1242 ---- */ subrange_type : constant TWODOTS expression ! { if (pedantic && (! TREE_CONSTANT ($3) || ! TREE_CONSTANT ($1))) warning ("ISO Pascal does not allow non-constant range bounds\n"); if (TREE_TYPE ($1) != TREE_TYPE ($3)) { error ("subrange bounds are not of the same type"); $$ = error_mark_node; ! } else ! /* @@@ Changed in 2.4.3.1 */ ! $$ = build_range_type (TREE_TYPE ($1), $1, $3); } ; *************** *** 2515,2526 **** FUNCTION_TYPE)) target = maybe_call_function (target, NULL_TREE); ! if (TREE_CODE (target) != CALL_EXPR) ! warning ("Expression used as a statement -- value is ignored"); ! else if (TREE_TYPE (target) != void_type_node) ! warning ("Function call as a statement -- value is ignored"); ! ! expand_expr_stmt (target); } else { --- 2515,2529 ---- FUNCTION_TYPE)) target = maybe_call_function (target, NULL_TREE); ! if (target != error_mark_node) ! { ! if (TREE_CODE (target) != CALL_EXPR) ! warning ("Expression used as a statement -- value is ignored"); ! else if (TREE_TYPE (target) != void_type_node) ! warning ("Function call as a statement -- value is ignored"); ! ! expand_expr_stmt (target); ! } } else { *************** *** 3635,3642 **** ; export_part : ! new_identifier '(' export_list ')' ! { export_interface ($1, $3); } ; export_list : --- 3638,3652 ---- ; export_part : ! new_identifier optional_equal_sign '(' export_list ')' ! { export_interface ($1, $4); } ! ; ! ! optional_equal_sign : ! /* Empty */ ! { warning ("Missing '=' after export interface identifier"); } ! | '=' ! { } ; export_list : *************** *** 3698,3704 **** import_specification : new_identifier optional_access_qualifier optional_import_qualifier ! { import_interface ($1, $3, $2 != NULL_TREE); } ; optional_access_qualifier : --- 3708,3722 ---- import_specification : new_identifier optional_access_qualifier optional_import_qualifier ! { ! /* Recovering from an error if id is NULL_TREE ! * If $1 is NULL_TREE lastiddecl is one of the ! * predefined identifiers, but it does not matter ! * anymore. ! */ ! if ($1) ! import_interface ($1, $3, $2 != NULL_TREE); ! } ; optional_access_qualifier : *** 1.14 1994/01/01 20:20:42 --- gpc-typeck.c 1994/01/20 04:59:09 *************** *** 1869,1882 **** /* Convert the set constructor to the corresponding set type */ val = construct_set (val, type, 2); } ! else if (type && (PASCAL_TYPE_STRING (type) ! || (TREE_CODE (type) == REFERENCE_TYPE ! && PASCAL_TYPE_STRING (TREE_TYPE (type))))) { ! /* The formal parameter is a variable length string. ! */ int varparm = 0; int conforming; if (TREE_CODE (type) == REFERENCE_TYPE) varparm = 1; --- 1869,1885 ---- /* Convert the set constructor to the corresponding set type */ val = construct_set (val, type, 2); } ! else if (type ! && (is_string_type (val) || TREE_CODE (TREE_TYPE (val)) == CHAR_TYPE) ! && (is_of_string_type (type) ! || (TREE_CODE (type) == REFERENCE_TYPE ! && PASCAL_TYPE_STRING (TREE_TYPE (type))))) { ! /* @@@@@@@ Formal type CHAR should accept STRING-TYPE !!! */ ! int varparm = 0; int conforming; + int val_is_char = TREE_CODE (TREE_TYPE (val)) == CHAR_TYPE; if (TREE_CODE (type) == REFERENCE_TYPE) varparm = 1; *************** *** 1887,1901 **** conforming = (varparm && TREE_TYPE (type) == string_schema_proto_type) || type == string_schema_proto_type; ! /* See if the actual parameter is a variable length string */ ! if (is_variable_string_type (TREE_TYPE (val))) ! { ! if (conforming) ! type = TREE_TYPE (val); ! } ! else if (! varparm ! && (TREE_CODE (TREE_TYPE (val)) == CHAR_TYPE ! || is_string_type (val))) { /* Ugh, the actual parameter is an ARRAY_TYPE or a CHAR_TYPE; the formal parameter is a string --- 1890,1911 ---- conforming = (varparm && TREE_TYPE (type) == string_schema_proto_type) || type == string_schema_proto_type; ! ! /* See if the actual parameter is a variable length string ! * and the formal is an undiscriminated string schema -> use ! * type of actual parameter. ! * ! * If actual is not a variable-string, create a new variable string ! * type with the proper length and use the new type. ! */ ! if (conforming) ! if (is_variable_string_type (TREE_TYPE (val))) ! type = TREE_TYPE (val); ! else if (! varparm) ! type = build_pascal_string_schema (PASCAL_STRING_LENGTH (val)); ! ! /* Take care of value parameter type conversions/blank paddings */ ! if (! varparm) { /* Ugh, the actual parameter is an ARRAY_TYPE or a CHAR_TYPE; the formal parameter is a string *************** *** 1906,1917 **** use that type, otherwise create a new type with capacity equal to LENGTH(val) */ ! val = new_string_by_model (conforming ? NULL_TREE : type, ! val, 1); ! type = TREE_TYPE (val); } ! ! if (varparm && conforming) type = build_reference_type (type); /* VAR parameter string schema */ } else if (! conf_array_indices) --- 1916,1936 ---- use that type, otherwise create a new type with capacity equal to LENGTH(val) */ ! ! /* @@ Creates a new copy of string, but the size is now ! @@ the same as the formal parameters size, padding the ! @@ value parameter with spaces if necessary. ! @@ ! @@ The result is then *again* copied to the stack as a value parameter. ! @@ ! @@ The first copy can be avoided if the formal and actual ! @@ parameters are of same size. Now avoided if the types ! @@ are equal. ! */ ! if (TREE_TYPE (val) != type) ! val = new_string_by_model (type, val, 1); } ! else if (conforming) type = build_reference_type (type); /* VAR parameter string schema */ } else if (! conf_array_indices) *************** *** 2833,2842 **** if (code0 == SET_TYPE && (TREE_CODE (TREE_TYPE (type0)) == VOID_TYPE || code1 == TREE_CODE (TREE_TYPE (type0)) ! || code1 == TREE_CODE (set_base_type (type0)))) { /* Make expr.c(expand_expr:IN_EXPR) happy and avoid aborting with bit_index with e.g. CHAR_TYPE index. */ if (type1 != integer_type_node) op1 = convert (integer_type_node, op1); --- 2852,2865 ---- if (code0 == SET_TYPE && (TREE_CODE (TREE_TYPE (type0)) == VOID_TYPE || code1 == TREE_CODE (TREE_TYPE (type0)) ! || code1 == TREE_CODE (base_type (TREE_TYPE (type0)))) ! || (code1 == INTEGER_TYPE /* Maybe the set is of subrange type */ ! && TREE_TYPE (type1) ! && TREE_TYPE (type1) == TREE_TYPE (type0))) /* subrange of same type? */ { /* Make expr.c(expand_expr:IN_EXPR) happy and avoid aborting with bit_index with e.g. CHAR_TYPE index. */ + if (type1 != integer_type_node) op1 = convert (integer_type_node, op1); *************** *** 4673,4680 **** } else if (codel == SET_TYPE && coder == SET_TYPE) { ! tree lhs_basetype = set_base_type (type); ! tree rhs_basetype = set_base_type (rhstype); /* Allow empty set operations & ops when set base types match */ if ( TREE_CODE (rhs_basetype) != TREE_CODE (lhs_basetype) --- 4696,4703 ---- } else if (codel == SET_TYPE && coder == SET_TYPE) { ! tree lhs_basetype = base_type (TREE_TYPE (type)); ! tree rhs_basetype = base_type (TREE_TYPE (rhstype)); /* Allow empty set operations & ops when set base types match */ if ( TREE_CODE (rhs_basetype) != TREE_CODE (lhs_basetype) *** 1.31 1994/01/01 20:17:04 --- gpc-util.c 1994/01/20 06:11:25 *************** *** 46,51 **** --- 46,55 ---- /* This is not used. It's required to compile gpc-decl.c */ tree ridpointers[1]; + /* move to tree.h */ + extern rtx emit_string_move PROTO ((tree, tree, tree)); + extern void emit_string_pad PROTO ((rtx, rtx, int)); + /* Required to allocate space for modified program name. * see get_main_program_name(). */ *************** *** 619,645 **** } /* ! * Returns the base type of the SET_TYPE TYPE */ tree ! set_base_type (type) ! tree type; { - tree basetype; - - if (TREE_CODE (type) != SET_TYPE) - abort (); - - basetype = TREE_TYPE (type); - /* Check for ordinal subranges */ ! if (TREE_CODE (basetype) == INTEGER_TYPE ! && TREE_TYPE (basetype) ! /* If it is an integer subrange return the range */ ! && TREE_CODE (TREE_TYPE (basetype)) != INTEGER_TYPE) ! basetype = TREE_TYPE (basetype); ! return basetype; } /* FILETYPE is the file component type. --- 623,646 ---- } /* ! * Returns the base type of an ordinal subrange, or the type ! * itself if it is not a subrange */ tree ! base_type (type) ! tree type; { /* Check for ordinal subranges */ ! if (TREE_CODE (type) == INTEGER_TYPE ! && TREE_TYPE (type) ! #if 0 ! /* If it is an integer subrange return the range */ ! && TREE_CODE (TREE_TYPE (type)) != INTEGER_TYPE ! #endif ! ) ! type = TREE_TYPE (type); ! return type; } /* FILETYPE is the file component type. *************** *** 761,768 **** case RECORD_TYPE: /* String schema */ case STRING_CST: case ARRAY_TYPE: ! if (is_string_type (source) && is_string_type (target)) { if (TREE_CODE (t_type) == CHAR_TYPE) expand_expr_stmt (build_modify_expr (target, --- 762,771 ---- case RECORD_TYPE: /* String schema */ case STRING_CST: case ARRAY_TYPE: ! if (is_string_type (source) ! && (is_string_type (target) || TREE_CODE (t_type) == CHAR_TYPE)) { + /* @@@@ Check if source longer than target!!! */ if (TREE_CODE (t_type) == CHAR_TYPE) expand_expr_stmt (build_modify_expr (target, *************** *** 770,779 **** (build_array_ref (source, integer_one_node)))); else { ! if (is_variable_string_type (s_type)) ! length = PASCAL_STRING_LENGTH (source); ! else ! length = TYPE_MAX_VALUE (TYPE_DOMAIN (s_type)); /* The target needs to be an lvalue, but the source might be e.g. an array returned by a --- 773,779 ---- (build_array_ref (source, integer_one_node)))); else { ! length = PASCAL_STRING_LENGTH (source); /* The target needs to be an lvalue, but the source might be e.g. an array returned by a *************** *** 795,801 **** /* FALLTHROUGH */ default: ! error("Only pascal string-type and char type may be assigned to a string"); return; } --- 795,801 ---- /* FALLTHROUGH */ default: ! error("Only pascal string-type and char type are assignment compatible with a string"); return; } *************** *** 821,827 **** 0), NULL_RTX, Pmode, 0), expand_expr (build_binary_op (MINUS_EXPR, t_length, length, 0), ! NULL_RTX, VOIDmode, 0)); } } } --- 821,828 ---- 0), NULL_RTX, Pmode, 0), expand_expr (build_binary_op (MINUS_EXPR, t_length, length, 0), ! NULL_RTX, VOIDmode, 0), ! ' '); } } } *************** *** 874,886 **** if (! data) abort (); ! length = (TREE_CODE (TREE_TYPE (data)) == CHAR_TYPE) ! ? integer_one_node ! : is_variable_string_type (TREE_TYPE (data)) ! ? PASCAL_STRING_LENGTH (data) ! : TYPE_MAX_VALUE ! (TYPE_DOMAIN (TREE_TYPE ! (PASCAL_STRING_VALUE (data)))); type = build_pascal_string_schema (length); } --- 875,881 ---- if (! data) abort (); ! length = PASCAL_STRING_LENGTH (data); type = build_pascal_string_schema (length); } *************** *** 894,900 **** assign_string (new_string, data); /* Initialize the capacity schema discriminant field to length of string */ ! init_any (new_string, 0); return new_string; } --- 889,896 ---- assign_string (new_string, data); /* Initialize the capacity schema discriminant field to length of string */ ! if (PASCAL_TYPE_STRING (type)) ! init_any (new_string, 0); return new_string; } *************** *** 1090,1096 **** if (protected) type = build_type_variant (type, 1, 0); ! if (varparm) type = build_reference_type (type); type = build_tree_list (NULL_TREE, type); --- 1086,1092 ---- if (protected) type = build_type_variant (type, 1, 0); ! if (varparm && type != error_mark_node) type = build_reference_type (type); type = build_tree_list (NULL_TREE, type); *************** *** 1737,1743 **** what = P_FIX_STRING; if (field2) warning ("second field width allowed only when writing REAL type"); - field2 = field1; } else { --- 1733,1738 ---- *************** *** 1754,1767 **** field1 = null_pointer_node; } p = PASCAL_STRING_VALUE (p); - if (TREE_CODE (p) == STRING_CST) - field2 = size_int (TREE_STRING_LENGTH (p) - 1); - else - field2 = convert (integer_type_node, - TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (p)))); - /* pass the address of the string */ p = build1 (ADDR_EXPR, string_type_node, p); break; --- 1749,1757 ---- field1 = null_pointer_node; } + field2 = PASCAL_STRING_LENGTH (p); p = PASCAL_STRING_VALUE (p); /* pass the address of the string */ p = build1 (ADDR_EXPR, string_type_node, p); break; *************** *** 1840,1849 **** len1 = integer_one_node; arg1 = parm1; } - else if (is_variable_string_type (TREE_TYPE (parm1))) - len1 = PASCAL_STRING_LENGTH (parm1); else if (is_string_type (parm1)) ! len1 = convert (integer_type_node, TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (parm1)))); else { error ("First parameter to string routines must be of char or string type"); --- 1830,1837 ---- len1 = integer_one_node; arg1 = parm1; } else if (is_string_type (parm1)) ! len1 = PASCAL_STRING_LENGTH (parm1); else { error ("First parameter to string routines must be of char or string type"); *************** *** 1875,1885 **** len2 = integer_one_node; arg2 = parm2; } - else if (is_variable_string_type (TREE_TYPE (parm2))) - len2 = PASCAL_STRING_LENGTH (parm2); else if (is_string_type (parm2)) ! len2 = convert (integer_type_node, ! TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (parm2)))); else { error ("Second parameter to this string routine must be of char or string type"); --- 1863,1870 ---- len2 = integer_one_node; arg2 = parm2; } else if (is_string_type (parm2)) ! len2 = PASCAL_STRING_LENGTH (parm2); else { error ("Second parameter to this string routine must be of char or string type"); *************** *** 2339,2350 **** case p_LENGTH: /* rts_inline */ INLINE_RTS_LENGTH("length", 1); ! if (code == CHAR_TYPE) ! retval = integer_one_node; ! else if (is_variable_string_type (type)) retval = PASCAL_STRING_LENGTH (val); - else if (is_string_type (val)) - retval = convert (integer_type_node, TYPE_MAX_VALUE (TYPE_DOMAIN (type))); else errstr = "argument to `length' must be a string or char type"; break; --- 2324,2331 ---- case p_LENGTH: /* rts_inline */ INLINE_RTS_LENGTH("length", 1); ! if (code == CHAR_TYPE || is_string_type (val)) retval = PASCAL_STRING_LENGTH (val); else errstr = "argument to `length' must be a string or char type"; break; *************** *** 2687,2693 **** if (val2 && ORDINAL_TYPE (code2)) { if (TYPE_DOMAIN (type)) ! if (type2 == TREE_TYPE (TYPE_MIN_VALUE (TYPE_DOMAIN (type)))) { val2 = build_binary_op (MINUS_EXPR, val2, --- 2668,2675 ---- if (val2 && ORDINAL_TYPE (code2)) { if (TYPE_DOMAIN (type)) ! if (base_type (type2) ! == base_type (TREE_TYPE (TYPE_DOMAIN (type)))) { val2 = build_binary_op (MINUS_EXPR, val2, *************** *** 2858,2867 **** if (val2 != null_pointer_node) if (is_string_type (val2)) { if (is_variable_string_type (type2)) { - size = PASCAL_STRING_LENGTH (val2); - /* Use the string, not the schema type. * Converted to a reference by fpar. */ --- 2840,2849 ---- if (val2 != null_pointer_node) if (is_string_type (val2)) { + size = PASCAL_STRING_LENGTH (val2); + if (is_variable_string_type (type2)) { /* Use the string, not the schema type. * Converted to a reference by fpar. */ *************** *** 2872,2882 **** */ TREE_VALUE (TREE_CHAIN (apar)) = val2; } - else - if (TREE_CODE (val2) == STRING_CST) - size = size_int (TREE_STRING_LENGTH (val2) - 1); - else - size = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (val2))); fpar = chainon (do_ptype (type, 1, 0), chainon (do_ptype (TREE_TYPE(val2), 1, 0), --- 2854,2859 ---- *************** *** 3704,3711 **** --- 3681,3718 ---- evaluate_function_calls = state; } + /* A problem with the function calls again... + * If a forward declared/external function is used in an expression that is + * part of some function arguments it will not be called by the routine + * maybe_call_function() + * + * The function probably_call_function() is used when we know that the function + * is not a function parameter but rather should be evaluated. + */ + tree + probably_call_function (fun) + tree fun; + { + tree t = TREE_TYPE (fun); + + /* If this is a function without parameters, call it */ + if (TREE_CODE (fun) == FUNCTION_DECL + && TREE_CODE (t) == FUNCTION_TYPE + && TREE_CODE (TREE_TYPE (t)) != VOID_TYPE + && TYPE_ARG_TYPES (t) + && TREE_CODE (TREE_VALUE (TYPE_ARG_TYPES (t))) == VOID_TYPE) + { + fun = build_function_call (fun, NULL_TREE); + } + + return fun; + } + /* * Maybe call the function, or pass it as a routine parameter. + * The problem is that the corresponding argument type is not known + * when the factor is parsed. Neither is it known if this is part + * of an expression... */ tree maybe_call_function (fun, args) *************** *** 3714,3721 **** { tree temp = fun; ! /* This is a quick test to do this. ! to do it properly requires knowledge what we are doing: 1) this is a procedure statement without parameters 2) this is an assignment from function with no parameters to some variable, or passing the RESULT of such function --- 3721,3727 ---- { tree temp = fun; ! /* 1) this is a procedure statement without parameters 2) this is an assignment from function with no parameters to some variable, or passing the RESULT of such function *** 1.12 1993/12/30 23:26:48 --- rts/rts-file.c 1994/01/12 03:01:08 *************** *** 26,32 **** #include /* Routine to call when you wish to flush the file buffers ! * from your pascal source. */ void _p_flush (File) --- 26,32 ---- #include /* Routine to call when you wish to flush the file buffers ! * from your pascal source. (OBSOLETE?) */ void _p_flush (File) *************** *** 36,41 **** --- 36,51 ---- fflush (m_FILNUM (File)); } + /* Call this if you need to use the (FILE *) pointer in your pascal program + * for external C routines. + */ + FILE * + _p_getfile (File) + FDR File; + { + return m_FILNUM (File); + } + void _p_initfdr(File, Name, Size, flags) FDR File; /* address of FDR variable */ *************** *** 198,203 **** --- 208,217 ---- if ( ! in || (n = read (0,b,sizeof(b))) < 0) _p_error (ABORT, "Can't query user for external file name bindings"); } + + if (b[0] == EOT) + _p_error (ABORT, "EOT character given for file name query -- aborting"); + b[n] = '\0'; if (n > 0 && b[n-1] == '\n') b[n-1] = '\0'; close (tty); *************** *** 697,735 **** if (s) fprintf(stderr,"%s: ",s); ! fprintf (stderr,"FDR of %.10s\n",m_NAM(File)); if (Gpc_debug > 2 || !s) { ! fprintf(stderr,"\tofnum %d\n", (m_FILNUM(File) ? fileno(m_FILNUM(File)) : -1)); fprintf(stderr,"\tUND %d", tst_UND(File)); fprintf(stderr,"\tLAZY %d", tst_LAZY(File)); fprintf(stderr,"\tEOF %d", tst_EOF(File)); ! fprintf(stderr,"\tEOLN %d\n",tst_EOLN(File)); fprintf(stderr,"\tEXT %d", tst_EXT(File)); fprintf(stderr,"\tPCK %d", tst_PCK(File)); fprintf(stderr,"\tTXT %d", tst_TXT(File)); ! fprintf(stderr,"\tEMPTY %d\n",tst_EMPTY(File)); fprintf(stderr,"\tEXT %d", tst_EXT(File)); fprintf(stderr,"\tLGET %d", tst_LGET(File)); fprintf(stderr,"\tDIRECT %d", tst_DIRECT(File)); fprintf(stderr,"\tEOFOK %d", tst_EOFOK(File)); ! fprintf(stderr,"\n\tSTATUS 0x%x\n",m_STATUS(File)); ! fprintf(stderr,"\tSIZ %d\n",m_SIZ(File)); ! fprintf(stderr,"\tExt name %s\n",m_EXTNAM(File) ? m_EXTNAM(File) : ""); ! fprintf(stderr,"\tElem %d\n",m_FISIZE(File)); ! fprintf(stderr,"\tBinding 0x%lx\n", m_BINDING(File)); if (Gpc_debug > 3 || !s) { ! fprintf(stderr,"\tthis fdr adr: 0x%lx\n", File); ! fprintf(stderr,"\tnext fdr adr: 0x%lx\n",m_NXTFDR(File)); } /* Output the file buffer contents if this is a text file */ if (tst_TXT(File)) ! fprintf(stderr,"\tfile buffer: '%c' (0x%x)\n", m_FILBUF(File), m_FILBUF(File)); } } --- 711,749 ---- if (s) fprintf(stderr,"%s: ",s); ! fprintf (stderr,"FDR of %.10s\r\n",m_NAM(File)); if (Gpc_debug > 2 || !s) { ! fprintf(stderr,"\tofnum %d\r\n", (m_FILNUM(File) ? fileno(m_FILNUM(File)) : -1)); fprintf(stderr,"\tUND %d", tst_UND(File)); fprintf(stderr,"\tLAZY %d", tst_LAZY(File)); fprintf(stderr,"\tEOF %d", tst_EOF(File)); ! fprintf(stderr,"\tEOLN %d\r\n",tst_EOLN(File)); fprintf(stderr,"\tEXT %d", tst_EXT(File)); fprintf(stderr,"\tPCK %d", tst_PCK(File)); fprintf(stderr,"\tTXT %d", tst_TXT(File)); ! fprintf(stderr,"\tEMPTY %d\r\n",tst_EMPTY(File)); fprintf(stderr,"\tEXT %d", tst_EXT(File)); fprintf(stderr,"\tLGET %d", tst_LGET(File)); fprintf(stderr,"\tDIRECT %d", tst_DIRECT(File)); fprintf(stderr,"\tEOFOK %d", tst_EOFOK(File)); ! fprintf(stderr,"\r\n\tSTATUS 0x%x\r\n",m_STATUS(File)); ! fprintf(stderr,"\tSIZ %d\r\n",m_SIZ(File)); ! fprintf(stderr,"\tExt name %s\r\n",m_EXTNAM(File) ? m_EXTNAM(File) : ""); ! fprintf(stderr,"\tElem %d\r\n",m_FISIZE(File)); ! fprintf(stderr,"\tBinding 0x%lx\r\n", m_BINDING(File)); if (Gpc_debug > 3 || !s) { ! fprintf(stderr,"\tthis fdr adr: 0x%lx\r\n", File); ! fprintf(stderr,"\tnext fdr adr: 0x%lx\r\n",m_NXTFDR(File)); } /* Output the file buffer contents if this is a text file */ if (tst_TXT(File)) ! fprintf(stderr,"\tfile buffer: '%c' (0x%x)\r\n", m_FILBUF(File), m_FILBUF(File)); } } *** 1.6 1993/12/30 23:29:25 --- rts/rts-random.c 1994/01/11 23:20:04 *************** *** 141,147 **** _p_open (File, NULL, M_UPDATE | M_READ, 0); ! if (NewPlace >= m_FISIZE(File)) _p_generic(406); if (!tst_DIRECT(File)) --- 141,147 ---- _p_open (File, NULL, M_UPDATE | M_READ, 0); ! if (NewPlace > m_FISIZE(File)) _p_generic(406); if (!tst_DIRECT(File)) *************** *** 162,168 **** /* Seek back to the place where we were before the GET. It's m_SIZ(File) before the place we are now at */ ! if (_p_seek (File, -1, 1, 1)) _p_error (ABORT, "`SeekRead' failed to reset file position"); } --- 162,168 ---- /* Seek back to the place where we were before the GET. It's m_SIZ(File) before the place we are now at */ ! if (! tst_EOF (File) && _p_seek (File, -1, 1, 1)) _p_error (ABORT, "`SeekRead' failed to reset file position"); } *************** *** 189,195 **** _p_open (File, NULL, M_UPDATE | M_WRITE, 0); ! if (NewPlace >= m_FISIZE(File)) { /* It fails always in 10206. */ _p_error (REPORT, "GPC extension: Extending file %s in `SeekWrite' to %d elements", --- 189,195 ---- _p_open (File, NULL, M_UPDATE | M_WRITE, 0); ! if (NewPlace > m_FISIZE(File)) { /* It fails always in 10206. */ _p_error (REPORT, "GPC extension: Extending file %s in `SeekWrite' to %d elements", *************** *** 208,232 **** /* Change the mode to generation */ CLR_STATUS (File, FiANY); SET_STATUS (File, FiWRI); - - #if 0 - /* I understood the defintion of SeekWrite so that - * it just moves the file pointer and alters the MODE. - * But it does not write anything. - * - * So this code that writes F^ is not enabled. - */ - - _p_put(File); - - /* Seek back to the place where we were before the - PUT. It's m_SIZ(File) before the place we are now at */ - - if (_p_seek (File, -1, 1, 1)) - _p_error (ABORT, "`SeekWrite' failed to reset file position"); - - _p_resize (File); - #endif } /* SEEKUPDATE --- 208,213 ---- *************** *** 254,260 **** _p_open (File, NULL, M_UPDATE | M_READ, 0); ! if (NewPlace >= m_FISIZE(File)) _p_generic(406); if (!tst_DIRECT(File)) --- 235,241 ---- _p_open (File, NULL, M_UPDATE | M_READ, 0); ! if (NewPlace > m_FISIZE(File)) _p_generic(406); if (!tst_DIRECT(File)) *************** *** 273,279 **** /* Seek back to the place where we were before the GET. It's m_SIZ(File) before the place we are now at */ ! if (_p_seek (File, -1, 1, 0)) _p_error (ABORT, "`SeekUpdate' failed to reset file position"); } --- 254,260 ---- /* Seek back to the place where we were before the GET. It's m_SIZ(File) before the place we are now at */ ! if (! tst_EOF (File) && _p_seek (File, -1, 1, 0)) _p_error (ABORT, "`SeekUpdate' failed to reset file position"); } *************** *** 325,333 **** --- 306,321 ---- _p_get (File); } + #if 0 + /* @@@@@ Ooops: Currently assigning a value to a file buffer + does not clear the UND bit in the status word. + Disable this check -> UNDefined file buffers may be written with + update... + */ if (tst_UND (File)) _p_error (ABORT, "`Update(%s)' with an undefined file buffer", m_NAM (File)); + #endif is_random = TST_STATUS (File, FiRND); if (is_random) *** 1.9 1993/12/28 19:02:38 --- rts/rts-read.c 1994/01/12 03:54:14 *************** *** 174,253 **** _p_GetByt(File) FDR File; { ! if (ok_EOF(File)) { ! int temp; ! int eof_now = tst_EOFOK(File); ! if (tst_TTY(File)) { ! _p_fflush(TRUE); ! /* First get from the terminal input device ! * This is done to take care of an EOLN test ! * before anything is read in. Otherwise we ! * would have to read in a character to test. ! * ! * @@ Document: If INPUT is RESET, the file buffer ! * is set UNDEFINED and when nothing is read in yet: ! * ! * EOF(input) = False ! * ! * (This is according to standard, because EOLN must be on ! * before EOF can be TRUE). ! * ! * EOLN(Input) ! * ! * If it is TESTED it is TRUE. ! * If it is NOT TESTED it is FALSE ! */ ! if (tst_EMPTY(File) && tst_UND(File) && tst_LGET(File)) ! clr_EMPTY(File); ! } - clr_UND(File); - clr_LGET(File); - clr_EOFOK(File); - - m_FILBUF(File) = temp = getc(m_FILNUM(File)); - while (1) - if (temp != EOF) - break; - else - { - if (stdin != current_stdin && m_FILNUM(File) == current_stdin) - { - /* If this is the end of current_stdin, we are reading - * from the options file. Continue with the original stdin - * instead of quitting. - */ - if (_p_restore_stdin(File)) - { - m_FILBUF(File) = temp = getc(m_FILNUM(File)); - continue; - } - } - - if (tst_TXT(File) && !eof_now - && !tst_EOLN(File) && !tst_EMPTY(File)) { - /* When reading from TEXT file EOLN is always true just before EOF, even if there is no end of line at the end of the file */ ! set_EOLN(File); m_FILBUF(File) = ' '; ! } else { set_EOF(File); clr_EOLN(File); } ! return; ! } ! ! if (tst_TXT(File) && m_FILBUF(File) == NEWLINE) { ! set_EOLN(File); ! m_FILBUF(File) = ' '; ! } else ! clr_EOLN(File); } } --- 174,260 ---- _p_GetByt(File) FDR File; { ! if (ok_EOF(File)) ! { ! int temp; ! int eof_now = tst_EOFOK(File); ! ! if (tst_TTY(File)) ! { ! _p_fflush(TRUE); ! ! /* First get from the terminal input device ! * This is done to take care of an EOLN test ! * before anything is read in. Otherwise we ! * would have to read in a character to test. ! * ! * @@ Document: If INPUT is RESET, the file buffer ! * is set UNDEFINED and when nothing is read in yet: ! * ! * EOF(input) = False ! * ! * (This is according to standard, because EOLN must be on ! * before EOF can be TRUE). ! * ! * EOLN(Input) ! * ! * If it is TESTED it is TRUE. ! * If it is NOT TESTED it is FALSE ! */ ! if (tst_EMPTY(File) && tst_UND(File) && tst_LGET(File)) ! clr_EMPTY(File); ! } ! clr_UND(File); ! clr_LGET(File); ! clr_EOFOK(File); ! ! m_FILBUF(File) = temp = getc(m_FILNUM(File)); ! while (1) ! if (temp != EOF) ! break; ! else { ! if (stdin != current_stdin && m_FILNUM(File) == current_stdin) ! { ! /* If this is the end of current_stdin, we are reading ! * from the options file. Continue with the original stdin ! * instead of quitting. ! */ ! if (_p_restore_stdin(File)) ! { ! m_FILBUF(File) = temp = getc(m_FILNUM(File)); ! continue; ! } ! } ! if (tst_TXT(File) && !eof_now ! && !tst_EOLN(File) && !tst_EMPTY(File)) ! { /* When reading from TEXT file EOLN is always true just before EOF, even if there is no end of line at the end of the file */ ! set_EOLN(File); m_FILBUF(File) = ' '; ! } ! else ! { set_EOF(File); clr_EOLN(File); + set_UND(File); } ! return; ! } ! ! if (tst_TXT(File) && m_FILBUF(File) == NEWLINE) ! { ! set_EOLN(File); ! m_FILBUF(File) = ' '; ! } ! else ! clr_EOLN(File); } } *************** *** 260,265 **** --- 267,273 ---- if (ok_EOF(File)) { + clr_UND(File); if ((n = fread(m_FILBPTR(File),1,m_SIZ(File),m_FILNUM(File))) < m_SIZ(File)) { if (n != 0) *************** *** 269,276 **** set_EOF(File); clr_EOLN(File); } } - clr_UND(File); } } --- 277,284 ---- set_EOF(File); clr_EOLN(File); } + set_UND (File); } } } *************** *** 382,391 **** _p_lazyget(File) FDR File; { if (tst_UND (File) && !tst_LGET (File)) _p_error (ABORT, "Reference to a file buffer variable with undefined value `%s^'", m_NAM (File)); ! /* If the file buffer contents is lazy, validate it */ if (! tst_LGET(File)) return; --- 390,406 ---- _p_lazyget(File) FDR File; { + #if 0 + /* @@@ This is called also for "buffer^ := VAL;" + * So it must not blindly trap the reference + * + * Compiler should clear the UND bit for these... + */ if (tst_UND (File) && !tst_LGET (File)) _p_error (ABORT, "Reference to a file buffer variable with undefined value `%s^'", m_NAM (File)); ! #endif ! /* If the file buffer contents is lazy, validate it */ if (! tst_LGET(File)) return; *** 1.5 1993/12/28 18:48:16 --- rts/rts-readsub.c 1994/01/11 08:15:56 *************** *** 149,155 **** #endif { _p_generic(605); /* Sign or digit expected */ ! *res = '0'; return(ROK); } else --- 149,155 ---- #endif { _p_generic(605); /* Sign or digit expected */ ! strcpy (res, "0"); return(ROK); } else *************** *** 169,175 **** if (!isdigit(ch)) { _p_generic(604); /* Digit expected after sign */ ! *res = '0'; return(ROK); } --- 169,175 ---- if (!isdigit(ch)) { _p_generic(604); /* Digit expected after sign */ ! strcpy (res, "0"); return(ROK); } *************** *** 178,184 **** if (!isdigit(ch) && ch != '.') { _p_error (ABORT, "Digit or '.' expexted after sign"); ! *res = '0'; return(ROK); } --- 178,184 ---- if (!isdigit(ch) && ch != '.') { _p_error (ABORT, "Digit or '.' expexted after sign"); ! strcpy (res, "0"); return(ROK); } *************** *** 196,201 **** --- 196,207 ---- NEXTCHAR (ch, f, count); } + /* No significant digits, and there is no decimal point + * --> mantissa is zero + */ + if (! nonzero && ch != '.') + *res++ = '0'; + /* read the fractional part */ if (ch == '.') { /* Read the fractional part */ *** 1.13 1993/12/30 23:28:20 --- rts/rts.h 1994/01/12 02:41:43 *************** *** 251,256 **** --- 251,258 ---- # define TRUE 1 # define FALSE 0 + # define EOT '\004' /* File name queries abort if first char is EOT */ + #define NULL_DEVICE_NAME "/dev/null" /* Signal handling types */ *** /ykshailee/jtv/tmp/2.5.7/contrib/screen.c Sat Jan 1 16:20:45 1994 --- contrib/screen.c Fri Jan 14 01:13:09 1994 *************** *** 1,8 **** #include /* A screen module for gpc .... */ - /* Routine descriptions. */ int tgetent(char *bp, char *name); --- 1,9 ---- + #include + #include /* A screen module for gpc .... */ /* Routine descriptions. */ int tgetent(char *bp, char *name); *************** *** 29,34 **** --- 30,42 ---- char *_scr_cm; /* cursor motion. */ char *_scr_ho; /* home cursor */ + char *_scr_up; + char *_scr_do; + char *_scr_ri; + char *_scr_le; + + char _scr_mode_changed = 0; + /* Have we done the init yet? */ int _scr_did_init = 0; *************** *** 40,50 **** fputc (c, stdout); } /* Called to initialize the "module." */ ! void _scr_init () { char *area; _scr_tname = getenv ("TERM"); tgetent (_scr_bp, _scr_tname); --- 48,132 ---- fputc (c, stdout); } + static struct sgttyb orig_mode; + static struct sgttyb current_mode; + static struct sgttyb saved_mode; + + int + c_tty_mode (mode) + int mode; + { + if (! _scr_did_init) + { + fprintf (stderr, "You need to call c_init() before calling this\n"); + return 1; + } + + switch (mode) { + case 0: /* Restore original modes */ + current_mode = orig_mode; + break; + + case 1: /* Set RAW mode */ + current_mode.sg_flags |= (RAW); + break; + + case 2: /* Set Cooked mode (e.g. unset RAW */ + current_mode.sg_flags &= ~(RAW); + break; + + case 3: /* Set CBREAK mode */ + current_mode.sg_flags |= (CBREAK); + break; + + case 4: /* Unset CBREAK mode */ + current_mode.sg_flags &= ~(CBREAK); + break; + + case 5: /* Set NO ECHO mode */ + current_mode.sg_flags &= ~(ECHO); + break; + + case 6: /* Set ECHO mode */ + current_mode.sg_flags |= (ECHO); + break; + + case 7: /* Save current mode */ + saved_mode = current_mode; + return 0; + + case 8: /* Restore saved mode */ + current_mode = saved_mode; + break; + } + + if (ioctl (0, TIOCSETP, (char *)¤t_mode) == -1) + { + perror ("c_tty_mode: Can't set tty mode"); + + return 1; + } + } + + /* + * Initialize the screen handling for gpc. + */ + /* Called to initialize the "module." */ ! int ! c_init (how) ! int how; { char *area; + if (! how) + { + /* Called to reset everything before exiting */ + c_tty_mode (0); + + return 0; + } + _scr_tname = getenv ("TERM"); tgetent (_scr_bp, _scr_tname); *************** *** 57,106 **** _scr_cm = tgetstr ("cm", &area); _scr_ho = tgetstr ("ho", &area); /* Error Checks */ if (_scr_cm == NULL) { fprintf (stderr, "Terminal is not powerful enough.\n"); ! exit (1); } _scr_did_init = 1; } /* Cursor Movement */ ! void gotoxy (int x, int y) { - if (!_scr_did_init) _scr_init(); tputs (tgoto (_scr_cm, x, y), 1, _scr_outc); } /* Clear the entire screen and move to home. */ ! void clearscreen () { - if (!_scr_did_init) _scr_init(); tputs (_scr_cl, 1, _scr_outc); } /* Clear from cursor to the end of the screen. */ ! void cleartoeos () { - if (!_scr_did_init) _scr_init(); tputs (_scr_cd, 1, _scr_outc); } /* Clear from cursor to the end of the line. */ ! void cleartoeol () { - if (!_scr_did_init) _scr_init(); tputs (_scr_ce, 1, _scr_outc); } /* Go to the home position. */ ! void home() { - if (!_scr_did_init) _scr_init(); tputs (_scr_ho, 1, _scr_outc); } --- 139,243 ---- _scr_cm = tgetstr ("cm", &area); _scr_ho = tgetstr ("ho", &area); + _scr_up = tgetstr ("ku", &area); + _scr_do = tgetstr ("kd", &area); + _scr_le = tgetstr ("kl", &area); + _scr_ri = tgetstr ("kr", &area); + + if (! _scr_ri) + fprintf (stderr, "Cursor movement right is not supported\n"); + + if (! _scr_le) + fprintf (stderr, "Cursor movement left is not supported\n"); + + if (! _scr_up) + fprintf (stderr, "Cursor movement up is not supported\n"); + if (! _scr_do) + fprintf (stderr, "Cursor movement down is not supported\n"); + + if (ioctl (0, TIOCGETP, (char *)&orig_mode) == -1) + { + perror ("Can't save tty modes in c_init"); + return 1; + } + + /* Save the original tty modes also here */ + saved_mode = current_mode = orig_mode; + /* Error Checks */ if (_scr_cm == NULL) { fprintf (stderr, "Terminal is not powerful enough.\n"); ! return 1; } + _scr_did_init = 1; + + return 0; } + void c_right (count) + int count; + { + for (; count > 0; count--) + tputs (_scr_ri, 1, _scr_outc); + } + + void c_left (count) + int count; + { + for (; count > 0; count--) + tputs (_scr_le, 1, _scr_outc); + } + + void c_down (count) + int count; + { + for (; count > 0; count--) + tputs (_scr_do, 1, _scr_outc); + } + + void c_up (count) + int count; + { + for (; count > 0; count--) + tputs (_scr_up, 1, _scr_outc); + } /* Cursor Movement */ ! void c_gotoxy (int x, int y) { tputs (tgoto (_scr_cm, x, y), 1, _scr_outc); } /* Clear the entire screen and move to home. */ ! void c_clearscreen () { tputs (_scr_cl, 1, _scr_outc); } /* Clear from cursor to the end of the screen. */ ! void c_cleartoeos () { tputs (_scr_cd, 1, _scr_outc); } /* Clear from cursor to the end of the line. */ ! void c_cleartoeol () { tputs (_scr_ce, 1, _scr_outc); } /* Go to the home position. */ ! void c_home() { tputs (_scr_ho, 1, _scr_outc); + } + + int c_getch() + { + return getchar(); } *** /ykshailee/jtv/tmp/2.5.7/contrib/screen.p Sat Jan 1 16:20:45 1994 --- contrib/screen.p Tue Jan 11 12:13:06 1994 *************** *** 1,11 **** module screen interface; ! export screen (clearscreen, cleartoeos, cleartoeol, gotoxy, home); ! procedure clearscreen; C; ! procedure cleartoeos; C; ! procedure cleartoeol; C; ! procedure gotoxy (x,y:integer); C; ! procedure home; C; end. --- 1,13 ---- + module screen interface; ! export screen = (c_clearscreen, c_cleartoeos, c_cleartoeol, ! c_gotoxy, c_home); ! procedure c_clearscreen; C; ! procedure c_cleartoeos; C; ! procedure c_cleartoeol; C; ! procedure c_gotoxy (x,y:integer); C; ! procedure c_home; C; end. End of diffs.