diff --git a/src/c/compiler.d b/src/c/compiler.d index fb2336237..256da6547 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -131,19 +131,18 @@ static int c_listA(cl_env_ptr env, cl_object args, int push); static cl_object ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda); static void FEillegal_variable_name(cl_object) ecl_attr_noreturn; - static void FEill_formed_input(void) ecl_attr_noreturn; +static void FEill_formed_input(void) ecl_attr_noreturn; - /* -------------------- SAFE LIST HANDLING -------------------- */ - - static cl_object - pop(cl_object *l) { - cl_object head, list = *l; - unlikely_if (ECL_ATOM(list)) - FEill_formed_input(); - head = ECL_CONS_CAR(list); - *l = ECL_CONS_CDR(list); - return head; - } +/* -------------------- SAFE LIST HANDLING -------------------- */ +static cl_object +pop(cl_object *l) { + cl_object head, list = *l; + unlikely_if (ECL_ATOM(list)) + FEill_formed_input(); + head = ECL_CONS_CAR(list); + *l = ECL_CONS_CDR(list); + return head; +} static cl_object pop_maybe_nil(cl_object *l) { diff --git a/src/c/disassembler.d b/src/c/disassembler.d index f06864f5d..489df7203 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - disassembler.c -- Byte compiler and function evaluator -*/ -/* - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ + * disassembler.d - bytecodes disassembler utilities + * + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -26,60 +21,60 @@ static cl_opcode *base = NULL; static void print_noarg(const char *s) { - ecl_princ_str(s, ECL_NIL); + ecl_princ_str(s, ECL_NIL); } static void print_oparg(const char *s, cl_fixnum n) { - ecl_princ_str(s, ECL_NIL); - ecl_princ(ecl_make_fixnum(n), ECL_NIL); + ecl_princ_str(s, ECL_NIL); + ecl_princ(ecl_make_fixnum(n), ECL_NIL); } static void print_arg(const char *s, cl_object x) { - ecl_princ_str(s, ECL_NIL); - ecl_princ(x, ECL_NIL); + ecl_princ_str(s, ECL_NIL); + ecl_princ(x, ECL_NIL); } static void print_oparg_arg(const char *s, cl_fixnum n, cl_object x) { - ecl_princ_str(s, ECL_NIL); - ecl_princ(ecl_make_fixnum(n), ECL_NIL); - ecl_princ_str(",", ECL_NIL); - ecl_princ(x, ECL_NIL); + ecl_princ_str(s, ECL_NIL); + ecl_princ(ecl_make_fixnum(n), ECL_NIL); + ecl_princ_str(",", ECL_NIL); + ecl_princ(x, ECL_NIL); } -#define GET_DATA(r,v,data) { \ - cl_oparg ndx; \ - GET_OPARG(ndx, v); \ - r = data[ndx]; \ -} +#define GET_DATA(r,v,data) { \ + cl_oparg ndx; \ + GET_OPARG(ndx, v); \ + r = data[ndx]; \ + } static void disassemble_lambda(cl_object bytecodes) { - const cl_env_ptr env = ecl_process_env(); - cl_object *data; - cl_opcode *vector; + const cl_env_ptr env = ecl_process_env(); + cl_object *data; + cl_opcode *vector; - ecl_bds_bind(env, @'*print-pretty*', ECL_NIL); + ecl_bds_bind(env, @'*print-pretty*', ECL_NIL); - /* Print required arguments */ - data = bytecodes->bytecodes.data->vector.self.t; - cl_print(1,bytecodes->bytecodes.data); + /* Print required arguments */ + data = bytecodes->bytecodes.data->vector.self.t; + cl_print(1,bytecodes->bytecodes.data); - /* Name of LAMBDA */ - print_arg("\nName:\t\t", bytecodes->bytecodes.name); - if (bytecodes->bytecodes.name == OBJNULL || - bytecodes->bytecodes.name == @'si::bytecodes') { - print_noarg("\nEvaluated form:"); - goto NO_ARGS; - } + /* Name of LAMBDA */ + print_arg("\nName:\t\t", bytecodes->bytecodes.name); + if (bytecodes->bytecodes.name == OBJNULL || + bytecodes->bytecodes.name == @'si::bytecodes') { + print_noarg("\nEvaluated form:"); + goto NO_ARGS; + } NO_ARGS: - base = vector = (cl_opcode *)bytecodes->bytecodes.code; - disassemble(bytecodes, vector); + base = vector = (cl_opcode *)bytecodes->bytecodes.code; + disassemble(bytecodes, vector); - ecl_bds_unwind1(env); + ecl_bds_unwind1(env); } /* -------------------- DISASSEMBLER CORE -------------------- */ @@ -87,606 +82,606 @@ disassemble_lambda(cl_object bytecodes) { /* OP_FLET nfun{arg}, fun1{object} ... - Executes the enclosed code in a lexical enviroment extended with - the functions "fun1" ... "funn". + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". */ static cl_opcode * disassemble_flet(cl_object bytecodes, cl_opcode *vector) { - cl_index nfun; - cl_object *data = bytecodes->bytecodes.data->vector.self.t; - GET_OPARG(nfun, vector); - print_noarg("FLET"); - while (nfun--) { - cl_object fun; - GET_DATA(fun, vector, data); - print_arg("\n\tFLET\t", fun->bytecodes.name); - } - return vector; + cl_index nfun; + cl_object *data = bytecodes->bytecodes.data->vector.self.t; + GET_OPARG(nfun, vector); + print_noarg("FLET"); + while (nfun--) { + cl_object fun; + GET_DATA(fun, vector, data); + print_arg("\n\tFLET\t", fun->bytecodes.name); + } + return vector; } /* OP_LABELS nfun{arg}, fun1{object} ... - Executes the enclosed code in a lexical enviroment extended with - the functions "fun1" ... "funn". + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". */ static cl_opcode * disassemble_labels(cl_object bytecodes, cl_opcode *vector) { - cl_index nfun; - cl_object *data = bytecodes->bytecodes.data->vector.self.t; - GET_OPARG(nfun, vector); - print_noarg("LABELS"); - while (nfun--) { - cl_object fun; - GET_DATA(fun, vector, data); - print_arg("\n\tLABELS\t", fun->bytecodes.name); - } - return vector; + cl_index nfun; + cl_object *data = bytecodes->bytecodes.data->vector.self.t; + GET_OPARG(nfun, vector); + print_noarg("LABELS"); + while (nfun--) { + cl_object fun; + GET_DATA(fun, vector, data); + print_arg("\n\tLABELS\t", fun->bytecodes.name); + } + return vector; } /* OP_PROGV bindings{list} ... OP_EXIT - Execute the code enclosed with the special variables in BINDINGS - set to the values in the list which was passed in VALUES(0). + Execute the code enclosed with the special variables in BINDINGS + set to the values in the list which was passed in VALUES(0). */ static cl_opcode * disassemble_progv(cl_object bytecodes, cl_opcode *vector) { - print_noarg("PROGV"); - vector = disassemble(bytecodes, vector); - print_noarg("\t\t; progv"); - return vector; + print_noarg("PROGV"); + vector = disassemble(bytecodes, vector); + print_noarg("\t\t; progv"); + return vector; } /* OP_TAGBODY n{arg} label1 ... labeln -label1: + label1: ... -labeln: + labeln: ... OP_EXIT - High level construct for the TAGBODY form. + High level construct for the TAGBODY form. */ static cl_opcode * disassemble_tagbody(cl_object bytecodes, cl_opcode *vector) { - cl_index i, ntags; - cl_opcode *destination; - GET_OPARG(ntags, vector); - print_noarg("TAGBODY"); - for (i=0; ibytecodes.data->vector.self.t; - cl_object line_no; + const char *string; + cl_object o; + cl_fixnum n, m; + cl_object line_format; + cl_object *data = bytecodes->bytecodes.data->vector.self.t; + cl_object line_no; - if (cl_fboundp(@'si::formatter-aux') != ECL_NIL) - line_format = make_constant_base_string("~%~4d\t"); - else - line_format = ECL_NIL; + if (cl_fboundp(@'si::formatter-aux') != ECL_NIL) + line_format = make_constant_base_string("~%~4d\t"); + else + line_format = ECL_NIL; BEGIN: - if (1) { - line_no = ecl_make_fixnum(vector-base); - } else { - line_no = @'*'; - } - if (line_format != ECL_NIL) { - cl_format(3, ECL_T, line_format, line_no); - } else { - ecl_princ_char('\n', ECL_NIL); - ecl_princ(line_no, ECL_NIL); - ecl_princ_char('\t', ECL_NIL); - } - switch (GET_OPCODE(vector)) { + if (1) { + line_no = ecl_make_fixnum(vector-base); + } else { + line_no = @'*'; + } + if (line_format != ECL_NIL) { + cl_format(3, ECL_T, line_format, line_no); + } else { + ecl_princ_char('\n', ECL_NIL); + ecl_princ(line_no, ECL_NIL); + ecl_princ_char('\t', ECL_NIL); + } + switch (GET_OPCODE(vector)) { - /* OP_NOP - Sets VALUES(0) = NIL and NVALUES = 1 - */ - case OP_NOP: string = "NOP"; goto NOARG; + /* OP_NOP + Sets VALUES(0) = NIL and NVALUES = 1 + */ + case OP_NOP: string = "NOP"; goto NOARG; - case OP_INT: string = "QUOTE\t"; - GET_OPARG(n, vector); - goto OPARG; + case OP_INT: string = "QUOTE\t"; + GET_OPARG(n, vector); + goto OPARG; - case OP_PINT: string = "PUSH\t"; - GET_OPARG(n, vector); - goto OPARG; + case OP_PINT: string = "PUSH\t"; + GET_OPARG(n, vector); + goto OPARG; - /* OP_QUOTE - Sets VALUES(0) to an immediate value. - */ - case OP_QUOTE: string = "QUOTE\t"; - GET_DATA(o, vector, data); - goto ARG; + /* OP_QUOTE + Sets VALUES(0) to an immediate value. + */ + case OP_QUOTE: string = "QUOTE\t"; + GET_DATA(o, vector, data); + goto ARG; - /* OP_CSET n{arg} - Replace constant with a computed value - */ - case OP_CSET: string = "CSET\t"; - GET_OPARG(n, vector); - goto OPARG; + /* OP_CSET n{arg} + Replace constant with a computed value + */ + case OP_CSET: string = "CSET\t"; + GET_OPARG(n, vector); + goto OPARG; - /* OP_VAR n{arg} - Sets NVALUES=1 and VALUES(0) to the value of the n-th local. - */ - case OP_VAR: string = "VAR\t"; - GET_OPARG(n, vector); - goto OPARG; + /* OP_VAR n{arg} + Sets NVALUES=1 and VALUES(0) to the value of the n-th local. + */ + case OP_VAR: string = "VAR\t"; + GET_OPARG(n, vector); + goto OPARG; - /* OP_VARS var{symbol} - Sets NVALUES=1 and VALUES(0) to the value of the symbol VAR. - VAR should be either a special variable or a constant. - */ - case OP_VARS: string = "VARS\t"; - GET_DATA(o, vector, data); - goto ARG; + /* OP_VARS var{symbol} + Sets NVALUES=1 and VALUES(0) to the value of the symbol VAR. + VAR should be either a special variable or a constant. + */ + case OP_VARS: string = "VARS\t"; + GET_DATA(o, vector, data); + goto ARG; - /* OP_PUSH - Pushes the object in VALUES(0). - */ - case OP_PUSH: string = "PUSH\tVALUES(0)"; - goto NOARG; + /* OP_PUSH + Pushes the object in VALUES(0). + */ + case OP_PUSH: string = "PUSH\tVALUES(0)"; + goto NOARG; - case OP_VALUEREG0: string = "SET\tVALUES(0),REG0"; - goto NOARG; + case OP_VALUEREG0: string = "SET\tVALUES(0),REG0"; + goto NOARG; - /* OP_PUSHV n{arg} - Pushes the value of the n-th local onto the stack. - */ - case OP_PUSHV: string = "PUSHV\t"; - GET_OPARG(n, vector); - goto OPARG; + /* OP_PUSHV n{arg} + Pushes the value of the n-th local onto the stack. + */ + case OP_PUSHV: string = "PUSHV\t"; + GET_OPARG(n, vector); + goto OPARG; - /* OP_PUSHVS var{symbol} - Pushes the value of the symbol VAR onto the stack. - VAR should be either a special variable or a constant. - */ - case OP_PUSHVS: string = "PUSHVS\t"; - GET_DATA(o, vector, data); - goto ARG; + /* OP_PUSHVS var{symbol} + Pushes the value of the symbol VAR onto the stack. + VAR should be either a special variable or a constant. + */ + case OP_PUSHVS: string = "PUSHVS\t"; + GET_DATA(o, vector, data); + goto ARG; - /* OP_PUSHQ value{object} - Pushes "value" onto the stack. - */ - case OP_PUSHQ: string = "PUSH\t'"; - GET_DATA(o, vector, data); - goto ARG; + /* OP_PUSHQ value{object} + Pushes "value" onto the stack. + */ + case OP_PUSHQ: string = "PUSH\t'"; + GET_DATA(o, vector, data); + goto ARG; - /* OP_PUSHVALUES - Pushes the values output by the last form, plus the number - of values. - */ - case OP_PUSHVALUES: string = "PUSH\tVALUES"; - goto NOARG; - /* OP_PUSHMOREVALUES - Adds more values to the ones pushed by OP_PUSHVALUES. - */ - case OP_PUSHMOREVALUES: string = "PUSH\tMORE VALUES"; - goto NOARG; - /* OP_POP - Pops a single value pushed by a OP_PUSH[V[S]] operator. - */ - case OP_POP: string = "POP"; - goto NOARG; - /* OP_POP1 - Pops a single value pushed by a OP_PUSH[V[S]] operator. - */ - case OP_POP1: string = "POP1"; - goto NOARG; - /* OP_POPVALUES - Pops all values pushed by a OP_PUSHVALUES operator. - */ - case OP_POPVALUES: string = "POP\tVALUES"; - goto NOARG; + /* OP_PUSHVALUES + Pushes the values output by the last form, plus the number + of values. + */ + case OP_PUSHVALUES: string = "PUSH\tVALUES"; + goto NOARG; + /* OP_PUSHMOREVALUES + Adds more values to the ones pushed by OP_PUSHVALUES. + */ + case OP_PUSHMOREVALUES: string = "PUSH\tMORE VALUES"; + goto NOARG; + /* OP_POP + Pops a single value pushed by a OP_PUSH[V[S]] operator. + */ + case OP_POP: string = "POP"; + goto NOARG; + /* OP_POP1 + Pops a single value pushed by a OP_PUSH[V[S]] operator. + */ + case OP_POP1: string = "POP1"; + goto NOARG; + /* OP_POPVALUES + Pops all values pushed by a OP_PUSHVALUES operator. + */ + case OP_POPVALUES: string = "POP\tVALUES"; + goto NOARG; - case OP_BLOCK: string = "BLOCK\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_CATCH: string = "CATCH\tREG0"; - goto NOARG; - case OP_DO: string = "BLOCK\t"; - o = ECL_NIL; - goto ARG; - case OP_FRAME: string = "FRAME\t"; - goto JMP; + case OP_BLOCK: string = "BLOCK\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_CATCH: string = "CATCH\tREG0"; + goto NOARG; + case OP_DO: string = "BLOCK\t"; + o = ECL_NIL; + goto ARG; + case OP_FRAME: string = "FRAME\t"; + goto JMP; - /* OP_CALL n{arg} - Calls the function in VALUES(0) with N arguments which - have been deposited in the stack. The output values - are left in VALUES(...) - */ - case OP_CALL: string = "CALL\t"; - GET_OPARG(n, vector); - goto OPARG; + /* OP_CALL n{arg} + Calls the function in VALUES(0) with N arguments which + have been deposited in the stack. The output values + are left in VALUES(...) + */ + case OP_CALL: string = "CALL\t"; + GET_OPARG(n, vector); + goto OPARG; - /* OP_CALLG n{arg}, name{arg} - Calls the function NAME with N arguments which have been - deposited in the stack. The output values are left in VALUES. - */ - case OP_CALLG: string = "CALLG\t"; - GET_OPARG(n, vector); - GET_DATA(o, vector, data); - goto OPARG_ARG; + /* OP_CALLG n{arg}, name{arg} + Calls the function NAME with N arguments which have been + deposited in the stack. The output values are left in VALUES. + */ + case OP_CALLG: string = "CALLG\t"; + GET_OPARG(n, vector); + GET_DATA(o, vector, data); + goto OPARG_ARG; - /* OP_FCALL n{arg} - Calls the function in the stack with N arguments which - have been also deposited in the stack. The output values - are left in VALUES(...) - */ - case OP_STEPCALL: - case OP_FCALL: string = "FCALL\t"; - GET_OPARG(n, vector); - goto OPARG; + /* OP_FCALL n{arg} + Calls the function in the stack with N arguments which + have been also deposited in the stack. The output values + are left in VALUES(...) + */ + case OP_STEPCALL: + case OP_FCALL: string = "FCALL\t"; + GET_OPARG(n, vector); + goto OPARG; - /* OP_MCALL - Similar to FCALL, but gets the number of arguments from - the stack (They all have been deposited by OP_PUSHVALUES) - */ - case OP_MCALL: string = "MCALL"; - goto NOARG; + /* OP_MCALL + Similar to FCALL, but gets the number of arguments from + the stack (They all have been deposited by OP_PUSHVALUES) + */ + case OP_MCALL: string = "MCALL"; + goto NOARG; - /* OP_POPREQ - Extracts next required argument. - */ - case OP_POPREQ: string = "POP\tREQ"; - goto NOARG; - /* OP_NOMORE - Ensure there are no more arguments. - */ - case OP_NOMORE: string = "NOMORE"; - goto NOARG; - /* OP_POPOPT - Extracts next optional argument. - */ - case OP_POPOPT: string = "POP\tOPT"; - goto NOARG; - /* OP_POPREST - Extracts list of remaining arguments. - */ - case OP_POPREST: string = "POP\tREST"; - goto NOARG; - /* OP_PUSHKEYS - Parses the keyword arguments - */ - case OP_PUSHKEYS: string = "PUSH\tKEYS "; - GET_DATA(o, vector, data); - goto ARG; + /* OP_POPREQ + Extracts next required argument. + */ + case OP_POPREQ: string = "POP\tREQ"; + goto NOARG; + /* OP_NOMORE + Ensure there are no more arguments. + */ + case OP_NOMORE: string = "NOMORE"; + goto NOARG; + /* OP_POPOPT + Extracts next optional argument. + */ + case OP_POPOPT: string = "POP\tOPT"; + goto NOARG; + /* OP_POPREST + Extracts list of remaining arguments. + */ + case OP_POPREST: string = "POP\tREST"; + goto NOARG; + /* OP_PUSHKEYS + Parses the keyword arguments + */ + case OP_PUSHKEYS: string = "PUSH\tKEYS "; + GET_DATA(o, vector, data); + goto ARG; - /* OP_EXIT - Marks the end of a high level construct - */ - case OP_EXIT: print_noarg("EXIT"); - return vector; - /* OP_EXIT_FRAME - Marks the end of a high level construct (BLOCK, CATCH...) - */ - case OP_EXIT_FRAME: string = "EXIT\tFRAME"; - goto NOARG; - /* OP_EXIT_TAGBODY - Marks the end of a high level construct (TAGBODY) - */ - case OP_EXIT_TAGBODY: print_noarg("EXIT\tTAGBODY"); - return vector; + /* OP_EXIT + Marks the end of a high level construct + */ + case OP_EXIT: print_noarg("EXIT"); + return vector; + /* OP_EXIT_FRAME + Marks the end of a high level construct (BLOCK, CATCH...) + */ + case OP_EXIT_FRAME: string = "EXIT\tFRAME"; + goto NOARG; + /* OP_EXIT_TAGBODY + Marks the end of a high level construct (TAGBODY) + */ + case OP_EXIT_TAGBODY: print_noarg("EXIT\tTAGBODY"); + return vector; - case OP_FLET: vector = disassemble_flet(bytecodes, vector); - break; - case OP_LABELS: vector = disassemble_labels(bytecodes, vector); - break; + case OP_FLET: vector = disassemble_flet(bytecodes, vector); + break; + case OP_LABELS: vector = disassemble_labels(bytecodes, vector); + break; - /* OP_LFUNCTION name{symbol} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. - */ - case OP_LFUNCTION: string = "LOCFUNC\t"; - GET_OPARG(n, vector); - goto OPARG; + /* OP_LFUNCTION name{symbol} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + case OP_LFUNCTION: string = "LOCFUNC\t"; + GET_OPARG(n, vector); + goto OPARG; - /* OP_FUNCTION name{symbol} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. - */ - case OP_FUNCTION: string = "SYMFUNC\t"; - GET_DATA(o, vector, data); - goto ARG; + /* OP_FUNCTION name{symbol} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + case OP_FUNCTION: string = "SYMFUNC\t"; + GET_DATA(o, vector, data); + goto ARG; - /* OP_CLOSE name{arg} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. - */ - case OP_CLOSE: string = "CLOSE\t"; - GET_DATA(o, vector, data); - goto ARG; + /* OP_CLOSE name{arg} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + case OP_CLOSE: string = "CLOSE\t"; + GET_DATA(o, vector, data); + goto ARG; - /* OP_GO n{arg}, tag-ndx{arg} - OP_QUOTE tag-name{symbol} - Jumps to the tag which is defined at the n-th position in - the lexical environment. TAG-NAME is kept for debugging - purposes. - */ - case OP_GO: string = "GO\t"; - GET_OPARG(n, vector); - GET_OPARG(m, vector); - o = ecl_make_fixnum(m); - goto OPARG_ARG; + /* OP_GO n{arg}, tag-ndx{arg} + OP_QUOTE tag-name{symbol} + Jumps to the tag which is defined at the n-th position in + the lexical environment. TAG-NAME is kept for debugging + purposes. + */ + case OP_GO: string = "GO\t"; + GET_OPARG(n, vector); + GET_OPARG(m, vector); + o = ecl_make_fixnum(m); + goto OPARG_ARG; - /* OP_RETURN n{arg} - Returns from the block whose record in the lexical environment - occuppies the n-th position. - */ - case OP_RETURN: string = "RETFROM"; - GET_OPARG(n, vector); - goto OPARG; + /* OP_RETURN n{arg} + Returns from the block whose record in the lexical environment + occuppies the n-th position. + */ + case OP_RETURN: string = "RETFROM"; + GET_OPARG(n, vector); + goto OPARG; - /* OP_THROW - Jumps to an enclosing CATCH form whose tag matches the one - of the THROW. The tag is taken from the stack, while the - output values are left in VALUES(...). - */ - case OP_THROW: string = "THROW"; - goto NOARG; + /* OP_THROW + Jumps to an enclosing CATCH form whose tag matches the one + of the THROW. The tag is taken from the stack, while the + output values are left in VALUES(...). + */ + case OP_THROW: string = "THROW"; + goto NOARG; - /* OP_JMP label{arg} - OP_JNIL label{arg} - OP_JT label{arg} - OP_JEQ label{arg}, value{object} - OP_JNEQ label{arg}, value{object} - Direct or conditional jumps. The conditional jumps are made - comparing with the value of VALUES(0). - */ - case OP_JMP: string = "JMP\t"; - goto JMP; - case OP_JNIL: string = "JNIL\t"; - goto JMP; - case OP_JT: string = "JT\t"; - JMP: { GET_OPARG(m, vector); - n = vector + m - OPARG_SIZE - base; - goto OPARG; - } - case OP_JEQL: string = "JEQL\t"; - goto JEQL; - case OP_JNEQL: string = "JNEQL\t"; - JEQL: { GET_DATA(o, vector, data); - GET_OPARG(m, vector); - n = vector + m - OPARG_SIZE - base; - goto OPARG_ARG; - } - case OP_NOT: string = "NOT"; - goto NOARG; + /* OP_JMP label{arg} + OP_JNIL label{arg} + OP_JT label{arg} + OP_JEQ label{arg}, value{object} + OP_JNEQ label{arg}, value{object} + Direct or conditional jumps. The conditional jumps are made + comparing with the value of VALUES(0). + */ + case OP_JMP: string = "JMP\t"; + goto JMP; + case OP_JNIL: string = "JNIL\t"; + goto JMP; + case OP_JT: string = "JT\t"; + JMP: { GET_OPARG(m, vector); + n = vector + m - OPARG_SIZE - base; + goto OPARG; + } + case OP_JEQL: string = "JEQL\t"; + goto JEQL; + case OP_JNEQL: string = "JNEQL\t"; + JEQL: { GET_DATA(o, vector, data); + GET_OPARG(m, vector); + n = vector + m - OPARG_SIZE - base; + goto OPARG_ARG; + } + case OP_NOT: string = "NOT"; + goto NOARG; - /* OP_UNBIND n{arg} - Undo "n" bindings of lexical variables. - */ - case OP_UNBIND: string = "UNBIND\t"; - GET_OPARG(n, vector); - goto OPARG; - /* OP_UNBINDS n{arg} - Undo "n" bindings of special variables. - */ - case OP_UNBINDS: string = "UNBINDS\t"; - GET_OPARG(n, vector); - goto OPARG; - /* OP_BIND name{symbol} - OP_PBIND name{symbol} - OP_BINDS name{symbol} - OP_PBINDS name{symbol} - Binds a lexical or special variable to the either the - value of VALUES(0), to the first value of the stack, or - to the n-th value of VALUES(...). - */ - case OP_BIND: string = "BIND\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_PBIND: string = "PBIND\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_VBIND: string = "VBIND\t"; - GET_OPARG(n, vector); - GET_DATA(o, vector, data); - goto OPARG_ARG; - case OP_BINDS: string = "BINDS\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_PBINDS: string = "PBINDS\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_VBINDS: string = "VBINDS\t"; - GET_OPARG(n, vector); - GET_DATA(o, vector, data); - goto OPARG_ARG; - /* OP_SETQ n{arg} - OP_PSETQ n{arg} - OP_SETQS var-name{symbol} - OP_PSETQS var-name{symbol} - Sets either the n-th local or a special variable VAR-NAME, - to either the value in VALUES(0) (OP_SETQ[S]) or to the - first value on the stack (OP_PSETQ[S]). - */ - case OP_SETQ: string = "SETQ\t"; - GET_OPARG(n, vector); - goto OPARG; - case OP_PSETQ: string = "PSETQ\t"; - GET_OPARG(n, vector); - goto OPARG; - case OP_VSETQ: string = "VSETQ\t"; - GET_OPARG(m, vector); - o = ecl_make_fixnum(m); - GET_OPARG(n, vector); - goto OPARG_ARG; - case OP_SETQS: string = "SETQS\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_PSETQS: string = "PSETQS\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_VSETQS: string = "VSETQS\t"; - GET_DATA(o, vector, data); - GET_OPARG(n, vector); - goto OPARG_ARG; + /* OP_UNBIND n{arg} + Undo "n" bindings of lexical variables. + */ + case OP_UNBIND: string = "UNBIND\t"; + GET_OPARG(n, vector); + goto OPARG; + /* OP_UNBINDS n{arg} + Undo "n" bindings of special variables. + */ + case OP_UNBINDS: string = "UNBINDS\t"; + GET_OPARG(n, vector); + goto OPARG; + /* OP_BIND name{symbol} + OP_PBIND name{symbol} + OP_BINDS name{symbol} + OP_PBINDS name{symbol} + Binds a lexical or special variable to the either the + value of VALUES(0), to the first value of the stack, or + to the n-th value of VALUES(...). + */ + case OP_BIND: string = "BIND\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_PBIND: string = "PBIND\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_VBIND: string = "VBIND\t"; + GET_OPARG(n, vector); + GET_DATA(o, vector, data); + goto OPARG_ARG; + case OP_BINDS: string = "BINDS\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_PBINDS: string = "PBINDS\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_VBINDS: string = "VBINDS\t"; + GET_OPARG(n, vector); + GET_DATA(o, vector, data); + goto OPARG_ARG; + /* OP_SETQ n{arg} + OP_PSETQ n{arg} + OP_SETQS var-name{symbol} + OP_PSETQS var-name{symbol} + Sets either the n-th local or a special variable VAR-NAME, + to either the value in VALUES(0) (OP_SETQ[S]) or to the + first value on the stack (OP_PSETQ[S]). + */ + case OP_SETQ: string = "SETQ\t"; + GET_OPARG(n, vector); + goto OPARG; + case OP_PSETQ: string = "PSETQ\t"; + GET_OPARG(n, vector); + goto OPARG; + case OP_VSETQ: string = "VSETQ\t"; + GET_OPARG(m, vector); + o = ecl_make_fixnum(m); + GET_OPARG(n, vector); + goto OPARG_ARG; + case OP_SETQS: string = "SETQS\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_PSETQS: string = "PSETQS\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_VSETQS: string = "VSETQS\t"; + GET_DATA(o, vector, data); + GET_OPARG(n, vector); + goto OPARG_ARG; - case OP_PROGV: vector = disassemble_progv(bytecodes, vector); - break; - case OP_EXIT_PROGV: print_noarg("PROGV\tEXIT"); - return vector; + case OP_PROGV: vector = disassemble_progv(bytecodes, vector); + break; + case OP_EXIT_PROGV: print_noarg("PROGV\tEXIT"); + return vector; - /* OP_VALUES n{arg} - Pop N values from the stack and store them in VALUES(...) - */ - case OP_VALUES: string = "VALUES\t"; - GET_OPARG(n, vector); - goto OPARG; - /* OP_NTHVAL - Set VALUES(0) to the N-th value of the VALUES(...) list. - The index N-th is extracted from the top of the stack. - */ - case OP_NTHVAL: string = "NTHVAL\t"; - goto NOARG; - case OP_TAGBODY: vector = disassemble_tagbody(bytecodes, vector); - break; - case OP_PROTECT: string = "PROTECT\t"; - goto JMP; - case OP_PROTECT_NORMAL: string = "PROTECT\tNORMAL"; - goto NOARG; - case OP_PROTECT_EXIT: string = "PROTECT\tEXIT"; - goto NOARG; - case OP_NIL: string = "QUOTE\tNIL"; - goto NOARG; - case OP_PUSHNIL: string = "PUSH\t'NIL"; - goto NOARG; - case OP_STEPIN: string = "STEP\tIN,"; - GET_DATA(o, vector, data); - goto ARG; - case OP_STEPOUT: string = "STEP\tOUT"; - goto NOARG; + /* OP_VALUES n{arg} + Pop N values from the stack and store them in VALUES(...) + */ + case OP_VALUES: string = "VALUES\t"; + GET_OPARG(n, vector); + goto OPARG; + /* OP_NTHVAL + Set VALUES(0) to the N-th value of the VALUES(...) list. + The index N-th is extracted from the top of the stack. + */ + case OP_NTHVAL: string = "NTHVAL\t"; + goto NOARG; + case OP_TAGBODY: vector = disassemble_tagbody(bytecodes, vector); + break; + case OP_PROTECT: string = "PROTECT\t"; + goto JMP; + case OP_PROTECT_NORMAL: string = "PROTECT\tNORMAL"; + goto NOARG; + case OP_PROTECT_EXIT: string = "PROTECT\tEXIT"; + goto NOARG; + case OP_NIL: string = "QUOTE\tNIL"; + goto NOARG; + case OP_PUSHNIL: string = "PUSH\t'NIL"; + goto NOARG; + case OP_STEPIN: string = "STEP\tIN,"; + GET_DATA(o, vector, data); + goto ARG; + case OP_STEPOUT: string = "STEP\tOUT"; + goto NOARG; - case OP_CONS: string = "CONS"; goto NOARG; - case OP_ENDP: string = "ENDP\tREG0"; goto NOARG; - case OP_CAR: string = "CAR\tREG0"; goto NOARG; - case OP_CDR: string = "CDR\tREG0"; goto NOARG; - case OP_LIST: string = "LIST\t"; - GET_OPARG(n, vector); - goto OPARG; - case OP_LISTA: string = "LIST*\t"; - GET_OPARG(n, vector); - goto OPARG; - case OP_CALLG1: string = "CALLG1\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_CALLG2: string = "CALLG2\t"; - GET_DATA(o, vector, data); - goto ARG; + case OP_CONS: string = "CONS"; goto NOARG; + case OP_ENDP: string = "ENDP\tREG0"; goto NOARG; + case OP_CAR: string = "CAR\tREG0"; goto NOARG; + case OP_CDR: string = "CDR\tREG0"; goto NOARG; + case OP_LIST: string = "LIST\t"; + GET_OPARG(n, vector); + goto OPARG; + case OP_LISTA: string = "LIST*\t"; + GET_OPARG(n, vector); + goto OPARG; + case OP_CALLG1: string = "CALLG1\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_CALLG2: string = "CALLG2\t"; + GET_DATA(o, vector, data); + goto ARG; - default: - FEerror("Unknown code ~S", 1, ecl_make_fixnum(*(vector-1))); - return vector; - NOARG: print_noarg(string); - break; - ARG: print_noarg(string); - @prin1(1, o); - break; - OPARG: print_oparg(string, n); - break; - OPARG_ARG: print_oparg_arg(string, n, o); - break; - } - goto BEGIN; + default: + FEerror("Unknown code ~S", 1, ecl_make_fixnum(*(vector-1))); + return vector; + NOARG: print_noarg(string); + break; + ARG: print_noarg(string); + @prin1(1, o); + break; + OPARG: print_oparg(string, n); + break; + OPARG_ARG: print_oparg_arg(string, n, o); + break; + } + goto BEGIN; } cl_object si_bc_disassemble(cl_object v) { - if (ecl_t_of(v) == t_bclosure) { - v = v->bclosure.code; - } - if (ecl_t_of(v) == t_bytecodes) { - disassemble_lambda(v); - @(return v) - } - @(return ECL_NIL) + if (ecl_t_of(v) == t_bclosure) { + v = v->bclosure.code; + } + if (ecl_t_of(v) == t_bytecodes) { + disassemble_lambda(v); + @(return v); + } + @(return ECL_NIL); } cl_object si_bc_split(cl_object b) { - cl_object vector, data, name, lex = ECL_NIL; + cl_object vector, data, name, lex = ECL_NIL; - if (ecl_t_of(b) == t_bclosure) { - b = b->bclosure.code; - lex = b->bclosure.lex; - } - if (ecl_t_of(b) != t_bytecodes) { - vector = ECL_NIL; - data = ECL_NIL; - name = ECL_NIL; - } else { - vector = ecl_alloc_simple_vector(b->bytecodes.code_size * - sizeof(cl_opcode), ecl_aet_b8); - vector->vector.self.b8 = (uint8_t*)b->bytecodes.code; - data = cl_copy_seq(b->bytecodes.data); - name = b->bytecodes.name; - } - @(return lex vector data name) + if (ecl_t_of(b) == t_bclosure) { + b = b->bclosure.code; + lex = b->bclosure.lex; + } + if (ecl_t_of(b) != t_bytecodes) { + vector = ECL_NIL; + data = ECL_NIL; + name = ECL_NIL; + } else { + vector = ecl_alloc_simple_vector(b->bytecodes.code_size * + sizeof(cl_opcode), ecl_aet_b8); + vector->vector.self.b8 = (uint8_t*)b->bytecodes.code; + data = cl_copy_seq(b->bytecodes.data); + name = b->bytecodes.name; + } + @(return lex vector data name); } cl_object si_bc_join(cl_object lex, cl_object code, cl_object data, cl_object name) { - cl_object output; - if (lex != ECL_NIL) { - output = ecl_alloc_object(t_bclosure); - output->bclosure.code = si_bc_join(ECL_NIL, code, data, name); - output->bclosure.lex = lex; - output->bclosure.entry = _ecl_bclosure_dispatch_vararg; - } else { - /* Ensure minimal sanity of data */ - unlikely_if (!ECL_VECTORP(code) || - (code->vector.elttype != ecl_aet_b8)) { - FEwrong_type_nth_arg(@[si::bc-join], - 0, code, - cl_list(2, - @'simple-array', - @'ext::byte8')); - } - unlikely_if (!ECL_VECTORP(code) || - (data->vector.elttype != ecl_aet_object)) { - FEwrong_type_nth_arg(@[si::bc-join], - 0, code, - cl_list(2, - @'simple-array', - ECL_T)); - } - /* Duplicate the vectors and steal their data pointers */ - code = cl_copy_seq(code); - data = cl_copy_seq(data); - output = ecl_alloc_object(t_bytecodes); - output->bytecodes.name = ECL_NIL; - output->bytecodes.definition = ECL_NIL; - output->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; - output->bytecodes.code_size = code->vector.fillp / sizeof(cl_opcode); - output->bytecodes.code = (void*)code->vector.self.b8; - output->bytecodes.data = data; - output->bytecodes.file = ECL_NIL; - output->bytecodes.file_position = ECL_NIL; - } - @(return output) + cl_object output; + if (lex != ECL_NIL) { + output = ecl_alloc_object(t_bclosure); + output->bclosure.code = si_bc_join(ECL_NIL, code, data, name); + output->bclosure.lex = lex; + output->bclosure.entry = _ecl_bclosure_dispatch_vararg; + } else { + /* Ensure minimal sanity of data */ + unlikely_if (!ECL_VECTORP(code) || + (code->vector.elttype != ecl_aet_b8)) { + FEwrong_type_nth_arg(@[si::bc-join], + 0, code, + cl_list(2, + @'simple-array', + @'ext::byte8')); + } + unlikely_if (!ECL_VECTORP(code) || + (data->vector.elttype != ecl_aet_object)) { + FEwrong_type_nth_arg(@[si::bc-join], + 0, code, + cl_list(2, + @'simple-array', + ECL_T)); + } + /* Duplicate the vectors and steal their data pointers */ + code = cl_copy_seq(code); + data = cl_copy_seq(data); + output = ecl_alloc_object(t_bytecodes); + output->bytecodes.name = ECL_NIL; + output->bytecodes.definition = ECL_NIL; + output->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; + output->bytecodes.code_size = code->vector.fillp / sizeof(cl_opcode); + output->bytecodes.code = (void*)code->vector.self.b8; + output->bytecodes.data = data; + output->bytecodes.file = ECL_NIL; + output->bytecodes.file_position = ECL_NIL; + } + @(return output); } diff --git a/src/c/dpp.c b/src/c/dpp.c index f1f8a916e..3b4d9b1df 100755 --- a/src/c/dpp.c +++ b/src/c/dpp.c @@ -1,74 +1,73 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - dpp.c -- Defun preprocessor. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ - + * dpp.c - defun preprocessor + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ /* - Usage: - dpp [in-file [out-file]] - - The file named in-file is preprocessed and the output will be - written to the file whose name is out-file. If in-file is "-" - program is read from standard input, while if out-file is "-" - C-program is written to standard output. - - - The function definition: - - @(defun name ({var}* - [&optional {var | (var [initform [svar]])}*] - [&rest var] - [&key {var | - ({var | (keyword var)} [initform [svar]])}* - [&allow_other_keys]] - [&aux {var | (var [initform])}*]) - - C-declaration - - @ - - C-body - - @) - - name can be either an identifier or a full C procedure header - enclosed in quotes ('). - - &optional may be abbreviated as &o. - &rest may be abbreviated as &r. - &key may be abbreviated as &k. - &allow_other_keys may be abbreviated as &aok. - &aux may be abbreviated as &a. - - Each variable becomes a C variable. - - Each supplied-p parameter becomes a boolean C variable. - - Initforms are C expressions. - If an expression contains non-alphanumeric characters, - it should be surrounded by backquotes (`). - - - Function return: - - @(return {form}*) - -*/ + * Usage: + * dpp [in-file [out-file]] + * + * The file named in-file is preprocessed and the output will be + * written to the file whose name is out-file. If in-file is "-" + * program is read from standard input, while if out-file is "-" + * C-program is written to standard output. + * + * + * The function definition: + * + * @(defun name ({var}* + * [&optional {var | (var [initform [svar]])}*] + * [&rest var] + * [&key {var | + * ({var | (keyword var)} [initform [svar]])}* + * [&allow_other_keys]] + * [&aux {var | (var [initform])}*]) + * + * C-declaration + * + * @ { + * + * C-body + * + * } @) + * + * name can be either an identifier or a full C procedure header + * enclosed in quotes ('). + * + * &optional may be abbreviated as &o. + * &rest may be abbreviated as &r. + * &key may be abbreviated as &k. + * &allow_other_keys may be abbreviated as &aok. + * &aux may be abbreviated as &a. + * + * Each variable becomes a C variable. + * + * Each supplied-p parameter becomes a boolean C variable. + * + * Initforms are C expressions. + * If an expression contains non-alphanumeric characters, + * it should be surrounded by backquotes (`). + * + * + * Function return: + * + * @(return {form}*); + * + * Return function expands into a lexical block {}, so if it's + * used inside IF/ELSE, then it should be enclosed, even if we + * use sole @(return);, because ";" will be treated as the next + * instruction. + * + */ #include #include @@ -115,9 +114,9 @@ int nreq; int the_env_defined = 0; struct optional { - char *o_var; - char *o_init; - char *o_svar; + char *o_var; + char *o_init; + char *o_svar; } optional[MAXOPT]; int nopt; @@ -126,17 +125,17 @@ char *rest_var; bool key_flag; struct keyword { - char *k_key; - char *k_var; - char *k_init; - char *k_svar; + char *k_key; + char *k_var; + char *k_init; + char *k_svar; } keyword[MAXKEY]; int nkey; bool allow_other_keys_flag; struct aux { - char *a_var; - char *a_init; + char *a_var; + char *a_init; } aux[MAXAUX]; int naux; @@ -146,511 +145,511 @@ int nres; void put_lineno(void) { - static int flag = 0; - if (flag) - fprintf(out, "#line %d\n", lineno); - else { - flag++; - fprintf(out, "#line %d \"%s\"\n", lineno, filename); - } + static int flag = 0; + if (flag) + fprintf(out, "#line %d\n", lineno); + else { + flag++; + fprintf(out, "#line %d \"%s\"\n", lineno, filename); + } } void error(char *s) { - printf("Error in line %d: %s.\n", lineno, s); - exit(1); + printf("Error in line %d: %s.\n", lineno, s); + exit(1); } void error_symbol(char *s) { - printf("Error in line %d: illegal symbol %s.\n", lineno, s); - exit(1); + printf("Error in line %d: illegal symbol %s.\n", lineno, s); + exit(1); } int readc(void) { - int c; + int c; - c = getc(in); - if (feof(in)) { - if (function != NULL) - error("unexpected end of file"); - exit(0); - } - if (c == '\n') { - lineno++; - tab = 0; - } else if (c == '\t') - tab++; - return(c); + c = getc(in); + if (feof(in)) { + if (function != NULL) + error("unexpected end of file"); + exit(0); + } + if (c == '\n') { + lineno++; + tab = 0; + } else if (c == '\t') + tab++; + return(c); } int nextc(void) { - int c; + int c; - while (isspace(c = readc())) - ; - return(c); + while (isspace(c = readc())) + ; + return(c); } void unreadc(int c) { - if (c == '\n') - --lineno; - else if (c == '\t') - --tab; - ungetc(c, in); + if (c == '\n') + --lineno; + else if (c == '\t') + --tab; + ungetc(c, in); } void put_tabs(int n) { - put_lineno(); - while (n--) - putc('\t', out); + put_lineno(); + while (n--) + putc('\t', out); } void pushc(int c) { - if (poolp >= &pool[POOLSIZE]) - error("buffer pool overflow"); - *poolp++ = c; + if (poolp >= &pool[POOLSIZE]) + error("buffer pool overflow"); + *poolp++ = c; } void pushstr(const char *s) { - while (*s) - pushc(*(s++)); + while (*s) + pushc(*(s++)); } int search_keyword(const char *name) { - int i; - char c[256]; + int i; + char c[256]; - for (i=0; name[i] && i<255; i++) - if (name[i] == '_') - c[i] = '-'; - else - c[i] = name[i]; - if (i == 255) - error("Too long keyword"); - c[i] = 0; - for (i = 0; cl_symbols[i].name != NULL; i++) { - if (cl_symbols[i].name[0] == ':') - if (!strcasecmp(c, cl_symbols[i].name+1)) - return i; - } - printf("Keyword not found: %s.\n", c); - return 0; + for (i=0; name[i] && i<255; i++) + if (name[i] == '_') + c[i] = '-'; + else + c[i] = name[i]; + if (i == 255) + error("Too long keyword"); + c[i] = 0; + for (i = 0; cl_symbols[i].name != NULL; i++) { + if (cl_symbols[i].name[0] == ':') + if (!strcasecmp(c, cl_symbols[i].name+1)) + return i; + } + printf("Keyword not found: %s.\n", c); + return 0; } char * search_symbol(char *name, int *symbol_code, int code) { - int i; - for (i = 0; cl_symbols[i].name != NULL; i++) { - if (!strcasecmp(name, cl_symbols[i].name)) { - name = poolp; - if (code) { - pushstr("ecl_make_fixnum(/*"); - pushstr(cl_symbols[i].name); - pushstr("*/"); - if (i >= 1000) - pushc((i / 1000) % 10 + '0'); - if (i >= 100) - pushc((i / 100) % 10 + '0'); - if (i >= 10) - pushc((i / 10) % 10 + '0'); - pushc(i % 10 + '0'); - pushstr(")"); - pushc(0); - } else if (i == 0) { - pushstr("ECL_NIL"); - pushc(0); - } else { - pushstr("ECL_SYM(\""); - pushstr(cl_symbols[i].name); - pushstr("\","); - if (i >= 1000) - pushc((i / 1000) % 10 + '0'); - if (i >= 100) - pushc((i / 100) % 10 + '0'); - if (i >= 10) - pushc((i / 10) % 10 + '0'); - pushc(i % 10 + '0'); - pushstr(")"); - pushc(0); - } - if (symbol_code) - *symbol_code = i; - return name; - } - } - return NULL; + int i; + for (i = 0; cl_symbols[i].name != NULL; i++) { + if (!strcasecmp(name, cl_symbols[i].name)) { + name = poolp; + if (code) { + pushstr("ecl_make_fixnum(/*"); + pushstr(cl_symbols[i].name); + pushstr("*/"); + if (i >= 1000) + pushc((i / 1000) % 10 + '0'); + if (i >= 100) + pushc((i / 100) % 10 + '0'); + if (i >= 10) + pushc((i / 10) % 10 + '0'); + pushc(i % 10 + '0'); + pushstr(")"); + pushc(0); + } else if (i == 0) { + pushstr("ECL_NIL"); + pushc(0); + } else { + pushstr("ECL_SYM(\""); + pushstr(cl_symbols[i].name); + pushstr("\","); + if (i >= 1000) + pushc((i / 1000) % 10 + '0'); + if (i >= 100) + pushc((i / 100) % 10 + '0'); + if (i >= 10) + pushc((i / 10) % 10 + '0'); + pushc(i % 10 + '0'); + pushstr(")"); + pushc(0); + } + if (symbol_code) + *symbol_code = i; + return name; + } + } + return NULL; } char * read_symbol(int code) { - char c, *name = poolp; - char end = code? ']' : '\''; + char c, *name = poolp; + char end = code? ']' : '\''; - c = readc(); - while (c != end) { - if (c == '_') c = '-'; - pushc(c); - c = readc(); - } - pushc(0); + c = readc(); + while (c != end) { + if (c == '_') c = '-'; + pushc(c); + c = readc(); + } + pushc(0); - name = search_symbol(poolp = name, 0, code); - if (name == NULL) { - name = poolp; - printf("\nUnknown symbol: %s\n", name); - pushstr("unknown"); - } - return name; + name = search_symbol(poolp = name, 0, code); + if (name == NULL) { + name = poolp; + printf("\nUnknown symbol: %s\n", name); + pushstr("unknown"); + } + return name; } char * search_function(char *name) { - int i; - for (i = 0; cl_symbols[i].name != NULL; i++) { - if (cl_symbols[i].translation != NULL && - !strcasecmp(name, cl_symbols[i].name)) { - name = poolp; - pushstr(cl_symbols[i].translation); - pushc(0); - return name; - } - } - return name; + int i; + for (i = 0; cl_symbols[i].name != NULL; i++) { + if (cl_symbols[i].translation != NULL && + !strcasecmp(name, cl_symbols[i].name)) { + name = poolp; + pushstr(cl_symbols[i].translation); + pushc(0); + return name; + } + } + return name; } char * read_function() { - char c, *name = poolp; + char c, *name = poolp; - c = readc(); - if (c == '"') { - c = readc(); - while (c != '"') { - pushc(c); - c = readc(); - } - pushc(0); - return name; - } - while (c != '(' && !isspace(c) && c != ')' && c != ',') { - if (c == '_') c = '-'; - pushc(c); - c = readc(); - } - unreadc(c); - pushc(0); - return name; + c = readc(); + if (c == '"') { + c = readc(); + while (c != '"') { + pushc(c); + c = readc(); + } + pushc(0); + return name; + } + while (c != '(' && !isspace(c) && c != ')' && c != ',') { + if (c == '_') c = '-'; + pushc(c); + c = readc(); + } + unreadc(c); + pushc(0); + return name; } char * translate_function(char *name) { - char *output = search_function(name); - if (output == NULL) { - printf("\nUnknown function: %s\n", name); - pushstr("unknown"); - output = poolp; - } - return output; + char *output = search_function(name); + if (output == NULL) { + printf("\nUnknown function: %s\n", name); + pushstr("unknown"); + output = poolp; + } + return output; } char * read_token(void) { - int c; - int left_paren = 0; - char *p; + int c; + int left_paren = 0; + char *p; - p = poolp; + p = poolp; + c = readc(); + while (isspace(c)) + c = readc(); + do { + if (c == '(') { + left_paren++; + pushc(c); + } else if (c == ')') { + if (left_paren == 0) { + break; + } else { + left_paren--; + pushc(c); + } + } else if (isspace(c) && left_paren == 0) { + do c = readc(); - while (isspace(c)) - c = readc(); - do { - if (c == '(') { - left_paren++; - pushc(c); - } else if (c == ')') { - if (left_paren == 0) { - break; - } else { - left_paren--; - pushc(c); - } - } else if (isspace(c) && left_paren == 0) { - do - c = readc(); - while (isspace(c)); - break; - } else if (c == '@') { - c = readc(); - if (c == '\'') { - (void)read_symbol(0); - poolp--; - } else if (c == '[') { - (void)read_symbol(1); - poolp--; - } else if (c == '@') { - pushc(c); - } else { - char *name; - unreadc(c); - poolp = name = read_function(); - (void)translate_function(poolp); - } - } else { - pushc(c); - } - c = readc(); - } while (1); + while (isspace(c)); + break; + } else if (c == '@') { + c = readc(); + if (c == '\'') { + (void)read_symbol(0); + poolp--; + } else if (c == '[') { + (void)read_symbol(1); + poolp--; + } else if (c == '@') { + pushc(c); + } else { + char *name; unreadc(c); - pushc('\0'); - return(p); + poolp = name = read_function(); + (void)translate_function(poolp); + } + } else { + pushc(c); + } + c = readc(); + } while (1); + unreadc(c); + pushc('\0'); + return(p); } void reset(void) { - int i; + int i; - the_env_defined = 0; - poolp = pool; - function = NULL; - function_symbol = ""; - function_c_name = ""; - nreq = 0; - for (i = 0; i < MAXREQ; i++) - required[i] = NULL; - nopt = 0; - for (i = 0; i < MAXOPT; i++) - optional[i].o_var - = optional[i].o_init - = optional[i].o_svar - = NULL; - rest_flag = FALSE; - rest_var = "ARGS"; - key_flag = FALSE; - nkey = 0; - for (i = 0; i < MAXKEY; i++) - keyword[i].k_key - = keyword[i].k_var - = keyword[i].k_init - = keyword[i].k_svar - = NULL; - allow_other_keys_flag = FALSE; - naux = 0; - for (i = 0; i < MAXAUX; i++) - aux[i].a_var - = aux[i].a_init - = NULL; + the_env_defined = 0; + poolp = pool; + function = NULL; + function_symbol = ""; + function_c_name = ""; + nreq = 0; + for (i = 0; i < MAXREQ; i++) + required[i] = NULL; + nopt = 0; + for (i = 0; i < MAXOPT; i++) + optional[i].o_var + = optional[i].o_init + = optional[i].o_svar + = NULL; + rest_flag = FALSE; + rest_var = "ARGS"; + key_flag = FALSE; + nkey = 0; + for (i = 0; i < MAXKEY; i++) + keyword[i].k_key + = keyword[i].k_var + = keyword[i].k_init + = keyword[i].k_svar + = NULL; + allow_other_keys_flag = FALSE; + naux = 0; + for (i = 0; i < MAXAUX; i++) + aux[i].a_var + = aux[i].a_init + = NULL; } void get_function(void) { - function = read_function(); - function_symbol = search_symbol(function, &function_code, 0); - if (function_symbol == NULL) { - function_symbol = poolp; - pushstr("ECL_NIL"); - pushc('\0'); - } - function_c_name = translate_function(function); + function = read_function(); + function_symbol = search_symbol(function, &function_code, 0); + if (function_symbol == NULL) { + function_symbol = poolp; + pushstr("ECL_NIL"); + pushc('\0'); + } + function_c_name = translate_function(function); } void get_lambda_list(void) { - int c; - char *p; + int c; + char *p; - if ((c = nextc()) != '(') - error("( expected"); - for (;;) { - if ((c = nextc()) == ')') - return; - if (c == '&') { - p = read_token(); - goto _OPT; - } - unreadc(c); - p = read_token(); - if (nreq >= MAXREQ) - error("too many required variables"); - required[nreq++] = p; - } + if ((c = nextc()) != '(') + error("( expected"); + for (;;) { + if ((c = nextc()) == ')') + return; + if (c == '&') { + p = read_token(); + goto _OPT; + } + unreadc(c); + p = read_token(); + if (nreq >= MAXREQ) + error("too many required variables"); + required[nreq++] = p; + } -_OPT: - if (strcmp(p, "optional") != 0 && strcmp(p, "o") != 0) - goto _REST; - for (;; nopt++) { - if ((c = nextc()) == ')') - return; - if (c == '&') { - p = read_token(); - goto _REST; - } - if (nopt >= MAXOPT) - error("too many optional argument"); - if (c == '(') { - optional[nopt].o_var = read_token(); - if ((c = nextc()) == ')') - continue; - unreadc(c); - optional[nopt].o_init = read_token(); - if ((c = nextc()) == ')') - continue; - unreadc(c); - optional[nopt].o_svar = read_token(); - if (nextc() != ')') - error(") expected"); - } else { - unreadc(c); - optional[nopt].o_var = read_token(); - } - } + _OPT: + if (strcmp(p, "optional") != 0 && strcmp(p, "o") != 0) + goto _REST; + for (;; nopt++) { + if ((c = nextc()) == ')') + return; + if (c == '&') { + p = read_token(); + goto _REST; + } + if (nopt >= MAXOPT) + error("too many optional argument"); + if (c == '(') { + optional[nopt].o_var = read_token(); + if ((c = nextc()) == ')') + continue; + unreadc(c); + optional[nopt].o_init = read_token(); + if ((c = nextc()) == ')') + continue; + unreadc(c); + optional[nopt].o_svar = read_token(); + if (nextc() != ')') + error(") expected"); + } else { + unreadc(c); + optional[nopt].o_var = read_token(); + } + } -_REST: - if (strcmp(p, "rest") != 0 && strcmp(p, "r") != 0) - goto _KEY; - rest_flag = TRUE; - if ((c = nextc()) == ')' || c == '&') - error("&rest var missing"); - unreadc(c); - rest_var = read_token(); + _REST: + if (strcmp(p, "rest") != 0 && strcmp(p, "r") != 0) + goto _KEY; + rest_flag = TRUE; + if ((c = nextc()) == ')' || c == '&') + error("&rest var missing"); + unreadc(c); + rest_var = read_token(); + if ((c = nextc()) == ')') + return; + if (c != '&') + error("& expected"); + p = read_token(); + + _KEY: + if (strcmp(p, "key") != 0 && strcmp(p, "k") != 0) + goto _AUX; + key_flag = TRUE; + for (;; nkey++) { + if ((c = nextc()) == ')') + return; + if (c == '&') { + p = read_token(); + if (strcmp(p, "allow_other_keys") == 0 || + strcmp(p, "aok") == 0) { + allow_other_keys_flag = TRUE; if ((c = nextc()) == ')') - return; + return; if (c != '&') - error("& expected"); + error("& expected"); p = read_token(); + } + goto _AUX; + } + if (nkey >= MAXKEY) + error("too many optional argument"); + if (c == '(') { + if ((c = nextc()) == '(') { + p = read_token(); + if (p[0] != ':' || p[1] == '\0') + error("keyword expected"); + keyword[nkey].k_key = p + 1; + keyword[nkey].k_var = read_token(); + if (nextc() != ')') + error(") expected"); + } else { + unreadc(c); + keyword[nkey].k_key + = keyword[nkey].k_var + = read_token(); + } + if ((c = nextc()) == ')') + continue; + unreadc(c); + keyword[nkey].k_init = read_token(); + if ((c = nextc()) == ')') + continue; + unreadc(c); + keyword[nkey].k_svar = read_token(); + if (nextc() != ')') + error(") expected"); + } else { + unreadc(c); + keyword[nkey].k_key + = keyword[nkey].k_var + = read_token(); + } + } -_KEY: - if (strcmp(p, "key") != 0 && strcmp(p, "k") != 0) - goto _AUX; - key_flag = TRUE; - for (;; nkey++) { - if ((c = nextc()) == ')') - return; - if (c == '&') { - p = read_token(); - if (strcmp(p, "allow_other_keys") == 0 || - strcmp(p, "aok") == 0) { - allow_other_keys_flag = TRUE; - if ((c = nextc()) == ')') - return; - if (c != '&') - error("& expected"); - p = read_token(); - } - goto _AUX; - } - if (nkey >= MAXKEY) - error("too many optional argument"); - if (c == '(') { - if ((c = nextc()) == '(') { - p = read_token(); - if (p[0] != ':' || p[1] == '\0') - error("keyword expected"); - keyword[nkey].k_key = p + 1; - keyword[nkey].k_var = read_token(); - if (nextc() != ')') - error(") expected"); - } else { - unreadc(c); - keyword[nkey].k_key - = keyword[nkey].k_var - = read_token(); - } - if ((c = nextc()) == ')') - continue; - unreadc(c); - keyword[nkey].k_init = read_token(); - if ((c = nextc()) == ')') - continue; - unreadc(c); - keyword[nkey].k_svar = read_token(); - if (nextc() != ')') - error(") expected"); - } else { - unreadc(c); - keyword[nkey].k_key - = keyword[nkey].k_var - = read_token(); - } - } - -_AUX: - if (strcmp(p, "aux") != 0 && strcmp(p, "a") != 0) - error("illegal lambda-list keyword"); - for (;;) { - if ((c = nextc()) == ')') - return; - if (c == '&') - error("illegal lambda-list keyword"); - if (naux >= MAXAUX) - error("too many auxiliary variable"); - if (c == '(') { - aux[naux].a_var = read_token(); - if ((c = nextc()) == ')') - continue; - unreadc(c); - aux[naux].a_init = read_token(); - if (nextc() != ')') - error(") expected"); - } else { - unreadc(c); - aux[naux].a_var = read_token(); - } - naux++; - } + _AUX: + if (strcmp(p, "aux") != 0 && strcmp(p, "a") != 0) + error("illegal lambda-list keyword"); + for (;;) { + if ((c = nextc()) == ')') + return; + if (c == '&') + error("illegal lambda-list keyword"); + if (naux >= MAXAUX) + error("too many auxiliary variable"); + if (c == '(') { + aux[naux].a_var = read_token(); + if ((c = nextc()) == ')') + continue; + unreadc(c); + aux[naux].a_init = read_token(); + if (nextc() != ')') + error(") expected"); + } else { + unreadc(c); + aux[naux].a_var = read_token(); + } + naux++; + } } void get_return(void) { - int c; + int c; - nres = 0; - for (;;) { - if ((c = nextc()) == ')') - return; - unreadc(c); - result[nres++] = read_token(); - } + nres = 0; + for (;;) { + if ((c = nextc()) == ')') + return; + unreadc(c); + result[nres++] = read_token(); + } } void put_fhead(void) { - int i; + int i; - put_lineno(); - fprintf(out, "cl_object %s(cl_narg narg", function_c_name); - for (i = 0; i < nreq; i++) - fprintf(out, ", cl_object %s", required[i]); - if (nopt > 0 || rest_flag || key_flag) - fprintf(out, ", ..."); - fprintf(out, ")\n{\n"); + put_lineno(); + fprintf(out, "cl_object %s(cl_narg narg", function_c_name); + for (i = 0; i < nreq; i++) + fprintf(out, ", cl_object %s", required[i]); + if (nopt > 0 || rest_flag || key_flag) + fprintf(out, ", ..."); + fprintf(out, ")\n{\n"); } void @@ -712,12 +711,12 @@ put_declaration(void) } put_lineno(); if (simple_varargs) - fprintf(out,"\tva_list %s;\n\tva_start(%s, %s);\n", - rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg")); + fprintf(out,"\tva_list %s;\n\tva_start(%s, %s);\n", + rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg")); else - fprintf(out,"\tecl_va_list %s;\n\tecl_va_start(%s, %s, narg, %d);\n", - rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg"), - nreq); + fprintf(out,"\tecl_va_list %s;\n\tecl_va_start(%s, %s, narg, %d);\n", + rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg"), + nreq); put_lineno(); fprintf(out, "\tif (ecl_unlikely(narg < %d", nreq); if (nopt > 0 && !rest_flag && !key_flag) { @@ -787,149 +786,149 @@ put_declaration(void) void put_return(void) { - int i, t; + int i, t; - t = tab_save+1; + t = tab_save+1; - fprintf(out, "{\n"); - if (!the_env_defined) { - put_tabs(t); - fprintf(out, "const cl_env_ptr the_env = ecl_process_env();\n"); - } - if (nres == 0) { - fprintf(out, "the_env->nvalues = 0; return ECL_NIL;\n"); - } else { - put_tabs(t); - for (i = 0; i < nres; i++) { - put_tabs(t); - fprintf(out, "cl_object __value%d = %s;\n", i, result[i]); - } - put_tabs(t); - fprintf(out, "the_env->nvalues = %d;\n", nres); - for (i = nres-1; i > 0; i--) { - put_tabs(t); - fprintf(out, "the_env->values[%d] = __value%d;\n", i, i); - } - put_tabs(t); - fprintf(out, "return __value0;\n"); - } - put_tabs(tab_save); - fprintf(out, "}\n"); + fprintf(out, "{\n"); + if (!the_env_defined) { + put_tabs(t); + fprintf(out, "const cl_env_ptr the_env = ecl_process_env();\n"); + } + if (nres == 0) { + fprintf(out, "the_env->nvalues = 0; return ECL_NIL;\n"); + } else { + put_tabs(t); + for (i = 0; i < nres; i++) { + put_tabs(t); + fprintf(out, "cl_object __value%d = %s;\n", i, result[i]); + } + put_tabs(t); + fprintf(out, "the_env->nvalues = %d;\n", nres); + for (i = nres-1; i > 0; i--) { + put_tabs(t); + fprintf(out, "the_env->values[%d] = __value%d;\n", i, i); + } + put_tabs(t); + fprintf(out, "return __value0;\n"); + } + put_tabs(tab_save); + fprintf(out, "}\n"); } int jump_to_at(void) { - int c; + int c; GO_ON: - while ((c = readc()) != '@') - putc(c, out); - if ((c = readc()) == '@') { - putc(c, out); - goto GO_ON; - } - return c; + while ((c = readc()) != '@') + putc(c, out); + if ((c = readc()) == '@') { + putc(c, out); + goto GO_ON; + } + return c; } void main_loop(void) { - int c; - int in_defun=0; - char *p; + int c; + int in_defun=0; + char *p; - lineno = 1; + lineno = 1; - reset(); - put_lineno(); -LOOP: - c = jump_to_at(); - if (c == ')') { - if (!in_defun) - error("unmatched @) found"); - in_defun = 0; - putc('}',out); - reset(); - goto LOOP; - } else if (c == '\'') { - char *p; - poolp = pool; - p = read_symbol(0); - pushc('\0'); - fprintf(out,"%s",p); - goto LOOP; - } else if (c == '[') { - char *p; - poolp = pool; - p = read_symbol(1); - pushc('\0'); - fprintf(out,"%s",p); - goto LOOP; - } else if (c != '(') { - char *p; - unreadc(c); - poolp = pool; - poolp = p = read_function(); - fprintf(out,"%s",translate_function(poolp)); - goto LOOP; - } - p = read_token(); - if (strcmp(p, "defun") == 0) { - if (in_defun) - error("@) expected before new function definition"); - in_defun = 1; - get_function(); - get_lambda_list(); - put_fhead(); - put_lineno(); - c = jump_to_at(); - put_declaration(); - put_lineno(); - } else if (strcmp(p, "return") == 0) { - tab_save = tab; - get_return(); - put_return(); - } else - error_symbol(p); - goto LOOP; + reset(); + put_lineno(); + LOOP: + c = jump_to_at(); + if (c == ')') { + if (!in_defun) + error("unmatched @) found"); + in_defun = 0; + putc('}',out); + reset(); + goto LOOP; + } else if (c == '\'') { + char *p; + poolp = pool; + p = read_symbol(0); + pushc('\0'); + fprintf(out,"%s",p); + goto LOOP; + } else if (c == '[') { + char *p; + poolp = pool; + p = read_symbol(1); + pushc('\0'); + fprintf(out,"%s",p); + goto LOOP; + } else if (c != '(') { + char *p; + unreadc(c); + poolp = pool; + poolp = p = read_function(); + fprintf(out,"%s",translate_function(poolp)); + goto LOOP; + } + p = read_token(); + if (strcmp(p, "defun") == 0) { + if (in_defun) + error("@) expected before new function definition"); + in_defun = 1; + get_function(); + get_lambda_list(); + put_fhead(); + put_lineno(); + c = jump_to_at(); + put_declaration(); + put_lineno(); + } else if (strcmp(p, "return") == 0) { + tab_save = tab; + get_return(); + put_return(); + } else + error_symbol(p); + goto LOOP; } int main(int argc, char **argv) { - char outfile[BUFSIZ]; + char outfile[BUFSIZ]; #ifdef _MSC_VER - char *p; + char *p; #endif - if (argc < 2 || !strcmp(argv[1],"-")) { - in = stdin; - strcpy(filename, "-"); - } else { - in = fopen(argv[1],"r"); - strncpy(filename, argv[1], BUFSIZ-1); - filename[BUFSIZ-1] = '\0'; - } + if (argc < 2 || !strcmp(argv[1],"-")) { + in = stdin; + strcpy(filename, "-"); + } else { + in = fopen(argv[1],"r"); + strncpy(filename, argv[1], BUFSIZ-1); + filename[BUFSIZ-1] = '\0'; + } #ifdef _MSC_VER - /* Convert all backslashes in filename into slashes, - * to avoid warnings when compiling with MSVC - */ - for ( p=filename; *p; p++ ) - if ( *p == '\\' ) - *p = '/'; + /* Convert all backslashes in filename into slashes, + * to avoid warnings when compiling with MSVC + */ + for ( p=filename; *p; p++ ) + if ( *p == '\\' ) + *p = '/'; #endif - if (argc < 3 || !strcmp(argv[2],"-")) { - out = stdout; - strcpy(outfile, "-"); - } else { - out = fopen(argv[2],"w"); - strncpy(outfile, argv[2], BUFSIZ-1); - outfile[BUFSIZ-1] = '\0'; - } - if (in == NULL) - error("can't open input file"); - if (out == NULL) - error("can't open output file"); - printf("dpp: %s -> %s\n", filename, outfile); - main_loop(); - return 0; + if (argc < 3 || !strcmp(argv[2],"-")) { + out = stdout; + strcpy(outfile, "-"); + } else { + out = fopen(argv[2],"w"); + strncpy(outfile, argv[2], BUFSIZ-1); + outfile[BUFSIZ-1] = '\0'; + } + if (in == NULL) + error("can't open input file"); + if (out == NULL) + error("can't open output file"); + printf("dpp: %s -> %s\n", filename, outfile); + main_loop(); + return 0; } diff --git a/src/c/ecl_constants.h b/src/c/ecl_constants.h index d3a21a578..ce7ccda23 100644 --- a/src/c/ecl_constants.h +++ b/src/c/ecl_constants.h @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - ecl_constants.c -- constant values for all_symbols.d -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ + * ecl_constants.h - contstant values for all_symbols.d + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include diff --git a/src/c/ecl_features.h b/src/c/ecl_features.h index 02578b21d..3d9b1d1de 100644 --- a/src/c/ecl_features.h +++ b/src/c/ecl_features.h @@ -1,120 +1,115 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - features.h -- names of features compiled into ECL -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ + * features.h - names of features compiled into ECL + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ ecl_def_string_array(feature_names,static,const) = { - ecl_def_string_array_elt("ECL"), - ecl_def_string_array_elt("COMMON"), - ecl_def_string_array_elt(ECL_ARCHITECTURE), - ecl_def_string_array_elt("FFI"), - ecl_def_string_array_elt("PREFIXED-API"), + ecl_def_string_array_elt("ECL"), + ecl_def_string_array_elt("COMMON"), + ecl_def_string_array_elt(ECL_ARCHITECTURE), + ecl_def_string_array_elt("FFI"), + ecl_def_string_array_elt("PREFIXED-API"), #ifdef ECL_IEEE_FP - ecl_def_string_array_elt("IEEE-FLOATING-POINT"), + ecl_def_string_array_elt("IEEE-FLOATING-POINT"), #endif - ecl_def_string_array_elt("COMMON-LISP"), - ecl_def_string_array_elt("ANSI-CL"), + ecl_def_string_array_elt("COMMON-LISP"), + ecl_def_string_array_elt("ANSI-CL"), #if defined(GBC_BOEHM) - ecl_def_string_array_elt("BOEHM-GC"), + ecl_def_string_array_elt("BOEHM-GC"), #endif #ifdef ECL_THREADS - ecl_def_string_array_elt("THREADS"), + ecl_def_string_array_elt("THREADS"), #endif - ecl_def_string_array_elt("CLOS"), + ecl_def_string_array_elt("CLOS"), #ifdef ENABLE_DLOPEN - ecl_def_string_array_elt("DLOPEN"), + ecl_def_string_array_elt("DLOPEN"), #endif - ecl_def_string_array_elt("ECL-PDE"), + ecl_def_string_array_elt("ECL-PDE"), #if defined(unix) || defined(netbsd) || defined(openbsd) || defined(linux) || defined(darwin) || \ - defined(freebsd) || defined(dragonfly) || defined(kfreebsd) || defined(gnu) || defined(nsk) - ecl_def_string_array_elt("UNIX"), + defined(freebsd) || defined(dragonfly) || defined(kfreebsd) || defined(gnu) || defined(nsk) + ecl_def_string_array_elt("UNIX"), #endif #ifdef BSD - ecl_def_string_array_elt("BSD"), + ecl_def_string_array_elt("BSD"), #endif #ifdef SYSV - ecl_def_string_array_elt("SYSTEM-V"), + ecl_def_string_array_elt("SYSTEM-V"), #endif #if defined(__MINGW32__) - ecl_def_string_array_elt("MINGW32"), - ecl_def_string_array_elt("WIN32"), + ecl_def_string_array_elt("MINGW32"), + ecl_def_string_array_elt("WIN32"), #endif #if defined(__WIN64__) - ecl_def_string_array_elt("WIN64"), + ecl_def_string_array_elt("WIN64"), #endif #ifdef _MSC_VER - ecl_def_string_array_elt("MSVC"), + ecl_def_string_array_elt("MSVC"), #endif #if defined(ECL_MS_WINDOWS_HOST) - ecl_def_string_array_elt("WINDOWS"), + ecl_def_string_array_elt("WINDOWS"), #endif #ifdef ECL_CMU_FORMAT - ecl_def_string_array_elt("CMU-FORMAT"), + ecl_def_string_array_elt("CMU-FORMAT"), #endif #ifdef ECL_CLOS_STREAMS - ecl_def_string_array_elt("CLOS-STREAMS"), + ecl_def_string_array_elt("CLOS-STREAMS"), #endif #if defined(HAVE_LIBFFI) - ecl_def_string_array_elt("DFFI"), + ecl_def_string_array_elt("DFFI"), #endif #ifdef ECL_UNICODE - ecl_def_string_array_elt("UNICODE"), + ecl_def_string_array_elt("UNICODE"), #endif #ifdef ECL_LONG_FLOAT - ecl_def_string_array_elt("LONG-FLOAT"), + ecl_def_string_array_elt("LONG-FLOAT"), #endif #ifdef ECL_RELATIVE_PACKAGE_NAMES - ecl_def_string_array_elt("RELATIVE-PACKAGE-NAMES"), + ecl_def_string_array_elt("RELATIVE-PACKAGE-NAMES"), #endif #ifdef ecl_uint16_t - ecl_def_string_array_elt("UINT16-T"), + ecl_def_string_array_elt("UINT16-T"), #endif #ifdef ecl_uint32_t - ecl_def_string_array_elt("UINT32-T"), + ecl_def_string_array_elt("UINT32-T"), #endif #ifdef ecl_uint64_t - ecl_def_string_array_elt("UINT64-T"), + ecl_def_string_array_elt("UINT64-T"), #endif #ifdef ecl_long_long_t - ecl_def_string_array_elt("LONG-LONG"), + ecl_def_string_array_elt("LONG-LONG"), #endif #ifdef ECL_EXTERNALIZABLE - ecl_def_string_array_elt("EXTERNALIZABLE"), + ecl_def_string_array_elt("EXTERNALIZABLE"), #endif #ifdef __cplusplus - ecl_def_string_array_elt("C++"), + ecl_def_string_array_elt("C++"), #endif #ifdef ECL_SSE2 - ecl_def_string_array_elt("SSE2"), + ecl_def_string_array_elt("SSE2"), #endif #ifdef ECL_SEMAPHORES - ecl_def_string_array_elt("SEMAPHORES"), + ecl_def_string_array_elt("SEMAPHORES"), #endif #ifdef ECL_RWLOCK - ecl_def_string_array_elt("ECL-READ-WRITE-LOCK"), + ecl_def_string_array_elt("ECL-READ-WRITE-LOCK"), #endif #ifdef WORDS_BIGENDIAN - ecl_def_string_array_elt("BIG-ENDIAN"), + ecl_def_string_array_elt("BIG-ENDIAN"), #else - ecl_def_string_array_elt("LITTLE-ENDIAN"), + ecl_def_string_array_elt("LITTLE-ENDIAN"), #endif #ifdef ECL_WEAK_HASH - ecl_def_string_array_elt("ECL-WEAK-HASH"), + ecl_def_string_array_elt("ECL-WEAK-HASH"), #endif - ecl_def_string_array_elt(0) + ecl_def_string_array_elt(0) }; diff --git a/src/c/error.d b/src/c/error.d index 82b540ee1..c7d6beb0e 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - error.c -- Error handling. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ + * error.d - error handling + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -32,73 +27,73 @@ static cl_object cl_symbol_or_object(cl_object x) { - if (ECL_FIXNUMP(x)) - return (cl_object)(cl_symbols + ecl_fixnum(x)); - return x; + if (ECL_FIXNUMP(x)) + return (cl_object)(cl_symbols + ecl_fixnum(x)); + return x; } void _ecl_unexpected_return() { - ecl_internal_error( -"*** \n" -"*** A call to ERROR returned without handling the error.\n" -"*** This should have never happened and is usually a signal\n" -"*** that the debugger or the universal error handler were\n" -"*** improperly coded or altered. Please contact the maintainers\n" -"***\n"); + ecl_internal_error( + "*** \n" + "*** A call to ERROR returned without handling the error.\n" + "*** This should have never happened and is usually a signal\n" + "*** that the debugger or the universal error handler were\n" + "*** improperly coded or altered. Please contact the maintainers\n" + "***\n"); } void ecl_internal_error(const char *s) { - int saved_errno = errno; - fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s); - if (saved_errno) { - fprintf(stderr, " [%d: %s]\n", saved_errno, - strerror(saved_errno)); - } - fflush(stderr); - si_dump_c_backtrace(ecl_make_fixnum(32)); + int saved_errno = errno; + fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s); + if (saved_errno) { + fprintf(stderr, " [%d: %s]\n", saved_errno, + strerror(saved_errno)); + } + fflush(stderr); + si_dump_c_backtrace(ecl_make_fixnum(32)); #ifdef SIGIOT - signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */ + signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */ #endif - abort(); + abort(); } void ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) { - /* - * Right now we have no means of specifying a jump point - * for really bad events. We just jump to the outermost - * frame, which is equivalent to quitting, and wait for - * someone to intercept this jump. - */ - ecl_frame_ptr destination; - cl_object tag; + /* + * Right now we have no means of specifying a jump point + * for really bad events. We just jump to the outermost + * frame, which is equivalent to quitting, and wait for + * someone to intercept this jump. + */ + ecl_frame_ptr destination; + cl_object tag; - /* - * We output the error message with very low level routines - * because we can not risk another stack overflow. - */ - writestr_stream(message, cl_core.error_output); + /* + * We output the error message with very low level routines + * because we can not risk another stack overflow. + */ + writestr_stream(message, cl_core.error_output); - tag = ECL_SYM_VAL(the_env, @'si::*quit-tag*'); - the_env->nvalues = 0; - if (tag) { - destination = frs_sch(tag); - if (destination) { - ecl_unwind(the_env, destination); - } - } - if (the_env->frs_org <= the_env->frs_top) { - destination = ecl_process_env()->frs_org; - ecl_unwind(the_env, destination); - } else { - ecl_internal_error("\n;;;\n;;; No frame to jump to\n;;; Aborting ECL\n;;;"); - } + tag = ECL_SYM_VAL(the_env, @'si::*quit-tag*'); + the_env->nvalues = 0; + if (tag) { + destination = frs_sch(tag); + if (destination) { + ecl_unwind(the_env, destination); + } + } + if (the_env->frs_org <= the_env->frs_top) { + destination = ecl_process_env()->frs_org; + ecl_unwind(the_env, destination); + } else { + ecl_internal_error("\n;;;\n;;; No frame to jump to\n;;; Aborting ECL\n;;;"); + } } /*****************************************************************************/ @@ -108,26 +103,26 @@ ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) void FEerror(const char *s, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - ecl_enable_interrupts(); - funcall(4, @'si::universal-error-handler', - ECL_NIL, /* not correctable */ - make_constant_base_string(s), /* condition text */ - cl_grab_rest_args(args)); - _ecl_unexpected_return(); + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + ecl_enable_interrupts(); + funcall(4, @'si::universal-error-handler', + ECL_NIL, /* not correctable */ + make_constant_base_string(s), /* condition text */ + cl_grab_rest_args(args)); + _ecl_unexpected_return(); } cl_object CEerror(cl_object c, const char *err, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - ecl_enable_interrupts(); - return funcall(4, @'si::universal-error-handler', - c, /* correctable */ - make_constant_base_string(err), /* continue-format-string */ - cl_grab_rest_args(args)); + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + ecl_enable_interrupts(); + return funcall(4, @'si::universal-error-handler', + c, /* correctable */ + make_constant_base_string(err), /* continue-format-string */ + cl_grab_rest_args(args)); } /*********************** @@ -137,245 +132,245 @@ CEerror(cl_object c, const char *err, int narg, ...) void FEprogram_error(const char *s, int narg, ...) { - cl_object real_args, text; - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - text = make_constant_base_string(s); - real_args = cl_grab_rest_args(args); - if (cl_boundp(@'si::*current-form*') != ECL_NIL) { - /* When FEprogram_error is invoked from the compiler, we can - * provide information about the offending form. - */ - cl_object stmt = ecl_symbol_value(@'si::*current-form*'); - if (stmt != ECL_NIL) { - real_args = @list(3, stmt, text, real_args); - text = make_constant_base_string("In form~%~S~%~?"); - } - } - si_signal_simple_error(4, - @'program-error', /* condition name */ - ECL_NIL, /* not correctable */ - text, - real_args); + cl_object real_args, text; + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + text = make_constant_base_string(s); + real_args = cl_grab_rest_args(args); + if (cl_boundp(@'si::*current-form*') != ECL_NIL) { + /* When FEprogram_error is invoked from the compiler, we can + * provide information about the offending form. + */ + cl_object stmt = ecl_symbol_value(@'si::*current-form*'); + if (stmt != ECL_NIL) { + real_args = @list(3, stmt, text, real_args); + text = make_constant_base_string("In form~%~S~%~?"); + } + } + si_signal_simple_error(4, + @'program-error', /* condition name */ + ECL_NIL, /* not correctable */ + text, + real_args); } void FEprogram_error_noreturn(const char *s, int narg, ...) { - cl_object real_args, text; - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - text = make_constant_base_string(s); - real_args = cl_grab_rest_args(args); - if (cl_boundp(@'si::*current-form*') != ECL_NIL) { - /* When FEprogram_error is invoked from the compiler, we can - * provide information about the offending form. - */ - cl_object stmt = ecl_symbol_value(@'si::*current-form*'); - if (stmt != ECL_NIL) { - real_args = @list(3, stmt, text, real_args); - text = make_constant_base_string("In form~%~S~%~?"); - } - } - si_signal_simple_error(4, - @'program-error', /* condition name */ - ECL_NIL, /* not correctable */ - text, - real_args); + cl_object real_args, text; + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + text = make_constant_base_string(s); + real_args = cl_grab_rest_args(args); + if (cl_boundp(@'si::*current-form*') != ECL_NIL) { + /* When FEprogram_error is invoked from the compiler, we can + * provide information about the offending form. + */ + cl_object stmt = ecl_symbol_value(@'si::*current-form*'); + if (stmt != ECL_NIL) { + real_args = @list(3, stmt, text, real_args); + text = make_constant_base_string("In form~%~S~%~?"); + } + } + si_signal_simple_error(4, + @'program-error', /* condition name */ + ECL_NIL, /* not correctable */ + text, + real_args); } void FEcontrol_error(const char *s, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - si_signal_simple_error(4, - @'control-error', /* condition name */ - ECL_NIL, /* not correctable */ - make_constant_base_string(s), /* format control */ - cl_grab_rest_args(args)); /* format args */ + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + si_signal_simple_error(4, + @'control-error', /* condition name */ + ECL_NIL, /* not correctable */ + make_constant_base_string(s), /* format control */ + cl_grab_rest_args(args)); /* format args */ } void FEreader_error(const char *s, cl_object stream, int narg, ...) { - cl_object message = make_constant_base_string(s); - cl_object args_list; - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - args_list = cl_grab_rest_args(args); - if (Null(stream)) { - /* Parser error */ - si_signal_simple_error(4, - @'parse-error', /* condition name */ - ECL_NIL, /* not correctable */ - message, /* format control */ - args_list); - } else { - /* Actual reader error */ - cl_object prefix = make_constant_base_string("Reader error in file ~S, " - "position ~D:~%"); - cl_object position = cl_file_position(1, stream); - message = si_base_string_concatenate(2, prefix, message); - args_list = cl_listX(3, stream, position, args_list); - si_signal_simple_error(6, - @'reader-error', /* condition name */ - ECL_NIL, /* not correctable */ - message, /* format control */ - args_list, /* format args */ - @':stream', stream); - } + cl_object message = make_constant_base_string(s); + cl_object args_list; + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + args_list = cl_grab_rest_args(args); + if (Null(stream)) { + /* Parser error */ + si_signal_simple_error(4, + @'parse-error', /* condition name */ + ECL_NIL, /* not correctable */ + message, /* format control */ + args_list); + } else { + /* Actual reader error */ + cl_object prefix = make_constant_base_string("Reader error in file ~S, " + "position ~D:~%"); + cl_object position = cl_file_position(1, stream); + message = si_base_string_concatenate(2, prefix, message); + args_list = cl_listX(3, stream, position, args_list); + si_signal_simple_error(6, + @'reader-error', /* condition name */ + ECL_NIL, /* not correctable */ + message, /* format control */ + args_list, /* format args */ + @':stream', stream); + } } void FEcannot_open(cl_object fn) { - cl_error(3, @'file-error', @':pathname', fn); + cl_error(3, @'file-error', @':pathname', fn); } void FEend_of_file(cl_object strm) { - cl_error(3, @'end-of-file', @':stream', strm); + cl_error(3, @'end-of-file', @':stream', strm); } void FEclosed_stream(cl_object strm) { - cl_error(3, @'stream-error', @':stream', strm); + cl_error(3, @'stream-error', @':stream', strm); } cl_object si_signal_type_error(cl_object value, cl_object type) { - return cl_error(5, @'type-error', @':expected-type', type, - @':datum', value); + return cl_error(5, @'type-error', @':expected-type', type, + @':datum', value); } void FEwrong_type_argument(cl_object type, cl_object value) { - si_signal_type_error(value, cl_symbol_or_object(type)); + si_signal_type_error(value, cl_symbol_or_object(type)); } void FEwrong_type_only_arg(cl_object function, cl_object value, cl_object type) { - const char *message = - "In ~:[an anonymous function~;~:*function ~A~], " - "the value of the only argument is~& ~S~&which is " - "not of the expected type ~A"; - cl_env_ptr env = ecl_process_env(); - struct ecl_ihs_frame tmp_ihs; - function = cl_symbol_or_object(function); - type = cl_symbol_or_object(type); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { - ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); - } - si_signal_simple_error(8, - @'type-error', /* condition name */ - ECL_NIL, /* not correctable */ - make_constant_base_string(message), /* format control */ - cl_list(3, function, value, type), - @':expected-type', type, - @':datum', value); + const char *message = + "In ~:[an anonymous function~;~:*function ~A~], " + "the value of the only argument is~& ~S~&which is " + "not of the expected type ~A"; + cl_env_ptr env = ecl_process_env(); + struct ecl_ihs_frame tmp_ihs; + function = cl_symbol_or_object(function); + type = cl_symbol_or_object(type); + if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); + } + si_signal_simple_error(8, + @'type-error', /* condition name */ + ECL_NIL, /* not correctable */ + make_constant_base_string(message), /* format control */ + cl_list(3, function, value, type), + @':expected-type', type, + @':datum', value); } void FEwrong_type_nth_arg(cl_object function, cl_narg narg, cl_object value, cl_object type) { - const char *message = - "In ~:[an anonymous function~;~:*function ~A~], " - "the value of the ~:R argument is~& ~S~&which is " - "not of the expected type ~A"; - cl_env_ptr env = ecl_process_env(); - struct ecl_ihs_frame tmp_ihs; - function = cl_symbol_or_object(function); - type = cl_symbol_or_object(type); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { - ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); - } - si_signal_simple_error(8, - @'type-error', /* condition name */ - ECL_NIL, /* not correctable */ - make_constant_base_string(message), /* format control */ - cl_list(4, function, ecl_make_fixnum(narg), - value, type), - @':expected-type', type, - @':datum', value); + const char *message = + "In ~:[an anonymous function~;~:*function ~A~], " + "the value of the ~:R argument is~& ~S~&which is " + "not of the expected type ~A"; + cl_env_ptr env = ecl_process_env(); + struct ecl_ihs_frame tmp_ihs; + function = cl_symbol_or_object(function); + type = cl_symbol_or_object(type); + if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); + } + si_signal_simple_error(8, + @'type-error', /* condition name */ + ECL_NIL, /* not correctable */ + make_constant_base_string(message), /* format control */ + cl_list(4, function, ecl_make_fixnum(narg), + value, type), + @':expected-type', type, + @':datum', value); } void FEwrong_type_key_arg(cl_object function, cl_object key, cl_object value, cl_object type) { - const char *message = - "In ~:[an anonymous function~;~:*function ~A~], " - "the value of the argument ~S is~& ~S~&which is " - "not of the expected type ~A"; - cl_env_ptr env = ecl_process_env(); - struct ecl_ihs_frame tmp_ihs; - function = cl_symbol_or_object(function); - type = cl_symbol_or_object(type); - key = cl_symbol_or_object(key); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { - ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); - } - si_signal_simple_error(8, - @'type-error', /* condition name */ - ECL_NIL, /* not correctable */ - make_constant_base_string(message), /* format control */ - cl_list(4, function, key, value, type), - @':expected-type', type, - @':datum', value); + const char *message = + "In ~:[an anonymous function~;~:*function ~A~], " + "the value of the argument ~S is~& ~S~&which is " + "not of the expected type ~A"; + cl_env_ptr env = ecl_process_env(); + struct ecl_ihs_frame tmp_ihs; + function = cl_symbol_or_object(function); + type = cl_symbol_or_object(type); + key = cl_symbol_or_object(key); + if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); + } + si_signal_simple_error(8, + @'type-error', /* condition name */ + ECL_NIL, /* not correctable */ + make_constant_base_string(message), /* format control */ + cl_list(4, function, key, value, type), + @':expected-type', type, + @':datum', value); } void FEwrong_index(cl_object function, cl_object a, int which, cl_object ndx, cl_index nonincl_limit) { - const char *message1 = - "In ~:[an anonymous function~;~:*function ~A~], " - "the ~*index into the object~% ~A.~%" - "takes a value ~D out of the range ~A."; - const char *message2 = - "In ~:[an anonymous function~;~:*function ~A~], " - "the ~:R index into the object~% ~A~%" - "takes a value ~D out of the range ~A."; - cl_object limit = ecl_make_integer(nonincl_limit-1); - cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), limit); - cl_object message = make_constant_base_string((which<0) ? message1 : message2); - cl_env_ptr env = ecl_process_env(); - struct ecl_ihs_frame tmp_ihs; - function = cl_symbol_or_object(function); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { - ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); - } - cl_error(9, - @'simple-type-error', /* condition name */ - @':format-control', message, - @':format-arguments', - cl_list(5, function, ecl_make_fixnum(which+1), a, ndx, type), - @':expected-type', type, - @':datum', ndx); + const char *message1 = + "In ~:[an anonymous function~;~:*function ~A~], " + "the ~*index into the object~% ~A.~%" + "takes a value ~D out of the range ~A."; + const char *message2 = + "In ~:[an anonymous function~;~:*function ~A~], " + "the ~:R index into the object~% ~A~%" + "takes a value ~D out of the range ~A."; + cl_object limit = ecl_make_integer(nonincl_limit-1); + cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), limit); + cl_object message = make_constant_base_string((which<0) ? message1 : message2); + cl_env_ptr env = ecl_process_env(); + struct ecl_ihs_frame tmp_ihs; + function = cl_symbol_or_object(function); + if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); + } + cl_error(9, + @'simple-type-error', /* condition name */ + @':format-control', message, + @':format-arguments', + cl_list(5, function, ecl_make_fixnum(which+1), a, ndx, type), + @':expected-type', type, + @':datum', ndx); } void FEunbound_variable(cl_object sym) { - cl_error(3, @'unbound-variable', @':name', sym); + cl_error(3, @'unbound-variable', @':name', sym); } void FEundefined_function(cl_object fname) { - cl_error(3, @'undefined-function', @':name', fname); + cl_error(3, @'undefined-function', @':name', fname); } void FEprint_not_readable(cl_object x) { - cl_error(3, @'print-not-readable', @':object', x); + cl_error(3, @'print-not-readable', @':object', x); } /************* @@ -385,49 +380,49 @@ FEprint_not_readable(cl_object x) void FEwrong_num_arguments(cl_object fun) { - fun = cl_symbol_or_object(fun); - FEprogram_error("Wrong number of arguments passed to function ~S.", - 1, fun); + fun = cl_symbol_or_object(fun); + FEprogram_error("Wrong number of arguments passed to function ~S.", + 1, fun); } void FEwrong_num_arguments_anonym(void) { - FEprogram_error("Wrong number of arguments passed to an anonymous function", 0); + FEprogram_error("Wrong number of arguments passed to an anonymous function", 0); } void FEinvalid_macro_call(cl_object name) { - FEerror("Invalid macro call to ~S.", 1, name); + FEerror("Invalid macro call to ~S.", 1, name); } void FEinvalid_variable(const char *s, cl_object obj) { - FEerror(s, 1, obj); + FEerror(s, 1, obj); } void FEassignment_to_constant(cl_object v) { - FEprogram_error("SETQ: Tried to assign a value to the constant ~S.", 1, v); + FEprogram_error("SETQ: Tried to assign a value to the constant ~S.", 1, v); } void FEinvalid_function(cl_object obj) { - FEwrong_type_argument(@'function', obj); + FEwrong_type_argument(@'function', obj); } void FEinvalid_function_name(cl_object fname) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Not a valid function name ~D"), - @':format-arguments', cl_list(1, fname), - @':expected-type', cl_list(2, @'satisfies', @'si::valid-function-name-p'), - @':datum', fname); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Not a valid function name ~D"), + @':format-arguments', cl_list(1, fname), + @':expected-type', cl_list(2, @'satisfies', @'si::valid-function-name-p'), + @':datum', fname); } /* bootstrap version */ @@ -437,42 +432,42 @@ static cl_object universal_error_handler(cl_object continue_string, cl_object datum, cl_object args) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object stream; - if (recursive_error) - goto ABORT; - recursive_error = 1; - stream = cl_core.error_output; - if (!Null(stream)) { - ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-level*', ecl_make_fixnum(3)); - ecl_bds_bind(the_env, @'*print-length*', ecl_make_fixnum(3)); - ecl_bds_bind(the_env, @'*print-circle*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); - writestr_stream("\n;;; Unhandled lisp initialization error", - stream); - writestr_stream("\n;;; Message:\n", stream); - si_write_ugly_object(datum, stream); - writestr_stream("\n;;; Arguments:\n", stream); - si_write_ugly_object(args, stream); - ecl_bds_unwind_n(the_env, 5); - } + const cl_env_ptr the_env = ecl_process_env(); + cl_object stream; + if (recursive_error) + goto ABORT; + recursive_error = 1; + stream = cl_core.error_output; + if (!Null(stream)) { + ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-level*', ecl_make_fixnum(3)); + ecl_bds_bind(the_env, @'*print-length*', ecl_make_fixnum(3)); + ecl_bds_bind(the_env, @'*print-circle*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); + writestr_stream("\n;;; Unhandled lisp initialization error", + stream); + writestr_stream("\n;;; Message:\n", stream); + si_write_ugly_object(datum, stream); + writestr_stream("\n;;; Arguments:\n", stream); + si_write_ugly_object(args, stream); + ecl_bds_unwind_n(the_env, 5); + } ABORT: - ecl_internal_error("\nLisp initialization error.\n"); + ecl_internal_error("\nLisp initialization error.\n"); } void FEdivision_by_zero(cl_object x, cl_object y) { - cl_error(5, @'division-by-zero', @':operation', @'/', - @':operands', cl_list(2, x, y)); + cl_error(5, @'division-by-zero', @':operation', @'/', + @':operands', cl_list(2, x, y)); } cl_object _ecl_strerror(int code) { - const char *error = strerror(code); - return make_base_string_copy(error); + const char *error = strerror(code); + return make_base_string_copy(error); } /************************************* @@ -486,15 +481,15 @@ _ecl_strerror(int code) void FElibc_error(const char *msg, int narg, ...) { - ecl_va_list args; - cl_object rest, error = _ecl_strerror(errno); + ecl_va_list args; + cl_object rest, error = _ecl_strerror(errno); - ecl_va_start(args, narg, narg, 0); - rest = cl_grab_rest_args(args); + ecl_va_start(args, narg, narg, 0); + rest = cl_grab_rest_args(args); - FEerror("~?~%C library explanation: ~A.", 3, - make_constant_base_string(msg), rest, - error); + FEerror("~?~%C library explanation: ~A.", 3, + make_constant_base_string(msg), rest, + error); } #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) @@ -503,23 +498,23 @@ ecl_def_ct_base_string(unknown_error,"[Unable to get error message]",28,static,c void FEwin32_error(const char *msg, int narg, ...) { - ecl_va_list args; - cl_object rest, win_msg_obj; - char *win_msg; + ecl_va_list args; + cl_object rest, win_msg_obj; + char *win_msg; - if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_ALLOCATE_BUFFER, - 0, GetLastError(), 0, (void*)&win_msg, 0, NULL) == 0) - win_msg_obj = unknown_error; - else { - win_msg_obj = make_base_string_copy(win_msg); - LocalFree(win_msg); - } + if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_ALLOCATE_BUFFER, + 0, GetLastError(), 0, (void*)&win_msg, 0, NULL) == 0) + win_msg_obj = unknown_error; + else { + win_msg_obj = make_base_string_copy(win_msg); + LocalFree(win_msg); + } - ecl_va_start(args, narg, narg, 0); - rest = cl_grab_rest_args(args); - FEerror("~?~%Windows library explanation: ~A.", 3, - make_constant_base_string(msg), rest, - win_msg_obj); + ecl_va_start(args, narg, narg, 0); + rest = cl_grab_rest_args(args); + FEerror("~?~%Windows library explanation: ~A.", 3, + make_constant_base_string(msg), rest, + win_msg_obj); } #endif @@ -528,32 +523,32 @@ FEwin32_error(const char *msg, int narg, ...) ************************************/ @(defun error (eformat &rest args) -@ - ecl_enable_interrupts(); - funcall(4, @'si::universal-error-handler', ECL_NIL, eformat, - cl_grab_rest_args(args)); - _ecl_unexpected_return(); - @(return); -@) +@ { + ecl_enable_interrupts(); + funcall(4, @'si::universal-error-handler', ECL_NIL, eformat, + cl_grab_rest_args(args)); + _ecl_unexpected_return(); + @(return); +} @) @(defun cerror (cformat eformat &rest args) -@ - ecl_enable_interrupts(); - return funcall(4, @'si::universal-error-handler', cformat, eformat, - cl_grab_rest_args(args)); -@) +@ { + ecl_enable_interrupts(); + return funcall(4, @'si::universal-error-handler', cformat, eformat, + cl_grab_rest_args(args)); +} @) @(defun si::serror (cformat eformat &rest args) -@ - ecl_enable_interrupts(); - return funcall(4, @'si::stack-error-handler', cformat, eformat, - cl_grab_rest_args(args)); -@) +@ { + ecl_enable_interrupts(); + return funcall(4, @'si::stack-error-handler', cformat, eformat, + cl_grab_rest_args(args)); +} @) void init_error(void) { - ecl_def_c_function(@'si::universal-error-handler', - (cl_objectfn_fixed)universal_error_handler, - 3); + ecl_def_c_function(@'si::universal-error-handler', + (cl_objectfn_fixed)universal_error_handler, + 3); } diff --git a/src/c/eval.d b/src/c/eval.d index dd4cae565..c6bf758be 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -1,22 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - eval.c -- Eval. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ - + * eval.d - evaluation + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -25,234 +19,230 @@ cl_object * _ecl_va_sp(cl_narg narg) { - return ecl_process_env()->stack_top - narg; + return ecl_process_env()->stack_top - narg; } /* Calling conventions: - Compiled C code calls lisp function supplying #args, and args. - Linking function performs check_args, gets jmp_buf with _setjmp, then - if cfun then stores C code address into function link location - and transfers to jmp_buf at cf_self - if cclosure then replaces #args with cc_env and calls cc_self - otherwise, it emulates funcall. + * Compiled C code calls lisp function supplying #args, and args. + * Linking function performs check_args, gets jmp_buf with _setjmp, then + * if cfun then stores C code address into function link location + * and transfers to jmp_buf at cf_self + * if cclosure then replaces #args with cc_env and calls cc_self + * otherwise, it emulates funcall. */ cl_object ecl_apply_from_stack_frame(cl_object frame, cl_object x) { - cl_object *sp = frame->frame.base; - cl_index narg = frame->frame.size; - cl_object fun = x; - AGAIN: - frame->frame.env->function = fun; - if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(fun)) { - case t_cfunfixed: - if (ecl_unlikely(narg != (cl_index)fun->cfun.narg)) - FEwrong_num_arguments(fun); - return APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp); - case t_cfun: - return APPLY(narg, fun->cfun.entry, sp); - case t_cclosure: - return APPLY(narg, fun->cclosure.entry, sp); - case t_instance: - switch (fun->instance.isgf) { - case ECL_STANDARD_DISPATCH: - case ECL_RESTRICTED_DISPATCH: - return _ecl_standard_dispatch(frame, fun); - case ECL_USER_DISPATCH: - fun = fun->instance.slots[fun->instance.length - 1]; - goto AGAIN; - case ECL_READER_DISPATCH: - case ECL_WRITER_DISPATCH: - return APPLY(narg, fun->instance.entry, sp); - default: - FEinvalid_function(fun); - } - case t_symbol: - if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro)) - FEundefined_function(x); - fun = ECL_SYM_FUN(fun); - goto AGAIN; - case t_bytecodes: - return ecl_interpret(frame, ECL_NIL, fun); - case t_bclosure: - return ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code); - default: - FEinvalid_function(x); - } + cl_object *sp = frame->frame.base; + cl_index narg = frame->frame.size; + cl_object fun = x; + AGAIN: + frame->frame.env->function = fun; + if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL)) + FEundefined_function(x); + switch (ecl_t_of(fun)) { + case t_cfunfixed: + if (ecl_unlikely(narg != (cl_index)fun->cfun.narg)) + FEwrong_num_arguments(fun); + return APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp); + case t_cfun: + return APPLY(narg, fun->cfun.entry, sp); + case t_cclosure: + return APPLY(narg, fun->cclosure.entry, sp); + case t_instance: + switch (fun->instance.isgf) { + case ECL_STANDARD_DISPATCH: + case ECL_RESTRICTED_DISPATCH: + return _ecl_standard_dispatch(frame, fun); + case ECL_USER_DISPATCH: + fun = fun->instance.slots[fun->instance.length - 1]; + goto AGAIN; + case ECL_READER_DISPATCH: + case ECL_WRITER_DISPATCH: + return APPLY(narg, fun->instance.entry, sp); + default: + FEinvalid_function(fun); + } + case t_symbol: + if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro)) + FEundefined_function(x); + fun = ECL_SYM_FUN(fun); + goto AGAIN; + case t_bytecodes: + return ecl_interpret(frame, ECL_NIL, fun); + case t_bclosure: + return ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code); + default: + FEinvalid_function(x); + } } cl_objectfn ecl_function_dispatch(cl_env_ptr env, cl_object x) { - cl_object fun = x; + cl_object fun = x; AGAIN: - if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(fun)) { - case t_cfunfixed: - env->function = fun; - return fun->cfunfixed.entry; - case t_cfun: - env->function = fun; - return fun->cfun.entry; - case t_cclosure: - env->function = fun; - return fun->cclosure.entry; - case t_instance: - env->function = fun; - return fun->instance.entry; - case t_symbol: - if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro)) - FEundefined_function(x); - fun = ECL_SYM_FUN(fun); - goto AGAIN; - case t_bytecodes: - env->function = fun; - return fun->bytecodes.entry; - case t_bclosure: - env->function = fun; - return fun->bclosure.entry; - default: - FEinvalid_function(x); - } + if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL)) + FEundefined_function(x); + switch (ecl_t_of(fun)) { + case t_cfunfixed: + env->function = fun; + return fun->cfunfixed.entry; + case t_cfun: + env->function = fun; + return fun->cfun.entry; + case t_cclosure: + env->function = fun; + return fun->cclosure.entry; + case t_instance: + env->function = fun; + return fun->instance.entry; + case t_symbol: + if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro)) + FEundefined_function(x); + fun = ECL_SYM_FUN(fun); + goto AGAIN; + case t_bytecodes: + env->function = fun; + return fun->bytecodes.entry; + case t_bclosure: + env->function = fun; + return fun->bclosure.entry; + default: + FEinvalid_function(x); + } } cl_object cl_funcall(cl_narg narg, cl_object function, ...) { - cl_object output; - --narg; - { - ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame); - output = ecl_apply_from_stack_frame(frame, function); - ECL_STACK_FRAME_VARARGS_END(frame); - } - return output; + cl_object output; + --narg; + { + ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame); + output = ecl_apply_from_stack_frame(frame, function); + ECL_STACK_FRAME_VARARGS_END(frame); + } + return output; } @(defun apply (fun lastarg &rest args) -@ - if (narg == 2 && ecl_t_of(lastarg) == t_frame) { - return ecl_apply_from_stack_frame(lastarg, fun); - } else { - cl_object out; - cl_index i; - struct ecl_stack_frame frame_aux; - const cl_object frame = ecl_stack_frame_open(the_env, - (cl_object)&frame_aux, - narg -= 2); - for (i = 0; i < narg; i++) { - ECL_STACK_FRAME_SET(frame, i, lastarg); - lastarg = ecl_va_arg(args); - } - if (ecl_t_of(lastarg) == t_frame) { - /* This could be replaced with a memcpy() */ - for (i = 0; i < lastarg->frame.size; i++) { - ecl_stack_frame_push(frame, lastarg->frame.base[i]); - } - } else loop_for_in (lastarg) { - if (ecl_unlikely(i >= ECL_CALL_ARGUMENTS_LIMIT)) { - ecl_stack_frame_close(frame); - FEprogram_error_noreturn("CALL-ARGUMENTS-LIMIT exceeded",0); - } - ecl_stack_frame_push(frame, CAR(lastarg)); - i++; - } end_loop_for_in; - out = ecl_apply_from_stack_frame(frame, fun); - ecl_stack_frame_close(frame); - return out; +@ { + if (narg == 2 && ecl_t_of(lastarg) == t_frame) { + return ecl_apply_from_stack_frame(lastarg, fun); + } else { + cl_object out; + cl_index i; + struct ecl_stack_frame frame_aux; + const cl_object frame = ecl_stack_frame_open(the_env, + (cl_object)&frame_aux, + narg -= 2); + for (i = 0; i < narg; i++) { + ECL_STACK_FRAME_SET(frame, i, lastarg); + lastarg = ecl_va_arg(args); + } + if (ecl_t_of(lastarg) == t_frame) { + /* This could be replaced with a memcpy() */ + for (i = 0; i < lastarg->frame.size; i++) { + ecl_stack_frame_push(frame, lastarg->frame.base[i]); } -@) + } else loop_for_in (lastarg) { + if (ecl_unlikely(i >= ECL_CALL_ARGUMENTS_LIMIT)) { + ecl_stack_frame_close(frame); + FEprogram_error_noreturn("CALL-ARGUMENTS-LIMIT exceeded",0); + } + ecl_stack_frame_push(frame, CAR(lastarg)); + i++; + } end_loop_for_in; + out = ecl_apply_from_stack_frame(frame, fun); + ecl_stack_frame_close(frame); + return out; + } +}@) cl_object cl_eval(cl_object form) { - return si_eval_with_env(1, form); + return si_eval_with_env(1, form); } @(defun constantp (arg &optional env) @ - return _ecl_funcall3(@'ext::constantp-inner', arg, env); + return _ecl_funcall3(@'ext::constantp-inner', arg, env); @) @(defun ext::constantp-inner (form &optional env) - cl_object value; -@ + cl_object value; +@ { AGAIN: - switch (ecl_t_of(form)) { - case t_list: - if (Null(form)) { - value = ECL_T; - break; - } - if (ECL_CONS_CAR(form) == @'quote') { - value = ECL_T; - break; - } - /* - value = cl_macroexpand(2, form, env); - if (value != form) { - form = value; - goto AGAIN; - } - */ - value = ECL_NIL; - break; - case t_symbol: - value = cl_macroexpand(2, form, env); - if (value != form) { - form = value; - goto AGAIN; - } - if (!(form->symbol.stype & ecl_stp_constant)) { - value = ECL_NIL; - break; - } - default: - value = ECL_T; - } - ecl_return1(the_env, value); -@) + switch (ecl_t_of(form)) { + case t_list: + if (Null(form)) { + value = ECL_T; + break; + } + if (ECL_CONS_CAR(form) == @'quote') { + value = ECL_T; + break; + } + /* + value = cl_macroexpand(2, form, env); + if (value != form) { + form = value; + goto AGAIN; + } + */ + value = ECL_NIL; + break; + case t_symbol: + value = cl_macroexpand(2, form, env); + if (value != form) { + form = value; + goto AGAIN; + } + if (!(form->symbol.stype & ecl_stp_constant)) { + value = ECL_NIL; + break; + } + default: + value = ECL_T; + } + ecl_return1(the_env, value); +} @) @(defun ext::constant-form-value (form &optional env) - cl_object value; -@ -{ - AGAIN: - switch (ecl_t_of(form)) { - case t_list: - if (Null(form)) { - value = ECL_NIL; - break; - } - if (ECL_CONS_CAR(form) == @'quote') { - return cl_second(form); - } - /* - value = cl_macroexpand(2, form, env); - if (value != form) { - form = value; - goto AGAIN; - } - */ - ERROR: - FEerror("EXT:CONSTANT-FORM-VALUE invoked with a non-constant form ~A", - 0, form); - break; - case t_symbol: - value = cl_macroexpand(2, form, env); - if (value != form) { - form = value; - goto AGAIN; - } - value = ECL_SYM_VAL(the_env, value); - break; - default: - value = form; - } - @(return value); -} -@) + cl_object value; +@ { + AGAIN: + switch (ecl_t_of(form)) { + case t_list: + if (Null(form)) { + value = ECL_NIL; + break; + } + if (ECL_CONS_CAR(form) == @'quote') { + return cl_second(form); + } + /* value = cl_macroexpand(2, form, env); */ + /* if (value != form) { */ + /* form = value; */ + /* goto AGAIN; */ + /* } */ + ERROR: + FEerror("EXT:CONSTANT-FORM-VALUE invoked with a non-constant form ~A", + 0, form); + break; + case t_symbol: + value = cl_macroexpand(2, form, env); + if (value != form) { + form = value; + goto AGAIN; + } + value = ECL_SYM_VAL(the_env, value); + break; + default: + value = form; + } + @(return value); +} @) diff --git a/src/c/ffi.d b/src/c/ffi.d index ee46060ad..8174977a6 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - ffi.c -- User defined data types and foreign functions interface. -*/ -/* - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ + * ffi.d - user defined data types and foreign functions interface + * + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #define ECL_INCLUDE_FFI_H @@ -21,408 +16,408 @@ #include static const cl_object ecl_aet_to_ffi_table[ecl_aet_bc+1] = { - @':void', /* ecl_aet_object */ - @':float', /* ecl_aet_df */ - @':double', /* ecl_aet_df */ - @':void', /* ecl_aet_bit */ + @':void', /* ecl_aet_object */ + @':float', /* ecl_aet_df */ + @':double', /* ecl_aet_df */ + @':void', /* ecl_aet_bit */ #if ECL_FIXNUM_BITS == 32 && defined(ecl_uint32_t) - @':int32-t', /* ecl_aet_fix */ - @':uint32-t', /* ecl_aet_index */ + @':int32-t', /* ecl_aet_fix */ + @':uint32-t', /* ecl_aet_index */ #else # if ECL_FIXNUM_BITS == 64 && defined(ecl_uint64_t) - @':int64-t', /* ecl_aet_fix */ - @':uint64-t', /* ecl_aet_index */ + @':int64-t', /* ecl_aet_fix */ + @':uint64-t', /* ecl_aet_index */ # else - @':void', /* ecl_aet_fix */ - @':void', /* ecl_aet_index */ + @':void', /* ecl_aet_fix */ + @':void', /* ecl_aet_index */ # endif #endif - @':uint8-t', /* ecl_aet_b8 */ - @':int8-t', /* ecl_aet_i8 */ + @':uint8-t', /* ecl_aet_b8 */ + @':int8-t', /* ecl_aet_i8 */ #ifdef ecl_uint16_t - @':uint16-t', /* ecl_aet_b16 */ - @':int16-t', /* ecl_aet_i16 */ + @':uint16-t', /* ecl_aet_b16 */ + @':int16-t', /* ecl_aet_i16 */ #endif #ifdef ecl_uint32_t - @':uint32-t', /* ecl_aet_b32 */ - @':int32-t', /* ecl_aet_i32 */ + @':uint32-t', /* ecl_aet_b32 */ + @':int32-t', /* ecl_aet_i32 */ #endif #ifdef ecl_uint64_t - @':uint64-t', /* ecl_aet_b64 */ - @':int64-t', /* ecl_aet_i64 */ + @':uint64-t', /* ecl_aet_b64 */ + @':int64-t', /* ecl_aet_i64 */ #endif #ifdef ECL_UNICODE # ifdef ecl_int32_t - @':int32-t', /* ecl_aet_ch */ + @':int32-t', /* ecl_aet_ch */ # else - @':void', /* ecl_aet_ch */ + @':void', /* ecl_aet_ch */ # endif #endif - @':char' /* ecl_aet_bc */ + @':char' /* ecl_aet_bc */ }; -#define AUX_PTR(type) \ - ((struct { char a[1]; union { type c[1]; char d[sizeof(type)]; } b; } *)0) +#define AUX_PTR(type) \ + ((struct { char a[1]; union { type c[1]; char d[sizeof(type)]; } b; } *)0) #ifdef __GNUC__ typedef struct { - cl_object name; - cl_index size; - cl_index alignment; + cl_object name; + cl_index size; + cl_index alignment; } ecl_foreign_type_record; # define ALIGNMENT(tag) (ecl_foreign_type_table[tag].alignment) -# define FFI_DESC(symbol,type) \ +# define FFI_DESC(symbol,type) \ {symbol, sizeof(type), (AUX_PTR(type)->b.d - AUX_PTR(type)->a)} #else typedef struct { - cl_object name; - cl_index size; - char *d, *a; + cl_object name; + cl_index size; + char *d, *a; } ecl_foreign_type_record; #define ALIGNMENT(tag) (ecl_foreign_type_table[tag].d - ecl_foreign_type_table[tag].a) -#define AUX_PTR(type) \ - ((struct { char a[1]; union { type c[1]; char d[sizeof(type)]; } b; } *)0) -#define FFI_DESC(symbol,type) \ +#define AUX_PTR(type) \ + ((struct { char a[1]; union { type c[1]; char d[sizeof(type)]; } b; } *)0) +#define FFI_DESC(symbol,type) \ {symbol, sizeof(type), AUX_PTR(type)->b.d, AUX_PTR(type)->a} #endif static const ecl_foreign_type_record ecl_foreign_type_table[] = { - FFI_DESC(@':char', char), - FFI_DESC(@':unsigned-char', unsigned char), - FFI_DESC(@':byte', ecl_int8_t), - FFI_DESC(@':unsigned-byte', ecl_uint8_t), - FFI_DESC(@':short', short), - FFI_DESC(@':unsigned-short', unsigned short), - FFI_DESC(@':int', int), - FFI_DESC(@':unsigned-int', unsigned int), - FFI_DESC(@':long', long), - FFI_DESC(@':unsigned-long', unsigned long), + FFI_DESC(@':char', char), + FFI_DESC(@':unsigned-char', unsigned char), + FFI_DESC(@':byte', ecl_int8_t), + FFI_DESC(@':unsigned-byte', ecl_uint8_t), + FFI_DESC(@':short', short), + FFI_DESC(@':unsigned-short', unsigned short), + FFI_DESC(@':int', int), + FFI_DESC(@':unsigned-int', unsigned int), + FFI_DESC(@':long', long), + FFI_DESC(@':unsigned-long', unsigned long), #ifdef ecl_uint8_t - FFI_DESC(@':int8-t', ecl_int8_t), - FFI_DESC(@':uint8-t', ecl_uint8_t), + FFI_DESC(@':int8-t', ecl_int8_t), + FFI_DESC(@':uint8-t', ecl_uint8_t), #endif #ifdef ecl_uint16_t - FFI_DESC(@':int16-t', ecl_int16_t), - FFI_DESC(@':uint16-t', ecl_uint16_t), + FFI_DESC(@':int16-t', ecl_int16_t), + FFI_DESC(@':uint16-t', ecl_uint16_t), #endif #ifdef ecl_uint32_t - FFI_DESC(@':int32-t', ecl_int32_t), - FFI_DESC(@':uint32-t', ecl_uint32_t), + FFI_DESC(@':int32-t', ecl_int32_t), + FFI_DESC(@':uint32-t', ecl_uint32_t), #endif #ifdef ecl_uint64_t - FFI_DESC(@':int64-t', ecl_int64_t), - FFI_DESC(@':uint64-t', ecl_uint64_t), + FFI_DESC(@':int64-t', ecl_int64_t), + FFI_DESC(@':uint64-t', ecl_uint64_t), #endif #ifdef ecl_long_long_t - FFI_DESC(@':long-long', long long), - FFI_DESC(@':unsigned-long-long', unsigned long long), + FFI_DESC(@':long-long', long long), + FFI_DESC(@':unsigned-long-long', unsigned long long), #endif - FFI_DESC(@':pointer-void', void *), - FFI_DESC(@':cstring', char *), - FFI_DESC(@':object', cl_object), - FFI_DESC(@':float', float), - FFI_DESC(@':double', double), - {@':void', 0, 0} + FFI_DESC(@':pointer-void', void *), + FFI_DESC(@':cstring', char *), + FFI_DESC(@':object', cl_object), + FFI_DESC(@':float', float), + FFI_DESC(@':double', double), + {@':void', 0, 0} }; #ifdef HAVE_LIBFFI static struct { - const cl_object symbol; - ffi_abi abi; + const cl_object symbol; + ffi_abi abi; } ecl_foreign_cc_table[] = { - {@':default', FFI_DEFAULT_ABI}, + {@':default', FFI_DEFAULT_ABI}, #ifdef X86_WIN32 - {@':cdecl', FFI_SYSV}, - {@':sysv', FFI_SYSV}, - {@':stdcall', FFI_STDCALL}, + {@':cdecl', FFI_SYSV}, + {@':sysv', FFI_SYSV}, + {@':stdcall', FFI_STDCALL}, #elif defined(X86_WIN64) - {@':win64', FFI_WIN64}, + {@':win64', FFI_WIN64}, #elif defined(X86_ANY) || defined(X86) || defined(X86_64) - {@':cdecl', FFI_SYSV}, - {@':sysv', FFI_SYSV}, - {@':unix64', FFI_UNIX64}, + {@':cdecl', FFI_SYSV}, + {@':sysv', FFI_SYSV}, + {@':unix64', FFI_UNIX64}, #endif }; static ffi_type *ecl_type_to_libffi_type[] = { - &ffi_type_schar, /*@':char',*/ - &ffi_type_uchar, /*@':unsigned-char',*/ - &ffi_type_sint8, /*@':byte',*/ - &ffi_type_uint8, /*@':unsigned-byte',*/ - &ffi_type_sshort, /*@':short',*/ - &ffi_type_ushort, /*@':unsigned-short',*/ - &ffi_type_sint, /*@':int',*/ - &ffi_type_uint, /*@':unsigned-int',*/ - &ffi_type_slong, /*@':long',*/ - &ffi_type_ulong, /*@':unsigned-long',*/ + &ffi_type_schar, /*@':char',*/ + &ffi_type_uchar, /*@':unsigned-char',*/ + &ffi_type_sint8, /*@':byte',*/ + &ffi_type_uint8, /*@':unsigned-byte',*/ + &ffi_type_sshort, /*@':short',*/ + &ffi_type_ushort, /*@':unsigned-short',*/ + &ffi_type_sint, /*@':int',*/ + &ffi_type_uint, /*@':unsigned-int',*/ + &ffi_type_slong, /*@':long',*/ + &ffi_type_ulong, /*@':unsigned-long',*/ #ifdef ecl_uint8_t - &ffi_type_sint8, /*@':int8-t',*/ - &ffi_type_uint8, /*@':uint8-t',*/ + &ffi_type_sint8, /*@':int8-t',*/ + &ffi_type_uint8, /*@':uint8-t',*/ #endif #ifdef ecl_uint16_t - &ffi_type_sint16, /*@':int16-t',*/ - &ffi_type_uint16, /*@':uint16-t',*/ + &ffi_type_sint16, /*@':int16-t',*/ + &ffi_type_uint16, /*@':uint16-t',*/ #endif #ifdef ecl_uint32_t - &ffi_type_sint32, /*@':int32-t',*/ - &ffi_type_uint32, /*@':uint32-t',*/ + &ffi_type_sint32, /*@':int32-t',*/ + &ffi_type_uint32, /*@':uint32-t',*/ #endif #ifdef ecl_uint64_t - &ffi_type_sint64, /*@':int64-t',*/ - &ffi_type_uint64, /*@':uint64-t',*/ + &ffi_type_sint64, /*@':int64-t',*/ + &ffi_type_uint64, /*@':uint64-t',*/ #endif #ifdef ecl_long_long_t - &ffi_type_sint64, /*@':long-long',*/ /*FIXME! libffi does not have long long */ - &ffi_type_uint64, /*@':unsigned-long-long',*/ + &ffi_type_sint64, /*@':long-long',*/ /*FIXME! libffi does not have long long */ + &ffi_type_uint64, /*@':unsigned-long-long',*/ #endif - &ffi_type_pointer, /*@':pointer-void',*/ - &ffi_type_pointer, /*@':cstring',*/ - &ffi_type_pointer, /*@':object',*/ - &ffi_type_float, /*@':float',*/ - &ffi_type_double, /*@':double',*/ - &ffi_type_void /*@':void'*/ + &ffi_type_pointer, /*@':pointer-void',*/ + &ffi_type_pointer, /*@':cstring',*/ + &ffi_type_pointer, /*@':object',*/ + &ffi_type_float, /*@':float',*/ + &ffi_type_double, /*@':double',*/ + &ffi_type_void /*@':void'*/ }; #endif /* HAVE_LIBFFI */ cl_object ecl_make_foreign_data(cl_object tag, cl_index size, void *data) { - cl_object output = ecl_alloc_object(t_foreign); - output->foreign.tag = tag == ECL_NIL ? @':void' : tag; - output->foreign.size = size; - output->foreign.data = (char*)data; - return output; + cl_object output = ecl_alloc_object(t_foreign); + output->foreign.tag = tag == ECL_NIL ? @':void' : tag; + output->foreign.size = size; + output->foreign.data = (char*)data; + return output; } cl_object ecl_allocate_foreign_data(cl_object tag, cl_index size) { - cl_object output = ecl_alloc_object(t_foreign); - output->foreign.tag = tag; - output->foreign.size = size; - output->foreign.data = (char*)ecl_alloc_atomic(size); - return output; + cl_object output = ecl_alloc_object(t_foreign); + output->foreign.tag = tag; + output->foreign.size = size; + output->foreign.data = (char*)ecl_alloc_atomic(size); + return output; } void * ecl_foreign_data_pointer_safe(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_only_arg(@[si::foreign-data-pointer], f, - @[si::foreign-data]); - } - return f->foreign.data; + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_only_arg(@[si::foreign-data-pointer], f, + @[si::foreign-data]); + } + return f->foreign.data; } char * ecl_base_string_pointer_safe(cl_object f) { - unsigned char *s; - /* FIXME! Is there a better function name? */ - f = ecl_check_cl_type(@'si::make-foreign-data-from-array', f, t_base_string); - s = f->base_string.self; - if (ecl_unlikely(ECL_ARRAY_HAS_FILL_POINTER_P(f) && - s[f->base_string.fillp] != 0)) { - FEerror("Cannot coerce a string with fill pointer to (char *)", 0); - } - return (char *)s; + unsigned char *s; + /* FIXME! Is there a better function name? */ + f = ecl_check_cl_type(@'si::make-foreign-data-from-array', f, t_base_string); + s = f->base_string.self; + if (ecl_unlikely(ECL_ARRAY_HAS_FILL_POINTER_P(f) && + s[f->base_string.fillp] != 0)) { + FEerror("Cannot coerce a string with fill pointer to (char *)", 0); + } + return (char *)s; } cl_object ecl_null_terminated_base_string(cl_object f) { - /* FIXME! Is there a better function name? */ - f = ecl_check_cl_type(@'si::make-foreign-data-from-array', f, t_base_string); - if (ECL_ARRAY_HAS_FILL_POINTER_P(f) && - f->base_string.self[f->base_string.fillp] != 0) { - return cl_copy_seq(f); - } else { - return f; - } + /* FIXME! Is there a better function name? */ + f = ecl_check_cl_type(@'si::make-foreign-data-from-array', f, t_base_string); + if (ECL_ARRAY_HAS_FILL_POINTER_P(f) && + f->base_string.self[f->base_string.fillp] != 0) { + return cl_copy_seq(f); + } else { + return f; + } } cl_object si_allocate_foreign_data(cl_object tag, cl_object size) { - cl_object output = ecl_alloc_object(t_foreign); - cl_index bytes = ecl_to_size(size); - output->foreign.tag = tag; - output->foreign.size = bytes; - /* FIXME! Should be atomic uncollectable or malloc, but we do not export - * that garbage collector interface and malloc may be overwritten - * by the GC library */ - output->foreign.data = bytes? ecl_alloc_uncollectable(bytes) : NULL; - @(return output) + cl_object output = ecl_alloc_object(t_foreign); + cl_index bytes = ecl_to_size(size); + output->foreign.tag = tag; + output->foreign.size = bytes; + /* FIXME! Should be atomic uncollectable or malloc, but we do not export + * that garbage collector interface and malloc may be overwritten + * by the GC library */ + output->foreign.data = bytes? ecl_alloc_uncollectable(bytes) : NULL; + @(return output); } cl_object si_free_foreign_data(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_only_arg(@[si::free-foreign-data], f, - @[si::foreign-data]); - } - if (f->foreign.size) { - /* See si_allocate_foreign_data() */ - ecl_free_uncollectable(f->foreign.data); - } - f->foreign.size = 0; - f->foreign.data = NULL; - @(return) + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_only_arg(@[si::free-foreign-data], f, + @[si::foreign-data]); + } + if (f->foreign.size) { + /* See si_allocate_foreign_data() */ + ecl_free_uncollectable(f->foreign.data); + } + f->foreign.size = 0; + f->foreign.data = NULL; + @(return); } cl_object si_make_foreign_data_from_array(cl_object array) { - cl_object tag; - if (!ECL_ARRAYP (array)) - FEwrong_type_only_arg(@[si::make-foreign-data-from-array], - array, @[array]); - tag = ecl_aet_to_ffi_table[array->array.elttype]; - if (ecl_unlikely(Null(tag))) { - FEerror("Cannot make foreign object from array " - "with element type ~S.", 1, - ecl_elttype_to_symbol(array->array.elttype)); - } - @(return ecl_make_foreign_data(tag, 0, array->array.self.bc)); + cl_object tag; + if (!ECL_ARRAYP (array)) + FEwrong_type_only_arg(@[si::make-foreign-data-from-array], + array, @[array]); + tag = ecl_aet_to_ffi_table[array->array.elttype]; + if (ecl_unlikely(Null(tag))) { + FEerror("Cannot make foreign object from array " + "with element type ~S.", 1, + ecl_elttype_to_symbol(array->array.elttype)); + } + @(return ecl_make_foreign_data(tag, 0, array->array.self.bc)); } cl_object si_foreign_data_p(cl_object f) { - @(return (ECL_FOREIGN_DATA_P(f)? ECL_T : ECL_NIL)) + @(return (ECL_FOREIGN_DATA_P(f)? ECL_T : ECL_NIL)); } cl_object si_foreign_data_address(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_only_arg(@[si::foreign-data-address], f, - @[si::foreign-data]); - } - @(return ecl_make_unsigned_integer((cl_index)f->foreign.data)) + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_only_arg(@[si::foreign-data-address], f, + @[si::foreign-data]); + } + @(return ecl_make_unsigned_integer((cl_index)f->foreign.data)); } cl_object si_foreign_data_tag(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_only_arg(@[si::foreign-data-tag], f, - @[si::foreign-data]); - } - @(return f->foreign.tag); + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_only_arg(@[si::foreign-data-tag], f, + @[si::foreign-data]); + } + @(return f->foreign.tag); } cl_object si_foreign_data_equal(cl_object f1, cl_object f2) { - if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f1))) { - FEwrong_type_only_arg(@[si::foreign-data-address], f1, - @[si::foreign-data]); - } - if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f2))) { - FEwrong_type_only_arg(@[si::foreign-data-address], f2, - @[si::foreign-data]); - } - @(return ((f1->foreign.data == f2->foreign.data)? ECL_T : ECL_NIL)) + if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f1))) { + FEwrong_type_only_arg(@[si::foreign-data-address], f1, + @[si::foreign-data]); + } + if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f2))) { + FEwrong_type_only_arg(@[si::foreign-data-address], f2, + @[si::foreign-data]); + } + @(return ((f1->foreign.data == f2->foreign.data)? ECL_T : ECL_NIL)); } cl_object si_foreign_data_pointer(cl_object f, cl_object andx, cl_object asize, cl_object tag) { - cl_index ndx = ecl_to_size(andx); - cl_index size = ecl_to_size(asize); - cl_object output; + cl_index ndx = ecl_to_size(andx); + cl_index size = ecl_to_size(asize); + cl_object output; - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_only_arg(@[si::foreign-data-pointer], f, - @[si::foreign-data]); - } - if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - output = ecl_alloc_object(t_foreign); - output->foreign.tag = tag; - output->foreign.size = size; - output->foreign.data = f->foreign.data + ndx; - @(return output) + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_only_arg(@[si::foreign-data-pointer], f, + @[si::foreign-data]); + } + if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + output = ecl_alloc_object(t_foreign); + output->foreign.tag = tag; + output->foreign.size = size; + output->foreign.data = f->foreign.data + ndx; + @(return output); } cl_object si_foreign_data_ref(cl_object f, cl_object andx, cl_object asize, cl_object tag) { - cl_index ndx = ecl_to_size(andx); - cl_index size = ecl_to_size(asize); - cl_object output; + cl_index ndx = ecl_to_size(andx); + cl_index size = ecl_to_size(asize); + cl_object output; - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_nth_arg(@[si::foreign-data-ref], 1, f, - @[si::foreign-data]); - } - if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - output = ecl_allocate_foreign_data(tag, size); - memcpy(output->foreign.data, f->foreign.data + ndx, size); - @(return output) + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_nth_arg(@[si::foreign-data-ref], 1, f, + @[si::foreign-data]); + } + if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + output = ecl_allocate_foreign_data(tag, size); + memcpy(output->foreign.data, f->foreign.data + ndx, size); + @(return output); } cl_object si_foreign_data_set(cl_object f, cl_object andx, cl_object value) { - cl_index ndx = ecl_to_size(andx); - cl_index size, limit; + cl_index ndx = ecl_to_size(andx); + cl_index size, limit; - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_nth_arg(@[si::foreign-data-set], 1, f, - @[si::foreign-data]); - } - if (ecl_unlikely(ecl_t_of(value) != t_foreign)) { - FEwrong_type_nth_arg(@[si::foreign-data-set], 3, value, - @[si::foreign-data]); - } - size = value->foreign.size; - limit = f->foreign.size; - if (ecl_unlikely(ndx >= limit || (limit - ndx) < size)) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - memcpy(f->foreign.data + ndx, value->foreign.data, size); - @(return value) + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_nth_arg(@[si::foreign-data-set], 1, f, + @[si::foreign-data]); + } + if (ecl_unlikely(ecl_t_of(value) != t_foreign)) { + FEwrong_type_nth_arg(@[si::foreign-data-set], 3, value, + @[si::foreign-data]); + } + size = value->foreign.size; + limit = f->foreign.size; + if (ecl_unlikely(ndx >= limit || (limit - ndx) < size)) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + memcpy(f->foreign.data + ndx, value->foreign.data, size); + @(return value); } static int foreign_type_code(cl_object type) { - int i; - for (i = 0; i <= ECL_FFI_VOID; i++) { - if (type == ecl_foreign_type_table[i].name) - return i; - } - return -1; + int i; + for (i = 0; i <= ECL_FFI_VOID; i++) { + if (type == ecl_foreign_type_table[i].name) + return i; + } + return -1; } enum ecl_ffi_tag ecl_foreign_type_code(cl_object type) { - int i = foreign_type_code(type); - if (ecl_unlikely(i < 0)) { - FEerror("~A does not denote an elementary foreign type.", 1, type); - } - return (enum ecl_ffi_tag)i; + int i = foreign_type_code(type); + if (ecl_unlikely(i < 0)) { + FEerror("~A does not denote an elementary foreign type.", 1, type); + } + return (enum ecl_ffi_tag)i; } #ifdef HAVE_LIBFFI ffi_abi ecl_foreign_cc_code(cl_object cc) { - int i; - for (i = 0; i <= ECL_FFI_CC_STDCALL; i++) { - if (cc == ecl_foreign_cc_table[i].symbol) - return ecl_foreign_cc_table[i].abi; - } - FEerror("~A does no denote a valid calling convention.", 1, cc); - return ECL_FFI_CC_CDECL; + int i; + for (i = 0; i <= ECL_FFI_CC_STDCALL; i++) { + if (cc == ecl_foreign_cc_table[i].symbol) + return ecl_foreign_cc_table[i].abi; + } + FEerror("~A does no denote a valid calling convention.", 1, cc); + return ECL_FFI_CC_CDECL; } #endif @@ -431,280 +426,280 @@ static void wrong_ffi_tag(enum ecl_ffi_tag tag) ecl_attr_noreturn; static void wrong_ffi_tag(enum ecl_ffi_tag tag) { - FEerror("Invalid ecl_ffi_tag code ~D", 1, ecl_make_integer(tag)); + FEerror("Invalid ecl_ffi_tag code ~D", 1, ecl_make_integer(tag)); } cl_object ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag tag) { - switch (tag) { - case ECL_FFI_CHAR: - return ECL_CODE_CHAR(*(char *)p); - case ECL_FFI_UNSIGNED_CHAR: - return ECL_CODE_CHAR(*(unsigned char *)p); - case ECL_FFI_BYTE: - return ecl_make_fixnum(*(int8_t *)p); - case ECL_FFI_UNSIGNED_BYTE: - return ecl_make_fixnum(*(uint8_t *)p); - case ECL_FFI_SHORT: - return ecl_make_fixnum(*(short *)p); - case ECL_FFI_UNSIGNED_SHORT: - return ecl_make_fixnum(*(unsigned short *)p); - case ECL_FFI_INT: - return ecl_make_integer(*(int *)p); - case ECL_FFI_UNSIGNED_INT: - return ecl_make_unsigned_integer(*(unsigned int *)p); - case ECL_FFI_LONG: - return ecl_make_integer(*(long *)p); + switch (tag) { + case ECL_FFI_CHAR: + return ECL_CODE_CHAR(*(char *)p); + case ECL_FFI_UNSIGNED_CHAR: + return ECL_CODE_CHAR(*(unsigned char *)p); + case ECL_FFI_BYTE: + return ecl_make_fixnum(*(int8_t *)p); + case ECL_FFI_UNSIGNED_BYTE: + return ecl_make_fixnum(*(uint8_t *)p); + case ECL_FFI_SHORT: + return ecl_make_fixnum(*(short *)p); + case ECL_FFI_UNSIGNED_SHORT: + return ecl_make_fixnum(*(unsigned short *)p); + case ECL_FFI_INT: + return ecl_make_integer(*(int *)p); + case ECL_FFI_UNSIGNED_INT: + return ecl_make_unsigned_integer(*(unsigned int *)p); + case ECL_FFI_LONG: + return ecl_make_integer(*(long *)p); #ifdef ecl_uint8_t - case ECL_FFI_INT8_T: - return ecl_make_fixnum(*(ecl_int8_t *)p); - case ECL_FFI_UINT8_T: - return ecl_make_fixnum(*(ecl_uint8_t *)p); + case ECL_FFI_INT8_T: + return ecl_make_fixnum(*(ecl_int8_t *)p); + case ECL_FFI_UINT8_T: + return ecl_make_fixnum(*(ecl_uint8_t *)p); #endif #ifdef ecl_uint16_t - case ECL_FFI_INT16_T: - return ecl_make_int16_t(*(ecl_int16_t *)p); - case ECL_FFI_UINT16_T: - return ecl_make_uint16_t(*(ecl_uint16_t *)p); + case ECL_FFI_INT16_T: + return ecl_make_int16_t(*(ecl_int16_t *)p); + case ECL_FFI_UINT16_T: + return ecl_make_uint16_t(*(ecl_uint16_t *)p); #endif #ifdef ecl_uint32_t - case ECL_FFI_INT32_T: - return ecl_make_int32_t(*(ecl_int32_t *)p); - case ECL_FFI_UINT32_T: - return ecl_make_uint32_t(*(ecl_uint32_t *)p); + case ECL_FFI_INT32_T: + return ecl_make_int32_t(*(ecl_int32_t *)p); + case ECL_FFI_UINT32_T: + return ecl_make_uint32_t(*(ecl_uint32_t *)p); #endif #ifdef ecl_uint64_t - case ECL_FFI_INT64_T: - return ecl_make_int64_t(*(ecl_int64_t *)p); - case ECL_FFI_UINT64_T: - return ecl_make_uint64_t(*(ecl_uint64_t *)p); + case ECL_FFI_INT64_T: + return ecl_make_int64_t(*(ecl_int64_t *)p); + case ECL_FFI_UINT64_T: + return ecl_make_uint64_t(*(ecl_uint64_t *)p); #endif #ifdef ecl_long_long_t - case ECL_FFI_LONG_LONG: - return ecl_make_long_long(*(ecl_long_long_t *)p); - case ECL_FFI_UNSIGNED_LONG_LONG: - return ecl_make_ulong_long(*(ecl_ulong_long_t *)p); + case ECL_FFI_LONG_LONG: + return ecl_make_long_long(*(ecl_long_long_t *)p); + case ECL_FFI_UNSIGNED_LONG_LONG: + return ecl_make_ulong_long(*(ecl_ulong_long_t *)p); #endif - case ECL_FFI_UNSIGNED_LONG: - return ecl_make_unsigned_integer(*(unsigned long *)p); - case ECL_FFI_POINTER_VOID: - return ecl_make_foreign_data(@':pointer-void', 0, *(void **)p); - case ECL_FFI_CSTRING: - return *(char **)p ? - ecl_make_simple_base_string(*(char **)p, -1) : ECL_NIL; - case ECL_FFI_OBJECT: - return *(cl_object *)p; - case ECL_FFI_FLOAT: - return ecl_make_single_float(*(float *)p); - case ECL_FFI_DOUBLE: - return ecl_make_double_float(*(double *)p); - case ECL_FFI_VOID: - return ECL_NIL; - default: - wrong_ffi_tag(tag); - } + case ECL_FFI_UNSIGNED_LONG: + return ecl_make_unsigned_integer(*(unsigned long *)p); + case ECL_FFI_POINTER_VOID: + return ecl_make_foreign_data(@':pointer-void', 0, *(void **)p); + case ECL_FFI_CSTRING: + return *(char **)p ? + ecl_make_simple_base_string(*(char **)p, -1) : ECL_NIL; + case ECL_FFI_OBJECT: + return *(cl_object *)p; + case ECL_FFI_FLOAT: + return ecl_make_single_float(*(float *)p); + case ECL_FFI_DOUBLE: + return ecl_make_double_float(*(double *)p); + case ECL_FFI_VOID: + return ECL_NIL; + default: + wrong_ffi_tag(tag); + } } void ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag tag, cl_object value) { - switch (tag) { - case ECL_FFI_CHAR: - *(char *)p = (char)ecl_base_char_code(value); - break; - case ECL_FFI_UNSIGNED_CHAR: - *(unsigned char*)p = (unsigned char)ecl_base_char_code(value); - break; - case ECL_FFI_BYTE: - *(int8_t *)p = ecl_to_int8_t(value); - break; - case ECL_FFI_UNSIGNED_BYTE: - *(uint8_t *)p = ecl_to_uint8_t(value); - break; - case ECL_FFI_SHORT: - *(short *)p = ecl_to_short(value); - break; - case ECL_FFI_UNSIGNED_SHORT: - *(unsigned short *)p = ecl_to_ushort(value); - break; - case ECL_FFI_INT: - *(int *)p = ecl_to_int(value); - break; - case ECL_FFI_UNSIGNED_INT: - *(unsigned int *)p = ecl_to_uint(value); - break; - case ECL_FFI_LONG: - *(long *)p = ecl_to_long(value); - break; - case ECL_FFI_UNSIGNED_LONG: - *(unsigned long *)p = ecl_to_ulong(value); - break; - case ECL_FFI_INT8_T: - *(ecl_int8_t *)p = ecl_to_int8_t(value); - break; - case ECL_FFI_UINT8_T: - *(ecl_uint8_t *)p = ecl_to_uint8_t(value); - break; + switch (tag) { + case ECL_FFI_CHAR: + *(char *)p = (char)ecl_base_char_code(value); + break; + case ECL_FFI_UNSIGNED_CHAR: + *(unsigned char*)p = (unsigned char)ecl_base_char_code(value); + break; + case ECL_FFI_BYTE: + *(int8_t *)p = ecl_to_int8_t(value); + break; + case ECL_FFI_UNSIGNED_BYTE: + *(uint8_t *)p = ecl_to_uint8_t(value); + break; + case ECL_FFI_SHORT: + *(short *)p = ecl_to_short(value); + break; + case ECL_FFI_UNSIGNED_SHORT: + *(unsigned short *)p = ecl_to_ushort(value); + break; + case ECL_FFI_INT: + *(int *)p = ecl_to_int(value); + break; + case ECL_FFI_UNSIGNED_INT: + *(unsigned int *)p = ecl_to_uint(value); + break; + case ECL_FFI_LONG: + *(long *)p = ecl_to_long(value); + break; + case ECL_FFI_UNSIGNED_LONG: + *(unsigned long *)p = ecl_to_ulong(value); + break; + case ECL_FFI_INT8_T: + *(ecl_int8_t *)p = ecl_to_int8_t(value); + break; + case ECL_FFI_UINT8_T: + *(ecl_uint8_t *)p = ecl_to_uint8_t(value); + break; #ifdef ecl_uint16_t - case ECL_FFI_INT16_T: - *(ecl_int16_t *)p = ecl_to_int16_t(value); - break; - case ECL_FFI_UINT16_T: - *(ecl_uint16_t *)p = ecl_to_uint16_t(value); - break; + case ECL_FFI_INT16_T: + *(ecl_int16_t *)p = ecl_to_int16_t(value); + break; + case ECL_FFI_UINT16_T: + *(ecl_uint16_t *)p = ecl_to_uint16_t(value); + break; #endif #ifdef ecl_uint32_t - case ECL_FFI_INT32_T: - *(ecl_int32_t *)p = ecl_to_int32_t(value); - break; - case ECL_FFI_UINT32_T: - *(ecl_uint32_t *)p = ecl_to_uint32_t(value); - break; + case ECL_FFI_INT32_T: + *(ecl_int32_t *)p = ecl_to_int32_t(value); + break; + case ECL_FFI_UINT32_T: + *(ecl_uint32_t *)p = ecl_to_uint32_t(value); + break; #endif #ifdef ecl_uint64_t - case ECL_FFI_INT64_T: - *(ecl_int64_t *)p = ecl_to_int64_t(value); - break; - case ECL_FFI_UINT64_T: - *(ecl_uint64_t *)p = ecl_to_uint64_t(value); - break; + case ECL_FFI_INT64_T: + *(ecl_int64_t *)p = ecl_to_int64_t(value); + break; + case ECL_FFI_UINT64_T: + *(ecl_uint64_t *)p = ecl_to_uint64_t(value); + break; #endif #ifdef ecl_long_long_t - case ECL_FFI_LONG_LONG: - *(ecl_long_long_t *)p = ecl_to_long_long(value); - break; - case ECL_FFI_UNSIGNED_LONG_LONG: - *(ecl_ulong_long_t *)p = ecl_to_ulong_long(value); - break; + case ECL_FFI_LONG_LONG: + *(ecl_long_long_t *)p = ecl_to_long_long(value); + break; + case ECL_FFI_UNSIGNED_LONG_LONG: + *(ecl_ulong_long_t *)p = ecl_to_ulong_long(value); + break; #endif - case ECL_FFI_POINTER_VOID: - *(void **)p = ecl_foreign_data_pointer_safe(value); - break; - case ECL_FFI_CSTRING: - *(char **)p = value == ECL_NIL ? NULL : (char*)value->base_string.self; - break; - case ECL_FFI_OBJECT: - *(cl_object *)p = value; - break; - case ECL_FFI_FLOAT: - *(float *)p = ecl_to_float(value); - break; - case ECL_FFI_DOUBLE: - *(double *)p = ecl_to_double(value); - break; - case ECL_FFI_VOID: - break; - default: - wrong_ffi_tag(tag); - } + case ECL_FFI_POINTER_VOID: + *(void **)p = ecl_foreign_data_pointer_safe(value); + break; + case ECL_FFI_CSTRING: + *(char **)p = value == ECL_NIL ? NULL : (char*)value->base_string.self; + break; + case ECL_FFI_OBJECT: + *(cl_object *)p = value; + break; + case ECL_FFI_FLOAT: + *(float *)p = ecl_to_float(value); + break; + case ECL_FFI_DOUBLE: + *(double *)p = ecl_to_double(value); + break; + case ECL_FFI_VOID: + break; + default: + wrong_ffi_tag(tag); + } } cl_object si_foreign_data_ref_elt(cl_object f, cl_object andx, cl_object type) { - cl_index ndx = ecl_to_size(andx); - cl_index limit = f->foreign.size; - enum ecl_ffi_tag tag = ecl_foreign_type_code(type); - if (ecl_unlikely(ndx >= limit || - (ndx + ecl_foreign_type_table[tag].size > limit))) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_nth_arg(@[si::foreign-data-ref-elt], 1, f, - @[si::foreign-data]); - } - @(return ecl_foreign_data_ref_elt((void*)(f->foreign.data + ndx), tag)) + cl_index ndx = ecl_to_size(andx); + cl_index limit = f->foreign.size; + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + if (ecl_unlikely(ndx >= limit || + (ndx + ecl_foreign_type_table[tag].size > limit))) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_nth_arg(@[si::foreign-data-ref-elt], 1, f, + @[si::foreign-data]); + } + @(return ecl_foreign_data_ref_elt((void*)(f->foreign.data + ndx), tag)); } cl_object si_foreign_data_set_elt(cl_object f, cl_object andx, cl_object type, cl_object value) { - cl_index ndx = ecl_to_size(andx); - cl_index limit = f->foreign.size; - enum ecl_ffi_tag tag = ecl_foreign_type_code(type); - if (ecl_unlikely(ndx >= limit || - ndx + ecl_foreign_type_table[tag].size > limit)) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_nth_arg(@[si::foreign-data-set-elt], 1, f, - @[si::foreign-data]); - } - ecl_foreign_data_set_elt((void*)(f->foreign.data + ndx), tag, value); - @(return value) + cl_index ndx = ecl_to_size(andx); + cl_index limit = f->foreign.size; + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + if (ecl_unlikely(ndx >= limit || + ndx + ecl_foreign_type_table[tag].size > limit)) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_nth_arg(@[si::foreign-data-set-elt], 1, f, + @[si::foreign-data]); + } + ecl_foreign_data_set_elt((void*)(f->foreign.data + ndx), tag, value); + @(return value); } cl_object si_size_of_foreign_elt_type(cl_object type) { - enum ecl_ffi_tag tag = ecl_foreign_type_code(type); - @(return ecl_make_fixnum(ecl_foreign_type_table[tag].size)) + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + @(return ecl_make_fixnum(ecl_foreign_type_table[tag].size)); } cl_object si_alignment_of_foreign_elt_type(cl_object type) { - enum ecl_ffi_tag tag = ecl_foreign_type_code(type); - @(return ecl_make_fixnum(ALIGNMENT(tag))) + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + @(return ecl_make_fixnum(ALIGNMENT(tag))); } cl_object si_foreign_elt_type_p(cl_object type) { - @(return ((foreign_type_code(type) < 0)? ECL_NIL : ECL_T)) + @(return ((foreign_type_code(type) < 0)? ECL_NIL : ECL_T)); } cl_object si_null_pointer_p(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) - FEwrong_type_only_arg(@[si::null-pointer-p], f, - @[si::foreign-data]); - @(return ((f->foreign.data == NULL)? ECL_T : ECL_NIL)) + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) + FEwrong_type_only_arg(@[si::null-pointer-p], f, + @[si::foreign-data]); + @(return ((f->foreign.data == NULL)? ECL_T : ECL_NIL)); } cl_object si_foreign_data_recast(cl_object f, cl_object size, cl_object tag) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) - FEwrong_type_nth_arg(@[si::foreign-data-recast], 1, f, - @[si::foreign-data]); - f->foreign.size = ecl_to_size(size); - f->foreign.tag = tag; - @(return f) + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) + FEwrong_type_nth_arg(@[si::foreign-data-recast], 1, f, + @[si::foreign-data]); + f->foreign.size = ecl_to_size(size); + f->foreign.tag = tag; + @(return f); } cl_object si_load_foreign_module(cl_object filename) { #if !defined(ENABLE_DLOPEN) - FEerror("SI:LOAD-FOREIGN-MODULE does not work when ECL is statically linked", 0); + FEerror("SI:LOAD-FOREIGN-MODULE does not work when ECL is statically linked", 0); #else - cl_object output; + cl_object output; # ifdef ECL_THREADS - mp_get_lock(1, ecl_symbol_value(@'mp::+load-compile-lock+')); - ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { + mp_get_lock(1, ecl_symbol_value(@'mp::+load-compile-lock+')); + ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { # endif - output = ecl_library_open(filename, 0); - if (output->cblock.handle == NULL) { - cl_object aux = ecl_library_error(output); - ecl_library_close(output); - output = aux; - } + output = ecl_library_open(filename, 0); + if (output->cblock.handle == NULL) { + cl_object aux = ecl_library_error(output); + ecl_library_close(output); + output = aux; + } # ifdef ECL_THREADS - (void)0; /* MSVC complains about missing ';' before '}' */ - } ECL_UNWIND_PROTECT_EXIT { - mp_giveup_lock(ecl_symbol_value(@'mp::+load-compile-lock+')); - } ECL_UNWIND_PROTECT_END; + (void)0; /* MSVC complains about missing ';' before '}' */ + } ECL_UNWIND_PROTECT_EXIT { + mp_giveup_lock(ecl_symbol_value(@'mp::+load-compile-lock+')); + } ECL_UNWIND_PROTECT_END; # endif - if (ecl_unlikely(ecl_t_of(output) != t_codeblock)) { - FEerror("LOAD-FOREIGN-MODULE: Could not load " - "foreign module ~S (Error: ~S)", 2, filename, output); - } - output->cblock.locked |= 1; - @(return output) + if (ecl_unlikely(ecl_t_of(output) != t_codeblock)) { + FEerror("LOAD-FOREIGN-MODULE: Could not load " + "foreign module ~S (Error: ~S)", 2, filename, output); + } + output->cblock.locked |= 1; + @(return output); #endif } @@ -712,26 +707,26 @@ cl_object si_unload_foreign_module(cl_object module) { #if !defined(ENABLE_DLOPEN) - FEerror("SI:UNLOAD-FOREIGN-MODULE does not work when ECL is statically linked", 0); + FEerror("SI:UNLOAD-FOREIGN-MODULE does not work when ECL is statically linked", 0); #else - cl_object output = ECL_NIL; + cl_object output = ECL_NIL; - if (ecl_unlikely(ecl_t_of(module) != t_codeblock)) { - FEerror("UNLOAD-FOREIGN-MODULE: Argument is not a foreign module: ~S ", - 1, module); - } + if (ecl_unlikely(ecl_t_of(module) != t_codeblock)) { + FEerror("UNLOAD-FOREIGN-MODULE: Argument is not a foreign module: ~S ", + 1, module); + } # ifdef ECL_THREADS - mp_get_lock(1, ecl_symbol_value(@'mp::+load-compile-lock+')); - ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { + mp_get_lock(1, ecl_symbol_value(@'mp::+load-compile-lock+')); + ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { # endif - if (ecl_likely(ecl_library_close(module))) output = ECL_T; + if (ecl_likely(ecl_library_close(module))) output = ECL_T; # ifdef ECL_THREADS - (void)0; /* MSVC complains about missing ';' before '}' */ - } ECL_UNWIND_PROTECT_EXIT { - mp_giveup_lock(ecl_symbol_value(@'mp::+load-compile-lock+')); - } ECL_UNWIND_PROTECT_END; + (void)0; /* MSVC complains about missing ';' before '}' */ + } ECL_UNWIND_PROTECT_EXIT { + mp_giveup_lock(ecl_symbol_value(@'mp::+load-compile-lock+')); + } ECL_UNWIND_PROTECT_END; # endif - @(return output) + @(return output); #endif } @@ -739,27 +734,27 @@ cl_object si_find_foreign_symbol(cl_object var, cl_object module, cl_object type, cl_object size) { #if !defined(ENABLE_DLOPEN) - FEerror("SI:FIND-FOREIGN-SYMBOL does not work when ECL is statically linked", 0); + FEerror("SI:FIND-FOREIGN-SYMBOL does not work when ECL is statically linked", 0); #else - cl_object block; - cl_object output = ECL_NIL; - void *sym; + cl_object block; + cl_object output = ECL_NIL; + void *sym; - block = (module == @':default' ? module : si_load_foreign_module(module)); - var = ecl_null_terminated_base_string(var); - sym = ecl_library_symbol(block, (char*)var->base_string.self, 1); - if (sym == NULL) { - if (block != @':default') - output = ecl_library_error(block); - goto OUTPUT; - } - output = ecl_make_foreign_data(type, ecl_to_fixnum(size), sym); -OUTPUT: - if (ecl_unlikely(ecl_t_of(output) != t_foreign)) - FEerror("FIND-FOREIGN-SYMBOL: Could not load " - "foreign symbol ~S from module ~S (Error: ~S)", - 3, var, module, output); - @(return output) + block = (module == @':default' ? module : si_load_foreign_module(module)); + var = ecl_null_terminated_base_string(var); + sym = ecl_library_symbol(block, (char*)var->base_string.self, 1); + if (sym == NULL) { + if (block != @':default') + output = ecl_library_error(block); + goto OUTPUT; + } + output = ecl_make_foreign_data(type, ecl_to_fixnum(size), sym); + OUTPUT: + if (ecl_unlikely(ecl_t_of(output) != t_foreign)) + FEerror("FIND-FOREIGN-SYMBOL: Could not load " + "foreign symbol ~S from module ~S (Error: ~S)", + 3, var, module, output); + @(return output); #endif } @@ -767,26 +762,26 @@ OUTPUT: static void resize_call_stack(cl_env_ptr env, cl_index new_size) { - cl_index i; - ffi_type **types = - ecl_alloc_atomic((new_size + 1) * sizeof(ffi_type*)); - union ecl_ffi_values *values = - ecl_alloc_atomic((new_size + 1) * sizeof(union ecl_ffi_values)); - union ecl_ffi_values **values_ptrs = - ecl_alloc_atomic(new_size * sizeof(union ecl_ffi_values *)); - memcpy(types, env->ffi_types, env->ffi_args_limit * sizeof(ffi_type*)); - memcpy(values, env->ffi_values, env->ffi_args_limit * - sizeof(union ecl_ffi_values)); - for (i = 0; i < new_size; i++) { - values_ptrs[i] = (values + i + 1); - } - env->ffi_args_limit = new_size; - ecl_dealloc(env->ffi_types); - env->ffi_types = types; - ecl_dealloc(env->ffi_values); - env->ffi_values = values; - ecl_dealloc(env->ffi_values_ptrs); - env->ffi_values_ptrs = values_ptrs; + cl_index i; + ffi_type **types = + ecl_alloc_atomic((new_size + 1) * sizeof(ffi_type*)); + union ecl_ffi_values *values = + ecl_alloc_atomic((new_size + 1) * sizeof(union ecl_ffi_values)); + union ecl_ffi_values **values_ptrs = + ecl_alloc_atomic(new_size * sizeof(union ecl_ffi_values *)); + memcpy(types, env->ffi_types, env->ffi_args_limit * sizeof(ffi_type*)); + memcpy(values, env->ffi_values, env->ffi_args_limit * + sizeof(union ecl_ffi_values)); + for (i = 0; i < new_size; i++) { + values_ptrs[i] = (values + i + 1); + } + env->ffi_args_limit = new_size; + ecl_dealloc(env->ffi_types); + env->ffi_types = types; + ecl_dealloc(env->ffi_values); + env->ffi_values = values; + ecl_dealloc(env->ffi_values_ptrs); + env->ffi_values_ptrs = values_ptrs; } static int @@ -794,139 +789,135 @@ prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type, cl_object arg_types, cl_object args, cl_object cc_type, ffi_type ***output_copy) { - int n, ok; - ffi_type **types; - enum ecl_ffi_tag type = ecl_foreign_type_code(return_type); - if (!the_env->ffi_args_limit) - resize_call_stack(the_env, 32); - the_env->ffi_types[0] = ecl_type_to_libffi_type[type]; - for (n=0; !Null(arg_types); ) { - if (!LISTP(arg_types)) { - FEerror("In CALL-CFUN, types lists is not a proper list", 0); - } - if (n >= the_env->ffi_args_limit) { - resize_call_stack(the_env, n + 32); - } - type = ecl_foreign_type_code(ECL_CONS_CAR(arg_types)); - arg_types = ECL_CONS_CDR(arg_types); - the_env->ffi_types[++n] = ecl_type_to_libffi_type[type]; - if (CONSP(args)) { - cl_object object = ECL_CONS_CAR(args); - args = ECL_CONS_CDR(args); - if (type == ECL_FFI_CSTRING) { - object = ecl_null_terminated_base_string(CAR(args)); - if (ECL_CONS_CAR(args) != object) { - ECL_STACK_PUSH(the_env, object); - } - } - ecl_foreign_data_set_elt(the_env->ffi_values + n, type, object); - } + int n, ok; + ffi_type **types; + enum ecl_ffi_tag type = ecl_foreign_type_code(return_type); + if (!the_env->ffi_args_limit) + resize_call_stack(the_env, 32); + the_env->ffi_types[0] = ecl_type_to_libffi_type[type]; + for (n=0; !Null(arg_types); ) { + if (!LISTP(arg_types)) { + FEerror("In CALL-CFUN, types lists is not a proper list", 0); + } + if (n >= the_env->ffi_args_limit) { + resize_call_stack(the_env, n + 32); + } + type = ecl_foreign_type_code(ECL_CONS_CAR(arg_types)); + arg_types = ECL_CONS_CDR(arg_types); + the_env->ffi_types[++n] = ecl_type_to_libffi_type[type]; + if (CONSP(args)) { + cl_object object = ECL_CONS_CAR(args); + args = ECL_CONS_CDR(args); + if (type == ECL_FFI_CSTRING) { + object = ecl_null_terminated_base_string(CAR(args)); + if (ECL_CONS_CAR(args) != object) { + ECL_STACK_PUSH(the_env, object); } - if (output_copy) { - cl_index bytes = (n + 1) * sizeof(ffi_type*); - *output_copy = types = (ffi_type**)ecl_alloc_atomic(bytes); - memcpy(types, the_env->ffi_types, bytes); - } else { - types = the_env->ffi_types; - } - ok = ffi_prep_cif(cif, ecl_foreign_cc_code(cc_type), n, types[0], types + 1); - if (ok != FFI_OK) { - if (ok == FFI_BAD_ABI) { - FEerror("In CALL-CFUN, not a valid ABI: ~A", 1, - cc_type); - } - if (ok == FFI_BAD_TYPEDEF) { - FEerror("In CALL-CFUN, wrong or malformed argument types", 0); - } - } - return n; + } + ecl_foreign_data_set_elt(the_env->ffi_values + n, type, object); + } + } + if (output_copy) { + cl_index bytes = (n + 1) * sizeof(ffi_type*); + *output_copy = types = (ffi_type**)ecl_alloc_atomic(bytes); + memcpy(types, the_env->ffi_types, bytes); + } else { + types = the_env->ffi_types; + } + ok = ffi_prep_cif(cif, ecl_foreign_cc_code(cc_type), n, types[0], types + 1); + if (ok != FFI_OK) { + if (ok == FFI_BAD_ABI) { + FEerror("In CALL-CFUN, not a valid ABI: ~A", 1, + cc_type); + } + if (ok == FFI_BAD_TYPEDEF) { + FEerror("In CALL-CFUN, wrong or malformed argument types", 0); + } + } + return n; } @(defun si::call-cfun (fun return_type arg_types args &optional (cc_type @':default')) - void *cfun = ecl_foreign_data_pointer_safe(fun); - cl_object object; - volatile cl_index sp; - ffi_cif cif; -@ -{ - sp = ECL_STACK_INDEX(the_env); - prepare_cif(the_env, &cif, return_type, arg_types, args, cc_type, NULL); - ffi_call(&cif, cfun, the_env->ffi_values, (void **)the_env->ffi_values_ptrs); - object = ecl_foreign_data_ref_elt(the_env->ffi_values, - ecl_foreign_type_code(return_type)); - ECL_STACK_SET_INDEX(the_env, sp); - @(return object) -} -@) + void *cfun = ecl_foreign_data_pointer_safe(fun); + cl_object object; + volatile cl_index sp; + ffi_cif cif; +@ { + sp = ECL_STACK_INDEX(the_env); + prepare_cif(the_env, &cif, return_type, arg_types, args, cc_type, NULL); + ffi_call(&cif, cfun, the_env->ffi_values, (void **)the_env->ffi_values_ptrs); + object = ecl_foreign_data_ref_elt(the_env->ffi_values, + ecl_foreign_type_code(return_type)); + ECL_STACK_SET_INDEX(the_env, sp); + @(return object); +} @) static void callback_executor(ffi_cif *cif, void *result, void **args, void *userdata) { - cl_object data = (cl_object)userdata; - cl_object fun = ECL_CONS_CAR(data); - cl_object ret_type = (data = ECL_CONS_CDR(data), ECL_CONS_CAR(data)); - cl_object arg_types = (data = ECL_CONS_CDR(data), ECL_CONS_CAR(data)); - cl_env_ptr the_env = ecl_process_env(); - struct ecl_stack_frame frame_aux; - const cl_object frame = ecl_stack_frame_open(the_env, (cl_object)&frame_aux, 0); - cl_object x; - while (arg_types != ECL_NIL) { - cl_object type = ECL_CONS_CAR(arg_types); - enum ecl_ffi_tag tag = ecl_foreign_type_code(type); - x = ecl_foreign_data_ref_elt(*args, tag); - ecl_stack_frame_push(frame, x); - arg_types = ECL_CONS_CDR(arg_types); - args++; - } - x = ecl_apply_from_stack_frame(frame, fun); - ecl_stack_frame_close(frame); - ecl_foreign_data_set_elt(result, ecl_foreign_type_code(ret_type), x); + cl_object data = (cl_object)userdata; + cl_object fun = ECL_CONS_CAR(data); + cl_object ret_type = (data = ECL_CONS_CDR(data), ECL_CONS_CAR(data)); + cl_object arg_types = (data = ECL_CONS_CDR(data), ECL_CONS_CAR(data)); + cl_env_ptr the_env = ecl_process_env(); + struct ecl_stack_frame frame_aux; + const cl_object frame = ecl_stack_frame_open(the_env, (cl_object)&frame_aux, 0); + cl_object x; + while (arg_types != ECL_NIL) { + cl_object type = ECL_CONS_CAR(arg_types); + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + x = ecl_foreign_data_ref_elt(*args, tag); + ecl_stack_frame_push(frame, x); + arg_types = ECL_CONS_CDR(arg_types); + args++; + } + x = ecl_apply_from_stack_frame(frame, fun); + ecl_stack_frame_close(frame); + ecl_foreign_data_set_elt(result, ecl_foreign_type_code(ret_type), x); } cl_object si_free_ffi_closure(cl_object closure) { - ffi_closure_free(ecl_foreign_data_pointer_safe(closure)); - @(return); + ffi_closure_free(ecl_foreign_data_pointer_safe(closure)); + @(return); } @(defun si::make-dynamic-callback (fun sym return_type arg_types &optional (cc_type @':default')) -@ -{ - ffi_cif *cif = ecl_alloc(sizeof(ffi_cif)); - ffi_type **types; - int n = prepare_cif(the_env, cif, return_type, arg_types, ECL_NIL, cc_type, - &types); +@ { + ffi_cif *cif = ecl_alloc(sizeof(ffi_cif)); + ffi_type **types; + int n = prepare_cif(the_env, cif, return_type, arg_types, ECL_NIL, cc_type, + &types); - /* libffi allocates executable memory for us. ffi_closure_alloc() - * returns a pointer to memory and a pointer to the beginning of - * the actual executable region (executable_closure) which is - * where the code resides. */ - void *executable_region; - ffi_closure *closure = ffi_closure_alloc(sizeof(ffi_closure), &executable_region); + /* libffi allocates executable memory for us. ffi_closure_alloc() + * returns a pointer to memory and a pointer to the beginning of + * the actual executable region (executable_closure) which is + * where the code resides. */ + void *executable_region; + ffi_closure *closure = ffi_closure_alloc(sizeof(ffi_closure), &executable_region); - cl_object closure_object = ecl_make_foreign_data(@':pointer-void', - sizeof(ffi_closure), - closure); - si_set_finalizer(closure_object, @'si::free-ffi-closure'); + cl_object closure_object = ecl_make_foreign_data(@':pointer-void', + sizeof(ffi_closure), + closure); + si_set_finalizer(closure_object, @'si::free-ffi-closure'); - cl_object data = cl_list(6, closure_object, - fun, return_type, arg_types, cc_type, - ecl_make_foreign_data(@':pointer-void', - sizeof(*cif), cif), - ecl_make_foreign_data(@':pointer-void', - (n + 1) * sizeof(ffi_type*), - types)); - int status = ffi_prep_closure_loc(closure, cif, callback_executor, - ECL_CONS_CDR(data), executable_region); + cl_object data = cl_list(6, closure_object, + fun, return_type, arg_types, cc_type, + ecl_make_foreign_data(@':pointer-void', + sizeof(*cif), cif), + ecl_make_foreign_data(@':pointer-void', + (n + 1) * sizeof(ffi_type*), + types)); + int status = ffi_prep_closure_loc(closure, cif, callback_executor, + ECL_CONS_CDR(data), executable_region); - if (status != FFI_OK) { - FEerror("Unable to build callback. libffi returns ~D", 1, - ecl_make_fixnum(status)); - } - si_put_sysprop(sym, @':callback', data); - @(return closure_object); -} -@) + if (status != FFI_OK) { + FEerror("Unable to build callback. libffi returns ~D", 1, + ecl_make_fixnum(status)); + } + si_put_sysprop(sym, @':callback', data); + @(return closure_object); +} @) #endif /* HAVE_LIBFFI */ diff --git a/src/c/ffi/backtrace.d b/src/c/ffi/backtrace.d index 8a39088f0..ce4b8d655 100644 --- a/src/c/ffi/backtrace.d +++ b/src/c/ffi/backtrace.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - backtrace.d -- C backtraces -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ + * backtrace.d - C backtraces + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -34,43 +29,43 @@ static int backtrace(void **buffer, int n) { - int nframes = (n > 32)? 32 : n; - int i; - switch (nframes) { - case 32: buffer[31] = __builtin_return_address(31); - case 31: buffer[30] = __builtin_return_address(30); - case 30: buffer[29] = __builtin_return_address(29); - case 29: buffer[28] = __builtin_return_address(28); - case 28: buffer[27] = __builtin_return_address(27); - case 27: buffer[26] = __builtin_return_address(26); - case 26: buffer[25] = __builtin_return_address(25); - case 25: buffer[24] = __builtin_return_address(24); - case 24: buffer[23] = __builtin_return_address(23); - case 23: buffer[22] = __builtin_return_address(22); - case 22: buffer[21] = __builtin_return_address(21); - case 21: buffer[20] = __builtin_return_address(20); - case 20: buffer[19] = __builtin_return_address(19); - case 19: buffer[18] = __builtin_return_address(18); - case 18: buffer[17] = __builtin_return_address(17); - case 17: buffer[16] = __builtin_return_address(16); - case 16: buffer[15] = __builtin_return_address(15); - case 15: buffer[14] = __builtin_return_address(14); - case 14: buffer[13] = __builtin_return_address(13); - case 13: buffer[12] = __builtin_return_address(12); - case 12: buffer[11] = __builtin_return_address(11); - case 11: buffer[10] = __builtin_return_address(10); - case 10: buffer[9] = __builtin_return_address(9); - case 9: buffer[8] = __builtin_return_address(8); - case 8: buffer[7] = __builtin_return_address(7); - case 7: buffer[6] = __builtin_return_address(6); - case 6: buffer[5] = __builtin_return_address(5); - case 5: buffer[4] = __builtin_return_address(4); - case 4: buffer[3] = __builtin_return_address(3); - case 3: buffer[2] = __builtin_return_address(2); - case 2: buffer[1] = __builtin_return_address(1); - case 1: buffer[0] = __builtin_return_address(0); - } - return nframes; + int nframes = (n > 32)? 32 : n; + int i; + switch (nframes) { + case 32: buffer[31] = __builtin_return_address(31); + case 31: buffer[30] = __builtin_return_address(30); + case 30: buffer[29] = __builtin_return_address(29); + case 29: buffer[28] = __builtin_return_address(28); + case 28: buffer[27] = __builtin_return_address(27); + case 27: buffer[26] = __builtin_return_address(26); + case 26: buffer[25] = __builtin_return_address(25); + case 25: buffer[24] = __builtin_return_address(24); + case 24: buffer[23] = __builtin_return_address(23); + case 23: buffer[22] = __builtin_return_address(22); + case 22: buffer[21] = __builtin_return_address(21); + case 21: buffer[20] = __builtin_return_address(20); + case 20: buffer[19] = __builtin_return_address(19); + case 19: buffer[18] = __builtin_return_address(18); + case 18: buffer[17] = __builtin_return_address(17); + case 17: buffer[16] = __builtin_return_address(16); + case 16: buffer[15] = __builtin_return_address(15); + case 15: buffer[14] = __builtin_return_address(14); + case 14: buffer[13] = __builtin_return_address(13); + case 13: buffer[12] = __builtin_return_address(12); + case 12: buffer[11] = __builtin_return_address(11); + case 11: buffer[10] = __builtin_return_address(10); + case 10: buffer[9] = __builtin_return_address(9); + case 9: buffer[8] = __builtin_return_address(8); + case 8: buffer[7] = __builtin_return_address(7); + case 7: buffer[6] = __builtin_return_address(6); + case 6: buffer[5] = __builtin_return_address(5); + case 5: buffer[4] = __builtin_return_address(4); + case 4: buffer[3] = __builtin_return_address(3); + case 3: buffer[2] = __builtin_return_address(2); + case 2: buffer[1] = __builtin_return_address(1); + case 1: buffer[0] = __builtin_return_address(0); + } + return nframes; } #endif @@ -81,17 +76,17 @@ backtrace(void **buffer, int n) static char ** backtrace_symbols(void **buffer, int nframes) { - Dl_info data[1]; - int i; - char **strings = malloc(nframes * sizeof(char*)); - for (i = 0; i < nframes; i++) { - if (dladdr(buffer[i], data)) { - strings[i] = data->dli_sname; - } else { - strings[i] = "unknown"; - } - } - return strings; + Dl_info data[1]; + int i; + char **strings = malloc(nframes * sizeof(char*)); + for (i = 0; i < nframes; i++) { + if (dladdr(buffer[i], data)) { + strings[i] = data->dli_sname; + } else { + strings[i] = "unknown"; + } + } + return strings; } # endif /* HAVE_BACKTRACE && HAVE_DLADDR */ #endif /* !HAVE_BACKTRACE_SYMBOLS */ @@ -99,32 +94,32 @@ backtrace_symbols(void **buffer, int nframes) cl_object si_dump_c_backtrace(cl_object size) { - cl_env_ptr the_env = ecl_process_env(); + cl_env_ptr the_env = ecl_process_env(); #ifdef HAVE_BACKTRACE_SYMBOLS - { - void *pointers[32]; - int nframes = backtrace(pointers, 32); - char **names = backtrace_symbols(pointers, nframes); - int i; - fprintf(stderr, "\n;;; ECL C Backtrace\n"); - for (i = 0; i < nframes; i++) { + { + void *pointers[32]; + int nframes = backtrace(pointers, 32); + char **names = backtrace_symbols(pointers, nframes); + int i; + fprintf(stderr, "\n;;; ECL C Backtrace\n"); + for (i = 0; i < nframes; i++) { #ifdef BACKTRACE_SYMBOLS_SIMPLE - fprintf(stderr, ";;; %4d %s (%p) \n", i, names[i], pointers[i]); + fprintf(stderr, ";;; %4d %s (%p) \n", i, names[i], pointers[i]); #else - fprintf(stderr, ";;; %s\n", names[i]); + fprintf(stderr, ";;; %s\n", names[i]); #endif - } - fflush(stderr); - free(names); - } - ecl_return1(the_env, ECL_T); + } + fflush(stderr); + free(names); + } + ecl_return1(the_env, ECL_T); #else - ecl_return1(the_env, ECL_NIL); + ecl_return1(the_env, ECL_NIL); #endif } cl_object si_backtrace(cl_object start, cl_object end) { - @(return ECL_NIL) + @(return ECL_NIL); } diff --git a/src/c/ffi/cdata.d b/src/c/ffi/cdata.d index 81f8f113a..2cad49257 100644 --- a/src/c/ffi/cdata.d +++ b/src/c/ffi/cdata.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - cdata.d -- Data for compiled files. -*/ -/* - Copyright (c) 2011, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ + * cdata.d - data for compiled files + * + * Copyright (c) 2011 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -23,8 +18,8 @@ #define HEADER_PREFIX_LENGTH 15 typedef struct { - char code[16]; - cl_index offset, size; + char code[16]; + cl_index offset, size; } cdata_header; ecl_def_ct_base_string(str_no_data,"",0,static,const); @@ -32,55 +27,55 @@ ecl_def_ct_base_string(str_no_data,"",0,static,const); cl_object si_get_cdata(cl_object filename) { - cl_object map, array, displaced; - cdata_header *header; - map = si_mmap(3, filename, @':direction', @':input'); - array = si_mmap_array(map); - { - char *v = (char*)array->base_string.self - + array->base_string.dim - - sizeof(cdata_header); - header = (cdata_header*)v; + cl_object map, array, displaced; + cdata_header *header; + map = si_mmap(3, filename, @':direction', @':input'); + array = si_mmap_array(map); + { + char *v = (char*)array->base_string.self + + array->base_string.dim + - sizeof(cdata_header); + header = (cdata_header*)v; - } - if (memcmp(header->code, HEADER_PREFIX, HEADER_PREFIX_LENGTH)) { - displaced = str_no_data; - } else { - displaced = cl_funcall(8, @'make-array', - ecl_make_fixnum(header->size), - @':element-type', @'base-char', - @':displaced-to', array, - @':displaced-index-offset', - ecl_make_fixnum(header->offset)); - } - @(return map displaced); + } + if (memcmp(header->code, HEADER_PREFIX, HEADER_PREFIX_LENGTH)) { + displaced = str_no_data; + } else { + displaced = cl_funcall(8, @'make-array', + ecl_make_fixnum(header->size), + @':element-type', @'base-char', + @':displaced-to', array, + @':displaced-index-offset', + ecl_make_fixnum(header->offset)); + } + @(return map displaced); } cl_object si_add_cdata(cl_object filename, cl_object data) { - cl_object stream, offset; - cdata_header header; + cl_object stream, offset; + cdata_header header; - data = si_copy_to_simple_base_string(data); - stream = cl_open(9, filename, - @':element-type', @'base-char', - @':direction', @':output', - @':if-does-not-exist', @':error', - @':if-exists', @':append'); - offset = ecl_file_length(stream); - ecl_file_position_set(stream, offset); - cl_write_sequence(2, data, stream); - memcpy(header.code, HEADER_PREFIX, HEADER_PREFIX_LENGTH); - header.offset = fixnnint(offset); - header.size = data->base_string.dim; - { - unsigned char *c = (unsigned char *)&header; - int i; - for (i = 0; i < sizeof(header); i++) { - ecl_write_byte(ecl_make_fixnum(c[i]), stream); - } - } - cl_close(1, stream); - @(return) + data = si_copy_to_simple_base_string(data); + stream = cl_open(9, filename, + @':element-type', @'base-char', + @':direction', @':output', + @':if-does-not-exist', @':error', + @':if-exists', @':append'); + offset = ecl_file_length(stream); + ecl_file_position_set(stream, offset); + cl_write_sequence(2, data, stream); + memcpy(header.code, HEADER_PREFIX, HEADER_PREFIX_LENGTH); + header.offset = fixnnint(offset); + header.size = data->base_string.dim; + { + unsigned char *c = (unsigned char *)&header; + int i; + for (i = 0; i < sizeof(header); i++) { + ecl_write_byte(ecl_make_fixnum(c[i]), stream); + } + } + cl_close(1, stream); + @(return); } diff --git a/src/c/ffi/libraries.d b/src/c/ffi/libraries.d index c8be30c81..a39f20129 100644 --- a/src/c/ffi/libraries.d +++ b/src/c/ffi/libraries.d @@ -1,20 +1,15 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - load.d -- Shared library and bundle opening / copying / closing -*/ -/* - Copyright (c) 1990, Giuseppe Attardi and William F. Schelter. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ + * libraries.d - shared library and bundle opening / copying / closing + * + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include /* @@ -78,384 +73,384 @@ cl_object ecl_make_codeblock() { - cl_object block = ecl_alloc(t_codeblock); - block = ecl_alloc_object(t_codeblock); - block->cblock.self_destruct = 0; - block->cblock.locked = 0; - block->cblock.handle = NULL; - block->cblock.data = NULL; - block->cblock.data_size = 0; - block->cblock.temp_data = NULL; - block->cblock.temp_data_size = 0; - block->cblock.data_text = NULL; - block->cblock.next = ECL_NIL; - block->cblock.name = ECL_NIL; - block->cblock.links = ECL_NIL; - block->cblock.cfuns_size = 0; - block->cblock.cfuns = NULL; - block->cblock.source = ECL_NIL; - block->cblock.error = ECL_NIL; - block->cblock.refs = ecl_make_fixnum(0); - si_set_finalizer(block, ECL_T); - return block; + cl_object block = ecl_alloc(t_codeblock); + block = ecl_alloc_object(t_codeblock); + block->cblock.self_destruct = 0; + block->cblock.locked = 0; + block->cblock.handle = NULL; + block->cblock.data = NULL; + block->cblock.data_size = 0; + block->cblock.temp_data = NULL; + block->cblock.temp_data_size = 0; + block->cblock.data_text = NULL; + block->cblock.next = ECL_NIL; + block->cblock.name = ECL_NIL; + block->cblock.links = ECL_NIL; + block->cblock.cfuns_size = 0; + block->cblock.cfuns = NULL; + block->cblock.source = ECL_NIL; + block->cblock.error = ECL_NIL; + block->cblock.refs = ecl_make_fixnum(0); + si_set_finalizer(block, ECL_T); + return block; } static cl_object copy_object_file(cl_object original) { - int err; - cl_object copy = make_constant_base_string("TMP:ECL"); - copy = si_coerce_to_filename(si_mkstemp(copy)); - /* - * We either have to make a full copy to convince the loader to load this object - * file again, or we want to retain the possibility of overwriting the object - * file we load later on (case of Windows, which locks files that are loaded). - * The symlinks do not seem to work in latest versions of Linux. - */ + int err; + cl_object copy = make_constant_base_string("TMP:ECL"); + copy = si_coerce_to_filename(si_mkstemp(copy)); + /* + * We either have to make a full copy to convince the loader to load this object + * file again, or we want to retain the possibility of overwriting the object + * file we load later on (case of Windows, which locks files that are loaded). + * The symlinks do not seem to work in latest versions of Linux. + */ #if defined(ECL_MS_WINDOWS_HOST) - ecl_disable_interrupts(); - err = !CopyFile(original->base_string.self, copy->base_string.self, 0); - ecl_enable_interrupts(); - if (err) { - FEwin32_error("Error when copying file from~&~3T~A~&to~&~3T~A", - 2, original, copy); - } + ecl_disable_interrupts(); + err = !CopyFile(original->base_string.self, copy->base_string.self, 0); + ecl_enable_interrupts(); + if (err) { + FEwin32_error("Error when copying file from~&~3T~A~&to~&~3T~A", + 2, original, copy); + } #else - err = Null(si_copy_file(original, copy)); - if (err) { - FEerror("Error when copying file from~&~3T~A~&to~&~3T~A", - 2, original, copy); - } + err = Null(si_copy_file(original, copy)); + if (err) { + FEerror("Error when copying file from~&~3T~A~&to~&~3T~A", + 2, original, copy); + } #endif #ifdef cygwin - { - cl_object new_copy = make_constant_base_string(".dll"); - new_copy = si_base_string_concatenate(2, copy, new_copy); - cl_rename_file(2, copy, new_copy); - copy = new_copy; - } - ecl_disable_interrupts(); - err = chmod(copy->base_string.self, S_IRWXU) < 0; - ecl_enable_interrupts(); - if (err) { - FElibc_error("Unable to give executable permissions to ~A", - 1, copy); - } + { + cl_object new_copy = make_constant_base_string(".dll"); + new_copy = si_base_string_concatenate(2, copy, new_copy); + cl_rename_file(2, copy, new_copy); + copy = new_copy; + } + ecl_disable_interrupts(); + err = chmod(copy->base_string.self, S_IRWXU) < 0; + ecl_enable_interrupts(); + if (err) { + FElibc_error("Unable to give executable permissions to ~A", + 1, copy); + } #endif - return copy; + return copy; } #ifdef ENABLE_DLOPEN static void set_library_error(cl_object block) { - cl_object output; - ecl_disable_interrupts(); + cl_object output; + ecl_disable_interrupts(); #ifdef HAVE_DLFCN_H - output = make_base_string_copy(dlerror()); + output = make_base_string_copy(dlerror()); #endif #ifdef HAVE_MACH_O_DYLD_H - { - NSLinkEditErrors c; - int number; - const char *filename; - NSLinkEditError(&c, &number, &filename, &message); - output = make_base_string_copy(message); - } + { + NSLinkEditErrors c; + int number; + const char *filename; + NSLinkEditError(&c, &number, &filename, &message); + output = make_base_string_copy(message); + } #endif #if defined(ECL_MS_WINDOWS_HOST) - { - const char *message; - FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | - FORMAT_MESSAGE_ALLOCATE_BUFFER, - 0, GetLastError(), 0, (void*)&message, 0, NULL); - output = make_base_string_copy(message); - LocalFree(message); - } + { + const char *message; + FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | + FORMAT_MESSAGE_ALLOCATE_BUFFER, + 0, GetLastError(), 0, (void*)&message, 0, NULL); + output = make_base_string_copy(message); + LocalFree(message); + } #endif - ecl_enable_interrupts(); - block->cblock.error = output; + ecl_enable_interrupts(); + block->cblock.error = output; } static void dlopen_wrapper(cl_object block) { - cl_object filename = block->cblock.name; - char *filename_string = (char*)filename->base_string.self; + cl_object filename = block->cblock.name; + char *filename_string = (char*)filename->base_string.self; #ifdef HAVE_DLFCN_H - block->cblock.handle = dlopen(filename_string, RTLD_NOW|RTLD_GLOBAL); + block->cblock.handle = dlopen(filename_string, RTLD_NOW|RTLD_GLOBAL); #endif #ifdef HAVE_MACH_O_DYLD_H - { - NSObjectFileImage file; - static NSObjectFileImageReturnCode code; - code = NSCreateObjectFileImageFromFile(filename_string, &file); - if (code != NSObjectFileImageSuccess) { - block->cblock.handle = NULL; - } else { - NSModule out = NSLinkModule(file, filename_string, - NSLINKMODULE_OPTION_PRIVATE| - NSLINKMODULE_OPTION_BINDNOW| - NSLINKMODULE_OPTION_RETURN_ON_ERROR); - block->cblock.handle = out; - }} + { + NSObjectFileImage file; + static NSObjectFileImageReturnCode code; + code = NSCreateObjectFileImageFromFile(filename_string, &file); + if (code != NSObjectFileImageSuccess) { + block->cblock.handle = NULL; + } else { + NSModule out = NSLinkModule(file, filename_string, + NSLINKMODULE_OPTION_PRIVATE| + NSLINKMODULE_OPTION_BINDNOW| + NSLINKMODULE_OPTION_RETURN_ON_ERROR); + block->cblock.handle = out; + }} #endif #if defined(ECL_MS_WINDOWS_HOST) - block->cblock.handle = LoadLibrary(filename_string); + block->cblock.handle = LoadLibrary(filename_string); #endif - if (block->cblock.handle == NULL) - set_library_error(block); + if (block->cblock.handle == NULL) + set_library_error(block); } static int dlclose_wrapper(cl_object block) { - if (block->cblock.handle != NULL) { + if (block->cblock.handle != NULL) { #ifdef HAVE_DLFCN_H - dlclose(block->cblock.handle); + dlclose(block->cblock.handle); #endif #ifdef HAVE_MACH_O_DYLD_H - NSUnLinkModule(block->cblock.handle, NSUNLINKMODULE_OPTION_NONE); + NSUnLinkModule(block->cblock.handle, NSUNLINKMODULE_OPTION_NONE); #endif #if defined(ECL_MS_WINDOWS_HOST) - FreeLibrary(block->cblock.handle); + FreeLibrary(block->cblock.handle); #endif - block->cblock.handle = NULL; - return TRUE; - } - return FALSE; + block->cblock.handle = NULL; + return TRUE; + } + return FALSE; } static cl_object ecl_library_find_by_name(cl_object filename) { - cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object other = ECL_CONS_CAR(l); - cl_object name = other->cblock.name; - if (!Null(name) && ecl_string_eq(name, filename)) { - return other; - } - } - return ECL_NIL; + cl_object l; + for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object other = ECL_CONS_CAR(l); + cl_object name = other->cblock.name; + if (!Null(name) && ecl_string_eq(name, filename)) { + return other; + } + } + return ECL_NIL; } static cl_object ecl_library_find_by_handle(void *handle) { - cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object other = ECL_CONS_CAR(l); - if (handle == other->cblock.handle) { - return other; - } - } - return ECL_NIL; + cl_object l; + for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object other = ECL_CONS_CAR(l); + if (handle == other->cblock.handle) { + return other; + } + } + return ECL_NIL; } static cl_object ecl_library_open_inner(cl_object filename, bool self_destruct) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object block = ecl_make_codeblock(); - block->cblock.self_destruct = self_destruct; - block->cblock.name = filename; - block->cblock.refs = ecl_make_fixnum(1); + const cl_env_ptr the_env = ecl_process_env(); + cl_object block = ecl_make_codeblock(); + block->cblock.self_destruct = self_destruct; + block->cblock.name = filename; + block->cblock.refs = ecl_make_fixnum(1); - ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) { - ecl_disable_interrupts(); - GC_call_with_alloc_lock(dlopen_wrapper, block); - if (block->cblock.handle != NULL) { - /* Have we already loaded this library? If so, then unload this - * copy and increase the reference counter so that we can keep - * track (in lisp) of how many copies we use. - */ - cl_object other = ecl_library_find_by_handle(block->cblock.handle); - if (other != ECL_NIL) { - GC_call_with_alloc_lock(dlclose_wrapper, block); - block = other; - block->cblock.refs = ecl_one_plus(block->cblock.refs); - } else { - si_set_finalizer(block, ECL_T); - cl_core.libraries = CONS(block, cl_core.libraries); - } - } - ecl_enable_interrupts(); - } ECL_WITH_GLOBAL_LOCK_END; - return block; + ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) { + ecl_disable_interrupts(); + GC_call_with_alloc_lock(dlopen_wrapper, block); + if (block->cblock.handle != NULL) { + /* Have we already loaded this library? If so, then unload this + * copy and increase the reference counter so that we can keep + * track (in lisp) of how many copies we use. + */ + cl_object other = ecl_library_find_by_handle(block->cblock.handle); + if (other != ECL_NIL) { + GC_call_with_alloc_lock(dlclose_wrapper, block); + block = other; + block->cblock.refs = ecl_one_plus(block->cblock.refs); + } else { + si_set_finalizer(block, ECL_T); + cl_core.libraries = CONS(block, cl_core.libraries); + } + } + ecl_enable_interrupts(); + } ECL_WITH_GLOBAL_LOCK_END; + return block; } cl_object ecl_library_open(cl_object filename, bool force_reload) { - cl_object block; - bool self_destruct = 0; - char *filename_string; + cl_object block; + bool self_destruct = 0; + char *filename_string; - /* Coerces to a file name but does not merge with cwd */ - filename = coerce_to_physical_pathname(filename); - filename = ecl_namestring(filename, - ECL_NAMESTRING_TRUNCATE_IF_ERROR | - ECL_NAMESTRING_FORCE_BASE_STRING); + /* Coerces to a file name but does not merge with cwd */ + filename = coerce_to_physical_pathname(filename); + filename = ecl_namestring(filename, + ECL_NAMESTRING_TRUNCATE_IF_ERROR | + ECL_NAMESTRING_FORCE_BASE_STRING); - if (!force_reload) { - /* When loading a foreign library, such as a dll or a - * so, it cannot contain any executable top level - * code. In that case force_reload=0 and there is no - * need to reload it if it has already been loaded. */ - block = ecl_library_find_by_name(filename); - if (!Null(block)) { - return block; - } - } else { - /* We are using shared libraries as modules and - * force_reload=1. Here we have to face the problem - * that many operating systems do not allow to load a - * shared library twice, even if it has changed. Hence - * we have to make a unique copy to be able to load - * the same FASL twice. In Windows this copy is - * _always_ made because otherwise it cannot be - * overwritten. In Unix we need only do that when the - * file has been previously loaded. */ + if (!force_reload) { + /* When loading a foreign library, such as a dll or a + * so, it cannot contain any executable top level + * code. In that case force_reload=0 and there is no + * need to reload it if it has already been loaded. */ + block = ecl_library_find_by_name(filename); + if (!Null(block)) { + return block; + } + } else { + /* We are using shared libraries as modules and + * force_reload=1. Here we have to face the problem + * that many operating systems do not allow to load a + * shared library twice, even if it has changed. Hence + * we have to make a unique copy to be able to load + * the same FASL twice. In Windows this copy is + * _always_ made because otherwise it cannot be + * overwritten. In Unix we need only do that when the + * file has been previously loaded. */ #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) - filename = copy_object_file(filename); - self_destruct = 1; + filename = copy_object_file(filename); + self_destruct = 1; #else - block = ecl_library_find_by_name(filename); - if (!Null(block)) { - filename = copy_object_file(filename); - self_destruct = 1; - } + block = ecl_library_find_by_name(filename); + if (!Null(block)) { + filename = copy_object_file(filename); + self_destruct = 1; + } #endif - } + } DO_LOAD: - block = ecl_library_open_inner(filename, self_destruct); - /* - * A second pass to ensure that the dlopen routine has not - * returned a library that we had already loaded. If this is - * the case, we close the new copy to ensure we do refcounting - * right. - */ - if (block->cblock.refs != ecl_make_fixnum(1)) { - if (force_reload) { - ecl_library_close(block); - filename = copy_object_file(filename); - self_destruct = 1; - goto DO_LOAD; - } - } - return block; + block = ecl_library_open_inner(filename, self_destruct); + /* + * A second pass to ensure that the dlopen routine has not + * returned a library that we had already loaded. If this is + * the case, we close the new copy to ensure we do refcounting + * right. + */ + if (block->cblock.refs != ecl_make_fixnum(1)) { + if (force_reload) { + ecl_library_close(block); + filename = copy_object_file(filename); + self_destruct = 1; + goto DO_LOAD; + } + } + return block; } void * ecl_library_symbol(cl_object block, const char *symbol, bool lock) { - void *p; - if (block == @':default') { - cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object block = ECL_CONS_CAR(l); - p = ecl_library_symbol(block, symbol, lock); - if (p) return p; - } - ecl_disable_interrupts(); + void *p; + if (block == @':default') { + cl_object l; + for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object block = ECL_CONS_CAR(l); + p = ecl_library_symbol(block, symbol, lock); + if (p) return p; + } + ecl_disable_interrupts(); #if defined(ECL_MS_WINDOWS_HOST) - { - HANDLE hndSnap = NULL; - HANDLE hnd = NULL; - hndSnap = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, GetCurrentProcessId()); - if (hndSnap != INVALID_HANDLE_VALUE) - { - MODULEENTRY32 me32; - me32.dwSize = sizeof(MODULEENTRY32); - if (Module32First(hndSnap, &me32)) - { - do - hnd = GetProcAddress(me32.hModule, symbol); - while (hnd == NULL && Module32Next(hndSnap, &me32)); - } - CloseHandle(hndSnap); - } - p = (void*)hnd; - } + { + HANDLE hndSnap = NULL; + HANDLE hnd = NULL; + hndSnap = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, GetCurrentProcessId()); + if (hndSnap != INVALID_HANDLE_VALUE) + { + MODULEENTRY32 me32; + me32.dwSize = sizeof(MODULEENTRY32); + if (Module32First(hndSnap, &me32)) + { + do + hnd = GetProcAddress(me32.hModule, symbol); + while (hnd == NULL && Module32Next(hndSnap, &me32)); + } + CloseHandle(hndSnap); + } + p = (void*)hnd; + } #endif #ifdef HAVE_DLFCN_H - p = dlsym(0, symbol); + p = dlsym(0, symbol); #endif #if !defined(ECL_MS_WINDOWS_HOST) && !defined(HAVE_DLFCN_H) - p = 0; + p = 0; #endif - ecl_enable_interrupts(); - } else { - ecl_disable_interrupts(); + ecl_enable_interrupts(); + } else { + ecl_disable_interrupts(); #ifdef HAVE_DLFCN_H - p = dlsym(block->cblock.handle, symbol); + p = dlsym(block->cblock.handle, symbol); #endif #if defined(ECL_MS_WINDOWS_HOST) - { - HMODULE h = (HMODULE)(block->cblock.handle); - p = GetProcAddress(h, symbol); - } + { + HMODULE h = (HMODULE)(block->cblock.handle); + p = GetProcAddress(h, symbol); + } #endif #ifdef HAVE_MACH_O_DYLD_H - NSSymbol sym; - sym = NSLookupSymbolInModule((NSModule)(block->cblock.handle), - symbol); - if (sym == 0) { - p = 0; - } else { - p = NSAddressOfSymbol(sym); - } + NSSymbol sym; + sym = NSLookupSymbolInModule((NSModule)(block->cblock.handle), + symbol); + if (sym == 0) { + p = 0; + } else { + p = NSAddressOfSymbol(sym); + } #endif - ecl_enable_interrupts(); - /* Libraries whose symbols are being referenced by the FFI should not - * get garbage collected. Until we find a better solution we simply lock - * them for the rest of the runtime */ - if (p) { - block->cblock.locked |= lock; - } - } - if (!p) - set_library_error(block); - return p; + ecl_enable_interrupts(); + /* Libraries whose symbols are being referenced by the FFI should not + * get garbage collected. Until we find a better solution we simply lock + * them for the rest of the runtime */ + if (p) { + block->cblock.locked |= lock; + } + } + if (!p) + set_library_error(block); + return p; } cl_object ecl_library_error(cl_object block) { - return block->cblock.error; + return block->cblock.error; } bool ecl_library_close(cl_object block) { - const cl_env_ptr the_env = ecl_process_env(); - bool success = TRUE; - ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) { - ecl_disable_interrupts(); - /* is it ever a case? no matter how many times i call - load-foreign-module it seems that block->cblock.refs = 1 */ - if (block->cblock.refs > ecl_make_fixnum(1)) { - block->cblock.refs = ecl_one_minus(block->cblock.refs); - block = ECL_NIL; - } else if (block->cblock.handle != NULL) { - success = GC_call_with_alloc_lock(dlclose_wrapper, block); - cl_core.libraries = ecl_remove_eq(block, cl_core.libraries); - } else { /* block not loaded */ - success = FALSE; + const cl_env_ptr the_env = ecl_process_env(); + bool success = TRUE; + ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) { + ecl_disable_interrupts(); + /* is it ever a case? no matter how many times i call + load-foreign-module it seems that block->cblock.refs = 1 */ + if (block->cblock.refs > ecl_make_fixnum(1)) { + block->cblock.refs = ecl_one_minus(block->cblock.refs); + block = ECL_NIL; + } else if (block->cblock.handle != NULL) { + success = GC_call_with_alloc_lock(dlclose_wrapper, block); + cl_core.libraries = ecl_remove_eq(block, cl_core.libraries); + } else { /* block not loaded */ + success = FALSE; + } + ecl_enable_interrupts(); + } ECL_WITH_GLOBAL_LOCK_END; + if (block != ECL_NIL && block->cblock.self_destruct) { + if (!Null(block->cblock.name)) { + unlink((char*)block->cblock.name->base_string.self); + } } - ecl_enable_interrupts(); - } ECL_WITH_GLOBAL_LOCK_END; - if (block != ECL_NIL && block->cblock.self_destruct) { - if (!Null(block->cblock.name)) { - unlink((char*)block->cblock.name->base_string.self); - } - } - return success; + return success; } void ecl_library_close_all(void) { - while (cl_core.libraries != ECL_NIL) { - ecl_library_close(ECL_CONS_CAR(cl_core.libraries)); - } + while (cl_core.libraries != ECL_NIL) { + ecl_library_close(ECL_CONS_CAR(cl_core.libraries)); + } } ecl_def_ct_base_string(init_prefix, INIT_PREFIX, sizeof(INIT_PREFIX)-1, static, const); @@ -463,15 +458,15 @@ ecl_def_ct_base_string(init_prefix, INIT_PREFIX, sizeof(INIT_PREFIX)-1, static, cl_object _ecl_library_init_prefix(void) { - return init_prefix; + return init_prefix; } ecl_def_ct_base_string(default_entry, INIT_PREFIX "CODE", sizeof(INIT_PREFIX "CODE")-1, - static, const); + static, const); cl_object _ecl_library_default_entry(void) { - return default_entry; + return default_entry; } #endif /* ENABLE_DLOPEN */ diff --git a/src/c/ffi/mmap.d b/src/c/ffi/mmap.d index b0c77e935..ee1f49b65 100644 --- a/src/c/ffi/mmap.d +++ b/src/c/ffi/mmap.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - mmap.d -- Mapping of binary files. -*/ -/* - Copyright (c) 2011, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ + * mmap.d - mapping of binary files + * + * Copyright (c) 2011 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #ifdef HAVE_SYS_MMAN_H @@ -33,77 +28,77 @@ (external_format @':default')) @ #ifdef HAVE_SYS_MMAN_H -{ - cl_object output, stream; - int c_prot, c_flags, fd; - size_t len; - void *pa; - if (direction == @':input') - c_prot = PROT_READ; - else if (direction == @':output') - c_prot = PROT_WRITE; - else if (direction == @':io') - c_prot = PROT_READ | PROT_WRITE; - else - c_prot = PROT_NONE; - if (Null(filename)) { - c_flags = MAP_ANON | MAP_PRIVATE; - fd = -1; - len = ecl_to_unsigned_integer(length); - stream = ECL_NIL; - } else { - c_flags = MAP_SHARED; - stream = cl_open(13, filename, + { + cl_object output, stream; + int c_prot, c_flags, fd; + size_t len; + void *pa; + if (direction == @':input') + c_prot = PROT_READ; + else if (direction == @':output') + c_prot = PROT_WRITE; + else if (direction == @':io') + c_prot = PROT_READ | PROT_WRITE; + else + c_prot = PROT_NONE; + if (Null(filename)) { + c_flags = MAP_ANON | MAP_PRIVATE; + fd = -1; + len = ecl_to_unsigned_integer(length); + stream = ECL_NIL; + } else { + c_flags = MAP_SHARED; + stream = cl_open(13, filename, + @':direction', direction, + @':element-type', element_type, + @':if-exists', if_exists, + @':if-does-not-exist', if_does_not_exist, + @':external-format', @':default', + @':cstream', ECL_NIL); + fd = ecl_to_int(si_file_stream_fd(stream)); + if (Null(length)) + len = ecl_to_unsigned_integer(ecl_file_length(stream)); + else + len = ecl_to_unsigned_integer(length); + } + output = si_make_vector(element_type, ecl_make_fixnum(0), ECL_NIL, + ECL_NIL, ECL_NIL, ECL_NIL); + pa = mmap(0, len, c_prot, c_flags, fd, + ecl_integer_to_off_t(offset)); + if (pa == MAP_FAILED) { + FElibc_error("EXT::MMAP failed.", 0); + } else { + output->base_string.self = pa; + output->base_string.dim = + output->base_string.fillp = len; + } + @(return CONS(output, stream)); + } +#else + { + cl_object output, vector; + if (Null(filename)) { + output = si_make_vector(element_type, length, ECL_NIL, + ECL_NIL, ECL_NIL, ECL_NIL); + } else { + cl_object stream = cl_open(13, filename, @':direction', direction, @':element-type', element_type, @':if-exists', if_exists, @':if-does-not-exist', if_does_not_exist, - @':external-format', @':default', - @':cstream', ECL_NIL); - fd = ecl_to_int(si_file_stream_fd(stream)); - if (Null(length)) - len = ecl_to_unsigned_integer(ecl_file_length(stream)); - else - len = ecl_to_unsigned_integer(length); - } - output = si_make_vector(element_type, ecl_make_fixnum(0), ECL_NIL, - ECL_NIL, ECL_NIL, ECL_NIL); - pa = mmap(0, len, c_prot, c_flags, fd, - ecl_integer_to_off_t(offset)); - if (pa == MAP_FAILED) { - FElibc_error("EXT::MMAP failed.", 0); - } else { - output->base_string.self = pa; - output->base_string.dim = - output->base_string.fillp = len; - } - @(return CONS(output, stream)) -} -#else -{ - cl_object output, vector; - if (Null(filename)) { - output = si_make_vector(element_type, length, ECL_NIL, - ECL_NIL, ECL_NIL, ECL_NIL); - } else { - cl_object stream = cl_open(13, filename, - @':direction', direction, - @':element-type', element_type, - @':if-exists', if_exists, - @':if-does-not-exist', if_does_not_exist, - @':external-format', @':pass-through', - @':cstream', ECL_T); - if (Null(length)) - length = ecl_file_length(stream); - else - length = ecl_to_unsigned_integer(length); - output = si_make_vector(element_type, length, ECL_NIL, - ECL_NIL, ECL_NIL, ECL_NIL); - cl_read_sequence(2, output, stream); - cl_close(1, stream); - } - @(return output) -} + @':external-format', @':pass-through', + @':cstream', ECL_T); + if (Null(length)) + length = ecl_file_length(stream); + else + length = ecl_to_unsigned_integer(length); + output = si_make_vector(element_type, length, ECL_NIL, + ECL_NIL, ECL_NIL, ECL_NIL); + cl_read_sequence(2, output, stream); + cl_close(1, stream); + } + @(return output); + } #endif @) @@ -111,9 +106,9 @@ cl_object si_mmap_array(cl_object map) { #ifdef HAVE_SYS_MMAN_H - @(return cl_car(map)); + @(return cl_car(map)); #else - @(return map); + @(return map); #endif } @@ -121,13 +116,13 @@ cl_object si_munmap(cl_object map) { #ifdef HAVE_SYS_MMAN_H - cl_object array = cl_car(map); - cl_object stream = cl_cdr(map); - int code = munmap(array->base_string.self, array->base_string.dim); - if (code < 0) { - FElibc_error("Error when unmapping file.", 0); - } - cl_close(1, stream); + cl_object array = cl_car(map); + cl_object stream = cl_cdr(map); + int code = munmap(array->base_string.self, array->base_string.dim); + if (code < 0) { + FElibc_error("Error when unmapping file.", 0); + } + cl_close(1, stream); #endif - @(return ECL_NIL) + @(return ECL_NIL); } diff --git a/src/c/file.d b/src/c/file.d index 429e6a906..fabda6e70 100755 --- a/src/c/file.d +++ b/src/c/file.d @@ -1,27 +1,22 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - file.d -- File interface. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ + * file.d - file interface + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ /* - IMPLEMENTATION-DEPENDENT + IMPLEMENTATION-DEPENDENT - The file contains code to reclaim the I/O buffer - by accessing the FILE structure of C. + The file contains code to reclaim the I/O buffer + by accessing the FILE structure of C. */ #include @@ -104,129 +99,129 @@ static void wsock_error( const char *err_msg, cl_object strm ) ecl_attr_noreturn static cl_index not_output_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - not_an_output_stream(strm); - return 0; + not_an_output_stream(strm); + return 0; } static cl_index not_input_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - not_an_input_stream(strm); - return 0; + not_an_input_stream(strm); + return 0; } static cl_index not_binary_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - not_a_binary_stream(strm); - return 0; + not_a_binary_stream(strm); + return 0; } static void not_output_write_byte(cl_object c, cl_object strm) { - not_an_output_stream(strm); + not_an_output_stream(strm); } static cl_object not_input_read_byte(cl_object strm) { - not_an_input_stream(strm); - return OBJNULL; + not_an_input_stream(strm); + return OBJNULL; } static void not_binary_write_byte(cl_object c, cl_object strm) { - not_a_binary_stream(strm); + not_a_binary_stream(strm); } static cl_object not_binary_read_byte(cl_object strm) { - not_a_binary_stream(strm); - return OBJNULL; + not_a_binary_stream(strm); + return OBJNULL; } static ecl_character not_input_read_char(cl_object strm) { - not_an_input_stream(strm); - return -1; + not_an_input_stream(strm); + return -1; } static ecl_character not_output_write_char(cl_object strm, ecl_character c) { - not_an_output_stream(strm); - return c; + not_an_output_stream(strm); + return c; } static void not_input_unread_char(cl_object strm, ecl_character c) { - not_an_input_stream(strm); + not_an_input_stream(strm); } static int not_input_listen(cl_object strm) { - not_an_input_stream(strm); - return -1; + not_an_input_stream(strm); + return -1; } static ecl_character not_character_read_char(cl_object strm) { - not_a_character_stream(strm); - return -1; + not_a_character_stream(strm); + return -1; } static ecl_character not_character_write_char(cl_object strm, ecl_character c) { - not_a_character_stream(strm); - return c; + not_a_character_stream(strm); + return c; } static void not_input_clear_input(cl_object strm) { - not_an_input_stream(strm); - return; + not_an_input_stream(strm); + return; } static void not_output_clear_output(cl_object strm) { - not_an_output_stream(strm); + not_an_output_stream(strm); } static void not_output_force_output(cl_object strm) { - not_an_output_stream(strm); + not_an_output_stream(strm); } static void not_output_finish_output(cl_object strm) { - not_an_output_stream(strm); + not_an_output_stream(strm); } #if defined(ECL_WSOCK) static cl_object not_implemented_get_position(cl_object strm) { - FEerror("file-position not implemented for stream ~S", 1, strm); - return ECL_NIL; + FEerror("file-position not implemented for stream ~S", 1, strm); + return ECL_NIL; } static cl_object not_implemented_set_position(cl_object strm, cl_object pos) { - FEerror("file-position not implemented for stream ~S", 1, strm); - return ECL_NIL; + FEerror("file-position not implemented for stream ~S", 1, strm); + return ECL_NIL; } #endif @@ -237,48 +232,48 @@ not_implemented_set_position(cl_object strm, cl_object pos) static cl_index closed_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - FEclosed_stream(strm); - return 0; + FEclosed_stream(strm); + return 0; } static cl_index closed_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - FEclosed_stream(strm); - return 0; + FEclosed_stream(strm); + return 0; } static ecl_character closed_stream_read_char(cl_object strm) { - FEclosed_stream(strm); - return 0; + FEclosed_stream(strm); + return 0; } static ecl_character closed_stream_write_char(cl_object strm, ecl_character c) { - FEclosed_stream(strm); - return c; + FEclosed_stream(strm); + return c; } static void closed_stream_unread_char(cl_object strm, ecl_character c) { - FEclosed_stream(strm); + FEclosed_stream(strm); } static int closed_stream_listen(cl_object strm) { - FEclosed_stream(strm); - return 0; + FEclosed_stream(strm); + return 0; } static void closed_stream_clear_input(cl_object strm) { - FEclosed_stream(strm); + FEclosed_stream(strm); } #define closed_stream_clear_output closed_stream_clear_input @@ -288,7 +283,7 @@ closed_stream_clear_input(cl_object strm) static cl_object closed_stream_length(cl_object strm) { - FEclosed_stream(strm); + FEclosed_stream(strm); } #define closed_stream_get_position closed_stream_length @@ -296,7 +291,7 @@ closed_stream_length(cl_object strm) static cl_object closed_stream_set_position(cl_object strm, cl_object position) { - FEclosed_stream(strm); + FEclosed_stream(strm); } /********************************************************************** @@ -310,123 +305,123 @@ closed_stream_set_position(cl_object strm, cl_object position) static cl_object generic_read_byte_unsigned8(cl_object strm) { - unsigned char c; - if (strm->stream.ops->read_byte8(strm, &c, 1) < 1) { - return ECL_NIL; - } - return ecl_make_fixnum(c); + unsigned char c; + if (strm->stream.ops->read_byte8(strm, &c, 1) < 1) { + return ECL_NIL; + } + return ecl_make_fixnum(c); } static void generic_write_byte_unsigned8(cl_object byte, cl_object strm) { - unsigned char c = ecl_to_uint8_t(byte); - strm->stream.ops->write_byte8(strm, &c, 1); + unsigned char c = ecl_to_uint8_t(byte); + strm->stream.ops->write_byte8(strm, &c, 1); } static cl_object generic_read_byte_signed8(cl_object strm) { - signed char c; - if (strm->stream.ops->read_byte8(strm, (unsigned char *)&c, 1) < 1) - return ECL_NIL; - return ecl_make_fixnum(c); + signed char c; + if (strm->stream.ops->read_byte8(strm, (unsigned char *)&c, 1) < 1) + return ECL_NIL; + return ecl_make_fixnum(c); } static void generic_write_byte_signed8(cl_object byte, cl_object strm) { - signed char c = fixint(byte); - strm->stream.ops->write_byte8(strm, (unsigned char *)&c, 1); + signed char c = fixint(byte); + strm->stream.ops->write_byte8(strm, (unsigned char *)&c, 1); } static cl_object generic_read_byte_le(cl_object strm) { - cl_index (*read_byte8)(cl_object, unsigned char *, cl_index); - unsigned char c; - cl_index nb, bs; - cl_object output = ecl_make_fixnum(0); - read_byte8 = strm->stream.ops->read_byte8; - bs = strm->stream.byte_size; - for (nb = 0; bs >= 8; bs -= 8, nb += 8) { - cl_object aux; - if (read_byte8(strm, &c, 1) < 1) - return ECL_NIL; - if (bs <= 8 && (strm->stream.flags & ECL_STREAM_SIGNED_BYTES)) - aux = ecl_make_fixnum((signed char)c); - else - aux = ecl_make_fixnum((unsigned char)c); - output = cl_logior(2, output, cl_ash(aux, ecl_make_fixnum(nb))); - } - return output; + cl_index (*read_byte8)(cl_object, unsigned char *, cl_index); + unsigned char c; + cl_index nb, bs; + cl_object output = ecl_make_fixnum(0); + read_byte8 = strm->stream.ops->read_byte8; + bs = strm->stream.byte_size; + for (nb = 0; bs >= 8; bs -= 8, nb += 8) { + cl_object aux; + if (read_byte8(strm, &c, 1) < 1) + return ECL_NIL; + if (bs <= 8 && (strm->stream.flags & ECL_STREAM_SIGNED_BYTES)) + aux = ecl_make_fixnum((signed char)c); + else + aux = ecl_make_fixnum((unsigned char)c); + output = cl_logior(2, output, cl_ash(aux, ecl_make_fixnum(nb))); + } + return output; } static void generic_write_byte_le(cl_object c, cl_object strm) { - cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); - cl_index bs; - write_byte8 = strm->stream.ops->write_byte8; - bs = strm->stream.byte_size; - do { - cl_object b = cl_logand(2, c, ecl_make_fixnum(0xFF)); - unsigned char aux = (unsigned char)ecl_fixnum(b); - if (write_byte8(strm, &aux, 1) < 1) - break; - c = cl_ash(c, ecl_make_fixnum(-8)); - bs -= 8; - } while (bs); + cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); + cl_index bs; + write_byte8 = strm->stream.ops->write_byte8; + bs = strm->stream.byte_size; + do { + cl_object b = cl_logand(2, c, ecl_make_fixnum(0xFF)); + unsigned char aux = (unsigned char)ecl_fixnum(b); + if (write_byte8(strm, &aux, 1) < 1) + break; + c = cl_ash(c, ecl_make_fixnum(-8)); + bs -= 8; + } while (bs); } static cl_object generic_read_byte(cl_object strm) { - cl_index (*read_byte8)(cl_object, unsigned char *, cl_index); - unsigned char c; - cl_object output = NULL; - cl_index bs; - read_byte8 = strm->stream.ops->read_byte8; - bs = strm->stream.byte_size; - for (; bs >= 8; bs -= 8) { - if (read_byte8(strm, &c, 1) < 1) - return ECL_NIL; - if (output) { - output = cl_logior(2, ecl_make_fixnum(c), - cl_ash(output, ecl_make_fixnum(8))); - } else if (strm->stream.flags & ECL_STREAM_SIGNED_BYTES) { - output = ecl_make_fixnum((signed char)c); - } else { - output = ecl_make_fixnum((unsigned char)c); - } - } - return output; + cl_index (*read_byte8)(cl_object, unsigned char *, cl_index); + unsigned char c; + cl_object output = NULL; + cl_index bs; + read_byte8 = strm->stream.ops->read_byte8; + bs = strm->stream.byte_size; + for (; bs >= 8; bs -= 8) { + if (read_byte8(strm, &c, 1) < 1) + return ECL_NIL; + if (output) { + output = cl_logior(2, ecl_make_fixnum(c), + cl_ash(output, ecl_make_fixnum(8))); + } else if (strm->stream.flags & ECL_STREAM_SIGNED_BYTES) { + output = ecl_make_fixnum((signed char)c); + } else { + output = ecl_make_fixnum((unsigned char)c); + } + } + return output; } static void generic_write_byte(cl_object c, cl_object strm) { - cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); - cl_index bs; - write_byte8 = strm->stream.ops->write_byte8; - bs = strm->stream.byte_size; - do { - unsigned char aux; - cl_object b; - bs -= 8; - b = cl_logand(2, ecl_make_fixnum(0xFF), bs? cl_ash(c, ecl_make_fixnum(-bs)) : c); - aux = (unsigned char)ecl_fixnum(b); - if (write_byte8(strm, &aux, 1) < 1) - break; - } while (bs); + cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); + cl_index bs; + write_byte8 = strm->stream.ops->write_byte8; + bs = strm->stream.byte_size; + do { + unsigned char aux; + cl_object b; + bs -= 8; + b = cl_logand(2, ecl_make_fixnum(0xFF), bs? cl_ash(c, ecl_make_fixnum(-bs)) : c); + aux = (unsigned char)ecl_fixnum(b); + if (write_byte8(strm, &aux, 1) < 1) + break; + } while (bs); } static ecl_character generic_peek_char(cl_object strm) { - ecl_character out = ecl_read_char(strm); - if (out != EOF) ecl_unread_char(out, strm); - return out; + ecl_character out = ecl_read_char(strm); + if (out != EOF) ecl_unread_char(out, strm); + return out; } static void @@ -437,111 +432,111 @@ generic_void(cl_object strm) static int generic_always_true(cl_object strm) { - return 1; + return 1; } static int generic_always_false(cl_object strm) { - return 0; + return 0; } static cl_object generic_always_nil(cl_object strm) { - return ECL_NIL; + return ECL_NIL; } static int generic_column(cl_object strm) { - return 0; + return 0; } static cl_object generic_set_position(cl_object strm, cl_object pos) { - return ECL_NIL; + return ECL_NIL; } static cl_object generic_close(cl_object strm) { - struct ecl_file_ops *ops = strm->stream.ops; - if (ecl_input_stream_p(strm)) { - ops->read_byte8 = closed_stream_read_byte8; - ops->read_char = closed_stream_read_char; - ops->unread_char = closed_stream_unread_char; - ops->listen = closed_stream_listen; - ops->clear_input = closed_stream_clear_input; - } - if (ecl_output_stream_p(strm)) { - ops->write_byte8 = closed_stream_write_byte8; - ops->write_char = closed_stream_write_char; - ops->clear_output = closed_stream_clear_output; - ops->force_output = closed_stream_force_output; - ops->finish_output = closed_stream_finish_output; - } - ops->get_position = closed_stream_get_position; - ops->set_position = closed_stream_set_position; - ops->length = closed_stream_length; - ops->close = generic_close; - strm->stream.closed = 1; - return ECL_T; + struct ecl_file_ops *ops = strm->stream.ops; + if (ecl_input_stream_p(strm)) { + ops->read_byte8 = closed_stream_read_byte8; + ops->read_char = closed_stream_read_char; + ops->unread_char = closed_stream_unread_char; + ops->listen = closed_stream_listen; + ops->clear_input = closed_stream_clear_input; + } + if (ecl_output_stream_p(strm)) { + ops->write_byte8 = closed_stream_write_byte8; + ops->write_char = closed_stream_write_char; + ops->clear_output = closed_stream_clear_output; + ops->force_output = closed_stream_force_output; + ops->finish_output = closed_stream_finish_output; + } + ops->get_position = closed_stream_get_position; + ops->set_position = closed_stream_set_position; + ops->length = closed_stream_length; + ops->close = generic_close; + strm->stream.closed = 1; + return ECL_T; } static cl_index generic_write_vector(cl_object strm, cl_object data, cl_index start, cl_index end) { - cl_elttype elttype; - const struct ecl_file_ops *ops; - if (start >= end) - return start; - ops = stream_dispatch_table(strm); - elttype = ecl_array_elttype(data); - if (elttype == ecl_aet_bc || + cl_elttype elttype; + const struct ecl_file_ops *ops; + if (start >= end) + return start; + ops = stream_dispatch_table(strm); + elttype = ecl_array_elttype(data); + if (elttype == ecl_aet_bc || #ifdef ECL_UNICODE - elttype == ecl_aet_ch || + elttype == ecl_aet_ch || #endif - (elttype == ecl_aet_object && ECL_CHARACTERP(ecl_elt(data, 0)))) { - ecl_character (*write_char)(cl_object, ecl_character) = ops->write_char; - for (; start < end; start++) { - write_char(strm, ecl_char_code(ecl_elt(data, start))); - } - } else { - void (*write_byte)(cl_object, cl_object) = ops->write_byte; - for (; start < end; start++) { - write_byte(ecl_elt(data, start), strm); - } - } - return start; + (elttype == ecl_aet_object && ECL_CHARACTERP(ecl_elt(data, 0)))) { + ecl_character (*write_char)(cl_object, ecl_character) = ops->write_char; + for (; start < end; start++) { + write_char(strm, ecl_char_code(ecl_elt(data, start))); + } + } else { + void (*write_byte)(cl_object, cl_object) = ops->write_byte; + for (; start < end; start++) { + write_byte(ecl_elt(data, start), strm); + } + } + return start; } static cl_index generic_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end) { - const struct ecl_file_ops *ops; - cl_object expected_type; - if (start >= end) - return start; - expected_type = ecl_stream_element_type(strm); - ops = stream_dispatch_table(strm); - if (expected_type == @'base-char' || expected_type == @'character') { - ecl_character (*read_char)(cl_object) = ops->read_char; - for (; start < end; start++) { - cl_fixnum c = read_char(strm); - if (c == EOF) break; - ecl_elt_set(data, start, ECL_CODE_CHAR(c)); - } - } else { - cl_object (*read_byte)(cl_object) = ops->read_byte; - for (; start < end; start++) { - cl_object x = read_byte(strm); - if (Null(x)) break; - ecl_elt_set(data, start, x); - } - } - return start; + const struct ecl_file_ops *ops; + cl_object expected_type; + if (start >= end) + return start; + expected_type = ecl_stream_element_type(strm); + ops = stream_dispatch_table(strm); + if (expected_type == @'base-char' || expected_type == @'character') { + ecl_character (*read_char)(cl_object) = ops->read_char; + for (; start < end; start++) { + cl_fixnum c = read_char(strm); + if (c == EOF) break; + ecl_elt_set(data, start, ECL_CODE_CHAR(c)); + } + } else { + cl_object (*read_byte)(cl_object) = ops->read_byte; + for (; start < end; start++) { + cl_object x = read_byte(strm); + if (Null(x)) break; + ecl_elt_set(data, start, x); + } + } + return start; } /********************************************************************** @@ -551,113 +546,113 @@ generic_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end static void eformat_unread_char(cl_object strm, ecl_character c) { - unlikely_if (c != strm->stream.last_char) { - unread_twice(strm); - } - { - unsigned char buffer[2*ENCODING_BUFFER_MAX_SIZE]; - int ndx = 0; - cl_object l = strm->stream.byte_stack; - cl_fixnum i = strm->stream.last_code[0]; - if (i != EOF) { - ndx += strm->stream.encoder(strm, buffer, i); - } - i = strm->stream.last_code[1]; - if (i != EOF) { - ndx += strm->stream.encoder(strm, buffer+ndx, i); - } - while (ndx != 0) { - l = CONS(ecl_make_fixnum(buffer[--ndx]), l); - } - strm->stream.byte_stack = l; - strm->stream.last_char = EOF; - } + unlikely_if (c != strm->stream.last_char) { + unread_twice(strm); + } + { + unsigned char buffer[2*ENCODING_BUFFER_MAX_SIZE]; + int ndx = 0; + cl_object l = strm->stream.byte_stack; + cl_fixnum i = strm->stream.last_code[0]; + if (i != EOF) { + ndx += strm->stream.encoder(strm, buffer, i); + } + i = strm->stream.last_code[1]; + if (i != EOF) { + ndx += strm->stream.encoder(strm, buffer+ndx, i); + } + while (ndx != 0) { + l = CONS(ecl_make_fixnum(buffer[--ndx]), l); + } + strm->stream.byte_stack = l; + strm->stream.last_char = EOF; + } } static ecl_character eformat_read_char(cl_object strm) { - ecl_character c = strm->stream.decoder(strm); - unlikely_if (c == strm->stream.eof_char) - return EOF; - if (c != EOF) { - strm->stream.last_char = c; - strm->stream.last_code[0] = c; - strm->stream.last_code[1] = EOF; - } - return c; + ecl_character c = strm->stream.decoder(strm); + unlikely_if (c == strm->stream.eof_char) + return EOF; + if (c != EOF) { + strm->stream.last_char = c; + strm->stream.last_code[0] = c; + strm->stream.last_code[1] = EOF; + } + return c; } static ecl_character eformat_write_char(cl_object strm, ecl_character c) { - unsigned char buffer[ENCODING_BUFFER_MAX_SIZE]; - ecl_character nbytes; - nbytes = strm->stream.encoder(strm, buffer, c); - strm->stream.ops->write_byte8(strm, buffer, nbytes); - if (c == '\n') - strm->stream.column = 0; - else if (c == '\t') - strm->stream.column = (strm->stream.column & ~((cl_index)07)) + 8; - else - strm->stream.column++; - fflush(stdout); - return c; + unsigned char buffer[ENCODING_BUFFER_MAX_SIZE]; + ecl_character nbytes; + nbytes = strm->stream.encoder(strm, buffer, c); + strm->stream.ops->write_byte8(strm, buffer, nbytes); + if (c == '\n') + strm->stream.column = 0; + else if (c == '\t') + strm->stream.column = (strm->stream.column & ~((cl_index)07)) + 8; + else + strm->stream.column++; + fflush(stdout); + return c; } static ecl_character eformat_read_char_cr(cl_object strm) { - ecl_character c = eformat_read_char(strm); - if (c == ECL_CHAR_CODE_RETURN) { - c = ECL_CHAR_CODE_NEWLINE; - strm->stream.last_char = c; - } - return c; + ecl_character c = eformat_read_char(strm); + if (c == ECL_CHAR_CODE_RETURN) { + c = ECL_CHAR_CODE_NEWLINE; + strm->stream.last_char = c; + } + return c; } static ecl_character eformat_write_char_cr(cl_object strm, ecl_character c) { - if (c == ECL_CHAR_CODE_NEWLINE) { - eformat_write_char(strm, ECL_CHAR_CODE_RETURN); - strm->stream.column = 0; - return c; - } - return eformat_write_char(strm, c); + if (c == ECL_CHAR_CODE_NEWLINE) { + eformat_write_char(strm, ECL_CHAR_CODE_RETURN); + strm->stream.column = 0; + return c; + } + return eformat_write_char(strm, c); } static ecl_character eformat_read_char_crlf(cl_object strm) { - ecl_character c = eformat_read_char(strm); - if (c == ECL_CHAR_CODE_RETURN) { - c = eformat_read_char(strm); - if (c == ECL_CHAR_CODE_LINEFEED) { - strm->stream.last_code[0] = ECL_CHAR_CODE_RETURN; - strm->stream.last_code[1] = c; - c = ECL_CHAR_CODE_NEWLINE; - } else { - eformat_unread_char(strm, c); - c = ECL_CHAR_CODE_RETURN; - strm->stream.last_code[0] = c; - strm->stream.last_code[1] = EOF; - } - strm->stream.last_char = c; - } - return c; + ecl_character c = eformat_read_char(strm); + if (c == ECL_CHAR_CODE_RETURN) { + c = eformat_read_char(strm); + if (c == ECL_CHAR_CODE_LINEFEED) { + strm->stream.last_code[0] = ECL_CHAR_CODE_RETURN; + strm->stream.last_code[1] = c; + c = ECL_CHAR_CODE_NEWLINE; + } else { + eformat_unread_char(strm, c); + c = ECL_CHAR_CODE_RETURN; + strm->stream.last_code[0] = c; + strm->stream.last_code[1] = EOF; + } + strm->stream.last_char = c; + } + return c; } static ecl_character eformat_write_char_crlf(cl_object strm, ecl_character c) { - if (c == ECL_CHAR_CODE_NEWLINE) { - eformat_write_char(strm, ECL_CHAR_CODE_RETURN); - eformat_write_char(strm, ECL_CHAR_CODE_LINEFEED); - strm->stream.column = 0; - return c; - } - return eformat_write_char(strm, c); + if (c == ECL_CHAR_CODE_NEWLINE) { + eformat_write_char(strm, ECL_CHAR_CODE_RETURN); + eformat_write_char(strm, ECL_CHAR_CODE_LINEFEED); + strm->stream.column = 0; + return c; + } + return eformat_write_char(strm, c); } /* @@ -669,23 +664,23 @@ eformat_write_char_crlf(cl_object strm, ecl_character c) static ecl_character passthrough_decoder(cl_object stream) { - unsigned char aux; - if (ecl_read_byte8(stream, &aux, 1) < 1) - return EOF; - else - return aux; + unsigned char aux; + if (ecl_read_byte8(stream, &aux, 1) < 1) + return EOF; + else + return aux; } static int passthrough_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { #ifdef ECL_UNICODE - unlikely_if (c > 0xFF) { - return encoding_error(stream, buffer, c); - } + unlikely_if (c > 0xFF) { + return encoding_error(stream, buffer, c); + } #endif - buffer[0] = c; - return 1; + buffer[0] = c; + return 1; } #ifdef ECL_UNICODE @@ -696,24 +691,24 @@ passthrough_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character ascii_decoder(cl_object stream) { - unsigned char aux; - if (ecl_read_byte8(stream, &aux, 1) < 1) { - return EOF; - } else if (aux > 127) { - return decoding_error(stream, &aux, 1); - } else { - return aux; - } + unsigned char aux; + if (ecl_read_byte8(stream, &aux, 1) < 1) { + return EOF; + } else if (aux > 127) { + return decoding_error(stream, &aux, 1); + } else { + return aux; + } } static int ascii_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - unlikely_if (c > 127) { - return encoding_error(stream, buffer, c); - } - buffer[0] = c; - return 1; + unlikely_if (c > 127) { + return encoding_error(stream, buffer, c); + } + buffer[0] = c; + return 1; } /* @@ -723,22 +718,22 @@ ascii_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character ucs_4be_decoder(cl_object stream) { - unsigned char buffer[4]; - if (ecl_read_byte8(stream, buffer, 4) < 4) { - return EOF; - } else { - return buffer[3]+(buffer[2]<<8)+(buffer[1]<<16)+(buffer[0]<<24); - } + unsigned char buffer[4]; + if (ecl_read_byte8(stream, buffer, 4) < 4) { + return EOF; + } else { + return buffer[3]+(buffer[2]<<8)+(buffer[1]<<16)+(buffer[0]<<24); + } } static int ucs_4be_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - buffer[3] = c & 0xFF; c >>= 8; - buffer[2] = c & 0xFF; c >>= 8; - buffer[1] = c & 0xFF; c >>= 8; - buffer[0] = c; - return 4; + buffer[3] = c & 0xFF; c >>= 8; + buffer[2] = c & 0xFF; c >>= 8; + buffer[1] = c & 0xFF; c >>= 8; + buffer[0] = c; + return 4; } /* @@ -748,22 +743,22 @@ ucs_4be_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character ucs_4le_decoder(cl_object stream) { - unsigned char buffer[4]; - if (ecl_read_byte8(stream, buffer, 4) < 4) { - return EOF; - } else { - return buffer[0]+(buffer[1]<<8)+(buffer[2]<<16)+(buffer[3]<<24); - } + unsigned char buffer[4]; + if (ecl_read_byte8(stream, buffer, 4) < 4) { + return EOF; + } else { + return buffer[0]+(buffer[1]<<8)+(buffer[2]<<16)+(buffer[3]<<24); + } } static int ucs_4le_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - buffer[0] = c & 0xFF; c >>= 8; - buffer[1] = c & 0xFF; c >>= 8; - buffer[2] = c & 0xFF; c >>= 8; - buffer[3] = c; - return 4; + buffer[0] = c & 0xFF; c >>= 8; + buffer[1] = c & 0xFF; c >>= 8; + buffer[2] = c & 0xFF; c >>= 8; + buffer[3] = c; + return 4; } /* @@ -773,31 +768,31 @@ ucs_4le_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character ucs_4_decoder(cl_object stream) { - cl_fixnum c = ucs_4be_decoder(stream); - if (c == 0xFEFF) { - stream->stream.decoder = ucs_4be_decoder; - stream->stream.encoder = ucs_4be_encoder; - return ucs_4be_decoder(stream); - } else if (c == 0xFFFE0000) { - stream->stream.decoder = ucs_4le_decoder; - stream->stream.encoder = ucs_4le_encoder; - return ucs_4le_decoder(stream); - } else { - stream->stream.decoder = ucs_4be_decoder; - stream->stream.encoder = ucs_4be_encoder; - return c; - } + cl_fixnum c = ucs_4be_decoder(stream); + if (c == 0xFEFF) { + stream->stream.decoder = ucs_4be_decoder; + stream->stream.encoder = ucs_4be_encoder; + return ucs_4be_decoder(stream); + } else if (c == 0xFFFE0000) { + stream->stream.decoder = ucs_4le_decoder; + stream->stream.encoder = ucs_4le_encoder; + return ucs_4le_decoder(stream); + } else { + stream->stream.decoder = ucs_4be_decoder; + stream->stream.encoder = ucs_4be_encoder; + return c; + } } static int ucs_4_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - stream->stream.decoder = ucs_4be_decoder; - stream->stream.encoder = ucs_4be_encoder; - buffer[0] = 0xFF; - buffer[1] = 0xFE; - buffer[2] = buffer[3] = 0; - return 4 + ucs_4be_encoder(stream, buffer+4, c); + stream->stream.decoder = ucs_4be_decoder; + stream->stream.encoder = ucs_4be_encoder; + buffer[0] = 0xFF; + buffer[1] = 0xFE; + buffer[2] = buffer[3] = 0; + return 4 + ucs_4be_encoder(stream, buffer+4, c); } @@ -808,40 +803,40 @@ ucs_4_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character ucs_2be_decoder(cl_object stream) { - unsigned char buffer[2] = {0,0}; - if (ecl_read_byte8(stream, buffer, 2) < 2) { - return EOF; - } else { - ecl_character c = ((ecl_character)buffer[0] << 8) | buffer[1]; - if ((buffer[0] & 0xFC) == 0xD8) { - if (ecl_read_byte8(stream, buffer, 2) < 2) { - return EOF; - } else { - ecl_character aux; - if ((buffer[1] & 0xFC) != 0xDC) { - return decoding_error(stream, buffer, 1); - } - aux = ((ecl_character)buffer[0] << 8) | buffer[1]; - return ((c & 0x3FFF) << 10) + (aux & 0x3FFF) + 0x10000; - } - } - return c; + unsigned char buffer[2] = {0,0}; + if (ecl_read_byte8(stream, buffer, 2) < 2) { + return EOF; + } else { + ecl_character c = ((ecl_character)buffer[0] << 8) | buffer[1]; + if ((buffer[0] & 0xFC) == 0xD8) { + if (ecl_read_byte8(stream, buffer, 2) < 2) { + return EOF; + } else { + ecl_character aux; + if ((buffer[1] & 0xFC) != 0xDC) { + return decoding_error(stream, buffer, 1); } + aux = ((ecl_character)buffer[0] << 8) | buffer[1]; + return ((c & 0x3FFF) << 10) + (aux & 0x3FFF) + 0x10000; + } + } + return c; + } } static int ucs_2be_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - if (c >= 0x10000) { - c -= 0x10000; - ucs_2be_encoder(stream, buffer, (c >> 10) | 0xD800); - ucs_2be_encoder(stream, buffer+2, (c & 0x3FFF) | 0xDC00); - return 4; - } else { - buffer[1] = c & 0xFF; c >>= 8; - buffer[0] = c; - return 2; - } + if (c >= 0x10000) { + c -= 0x10000; + ucs_2be_encoder(stream, buffer, (c >> 10) | 0xD800); + ucs_2be_encoder(stream, buffer+2, (c & 0x3FFF) | 0xDC00); + return 4; + } else { + buffer[1] = c & 0xFF; c >>= 8; + buffer[0] = c; + return 2; + } } /* @@ -851,40 +846,40 @@ ucs_2be_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character ucs_2le_decoder(cl_object stream) { - unsigned char buffer[2]; - if (ecl_read_byte8(stream, buffer, 2) < 2) { - return EOF; - } else { - ecl_character c = ((ecl_character)buffer[1] << 8) | buffer[0]; - if ((buffer[1] & 0xFC) == 0xD8) { - if (ecl_read_byte8(stream, buffer, 2) < 2) { - return EOF; - } else { - ecl_character aux; - if ((buffer[1] & 0xFC) != 0xDC) { - return decoding_error(stream, buffer, 2); - } - aux = ((ecl_character)buffer[1] << 8) | buffer[0]; - return ((c & 0x3FFF) << 10) + (aux & 0x3FFF) + 0x10000; - } - } - return c; + unsigned char buffer[2]; + if (ecl_read_byte8(stream, buffer, 2) < 2) { + return EOF; + } else { + ecl_character c = ((ecl_character)buffer[1] << 8) | buffer[0]; + if ((buffer[1] & 0xFC) == 0xD8) { + if (ecl_read_byte8(stream, buffer, 2) < 2) { + return EOF; + } else { + ecl_character aux; + if ((buffer[1] & 0xFC) != 0xDC) { + return decoding_error(stream, buffer, 2); } + aux = ((ecl_character)buffer[1] << 8) | buffer[0]; + return ((c & 0x3FFF) << 10) + (aux & 0x3FFF) + 0x10000; + } + } + return c; + } } static int ucs_2le_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - if (c >= 0x10000) { - c -= 0x10000; - ucs_2le_encoder(stream, buffer, (c >> 10) | 0xD8000); - ucs_2le_encoder(stream, buffer+2, (c & 0x3FFF) | 0xD800); - return 4; - } else { - buffer[0] = c & 0xFF; c >>= 8; - buffer[1] = c & 0xFF; - return 2; - } + if (c >= 0x10000) { + c -= 0x10000; + ucs_2le_encoder(stream, buffer, (c >> 10) | 0xD8000); + ucs_2le_encoder(stream, buffer+2, (c & 0x3FFF) | 0xD800); + return 4; + } else { + buffer[0] = c & 0xFF; c >>= 8; + buffer[1] = c & 0xFF; + return 2; + } } /* @@ -894,30 +889,30 @@ ucs_2le_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character ucs_2_decoder(cl_object stream) { - ecl_character c = ucs_2be_decoder(stream); - if (c == 0xFEFF) { - stream->stream.decoder = ucs_2be_decoder; - stream->stream.encoder = ucs_2be_encoder; - return ucs_2be_decoder(stream); - } else if (c == 0xFFFE) { - stream->stream.decoder = ucs_2le_decoder; - stream->stream.encoder = ucs_2le_encoder; - return ucs_2le_decoder(stream); - } else { - stream->stream.decoder = ucs_2be_decoder; - stream->stream.encoder = ucs_2be_encoder; - return c; - } + ecl_character c = ucs_2be_decoder(stream); + if (c == 0xFEFF) { + stream->stream.decoder = ucs_2be_decoder; + stream->stream.encoder = ucs_2be_encoder; + return ucs_2be_decoder(stream); + } else if (c == 0xFFFE) { + stream->stream.decoder = ucs_2le_decoder; + stream->stream.encoder = ucs_2le_encoder; + return ucs_2le_decoder(stream); + } else { + stream->stream.decoder = ucs_2be_decoder; + stream->stream.encoder = ucs_2be_encoder; + return c; + } } static int ucs_2_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - stream->stream.decoder = ucs_2be_decoder; - stream->stream.encoder = ucs_2be_encoder; - buffer[0] = 0xFF; - buffer[1] = 0xFE; - return 2 + ucs_2be_encoder(stream, buffer+2, c); + stream->stream.decoder = ucs_2be_decoder; + stream->stream.encoder = ucs_2be_encoder; + buffer[0] = 0xFF; + buffer[1] = 0xFE; + return 2 + ucs_2be_encoder(stream, buffer+2, c); } /* @@ -927,47 +922,47 @@ ucs_2_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character user_decoder(cl_object stream) { - cl_object table = stream->stream.format_table; - cl_object character; - unsigned char buffer[2]; - if (ecl_read_byte8(stream, buffer, 1) < 1) { - return EOF; - } - character = ecl_gethash_safe(ecl_make_fixnum(buffer[0]), table, ECL_NIL); - unlikely_if (Null(character)) { - return decoding_error(stream, buffer, 1); - } - if (character == ECL_T) { - if (ecl_read_byte8(stream, buffer+1, 1) < 1) { - return EOF; - } else { - cl_fixnum byte = (buffer[0]<<8) + buffer[1]; - character = ecl_gethash_safe(ecl_make_fixnum(byte), table, ECL_NIL); - unlikely_if (Null(character)) { - return decoding_error(stream, buffer, 2); - } - } - } - return ECL_CHAR_CODE(character); + cl_object table = stream->stream.format_table; + cl_object character; + unsigned char buffer[2]; + if (ecl_read_byte8(stream, buffer, 1) < 1) { + return EOF; + } + character = ecl_gethash_safe(ecl_make_fixnum(buffer[0]), table, ECL_NIL); + unlikely_if (Null(character)) { + return decoding_error(stream, buffer, 1); + } + if (character == ECL_T) { + if (ecl_read_byte8(stream, buffer+1, 1) < 1) { + return EOF; + } else { + cl_fixnum byte = (buffer[0]<<8) + buffer[1]; + character = ecl_gethash_safe(ecl_make_fixnum(byte), table, ECL_NIL); + unlikely_if (Null(character)) { + return decoding_error(stream, buffer, 2); + } + } + } + return ECL_CHAR_CODE(character); } static int user_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - cl_object byte = ecl_gethash_safe(ECL_CODE_CHAR(c), stream->stream.format_table, ECL_NIL); - if (Null(byte)) { - return encoding_error(stream, buffer, c); - } else { - cl_fixnum code = ecl_fixnum(byte); - if (code > 0xFF) { - buffer[1] = code & 0xFF; code >>= 8; - buffer[0] = code; - return 2; - } else { - buffer[0] = code; - return 1; - } - } + cl_object byte = ecl_gethash_safe(ECL_CODE_CHAR(c), stream->stream.format_table, ECL_NIL); + if (Null(byte)) { + return encoding_error(stream, buffer, c); + } else { + cl_fixnum code = ecl_fixnum(byte); + if (code > 0xFF) { + buffer[1] = code & 0xFF; code >>= 8; + buffer[0] = code; + return 2; + } else { + buffer[0] = code; + return 1; + } + } } /* @@ -977,74 +972,74 @@ user_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character user_multistate_decoder(cl_object stream) { - cl_object table_list = stream->stream.format_table; - cl_object table = ECL_CONS_CAR(table_list); - cl_object character; - cl_fixnum i, j; - unsigned char buffer[ENCODING_BUFFER_MAX_SIZE]; - for (i = j = 0; i < ENCODING_BUFFER_MAX_SIZE; i++) { - if (ecl_read_byte8(stream, buffer+i, 1) < 1) { - return EOF; - } - j = (j << 8) | buffer[i]; - character = ecl_gethash_safe(ecl_make_fixnum(j), table, ECL_NIL); - if (ECL_CHARACTERP(character)) { - return ECL_CHAR_CODE(character); - } - unlikely_if (Null(character)) { - return decoding_error(stream, buffer, i); - } - if (character == ECL_T) { - /* Need more characters */ - continue; - } - if (CONSP(character)) { - /* Changed the state. */ - stream->stream.format_table = table_list = character; - table = ECL_CONS_CAR(table_list); - i = j = 0; - continue; - } - break; - } - FEerror("Internal error in decoder table.", 0); + cl_object table_list = stream->stream.format_table; + cl_object table = ECL_CONS_CAR(table_list); + cl_object character; + cl_fixnum i, j; + unsigned char buffer[ENCODING_BUFFER_MAX_SIZE]; + for (i = j = 0; i < ENCODING_BUFFER_MAX_SIZE; i++) { + if (ecl_read_byte8(stream, buffer+i, 1) < 1) { + return EOF; + } + j = (j << 8) | buffer[i]; + character = ecl_gethash_safe(ecl_make_fixnum(j), table, ECL_NIL); + if (ECL_CHARACTERP(character)) { + return ECL_CHAR_CODE(character); + } + unlikely_if (Null(character)) { + return decoding_error(stream, buffer, i); + } + if (character == ECL_T) { + /* Need more characters */ + continue; + } + if (CONSP(character)) { + /* Changed the state. */ + stream->stream.format_table = table_list = character; + table = ECL_CONS_CAR(table_list); + i = j = 0; + continue; + } + break; + } + FEerror("Internal error in decoder table.", 0); } static int user_multistate_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - cl_object table_list = stream->stream.format_table; - cl_object p = table_list; - do { - cl_object table = ECL_CONS_CAR(p); - cl_object byte = ecl_gethash_safe(ECL_CODE_CHAR(c), table, ECL_NIL); - if (!Null(byte)) { - cl_fixnum code = ecl_fixnum(byte); - ecl_character n = 0; - if (p != table_list) { - /* Must output a escape sequence */ - cl_object x = ecl_gethash_safe(ECL_T, table, ECL_NIL); - while (!Null(x)) { - buffer[0] = ecl_fixnum(ECL_CONS_CAR(x)); - buffer++; - x = ECL_CONS_CDR(x); - n++; - } - stream->stream.format_table = p; - } - if (code > 0xFF) { - buffer[1] = code & 0xFF; code >>= 8; - buffer[0] = code; - return n+2; - } else { - buffer[0] = code; - return n+1; - } - } - p = ECL_CONS_CDR(p); - } while (p != table_list); - /* Exhausted all lists */ - return encoding_error(stream, buffer, c); + cl_object table_list = stream->stream.format_table; + cl_object p = table_list; + do { + cl_object table = ECL_CONS_CAR(p); + cl_object byte = ecl_gethash_safe(ECL_CODE_CHAR(c), table, ECL_NIL); + if (!Null(byte)) { + cl_fixnum code = ecl_fixnum(byte); + ecl_character n = 0; + if (p != table_list) { + /* Must output a escape sequence */ + cl_object x = ecl_gethash_safe(ECL_T, table, ECL_NIL); + while (!Null(x)) { + buffer[0] = ecl_fixnum(ECL_CONS_CAR(x)); + buffer++; + x = ECL_CONS_CDR(x); + n++; + } + stream->stream.format_table = p; + } + if (code > 0xFF) { + buffer[1] = code & 0xFF; code >>= 8; + buffer[0] = code; + return n+2; + } else { + buffer[0] = code; + return n+1; + } + } + p = ECL_CONS_CDR(p); + } while (p != table_list); + /* Exhausted all lists */ + return encoding_error(stream, buffer, c); } /* @@ -1054,80 +1049,80 @@ user_multistate_encoder(cl_object stream, unsigned char *buffer, ecl_character c static ecl_character utf_8_decoder(cl_object stream) { - /* In understanding this code: - * 0x8 = 1000, 0xC = 1100, 0xE = 1110, 0xF = 1111 - * 0x1 = 0001, 0x3 = 0011, 0x7 = 0111, 0xF = 1111 - */ - ecl_character cum = 0; - unsigned char buffer[5]; - int nbytes, i; - if (ecl_read_byte8(stream, buffer, 1) < 1) - return EOF; - if ((buffer[0] & 0x80) == 0) { - return buffer[0]; - } - unlikely_if ((buffer[0] & 0x40) == 0) - return decoding_error(stream, buffer, 1); - if ((buffer[0] & 0x20) == 0) { - cum = buffer[0] & 0x1F; - nbytes = 1; - } else if ((buffer[0] & 0x10) == 0) { - cum = buffer[0] & 0x0F; - nbytes = 2; - } else if ((buffer[0] & 0x08) == 0) { - cum = buffer[0] & 0x07; - nbytes = 3; - } else { - return decoding_error(stream, buffer, 1); - } - if (ecl_read_byte8(stream, buffer+1, nbytes) < nbytes) - return EOF; - for (i = 1; i <= nbytes; i++) { - unsigned char c = buffer[i]; - /*printf(": %04x :", c);*/ - unlikely_if ((c & 0xC0) != 0x80) - return decoding_error(stream, buffer, nbytes+1); - cum = (cum << 6) | (c & 0x3F); - unlikely_if (cum == 0) - return decoding_error(stream, buffer, nbytes+1); - } - if (cum >= 0xd800) { - unlikely_if (cum <= 0xdfff) - return decoding_error(stream, buffer, nbytes+1); - unlikely_if (cum >= 0xFFFE && cum <= 0xFFFF) - return decoding_error(stream, buffer, nbytes+1); - } - /*printf("; %04x ;", cum);*/ - return cum; + /* In understanding this code: + * 0x8 = 1000, 0xC = 1100, 0xE = 1110, 0xF = 1111 + * 0x1 = 0001, 0x3 = 0011, 0x7 = 0111, 0xF = 1111 + */ + ecl_character cum = 0; + unsigned char buffer[5]; + int nbytes, i; + if (ecl_read_byte8(stream, buffer, 1) < 1) + return EOF; + if ((buffer[0] & 0x80) == 0) { + return buffer[0]; + } + unlikely_if ((buffer[0] & 0x40) == 0) + return decoding_error(stream, buffer, 1); + if ((buffer[0] & 0x20) == 0) { + cum = buffer[0] & 0x1F; + nbytes = 1; + } else if ((buffer[0] & 0x10) == 0) { + cum = buffer[0] & 0x0F; + nbytes = 2; + } else if ((buffer[0] & 0x08) == 0) { + cum = buffer[0] & 0x07; + nbytes = 3; + } else { + return decoding_error(stream, buffer, 1); + } + if (ecl_read_byte8(stream, buffer+1, nbytes) < nbytes) + return EOF; + for (i = 1; i <= nbytes; i++) { + unsigned char c = buffer[i]; + /*printf(": %04x :", c);*/ + unlikely_if ((c & 0xC0) != 0x80) + return decoding_error(stream, buffer, nbytes+1); + cum = (cum << 6) | (c & 0x3F); + unlikely_if (cum == 0) + return decoding_error(stream, buffer, nbytes+1); + } + if (cum >= 0xd800) { + unlikely_if (cum <= 0xdfff) + return decoding_error(stream, buffer, nbytes+1); + unlikely_if (cum >= 0xFFFE && cum <= 0xFFFF) + return decoding_error(stream, buffer, nbytes+1); + } + /*printf("; %04x ;", cum);*/ + return cum; } static int utf_8_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - int nbytes; - if (c < 0) { - nbytes = 0; - } else if (c <= 0x7F) { - buffer[0] = c; - nbytes = 1; - } else if (c <= 0x7ff) { - buffer[1] = (c & 0x3f) | 0x80; c >>= 6; - buffer[0] = c | 0xC0; - /*printf("\n; %04x ;: %04x :: %04x :\n", c_orig, buffer[0], buffer[1]);*/ - nbytes = 2; - } else if (c <= 0xFFFF) { - buffer[2] = (c & 0x3f) | 0x80; c >>= 6; - buffer[1] = (c & 0x3f) | 0x80; c >>= 6; - buffer[0] = c | 0xE0; - nbytes = 3; - } else if (c <= 0x1FFFFFL) { - buffer[3] = (c & 0x3f) | 0x80; c >>= 6; - buffer[2] = (c & 0x3f) | 0x80; c >>= 6; - buffer[1] = (c & 0x3f) | 0x80; c >>= 6; - buffer[0] = c | 0xF0; - nbytes = 4; - } - return nbytes; + int nbytes; + if (c < 0) { + nbytes = 0; + } else if (c <= 0x7F) { + buffer[0] = c; + nbytes = 1; + } else if (c <= 0x7ff) { + buffer[1] = (c & 0x3f) | 0x80; c >>= 6; + buffer[0] = c | 0xC0; + /*printf("\n; %04x ;: %04x :: %04x :\n", c_orig, buffer[0], buffer[1]);*/ + nbytes = 2; + } else if (c <= 0xFFFF) { + buffer[2] = (c & 0x3f) | 0x80; c >>= 6; + buffer[1] = (c & 0x3f) | 0x80; c >>= 6; + buffer[0] = c | 0xE0; + nbytes = 3; + } else if (c <= 0x1FFFFFL) { + buffer[3] = (c & 0x3f) | 0x80; c >>= 6; + buffer[2] = (c & 0x3f) | 0x80; c >>= 6; + buffer[1] = (c & 0x3f) | 0x80; c >>= 6; + buffer[0] = c | 0xF0; + nbytes = 4; + } + return nbytes; } #endif @@ -1139,136 +1134,136 @@ utf_8_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static cl_index clos_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index i; - for (i = 0; i < n; i++) { - cl_object byte = _ecl_funcall2(@'gray::stream-read-byte', strm); - if (!ECL_FIXNUMP(byte)) - break; - c[i] = ecl_fixnum(byte); - } - return i; + cl_index i; + for (i = 0; i < n; i++) { + cl_object byte = _ecl_funcall2(@'gray::stream-read-byte', strm); + if (!ECL_FIXNUMP(byte)) + break; + c[i] = ecl_fixnum(byte); + } + return i; } static cl_index clos_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index i; - for (i = 0; i < n; i++) { - cl_object byte = _ecl_funcall3(@'gray::stream-write-byte', strm, - ecl_make_fixnum(c[i])); - if (!ECL_FIXNUMP(byte)) - break; - } - return i; + cl_index i; + for (i = 0; i < n; i++) { + cl_object byte = _ecl_funcall3(@'gray::stream-write-byte', strm, + ecl_make_fixnum(c[i])); + if (!ECL_FIXNUMP(byte)) + break; + } + return i; } static cl_object clos_stream_read_byte(cl_object strm) { - cl_object b = _ecl_funcall2(@'gray::stream-read-byte', strm); - if (b == @':eof') b = ECL_NIL; - return b; + cl_object b = _ecl_funcall2(@'gray::stream-read-byte', strm); + if (b == @':eof') b = ECL_NIL; + return b; } static void clos_stream_write_byte(cl_object c, cl_object strm) { - _ecl_funcall3(@'gray::stream-write-byte', strm, c); + _ecl_funcall3(@'gray::stream-write-byte', strm, c); } static ecl_character clos_stream_read_char(cl_object strm) { - cl_object output = _ecl_funcall2(@'gray::stream-read-char', strm); - cl_fixnum value; - if (ECL_CHARACTERP(output)) - value = ECL_CHAR_CODE(output); - else if (ECL_FIXNUMP(output)) - value = ecl_fixnum(output); - else if (output == ECL_NIL || output == @':eof') - return EOF; - else - value = -1; - unlikely_if (value < 0 || value > ECL_CHAR_CODE_LIMIT) - FEerror("Unknown character ~A", 1, output); - return value; + cl_object output = _ecl_funcall2(@'gray::stream-read-char', strm); + cl_fixnum value; + if (ECL_CHARACTERP(output)) + value = ECL_CHAR_CODE(output); + else if (ECL_FIXNUMP(output)) + value = ecl_fixnum(output); + else if (output == ECL_NIL || output == @':eof') + return EOF; + else + value = -1; + unlikely_if (value < 0 || value > ECL_CHAR_CODE_LIMIT) + FEerror("Unknown character ~A", 1, output); + return value; } static ecl_character clos_stream_write_char(cl_object strm, ecl_character c) { - _ecl_funcall3(@'gray::stream-write-char', strm, ECL_CODE_CHAR(c)); - return c; + _ecl_funcall3(@'gray::stream-write-char', strm, ECL_CODE_CHAR(c)); + return c; } static void clos_stream_unread_char(cl_object strm, ecl_character c) { - _ecl_funcall3(@'gray::stream-unread-char', strm, ECL_CODE_CHAR(c)); + _ecl_funcall3(@'gray::stream-unread-char', strm, ECL_CODE_CHAR(c)); } static int clos_stream_peek_char(cl_object strm) { - cl_object out = _ecl_funcall2(@'gray::stream-peek-char', strm); - if (out == @':eof') return EOF; - return ecl_char_code(out); + cl_object out = _ecl_funcall2(@'gray::stream-peek-char', strm); + if (out == @':eof') return EOF; + return ecl_char_code(out); } static int clos_stream_listen(cl_object strm) { - return !Null(_ecl_funcall2(@'gray::stream-listen', strm)); + return !Null(_ecl_funcall2(@'gray::stream-listen', strm)); } static void clos_stream_clear_input(cl_object strm) { - _ecl_funcall2(@'gray::stream-clear-input', strm); + _ecl_funcall2(@'gray::stream-clear-input', strm); } static void clos_stream_clear_output(cl_object strm) { - _ecl_funcall2(@'gray::stream-clear-output', strm); - return; + _ecl_funcall2(@'gray::stream-clear-output', strm); + return; } static void clos_stream_force_output(cl_object strm) { - _ecl_funcall2(@'gray::stream-force-output', strm); + _ecl_funcall2(@'gray::stream-force-output', strm); } static void clos_stream_finish_output(cl_object strm) { - _ecl_funcall2(@'gray::stream-finish-output', strm); + _ecl_funcall2(@'gray::stream-finish-output', strm); } static int clos_stream_input_p(cl_object strm) { - return !Null(_ecl_funcall2(@'gray::input-stream-p', strm)); + return !Null(_ecl_funcall2(@'gray::input-stream-p', strm)); } static int clos_stream_output_p(cl_object strm) { - return !Null(_ecl_funcall2(@'gray::output-stream-p', strm)); + return !Null(_ecl_funcall2(@'gray::output-stream-p', strm)); } static int clos_stream_interactive_p(cl_object strm) { - return !Null(_ecl_funcall2(@'gray::stream-interactive-p', strm)); + return !Null(_ecl_funcall2(@'gray::stream-interactive-p', strm)); } static cl_object clos_stream_element_type(cl_object strm) { - return _ecl_funcall2(@'gray::stream-element-type', strm); + return _ecl_funcall2(@'gray::stream-element-type', strm); } #define clos_stream_length not_a_file_stream @@ -1276,62 +1271,62 @@ clos_stream_element_type(cl_object strm) static cl_object clos_stream_get_position(cl_object strm) { - return _ecl_funcall2(@'gray::stream-file-position', strm); + return _ecl_funcall2(@'gray::stream-file-position', strm); } static cl_object clos_stream_set_position(cl_object strm, cl_object pos) { - return _ecl_funcall3(@'gray::stream-file-position', strm, pos); + return _ecl_funcall3(@'gray::stream-file-position', strm, pos); } static int clos_stream_column(cl_object strm) { - cl_object col = _ecl_funcall2(@'gray::stream-line-column', strm); - /* FIXME! The Gray streams specifies NIL is a valid - * value but means "unknown". Should we make it - * zero? */ - return Null(col)? 0 : ecl_to_size(col); + cl_object col = _ecl_funcall2(@'gray::stream-line-column', strm); + /* FIXME! The Gray streams specifies NIL is a valid + * value but means "unknown". Should we make it + * zero? */ + return Null(col)? 0 : ecl_to_size(col); } static cl_object clos_stream_close(cl_object strm) { - return _ecl_funcall2(@'gray::close', strm); + return _ecl_funcall2(@'gray::close', strm); } const struct ecl_file_ops clos_stream_ops = { - clos_stream_write_byte8, - clos_stream_read_byte8, + clos_stream_write_byte8, + clos_stream_read_byte8, - clos_stream_write_byte, - clos_stream_read_byte, + clos_stream_write_byte, + clos_stream_read_byte, - clos_stream_read_char, - clos_stream_write_char, - clos_stream_unread_char, - clos_stream_peek_char, + clos_stream_read_char, + clos_stream_write_char, + clos_stream_unread_char, + clos_stream_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - clos_stream_listen, - clos_stream_clear_input, - clos_stream_clear_output, - clos_stream_finish_output, - clos_stream_force_output, + clos_stream_listen, + clos_stream_clear_input, + clos_stream_clear_output, + clos_stream_finish_output, + clos_stream_force_output, - clos_stream_input_p, - clos_stream_output_p, - clos_stream_interactive_p, - clos_stream_element_type, + clos_stream_input_p, + clos_stream_output_p, + clos_stream_interactive_p, + clos_stream_element_type, - clos_stream_length, - clos_stream_get_position, - clos_stream_set_position, - clos_stream_column, - clos_stream_close + clos_stream_length, + clos_stream_get_position, + clos_stream_set_position, + clos_stream_column, + clos_stream_close }; #endif /* ECL_CLOS_STREAMS */ @@ -1342,165 +1337,165 @@ const struct ecl_file_ops clos_stream_ops = { static ecl_character str_out_write_char(cl_object strm, ecl_character c) { - int column = strm->stream.column; - if (c == '\n') - strm->stream.column = 0; - else if (c == '\t') - strm->stream.column = (column&~(cl_index)7) + 8; - else - strm->stream.column++; - ecl_string_push_extend(STRING_OUTPUT_STRING(strm), c); - return c; + int column = strm->stream.column; + if (c == '\n') + strm->stream.column = 0; + else if (c == '\t') + strm->stream.column = (column&~(cl_index)7) + 8; + else + strm->stream.column++; + ecl_string_push_extend(STRING_OUTPUT_STRING(strm), c); + return c; } static cl_object str_out_element_type(cl_object strm) { - cl_object string = STRING_OUTPUT_STRING(strm); - if (ECL_BASE_STRING_P(string)) - return @'base-char'; - return @'character'; + cl_object string = STRING_OUTPUT_STRING(strm); + if (ECL_BASE_STRING_P(string)) + return @'base-char'; + return @'character'; } static cl_object str_out_get_position(cl_object strm) { - return ecl_make_unsigned_integer(STRING_OUTPUT_STRING(strm)->base_string.fillp); + return ecl_make_unsigned_integer(STRING_OUTPUT_STRING(strm)->base_string.fillp); } static cl_object str_out_set_position(cl_object strm, cl_object pos) { - cl_object string = STRING_OUTPUT_STRING(strm); - cl_fixnum disp; - if (Null(pos)) { - disp = strm->base_string.dim; - } else { - disp = ecl_to_size(pos); - } - if (disp < string->base_string.fillp) { - string->base_string.fillp = disp; - } else { - disp -= string->base_string.fillp; - while (disp-- > 0) - ecl_write_char(' ', strm); - } - return ECL_T; + cl_object string = STRING_OUTPUT_STRING(strm); + cl_fixnum disp; + if (Null(pos)) { + disp = strm->base_string.dim; + } else { + disp = ecl_to_size(pos); + } + if (disp < string->base_string.fillp) { + string->base_string.fillp = disp; + } else { + disp -= string->base_string.fillp; + while (disp-- > 0) + ecl_write_char(' ', strm); + } + return ECL_T; } static int str_out_column(cl_object strm) { - return strm->stream.column; + return strm->stream.column; } const struct ecl_file_ops str_out_ops = { - not_output_write_byte8, - not_binary_read_byte8, + not_output_write_byte8, + not_binary_read_byte8, - not_binary_write_byte, - not_input_read_byte, + not_binary_write_byte, + not_input_read_byte, - not_input_read_char, - str_out_write_char, - not_input_unread_char, - generic_peek_char, + not_input_read_char, + str_out_write_char, + not_input_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - not_input_listen, - not_input_clear_input, - generic_void, /* clear-output */ - generic_void, /* finish-output */ - generic_void, /* force-output */ + not_input_listen, + not_input_clear_input, + generic_void, /* clear-output */ + generic_void, /* finish-output */ + generic_void, /* force-output */ - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - str_out_element_type, + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + str_out_element_type, - not_a_file_stream, /* length */ - str_out_get_position, - str_out_set_position, - str_out_column, - generic_close + not_a_file_stream, /* length */ + str_out_get_position, + str_out_set_position, + str_out_column, + generic_close }; cl_object si_make_string_output_stream_from_string(cl_object s) { - cl_object strm = alloc_stream(); - unlikely_if (!ECL_STRINGP(s) || !ECL_ARRAY_HAS_FILL_POINTER_P(s)) - FEerror("~S is not a -string with a fill-pointer.", 1, s); - strm->stream.ops = duplicate_dispatch_table(&str_out_ops); - strm->stream.mode = (short)ecl_smm_string_output; - STRING_OUTPUT_STRING(strm) = s; - strm->stream.column = 0; + cl_object strm = alloc_stream(); + unlikely_if (!ECL_STRINGP(s) || !ECL_ARRAY_HAS_FILL_POINTER_P(s)) + FEerror("~S is not a -string with a fill-pointer.", 1, s); + strm->stream.ops = duplicate_dispatch_table(&str_out_ops); + strm->stream.mode = (short)ecl_smm_string_output; + STRING_OUTPUT_STRING(strm) = s; + strm->stream.column = 0; #if !defined(ECL_UNICODE) - strm->stream.format = @':pass-through'; - strm->stream.flags = ECL_STREAM_DEFAULT_FORMAT; - strm->stream.byte_size = 8; + strm->stream.format = @':pass-through'; + strm->stream.flags = ECL_STREAM_DEFAULT_FORMAT; + strm->stream.byte_size = 8; #else - if (ECL_BASE_STRING_P(s)) { - strm->stream.format = @':latin-1'; - strm->stream.flags = ECL_STREAM_LATIN_1; - strm->stream.byte_size = 8; - } else { - strm->stream.format = @':ucs-4'; - strm->stream.flags = ECL_STREAM_UCS_4; - strm->stream.byte_size = 32; - } + if (ECL_BASE_STRING_P(s)) { + strm->stream.format = @':latin-1'; + strm->stream.flags = ECL_STREAM_LATIN_1; + strm->stream.byte_size = 8; + } else { + strm->stream.format = @':ucs-4'; + strm->stream.flags = ECL_STREAM_UCS_4; + strm->stream.byte_size = 32; + } #endif - @(return strm) + @(return strm); } cl_object ecl_make_string_output_stream(cl_index line_length, int extended) { #ifdef ECL_UNICODE - cl_object s = extended? - ecl_alloc_adjustable_extended_string(line_length) : - ecl_alloc_adjustable_base_string(line_length); + cl_object s = extended? + ecl_alloc_adjustable_extended_string(line_length) : + ecl_alloc_adjustable_base_string(line_length); #else - cl_object s = ecl_alloc_adjustable_base_string(line_length); + cl_object s = ecl_alloc_adjustable_base_string(line_length); #endif - return si_make_string_output_stream_from_string(s); + return si_make_string_output_stream_from_string(s); } @(defun make-string-output-stream (&key (element_type @'character')) - int extended = 0; + int extended = 0; @ - if (element_type == @'base-char') { - (void)0; - } else if (element_type == @'character') { + if (element_type == @'base-char') { + (void)0; + } else if (element_type == @'character') { #ifdef ECL_UNICODE - extended = 1; + extended = 1; #endif - } else if (!Null(_ecl_funcall3(@'subtypep', element_type, @'base-char'))) { - (void)0; - } else if (!Null(_ecl_funcall3(@'subtypep', element_type, @'character'))) { + } else if (!Null(_ecl_funcall3(@'subtypep', element_type, @'base-char'))) { + (void)0; + } else if (!Null(_ecl_funcall3(@'subtypep', element_type, @'character'))) { #ifdef ECL_UNICODE - extended = 1; + extended = 1; #endif - } else { - FEerror("In MAKE-STRING-OUTPUT-STREAM, the argument :ELEMENT-TYPE (~A) must be a subtype of character", - 1, element_type); - } - @(return ecl_make_string_output_stream(128, extended)) + } else { + FEerror("In MAKE-STRING-OUTPUT-STREAM, the argument :ELEMENT-TYPE (~A) must be a subtype of character", + 1, element_type); + } + @(return ecl_make_string_output_stream(128, extended)); @) cl_object cl_get_output_stream_string(cl_object strm) { - cl_object strng; - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_string_output)) - FEwrong_type_only_arg(@[get-output-stream-string], - strm, @[string-stream]); - strng = cl_copy_seq(STRING_OUTPUT_STRING(strm)); - STRING_OUTPUT_STRING(strm)->base_string.fillp = 0; - @(return strng) + cl_object strng; + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_string_output)) + FEwrong_type_only_arg(@[get-output-stream-string], + strm, @[string-stream]); + strng = cl_copy_seq(STRING_OUTPUT_STRING(strm)); + STRING_OUTPUT_STRING(strm)->base_string.fillp = 0; + @(return strng); } /********************************************************************** @@ -1510,146 +1505,146 @@ cl_get_output_stream_string(cl_object strm) static ecl_character str_in_read_char(cl_object strm) { - cl_fixnum curr_pos = STRING_INPUT_POSITION(strm); - ecl_character c; - if (curr_pos >= STRING_INPUT_LIMIT(strm)) { - c = EOF; - } else { - c = ecl_char(STRING_INPUT_STRING(strm), curr_pos); - STRING_INPUT_POSITION(strm) = curr_pos+1; - } - return c; + cl_fixnum curr_pos = STRING_INPUT_POSITION(strm); + ecl_character c; + if (curr_pos >= STRING_INPUT_LIMIT(strm)) { + c = EOF; + } else { + c = ecl_char(STRING_INPUT_STRING(strm), curr_pos); + STRING_INPUT_POSITION(strm) = curr_pos+1; + } + return c; } static void str_in_unread_char(cl_object strm, ecl_character c) { - cl_fixnum curr_pos = STRING_INPUT_POSITION(strm); - unlikely_if (c <= 0) { - unread_error(strm); - } - STRING_INPUT_POSITION(strm) = curr_pos - 1; + cl_fixnum curr_pos = STRING_INPUT_POSITION(strm); + unlikely_if (c <= 0) { + unread_error(strm); + } + STRING_INPUT_POSITION(strm) = curr_pos - 1; } static ecl_character str_in_peek_char(cl_object strm) { - cl_index pos = STRING_INPUT_POSITION(strm); - if (pos >= STRING_INPUT_LIMIT(strm)) { - return EOF; - } else { - return ecl_char(STRING_INPUT_STRING(strm), pos); - } + cl_index pos = STRING_INPUT_POSITION(strm); + if (pos >= STRING_INPUT_LIMIT(strm)) { + return EOF; + } else { + return ecl_char(STRING_INPUT_STRING(strm), pos); + } } static int str_in_listen(cl_object strm) { - if (STRING_INPUT_POSITION(strm) < STRING_INPUT_LIMIT(strm)) - return ECL_LISTEN_AVAILABLE; - else - return ECL_LISTEN_EOF; + if (STRING_INPUT_POSITION(strm) < STRING_INPUT_LIMIT(strm)) + return ECL_LISTEN_AVAILABLE; + else + return ECL_LISTEN_EOF; } static cl_object str_in_element_type(cl_object strm) { - cl_object string = STRING_INPUT_STRING(strm); - if (ECL_BASE_STRING_P(string)) - return @'base-char'; - return @'character'; + cl_object string = STRING_INPUT_STRING(strm); + if (ECL_BASE_STRING_P(string)) + return @'base-char'; + return @'character'; } static cl_object str_in_get_position(cl_object strm) { - return ecl_make_unsigned_integer(STRING_INPUT_POSITION(strm)); + return ecl_make_unsigned_integer(STRING_INPUT_POSITION(strm)); } static cl_object str_in_set_position(cl_object strm, cl_object pos) { - cl_fixnum disp; - if (Null(pos)) { - disp = STRING_INPUT_LIMIT(strm); - } else { - disp = ecl_to_size(pos); - if (disp >= STRING_INPUT_LIMIT(strm)) { - disp = STRING_INPUT_LIMIT(strm); - } - } - STRING_INPUT_POSITION(strm) = disp; - return ECL_T; + cl_fixnum disp; + if (Null(pos)) { + disp = STRING_INPUT_LIMIT(strm); + } else { + disp = ecl_to_size(pos); + if (disp >= STRING_INPUT_LIMIT(strm)) { + disp = STRING_INPUT_LIMIT(strm); + } + } + STRING_INPUT_POSITION(strm) = disp; + return ECL_T; } const struct ecl_file_ops str_in_ops = { - not_output_write_byte8, - not_binary_read_byte8, + not_output_write_byte8, + not_binary_read_byte8, - not_output_write_byte, - not_binary_read_byte, + not_output_write_byte, + not_binary_read_byte, - str_in_read_char, - not_output_write_char, - str_in_unread_char, - str_in_peek_char, + str_in_read_char, + not_output_write_char, + str_in_unread_char, + str_in_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - str_in_listen, - generic_void, /* clear-input */ - not_output_clear_output, - not_output_finish_output, - not_output_force_output, + str_in_listen, + generic_void, /* clear-input */ + not_output_clear_output, + not_output_finish_output, + not_output_force_output, - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - generic_always_false, - str_in_element_type, + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + generic_always_false, + str_in_element_type, - not_a_file_stream, /* length */ - str_in_get_position, - str_in_set_position, - generic_column, - generic_close + not_a_file_stream, /* length */ + str_in_get_position, + str_in_set_position, + generic_column, + generic_close }; cl_object ecl_make_string_input_stream(cl_object strng, cl_index istart, cl_index iend) { - cl_object strm; + cl_object strm; - strm = alloc_stream(); - strm->stream.ops = duplicate_dispatch_table(&str_in_ops); - strm->stream.mode = (short)ecl_smm_string_input; - STRING_INPUT_STRING(strm) = strng; - STRING_INPUT_POSITION(strm) = istart; - STRING_INPUT_LIMIT(strm) = iend; + strm = alloc_stream(); + strm->stream.ops = duplicate_dispatch_table(&str_in_ops); + strm->stream.mode = (short)ecl_smm_string_input; + STRING_INPUT_STRING(strm) = strng; + STRING_INPUT_POSITION(strm) = istart; + STRING_INPUT_LIMIT(strm) = iend; #if !defined(ECL_UNICODE) - strm->stream.format = @':pass-through'; - strm->stream.flags = ECL_STREAM_DEFAULT_FORMAT; - strm->stream.byte_size = 8; + strm->stream.format = @':pass-through'; + strm->stream.flags = ECL_STREAM_DEFAULT_FORMAT; + strm->stream.byte_size = 8; #else - if (ECL_BASE_STRING_P(strng) == t_base_string) { - strm->stream.format = @':latin-1'; - strm->stream.flags = ECL_STREAM_LATIN_1; - strm->stream.byte_size = 8; - } else { - strm->stream.format = @':ucs-4'; - strm->stream.flags = ECL_STREAM_UCS_4; - strm->stream.byte_size = 32; - } + if (ECL_BASE_STRING_P(strng) == t_base_string) { + strm->stream.format = @':latin-1'; + strm->stream.flags = ECL_STREAM_LATIN_1; + strm->stream.byte_size = 8; + } else { + strm->stream.format = @':ucs-4'; + strm->stream.flags = ECL_STREAM_UCS_4; + strm->stream.byte_size = 32; + } #endif - return strm; + return strm; } @(defun make_string_input_stream (strng &o (istart ecl_make_fixnum(0)) iend) - cl_index_pair p; + cl_index_pair p; @ - strng = cl_string(strng); - p = ecl_vector_start_end(@[make-string-input-stream], strng, istart, iend); - @(return (ecl_make_string_input_stream(strng, p.start, p.end))) + strng = cl_string(strng); + p = ecl_vector_start_end(@[make-string-input-stream], strng, istart, iend); + @(return (ecl_make_string_input_stream(strng, p.start, p.end))); @) /********************************************************************** @@ -1659,192 +1654,192 @@ ecl_make_string_input_stream(cl_object strng, cl_index istart, cl_index iend) static cl_index two_way_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - if (strm == cl_core.terminal_io) - ecl_force_output(TWO_WAY_STREAM_OUTPUT(cl_core.terminal_io)); - return ecl_read_byte8(TWO_WAY_STREAM_INPUT(strm), c, n); + if (strm == cl_core.terminal_io) + ecl_force_output(TWO_WAY_STREAM_OUTPUT(cl_core.terminal_io)); + return ecl_read_byte8(TWO_WAY_STREAM_INPUT(strm), c, n); } static cl_index two_way_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - return ecl_write_byte8(TWO_WAY_STREAM_OUTPUT(strm), c, n); + return ecl_write_byte8(TWO_WAY_STREAM_OUTPUT(strm), c, n); } static void two_way_write_byte(cl_object byte, cl_object stream) { - ecl_write_byte(byte, TWO_WAY_STREAM_OUTPUT(stream)); + ecl_write_byte(byte, TWO_WAY_STREAM_OUTPUT(stream)); } static cl_object two_way_read_byte(cl_object stream) { - return ecl_read_byte(TWO_WAY_STREAM_INPUT(stream)); + return ecl_read_byte(TWO_WAY_STREAM_INPUT(stream)); } static ecl_character two_way_read_char(cl_object strm) { - return ecl_read_char(TWO_WAY_STREAM_INPUT(strm)); + return ecl_read_char(TWO_WAY_STREAM_INPUT(strm)); } static ecl_character two_way_write_char(cl_object strm, ecl_character c) { - return ecl_write_char(c, TWO_WAY_STREAM_OUTPUT(strm)); + return ecl_write_char(c, TWO_WAY_STREAM_OUTPUT(strm)); } static void two_way_unread_char(cl_object strm, ecl_character c) { - ecl_unread_char(c, TWO_WAY_STREAM_INPUT(strm)); + ecl_unread_char(c, TWO_WAY_STREAM_INPUT(strm)); } static ecl_character two_way_peek_char(cl_object strm) { - return ecl_peek_char(TWO_WAY_STREAM_INPUT(strm)); + return ecl_peek_char(TWO_WAY_STREAM_INPUT(strm)); } static cl_index two_way_read_vector(cl_object strm, cl_object data, cl_index start, cl_index n) { - strm = TWO_WAY_STREAM_INPUT(strm); - return stream_dispatch_table(strm)->read_vector(strm, data, start, n); + strm = TWO_WAY_STREAM_INPUT(strm); + return stream_dispatch_table(strm)->read_vector(strm, data, start, n); } static cl_index two_way_write_vector(cl_object strm, cl_object data, cl_index start, cl_index n) { - strm = TWO_WAY_STREAM_OUTPUT(strm); - return stream_dispatch_table(strm)->write_vector(strm, data, start, n); + strm = TWO_WAY_STREAM_OUTPUT(strm); + return stream_dispatch_table(strm)->write_vector(strm, data, start, n); } static int two_way_listen(cl_object strm) { - return ecl_listen_stream(TWO_WAY_STREAM_INPUT(strm)); + return ecl_listen_stream(TWO_WAY_STREAM_INPUT(strm)); } static void two_way_clear_input(cl_object strm) { - ecl_clear_input(TWO_WAY_STREAM_INPUT(strm)); + ecl_clear_input(TWO_WAY_STREAM_INPUT(strm)); } static void two_way_clear_output(cl_object strm) { - ecl_clear_output(TWO_WAY_STREAM_OUTPUT(strm)); + ecl_clear_output(TWO_WAY_STREAM_OUTPUT(strm)); } static void two_way_force_output(cl_object strm) { - ecl_force_output(TWO_WAY_STREAM_OUTPUT(strm)); + ecl_force_output(TWO_WAY_STREAM_OUTPUT(strm)); } static void two_way_finish_output(cl_object strm) { - ecl_finish_output(TWO_WAY_STREAM_OUTPUT(strm)); + ecl_finish_output(TWO_WAY_STREAM_OUTPUT(strm)); } static int two_way_interactive_p(cl_object strm) { - return ecl_interactive_stream_p(TWO_WAY_STREAM_INPUT(strm)); + return ecl_interactive_stream_p(TWO_WAY_STREAM_INPUT(strm)); } static cl_object two_way_element_type(cl_object strm) { - return ecl_stream_element_type(TWO_WAY_STREAM_INPUT(strm)); + return ecl_stream_element_type(TWO_WAY_STREAM_INPUT(strm)); } static int two_way_column(cl_object strm) { - return ecl_file_column(TWO_WAY_STREAM_OUTPUT(strm)); + return ecl_file_column(TWO_WAY_STREAM_OUTPUT(strm)); } static cl_object two_way_close(cl_object strm) { - if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { - cl_close(1, TWO_WAY_STREAM_INPUT(strm)); - cl_close(1, TWO_WAY_STREAM_OUTPUT(strm)); - } - return generic_close(strm); + if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { + cl_close(1, TWO_WAY_STREAM_INPUT(strm)); + cl_close(1, TWO_WAY_STREAM_OUTPUT(strm)); + } + return generic_close(strm); } const struct ecl_file_ops two_way_ops = { - two_way_write_byte8, - two_way_read_byte8, + two_way_write_byte8, + two_way_read_byte8, - two_way_write_byte, - two_way_read_byte, + two_way_write_byte, + two_way_read_byte, - two_way_read_char, - two_way_write_char, - two_way_unread_char, - two_way_peek_char, + two_way_read_char, + two_way_write_char, + two_way_unread_char, + two_way_peek_char, - two_way_read_vector, - two_way_write_vector, + two_way_read_vector, + two_way_write_vector, - two_way_listen, - two_way_clear_input, - two_way_clear_output, - two_way_finish_output, - two_way_force_output, + two_way_listen, + two_way_clear_input, + two_way_clear_output, + two_way_finish_output, + two_way_force_output, - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - two_way_interactive_p, - two_way_element_type, + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + two_way_interactive_p, + two_way_element_type, - not_a_file_stream, /* length */ - generic_always_nil, /* get_position */ - generic_set_position, - two_way_column, - two_way_close + not_a_file_stream, /* length */ + generic_always_nil, /* get_position */ + generic_set_position, + two_way_column, + two_way_close }; cl_object cl_make_two_way_stream(cl_object istrm, cl_object ostrm) { - cl_object strm; - if (!ecl_input_stream_p(istrm)) - not_an_input_stream(istrm); - if (!ecl_output_stream_p(ostrm)) - not_an_output_stream(ostrm); - strm = alloc_stream(); - strm->stream.format = cl_stream_external_format(istrm); - strm->stream.mode = (short)ecl_smm_two_way; - strm->stream.ops = duplicate_dispatch_table(&two_way_ops); - TWO_WAY_STREAM_INPUT(strm) = istrm; - TWO_WAY_STREAM_OUTPUT(strm) = ostrm; - @(return strm) + cl_object strm; + if (!ecl_input_stream_p(istrm)) + not_an_input_stream(istrm); + if (!ecl_output_stream_p(ostrm)) + not_an_output_stream(ostrm); + strm = alloc_stream(); + strm->stream.format = cl_stream_external_format(istrm); + strm->stream.mode = (short)ecl_smm_two_way; + strm->stream.ops = duplicate_dispatch_table(&two_way_ops); + TWO_WAY_STREAM_INPUT(strm) = istrm; + TWO_WAY_STREAM_OUTPUT(strm) = ostrm; + @(return strm); } cl_object cl_two_way_stream_input_stream(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm,ecl_smm_two_way)) - FEwrong_type_only_arg(@[two-way-stream-input-stream], - strm, @[two-way-stream]); - @(return TWO_WAY_STREAM_INPUT(strm)); + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm,ecl_smm_two_way)) + FEwrong_type_only_arg(@[two-way-stream-input-stream], + strm, @[two-way-stream]); + @(return TWO_WAY_STREAM_INPUT(strm)); } cl_object cl_two_way_stream_output_stream(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_two_way)) - FEwrong_type_only_arg(@[two-way-stream-output-stream], - strm, @[two-way-stream]); - @(return TWO_WAY_STREAM_OUTPUT(strm)) + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_two_way)) + FEwrong_type_only_arg(@[two-way-stream-output-stream], + strm, @[two-way-stream]); + @(return TWO_WAY_STREAM_OUTPUT(strm)); } /********************************************************************** @@ -1854,173 +1849,173 @@ cl_two_way_stream_output_stream(cl_object strm) static cl_index broadcast_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_object l; - cl_index out = n; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - out = ecl_write_byte8(ECL_CONS_CAR(l), c, n); - } - return out; + cl_object l; + cl_index out = n; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + out = ecl_write_byte8(ECL_CONS_CAR(l), c, n); + } + return out; } static ecl_character broadcast_write_char(cl_object strm, ecl_character c) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_write_char(c, ECL_CONS_CAR(l)); - } - return c; + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_write_char(c, ECL_CONS_CAR(l)); + } + return c; } static void broadcast_write_byte(cl_object c, cl_object strm) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_write_byte(c, ECL_CONS_CAR(l)); - } + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_write_byte(c, ECL_CONS_CAR(l)); + } } static void broadcast_clear_output(cl_object strm) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_clear_output(ECL_CONS_CAR(l)); - } + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_clear_output(ECL_CONS_CAR(l)); + } } static void broadcast_force_output(cl_object strm) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_force_output(ECL_CONS_CAR(l)); - } + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_force_output(ECL_CONS_CAR(l)); + } } static void broadcast_finish_output(cl_object strm) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_finish_output(ECL_CONS_CAR(l)); - } + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_finish_output(ECL_CONS_CAR(l)); + } } static cl_object broadcast_element_type(cl_object strm) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return ECL_T; - return ecl_stream_element_type(ECL_CONS_CAR(l)); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return ECL_T; + return ecl_stream_element_type(ECL_CONS_CAR(l)); } static cl_object broadcast_length(cl_object strm) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return ecl_make_fixnum(0); - return ecl_file_length(ECL_CONS_CAR(l)); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return ecl_make_fixnum(0); + return ecl_file_length(ECL_CONS_CAR(l)); } static cl_object broadcast_get_position(cl_object strm) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return ecl_make_fixnum(0); - return ecl_file_position(ECL_CONS_CAR(l)); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return ecl_make_fixnum(0); + return ecl_file_position(ECL_CONS_CAR(l)); } static cl_object broadcast_set_position(cl_object strm, cl_object pos) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return ECL_NIL; - return ecl_file_position_set(ECL_CONS_CAR(l), pos); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return ECL_NIL; + return ecl_file_position_set(ECL_CONS_CAR(l), pos); } static int broadcast_column(cl_object strm) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return 0; - return ecl_file_column(ECL_CONS_CAR(l)); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return 0; + return ecl_file_column(ECL_CONS_CAR(l)); } static cl_object broadcast_close(cl_object strm) { - if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { - cl_mapc(2, @'close', BROADCAST_STREAM_LIST(strm)); - } - return generic_close(strm); + if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { + cl_mapc(2, @'close', BROADCAST_STREAM_LIST(strm)); + } + return generic_close(strm); } const struct ecl_file_ops broadcast_ops = { - broadcast_write_byte8, - not_input_read_byte8, + broadcast_write_byte8, + not_input_read_byte8, - broadcast_write_byte, - not_input_read_byte, + broadcast_write_byte, + not_input_read_byte, - not_input_read_char, - broadcast_write_char, - not_input_unread_char, - generic_peek_char, + not_input_read_char, + broadcast_write_char, + not_input_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - not_input_listen, - broadcast_force_output, /* clear_input */ /* FIXME! This is legacy behaviour */ - broadcast_clear_output, - broadcast_finish_output, - broadcast_force_output, + not_input_listen, + broadcast_force_output, /* clear_input */ /* FIXME! This is legacy behaviour */ + broadcast_clear_output, + broadcast_finish_output, + broadcast_force_output, - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - broadcast_element_type, + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + broadcast_element_type, - broadcast_length, - broadcast_get_position, - broadcast_set_position, - broadcast_column, - broadcast_close + broadcast_length, + broadcast_get_position, + broadcast_set_position, + broadcast_column, + broadcast_close }; @(defun make_broadcast_stream (&rest ap) - cl_object x, streams; - int i; + cl_object x, streams; + int i; @ - streams = ECL_NIL; - for (i = 0; i < narg; i++) { - x = ecl_va_arg(ap); - unlikely_if (!ecl_output_stream_p(x)) - not_an_output_stream(x); - streams = CONS(x, streams); - } - x = alloc_stream(); - x->stream.format = @':default'; - x->stream.ops = duplicate_dispatch_table(&broadcast_ops); - x->stream.mode = (short)ecl_smm_broadcast; - BROADCAST_STREAM_LIST(x) = cl_nreverse(streams); - @(return x) + streams = ECL_NIL; + for (i = 0; i < narg; i++) { + x = ecl_va_arg(ap); + unlikely_if (!ecl_output_stream_p(x)) + not_an_output_stream(x); + streams = CONS(x, streams); + } + x = alloc_stream(); + x->stream.format = @':default'; + x->stream.ops = duplicate_dispatch_table(&broadcast_ops); + x->stream.mode = (short)ecl_smm_broadcast; + BROADCAST_STREAM_LIST(x) = cl_nreverse(streams); + @(return x); @) cl_object cl_broadcast_stream_streams(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_broadcast)) - FEwrong_type_only_arg(@[broadcast-stream-streams], - strm, @[broadcast-stream]); - return cl_copy_list(BROADCAST_STREAM_LIST(strm)); + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_broadcast)) + FEwrong_type_only_arg(@[broadcast-stream-streams], + strm, @[broadcast-stream]); + return cl_copy_list(BROADCAST_STREAM_LIST(strm)); } /********************************************************************** @@ -2030,189 +2025,189 @@ cl_broadcast_stream_streams(cl_object strm) static cl_index echo_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index out = ecl_read_byte8(ECHO_STREAM_INPUT(strm), c, n); - return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, out); + cl_index out = ecl_read_byte8(ECHO_STREAM_INPUT(strm), c, n); + return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, out); } static cl_index echo_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, n); + return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, n); } static void echo_write_byte(cl_object c, cl_object strm) { - ecl_write_byte(c, ECHO_STREAM_OUTPUT(strm)); + ecl_write_byte(c, ECHO_STREAM_OUTPUT(strm)); } static cl_object echo_read_byte(cl_object strm) { - cl_object out = ecl_read_byte(ECHO_STREAM_INPUT(strm)); - if (!Null(out)) ecl_write_byte(out, ECHO_STREAM_OUTPUT(strm)); - return out; + cl_object out = ecl_read_byte(ECHO_STREAM_INPUT(strm)); + if (!Null(out)) ecl_write_byte(out, ECHO_STREAM_OUTPUT(strm)); + return out; } static ecl_character echo_read_char(cl_object strm) { - ecl_character c = strm->stream.last_code[0]; - if (c == EOF) { - c = ecl_read_char(ECHO_STREAM_INPUT(strm)); - if (c != EOF) - ecl_write_char(c, ECHO_STREAM_OUTPUT(strm)); - } else { - strm->stream.last_code[0] = EOF; - ecl_read_char(ECHO_STREAM_INPUT(strm)); - } - return c; + ecl_character c = strm->stream.last_code[0]; + if (c == EOF) { + c = ecl_read_char(ECHO_STREAM_INPUT(strm)); + if (c != EOF) + ecl_write_char(c, ECHO_STREAM_OUTPUT(strm)); + } else { + strm->stream.last_code[0] = EOF; + ecl_read_char(ECHO_STREAM_INPUT(strm)); + } + return c; } static ecl_character echo_write_char(cl_object strm, ecl_character c) { - return ecl_write_char(c, ECHO_STREAM_OUTPUT(strm)); + return ecl_write_char(c, ECHO_STREAM_OUTPUT(strm)); } static void echo_unread_char(cl_object strm, ecl_character c) { - unlikely_if (strm->stream.last_code[0] != EOF) { - unread_twice(strm); - } - strm->stream.last_code[0] = c; - ecl_unread_char(c, ECHO_STREAM_INPUT(strm)); + unlikely_if (strm->stream.last_code[0] != EOF) { + unread_twice(strm); + } + strm->stream.last_code[0] = c; + ecl_unread_char(c, ECHO_STREAM_INPUT(strm)); } static ecl_character echo_peek_char(cl_object strm) { - ecl_character c = strm->stream.last_code[0]; - if (c == EOF) { - c = ecl_peek_char(ECHO_STREAM_INPUT(strm)); - } - return c; + ecl_character c = strm->stream.last_code[0]; + if (c == EOF) { + c = ecl_peek_char(ECHO_STREAM_INPUT(strm)); + } + return c; } static int echo_listen(cl_object strm) { - return ecl_listen_stream(ECHO_STREAM_INPUT(strm)); + return ecl_listen_stream(ECHO_STREAM_INPUT(strm)); } static void echo_clear_input(cl_object strm) { - ecl_clear_input(ECHO_STREAM_INPUT(strm)); + ecl_clear_input(ECHO_STREAM_INPUT(strm)); } static void echo_clear_output(cl_object strm) { - ecl_clear_output(ECHO_STREAM_OUTPUT(strm)); + ecl_clear_output(ECHO_STREAM_OUTPUT(strm)); } static void echo_force_output(cl_object strm) { - ecl_force_output(ECHO_STREAM_OUTPUT(strm)); + ecl_force_output(ECHO_STREAM_OUTPUT(strm)); } static void echo_finish_output(cl_object strm) { - ecl_finish_output(ECHO_STREAM_OUTPUT(strm)); + ecl_finish_output(ECHO_STREAM_OUTPUT(strm)); } static cl_object echo_element_type(cl_object strm) { - return ecl_stream_element_type(ECHO_STREAM_INPUT(strm)); + return ecl_stream_element_type(ECHO_STREAM_INPUT(strm)); } static int echo_column(cl_object strm) { - return ecl_file_column(ECHO_STREAM_OUTPUT(strm)); + return ecl_file_column(ECHO_STREAM_OUTPUT(strm)); } static cl_object echo_close(cl_object strm) { - if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { - cl_close(1, ECHO_STREAM_INPUT(strm)); - cl_close(1, ECHO_STREAM_OUTPUT(strm)); - } - return generic_close(strm); + if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { + cl_close(1, ECHO_STREAM_INPUT(strm)); + cl_close(1, ECHO_STREAM_OUTPUT(strm)); + } + return generic_close(strm); } const struct ecl_file_ops echo_ops = { - echo_write_byte8, - echo_read_byte8, + echo_write_byte8, + echo_read_byte8, - echo_write_byte, - echo_read_byte, + echo_write_byte, + echo_read_byte, - echo_read_char, - echo_write_char, - echo_unread_char, - echo_peek_char, + echo_read_char, + echo_write_char, + echo_unread_char, + echo_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - echo_listen, - echo_clear_input, - echo_clear_output, - echo_finish_output, - echo_force_output, + echo_listen, + echo_clear_input, + echo_clear_output, + echo_finish_output, + echo_force_output, - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - echo_element_type, + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + echo_element_type, - not_a_file_stream, /* length */ - generic_always_nil, /* get_position */ - generic_set_position, - echo_column, - echo_close + not_a_file_stream, /* length */ + generic_always_nil, /* get_position */ + generic_set_position, + echo_column, + echo_close }; cl_object cl_make_echo_stream(cl_object strm1, cl_object strm2) { - cl_object strm; - unlikely_if (!ecl_input_stream_p(strm1)) - not_an_input_stream(strm1); - unlikely_if (!ecl_output_stream_p(strm2)) - not_an_output_stream(strm2); - strm = alloc_stream(); - strm->stream.format = cl_stream_external_format(strm1); - strm->stream.mode = (short)ecl_smm_echo; - strm->stream.ops = duplicate_dispatch_table(&echo_ops); - ECHO_STREAM_INPUT(strm) = strm1; - ECHO_STREAM_OUTPUT(strm) = strm2; - @(return strm) + cl_object strm; + unlikely_if (!ecl_input_stream_p(strm1)) + not_an_input_stream(strm1); + unlikely_if (!ecl_output_stream_p(strm2)) + not_an_output_stream(strm2); + strm = alloc_stream(); + strm->stream.format = cl_stream_external_format(strm1); + strm->stream.mode = (short)ecl_smm_echo; + strm->stream.ops = duplicate_dispatch_table(&echo_ops); + ECHO_STREAM_INPUT(strm) = strm1; + ECHO_STREAM_OUTPUT(strm) = strm2; + @(return strm); } cl_object cl_echo_stream_input_stream(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_echo)) - FEwrong_type_only_arg(@[echo-stream-input-stream], - strm, @[echo-stream]); - @(return ECHO_STREAM_INPUT(strm)) + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_echo)) + FEwrong_type_only_arg(@[echo-stream-input-stream], + strm, @[echo-stream]); + @(return ECHO_STREAM_INPUT(strm)); } cl_object cl_echo_stream_output_stream(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_echo)) - FEwrong_type_only_arg(@[echo-stream-output-stream], - strm, @[echo-stream]); - @(return ECHO_STREAM_OUTPUT(strm)) + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_echo)) + FEwrong_type_only_arg(@[echo-stream-output-stream], + strm, @[echo-stream]); + @(return ECHO_STREAM_OUTPUT(strm)); } /********************************************************************** @@ -2222,140 +2217,140 @@ cl_echo_stream_output_stream(cl_object strm) static cl_index concatenated_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - cl_index out = 0; - while (out < n && !Null(l)) { - cl_index delta = ecl_read_byte8(ECL_CONS_CAR(l), c + out, n - out); - out += delta; - if (out == n) break; - CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); - } - return out; + cl_object l = CONCATENATED_STREAM_LIST(strm); + cl_index out = 0; + while (out < n && !Null(l)) { + cl_index delta = ecl_read_byte8(ECL_CONS_CAR(l), c + out, n - out); + out += delta; + if (out == n) break; + CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); + } + return out; } static cl_object concatenated_read_byte(cl_object strm) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - cl_object c = ECL_NIL; - while (!Null(l)) { - c = ecl_read_byte(ECL_CONS_CAR(l)); - if (c != ECL_NIL) break; - CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); - } - return c; + cl_object l = CONCATENATED_STREAM_LIST(strm); + cl_object c = ECL_NIL; + while (!Null(l)) { + c = ecl_read_byte(ECL_CONS_CAR(l)); + if (c != ECL_NIL) break; + CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); + } + return c; } static ecl_character concatenated_read_char(cl_object strm) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - ecl_character c = EOF; - while (!Null(l)) { - c = ecl_read_char(ECL_CONS_CAR(l)); - if (c != EOF) break; - CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); - } - return c; + cl_object l = CONCATENATED_STREAM_LIST(strm); + ecl_character c = EOF; + while (!Null(l)) { + c = ecl_read_char(ECL_CONS_CAR(l)); + if (c != EOF) break; + CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); + } + return c; } static void concatenated_unread_char(cl_object strm, ecl_character c) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - unlikely_if (Null(l)) - unread_error(strm); - ecl_unread_char(c, ECL_CONS_CAR(l)); + cl_object l = CONCATENATED_STREAM_LIST(strm); + unlikely_if (Null(l)) + unread_error(strm); + ecl_unread_char(c, ECL_CONS_CAR(l)); } static int concatenated_listen(cl_object strm) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - while (!Null(l)) { - int f = ecl_listen_stream(ECL_CONS_CAR(l)); - l = ECL_CONS_CDR(l); - if (f == ECL_LISTEN_EOF) { - CONCATENATED_STREAM_LIST(strm) = l; - } else { - return f; - } - } - return ECL_LISTEN_EOF; + cl_object l = CONCATENATED_STREAM_LIST(strm); + while (!Null(l)) { + int f = ecl_listen_stream(ECL_CONS_CAR(l)); + l = ECL_CONS_CDR(l); + if (f == ECL_LISTEN_EOF) { + CONCATENATED_STREAM_LIST(strm) = l; + } else { + return f; + } + } + return ECL_LISTEN_EOF; } static cl_object concatenated_close(cl_object strm) { - if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { - cl_mapc(2, @'close', CONCATENATED_STREAM_LIST(strm)); - } - return generic_close(strm); + if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { + cl_mapc(2, @'close', CONCATENATED_STREAM_LIST(strm)); + } + return generic_close(strm); } const struct ecl_file_ops concatenated_ops = { - not_output_write_byte8, - concatenated_read_byte8, + not_output_write_byte8, + concatenated_read_byte8, - not_output_write_byte, - concatenated_read_byte, + not_output_write_byte, + concatenated_read_byte, - concatenated_read_char, - not_output_write_char, - concatenated_unread_char, - generic_peek_char, + concatenated_read_char, + not_output_write_char, + concatenated_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - concatenated_listen, - generic_void, /* clear_input */ - not_output_clear_output, - not_output_finish_output, - not_output_force_output, + concatenated_listen, + generic_void, /* clear_input */ + not_output_clear_output, + not_output_finish_output, + not_output_force_output, - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - generic_always_false, - broadcast_element_type, + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + generic_always_false, + broadcast_element_type, - not_a_file_stream, /* length */ - generic_always_nil, /* get_position */ - generic_set_position, - generic_column, - concatenated_close + not_a_file_stream, /* length */ + generic_always_nil, /* get_position */ + generic_set_position, + generic_column, + concatenated_close }; @(defun make_concatenated_stream (&rest ap) - cl_object x, streams; - int i; + cl_object x, streams; + int i; @ - streams = ECL_NIL; - for (i = 0; i < narg; i++) { - x = ecl_va_arg(ap); - unlikely_if (!ecl_input_stream_p(x)) - not_an_input_stream(x); - streams = CONS(x, streams); - } - x = alloc_stream(); - if (Null(streams)) { - x->stream.format = @':pass-through'; - } else { - x->stream.format = cl_stream_external_format(ECL_CONS_CAR(streams)); - } - x->stream.mode = (short)ecl_smm_concatenated; - x->stream.ops = duplicate_dispatch_table(&concatenated_ops); - CONCATENATED_STREAM_LIST(x) = cl_nreverse(streams); - @(return x) + streams = ECL_NIL; + for (i = 0; i < narg; i++) { + x = ecl_va_arg(ap); + unlikely_if (!ecl_input_stream_p(x)) + not_an_input_stream(x); + streams = CONS(x, streams); + } + x = alloc_stream(); + if (Null(streams)) { + x->stream.format = @':pass-through'; + } else { + x->stream.format = cl_stream_external_format(ECL_CONS_CAR(streams)); + } + x->stream.mode = (short)ecl_smm_concatenated; + x->stream.ops = duplicate_dispatch_table(&concatenated_ops); + CONCATENATED_STREAM_LIST(x) = cl_nreverse(streams); + @(return x); @) cl_object cl_concatenated_stream_streams(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_concatenated)) - FEwrong_type_only_arg(@[concatenated-stream-streams], - strm, @[concatenated-stream]); - return cl_copy_list(CONCATENATED_STREAM_LIST(strm)); + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_concatenated)) + FEwrong_type_only_arg(@[concatenated-stream-streams], + strm, @[concatenated-stream]); + return cl_copy_list(CONCATENATED_STREAM_LIST(strm)); } /********************************************************************** @@ -2365,196 +2360,196 @@ cl_concatenated_stream_streams(cl_object strm) static cl_index synonym_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - return ecl_read_byte8(SYNONYM_STREAM_STREAM(strm), c, n); + return ecl_read_byte8(SYNONYM_STREAM_STREAM(strm), c, n); } static cl_index synonym_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - return ecl_write_byte8(SYNONYM_STREAM_STREAM(strm), c, n); + return ecl_write_byte8(SYNONYM_STREAM_STREAM(strm), c, n); } static void synonym_write_byte(cl_object c, cl_object strm) { - ecl_write_byte(c, SYNONYM_STREAM_STREAM(strm)); + ecl_write_byte(c, SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_read_byte(cl_object strm) { - return ecl_read_byte(SYNONYM_STREAM_STREAM(strm)); + return ecl_read_byte(SYNONYM_STREAM_STREAM(strm)); } static ecl_character synonym_read_char(cl_object strm) { - return ecl_read_char(SYNONYM_STREAM_STREAM(strm)); + return ecl_read_char(SYNONYM_STREAM_STREAM(strm)); } static ecl_character synonym_write_char(cl_object strm, ecl_character c) { - return ecl_write_char(c, SYNONYM_STREAM_STREAM(strm)); + return ecl_write_char(c, SYNONYM_STREAM_STREAM(strm)); } static void synonym_unread_char(cl_object strm, ecl_character c) { - ecl_unread_char(c, SYNONYM_STREAM_STREAM(strm)); + ecl_unread_char(c, SYNONYM_STREAM_STREAM(strm)); } static ecl_character synonym_peek_char(cl_object strm) { - return ecl_peek_char(SYNONYM_STREAM_STREAM(strm)); + return ecl_peek_char(SYNONYM_STREAM_STREAM(strm)); } static cl_index synonym_read_vector(cl_object strm, cl_object data, cl_index start, cl_index n) { - strm = SYNONYM_STREAM_STREAM(strm); - return stream_dispatch_table(strm)->read_vector(strm, data, start, n); + strm = SYNONYM_STREAM_STREAM(strm); + return stream_dispatch_table(strm)->read_vector(strm, data, start, n); } static cl_index synonym_write_vector(cl_object strm, cl_object data, cl_index start, cl_index n) { - strm = SYNONYM_STREAM_STREAM(strm); - return stream_dispatch_table(strm)->write_vector(strm, data, start, n); + strm = SYNONYM_STREAM_STREAM(strm); + return stream_dispatch_table(strm)->write_vector(strm, data, start, n); } static int synonym_listen(cl_object strm) { - return ecl_listen_stream(SYNONYM_STREAM_STREAM(strm)); + return ecl_listen_stream(SYNONYM_STREAM_STREAM(strm)); } static void synonym_clear_input(cl_object strm) { - ecl_clear_input(SYNONYM_STREAM_STREAM(strm)); + ecl_clear_input(SYNONYM_STREAM_STREAM(strm)); } static void synonym_clear_output(cl_object strm) { - ecl_clear_output(SYNONYM_STREAM_STREAM(strm)); + ecl_clear_output(SYNONYM_STREAM_STREAM(strm)); } static void synonym_force_output(cl_object strm) { - ecl_force_output(SYNONYM_STREAM_STREAM(strm)); + ecl_force_output(SYNONYM_STREAM_STREAM(strm)); } static void synonym_finish_output(cl_object strm) { - ecl_finish_output(SYNONYM_STREAM_STREAM(strm)); + ecl_finish_output(SYNONYM_STREAM_STREAM(strm)); } static int synonym_input_p(cl_object strm) { - return ecl_input_stream_p(SYNONYM_STREAM_STREAM(strm)); + return ecl_input_stream_p(SYNONYM_STREAM_STREAM(strm)); } static int synonym_output_p(cl_object strm) { - return ecl_output_stream_p(SYNONYM_STREAM_STREAM(strm)); + return ecl_output_stream_p(SYNONYM_STREAM_STREAM(strm)); } static int synonym_interactive_p(cl_object strm) { - return ecl_interactive_stream_p(SYNONYM_STREAM_STREAM(strm)); + return ecl_interactive_stream_p(SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_element_type(cl_object strm) { - return ecl_stream_element_type(SYNONYM_STREAM_STREAM(strm)); + return ecl_stream_element_type(SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_length(cl_object strm) { - return ecl_file_length(SYNONYM_STREAM_STREAM(strm)); + return ecl_file_length(SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_get_position(cl_object strm) { - return ecl_file_position(SYNONYM_STREAM_STREAM(strm)); + return ecl_file_position(SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_set_position(cl_object strm, cl_object pos) { - return ecl_file_position_set(SYNONYM_STREAM_STREAM(strm), pos); + return ecl_file_position_set(SYNONYM_STREAM_STREAM(strm), pos); } static int synonym_column(cl_object strm) { - return ecl_file_column(SYNONYM_STREAM_STREAM(strm)); + return ecl_file_column(SYNONYM_STREAM_STREAM(strm)); } const struct ecl_file_ops synonym_ops = { - synonym_write_byte8, - synonym_read_byte8, + synonym_write_byte8, + synonym_read_byte8, - synonym_write_byte, - synonym_read_byte, + synonym_write_byte, + synonym_read_byte, - synonym_read_char, - synonym_write_char, - synonym_unread_char, - synonym_peek_char, + synonym_read_char, + synonym_write_char, + synonym_unread_char, + synonym_peek_char, - synonym_read_vector, - synonym_write_vector, + synonym_read_vector, + synonym_write_vector, - synonym_listen, - synonym_clear_input, - synonym_clear_output, - synonym_finish_output, - synonym_force_output, + synonym_listen, + synonym_clear_input, + synonym_clear_output, + synonym_finish_output, + synonym_force_output, - synonym_input_p, - synonym_output_p, - synonym_interactive_p, - synonym_element_type, + synonym_input_p, + synonym_output_p, + synonym_interactive_p, + synonym_element_type, - synonym_length, - synonym_get_position, - synonym_set_position, - synonym_column, - generic_close + synonym_length, + synonym_get_position, + synonym_set_position, + synonym_column, + generic_close }; cl_object cl_make_synonym_stream(cl_object sym) { - cl_object x; + cl_object x; - sym = ecl_check_cl_type(@'make-synonym-stream',sym,t_symbol); - x = alloc_stream(); - x->stream.ops = duplicate_dispatch_table(&synonym_ops); - x->stream.mode = (short)ecl_smm_synonym; - SYNONYM_STREAM_SYMBOL(x) = sym; - @(return x) + sym = ecl_check_cl_type(@'make-synonym-stream',sym,t_symbol); + x = alloc_stream(); + x->stream.ops = duplicate_dispatch_table(&synonym_ops); + x->stream.mode = (short)ecl_smm_synonym; + SYNONYM_STREAM_SYMBOL(x) = sym; + @(return x); } cl_object cl_synonym_stream_symbol(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_synonym)) - FEwrong_type_only_arg(@[synonym-stream-symbol], - strm, @[synonym-stream]); - @(return SYNONYM_STREAM_SYMBOL(strm)) + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_synonym)) + FEwrong_type_only_arg(@[synonym-stream-symbol], + strm, @[synonym-stream]); + @(return SYNONYM_STREAM_SYMBOL(strm)); } /********************************************************************** @@ -2570,56 +2565,56 @@ cl_synonym_stream_symbol(cl_object strm) static int safe_open(const char *filename, int flags, ecl_mode_t mode) { - const cl_env_ptr the_env = ecl_process_env(); - int output; - ecl_disable_interrupts_env(the_env); - output = open(filename, flags, mode); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + int output; + ecl_disable_interrupts_env(the_env); + output = open(filename, flags, mode); + ecl_enable_interrupts_env(the_env); + return output; } static int safe_close(int f) { - const cl_env_ptr the_env = ecl_process_env(); - int output; - ecl_disable_interrupts_env(the_env); - output = close(f); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + int output; + ecl_disable_interrupts_env(the_env); + output = close(f); + ecl_enable_interrupts_env(the_env); + return output; } static FILE * safe_fopen(const char *filename, const char *mode) { - const cl_env_ptr the_env = ecl_process_env(); - FILE *output; - ecl_disable_interrupts_env(the_env); - output = fopen(filename, mode); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + FILE *output; + ecl_disable_interrupts_env(the_env); + output = fopen(filename, mode); + ecl_enable_interrupts_env(the_env); + return output; } static FILE * safe_fdopen(int fildes, const char *mode) { - const cl_env_ptr the_env = ecl_process_env(); - FILE *output; - ecl_disable_interrupts_env(the_env); - output = fdopen(fildes, mode); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + FILE *output; + ecl_disable_interrupts_env(the_env); + output = fdopen(fildes, mode); + ecl_enable_interrupts_env(the_env); + return output; } static int safe_fclose(FILE *stream) { - const cl_env_ptr the_env = ecl_process_env(); - int output; - ecl_disable_interrupts_env(the_env); - output = fclose(stream); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + int output; + ecl_disable_interrupts_env(the_env); + output = fclose(stream); + ecl_enable_interrupts_env(the_env); + return output; } /********************************************************************** @@ -2629,96 +2624,96 @@ safe_fclose(FILE *stream) static cl_index consume_byte_stack(cl_object strm, unsigned char *c, cl_index n) { - cl_index out = 0; - while (n) { - cl_object l = strm->stream.byte_stack; - if (l == ECL_NIL) - return out + strm->stream.ops->read_byte8(strm, c, n); - *(c++) = ecl_fixnum(ECL_CONS_CAR(l)); - out++; - n--; - strm->stream.byte_stack = l = ECL_CONS_CDR(l); - } - return out; + cl_index out = 0; + while (n) { + cl_object l = strm->stream.byte_stack; + if (l == ECL_NIL) + return out + strm->stream.ops->read_byte8(strm, c, n); + *(c++) = ecl_fixnum(ECL_CONS_CAR(l)); + out++; + n--; + strm->stream.byte_stack = l = ECL_CONS_CDR(l); + } + return out; } static cl_index io_file_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return consume_byte_stack(strm, c, n); - } else { - int f = IO_FILE_DESCRIPTOR(strm); - cl_fixnum out = 0; - ecl_disable_interrupts(); - do { - out = read(f, c, sizeof(char)*n); - } while (out < 0 && restartable_io_error(strm, "read")); - ecl_enable_interrupts(); - return out; - } + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return consume_byte_stack(strm, c, n); + } else { + int f = IO_FILE_DESCRIPTOR(strm); + cl_fixnum out = 0; + ecl_disable_interrupts(); + do { + out = read(f, c, sizeof(char)*n); + } while (out < 0 && restartable_io_error(strm, "read")); + ecl_enable_interrupts(); + return out; + } } static cl_index output_file_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - int f = IO_FILE_DESCRIPTOR(strm); - cl_fixnum out; - ecl_disable_interrupts(); - do { - out = write(f, c, sizeof(char)*n); - } while (out < 0 && restartable_io_error(strm, "write")); - ecl_enable_interrupts(); - return out; + int f = IO_FILE_DESCRIPTOR(strm); + cl_fixnum out; + ecl_disable_interrupts(); + do { + out = write(f, c, sizeof(char)*n); + } while (out < 0 && restartable_io_error(strm, "write")); + ecl_enable_interrupts(); + return out; } static cl_index io_file_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - /* Try to move to the beginning of the unread characters */ - cl_object aux = ecl_file_position(strm); - if (!Null(aux)) - ecl_file_position_set(strm, aux); - strm->stream.byte_stack = ECL_NIL; - } - return output_file_write_byte8(strm, c, n); + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + /* Try to move to the beginning of the unread characters */ + cl_object aux = ecl_file_position(strm); + if (!Null(aux)) + ecl_file_position_set(strm, aux); + strm->stream.byte_stack = ECL_NIL; + } + return output_file_write_byte8(strm, c, n); } static int io_file_listen(cl_object strm) { - if (strm->stream.byte_stack != ECL_NIL) - return ECL_LISTEN_AVAILABLE; - if (strm->stream.flags & ECL_STREAM_MIGHT_SEEK) { - cl_env_ptr the_env = ecl_process_env(); - int f = IO_FILE_DESCRIPTOR(strm); - ecl_off_t disp, new; - ecl_disable_interrupts_env(the_env); - disp = lseek(f, 0, SEEK_CUR); - ecl_enable_interrupts_env(the_env); - if (disp != (ecl_off_t)-1) { - ecl_disable_interrupts_env(the_env); - new = lseek(f, 0, SEEK_END); - ecl_enable_interrupts_env(the_env); - lseek(f, disp, SEEK_SET); - if (new == disp) { - return ECL_LISTEN_NO_CHAR; - } else if (new != (ecl_off_t)-1) { - return ECL_LISTEN_AVAILABLE; - } - } - } - return file_listen(strm, IO_FILE_DESCRIPTOR(strm)); + if (strm->stream.byte_stack != ECL_NIL) + return ECL_LISTEN_AVAILABLE; + if (strm->stream.flags & ECL_STREAM_MIGHT_SEEK) { + cl_env_ptr the_env = ecl_process_env(); + int f = IO_FILE_DESCRIPTOR(strm); + ecl_off_t disp, new; + ecl_disable_interrupts_env(the_env); + disp = lseek(f, 0, SEEK_CUR); + ecl_enable_interrupts_env(the_env); + if (disp != (ecl_off_t)-1) { + ecl_disable_interrupts_env(the_env); + new = lseek(f, 0, SEEK_END); + ecl_enable_interrupts_env(the_env); + lseek(f, disp, SEEK_SET); + if (new == disp) { + return ECL_LISTEN_NO_CHAR; + } else if (new != (ecl_off_t)-1) { + return ECL_LISTEN_AVAILABLE; + } + } + } + return file_listen(strm, IO_FILE_DESCRIPTOR(strm)); } #if defined(ECL_MS_WINDOWS_HOST) static int isaconsole(int i) { - HANDLE h = (HANDLE)_get_osfhandle(i); - DWORD mode; - return !!GetConsoleMode(h, &mode); + HANDLE h = (HANDLE)_get_osfhandle(i); + DWORD mode; + return !!GetConsoleMode(h, &mode); } #define isatty isaconsole #endif @@ -2726,19 +2721,19 @@ isaconsole(int i) static void io_file_clear_input(cl_object strm) { - int f = IO_FILE_DESCRIPTOR(strm); + int f = IO_FILE_DESCRIPTOR(strm); #if defined(ECL_MS_WINDOWS_HOST) - if (isatty(f)) { - /* Flushes Win32 console */ - if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(f))) - FEwin32_error("FlushConsoleInputBuffer() failed", 0); - /* Do not stop here: the FILE structure needs also to be flushed */ - } + if (isatty(f)) { + /* Flushes Win32 console */ + if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(f))) + FEwin32_error("FlushConsoleInputBuffer() failed", 0); + /* Do not stop here: the FILE structure needs also to be flushed */ + } #endif - while (file_listen(strm, f) == ECL_LISTEN_AVAILABLE) { - ecl_character c = eformat_read_char(strm); - if (c == EOF) return; - } + while (file_listen(strm, f) == ECL_LISTEN_AVAILABLE) { + ecl_character c = eformat_read_char(strm); + if (c == EOF) return; + } } #define io_file_clear_output generic_void @@ -2748,573 +2743,573 @@ io_file_clear_input(cl_object strm) static int io_file_interactive_p(cl_object strm) { - int f = IO_FILE_DESCRIPTOR(strm); - return isatty(f); + int f = IO_FILE_DESCRIPTOR(strm); + return isatty(f); } static cl_object io_file_element_type(cl_object strm) { - return IO_FILE_ELT_TYPE(strm); + return IO_FILE_ELT_TYPE(strm); } static cl_object io_file_length(cl_object strm) { - int f = IO_FILE_DESCRIPTOR(strm); - cl_object output = ecl_file_len(f); - if (strm->stream.byte_size != 8) { - const cl_env_ptr the_env = ecl_process_env(); - cl_index bs = strm->stream.byte_size; - output = ecl_floor2(output, ecl_make_fixnum(bs/8)); - unlikely_if (ecl_nth_value(the_env, 1) != ecl_make_fixnum(0)) { - FEerror("File length is not on byte boundary", 0); - } - } - return output; + int f = IO_FILE_DESCRIPTOR(strm); + cl_object output = ecl_file_len(f); + if (strm->stream.byte_size != 8) { + const cl_env_ptr the_env = ecl_process_env(); + cl_index bs = strm->stream.byte_size; + output = ecl_floor2(output, ecl_make_fixnum(bs/8)); + unlikely_if (ecl_nth_value(the_env, 1) != ecl_make_fixnum(0)) { + FEerror("File length is not on byte boundary", 0); + } + } + return output; } static cl_object io_file_get_position(cl_object strm) { - cl_object output; - ecl_off_t offset; + cl_object output; + ecl_off_t offset; - int f = IO_FILE_DESCRIPTOR(strm); - if (isatty(f)) return(ECL_NIL); + int f = IO_FILE_DESCRIPTOR(strm); + if (isatty(f)) return(ECL_NIL); - ecl_disable_interrupts(); - offset = lseek(f, 0, SEEK_CUR); - ecl_enable_interrupts(); - unlikely_if (offset < 0) - if (errno == ESPIPE) - return(ECL_NIL); - else - io_error(strm); - if (sizeof(ecl_off_t) == sizeof(long)) { - output = ecl_make_integer(offset); - } else { - output = ecl_off_t_to_integer(offset); - } - { - /* If there are unread octets, we return the position at which - * these bytes begin! */ - cl_object l = strm->stream.byte_stack; - while (CONSP(l)) { - output = ecl_one_minus(output); - l = ECL_CONS_CDR(l); - } - } - if (strm->stream.byte_size != 8) { - output = ecl_floor2(output, ecl_make_fixnum(strm->stream.byte_size / 8)); - } - return output; + ecl_disable_interrupts(); + offset = lseek(f, 0, SEEK_CUR); + ecl_enable_interrupts(); + unlikely_if (offset < 0) + if (errno == ESPIPE) + return(ECL_NIL); + else + io_error(strm); + if (sizeof(ecl_off_t) == sizeof(long)) { + output = ecl_make_integer(offset); + } else { + output = ecl_off_t_to_integer(offset); + } + { + /* If there are unread octets, we return the position at which + * these bytes begin! */ + cl_object l = strm->stream.byte_stack; + while (CONSP(l)) { + output = ecl_one_minus(output); + l = ECL_CONS_CDR(l); + } + } + if (strm->stream.byte_size != 8) { + output = ecl_floor2(output, ecl_make_fixnum(strm->stream.byte_size / 8)); + } + return output; } static cl_object io_file_set_position(cl_object strm, cl_object large_disp) { - ecl_off_t disp; - int mode; - int f = IO_FILE_DESCRIPTOR(strm); - if (isatty(f)) return(ECL_NIL); - if (Null(large_disp)) { - disp = 0; - mode = SEEK_END; - } else { - if (strm->stream.byte_size != 8) { - large_disp = ecl_times(large_disp, - ecl_make_fixnum(strm->stream.byte_size / 8)); - } - disp = ecl_integer_to_off_t(large_disp); - mode = SEEK_SET; - } - disp = lseek(f, disp, mode); - return (disp == (ecl_off_t)-1)? ECL_NIL : ECL_T; + ecl_off_t disp; + int mode; + int f = IO_FILE_DESCRIPTOR(strm); + if (isatty(f)) return(ECL_NIL); + if (Null(large_disp)) { + disp = 0; + mode = SEEK_END; + } else { + if (strm->stream.byte_size != 8) { + large_disp = ecl_times(large_disp, + ecl_make_fixnum(strm->stream.byte_size / 8)); + } + disp = ecl_integer_to_off_t(large_disp); + mode = SEEK_SET; + } + disp = lseek(f, disp, mode); + return (disp == (ecl_off_t)-1)? ECL_NIL : ECL_T; } static int io_file_column(cl_object strm) { - return strm->stream.column; + return strm->stream.column; } static cl_object io_file_close(cl_object strm) { - int f = IO_FILE_DESCRIPTOR(strm); - int failed; - unlikely_if (f == STDOUT_FILENO) - FEerror("Cannot close the standard output", 0); - unlikely_if (f == STDIN_FILENO) - FEerror("Cannot close the standard input", 0); - failed = safe_close(f); - unlikely_if (failed < 0) - cannot_close(strm); - IO_FILE_DESCRIPTOR(strm) = -1; - return generic_close(strm); + int f = IO_FILE_DESCRIPTOR(strm); + int failed; + unlikely_if (f == STDOUT_FILENO) + FEerror("Cannot close the standard output", 0); + unlikely_if (f == STDIN_FILENO) + FEerror("Cannot close the standard input", 0); + failed = safe_close(f); + unlikely_if (failed < 0) + cannot_close(strm); + IO_FILE_DESCRIPTOR(strm) = -1; + return generic_close(strm); } static cl_index io_file_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end) { - cl_elttype t = ecl_array_elttype(data); - if (start >= end) - return start; - if (t == ecl_aet_b8 || t == ecl_aet_i8) { - if (strm->stream.byte_size == 8) { - void *aux = data->vector.self.bc + start; - return start + strm->stream.ops->read_byte8(strm, aux, end-start); - } - } else if (t == ecl_aet_fix || t == ecl_aet_index) { - if (strm->stream.byte_size == sizeof(cl_fixnum)*8) { - void *aux = data->vector.self.fix + start; - cl_index bytes = (end - start) * sizeof(cl_fixnum); - bytes = strm->stream.ops->read_byte8(strm, aux, bytes); - return start + bytes / sizeof(cl_fixnum); - } - } - return generic_read_vector(strm, data, start, end); + cl_elttype t = ecl_array_elttype(data); + if (start >= end) + return start; + if (t == ecl_aet_b8 || t == ecl_aet_i8) { + if (strm->stream.byte_size == 8) { + void *aux = data->vector.self.bc + start; + return start + strm->stream.ops->read_byte8(strm, aux, end-start); + } + } else if (t == ecl_aet_fix || t == ecl_aet_index) { + if (strm->stream.byte_size == sizeof(cl_fixnum)*8) { + void *aux = data->vector.self.fix + start; + cl_index bytes = (end - start) * sizeof(cl_fixnum); + bytes = strm->stream.ops->read_byte8(strm, aux, bytes); + return start + bytes / sizeof(cl_fixnum); + } + } + return generic_read_vector(strm, data, start, end); } static cl_index io_file_write_vector(cl_object strm, cl_object data, cl_index start, cl_index end) { - cl_elttype t = ecl_array_elttype(data); - if (start >= end) - return start; - if (t == ecl_aet_b8 || t == ecl_aet_i8) { - if (strm->stream.byte_size == 8) { - void *aux = data->vector.self.bc + start; - return strm->stream.ops->write_byte8(strm, aux, end-start); - } - } else if (t == ecl_aet_fix || t == ecl_aet_index) { - if (strm->stream.byte_size == sizeof(cl_fixnum)*8) { - void *aux = data->vector.self.fix + start; - cl_index bytes = (end - start) * sizeof(cl_fixnum); - bytes = strm->stream.ops->write_byte8(strm, aux, bytes); - return start + bytes / sizeof(cl_fixnum); - } - } - return generic_write_vector(strm, data, start, end); + cl_elttype t = ecl_array_elttype(data); + if (start >= end) + return start; + if (t == ecl_aet_b8 || t == ecl_aet_i8) { + if (strm->stream.byte_size == 8) { + void *aux = data->vector.self.bc + start; + return strm->stream.ops->write_byte8(strm, aux, end-start); + } + } else if (t == ecl_aet_fix || t == ecl_aet_index) { + if (strm->stream.byte_size == sizeof(cl_fixnum)*8) { + void *aux = data->vector.self.fix + start; + cl_index bytes = (end - start) * sizeof(cl_fixnum); + bytes = strm->stream.ops->write_byte8(strm, aux, bytes); + return start + bytes / sizeof(cl_fixnum); + } + } + return generic_write_vector(strm, data, start, end); } const struct ecl_file_ops io_file_ops = { - io_file_write_byte8, - io_file_read_byte8, + io_file_write_byte8, + io_file_read_byte8, - generic_write_byte, - generic_read_byte, + generic_write_byte, + generic_read_byte, - eformat_read_char, - eformat_write_char, - eformat_unread_char, - generic_peek_char, + eformat_read_char, + eformat_write_char, + eformat_unread_char, + generic_peek_char, - io_file_read_vector, - io_file_write_vector, + io_file_read_vector, + io_file_write_vector, - io_file_listen, - io_file_clear_input, - io_file_clear_output, - io_file_finish_output, - io_file_force_output, + io_file_listen, + io_file_clear_input, + io_file_clear_output, + io_file_finish_output, + io_file_force_output, - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - io_file_interactive_p, - io_file_element_type, + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + io_file_interactive_p, + io_file_element_type, - io_file_length, - io_file_get_position, - io_file_set_position, - io_file_column, - io_file_close + io_file_length, + io_file_get_position, + io_file_set_position, + io_file_column, + io_file_close }; const struct ecl_file_ops output_file_ops = { - output_file_write_byte8, - not_input_read_byte8, + output_file_write_byte8, + not_input_read_byte8, - generic_write_byte, - not_input_read_byte, + generic_write_byte, + not_input_read_byte, - not_input_read_char, - eformat_write_char, - not_input_unread_char, - not_input_read_char, + not_input_read_char, + eformat_write_char, + not_input_unread_char, + not_input_read_char, - generic_read_vector, - io_file_write_vector, + generic_read_vector, + io_file_write_vector, - not_input_listen, - not_input_clear_input, - io_file_clear_output, - io_file_finish_output, - io_file_force_output, + not_input_listen, + not_input_clear_input, + io_file_clear_output, + io_file_finish_output, + io_file_force_output, - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - io_file_element_type, + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + io_file_element_type, - io_file_length, - io_file_get_position, - io_file_set_position, - io_file_column, - io_file_close + io_file_length, + io_file_get_position, + io_file_set_position, + io_file_column, + io_file_close }; const struct ecl_file_ops input_file_ops = { - not_output_write_byte8, - io_file_read_byte8, + not_output_write_byte8, + io_file_read_byte8, - not_output_write_byte, - generic_read_byte, + not_output_write_byte, + generic_read_byte, - eformat_read_char, - not_output_write_char, - eformat_unread_char, - generic_peek_char, + eformat_read_char, + not_output_write_char, + eformat_unread_char, + generic_peek_char, - io_file_read_vector, - generic_write_vector, + io_file_read_vector, + generic_write_vector, - io_file_listen, - io_file_clear_input, - not_output_clear_output, - not_output_finish_output, - not_output_force_output, + io_file_listen, + io_file_clear_input, + not_output_clear_output, + not_output_finish_output, + not_output_force_output, - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - io_file_interactive_p, - io_file_element_type, + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + io_file_interactive_p, + io_file_element_type, - io_file_length, - io_file_get_position, - io_file_set_position, - generic_column, - io_file_close + io_file_length, + io_file_get_position, + io_file_set_position, + generic_column, + io_file_close }; static int parse_external_format(cl_object stream, cl_object format, int flags) { - if (format == @':default') { - format = ecl_symbol_value(@'ext::*default-external-format*'); - } - if (CONSP(format)) { - flags = parse_external_format(stream, ECL_CONS_CDR(format), flags); - format = ECL_CONS_CAR(format); - } - if (format == ECL_T) { + if (format == @':default') { + format = ecl_symbol_value(@'ext::*default-external-format*'); + } + if (CONSP(format)) { + flags = parse_external_format(stream, ECL_CONS_CDR(format), flags); + format = ECL_CONS_CAR(format); + } + if (format == ECL_T) { #ifdef ECL_UNICODE - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UTF_8; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UTF_8; #else - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_DEFAULT_FORMAT; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_DEFAULT_FORMAT; #endif - } - if (format == ECL_NIL) { - return flags; - } - if (format == @':CR') { - return (flags | ECL_STREAM_CR) & ~ECL_STREAM_LF; - } - if (format == @':LF') { - return (flags | ECL_STREAM_LF) & ~ECL_STREAM_CR; - } - if (format == @':CRLF') { - return flags | (ECL_STREAM_CR+ECL_STREAM_LF); - } - if (format == @':LITTLE-ENDIAN') { - return flags | ECL_STREAM_LITTLE_ENDIAN; - } - if (format == @':BIG-ENDIAN') { - return flags & ~ECL_STREAM_LITTLE_ENDIAN; - } - if (format == @':pass-through') { + } + if (format == ECL_NIL) { + return flags; + } + if (format == @':CR') { + return (flags | ECL_STREAM_CR) & ~ECL_STREAM_LF; + } + if (format == @':LF') { + return (flags | ECL_STREAM_LF) & ~ECL_STREAM_CR; + } + if (format == @':CRLF') { + return flags | (ECL_STREAM_CR+ECL_STREAM_LF); + } + if (format == @':LITTLE-ENDIAN') { + return flags | ECL_STREAM_LITTLE_ENDIAN; + } + if (format == @':BIG-ENDIAN') { + return flags & ~ECL_STREAM_LITTLE_ENDIAN; + } + if (format == @':pass-through') { #ifdef ECL_UNICODE - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_LATIN_1; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_LATIN_1; #else - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_DEFAULT_FORMAT; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_DEFAULT_FORMAT; #endif - } + } #ifdef ECL_UNICODE PARSE_SYMBOLS: - if (format == @':UTF-8') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UTF_8; - } - if (format == @':UCS-2') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2; - } - if (format == @':UCS-2BE') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2BE; - } - if (format == @':UCS-2LE') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2LE; - } - if (format == @':UCS-4') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4; - } - if (format == @':UCS-4BE') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4BE; - } - if (format == @':UCS-4LE') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4LE; - } - if (format == @':ISO-8859-1') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_ISO_8859_1; - } - if (format == @':LATIN-1') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_LATIN_1; - } - if (format == @':US-ASCII') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_US_ASCII; - } - if (ECL_HASH_TABLE_P(format)) { - stream->stream.format_table = format; - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_USER_FORMAT; - } - if (ECL_SYMBOLP(format)) { - format = si_make_encoding(format); - if (ECL_SYMBOLP(format)) - goto PARSE_SYMBOLS; - stream->stream.format_table = format; - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_USER_FORMAT; - } + if (format == @':UTF-8') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UTF_8; + } + if (format == @':UCS-2') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2; + } + if (format == @':UCS-2BE') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2BE; + } + if (format == @':UCS-2LE') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2LE; + } + if (format == @':UCS-4') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4; + } + if (format == @':UCS-4BE') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4BE; + } + if (format == @':UCS-4LE') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4LE; + } + if (format == @':ISO-8859-1') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_ISO_8859_1; + } + if (format == @':LATIN-1') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_LATIN_1; + } + if (format == @':US-ASCII') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_US_ASCII; + } + if (ECL_HASH_TABLE_P(format)) { + stream->stream.format_table = format; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_USER_FORMAT; + } + if (ECL_SYMBOLP(format)) { + format = si_make_encoding(format); + if (ECL_SYMBOLP(format)) + goto PARSE_SYMBOLS; + stream->stream.format_table = format; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_USER_FORMAT; + } #endif - FEerror("Unknown or unsupported external format: ~A", 1, format); - return ECL_STREAM_DEFAULT_FORMAT; + FEerror("Unknown or unsupported external format: ~A", 1, format); + return ECL_STREAM_DEFAULT_FORMAT; } static void set_stream_elt_type(cl_object stream, cl_fixnum byte_size, int flags, cl_object external_format) { - cl_object t; - if (byte_size < 0) { - byte_size = -byte_size; - flags |= ECL_STREAM_SIGNED_BYTES; - t = @'signed-byte'; - } else { - flags &= ~ECL_STREAM_SIGNED_BYTES; - t = @'unsigned-byte'; - } - flags = parse_external_format(stream, external_format, flags); - stream->stream.ops->read_char = eformat_read_char; - stream->stream.ops->write_char = eformat_write_char; - switch (flags & ECL_STREAM_FORMAT) { - case ECL_STREAM_BINARY: - IO_STREAM_ELT_TYPE(stream) = cl_list(2, t, ecl_make_fixnum(byte_size)); - stream->stream.format = t; - stream->stream.ops->read_char = not_character_read_char; - stream->stream.ops->write_char = not_character_write_char; - break; + cl_object t; + if (byte_size < 0) { + byte_size = -byte_size; + flags |= ECL_STREAM_SIGNED_BYTES; + t = @'signed-byte'; + } else { + flags &= ~ECL_STREAM_SIGNED_BYTES; + t = @'unsigned-byte'; + } + flags = parse_external_format(stream, external_format, flags); + stream->stream.ops->read_char = eformat_read_char; + stream->stream.ops->write_char = eformat_write_char; + switch (flags & ECL_STREAM_FORMAT) { + case ECL_STREAM_BINARY: + IO_STREAM_ELT_TYPE(stream) = cl_list(2, t, ecl_make_fixnum(byte_size)); + stream->stream.format = t; + stream->stream.ops->read_char = not_character_read_char; + stream->stream.ops->write_char = not_character_write_char; + break; #ifdef ECL_UNICODE - /*case ECL_ISO_8859_1:*/ - case ECL_STREAM_LATIN_1: - IO_STREAM_ELT_TYPE(stream) = @'base-char'; - byte_size = 8; - stream->stream.format = @':latin-1'; - stream->stream.encoder = passthrough_encoder; - stream->stream.decoder = passthrough_decoder; - break; - case ECL_STREAM_UTF_8: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8; - stream->stream.format = @':utf-8'; - stream->stream.encoder = utf_8_encoder; - stream->stream.decoder = utf_8_decoder; - break; - case ECL_STREAM_UCS_2: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8*2; - stream->stream.format = @':ucs-2'; - stream->stream.encoder = ucs_2_encoder; - stream->stream.decoder = ucs_2_decoder; - break; - case ECL_STREAM_UCS_2BE: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8*2; - if (flags & ECL_STREAM_LITTLE_ENDIAN) { - stream->stream.format = @':ucs-2le'; - stream->stream.encoder = ucs_2le_encoder; - stream->stream.decoder = ucs_2le_decoder; - } else { - stream->stream.format = @':ucs-2be'; - stream->stream.encoder = ucs_2be_encoder; - stream->stream.decoder = ucs_2be_decoder; - } - break; - case ECL_STREAM_UCS_4: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8*4; - stream->stream.format = @':ucs-4be'; - stream->stream.encoder = ucs_4_encoder; - stream->stream.decoder = ucs_4_decoder; - break; - case ECL_STREAM_UCS_4BE: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8*4; - if (flags & ECL_STREAM_LITTLE_ENDIAN) { - stream->stream.format = @':ucs-4le'; - stream->stream.encoder = ucs_4le_encoder; - stream->stream.decoder = ucs_4le_decoder; - } else { - stream->stream.format = @':ucs-4be'; - stream->stream.encoder = ucs_4be_encoder; - stream->stream.decoder = ucs_4be_decoder; - } - break; - case ECL_STREAM_USER_FORMAT: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8; - stream->stream.format = stream->stream.format_table; - if (CONSP(stream->stream.format)) { - stream->stream.encoder = user_multistate_encoder; - stream->stream.decoder = user_multistate_decoder; - } else { - stream->stream.encoder = user_encoder; - stream->stream.decoder = user_decoder; - } - break; - case ECL_STREAM_US_ASCII: - IO_STREAM_ELT_TYPE(stream) = @'base-char'; - byte_size = 8; - stream->stream.format = @':us-ascii'; - stream->stream.encoder = ascii_encoder; - stream->stream.decoder = ascii_decoder; - break; + /*case ECL_ISO_8859_1:*/ + case ECL_STREAM_LATIN_1: + IO_STREAM_ELT_TYPE(stream) = @'base-char'; + byte_size = 8; + stream->stream.format = @':latin-1'; + stream->stream.encoder = passthrough_encoder; + stream->stream.decoder = passthrough_decoder; + break; + case ECL_STREAM_UTF_8: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8; + stream->stream.format = @':utf-8'; + stream->stream.encoder = utf_8_encoder; + stream->stream.decoder = utf_8_decoder; + break; + case ECL_STREAM_UCS_2: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8*2; + stream->stream.format = @':ucs-2'; + stream->stream.encoder = ucs_2_encoder; + stream->stream.decoder = ucs_2_decoder; + break; + case ECL_STREAM_UCS_2BE: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8*2; + if (flags & ECL_STREAM_LITTLE_ENDIAN) { + stream->stream.format = @':ucs-2le'; + stream->stream.encoder = ucs_2le_encoder; + stream->stream.decoder = ucs_2le_decoder; + } else { + stream->stream.format = @':ucs-2be'; + stream->stream.encoder = ucs_2be_encoder; + stream->stream.decoder = ucs_2be_decoder; + } + break; + case ECL_STREAM_UCS_4: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8*4; + stream->stream.format = @':ucs-4be'; + stream->stream.encoder = ucs_4_encoder; + stream->stream.decoder = ucs_4_decoder; + break; + case ECL_STREAM_UCS_4BE: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8*4; + if (flags & ECL_STREAM_LITTLE_ENDIAN) { + stream->stream.format = @':ucs-4le'; + stream->stream.encoder = ucs_4le_encoder; + stream->stream.decoder = ucs_4le_decoder; + } else { + stream->stream.format = @':ucs-4be'; + stream->stream.encoder = ucs_4be_encoder; + stream->stream.decoder = ucs_4be_decoder; + } + break; + case ECL_STREAM_USER_FORMAT: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8; + stream->stream.format = stream->stream.format_table; + if (CONSP(stream->stream.format)) { + stream->stream.encoder = user_multistate_encoder; + stream->stream.decoder = user_multistate_decoder; + } else { + stream->stream.encoder = user_encoder; + stream->stream.decoder = user_decoder; + } + break; + case ECL_STREAM_US_ASCII: + IO_STREAM_ELT_TYPE(stream) = @'base-char'; + byte_size = 8; + stream->stream.format = @':us-ascii'; + stream->stream.encoder = ascii_encoder; + stream->stream.decoder = ascii_decoder; + break; #else - case ECL_STREAM_DEFAULT_FORMAT: - IO_STREAM_ELT_TYPE(stream) = @'base-char'; - byte_size = 8; - stream->stream.format = @':pass-through'; - stream->stream.encoder = passthrough_encoder; - stream->stream.decoder = passthrough_decoder; - break; + case ECL_STREAM_DEFAULT_FORMAT: + IO_STREAM_ELT_TYPE(stream) = @'base-char'; + byte_size = 8; + stream->stream.format = @':pass-through'; + stream->stream.encoder = passthrough_encoder; + stream->stream.decoder = passthrough_decoder; + break; #endif - default: - FEerror("Invalid or unsupported external format ~A with code ~D", - 2, external_format, ecl_make_fixnum(flags)); - } - t = @':LF'; - if (stream->stream.ops->write_char == eformat_write_char && - (flags & ECL_STREAM_CR)) { - if (flags & ECL_STREAM_LF) { - stream->stream.ops->read_char = eformat_read_char_crlf; - stream->stream.ops->write_char = eformat_write_char_crlf; - t = @':CRLF'; - } else { - stream->stream.ops->read_char = eformat_read_char_cr; - stream->stream.ops->write_char = eformat_write_char_cr; - t = @':CR'; - } - } - stream->stream.format = cl_list(2, stream->stream.format, t); - { - cl_object (*read_byte)(cl_object); - void (*write_byte)(cl_object,cl_object); - byte_size = (byte_size+7)&(~(cl_fixnum)7); - if (byte_size == 8) { - if (flags & ECL_STREAM_SIGNED_BYTES) { - read_byte = generic_read_byte_signed8; - write_byte = generic_write_byte_signed8; - } else { - read_byte = generic_read_byte_unsigned8; - write_byte = generic_write_byte_unsigned8; - } - } else if (flags & ECL_STREAM_LITTLE_ENDIAN) { - read_byte = generic_read_byte_le; - write_byte = generic_write_byte_le; - } else { - read_byte = generic_read_byte; - write_byte = generic_write_byte; - } - if (ecl_input_stream_p(stream)) { - stream->stream.ops->read_byte = read_byte; - } - if (ecl_output_stream_p(stream)) { - stream->stream.ops->write_byte = write_byte; - } - } - stream->stream.flags = flags; - stream->stream.byte_size = byte_size; + default: + FEerror("Invalid or unsupported external format ~A with code ~D", + 2, external_format, ecl_make_fixnum(flags)); + } + t = @':LF'; + if (stream->stream.ops->write_char == eformat_write_char && + (flags & ECL_STREAM_CR)) { + if (flags & ECL_STREAM_LF) { + stream->stream.ops->read_char = eformat_read_char_crlf; + stream->stream.ops->write_char = eformat_write_char_crlf; + t = @':CRLF'; + } else { + stream->stream.ops->read_char = eformat_read_char_cr; + stream->stream.ops->write_char = eformat_write_char_cr; + t = @':CR'; + } + } + stream->stream.format = cl_list(2, stream->stream.format, t); + { + cl_object (*read_byte)(cl_object); + void (*write_byte)(cl_object,cl_object); + byte_size = (byte_size+7)&(~(cl_fixnum)7); + if (byte_size == 8) { + if (flags & ECL_STREAM_SIGNED_BYTES) { + read_byte = generic_read_byte_signed8; + write_byte = generic_write_byte_signed8; + } else { + read_byte = generic_read_byte_unsigned8; + write_byte = generic_write_byte_unsigned8; + } + } else if (flags & ECL_STREAM_LITTLE_ENDIAN) { + read_byte = generic_read_byte_le; + write_byte = generic_write_byte_le; + } else { + read_byte = generic_read_byte; + write_byte = generic_write_byte; + } + if (ecl_input_stream_p(stream)) { + stream->stream.ops->read_byte = read_byte; + } + if (ecl_output_stream_p(stream)) { + stream->stream.ops->write_byte = write_byte; + } + } + stream->stream.flags = flags; + stream->stream.byte_size = byte_size; } cl_object si_stream_external_format_set(cl_object stream, cl_object format) { #ifdef ECL_CLOS_STREAMS - unlikely_if (ECL_INSTANCEP(stream)) { - FEerror("Cannot change external format of stream ~A", 1, stream); - } + unlikely_if (ECL_INSTANCEP(stream)) { + FEerror("Cannot change external format of stream ~A", 1, stream); + } #endif - switch (stream->stream.mode) { - case ecl_smm_input: - case ecl_smm_input_file: - case ecl_smm_output: - case ecl_smm_output_file: - case ecl_smm_io: - case ecl_smm_io_file: + switch (stream->stream.mode) { + case ecl_smm_input: + case ecl_smm_input_file: + case ecl_smm_output: + case ecl_smm_output_file: + case ecl_smm_io: + case ecl_smm_io_file: #ifdef ECL_WSOCK - case ecl_smm_input_wsock: - case ecl_smm_output_wsock: - case ecl_smm_io_wsock: - case ecl_smm_io_wcon: + case ecl_smm_input_wsock: + case ecl_smm_output_wsock: + case ecl_smm_io_wsock: + case ecl_smm_io_wcon: #endif - { - cl_object elt_type = ecl_stream_element_type(stream); - unlikely_if (elt_type != @'character' && - elt_type != @'base-char') - FEerror("Cannot change external format" - "of binary stream ~A", 1, stream); - set_stream_elt_type(stream, stream->stream.byte_size, - stream->stream.flags, format); - } - break; - default: - FEerror("Cannot change external format of stream ~A", 1, stream); - } - @(return) + { + cl_object elt_type = ecl_stream_element_type(stream); + unlikely_if (elt_type != @'character' && + elt_type != @'base-char') + FEerror("Cannot change external format" + "of binary stream ~A", 1, stream); + set_stream_elt_type(stream, stream->stream.byte_size, + stream->stream.flags, format); + } + break; + default: + FEerror("Cannot change external format of stream ~A", 1, stream); + } + @(return); } cl_object ecl_make_file_stream_from_fd(cl_object fname, int fd, enum ecl_smmode smm, cl_fixnum byte_size, int flags, cl_object external_format) { - cl_object stream = alloc_stream(); - switch(smm) { - case ecl_smm_input: - smm = ecl_smm_input_file; - case ecl_smm_input_file: - case ecl_smm_probe: - stream->stream.ops = duplicate_dispatch_table(&input_file_ops); - break; - case ecl_smm_output: - smm = ecl_smm_output_file; - case ecl_smm_output_file: - stream->stream.ops = duplicate_dispatch_table(&output_file_ops); - break; - case ecl_smm_io: - smm = ecl_smm_io_file; - case ecl_smm_io_file: - stream->stream.ops = duplicate_dispatch_table(&io_file_ops); - break; - default: - FEerror("make_stream: wrong mode", 0); - } - stream->stream.mode = (short)smm; - stream->stream.closed = 0; - set_stream_elt_type(stream, byte_size, flags, external_format); - IO_FILE_FILENAME(stream) = fname; /* not really used */ - stream->stream.column = 0; - IO_FILE_DESCRIPTOR(stream) = fd; - stream->stream.last_op = 0; - si_set_finalizer(stream, ECL_T); - return stream; + cl_object stream = alloc_stream(); + switch(smm) { + case ecl_smm_input: + smm = ecl_smm_input_file; + case ecl_smm_input_file: + case ecl_smm_probe: + stream->stream.ops = duplicate_dispatch_table(&input_file_ops); + break; + case ecl_smm_output: + smm = ecl_smm_output_file; + case ecl_smm_output_file: + stream->stream.ops = duplicate_dispatch_table(&output_file_ops); + break; + case ecl_smm_io: + smm = ecl_smm_io_file; + case ecl_smm_io_file: + stream->stream.ops = duplicate_dispatch_table(&io_file_ops); + break; + default: + FEerror("make_stream: wrong mode", 0); + } + stream->stream.mode = (short)smm; + stream->stream.closed = 0; + set_stream_elt_type(stream, byte_size, flags, external_format); + IO_FILE_FILENAME(stream) = fname; /* not really used */ + stream->stream.column = 0; + IO_FILE_DESCRIPTOR(stream) = fd; + stream->stream.last_op = 0; + si_set_finalizer(stream, ECL_T); + return stream; } /********************************************************************** @@ -3324,58 +3319,58 @@ ecl_make_file_stream_from_fd(cl_object fname, int fd, enum ecl_smmode smm, static cl_index input_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return consume_byte_stack(strm, c, n); - } else { - FILE *f = IO_STREAM_FILE(strm); - cl_fixnum out = 0; - ecl_disable_interrupts(); + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return consume_byte_stack(strm, c, n); + } else { + FILE *f = IO_STREAM_FILE(strm); + cl_fixnum out = 0; + ecl_disable_interrupts(); #ifdef FILE_CNT - do { - out = fread(c, sizeof(char), n, f); - } while (out < n && ferror(f) && restartable_io_error(strm, "fread")); + do { + out = fread(c, sizeof(char), n, f); + } while (out < n && ferror(f) && restartable_io_error(strm, "fread")); #else - /* We can't use fread here due to the buffering. It makes - impossible checking if we have some data available in the - buffer what renders listen returning incorrect result. */ - do { - out = read(fileno(f), c, sizeof(char)*n); - } while (out < 0 && restartable_io_error(strm, "read")); + /* We can't use fread here due to the buffering. It makes + impossible checking if we have some data available in the + buffer what renders listen returning incorrect result. */ + do { + out = read(fileno(f), c, sizeof(char)*n); + } while (out < 0 && restartable_io_error(strm, "read")); #endif - ecl_enable_interrupts(); - return out; - } + ecl_enable_interrupts(); + return out; + } } static cl_index output_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index out; - ecl_disable_interrupts(); - do { - out = fwrite(c, sizeof(char), n, IO_STREAM_FILE(strm)); - } while (out < n && restartable_io_error(strm, "fwrite")); - ecl_enable_interrupts(); - return out; + cl_index out; + ecl_disable_interrupts(); + do { + out = fwrite(c, sizeof(char), n, IO_STREAM_FILE(strm)); + } while (out < n && restartable_io_error(strm, "fwrite")); + ecl_enable_interrupts(); + return out; } static cl_index io_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - /* When using the same stream for input and output operations, we have to - * use some file position operation before reading again. Besides this, if - * there were unread octets, we have to move to the position at the - * begining of them. - */ - if (strm->stream.byte_stack != ECL_NIL) { - cl_object aux = ecl_file_position(strm); - if (!Null(aux)) - ecl_file_position_set(strm, aux); - } else if (strm->stream.last_op > 0) { - ecl_fseeko(IO_STREAM_FILE(strm), 0, SEEK_CUR); - } - strm->stream.last_op = -1; - return output_stream_write_byte8(strm, c, n); + /* When using the same stream for input and output operations, we have to + * use some file position operation before reading again. Besides this, if + * there were unread octets, we have to move to the position at the + * begining of them. + */ + if (strm->stream.byte_stack != ECL_NIL) { + cl_object aux = ecl_file_position(strm); + if (!Null(aux)) + ecl_file_position_set(strm, aux); + } else if (strm->stream.last_op > 0) { + ecl_fseeko(IO_STREAM_FILE(strm), 0, SEEK_CUR); + } + strm->stream.last_op = -1; + return output_stream_write_byte8(strm, c, n); } static void io_stream_force_output(cl_object strm); @@ -3383,42 +3378,42 @@ static void io_stream_force_output(cl_object strm); static cl_index io_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - /* When using the same stream for input and output operations, we have to - * flush the stream before reading. - */ - if (strm->stream.last_op < 0) { - io_stream_force_output(strm); - } - strm->stream.last_op = +1; - return input_stream_read_byte8(strm, c, n); + /* When using the same stream for input and output operations, we have to + * flush the stream before reading. + */ + if (strm->stream.last_op < 0) { + io_stream_force_output(strm); + } + strm->stream.last_op = +1; + return input_stream_read_byte8(strm, c, n); } static int io_stream_listen(cl_object strm) { - if (strm->stream.byte_stack != ECL_NIL) - return ECL_LISTEN_AVAILABLE; - return flisten(strm, IO_STREAM_FILE(strm)); + if (strm->stream.byte_stack != ECL_NIL) + return ECL_LISTEN_AVAILABLE; + return flisten(strm, IO_STREAM_FILE(strm)); } static void io_stream_clear_input(cl_object strm) { - FILE *fp = IO_STREAM_FILE(strm); + FILE *fp = IO_STREAM_FILE(strm); #if defined(ECL_MS_WINDOWS_HOST) - int f = fileno(fp); - if (isatty(f)) { - /* Flushes Win32 console */ - unlikely_if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(f))) - FEwin32_error("FlushConsoleInputBuffer() failed", 0); - /* Do not stop here: the FILE structure needs also to be flushed */ - } + int f = fileno(fp); + if (isatty(f)) { + /* Flushes Win32 console */ + unlikely_if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(f))) + FEwin32_error("FlushConsoleInputBuffer() failed", 0); + /* Do not stop here: the FILE structure needs also to be flushed */ + } #endif - while (flisten(strm, fp) == ECL_LISTEN_AVAILABLE) { - ecl_disable_interrupts(); - getc(fp); - ecl_enable_interrupts(); - } + while (flisten(strm, fp) == ECL_LISTEN_AVAILABLE) { + ecl_disable_interrupts(); + getc(fp); + ecl_enable_interrupts(); + } } #define io_stream_clear_output generic_void @@ -3426,11 +3421,11 @@ io_stream_clear_input(cl_object strm) static void io_stream_force_output(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - ecl_disable_interrupts(); - while ((fflush(f) == EOF) && restartable_io_error(strm, "fflush")) - (void)0; - ecl_enable_interrupts(); + FILE *f = IO_STREAM_FILE(strm); + ecl_disable_interrupts(); + while ((fflush(f) == EOF) && restartable_io_error(strm, "fflush")) + (void)0; + ecl_enable_interrupts(); } #define io_stream_finish_output io_stream_force_output @@ -3438,109 +3433,109 @@ io_stream_force_output(cl_object strm) static int io_stream_interactive_p(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - return isatty(fileno(f)); + FILE *f = IO_STREAM_FILE(strm); + return isatty(fileno(f)); } static cl_object io_stream_length(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - cl_object output = ecl_file_len(fileno(f)); - if (strm->stream.byte_size != 8) { - const cl_env_ptr the_env = ecl_process_env(); - cl_index bs = strm->stream.byte_size; - output = ecl_floor2(output, ecl_make_fixnum(bs/8)); - unlikely_if (ecl_nth_value(the_env, 1) != ecl_make_fixnum(0)) { - FEerror("File length is not on byte boundary", 0); - } - } - return output; + FILE *f = IO_STREAM_FILE(strm); + cl_object output = ecl_file_len(fileno(f)); + if (strm->stream.byte_size != 8) { + const cl_env_ptr the_env = ecl_process_env(); + cl_index bs = strm->stream.byte_size; + output = ecl_floor2(output, ecl_make_fixnum(bs/8)); + unlikely_if (ecl_nth_value(the_env, 1) != ecl_make_fixnum(0)) { + FEerror("File length is not on byte boundary", 0); + } + } + return output; } static cl_object io_stream_get_position(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - cl_object output; - ecl_off_t offset; + FILE *f = IO_STREAM_FILE(strm); + cl_object output; + ecl_off_t offset; - ecl_disable_interrupts(); - offset = ecl_ftello(f); - ecl_enable_interrupts(); - if (offset < 0) - io_error(strm); - if (sizeof(ecl_off_t) == sizeof(long)) { - output = ecl_make_integer(offset); - } else { - output = ecl_off_t_to_integer(offset); - } - { - /* If there are unread octets, we return the position at which - * these bytes begin! */ - cl_object l = strm->stream.byte_stack; - while (CONSP(l)) { - output = ecl_one_minus(output); - l = ECL_CONS_CDR(l); - } - } - if (strm->stream.byte_size != 8) { - output = ecl_floor2(output, ecl_make_fixnum(strm->stream.byte_size / 8)); - } - return output; + ecl_disable_interrupts(); + offset = ecl_ftello(f); + ecl_enable_interrupts(); + if (offset < 0) + io_error(strm); + if (sizeof(ecl_off_t) == sizeof(long)) { + output = ecl_make_integer(offset); + } else { + output = ecl_off_t_to_integer(offset); + } + { + /* If there are unread octets, we return the position at which + * these bytes begin! */ + cl_object l = strm->stream.byte_stack; + while (CONSP(l)) { + output = ecl_one_minus(output); + l = ECL_CONS_CDR(l); + } + } + if (strm->stream.byte_size != 8) { + output = ecl_floor2(output, ecl_make_fixnum(strm->stream.byte_size / 8)); + } + return output; } static cl_object io_stream_set_position(cl_object strm, cl_object large_disp) { - FILE *f = IO_STREAM_FILE(strm); - ecl_off_t disp; - int mode; - if (Null(large_disp)) { - disp = 0; - mode = SEEK_END; - } else { - if (strm->stream.byte_size != 8) { - large_disp = ecl_times(large_disp, - ecl_make_fixnum(strm->stream.byte_size / 8)); - } - disp = ecl_integer_to_off_t(large_disp); - mode = SEEK_SET; - } - ecl_disable_interrupts(); - mode = ecl_fseeko(f, disp, mode); - ecl_enable_interrupts(); - return mode? ECL_NIL : ECL_T; + FILE *f = IO_STREAM_FILE(strm); + ecl_off_t disp; + int mode; + if (Null(large_disp)) { + disp = 0; + mode = SEEK_END; + } else { + if (strm->stream.byte_size != 8) { + large_disp = ecl_times(large_disp, + ecl_make_fixnum(strm->stream.byte_size / 8)); + } + disp = ecl_integer_to_off_t(large_disp); + mode = SEEK_SET; + } + ecl_disable_interrupts(); + mode = ecl_fseeko(f, disp, mode); + ecl_enable_interrupts(); + return mode? ECL_NIL : ECL_T; } static int io_stream_column(cl_object strm) { - return strm->stream.column; + return strm->stream.column; } static cl_object io_stream_close(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - int failed; - unlikely_if (f == stdout) - FEerror("Cannot close the standard output", 0); - unlikely_if (f == stdin) - FEerror("Cannot close the standard input", 0); - unlikely_if (f == NULL) - wrong_file_handler(strm); - if (ecl_output_stream_p(strm)) { - ecl_force_output(strm); - } - failed = safe_fclose(f); - unlikely_if (failed) - cannot_close(strm); + FILE *f = IO_STREAM_FILE(strm); + int failed; + unlikely_if (f == stdout) + FEerror("Cannot close the standard output", 0); + unlikely_if (f == stdin) + FEerror("Cannot close the standard input", 0); + unlikely_if (f == NULL) + wrong_file_handler(strm); + if (ecl_output_stream_p(strm)) { + ecl_force_output(strm); + } + failed = safe_fclose(f); + unlikely_if (failed) + cannot_close(strm); #if !defined(GBC_BOEHM) - ecl_dealloc(strm->stream.buffer); - IO_STREAM_FILE(strm) = NULL; + ecl_dealloc(strm->stream.buffer); + IO_STREAM_FILE(strm) = NULL; #endif - return generic_close(strm); + return generic_close(strm); } /* @@ -3551,102 +3546,102 @@ io_stream_close(cl_object strm) #define io_stream_write_vector io_file_write_vector const struct ecl_file_ops io_stream_ops = { - io_stream_write_byte8, - io_stream_read_byte8, + io_stream_write_byte8, + io_stream_read_byte8, - generic_write_byte, - generic_read_byte, + generic_write_byte, + generic_read_byte, - eformat_read_char, - eformat_write_char, - eformat_unread_char, - generic_peek_char, + eformat_read_char, + eformat_write_char, + eformat_unread_char, + generic_peek_char, - io_file_read_vector, - io_file_write_vector, + io_file_read_vector, + io_file_write_vector, - io_stream_listen, - io_stream_clear_input, - io_stream_clear_output, - io_stream_finish_output, - io_stream_force_output, + io_stream_listen, + io_stream_clear_input, + io_stream_clear_output, + io_stream_finish_output, + io_stream_force_output, - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - io_stream_interactive_p, - io_file_element_type, + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + io_stream_interactive_p, + io_file_element_type, - io_stream_length, - io_stream_get_position, - io_stream_set_position, - io_stream_column, - io_stream_close + io_stream_length, + io_stream_get_position, + io_stream_set_position, + io_stream_column, + io_stream_close }; const struct ecl_file_ops output_stream_ops = { - output_stream_write_byte8, - not_input_read_byte8, + output_stream_write_byte8, + not_input_read_byte8, - generic_write_byte, - not_input_read_byte, + generic_write_byte, + not_input_read_byte, - not_input_read_char, - eformat_write_char, - not_input_unread_char, - not_input_read_char, + not_input_read_char, + eformat_write_char, + not_input_unread_char, + not_input_read_char, - generic_read_vector, - io_file_write_vector, + generic_read_vector, + io_file_write_vector, - not_input_listen, - generic_void, - io_stream_clear_output, - io_stream_finish_output, - io_stream_force_output, + not_input_listen, + generic_void, + io_stream_clear_output, + io_stream_finish_output, + io_stream_force_output, - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - io_file_element_type, + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + io_file_element_type, - io_stream_length, - io_stream_get_position, - io_stream_set_position, - io_stream_column, - io_stream_close + io_stream_length, + io_stream_get_position, + io_stream_set_position, + io_stream_column, + io_stream_close }; const struct ecl_file_ops input_stream_ops = { - not_output_write_byte8, - input_stream_read_byte8, + not_output_write_byte8, + input_stream_read_byte8, - not_output_write_byte, - generic_read_byte, + not_output_write_byte, + generic_read_byte, - eformat_read_char, - not_output_write_char, - eformat_unread_char, - generic_peek_char, + eformat_read_char, + not_output_write_char, + eformat_unread_char, + generic_peek_char, - io_file_read_vector, - generic_write_vector, + io_file_read_vector, + generic_write_vector, - io_stream_listen, - io_stream_clear_input, - generic_void, - generic_void, - generic_void, + io_stream_listen, + io_stream_clear_input, + generic_void, + generic_void, + generic_void, - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - io_stream_interactive_p, - io_file_element_type, + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + io_stream_interactive_p, + io_file_element_type, - io_stream_length, - io_stream_get_position, - io_stream_set_position, - generic_column, - io_stream_close + io_stream_length, + io_stream_get_position, + io_stream_set_position, + generic_column, + io_stream_close }; /********************************************************************** @@ -3660,206 +3655,206 @@ const struct ecl_file_ops input_stream_ops = { static cl_index winsock_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index len = 0; + cl_index len = 0; - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return consume_byte_stack(strm, c, n); - } - if(n > 0) { - SOCKET s = (SOCKET)IO_FILE_DESCRIPTOR(strm); - unlikely_if (INVALID_SOCKET == s) { - wrong_file_handler(strm); - } else { - ecl_disable_interrupts(); - len = recv(s, c, n, 0); - unlikely_if (len == SOCKET_ERROR) - wsock_error("Cannot read bytes from Windows " - "socket ~S.~%~A", strm); - ecl_enable_interrupts(); - } - } - return (len > 0) ? len : EOF; + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return consume_byte_stack(strm, c, n); + } + if(n > 0) { + SOCKET s = (SOCKET)IO_FILE_DESCRIPTOR(strm); + unlikely_if (INVALID_SOCKET == s) { + wrong_file_handler(strm); + } else { + ecl_disable_interrupts(); + len = recv(s, c, n, 0); + unlikely_if (len == SOCKET_ERROR) + wsock_error("Cannot read bytes from Windows " + "socket ~S.~%~A", strm); + ecl_enable_interrupts(); + } + } + return (len > 0) ? len : EOF; } static cl_index winsock_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index out = 0; - unsigned char *endp; - unsigned char *p; - SOCKET s = (SOCKET)IO_FILE_DESCRIPTOR(strm); - unlikely_if (INVALID_SOCKET == s) { - wrong_file_handler(strm); - } else { - ecl_disable_interrupts(); - do { - cl_index res = send(s, c + out, n, 0); - unlikely_if (res == SOCKET_ERROR) { - wsock_error("Cannot write bytes to Windows" - " socket ~S.~%~A", strm); - break; /* stop writing */ - } else { - out += res; - n -= res; - } - } while (n > 0); - ecl_enable_interrupts(); - } - return out; + cl_index out = 0; + unsigned char *endp; + unsigned char *p; + SOCKET s = (SOCKET)IO_FILE_DESCRIPTOR(strm); + unlikely_if (INVALID_SOCKET == s) { + wrong_file_handler(strm); + } else { + ecl_disable_interrupts(); + do { + cl_index res = send(s, c + out, n, 0); + unlikely_if (res == SOCKET_ERROR) { + wsock_error("Cannot write bytes to Windows" + " socket ~S.~%~A", strm); + break; /* stop writing */ + } else { + out += res; + n -= res; + } + } while (n > 0); + ecl_enable_interrupts(); + } + return out; } static int winsock_stream_listen(cl_object strm) { - SOCKET s; - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return ECL_LISTEN_AVAILABLE; - } - s = (SOCKET)IO_FILE_DESCRIPTOR(strm); - unlikely_if (INVALID_SOCKET == s) { - wrong_file_handler(strm); - } - { - struct timeval tv = { 0, 0 }; - fd_set fds; - cl_index result; + SOCKET s; + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return ECL_LISTEN_AVAILABLE; + } + s = (SOCKET)IO_FILE_DESCRIPTOR(strm); + unlikely_if (INVALID_SOCKET == s) { + wrong_file_handler(strm); + } + { + struct timeval tv = { 0, 0 }; + fd_set fds; + cl_index result; - FD_ZERO( &fds ); - FD_SET(s, &fds); - ecl_disable_interrupts(); - result = select( 0, &fds, NULL, NULL, &tv ); - unlikely_if (result == SOCKET_ERROR) - wsock_error("Cannot listen on Windows " - "socket ~S.~%~A", strm ); - ecl_enable_interrupts(); - return ( result > 0 - ? ECL_LISTEN_AVAILABLE - : ECL_LISTEN_NO_CHAR ); - } + FD_ZERO( &fds ); + FD_SET(s, &fds); + ecl_disable_interrupts(); + result = select( 0, &fds, NULL, NULL, &tv ); + unlikely_if (result == SOCKET_ERROR) + wsock_error("Cannot listen on Windows " + "socket ~S.~%~A", strm ); + ecl_enable_interrupts(); + return ( result > 0 + ? ECL_LISTEN_AVAILABLE + : ECL_LISTEN_NO_CHAR ); + } } static void winsock_stream_clear_input(cl_object strm) { - while (winsock_stream_listen(strm) == ECL_LISTEN_AVAILABLE) { - eformat_read_char(strm); - } + while (winsock_stream_listen(strm) == ECL_LISTEN_AVAILABLE) { + eformat_read_char(strm); + } } static cl_object winsock_stream_close(cl_object strm) { - SOCKET s = (SOCKET) IO_FILE_DESCRIPTOR(strm); - int failed; - ecl_disable_interrupts(); - failed = closesocket(s); - ecl_enable_interrupts(); - unlikely_if (failed < 0) - cannot_close(strm); - IO_FILE_DESCRIPTOR(strm) = (int)INVALID_SOCKET; - return generic_close(strm); + SOCKET s = (SOCKET) IO_FILE_DESCRIPTOR(strm); + int failed; + ecl_disable_interrupts(); + failed = closesocket(s); + ecl_enable_interrupts(); + unlikely_if (failed < 0) + cannot_close(strm); + IO_FILE_DESCRIPTOR(strm) = (int)INVALID_SOCKET; + return generic_close(strm); } const struct ecl_file_ops winsock_stream_io_ops = { - winsock_stream_write_byte8, - winsock_stream_read_byte8, + winsock_stream_write_byte8, + winsock_stream_read_byte8, - generic_write_byte, - generic_read_byte, + generic_write_byte, + generic_read_byte, - eformat_read_char, - eformat_write_char, - eformat_unread_char, - generic_peek_char, + eformat_read_char, + eformat_write_char, + eformat_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - winsock_stream_listen, - winsock_stream_clear_input, - generic_void, - generic_void, - generic_void, + winsock_stream_listen, + winsock_stream_clear_input, + generic_void, + generic_void, + generic_void, - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - winsock_stream_element_type, + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + winsock_stream_element_type, - not_a_file_stream, - not_implemented_get_position, - not_implemented_set_position, - generic_column, + not_a_file_stream, + not_implemented_get_position, + not_implemented_set_position, + generic_column, - winsock_stream_close + winsock_stream_close }; const struct ecl_file_ops winsock_stream_output_ops = { - winsock_stream_write_byte8, - not_input_read_byte8, + winsock_stream_write_byte8, + not_input_read_byte8, - generic_write_byte, - not_input_read_byte, + generic_write_byte, + not_input_read_byte, - not_input_read_char, - eformat_write_char, - not_input_unread_char, - generic_peek_char, + not_input_read_char, + eformat_write_char, + not_input_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - not_input_listen, - not_input_clear_input, - generic_void, - generic_void, - generic_void, + not_input_listen, + not_input_clear_input, + generic_void, + generic_void, + generic_void, - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - winsock_stream_element_type, + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + winsock_stream_element_type, - not_a_file_stream, - not_implemented_get_position, - not_implemented_set_position, - generic_column, + not_a_file_stream, + not_implemented_get_position, + not_implemented_set_position, + generic_column, - winsock_stream_close + winsock_stream_close }; const struct ecl_file_ops winsock_stream_input_ops = { - not_output_write_byte8, - winsock_stream_read_byte8, + not_output_write_byte8, + winsock_stream_read_byte8, - not_output_write_byte, - generic_read_byte, + not_output_write_byte, + generic_read_byte, - eformat_read_char, - not_output_write_char, - eformat_unread_char, - generic_peek_char, + eformat_read_char, + not_output_write_char, + eformat_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - winsock_stream_listen, - winsock_stream_clear_input, - not_output_clear_output, - not_output_finish_output, - not_output_force_output, + winsock_stream_listen, + winsock_stream_clear_input, + not_output_clear_output, + not_output_finish_output, + not_output_force_output, - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - generic_always_false, - winsock_stream_element_type, + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + generic_always_false, + winsock_stream_element_type, - not_a_file_stream, - not_implemented_get_position, - not_implemented_set_position, - generic_column, + not_a_file_stream, + not_implemented_get_position, + not_implemented_set_position, + generic_column, - winsock_stream_close + winsock_stream_close }; #endif @@ -3874,110 +3869,110 @@ const struct ecl_file_ops winsock_stream_input_ops = { static cl_index wcon_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return consume_byte_stack(strm, c, n); + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return consume_byte_stack(strm, c, n); + } else { + cl_index len = 0; + cl_env_ptr the_env = ecl_process_env(); + HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); + DWORD nchars; + unsigned char aux[4]; + for (len = 0; len < n; ) { + int i, ok; + ecl_disable_interrupts_env(the_env); + ok = ReadConsole(h, &aux, 1, &nchars, NULL); + ecl_enable_interrupts_env(the_env); + unlikely_if (!ok) { + FEwin32_error("Cannot read from console", 0); + } + for (i = 0; i < nchars; i++) { + if (len < n) { + c[len++] = aux[i]; } else { - cl_index len = 0; - cl_env_ptr the_env = ecl_process_env(); - HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); - DWORD nchars; - unsigned char aux[4]; - for (len = 0; len < n; ) { - int i, ok; - ecl_disable_interrupts_env(the_env); - ok = ReadConsole(h, &aux, 1, &nchars, NULL); - ecl_enable_interrupts_env(the_env); - unlikely_if (!ok) { - FEwin32_error("Cannot read from console", 0); - } - for (i = 0; i < nchars; i++) { - if (len < n) { - c[len++] = aux[i]; - } else { - strm->stream.byte_stack = - ecl_nconc(strm->stream.byte_stack, - ecl_list1(ecl_make_fixnum(aux[i]))); - } - } - } - return (len > 0) ? len : EOF; + strm->stream.byte_stack = + ecl_nconc(strm->stream.byte_stack, + ecl_list1(ecl_make_fixnum(aux[i]))); } + } + } + return (len > 0) ? len : EOF; + } } static cl_index wcon_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); - DWORD nchars; - unlikely_if(!WriteConsole(h, c, n, &nchars, NULL)) { - FEwin32_error("Cannot write to console.", 0); - } - return nchars; + HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); + DWORD nchars; + unlikely_if(!WriteConsole(h, c, n, &nchars, NULL)) { + FEwin32_error("Cannot write to console.", 0); + } + return nchars; } static int wcon_stream_listen(cl_object strm) { - HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); - INPUT_RECORD aux; - DWORD nevents; - do { - unlikely_if(!PeekConsoleInput(h, &aux, 1, &nevents)) - FEwin32_error("Cannot read from console.", 0); - if (nevents == 0) - return 0; - if (aux.EventType == KEY_EVENT) - return 1; - unlikely_if(!ReadConsoleInput(h, &aux, 1, &nevents)) - FEwin32_error("Cannot read from console.", 0); - } while (1); + HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); + INPUT_RECORD aux; + DWORD nevents; + do { + unlikely_if(!PeekConsoleInput(h, &aux, 1, &nevents)) + FEwin32_error("Cannot read from console.", 0); + if (nevents == 0) + return 0; + if (aux.EventType == KEY_EVENT) + return 1; + unlikely_if(!ReadConsoleInput(h, &aux, 1, &nevents)) + FEwin32_error("Cannot read from console.", 0); + } while (1); } static void wcon_stream_clear_input(cl_object strm) { - FlushConsoleInputBuffer((HANDLE)IO_FILE_DESCRIPTOR(strm)); + FlushConsoleInputBuffer((HANDLE)IO_FILE_DESCRIPTOR(strm)); } static void wcon_stream_force_output(cl_object strm) { - DWORD nchars; - WriteConsole((HANDLE)IO_FILE_DESCRIPTOR(strm), 0, 0, &nchars, NULL); + DWORD nchars; + WriteConsole((HANDLE)IO_FILE_DESCRIPTOR(strm), 0, 0, &nchars, NULL); } const struct ecl_file_ops wcon_stream_io_ops = { - wcon_stream_write_byte8, - wcon_stream_read_byte8, + wcon_stream_write_byte8, + wcon_stream_read_byte8, - generic_write_byte, - generic_read_byte, + generic_write_byte, + generic_read_byte, - eformat_read_char, - eformat_write_char, - eformat_unread_char, - generic_peek_char, + eformat_read_char, + eformat_write_char, + eformat_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - wcon_stream_listen, - wcon_stream_clear_input, - generic_void, - wcon_stream_force_output, - wcon_stream_force_output, + wcon_stream_listen, + wcon_stream_clear_input, + generic_void, + wcon_stream_force_output, + wcon_stream_force_output, - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - wcon_stream_element_type, + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + wcon_stream_element_type, - not_a_file_stream, - not_implemented_get_position, - not_implemented_set_position, - generic_column, + not_a_file_stream, + not_implemented_get_position, + not_implemented_set_position, + generic_column, - generic_close, + generic_close, }; #define CONTROL_Z 26 @@ -3987,22 +3982,22 @@ maybe_make_windows_console_FILE(cl_object fname, FILE *f, enum ecl_smmode smm, cl_fixnum byte_size, int flags, cl_object external_format) { - int desc = fileno(f); - cl_object output; - if (isatty(desc)) { - output = ecl_make_stream_from_FILE - (fname, - (void*)_get_osfhandle(desc), - ecl_smm_io_wcon, - byte_size, flags, - external_format); - output->stream.eof_char = CONTROL_Z; - } else { - output = ecl_make_stream_from_FILE - (fname, f, smm, byte_size, flags, - external_format); - } - return output; + int desc = fileno(f); + cl_object output; + if (isatty(desc)) { + output = ecl_make_stream_from_FILE + (fname, + (void*)_get_osfhandle(desc), + ecl_smm_io_wcon, + byte_size, flags, + external_format); + output->stream.eof_char = CONTROL_Z; + } else { + output = ecl_make_stream_from_FILE + (fname, f, smm, byte_size, flags, + external_format); + } + return output; } static cl_object @@ -4010,29 +4005,29 @@ maybe_make_windows_console_fd(cl_object fname, int desc, enum ecl_smmode smm, cl_fixnum byte_size, int flags, cl_object external_format) { - cl_object output; - if (isatty(desc)) { - output = ecl_make_stream_from_FILE - (fname, - (void*)_get_osfhandle(desc), - ecl_smm_io_wcon, - byte_size, flags, - external_format); - output->stream.eof_char = CONTROL_Z; - } else { - /* Windows changes the newline characters for \r\n - * even when using read()/write() */ - if (ecl_option_values[ECL_OPT_USE_SETMODE_ON_FILES]) { - _setmode(desc, _O_BINARY); - } else { - external_format = ECL_CONS_CDR(external_format); - } - output = ecl_make_file_stream_from_fd - (fname, desc, smm, - byte_size, flags, - external_format); - } - return output; + cl_object output; + if (isatty(desc)) { + output = ecl_make_stream_from_FILE + (fname, + (void*)_get_osfhandle(desc), + ecl_smm_io_wcon, + byte_size, flags, + external_format); + output->stream.eof_char = CONTROL_Z; + } else { + /* Windows changes the newline characters for \r\n + * even when using read()/write() */ + if (ecl_option_values[ECL_OPT_USE_SETMODE_ON_FILES]) { + _setmode(desc, _O_BINARY); + } else { + external_format = ECL_CONS_CDR(external_format); + } + output = ecl_make_file_stream_from_fd + (fname, desc, smm, + byte_size, flags, + external_format); + } + return output; } #else #define maybe_make_windows_console_FILE ecl_make_stream_from_FILE @@ -4042,188 +4037,188 @@ maybe_make_windows_console_fd(cl_object fname, int desc, enum ecl_smmode smm, cl_object si_set_buffering_mode(cl_object stream, cl_object buffer_mode_symbol) { - enum ecl_smmode mode = stream->stream.mode; - int buffer_mode; + enum ecl_smmode mode = stream->stream.mode; + int buffer_mode; - unlikely_if (!ECL_ANSI_STREAM_P(stream)) { - FEerror("Cannot set buffer of ~A", 1, stream); - } + unlikely_if (!ECL_ANSI_STREAM_P(stream)) { + FEerror("Cannot set buffer of ~A", 1, stream); + } - if (buffer_mode_symbol == @':none' || Null(buffer_mode_symbol)) - buffer_mode = _IONBF; - else if (buffer_mode_symbol == @':line' || buffer_mode_symbol == @':line-buffered') - buffer_mode = _IOLBF; - else if (buffer_mode_symbol == @':full' || buffer_mode_symbol == @':fully-buffered') - buffer_mode = _IOFBF; - else - FEerror("Not a valid buffering mode: ~A", 1, buffer_mode_symbol); + if (buffer_mode_symbol == @':none' || Null(buffer_mode_symbol)) + buffer_mode = _IONBF; + else if (buffer_mode_symbol == @':line' || buffer_mode_symbol == @':line-buffered') + buffer_mode = _IOLBF; + else if (buffer_mode_symbol == @':full' || buffer_mode_symbol == @':fully-buffered') + buffer_mode = _IOFBF; + else + FEerror("Not a valid buffering mode: ~A", 1, buffer_mode_symbol); - if (mode == ecl_smm_output || mode == ecl_smm_io || mode == ecl_smm_input) { - FILE *fp = IO_STREAM_FILE(stream); + if (mode == ecl_smm_output || mode == ecl_smm_io || mode == ecl_smm_input) { + FILE *fp = IO_STREAM_FILE(stream); - if (buffer_mode != _IONBF) { - cl_index buffer_size = BUFSIZ; - char *new_buffer = ecl_alloc_atomic(buffer_size); - stream->stream.buffer = new_buffer; - setvbuf(fp, new_buffer, buffer_mode, buffer_size); - } else - setvbuf(fp, NULL, _IONBF, 0); - } - @(return stream) + if (buffer_mode != _IONBF) { + cl_index buffer_size = BUFSIZ; + char *new_buffer = ecl_alloc_atomic(buffer_size); + stream->stream.buffer = new_buffer; + setvbuf(fp, new_buffer, buffer_mode, buffer_size); + } else + setvbuf(fp, NULL, _IONBF, 0); + } + @(return stream); } cl_object ecl_make_stream_from_FILE(cl_object fname, void *f, enum ecl_smmode smm, cl_fixnum byte_size, int flags, cl_object external_format) { - cl_object stream; - stream = alloc_stream(); - stream->stream.mode = (short)smm; - stream->stream.closed = 0; - switch (smm) { - case ecl_smm_io: - stream->stream.ops = duplicate_dispatch_table(&io_stream_ops); - break; - case ecl_smm_probe: - case ecl_smm_input: - stream->stream.ops = duplicate_dispatch_table(&input_stream_ops); - break; - case ecl_smm_output: - stream->stream.ops = duplicate_dispatch_table(&output_stream_ops); - break; + cl_object stream; + stream = alloc_stream(); + stream->stream.mode = (short)smm; + stream->stream.closed = 0; + switch (smm) { + case ecl_smm_io: + stream->stream.ops = duplicate_dispatch_table(&io_stream_ops); + break; + case ecl_smm_probe: + case ecl_smm_input: + stream->stream.ops = duplicate_dispatch_table(&input_stream_ops); + break; + case ecl_smm_output: + stream->stream.ops = duplicate_dispatch_table(&output_stream_ops); + break; #if defined(ECL_WSOCK) - case ecl_smm_input_wsock: - stream->stream.ops = duplicate_dispatch_table(&winsock_stream_input_ops); - break; - case ecl_smm_output_wsock: - stream->stream.ops = duplicate_dispatch_table(&winsock_stream_output_ops); - break; - case ecl_smm_io_wsock: - stream->stream.ops = duplicate_dispatch_table(&winsock_stream_io_ops); - break; - case ecl_smm_io_wcon: - stream->stream.ops = duplicate_dispatch_table(&wcon_stream_io_ops); - break; + case ecl_smm_input_wsock: + stream->stream.ops = duplicate_dispatch_table(&winsock_stream_input_ops); + break; + case ecl_smm_output_wsock: + stream->stream.ops = duplicate_dispatch_table(&winsock_stream_output_ops); + break; + case ecl_smm_io_wsock: + stream->stream.ops = duplicate_dispatch_table(&winsock_stream_io_ops); + break; + case ecl_smm_io_wcon: + stream->stream.ops = duplicate_dispatch_table(&wcon_stream_io_ops); + break; #endif - default: - FEerror("Not a valid mode ~D for ecl_make_stream_from_FILE", 1, ecl_make_fixnum(smm)); - } - set_stream_elt_type(stream, byte_size, flags, external_format); - IO_STREAM_FILENAME(stream) = fname; /* not really used */ - stream->stream.column = 0; - IO_STREAM_FILE(stream) = f; - stream->stream.last_op = 0; - si_set_finalizer(stream, ECL_T); - return stream; + default: + FEerror("Not a valid mode ~D for ecl_make_stream_from_FILE", 1, ecl_make_fixnum(smm)); + } + set_stream_elt_type(stream, byte_size, flags, external_format); + IO_STREAM_FILENAME(stream) = fname; /* not really used */ + stream->stream.column = 0; + IO_STREAM_FILE(stream) = f; + stream->stream.last_op = 0; + si_set_finalizer(stream, ECL_T); + return stream; } cl_object ecl_make_stream_from_fd(cl_object fname, int fd, enum ecl_smmode smm, cl_fixnum byte_size, int flags, cl_object external_format) { - char *mode; /* file open mode */ - FILE *fp; /* file pointer */ - switch(smm) { - case ecl_smm_input: - mode = OPEN_R; - break; - case ecl_smm_output: - mode = OPEN_W; - break; - case ecl_smm_io: - mode = OPEN_RW; - break; + char *mode; /* file open mode */ + FILE *fp; /* file pointer */ + switch(smm) { + case ecl_smm_input: + mode = OPEN_R; + break; + case ecl_smm_output: + mode = OPEN_W; + break; + case ecl_smm_io: + mode = OPEN_RW; + break; #if defined(ECL_WSOCK) - case ecl_smm_input_wsock: - case ecl_smm_output_wsock: - case ecl_smm_io_wsock: - case ecl_smm_io_wcon: - break; + case ecl_smm_input_wsock: + case ecl_smm_output_wsock: + case ecl_smm_io_wsock: + case ecl_smm_io_wcon: + break; #endif - default: - FEerror("make_stream: wrong mode", 0); - } + default: + FEerror("make_stream: wrong mode", 0); + } #if defined(ECL_WSOCK) - if (smm == ecl_smm_input_wsock || smm == ecl_smm_output_wsock || smm == ecl_smm_io_wsock || smm == ecl_smm_io_wcon) - fp = (FILE*)fd; - else - fp = safe_fdopen(fd, mode); + if (smm == ecl_smm_input_wsock || smm == ecl_smm_output_wsock || smm == ecl_smm_io_wsock || smm == ecl_smm_io_wcon) + fp = (FILE*)fd; + else + fp = safe_fdopen(fd, mode); #else - fp = safe_fdopen(fd, mode); + fp = safe_fdopen(fd, mode); #endif - if (fp == NULL) { - FElibc_error("Unable to create stream for file descriptor ~D", - 1, ecl_make_integer(fd)); - } - return ecl_make_stream_from_FILE(fname, fp, smm, byte_size, flags, - external_format); + if (fp == NULL) { + FElibc_error("Unable to create stream for file descriptor ~D", + 1, ecl_make_integer(fd)); + } + return ecl_make_stream_from_FILE(fname, fp, smm, byte_size, flags, + external_format); } int ecl_stream_to_handle(cl_object s, bool output) { BEGIN: - if (ecl_unlikely(!ECL_ANSI_STREAM_P(s))) - return -1; - switch ((enum ecl_smmode)s->stream.mode) { - case ecl_smm_input: - if (output) return -1; - return fileno(IO_STREAM_FILE(s)); - case ecl_smm_input_file: - if (output) return -1; - return IO_FILE_DESCRIPTOR(s); - case ecl_smm_output: - if (!output) return -1; - return fileno(IO_STREAM_FILE(s)); - case ecl_smm_output_file: - if (!output) return -1; - return IO_FILE_DESCRIPTOR(s); - case ecl_smm_io: - return fileno(IO_STREAM_FILE(s)); - case ecl_smm_io_file: - return IO_FILE_DESCRIPTOR(s); - case ecl_smm_synonym: - s = SYNONYM_STREAM_STREAM(s); - goto BEGIN; - case ecl_smm_two_way: - s = output? TWO_WAY_STREAM_OUTPUT(s) : TWO_WAY_STREAM_INPUT(s); - goto BEGIN; + if (ecl_unlikely(!ECL_ANSI_STREAM_P(s))) + return -1; + switch ((enum ecl_smmode)s->stream.mode) { + case ecl_smm_input: + if (output) return -1; + return fileno(IO_STREAM_FILE(s)); + case ecl_smm_input_file: + if (output) return -1; + return IO_FILE_DESCRIPTOR(s); + case ecl_smm_output: + if (!output) return -1; + return fileno(IO_STREAM_FILE(s)); + case ecl_smm_output_file: + if (!output) return -1; + return IO_FILE_DESCRIPTOR(s); + case ecl_smm_io: + return fileno(IO_STREAM_FILE(s)); + case ecl_smm_io_file: + return IO_FILE_DESCRIPTOR(s); + case ecl_smm_synonym: + s = SYNONYM_STREAM_STREAM(s); + goto BEGIN; + case ecl_smm_two_way: + s = output? TWO_WAY_STREAM_OUTPUT(s) : TWO_WAY_STREAM_INPUT(s); + goto BEGIN; #if defined(ECL_WSOCK) - case ecl_smm_input_wsock: - case ecl_smm_output_wsock: - case ecl_smm_io_wsock: + case ecl_smm_input_wsock: + case ecl_smm_output_wsock: + case ecl_smm_io_wsock: #endif #if defined(ECL_MS_WINDOWS_HOST) - case ecl_smm_io_wcon: + case ecl_smm_io_wcon: #endif - default: - return -1; - } + default: + return -1; + } } cl_object si_file_stream_fd(cl_object s) { - cl_object ret; + cl_object ret; - unlikely_if (!ECL_ANSI_STREAM_P(s)) - FEerror("file_stream_fd: not a stream", 0); + unlikely_if (!ECL_ANSI_STREAM_P(s)) + FEerror("file_stream_fd: not a stream", 0); - switch ((enum ecl_smmode)s->stream.mode) { - case ecl_smm_input: - case ecl_smm_output: - case ecl_smm_io: - ret = ecl_make_fixnum(fileno(IO_STREAM_FILE(s))); - break; - case ecl_smm_input_file: - case ecl_smm_output_file: - case ecl_smm_io_file: - ret = ecl_make_fixnum(IO_FILE_DESCRIPTOR(s)); - break; - default: - ecl_internal_error("not a file stream"); - } - @(return ret); + switch ((enum ecl_smmode)s->stream.mode) { + case ecl_smm_input: + case ecl_smm_output: + case ecl_smm_io: + ret = ecl_make_fixnum(fileno(IO_STREAM_FILE(s))); + break; + case ecl_smm_input_file: + case ecl_smm_output_file: + case ecl_smm_io_file: + ret = ecl_make_fixnum(IO_FILE_DESCRIPTOR(s)); + break; + default: + ecl_internal_error("not a file stream"); + } + @(return ret);; } /********************************************************************** @@ -4233,154 +4228,154 @@ si_file_stream_fd(cl_object s) static cl_index seq_in_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_fixnum curr_pos = SEQ_INPUT_POSITION(strm); - cl_fixnum last = SEQ_INPUT_LIMIT(strm); - cl_fixnum delta = last - curr_pos; - if (delta > 0) { - cl_object vector = SEQ_INPUT_VECTOR(strm); - if (delta > n) delta = n; - memcpy(c, vector->vector.self.bc + curr_pos, delta); - SEQ_INPUT_POSITION(strm) += delta; - return delta; - } - return 0; + cl_fixnum curr_pos = SEQ_INPUT_POSITION(strm); + cl_fixnum last = SEQ_INPUT_LIMIT(strm); + cl_fixnum delta = last - curr_pos; + if (delta > 0) { + cl_object vector = SEQ_INPUT_VECTOR(strm); + if (delta > n) delta = n; + memcpy(c, vector->vector.self.bc + curr_pos, delta); + SEQ_INPUT_POSITION(strm) += delta; + return delta; + } + return 0; } static void seq_in_unread_char(cl_object strm, ecl_character c) { - eformat_unread_char(strm, c); - SEQ_INPUT_POSITION(strm) -= ecl_length(strm->stream.byte_stack); - strm->stream.byte_stack = ECL_NIL; + eformat_unread_char(strm, c); + SEQ_INPUT_POSITION(strm) -= ecl_length(strm->stream.byte_stack); + strm->stream.byte_stack = ECL_NIL; } static int seq_in_listen(cl_object strm) { - if (SEQ_INPUT_POSITION(strm) < SEQ_INPUT_LIMIT(strm)) - return ECL_LISTEN_AVAILABLE; - else - return ECL_LISTEN_EOF; + if (SEQ_INPUT_POSITION(strm) < SEQ_INPUT_LIMIT(strm)) + return ECL_LISTEN_AVAILABLE; + else + return ECL_LISTEN_EOF; } static cl_object seq_in_get_position(cl_object strm) { - return ecl_make_unsigned_integer(SEQ_INPUT_POSITION(strm)); + return ecl_make_unsigned_integer(SEQ_INPUT_POSITION(strm)); } static cl_object seq_in_set_position(cl_object strm, cl_object pos) { - cl_fixnum disp; - if (Null(pos)) { - disp = SEQ_INPUT_LIMIT(strm); - } else { - disp = ecl_to_size(pos); - if (disp >= SEQ_INPUT_LIMIT(strm)) { - disp = SEQ_INPUT_LIMIT(strm); - } - } - SEQ_INPUT_POSITION(strm) = disp; - return ECL_T; + cl_fixnum disp; + if (Null(pos)) { + disp = SEQ_INPUT_LIMIT(strm); + } else { + disp = ecl_to_size(pos); + if (disp >= SEQ_INPUT_LIMIT(strm)) { + disp = SEQ_INPUT_LIMIT(strm); + } + } + SEQ_INPUT_POSITION(strm) = disp; + return ECL_T; } const struct ecl_file_ops seq_in_ops = { - not_output_write_byte8, - seq_in_read_byte8, + not_output_write_byte8, + seq_in_read_byte8, - not_output_write_byte, - generic_read_byte, + not_output_write_byte, + generic_read_byte, - eformat_read_char, - not_output_write_char, - seq_in_unread_char, - generic_peek_char, + eformat_read_char, + not_output_write_char, + seq_in_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - seq_in_listen, - generic_void, /* clear-input */ - not_output_clear_output, - not_output_finish_output, - not_output_force_output, + seq_in_listen, + generic_void, /* clear-input */ + not_output_clear_output, + not_output_finish_output, + not_output_force_output, - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - generic_always_false, - io_file_element_type, + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + generic_always_false, + io_file_element_type, - not_a_file_stream, /* length */ - seq_in_get_position, - seq_in_set_position, - generic_column, - generic_close + not_a_file_stream, /* length */ + seq_in_get_position, + seq_in_set_position, + generic_column, + generic_close }; static cl_object make_sequence_input_stream(cl_object vector, cl_index istart, cl_index iend, - cl_object external_format) + cl_object external_format) { - cl_object strm; - cl_elttype type; - cl_object type_name; - int byte_size; - int flags = 0; - if (!ECL_VECTORP(vector) || - ((type = ecl_array_elttype(vector)) < ecl_aet_b8 && - type > ecl_aet_bc) || - ecl_aet_size[type] != 1) - { - FEerror("MAKE-SEQUENCE-INPUT-STREAM only accepts vectors whose element has a size of 1 byte.~%~A", 1, vector); - } - type_name = ecl_elttype_to_symbol(type); - byte_size = ecl_normalize_stream_element_type(type_name); - /* Character streams always get some external format. For binary - * sequences it has to be explicitly mentioned. */ - strm = alloc_stream(); - strm->stream.ops = duplicate_dispatch_table(&seq_in_ops); - strm->stream.mode = (short)ecl_smm_sequence_input; - if (!byte_size) { + cl_object strm; + cl_elttype type; + cl_object type_name; + int byte_size; + int flags = 0; + if (!ECL_VECTORP(vector) || + ((type = ecl_array_elttype(vector)) < ecl_aet_b8 && + type > ecl_aet_bc) || + ecl_aet_size[type] != 1) + { + FEerror("MAKE-SEQUENCE-INPUT-STREAM only accepts vectors whose element has a size of 1 byte.~%~A", 1, vector); + } + type_name = ecl_elttype_to_symbol(type); + byte_size = ecl_normalize_stream_element_type(type_name); + /* Character streams always get some external format. For binary + * sequences it has to be explicitly mentioned. */ + strm = alloc_stream(); + strm->stream.ops = duplicate_dispatch_table(&seq_in_ops); + strm->stream.mode = (short)ecl_smm_sequence_input; + if (!byte_size) { #if defined(ECL_UNICODE) - if (ECL_BASE_STRING_P(vector)) { - if (Null(external_format)) - external_format = @':default'; - } else { - if (Null(external_format)) { + if (ECL_BASE_STRING_P(vector)) { + if (Null(external_format)) + external_format = @':default'; + } else { + if (Null(external_format)) { # ifdef WORDS_BIGENDIAN - external_format = @':ucs-4be'; + external_format = @':ucs-4be'; # else - external_format = @':ucs-4le'; + external_format = @':ucs-4le'; # endif - } - } + } + } #else - if (Null(external_format)) { - external_format = @':default'; - } + if (Null(external_format)) { + external_format = @':default'; + } #endif - } - set_stream_elt_type(strm, byte_size, flags, external_format); - /* Override byte size and elt type */ - if (byte_size) strm->stream.byte_size = byte_size; - SEQ_INPUT_VECTOR(strm) = vector; - SEQ_INPUT_POSITION(strm) = istart; - SEQ_INPUT_LIMIT(strm) = iend; - return strm; + } + set_stream_elt_type(strm, byte_size, flags, external_format); + /* Override byte size and elt type */ + if (byte_size) strm->stream.byte_size = byte_size; + SEQ_INPUT_VECTOR(strm) = vector; + SEQ_INPUT_POSITION(strm) = istart; + SEQ_INPUT_LIMIT(strm) = iend; + return strm; } @(defun ext::make_sequence_input_stream (vector &key (start ecl_make_fixnum(0)) (end ECL_NIL) (external_format ECL_NIL)) - cl_index_pair p; -@ - p = ecl_vector_start_end(@[ext::make-sequence-input-stream], - vector, start, end); - @(return make_sequence_input_stream(vector, p.start, p.end, - external_format)) -@) + cl_index_pair p; + @ + p = ecl_vector_start_end(@[ext::make-sequence-input-stream], + vector, start, end); + @(return make_sequence_input_stream(vector, p.start, p.end, + external_format)) + @) /********************************************************************** * SEQUENCE OUTPUT STREAMS @@ -4390,135 +4385,135 @@ static cl_index seq_out_write_byte8(cl_object strm, unsigned char *c, cl_index n) { AGAIN: - { - cl_object vector = SEQ_OUTPUT_VECTOR(strm); - cl_fixnum curr_pos = SEQ_OUTPUT_POSITION(strm); - cl_fixnum last = vector->vector.dim; - cl_fixnum delta = last - curr_pos; - if (delta < n) { - /* Not enough space, enlarge */ - vector = _ecl_funcall3(@'adjust-array', vector, - ecl_ash(ecl_make_fixnum(last), 1)); - SEQ_OUTPUT_VECTOR(strm) = vector; - goto AGAIN; - } - memcpy(vector->vector.self.bc + curr_pos, c, n); - SEQ_OUTPUT_POSITION(strm) = curr_pos += n; - if (vector->vector.fillp < curr_pos) - vector->vector.fillp = curr_pos; - } - return n; + { + cl_object vector = SEQ_OUTPUT_VECTOR(strm); + cl_fixnum curr_pos = SEQ_OUTPUT_POSITION(strm); + cl_fixnum last = vector->vector.dim; + cl_fixnum delta = last - curr_pos; + if (delta < n) { + /* Not enough space, enlarge */ + vector = _ecl_funcall3(@'adjust-array', vector, + ecl_ash(ecl_make_fixnum(last), 1)); + SEQ_OUTPUT_VECTOR(strm) = vector; + goto AGAIN; + } + memcpy(vector->vector.self.bc + curr_pos, c, n); + SEQ_OUTPUT_POSITION(strm) = curr_pos += n; + if (vector->vector.fillp < curr_pos) + vector->vector.fillp = curr_pos; + } + return n; } static cl_object seq_out_get_position(cl_object strm) { - return ecl_make_unsigned_integer(SEQ_OUTPUT_POSITION(strm)); + return ecl_make_unsigned_integer(SEQ_OUTPUT_POSITION(strm)); } static cl_object seq_out_set_position(cl_object strm, cl_object pos) { - cl_object vector = SEQ_OUTPUT_VECTOR(strm); - cl_fixnum disp; - if (Null(pos)) { - disp = vector->vector.fillp; - } else { - disp = ecl_to_size(pos); - if (disp >= vector->vector.dim) { - disp = vector->vector.fillp; - } - } - SEQ_OUTPUT_POSITION(strm) = disp; - return ECL_T; + cl_object vector = SEQ_OUTPUT_VECTOR(strm); + cl_fixnum disp; + if (Null(pos)) { + disp = vector->vector.fillp; + } else { + disp = ecl_to_size(pos); + if (disp >= vector->vector.dim) { + disp = vector->vector.fillp; + } + } + SEQ_OUTPUT_POSITION(strm) = disp; + return ECL_T; } const struct ecl_file_ops seq_out_ops = { - seq_out_write_byte8, - not_input_read_byte8, + seq_out_write_byte8, + not_input_read_byte8, - generic_write_byte, - not_input_read_byte, + generic_write_byte, + not_input_read_byte, - not_input_read_char, - eformat_write_char, - not_input_unread_char, - generic_peek_char, + not_input_read_char, + eformat_write_char, + not_input_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - not_input_listen, - not_input_clear_input, - generic_void, /* clear-output */ - generic_void, /* finish-output */ - generic_void, /* force-output */ + not_input_listen, + not_input_clear_input, + generic_void, /* clear-output */ + generic_void, /* finish-output */ + generic_void, /* force-output */ - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - io_file_element_type, + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + io_file_element_type, - not_a_file_stream, /* length */ - seq_out_get_position, - seq_out_set_position, - generic_column, - generic_close + not_a_file_stream, /* length */ + seq_out_get_position, + seq_out_set_position, + generic_column, + generic_close }; static cl_object make_sequence_output_stream(cl_object vector, cl_object external_format) { - cl_object strm; - cl_elttype type; - cl_object type_name; - int byte_size; - int flags = 0; - if (!ECL_VECTORP(vector) || - ((type = ecl_array_elttype(vector)) < ecl_aet_b8 && - type > ecl_aet_bc) || - ecl_aet_size[type] != 1) - { - FEerror("MAKE-SEQUENCE-OUTPUT-STREAM only accepts vectors whose element has a size of 1 byte.~%~A", 1, vector); - } - type_name = ecl_elttype_to_symbol(type); - byte_size = ecl_normalize_stream_element_type(type_name); - /* Character streams always get some external format. For binary - * sequences it has to be explicitly mentioned. */ - strm = alloc_stream(); - strm->stream.ops = duplicate_dispatch_table(&seq_out_ops); - strm->stream.mode = (short)ecl_smm_sequence_output; - if (!byte_size) { + cl_object strm; + cl_elttype type; + cl_object type_name; + int byte_size; + int flags = 0; + if (!ECL_VECTORP(vector) || + ((type = ecl_array_elttype(vector)) < ecl_aet_b8 && + type > ecl_aet_bc) || + ecl_aet_size[type] != 1) + { + FEerror("MAKE-SEQUENCE-OUTPUT-STREAM only accepts vectors whose element has a size of 1 byte.~%~A", 1, vector); + } + type_name = ecl_elttype_to_symbol(type); + byte_size = ecl_normalize_stream_element_type(type_name); + /* Character streams always get some external format. For binary + * sequences it has to be explicitly mentioned. */ + strm = alloc_stream(); + strm->stream.ops = duplicate_dispatch_table(&seq_out_ops); + strm->stream.mode = (short)ecl_smm_sequence_output; + if (!byte_size) { #if defined(ECL_UNICODE) - if (ECL_BASE_STRING_P(vector)) { - if (Null(external_format)) - external_format = @':default'; - } else { - if (Null(external_format)) { + if (ECL_BASE_STRING_P(vector)) { + if (Null(external_format)) + external_format = @':default'; + } else { + if (Null(external_format)) { # ifdef WORDS_BIGENDIAN - external_format = @':ucs-4be'; + external_format = @':ucs-4be'; # else - external_format = @':ucs-4le'; + external_format = @':ucs-4le'; # endif - } - } + } + } #else - if (Null(external_format)) { - external_format = @':default'; - } + if (Null(external_format)) { + external_format = @':default'; + } #endif - } - set_stream_elt_type(strm, byte_size, flags, external_format); - /* Override byte size and elt type */ - if (byte_size) strm->stream.byte_size = byte_size; - SEQ_OUTPUT_VECTOR(strm) = vector; - SEQ_OUTPUT_POSITION(strm) = vector->vector.fillp; - return strm; + } + set_stream_elt_type(strm, byte_size, flags, external_format); + /* Override byte size and elt type */ + if (byte_size) strm->stream.byte_size = byte_size; + SEQ_OUTPUT_VECTOR(strm) = vector; + SEQ_OUTPUT_POSITION(strm) = vector->vector.fillp; + return strm; } @(defun ext::make_sequence_output_stream (vector &key (external_format ECL_NIL)) @ - @(return make_sequence_output_stream(vector, external_format)) + @(return make_sequence_output_stream(vector, external_format)); @) /********************************************************************** @@ -4528,151 +4523,151 @@ make_sequence_output_stream(cl_object vector, cl_object external_format) struct ecl_file_ops * duplicate_dispatch_table(const struct ecl_file_ops *ops) { - struct ecl_file_ops *new_ops = ecl_alloc_atomic(sizeof(*ops)); - *new_ops = *ops; - return new_ops; + struct ecl_file_ops *new_ops = ecl_alloc_atomic(sizeof(*ops)); + *new_ops = *ops; + return new_ops; } const struct ecl_file_ops * stream_dispatch_table(cl_object strm) { #ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - return &clos_stream_ops; - } + if (ECL_INSTANCEP(strm)) { + return &clos_stream_ops; + } #endif - if (!ECL_ANSI_STREAM_P(strm)) - FEwrong_type_argument(@[stream], strm); - return (const struct ecl_file_ops *)strm->stream.ops; + if (!ECL_ANSI_STREAM_P(strm)) + FEwrong_type_argument(@[stream], strm); + return (const struct ecl_file_ops *)strm->stream.ops; } static cl_index ecl_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - return stream_dispatch_table(strm)->read_byte8(strm, c, n); + return stream_dispatch_table(strm)->read_byte8(strm, c, n); } static cl_index ecl_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - return stream_dispatch_table(strm)->write_byte8(strm, c, n); + return stream_dispatch_table(strm)->write_byte8(strm, c, n); } ecl_character ecl_read_char(cl_object strm) { - return stream_dispatch_table(strm)->read_char(strm); + return stream_dispatch_table(strm)->read_char(strm); } ecl_character ecl_read_char_noeof(cl_object strm) { - ecl_character c = ecl_read_char(strm); - if (c == EOF) - FEend_of_file(strm); - return c; + ecl_character c = ecl_read_char(strm); + if (c == EOF) + FEend_of_file(strm); + return c; } cl_object ecl_read_byte(cl_object strm) { - return stream_dispatch_table(strm)->read_byte(strm); + return stream_dispatch_table(strm)->read_byte(strm); } void ecl_write_byte(cl_object c, cl_object strm) { - stream_dispatch_table(strm)->write_byte(c, strm); + stream_dispatch_table(strm)->write_byte(c, strm); } ecl_character ecl_write_char(ecl_character c, cl_object strm) { - return stream_dispatch_table(strm)->write_char(strm, c); + return stream_dispatch_table(strm)->write_char(strm, c); } void ecl_unread_char(ecl_character c, cl_object strm) { - stream_dispatch_table(strm)->unread_char(strm, c); + stream_dispatch_table(strm)->unread_char(strm, c); } int ecl_listen_stream(cl_object strm) { - return stream_dispatch_table(strm)->listen(strm); + return stream_dispatch_table(strm)->listen(strm); } void ecl_clear_input(cl_object strm) { - stream_dispatch_table(strm)->clear_input(strm); + stream_dispatch_table(strm)->clear_input(strm); } void ecl_clear_output(cl_object strm) { - stream_dispatch_table(strm)->clear_output(strm); + stream_dispatch_table(strm)->clear_output(strm); } void ecl_force_output(cl_object strm) { - stream_dispatch_table(strm)->force_output(strm); + stream_dispatch_table(strm)->force_output(strm); } void ecl_finish_output(cl_object strm) { - stream_dispatch_table(strm)->finish_output(strm); + stream_dispatch_table(strm)->finish_output(strm); } int ecl_file_column(cl_object strm) { - return stream_dispatch_table(strm)->column(strm); + return stream_dispatch_table(strm)->column(strm); } cl_object ecl_file_length(cl_object strm) { - return stream_dispatch_table(strm)->length(strm); + return stream_dispatch_table(strm)->length(strm); } cl_object ecl_file_position(cl_object strm) { - return stream_dispatch_table(strm)->get_position(strm); + return stream_dispatch_table(strm)->get_position(strm); } cl_object ecl_file_position_set(cl_object strm, cl_object pos) { - return stream_dispatch_table(strm)->set_position(strm, pos); + return stream_dispatch_table(strm)->set_position(strm, pos); } bool ecl_input_stream_p(cl_object strm) { - return stream_dispatch_table(strm)->input_p(strm); + return stream_dispatch_table(strm)->input_p(strm); } bool ecl_output_stream_p(cl_object strm) { - return stream_dispatch_table(strm)->output_p(strm); + return stream_dispatch_table(strm)->output_p(strm); } cl_object ecl_stream_element_type(cl_object strm) { - return stream_dispatch_table(strm)->element_type(strm); + return stream_dispatch_table(strm)->element_type(strm); } int ecl_interactive_stream_p(cl_object strm) { - return stream_dispatch_table(strm)->interactive_p(strm); + return stream_dispatch_table(strm)->interactive_p(strm); } /* @@ -4687,7 +4682,7 @@ ecl_interactive_stream_p(cl_object strm) ecl_character ecl_peek_char(cl_object strm) { - return stream_dispatch_table(strm)->peek_char(strm); + return stream_dispatch_table(strm)->peek_char(strm); } /*******************************tl*************************************** @@ -4697,188 +4692,188 @@ ecl_peek_char(cl_object strm) void writestr_stream(const char *s, cl_object strm) { - while (*s != '\0') - ecl_write_char(*s++, strm); + while (*s != '\0') + ecl_write_char(*s++, strm); } static cl_index compute_char_size(cl_object stream, ecl_character c) { - unsigned char buffer[5]; - int l = 0; - if (c == ECL_CHAR_CODE_NEWLINE) { - int flags = stream->stream.flags; - if (flags & ECL_STREAM_CR) { - l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_RETURN); - if (flags & ECL_STREAM_LF) - l += stream->stream.encoder(stream, buffer, - ECL_CHAR_CODE_LINEFEED); - } else { - l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_LINEFEED); - } - } else { - l += stream->stream.encoder(stream, buffer, c); - } - return l; + unsigned char buffer[5]; + int l = 0; + if (c == ECL_CHAR_CODE_NEWLINE) { + int flags = stream->stream.flags; + if (flags & ECL_STREAM_CR) { + l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_RETURN); + if (flags & ECL_STREAM_LF) + l += stream->stream.encoder(stream, buffer, + ECL_CHAR_CODE_LINEFEED); + } else { + l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_LINEFEED); + } + } else { + l += stream->stream.encoder(stream, buffer, c); + } + return l; } cl_object cl_file_string_length(cl_object stream, cl_object string) { - cl_fixnum l = 0; - /* This is a stupid requirement from the spec. Why returning 1??? - * Why not simply leaving the value unspecified, as with other - * streams one cannot write to??? - */ + cl_fixnum l = 0; + /* This is a stupid requirement from the spec. Why returning 1??? + * Why not simply leaving the value unspecified, as with other + * streams one cannot write to??? + */ BEGIN: #ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(stream)) { - @(return ECL_NIL) - } + if (ECL_INSTANCEP(stream)) { + @(return ECL_NIL); + } #endif - unlikely_if (!ECL_ANSI_STREAM_P(stream)) { - FEwrong_type_only_arg(@[file-string-length], stream, @[stream]); - } - if (stream->stream.mode == ecl_smm_broadcast) { - stream = BROADCAST_STREAM_LIST(stream); - if (Null(stream)) { - @(return ecl_make_fixnum(1)); - } else { - goto BEGIN; - } - } - unlikely_if (!ECL_FILE_STREAM_P(stream)) { - not_a_file_stream(stream); - } - switch (ecl_t_of(string)) { + unlikely_if (!ECL_ANSI_STREAM_P(stream)) { + FEwrong_type_only_arg(@[file-string-length], stream, @[stream]); + } + if (stream->stream.mode == ecl_smm_broadcast) { + stream = BROADCAST_STREAM_LIST(stream); + if (Null(stream)) { + @(return ecl_make_fixnum(1)); + } else { + goto BEGIN; + } + } + unlikely_if (!ECL_FILE_STREAM_P(stream)) { + not_a_file_stream(stream); + } + switch (ecl_t_of(string)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: { - cl_index i; - for (i = 0; i < string->base_string.fillp; i++) { - l += compute_char_size(stream, ecl_char(string, i)); - } - break; - } - case t_character: - l = compute_char_size(stream, ECL_CHAR_CODE(string)); - break; - default: - FEwrong_type_nth_arg(@[file-string-length], 2, string, @[string]); - } - @(return ecl_make_fixnum(l)) + case t_base_string: { + cl_index i; + for (i = 0; i < string->base_string.fillp; i++) { + l += compute_char_size(stream, ecl_char(string, i)); + } + break; + } + case t_character: + l = compute_char_size(stream, ECL_CHAR_CODE(string)); + break; + default: + FEwrong_type_nth_arg(@[file-string-length], 2, string, @[string]); + } + @(return ecl_make_fixnum(l)); } cl_object si_do_write_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) { - const struct ecl_file_ops *ops; - cl_fixnum start,limit,end; + const struct ecl_file_ops *ops; + cl_fixnum start,limit,end; - /* Since we have called ecl_length(), we know that SEQ is a valid - sequence. Therefore, we only need to check the type of the - object, and seq == ECL_NIL i.f.f. t = t_symbol */ - limit = ecl_length(seq); - if (ecl_unlikely(!ECL_FIXNUMP(s) || - ((start = ecl_fixnum(s)) < 0) || - (start > limit))) { - FEwrong_type_key_arg(@[write-sequence], @[:start], s, - ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(limit-1))); - } - if (e == ECL_NIL) { - end = limit; - } else if (ecl_unlikely(!ECL_FIXNUMP(e) || - ((end = ecl_fixnum(e)) < 0) || - (end > limit))) { - FEwrong_type_key_arg(@[write-sequence], @[:end], e, - ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(limit))); - } - if (end <= start) { - goto OUTPUT; - } - ops = stream_dispatch_table(stream); - if (LISTP(seq)) { - cl_object elt_type = cl_stream_element_type(stream); - bool ischar = (elt_type == @'base-char') || (elt_type == @'character'); - cl_object s = ecl_nthcdr(start, seq); - loop_for_in(s) { - if (start < end) { - cl_object elt = CAR(s); - if (ischar) - ops->write_char(stream, ecl_char_code(elt)); - else - ops->write_byte(elt, stream); - start++; - } else { - goto OUTPUT; - } - } end_loop_for_in; - } else { - ops->write_vector(stream, seq, start, end); - } + /* Since we have called ecl_length(), we know that SEQ is a valid + sequence. Therefore, we only need to check the type of the + object, and seq == ECL_NIL i.f.f. t = t_symbol */ + limit = ecl_length(seq); + if (ecl_unlikely(!ECL_FIXNUMP(s) || + ((start = ecl_fixnum(s)) < 0) || + (start > limit))) { + FEwrong_type_key_arg(@[write-sequence], @[:start], s, + ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(limit-1))); + } + if (e == ECL_NIL) { + end = limit; + } else if (ecl_unlikely(!ECL_FIXNUMP(e) || + ((end = ecl_fixnum(e)) < 0) || + (end > limit))) { + FEwrong_type_key_arg(@[write-sequence], @[:end], e, + ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(limit))); + } + if (end <= start) { + goto OUTPUT; + } + ops = stream_dispatch_table(stream); + if (LISTP(seq)) { + cl_object elt_type = cl_stream_element_type(stream); + bool ischar = (elt_type == @'base-char') || (elt_type == @'character'); + cl_object s = ecl_nthcdr(start, seq); + loop_for_in(s) { + if (start < end) { + cl_object elt = CAR(s); + if (ischar) + ops->write_char(stream, ecl_char_code(elt)); + else + ops->write_byte(elt, stream); + start++; + } else { + goto OUTPUT; + } + } end_loop_for_in; + } else { + ops->write_vector(stream, seq, start, end); + } OUTPUT: - @(return seq); + @(return seq); } cl_object si_do_read_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) { - const struct ecl_file_ops *ops; - cl_fixnum start,limit,end; + const struct ecl_file_ops *ops; + cl_fixnum start,limit,end; - /* Since we have called ecl_length(), we know that SEQ is a valid - sequence. Therefore, we only need to check the type of the - object, and seq == ECL_NIL i.f.f. t = t_symbol */ - limit = ecl_length(seq); - if (ecl_unlikely(!ECL_FIXNUMP(s) || - ((start = ecl_fixnum(s)) < 0) || - (start > limit))) { - FEwrong_type_key_arg(@[read-sequence], @[:start], s, - ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(limit-1))); - } - if (e == ECL_NIL) { - end = limit; - } else if (ecl_unlikely(!ECL_FIXNUMP(e) || - ((end = ecl_fixnum(e)) < 0) || - (end > limit))) { - FEwrong_type_key_arg(@[read-sequence], @[:end], e, - ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(limit))); - } - if (end <= start) { - goto OUTPUT; - } - ops = stream_dispatch_table(stream); - if (LISTP(seq)) { - cl_object elt_type = cl_stream_element_type(stream); - bool ischar = (elt_type == @'base-char') || (elt_type == @'character'); - seq = ecl_nthcdr(start, seq); - loop_for_in(seq) { - if (start >= end) { - goto OUTPUT; - } else { - cl_object c; - if (ischar) { - int i = ops->read_char(stream); - if (i < 0) goto OUTPUT; - c = ECL_CODE_CHAR(i); - } else { - c = ops->read_byte(stream); - if (c == ECL_NIL) goto OUTPUT; - } - ECL_RPLACA(seq, c); - start++; - } - } end_loop_for_in; + /* Since we have called ecl_length(), we know that SEQ is a valid + sequence. Therefore, we only need to check the type of the + object, and seq == ECL_NIL i.f.f. t = t_symbol */ + limit = ecl_length(seq); + if (ecl_unlikely(!ECL_FIXNUMP(s) || + ((start = ecl_fixnum(s)) < 0) || + (start > limit))) { + FEwrong_type_key_arg(@[read-sequence], @[:start], s, + ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(limit-1))); + } + if (e == ECL_NIL) { + end = limit; + } else if (ecl_unlikely(!ECL_FIXNUMP(e) || + ((end = ecl_fixnum(e)) < 0) || + (end > limit))) { + FEwrong_type_key_arg(@[read-sequence], @[:end], e, + ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(limit))); + } + if (end <= start) { + goto OUTPUT; + } + ops = stream_dispatch_table(stream); + if (LISTP(seq)) { + cl_object elt_type = cl_stream_element_type(stream); + bool ischar = (elt_type == @'base-char') || (elt_type == @'character'); + seq = ecl_nthcdr(start, seq); + loop_for_in(seq) { + if (start >= end) { + goto OUTPUT; + } else { + cl_object c; + if (ischar) { + int i = ops->read_char(stream); + if (i < 0) goto OUTPUT; + c = ECL_CODE_CHAR(i); } else { - start = ops->read_vector(stream, seq, start, end); + c = ops->read_byte(stream); + if (c == ECL_NIL) goto OUTPUT; } + ECL_RPLACA(seq, c); + start++; + } + } end_loop_for_in; + } else { + start = ops->read_vector(stream, seq, start, end); + } OUTPUT: - @(return ecl_make_fixnum(start)) + @(return ecl_make_fixnum(start)); } /********************************************************************** @@ -4888,102 +4883,102 @@ si_do_read_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) cl_object si_file_column(cl_object strm) { - @(return ecl_make_fixnum(ecl_file_column(strm))) + @(return ecl_make_fixnum(ecl_file_column(strm))); } cl_object cl_file_length(cl_object strm) { - @(return ecl_file_length(strm)) + @(return ecl_file_length(strm)); } @(defun file-position (file_stream &o position) - cl_object output; + cl_object output; @ - if (Null(position)) { - output = ecl_file_position(file_stream); - } else { - if (position == @':start') { - position = ecl_make_fixnum(0); - } else if (position == @':end') { - position = ECL_NIL; - } - output = ecl_file_position_set(file_stream, position); - } - @(return output) + if (Null(position)) { + output = ecl_file_position(file_stream); + } else { + if (position == @':start') { + position = ecl_make_fixnum(0); + } else if (position == @':end') { + position = ECL_NIL; + } + output = ecl_file_position_set(file_stream, position); + } + @(return output); @) cl_object cl_input_stream_p(cl_object strm) { - @(return (ecl_input_stream_p(strm) ? ECL_T : ECL_NIL)) + @(return (ecl_input_stream_p(strm) ? ECL_T : ECL_NIL)); } cl_object cl_output_stream_p(cl_object strm) { - @(return (ecl_output_stream_p(strm) ? ECL_T : ECL_NIL)) + @(return (ecl_output_stream_p(strm) ? ECL_T : ECL_NIL)); } cl_object cl_interactive_stream_p(cl_object strm) { - @(return (stream_dispatch_table(strm)->interactive_p(strm)? ECL_T : ECL_NIL)) + @(return (stream_dispatch_table(strm)->interactive_p(strm)? ECL_T : ECL_NIL)); } cl_object cl_open_stream_p(cl_object strm) { - /* ANSI and Cltl2 specify that open-stream-p should work - on closed streams, and that a stream is only closed - when #'close has been applied on it */ + /* ANSI and Cltl2 specify that open-stream-p should work + on closed streams, and that a stream is only closed + when #'close has been applied on it */ #ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - return _ecl_funcall2(@'gray::open-stream-p', strm); - } + if (ECL_INSTANCEP(strm)) { + return _ecl_funcall2(@'gray::open-stream-p', strm); + } #endif - unlikely_if (!ECL_ANSI_STREAM_P(strm)) - FEwrong_type_only_arg(@'open-stream-p', strm, @'stream'); - @(return (strm->stream.closed ? ECL_NIL : ECL_T)) + unlikely_if (!ECL_ANSI_STREAM_P(strm)) + FEwrong_type_only_arg(@'open-stream-p', strm, @'stream'); + @(return (strm->stream.closed ? ECL_NIL : ECL_T)); } cl_object cl_stream_element_type(cl_object strm) { - @(return ecl_stream_element_type(strm)) + @(return ecl_stream_element_type(strm)); } cl_object cl_stream_external_format(cl_object strm) { - cl_object output; - cl_type t; + cl_object output; + cl_type t; AGAIN: - t= ecl_t_of(strm); + t= ecl_t_of(strm); #ifdef ECL_CLOS_STREAMS - if (t == t_instance) - output = @':default'; - else + if (t == t_instance) + output = @':default'; + else #endif - unlikely_if (t != t_stream) - FEwrong_type_only_arg(@[stream-external-format], strm, @[stream]); - if (strm->stream.mode == ecl_smm_synonym) { - strm = SYNONYM_STREAM_STREAM(strm); - goto AGAIN; - } - output = strm->stream.format; - @(return output) + unlikely_if (t != t_stream) + FEwrong_type_only_arg(@[stream-external-format], strm, @[stream]); + if (strm->stream.mode == ecl_smm_synonym) { + strm = SYNONYM_STREAM_STREAM(strm); + goto AGAIN; + } + output = strm->stream.format; + @(return output); } cl_object cl_streamp(cl_object strm) { #ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - return _ecl_funcall2(@'gray::streamp', strm); - } + if (ECL_INSTANCEP(strm)) { + return _ecl_funcall2(@'gray::streamp', strm); + } #endif - @(return (ECL_ANSI_STREAM_P(strm) ? ECL_T : ECL_NIL)) + @(return (ECL_ANSI_STREAM_P(strm) ? ECL_T : ECL_NIL)); } /********************************************************************** @@ -4993,12 +4988,12 @@ cl_streamp(cl_object strm) cl_object si_copy_stream(cl_object in, cl_object out) { - ecl_character c; - for (c = ecl_read_char(in); c != EOF; c = ecl_read_char(in)) { - ecl_write_char(c, out); - } - ecl_force_output(out); - @(return ECL_T) + ecl_character c; + for (c = ecl_read_char(in); c != EOF; c = ecl_read_char(in)) { + ecl_write_char(c, out); + } + ecl_force_output(out); + @(return ECL_T); } @@ -5009,46 +5004,46 @@ si_copy_stream(cl_object in, cl_object out) cl_fixnum ecl_normalize_stream_element_type(cl_object element_type) { - cl_fixnum sign = 0; - cl_index size; - if (element_type == @'signed-byte' || element_type == @'ext::integer8') { - return -8; - } else if (element_type == @'unsigned-byte' || element_type == @'ext::byte8') { - return 8; - } else if (element_type == @':default') { - return 0; - } else if (element_type == @'base-char' || element_type == @'character') { - return 0; - } else if (_ecl_funcall3(@'subtypep', element_type, @'character') != ECL_NIL) { - return 0; - } else if (_ecl_funcall3(@'subtypep', element_type, @'unsigned-byte') != ECL_NIL) { - sign = +1; - } else if (_ecl_funcall3(@'subtypep', element_type, @'signed-byte') != ECL_NIL) { - sign = -1; - } else { - FEerror("Not a valid stream element type: ~A", 1, element_type); - } - if (CONSP(element_type)) { - if (CAR(element_type) == @'unsigned-byte') - return ecl_to_size(cl_cadr(element_type)); - if (CAR(element_type) == @'signed-byte') - return -ecl_to_size(cl_cadr(element_type)); - } - for (size = 8; 1; size++) { - cl_object type; - type = cl_list(2, sign>0? @'unsigned-byte' : @'signed-byte', - ecl_make_fixnum(size)); - if (_ecl_funcall3(@'subtypep', element_type, type) != ECL_NIL) { - return size * sign; - } - } - FEerror("Not a valid stream element type: ~A", 1, element_type); + cl_fixnum sign = 0; + cl_index size; + if (element_type == @'signed-byte' || element_type == @'ext::integer8') { + return -8; + } else if (element_type == @'unsigned-byte' || element_type == @'ext::byte8') { + return 8; + } else if (element_type == @':default') { + return 0; + } else if (element_type == @'base-char' || element_type == @'character') { + return 0; + } else if (_ecl_funcall3(@'subtypep', element_type, @'character') != ECL_NIL) { + return 0; + } else if (_ecl_funcall3(@'subtypep', element_type, @'unsigned-byte') != ECL_NIL) { + sign = +1; + } else if (_ecl_funcall3(@'subtypep', element_type, @'signed-byte') != ECL_NIL) { + sign = -1; + } else { + FEerror("Not a valid stream element type: ~A", 1, element_type); + } + if (CONSP(element_type)) { + if (CAR(element_type) == @'unsigned-byte') + return ecl_to_size(cl_cadr(element_type)); + if (CAR(element_type) == @'signed-byte') + return -ecl_to_size(cl_cadr(element_type)); + } + for (size = 8; 1; size++) { + cl_object type; + type = cl_list(2, sign>0? @'unsigned-byte' : @'signed-byte', + ecl_make_fixnum(size)); + if (_ecl_funcall3(@'subtypep', element_type, type) != ECL_NIL) { + return size * sign; + } + } + FEerror("Not a valid stream element type: ~A", 1, element_type); } static void FEinvalid_option(cl_object option, cl_object value) { - FEerror("Invalid value op option ~A: ~A", 2, option, value); + FEerror("Invalid value op option ~A: ~A", 2, option, value); } cl_object @@ -5056,172 +5051,171 @@ ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, cl_object if_does_not_exist, cl_fixnum byte_size, int flags, cl_object external_format) { - cl_object output; - int f; + cl_object output; + int f; #if defined(ECL_MS_WINDOWS_HOST) - ecl_mode_t mode = _S_IREAD | _S_IWRITE; + ecl_mode_t mode = _S_IREAD | _S_IWRITE; #else - ecl_mode_t mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH; + ecl_mode_t mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH; #endif - cl_object filename = si_coerce_to_filename(fn); - char *fname = (char*)filename->base_string.self; - bool appending = 0; - bool exists = si_file_kind(filename, ECL_T) != ECL_NIL; - if (smm == ecl_smm_input || smm == ecl_smm_probe) { - if (!exists) { - if (if_does_not_exist == @':error') { - FEcannot_open(fn); - } else if (if_does_not_exist == @':create') { - f = safe_open(fname, O_WRONLY|O_CREAT, mode); - unlikely_if (f < 0) FEcannot_open(fn); - safe_close(f); - } else if (Null(if_does_not_exist)) { - return ECL_NIL; - } else { - FEinvalid_option(@':if-does-not-exist', - if_does_not_exist); - } - } - f = safe_open(fname, O_RDONLY, mode); - unlikely_if (f < 0) FEcannot_open(fn); - } else if (smm == ecl_smm_output || smm == ecl_smm_io) { - int base = (smm == ecl_smm_output)? O_WRONLY : O_RDWR; - if (if_exists == @':new_version' && - if_does_not_exist == @':create') { - exists = 0; - if_does_not_exist = @':create'; - } - if (exists) { - if (if_exists == @':error') { - FEcannot_open(fn); - } else if (if_exists == @':rename') { - f = ecl_backup_open(fname, base|O_CREAT, mode); - unlikely_if (f < 0) FEcannot_open(fn); - } else if (if_exists == @':rename_and_delete' || - if_exists == @':new_version' || - if_exists == @':supersede') { - f = safe_open(fname, base|O_TRUNC, mode); - unlikely_if (f < 0) FEcannot_open(fn); - } else if (if_exists == @':overwrite' || if_exists == @':append') { - f = safe_open(fname, base, mode); - unlikely_if (f < 0) FEcannot_open(fn); - appending = (if_exists == @':append'); - } else if (Null(if_exists)) { - return ECL_NIL; - } else { - FEinvalid_option(@':if-exists', if_exists); - } - } else { - if (if_does_not_exist == @':error') { - FEcannot_open(fn); - } else if (if_does_not_exist == @':create') { - f = safe_open(fname, base | O_CREAT | O_TRUNC, mode); - unlikely_if (f < 0) FEcannot_open(fn); - } else if (Null(if_does_not_exist)) { - return ECL_NIL; - } else { - FEinvalid_option(@':if-does-not-exist', - if_does_not_exist); - } - } - } else { - FEerror("Illegal stream mode ~S", 1, ecl_make_fixnum(smm)); - } - if (flags & ECL_STREAM_C_STREAM) { - FILE *fp; - safe_close(f); - /* We do not use fdopen() because Windows seems to - * have problems with the resulting streams. Furthermore, even for - * output we open with w+ because we do not want to - * overwrite the file. */ - switch (smm) { - case ecl_smm_probe: - case ecl_smm_input: fp = safe_fopen(fname, OPEN_R); break; - case ecl_smm_output: - case ecl_smm_io: fp = safe_fopen(fname, OPEN_RW); break; - default:; /* never reached */ - } - output = ecl_make_stream_from_FILE(fn, fp, smm, byte_size, flags, - external_format); - si_set_buffering_mode(output, byte_size? @':full' : @':line'); - } else { - output = ecl_make_file_stream_from_fd(fn, f, smm, byte_size, flags, - external_format); - } - if (smm == ecl_smm_probe) { - cl_close(1, output); - } else { - output->stream.flags |= ECL_STREAM_MIGHT_SEEK; - si_set_finalizer(output, ECL_T); - /* Set file pointer to the correct position */ - ecl_file_position_set(output, appending? ECL_NIL : ecl_make_fixnum(0)); - } - return output; + cl_object filename = si_coerce_to_filename(fn); + char *fname = (char*)filename->base_string.self; + bool appending = 0; + bool exists = si_file_kind(filename, ECL_T) != ECL_NIL; + if (smm == ecl_smm_input || smm == ecl_smm_probe) { + if (!exists) { + if (if_does_not_exist == @':error') { + FEcannot_open(fn); + } else if (if_does_not_exist == @':create') { + f = safe_open(fname, O_WRONLY|O_CREAT, mode); + unlikely_if (f < 0) FEcannot_open(fn); + safe_close(f); + } else if (Null(if_does_not_exist)) { + return ECL_NIL; + } else { + FEinvalid_option(@':if-does-not-exist', + if_does_not_exist); + } + } + f = safe_open(fname, O_RDONLY, mode); + unlikely_if (f < 0) FEcannot_open(fn); + } else if (smm == ecl_smm_output || smm == ecl_smm_io) { + int base = (smm == ecl_smm_output)? O_WRONLY : O_RDWR; + if (if_exists == @':new_version' && + if_does_not_exist == @':create') { + exists = 0; + if_does_not_exist = @':create'; + } + if (exists) { + if (if_exists == @':error') { + FEcannot_open(fn); + } else if (if_exists == @':rename') { + f = ecl_backup_open(fname, base|O_CREAT, mode); + unlikely_if (f < 0) FEcannot_open(fn); + } else if (if_exists == @':rename_and_delete' || + if_exists == @':new_version' || + if_exists == @':supersede') { + f = safe_open(fname, base|O_TRUNC, mode); + unlikely_if (f < 0) FEcannot_open(fn); + } else if (if_exists == @':overwrite' || if_exists == @':append') { + f = safe_open(fname, base, mode); + unlikely_if (f < 0) FEcannot_open(fn); + appending = (if_exists == @':append'); + } else if (Null(if_exists)) { + return ECL_NIL; + } else { + FEinvalid_option(@':if-exists', if_exists); + } + } else { + if (if_does_not_exist == @':error') { + FEcannot_open(fn); + } else if (if_does_not_exist == @':create') { + f = safe_open(fname, base | O_CREAT | O_TRUNC, mode); + unlikely_if (f < 0) FEcannot_open(fn); + } else if (Null(if_does_not_exist)) { + return ECL_NIL; + } else { + FEinvalid_option(@':if-does-not-exist', + if_does_not_exist); + } + } + } else { + FEerror("Illegal stream mode ~S", 1, ecl_make_fixnum(smm)); + } + if (flags & ECL_STREAM_C_STREAM) { + FILE *fp; + safe_close(f); + /* We do not use fdopen() because Windows seems to + * have problems with the resulting streams. Furthermore, even for + * output we open with w+ because we do not want to + * overwrite the file. */ + switch (smm) { + case ecl_smm_probe: + case ecl_smm_input: fp = safe_fopen(fname, OPEN_R); break; + case ecl_smm_output: + case ecl_smm_io: fp = safe_fopen(fname, OPEN_RW); break; + default:; /* never reached */ + } + output = ecl_make_stream_from_FILE(fn, fp, smm, byte_size, flags, + external_format); + si_set_buffering_mode(output, byte_size? @':full' : @':line'); + } else { + output = ecl_make_file_stream_from_fd(fn, f, smm, byte_size, flags, + external_format); + } + if (smm == ecl_smm_probe) { + cl_close(1, output); + } else { + output->stream.flags |= ECL_STREAM_MIGHT_SEEK; + si_set_finalizer(output, ECL_T); + /* Set file pointer to the correct position */ + ecl_file_position_set(output, appending? ECL_NIL : ecl_make_fixnum(0)); + } + return output; } @(defun open (filename &key (direction @':input') - (element_type @'character') - (if_exists ECL_NIL iesp) - (if_does_not_exist ECL_NIL idnesp) - (external_format @':default') - (cstream ECL_T) + (element_type @'character') + (if_exists ECL_NIL iesp) + (if_does_not_exist ECL_NIL idnesp) + (external_format @':default') + (cstream ECL_T) &aux strm) - enum ecl_smmode smm; - int flags = 0; - cl_fixnum byte_size; + enum ecl_smmode smm; + int flags = 0; + cl_fixnum byte_size; @ - /* INV: ecl_open_stream() checks types */ - if (direction == @':input') { - smm = ecl_smm_input; - if (!idnesp) - if_does_not_exist = @':error'; - } else if (direction == @':output') { - smm = ecl_smm_output; - if (!iesp) - if_exists = @':new_version'; - if (!idnesp) { - if (if_exists == @':overwrite' || - if_exists == @':append') - if_does_not_exist = @':error'; - else - if_does_not_exist = @':create'; - } - } else if (direction == @':io') { - smm = ecl_smm_io; - if (!iesp) - if_exists = @':new_version'; - if (!idnesp) { - if (if_exists == @':overwrite' || - if_exists == @':append') - if_does_not_exist = @':error'; - else - if_does_not_exist = @':create'; - } - } else if (direction == @':probe') { - smm = ecl_smm_probe; - if (!idnesp) - if_does_not_exist = ECL_NIL; - } else { - FEerror("~S is an illegal DIRECTION for OPEN.", - 1, direction); - } - byte_size = ecl_normalize_stream_element_type(element_type); - if (byte_size != 0) { - external_format = ECL_NIL; - } - if (!Null(cstream)) { - flags |= ECL_STREAM_C_STREAM; - } - strm = ecl_open_stream(filename, smm, if_exists, if_does_not_exist, - byte_size, flags, external_format); - @(return strm) + /* INV: ecl_open_stream() checks types */ + if (direction == @':input') { + smm = ecl_smm_input; + if (!idnesp) + if_does_not_exist = @':error'; + } else if (direction == @':output') { + smm = ecl_smm_output; + if (!iesp) + if_exists = @':new_version'; + if (!idnesp) { + if (if_exists == @':overwrite' || + if_exists == @':append') + if_does_not_exist = @':error'; + else + if_does_not_exist = @':create'; + } + } else if (direction == @':io') { + smm = ecl_smm_io; + if (!iesp) + if_exists = @':new_version'; + if (!idnesp) { + if (if_exists == @':overwrite' || + if_exists == @':append') + if_does_not_exist = @':error'; + else + if_does_not_exist = @':create'; + } + } else if (direction == @':probe') { + smm = ecl_smm_probe; + if (!idnesp) + if_does_not_exist = ECL_NIL; + } else { + FEerror("~S is an illegal DIRECTION for OPEN.", + 1, direction); + } + byte_size = ecl_normalize_stream_element_type(element_type); + if (byte_size != 0) { + external_format = ECL_NIL; + } + if (!Null(cstream)) { + flags |= ECL_STREAM_C_STREAM; + } + strm = ecl_open_stream(filename, smm, if_exists, if_does_not_exist, + byte_size, flags, external_format); + @(return strm); @) - @(defun close (strm &key (abort @'nil')) @ - @(return stream_dispatch_table(strm)->close(strm)); + @(return stream_dispatch_table(strm)->close(strm)); @) /********************************************************************** @@ -5233,190 +5227,190 @@ file_listen(cl_object stream, int fileno) { #if !defined(ECL_MS_WINDOWS_HOST) # if defined(HAVE_SELECT) - fd_set fds; - int retv; - struct timeval tv = { 0, 0 }; - /* - * Note that the following code is fragile. If the file is closed (/dev/null) - * then select() may return 1 (at least on OS X), so that we return a flag - * saying characters are available but will find none to read. See also the - * code in cl_clear_input(). - */ - FD_ZERO(&fds); - FD_SET(fileno, &fds); - retv = select(fileno + 1, &fds, NULL, NULL, &tv); - if (ecl_unlikely(retv < 0)) - file_libc_error(@[stream-error], stream, "Error while listening to stream.", 0); - else if (retv > 0) - return ECL_LISTEN_AVAILABLE; - else - return ECL_LISTEN_NO_CHAR; + fd_set fds; + int retv; + struct timeval tv = { 0, 0 }; + /* + * Note that the following code is fragile. If the file is closed (/dev/null) + * then select() may return 1 (at least on OS X), so that we return a flag + * saying characters are available but will find none to read. See also the + * code in cl_clear_input(). + */ + FD_ZERO(&fds); + FD_SET(fileno, &fds); + retv = select(fileno + 1, &fds, NULL, NULL, &tv); + if (ecl_unlikely(retv < 0)) + file_libc_error(@[stream-error], stream, "Error while listening to stream.", 0); + else if (retv > 0) + return ECL_LISTEN_AVAILABLE; + else + return ECL_LISTEN_NO_CHAR; # elif defined(FIONREAD) - { - long c = 0; - ioctl(fileno, FIONREAD, &c); - return (c > 0)? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR; - } + { + long c = 0; + ioctl(fileno, FIONREAD, &c); + return (c > 0)? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR; + } # endif /* FIONREAD */ #else - HANDLE hnd = (HANDLE)_get_osfhandle(fileno); - switch (GetFileType(hnd)) { - case FILE_TYPE_CHAR: { - DWORD dw, dw_read, cm; - if (GetNumberOfConsoleInputEvents(hnd, &dw)) { - unlikely_if (!GetConsoleMode(hnd, &cm)) - FEwin32_error("GetConsoleMode() failed", 0); - if (dw > 0) { - PINPUT_RECORD recs = (PINPUT_RECORD)GC_malloc(sizeof(INPUT_RECORD)*dw); - int i; - unlikely_if (!PeekConsoleInput(hnd, recs, dw, &dw_read)) - FEwin32_error("PeekConsoleInput failed()", 0); - if (dw_read > 0) { - if (cm & ENABLE_LINE_INPUT) { - for (i=0; i 0 ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR); - else if (GetLastError() == ERROR_BROKEN_PIPE) - return ECL_LISTEN_EOF; - else - FEwin32_error("PeekNamedPipe() failed", 0); - break; - } - default: - FEerror("Unsupported Windows file type: ~A", 1, ecl_make_fixnum(GetFileType(hnd))); - break; + HANDLE hnd = (HANDLE)_get_osfhandle(fileno); + switch (GetFileType(hnd)) { + case FILE_TYPE_CHAR: { + DWORD dw, dw_read, cm; + if (GetNumberOfConsoleInputEvents(hnd, &dw)) { + unlikely_if (!GetConsoleMode(hnd, &cm)) + FEwin32_error("GetConsoleMode() failed", 0); + if (dw > 0) { + PINPUT_RECORD recs = (PINPUT_RECORD)GC_malloc(sizeof(INPUT_RECORD)*dw); + int i; + unlikely_if (!PeekConsoleInput(hnd, recs, dw, &dw_read)) + FEwin32_error("PeekConsoleInput failed()", 0); + if (dw_read > 0) { + if (cm & ENABLE_LINE_INPUT) { + for (i=0; i 0 ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR); + else if (GetLastError() == ERROR_BROKEN_PIPE) + return ECL_LISTEN_EOF; + else + FEwin32_error("PeekNamedPipe() failed", 0); + break; + } + default: + FEerror("Unsupported Windows file type: ~A", 1, ecl_make_fixnum(GetFileType(hnd))); + break; + } #endif - return -3; + return -3; } static int flisten(cl_object stream, FILE *fp) { - int aux; - if (feof(fp)) - return ECL_LISTEN_EOF; + int aux; + if (feof(fp)) + return ECL_LISTEN_EOF; #ifdef FILE_CNT - if (FILE_CNT(fp) > 0) - return ECL_LISTEN_AVAILABLE; + if (FILE_CNT(fp) > 0) + return ECL_LISTEN_AVAILABLE; #endif - aux = file_listen(stream, fileno(fp)); - if (aux != -3) - return aux; - /* This code is portable, and implements the expected behavior for regular files. - It will fail on noninteractive streams. */ - { - /* regular file */ - ecl_off_t old_pos = ecl_ftello(fp), end_pos; - unlikely_if (ecl_fseeko(fp, 0, SEEK_END) != 0) - file_libc_error(@[file-error], stream, - "Unable to check file position", 0); - end_pos = ecl_ftello(fp); - unlikely_if (ecl_fseeko(fp, old_pos, SEEK_SET) != 0) - file_libc_error(@[file-error], stream, - "Unable to check file position", 0); - return (end_pos > old_pos ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_EOF); - } - return !ECL_LISTEN_AVAILABLE; + aux = file_listen(stream, fileno(fp)); + if (aux != -3) + return aux; + /* This code is portable, and implements the expected behavior for regular files. + It will fail on noninteractive streams. */ + { + /* regular file */ + ecl_off_t old_pos = ecl_ftello(fp), end_pos; + unlikely_if (ecl_fseeko(fp, 0, SEEK_END) != 0) + file_libc_error(@[file-error], stream, + "Unable to check file position", 0); + end_pos = ecl_ftello(fp); + unlikely_if (ecl_fseeko(fp, old_pos, SEEK_SET) != 0) + file_libc_error(@[file-error], stream, + "Unable to check file position", 0); + return (end_pos > old_pos ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_EOF); + } + return !ECL_LISTEN_AVAILABLE; } cl_object ecl_off_t_to_integer(ecl_off_t offset) { - cl_object output; - if (sizeof(ecl_off_t) == sizeof(cl_fixnum)) { - output = ecl_make_integer(offset); - } else if (offset <= MOST_POSITIVE_FIXNUM) { - output = ecl_make_fixnum((cl_fixnum)offset); - } else { - cl_object y = _ecl_big_register0(); - if (sizeof(ECL_BIGNUM_LIMBS(y)[0]) == sizeof(cl_index)) { - ECL_BIGNUM_LIMBS(y)[0] = (cl_index)offset; - offset >>= ECL_FIXNUM_BITS; - ECL_BIGNUM_LIMBS(y)[1] = offset; - ECL_BIGNUM_SIZE(y) = offset? 2 : 1; - } else if (sizeof(ECL_BIGNUM_LIMBS(y)[0]) >= sizeof(ecl_off_t)) { - ECL_BIGNUM_LIMBS(y)[0] = offset; - ECL_BIGNUM_SIZE(y) = 1; - } - output = _ecl_big_register_normalize(y); - } - return output; + cl_object output; + if (sizeof(ecl_off_t) == sizeof(cl_fixnum)) { + output = ecl_make_integer(offset); + } else if (offset <= MOST_POSITIVE_FIXNUM) { + output = ecl_make_fixnum((cl_fixnum)offset); + } else { + cl_object y = _ecl_big_register0(); + if (sizeof(ECL_BIGNUM_LIMBS(y)[0]) == sizeof(cl_index)) { + ECL_BIGNUM_LIMBS(y)[0] = (cl_index)offset; + offset >>= ECL_FIXNUM_BITS; + ECL_BIGNUM_LIMBS(y)[1] = offset; + ECL_BIGNUM_SIZE(y) = offset? 2 : 1; + } else if (sizeof(ECL_BIGNUM_LIMBS(y)[0]) >= sizeof(ecl_off_t)) { + ECL_BIGNUM_LIMBS(y)[0] = offset; + ECL_BIGNUM_SIZE(y) = 1; + } + output = _ecl_big_register_normalize(y); + } + return output; } ecl_off_t ecl_integer_to_off_t(cl_object offset) { - ecl_off_t output = 0; - if (sizeof(ecl_off_t) == sizeof(cl_fixnum)) { - output = fixint(offset); - } else if (ECL_FIXNUMP(offset)) { - output = fixint(offset); - } else if (ECL_BIGNUMP(offset)) { - if (sizeof(ECL_BIGNUM_LIMBS(offset)[0]) == sizeof(cl_index)) { - if (ECL_BIGNUM_SIZE(offset) > 2) { - goto ERROR; - } - if (ECL_BIGNUM_SIZE(offset) == 2) { - output = ECL_BIGNUM_LIMBS(offset)[1]; - output <<= ECL_FIXNUM_BITS; - } - output += ECL_BIGNUM_LIMBS(offset)[0]; - } else if (sizeof(ECL_BIGNUM_LIMBS(offset)[0]) >= sizeof(ecl_off_t)) { - if (ECL_BIGNUM_SIZE(offset) > 1) { - goto ERROR; - } - output = ECL_BIGNUM_LIMBS(offset)[0]; - } - } else { - ERROR: FEerror("Not a valid file offset: ~S", 1, offset); - } - return output; + ecl_off_t output = 0; + if (sizeof(ecl_off_t) == sizeof(cl_fixnum)) { + output = fixint(offset); + } else if (ECL_FIXNUMP(offset)) { + output = fixint(offset); + } else if (ECL_BIGNUMP(offset)) { + if (sizeof(ECL_BIGNUM_LIMBS(offset)[0]) == sizeof(cl_index)) { + if (ECL_BIGNUM_SIZE(offset) > 2) { + goto ERROR; + } + if (ECL_BIGNUM_SIZE(offset) == 2) { + output = ECL_BIGNUM_LIMBS(offset)[1]; + output <<= ECL_FIXNUM_BITS; + } + output += ECL_BIGNUM_LIMBS(offset)[0]; + } else if (sizeof(ECL_BIGNUM_LIMBS(offset)[0]) >= sizeof(ecl_off_t)) { + if (ECL_BIGNUM_SIZE(offset) > 1) { + goto ERROR; + } + output = ECL_BIGNUM_LIMBS(offset)[0]; + } + } else { + ERROR: FEerror("Not a valid file offset: ~S", 1, offset); + } + return output; } static cl_object alloc_stream() { - cl_object x = ecl_alloc_object(t_stream); - x->stream.closed = 0; - x->stream.file.descriptor = -1; - x->stream.object0 = - x->stream.object1 = OBJNULL; - x->stream.int0 = x->stream.int1 = 0; - x->stream.format = ECL_NIL; - x->stream.flags = 0; - x->stream.byte_size = 8; - x->stream.buffer = NULL; - x->stream.encoder = NULL; - x->stream.decoder = NULL; - x->stream.last_char = EOF; - x->stream.byte_stack = ECL_NIL; - x->stream.last_code[0] = x->stream.last_code[1] = EOF; - x->stream.eof_char = EOF; - return x; + cl_object x = ecl_alloc_object(t_stream); + x->stream.closed = 0; + x->stream.file.descriptor = -1; + x->stream.object0 = + x->stream.object1 = OBJNULL; + x->stream.int0 = x->stream.int1 = 0; + x->stream.format = ECL_NIL; + x->stream.flags = 0; + x->stream.byte_size = 8; + x->stream.buffer = NULL; + x->stream.encoder = NULL; + x->stream.decoder = NULL; + x->stream.last_char = EOF; + x->stream.byte_stack = ECL_NIL; + x->stream.last_code[0] = x->stream.last_code[1] = EOF; + x->stream.eof_char = EOF; + return x; } /********************************************************************** @@ -5426,166 +5420,166 @@ alloc_stream() static cl_object not_a_file_stream(cl_object strm) { - return cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not an file stream"), - @':format-arguments', cl_list(1, strm), - @':expected-type', @'file-stream', - @':datum', strm); + return cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not an file stream"), + @':format-arguments', cl_list(1, strm), + @':expected-type', @'file-stream', + @':datum', strm); } static void not_an_input_stream(cl_object strm) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not an input stream"), - @':format-arguments', cl_list(1, strm), - @':expected-type', - cl_list(2, @'satisfies', @'input-stream-p'), - @':datum', strm); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not an input stream"), + @':format-arguments', cl_list(1, strm), + @':expected-type', + cl_list(2, @'satisfies', @'input-stream-p'), + @':datum', strm); } static void not_an_output_stream(cl_object strm) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not an output stream"), - @':format-arguments', cl_list(1, strm), - @':expected-type', cl_list(2, @'satisfies', @'output-stream-p'), - @':datum', strm); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not an output stream"), + @':format-arguments', cl_list(1, strm), + @':expected-type', cl_list(2, @'satisfies', @'output-stream-p'), + @':datum', strm); } static void not_a_character_stream(cl_object s) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not a character stream"), - @':format-arguments', cl_list(1, s), - @':expected-type', @'character', - @':datum', cl_stream_element_type(s)); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not a character stream"), + @':format-arguments', cl_list(1, s), + @':expected-type', @'character', + @':datum', cl_stream_element_type(s)); } static void not_a_binary_stream(cl_object s) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not a binary stream"), - @':format-arguments', cl_list(1, s), - @':expected-type', @'integer', - @':datum', cl_stream_element_type(s)); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not a binary stream"), + @':format-arguments', cl_list(1, s), + @':expected-type', @'integer', + @':datum', cl_stream_element_type(s)); } static void cannot_close(cl_object stream) { - file_libc_error(@[file-error], stream, "Stream cannot be closed", 0); + file_libc_error(@[file-error], stream, "Stream cannot be closed", 0); } static void file_libc_error(cl_object error_type, cl_object stream, const char *msg, int narg, ...) { - ecl_va_list args; - cl_object rest, error = _ecl_strerror(errno); + ecl_va_list args; + cl_object rest, error = _ecl_strerror(errno); - ecl_va_start(args, narg, narg, 0); - rest = cl_grab_rest_args(args); + ecl_va_start(args, narg, narg, 0); + rest = cl_grab_rest_args(args); - si_signal_simple_error(4, (cl_object)(cl_symbols + ecl_fixnum(error_type)), Cnil, - make_constant_base_string("~?~%C library explanation: ~A."), - cl_list(3, make_constant_base_string(msg), rest, - error)); + si_signal_simple_error(4, (cl_object)(cl_symbols + ecl_fixnum(error_type)), Cnil, + make_constant_base_string("~?~%C library explanation: ~A."), + cl_list(3, make_constant_base_string(msg), rest, + error)); } static void unread_error(cl_object s) { - CEerror(ECL_T, "Error when using UNREAD-CHAR on stream ~D", 1, s); + CEerror(ECL_T, "Error when using UNREAD-CHAR on stream ~D", 1, s); } static void unread_twice(cl_object s) { - CEerror(ECL_T, "Used UNREAD-CHAR twice on stream ~D", 1, s); + CEerror(ECL_T, "Used UNREAD-CHAR twice on stream ~D", 1, s); } static void maybe_clearerr(cl_object strm) { - int t = strm->stream.mode; - if (t == ecl_smm_io || t == ecl_smm_output || t == ecl_smm_input) { - FILE *f = IO_STREAM_FILE(strm); - if (f != NULL) clearerr(f); - } + int t = strm->stream.mode; + if (t == ecl_smm_io || t == ecl_smm_output || t == ecl_smm_input) { + FILE *f = IO_STREAM_FILE(strm); + if (f != NULL) clearerr(f); + } } static int restartable_io_error(cl_object strm, const char *s) { - cl_env_ptr the_env = ecl_process_env(); - volatile int old_errno = errno; - /* ecl_disable_interrupts(); ** done by caller */ - maybe_clearerr(strm); - ecl_enable_interrupts_env(the_env); - if (old_errno == EINTR) { - return 1; - } else { - file_libc_error(@[stream-error], strm, - "C operation (~A) signaled an error.", - 1, ecl_make_constant_base_string(s, strlen(s))); - return 0; - } + cl_env_ptr the_env = ecl_process_env(); + volatile int old_errno = errno; + /* ecl_disable_interrupts(); ** done by caller */ + maybe_clearerr(strm); + ecl_enable_interrupts_env(the_env); + if (old_errno == EINTR) { + return 1; + } else { + file_libc_error(@[stream-error], strm, + "C operation (~A) signaled an error.", + 1, ecl_make_constant_base_string(s, strlen(s))); + return 0; + } } static void io_error(cl_object strm) { - cl_env_ptr the_env = ecl_process_env(); - /* ecl_disable_interrupts(); ** done by caller */ - maybe_clearerr(strm); - ecl_enable_interrupts_env(the_env); - file_libc_error(@[stream-error], strm, - "Read or write operation signaled an error", 0); + cl_env_ptr the_env = ecl_process_env(); + /* ecl_disable_interrupts(); ** done by caller */ + maybe_clearerr(strm); + ecl_enable_interrupts_env(the_env); + file_libc_error(@[stream-error], strm, + "Read or write operation signaled an error", 0); } static void wrong_file_handler(cl_object strm) { - FEerror("Internal error: stream ~S has no valid C file handler.", 1, strm); + FEerror("Internal error: stream ~S has no valid C file handler.", 1, strm); } #ifdef ECL_UNICODE static cl_index encoding_error(cl_object stream, unsigned char *buffer, ecl_character c) { - cl_object code = _ecl_funcall4(@'ext::encoding-error', stream, - cl_stream_external_format(stream), - ecl_make_integer(c)); - if (Null(code)) { - /* Output nothing */ - return 0; - } else { - /* Try with supplied character */ - return stream->stream.encoder(stream, buffer, ecl_char_code(code)); - } + cl_object code = _ecl_funcall4(@'ext::encoding-error', stream, + cl_stream_external_format(stream), + ecl_make_integer(c)); + if (Null(code)) { + /* Output nothing */ + return 0; + } else { + /* Try with supplied character */ + return stream->stream.encoder(stream, buffer, ecl_char_code(code)); + } } static ecl_character decoding_error(cl_object stream, unsigned char *buffer, int length) { - cl_object octets = ECL_NIL, code; - while (length > 0) { - octets = CONS(ecl_make_fixnum(buffer[--length]), octets); - } - code = _ecl_funcall4(@'ext::decoding-error', stream, - cl_stream_external_format(stream), - octets); - if (Null(code)) { - /* Go for next character */ - return stream->stream.decoder(stream); - } else { - /* Return supplied character */ - return ecl_char_code(code); - } + cl_object octets = ECL_NIL, code; + while (length > 0) { + octets = CONS(ecl_make_fixnum(buffer[--length]), octets); + } + code = _ecl_funcall4(@'ext::decoding-error', stream, + cl_stream_external_format(stream), + octets); + if (Null(code)) { + /* Go for next character */ + return stream->stream.decoder(stream); + } else { + /* Return supplied character */ + return ecl_char_code(code); + } } #endif @@ -5593,85 +5587,84 @@ decoding_error(cl_object stream, unsigned char *buffer, int length) static void wsock_error( const char *err_msg, cl_object strm ) { - char *msg; - cl_object msg_obj; - /* ecl_disable_interrupts(); ** done by caller */ - { - FormatMessage( FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, - 0, WSAGetLastError(), 0, ( void* )&msg, 0, NULL ); - msg_obj = make_base_string_copy( msg ); - LocalFree( msg ); - } - ecl_enable_interrupts(); - FEerror( err_msg, 2, strm, msg_obj ); + char *msg; + cl_object msg_obj; + /* ecl_disable_interrupts(); ** done by caller */ + { + FormatMessage( FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, + 0, WSAGetLastError(), 0, ( void* )&msg, 0, NULL ); + msg_obj = make_base_string_copy( msg ); + LocalFree( msg ); + } + ecl_enable_interrupts(); + FEerror( err_msg, 2, strm, msg_obj ); } #endif void init_file(void) { - int flags; - cl_object standard_input; - cl_object standard_output; - cl_object error_output; - cl_object aux; - cl_object null_stream; - cl_object external_format = ECL_NIL; + int flags; + cl_object standard_input; + cl_object standard_output; + cl_object error_output; + cl_object aux; + cl_object null_stream; + cl_object external_format = ECL_NIL; #if defined(ECL_MS_WINDOWS_HOST) # ifdef ECL_UNICODE - external_format = cl_list(2, @':latin-1', @':crlf'); - flags = 0; + external_format = cl_list(2, @':latin-1', @':crlf'); + flags = 0; # else - external_format = cl_list(2, @':crlf', @':pass-through'); - flags = ECL_STREAM_DEFAULT_FORMAT; + external_format = cl_list(2, @':crlf', @':pass-through'); + flags = ECL_STREAM_DEFAULT_FORMAT; # endif #else - flags = ECL_STREAM_DEFAULT_FORMAT; + flags = ECL_STREAM_DEFAULT_FORMAT; #endif - null_stream = ecl_make_stream_from_FILE(make_constant_base_string("/dev/null"), - NULL, ecl_smm_io, 8, flags, external_format); - generic_close(null_stream); - null_stream = cl_make_two_way_stream(null_stream, cl_make_broadcast_stream(0)); - cl_core.null_stream = null_stream; + null_stream = ecl_make_stream_from_FILE(make_constant_base_string("/dev/null"), + NULL, ecl_smm_io, 8, flags, external_format); + generic_close(null_stream); + null_stream = cl_make_two_way_stream(null_stream, cl_make_broadcast_stream(0)); + cl_core.null_stream = null_stream; - /* We choose C streams by default only when _not_ using threads. - * The reason is that C streams block on I/O operations. */ + /* We choose C streams by default only when _not_ using threads. + * The reason is that C streams block on I/O operations. */ #if !defined(ECL_THREADS) - standard_input = maybe_make_windows_console_FILE(make_constant_base_string("stdin"), - stdin, ecl_smm_input, 8, flags, external_format); - standard_output = maybe_make_windows_console_FILE(make_constant_base_string("stdout"), - stdout, ecl_smm_output, 8, flags, external_format); - error_output = maybe_make_windows_console_FILE(make_constant_base_string("stderr"), - stderr, ecl_smm_output, 8, flags, external_format); + standard_input = maybe_make_windows_console_FILE(make_constant_base_string("stdin"), + stdin, ecl_smm_input, 8, flags, external_format); + standard_output = maybe_make_windows_console_FILE(make_constant_base_string("stdout"), + stdout, ecl_smm_output, 8, flags, external_format); + error_output = maybe_make_windows_console_FILE(make_constant_base_string("stderr"), + stderr, ecl_smm_output, 8, flags, external_format); #else - standard_input = maybe_make_windows_console_fd(make_constant_base_string("stdin"), - STDIN_FILENO, ecl_smm_input_file, 8, flags, - external_format); - standard_output = maybe_make_windows_console_fd(make_constant_base_string("stdout"), - STDOUT_FILENO, ecl_smm_output_file, 8, flags, - external_format); - error_output = maybe_make_windows_console_fd(make_constant_base_string("stderr"), - STDERR_FILENO, ecl_smm_output_file, 8, flags, - external_format); + standard_input = maybe_make_windows_console_fd(make_constant_base_string("stdin"), + STDIN_FILENO, ecl_smm_input_file, 8, flags, + external_format); + standard_output = maybe_make_windows_console_fd(make_constant_base_string("stdout"), + STDOUT_FILENO, ecl_smm_output_file, 8, flags, + external_format); + error_output = maybe_make_windows_console_fd(make_constant_base_string("stderr"), + STDERR_FILENO, ecl_smm_output_file, 8, flags, + external_format); #endif - cl_core.standard_input = standard_input; - ECL_SET(@'ext::+process-standard-input+', standard_input); - ECL_SET(@'*standard-input*', standard_input); - cl_core.standard_output = standard_output; - ECL_SET(@'ext::+process-standard-output+', standard_output); - ECL_SET(@'*standard-output*', standard_output); - ECL_SET(@'*trace-output*', standard_output); - cl_core.error_output = error_output; - ECL_SET(@'ext::+process-error-output+', error_output); - ECL_SET(@'*error-output*', error_output); + cl_core.standard_input = standard_input; + ECL_SET(@'ext::+process-standard-input+', standard_input); + ECL_SET(@'*standard-input*', standard_input); + cl_core.standard_output = standard_output; + ECL_SET(@'ext::+process-standard-output+', standard_output); + ECL_SET(@'*standard-output*', standard_output); + ECL_SET(@'*trace-output*', standard_output); + cl_core.error_output = error_output; + ECL_SET(@'ext::+process-error-output+', error_output); + ECL_SET(@'*error-output*', error_output); - cl_core.terminal_io = aux - = cl_make_two_way_stream(standard_input, standard_output); + cl_core.terminal_io = aux + = cl_make_two_way_stream(standard_input, standard_output); - ECL_SET(@'*terminal-io*', aux); - aux = cl_make_synonym_stream(@'*terminal-io*'); - ECL_SET(@'*query-io*', aux); - ECL_SET(@'*debug-io*', aux); + ECL_SET(@'*terminal-io*', aux); + aux = cl_make_synonym_stream(@'*terminal-io*'); + ECL_SET(@'*query-io*', aux); + ECL_SET(@'*debug-io*', aux); } - diff --git a/src/c/format.d b/src/c/format.d index 9206d3dd3..b9a525dc0 100644 --- a/src/c/format.d +++ b/src/c/format.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - format.c -- Format. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ + * format.d - format + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -65,33 +60,33 @@ typedef struct format_stack_struct { #define CHAR 2 static const char *fmt_big_numeral[] = { - "thousand", - "million", - "billion", - "trillion", - "quadrillion", - "quintillion", - "sextillion", - "septillion", - "octillion" + "thousand", + "million", + "billion", + "trillion", + "quadrillion", + "quintillion", + "sextillion", + "septillion", + "octillion" }; static const char *fmt_numeral[] = { - "zero", "one", "two", "three", "four", - "five", "six", "seven", "eight", "nine", - "ten", "eleven", "twelve", "thirteen", "fourteen", - "fifteen", "sixteen", "seventeen", "eighteen", "nineteen", - "zero", "ten", "twenty", "thirty", "forty", - "fifty", "sixty", "seventy", "eighty", "ninety" + "zero", "one", "two", "three", "four", + "five", "six", "seven", "eight", "nine", + "ten", "eleven", "twelve", "thirteen", "fourteen", + "fifteen", "sixteen", "seventeen", "eighteen", "nineteen", + "zero", "ten", "twenty", "thirty", "forty", + "fifty", "sixty", "seventy", "eighty", "ninety" }; static const char *fmt_ordinal[] = { - "zeroth", "first", "second", "third", "fourth", - "fifth", "sixth", "seventh", "eighth", "ninth", - "tenth", "eleventh", "twelfth", "thirteenth", "fourteenth", - "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth", - "zeroth", "tenth", "twentieth", "thirtieth", "fortieth", - "fiftieth", "sixtieth", "seventieth", "eightieth", "ninetieth" + "zeroth", "first", "second", "third", "fourth", + "fifth", "sixth", "seventh", "eighth", "ninth", + "tenth", "eleventh", "twelfth", "thirteenth", "fourteenth", + "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth", + "zeroth", "tenth", "twentieth", "thirtieth", "fortieth", + "fiftieth", "sixtieth", "seventieth", "eightieth", "ninetieth" }; static void format(format_stack, cl_index, cl_index); @@ -100,309 +95,309 @@ static cl_object doformat(cl_narg narg, cl_object strm, cl_object string, ecl_va static cl_object get_aux_stream(void) { - cl_env_ptr env = ecl_process_env(); - cl_object stream; + cl_env_ptr env = ecl_process_env(); + cl_object stream; - ecl_disable_interrupts_env(env); - if (env->fmt_aux_stream == ECL_NIL) { - stream = ecl_make_string_output_stream(64, 1); - } else { - stream = env->fmt_aux_stream; - env->fmt_aux_stream = ECL_NIL; - } - ecl_enable_interrupts_env(env); - return stream; + ecl_disable_interrupts_env(env); + if (env->fmt_aux_stream == ECL_NIL) { + stream = ecl_make_string_output_stream(64, 1); + } else { + stream = env->fmt_aux_stream; + env->fmt_aux_stream = ECL_NIL; + } + ecl_enable_interrupts_env(env); + return stream; } static void fmt_error(format_stack fmt, const char *s) { - cl_error(7, @'si::format-error', - @':format-control', make_constant_base_string(s), - @':control-string', fmt->ctl_str, - @':offset', ecl_make_fixnum(fmt->ctl_index)); + cl_error(7, @'si::format-error', + @':format-control', make_constant_base_string(s), + @':control-string', fmt->ctl_str, + @':offset', ecl_make_fixnum(fmt->ctl_index)); } static ecl_character tempstr(format_stack fmt, int s) { - return ecl_char(fmt->aux_string,s); + return ecl_char(fmt->aux_string,s); } static ecl_character ctl_advance(format_stack fmt) { - if (fmt->ctl_index >= fmt->ctl_end) - fmt_error(fmt, "unexpected end of control string"); - return ecl_char(fmt->ctl_str, fmt->ctl_index++); + if (fmt->ctl_index >= fmt->ctl_end) + fmt_error(fmt, "unexpected end of control string"); + return ecl_char(fmt->ctl_str, fmt->ctl_index++); } static void fmt_go(format_stack fmt, cl_fixnum n) { - cl_object p; - if (n < 0) - fmt_error(fmt, "can't goto"); - if ((p = ecl_nthcdr(n, fmt->args)) == ECL_NIL) - fmt_error(fmt, "can't goto"); - fmt->current = p; + cl_object p; + if (n < 0) + fmt_error(fmt, "can't goto"); + if ((p = ecl_nthcdr(n, fmt->args)) == ECL_NIL) + fmt_error(fmt, "can't goto"); + fmt->current = p; } static cl_index fmt_index(format_stack fmt) { - cl_object p = fmt->args, target = fmt->current; - cl_index n = 0; - if (target == ECL_NIL) - return ecl_length(p); - while (p != fmt->current) { - p = CDR(p); - if (p == ECL_NIL) - fmt_error(fmt, "Overflow"); - n++; - } - return n; + cl_object p = fmt->args, target = fmt->current; + cl_index n = 0; + if (target == ECL_NIL) + return ecl_length(p); + while (p != fmt->current) { + p = CDR(p); + if (p == ECL_NIL) + fmt_error(fmt, "Overflow"); + n++; + } + return n; } static cl_object fmt_back_up(format_stack fmt) { - fmt_go(fmt, fmt_index(fmt) - 1); + fmt_go(fmt, fmt_index(fmt) - 1); } static bool fmt_more_args_p(format_stack fmt) { - return fmt->current != ECL_NIL; + return fmt->current != ECL_NIL; } static cl_index fmt_args_left(format_stack fmt) { - return ecl_length(fmt->current); + return ecl_length(fmt->current); } static cl_object fmt_advance(format_stack fmt) { - cl_object output, l = fmt->current; - if (l == ECL_NIL) - fmt_error(fmt, "arguments exhausted"); - output = CAR(l); - fmt->current = CDR(l); - return output; + cl_object output, l = fmt->current; + if (l == ECL_NIL) + fmt_error(fmt, "arguments exhausted"); + output = CAR(l); + fmt->current = CDR(l); + return output; } static void fmt_set_arg_list(format_stack fmt, cl_object l) { - assert_type_proper_list(l); - fmt->current = fmt->args = cl_copy_list(l); + assert_type_proper_list(l); + fmt->current = fmt->args = cl_copy_list(l); } static int fmt_skip(format_stack fmt) { - ecl_character c; - int level = 0; + ecl_character c; + int level = 0; -LOOP: - if (ctl_advance(fmt) != '~') - goto LOOP; - for (;;) - switch (c = ctl_advance(fmt)) { - case '\'': - ctl_advance(fmt); + LOOP: + if (ctl_advance(fmt) != '~') + goto LOOP; + for (;;) + switch (c = ctl_advance(fmt)) { + case '\'': + ctl_advance(fmt); - case ',': - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - case '+': - case '-': - case 'v': case 'V': - case '#': - case ':': case '@@': - continue; + case ',': + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + case '+': + case '-': + case 'v': case 'V': + case '#': + case ':': case '@@': + continue; - default: - goto DIRECTIVE; - } + default: + goto DIRECTIVE; + } -DIRECTIVE: - switch (c) { - case '(': case '[': case '<': case '{': - level++; - break; + DIRECTIVE: + switch (c) { + case '(': case '[': case '<': case '{': + level++; + break; - case ')': case ']': case '>': case '}': - if (level == 0) - return(fmt->ctl_index); - else - --level; - break; + case ')': case ']': case '>': case '}': + if (level == 0) + return(fmt->ctl_index); + else + --level; + break; - case ';': - if (level == 0) - return(fmt->ctl_index); - break; - } - goto LOOP; + case ';': + if (level == 0) + return(fmt->ctl_index); + break; + } + goto LOOP; } static void ensure_param(format_stack fmt, int n) { - if (fmt->nparam > n) - fmt_error(fmt, "too many parameters"); - while (n-- > fmt->nparam) - fmt->param[n] = ECL_NIL; + if (fmt->nparam > n) + fmt_error(fmt, "too many parameters"); + while (n-- > fmt->nparam) + fmt->param[n] = ECL_NIL; } static void fmt_not_colon(format_stack fmt, bool colon) { - if (colon) - fmt_error(fmt, "illegal :"); + if (colon) + fmt_error(fmt, "illegal :"); } static void fmt_not_atsign(format_stack fmt, bool atsign) { - if (atsign) - fmt_error(fmt, "illegal @@"); + if (atsign) + fmt_error(fmt, "illegal @@"); } static void fmt_not_colon_atsign(format_stack fmt, bool colon, bool atsign) { - if (colon && atsign) - fmt_error(fmt, "illegal :@@"); + if (colon && atsign) + fmt_error(fmt, "illegal :@@"); } static cl_object set_param(format_stack fmt, int i, int t, cl_object v) { - if (i >= fmt->nparam || fmt->param[i] == ECL_NIL) - return v; - else if ((t != INT && t != CHAR) || - (t == INT && !cl_integerp(fmt->param[i])) || - (t == CHAR && !ECL_CHARACTERP(fmt->param[i]))) - fmt_error(fmt, "illegal parameter type"); - return fmt->param[i]; + if (i >= fmt->nparam || fmt->param[i] == ECL_NIL) + return v; + else if ((t != INT && t != CHAR) || + (t == INT && !cl_integerp(fmt->param[i])) || + (t == CHAR && !ECL_CHARACTERP(fmt->param[i]))) + fmt_error(fmt, "illegal parameter type"); + return fmt->param[i]; } static int set_param_positive(format_stack fmt, int i, const char *message) { - if (i >= fmt->nparam || fmt->param[i] == ECL_NIL) - return -1; - else if (cl_integerp(fmt->param[i]) == ECL_NIL) - fmt_error(fmt, "illegal parameter type"); - else { - cl_object p = fmt->param[i]; - if (ecl_minusp(p)) fmt_error(fmt, message); - return ecl_to_fix(p); - } + if (i >= fmt->nparam || fmt->param[i] == ECL_NIL) + return -1; + else if (cl_integerp(fmt->param[i]) == ECL_NIL) + fmt_error(fmt, "illegal parameter type"); + else { + cl_object p = fmt->param[i]; + if (ecl_minusp(p)) fmt_error(fmt, message); + return ecl_to_fix(p); + } } static void fmt_copy(format_stack fmt_copy, format_stack fmt) { - *fmt_copy = *fmt; + *fmt_copy = *fmt; } static void fmt_copy1(format_stack fmt_copy, format_stack fmt) { - fmt_copy->stream = fmt->stream; - fmt_copy->ctl_str = fmt->ctl_str; - fmt_copy->ctl_index = fmt->ctl_index; - fmt_copy->ctl_end = fmt->ctl_end; - fmt_copy->jmp_buf = fmt->jmp_buf; - fmt_copy->indents = fmt->indents; + fmt_copy->stream = fmt->stream; + fmt_copy->ctl_str = fmt->ctl_str; + fmt_copy->ctl_index = fmt->ctl_index; + fmt_copy->ctl_end = fmt->ctl_end; + fmt_copy->jmp_buf = fmt->jmp_buf; + fmt_copy->indents = fmt->indents; } static void fmt_prepare_aux_stream(format_stack fmt) { - fmt->aux_string->base_string.fillp = 0; - fmt->aux_stream->stream.int0 = ecl_file_column(fmt->stream); - fmt->aux_stream->stream.int1 = ecl_file_column(fmt->stream); + fmt->aux_string->base_string.fillp = 0; + fmt->aux_stream->stream.int0 = ecl_file_column(fmt->stream); + fmt->aux_stream->stream.int1 = ecl_file_column(fmt->stream); } static void fmt_ascii(format_stack fmt, bool colon, bool atsign) { - int mincol, colinc, minpad; - ecl_character padchar; - cl_object x; - int l, i; + int mincol, colinc, minpad; + ecl_character padchar; + cl_object x; + int l, i; - ensure_param(fmt, 4); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); - minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); + ensure_param(fmt, 4); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); + minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); - fmt_prepare_aux_stream(fmt); - x = fmt_advance(fmt); - if (colon && Null(x)) - writestr_stream("()", fmt->aux_stream); - else if (mincol == 0 && minpad == 0) { - ecl_princ(x, fmt->stream); - return; - } else - ecl_princ(x, fmt->aux_stream); - l = fmt->aux_string->base_string.fillp; - for (i = minpad; l + i < mincol; i += colinc) - ; - if (!atsign) { - ecl_write_string(fmt->aux_string, fmt->stream); - while (i-- > 0) - ecl_write_char(padchar, fmt->stream); - } else { - while (i-- > 0) - ecl_write_char(padchar, fmt->stream); - ecl_write_string(fmt->aux_string, fmt->stream); - } + fmt_prepare_aux_stream(fmt); + x = fmt_advance(fmt); + if (colon && Null(x)) + writestr_stream("()", fmt->aux_stream); + else if (mincol == 0 && minpad == 0) { + ecl_princ(x, fmt->stream); + return; + } else + ecl_princ(x, fmt->aux_stream); + l = fmt->aux_string->base_string.fillp; + for (i = minpad; l + i < mincol; i += colinc) + ; + if (!atsign) { + ecl_write_string(fmt->aux_string, fmt->stream); + while (i-- > 0) + ecl_write_char(padchar, fmt->stream); + } else { + while (i-- > 0) + ecl_write_char(padchar, fmt->stream); + ecl_write_string(fmt->aux_string, fmt->stream); + } } static void fmt_S_expression(format_stack fmt, bool colon, bool atsign) { - int mincol, colinc, minpad; - ecl_character padchar; - cl_object x; - int l, i; + int mincol, colinc, minpad; + ecl_character padchar; + cl_object x; + int l, i; - ensure_param(fmt, 4); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); - minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); + ensure_param(fmt, 4); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); + minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); - fmt_prepare_aux_stream(fmt); - x = fmt_advance(fmt); - if (colon && Null(x)) - writestr_stream("()", fmt->aux_stream); - else if (mincol == 0 && minpad == 0) { - ecl_prin1(x, fmt->stream); - return; - } else - ecl_prin1(x, fmt->aux_stream); - l = fmt->aux_string->base_string.fillp; - for (i = minpad; l + i < mincol; i += colinc) - ; - if (!atsign) { - ecl_write_string(fmt->aux_string, fmt->stream); - while (i-- > 0) - ecl_write_char(padchar, fmt->stream); - } else { - while (i-- > 0) - ecl_write_char(padchar, fmt->stream); - ecl_write_string(fmt->aux_string, fmt->stream); - } + fmt_prepare_aux_stream(fmt); + x = fmt_advance(fmt); + if (colon && Null(x)) + writestr_stream("()", fmt->aux_stream); + else if (mincol == 0 && minpad == 0) { + ecl_prin1(x, fmt->stream); + return; + } else + ecl_prin1(x, fmt->aux_stream); + l = fmt->aux_string->base_string.fillp; + for (i = minpad; l + i < mincol; i += colinc) + ; + if (!atsign) { + ecl_write_string(fmt->aux_string, fmt->stream); + while (i-- > 0) + ecl_write_char(padchar, fmt->stream); + } else { + while (i-- > 0) + ecl_write_char(padchar, fmt->stream); + ecl_write_string(fmt->aux_string, fmt->stream); + } } @@ -410,334 +405,334 @@ static void fmt_integer(format_stack fmt, cl_object x, bool colon, bool atsign, int radix, int mincol, ecl_character padchar, ecl_character commachar) { - const cl_env_ptr env = ecl_process_env(); - int l, l1; - int s; + const cl_env_ptr env = ecl_process_env(); + int l, l1; + int s; - if (!ECL_FIXNUMP(x) && ecl_t_of(x) != t_bignum) { - fmt_prepare_aux_stream(fmt); - ecl_bds_bind(env, @'*print-escape*', ECL_NIL); - ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(radix)); - si_write_object(x, fmt->aux_stream); - ecl_bds_unwind_n(env, 2); - l = fmt->aux_string->base_string.fillp; - mincol -= l; - while (mincol-- > 0) - ecl_write_char(padchar, fmt->stream); - ecl_write_string(fmt->aux_string, fmt->stream); - return; - } - fmt_prepare_aux_stream(fmt); - ecl_bds_bind(env, @'*print-radix*', ECL_NIL); - ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(radix)); - si_write_object(x, fmt->aux_stream); - ecl_bds_unwind_n(env, 2); - l = l1 = fmt->aux_string->base_string.fillp; - s = 0; - if (tempstr(fmt, s) == '-') - --l1; - mincol -= l; - if (colon) - mincol -= (l1 - 1)/3; - if (atsign && tempstr(fmt, s) != '-') - --mincol; - while (mincol-- > 0) - ecl_write_char(padchar, fmt->stream); - if (tempstr(fmt, s) == '-') { - s++; - ecl_write_char('-', fmt->stream); - } else if (atsign) - ecl_write_char('+', fmt->stream); - while (l1-- > 0) { - ecl_write_char(tempstr(fmt, s++), fmt->stream); - if (colon && l1 > 0 && l1%3 == 0) - ecl_write_char(commachar, fmt->stream); - } + if (!ECL_FIXNUMP(x) && ecl_t_of(x) != t_bignum) { + fmt_prepare_aux_stream(fmt); + ecl_bds_bind(env, @'*print-escape*', ECL_NIL); + ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(radix)); + si_write_object(x, fmt->aux_stream); + ecl_bds_unwind_n(env, 2); + l = fmt->aux_string->base_string.fillp; + mincol -= l; + while (mincol-- > 0) + ecl_write_char(padchar, fmt->stream); + ecl_write_string(fmt->aux_string, fmt->stream); + return; + } + fmt_prepare_aux_stream(fmt); + ecl_bds_bind(env, @'*print-radix*', ECL_NIL); + ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(radix)); + si_write_object(x, fmt->aux_stream); + ecl_bds_unwind_n(env, 2); + l = l1 = fmt->aux_string->base_string.fillp; + s = 0; + if (tempstr(fmt, s) == '-') + --l1; + mincol -= l; + if (colon) + mincol -= (l1 - 1)/3; + if (atsign && tempstr(fmt, s) != '-') + --mincol; + while (mincol-- > 0) + ecl_write_char(padchar, fmt->stream); + if (tempstr(fmt, s) == '-') { + s++; + ecl_write_char('-', fmt->stream); + } else if (atsign) + ecl_write_char('+', fmt->stream); + while (l1-- > 0) { + ecl_write_char(tempstr(fmt, s++), fmt->stream); + if (colon && l1 > 0 && l1%3 == 0) + ecl_write_char(commachar, fmt->stream); + } } static void fmt_decimal(format_stack fmt, bool colon, bool atsign) { - int mincol; - ecl_character padchar, commachar; + int mincol; + ecl_character padchar, commachar; - ensure_param(fmt, 3); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); - fmt_integer(fmt, fmt_advance(fmt), colon, atsign, - 10, mincol, padchar, commachar); + ensure_param(fmt, 3); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); + fmt_integer(fmt, fmt_advance(fmt), colon, atsign, + 10, mincol, padchar, commachar); } static void fmt_binary(format_stack fmt, bool colon, bool atsign) { - int mincol; - ecl_character padchar, commachar; + int mincol; + ecl_character padchar, commachar; - ensure_param(fmt, 3); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); - fmt_integer(fmt, fmt_advance(fmt), colon, atsign, - 2, mincol, padchar, commachar); + ensure_param(fmt, 3); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); + fmt_integer(fmt, fmt_advance(fmt), colon, atsign, + 2, mincol, padchar, commachar); } static void fmt_octal(format_stack fmt, bool colon, bool atsign) { - int mincol; - ecl_character padchar, commachar; + int mincol; + ecl_character padchar, commachar; - ensure_param(fmt, 3); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); - fmt_integer(fmt, fmt_advance(fmt), colon, atsign, - 8, mincol, padchar, commachar); + ensure_param(fmt, 3); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); + fmt_integer(fmt, fmt_advance(fmt), colon, atsign, + 8, mincol, padchar, commachar); } static void fmt_hexadecimal(format_stack fmt, bool colon, bool atsign) { - int mincol; - ecl_character padchar, commachar; + int mincol; + ecl_character padchar, commachar; - ensure_param(fmt, 3); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); - fmt_integer(fmt, fmt_advance(fmt), colon, atsign, - 16, mincol, padchar, commachar); + ensure_param(fmt, 3); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); + fmt_integer(fmt, fmt_advance(fmt), colon, atsign, + 16, mincol, padchar, commachar); } static void fmt_write_numeral(format_stack fmt, int s, int i) { - writestr_stream(fmt_numeral[tempstr(fmt, s) - '0' + i], fmt->stream); + writestr_stream(fmt_numeral[tempstr(fmt, s) - '0' + i], fmt->stream); } static void fmt_write_ordinal(format_stack fmt, int s, int i) { - writestr_stream(fmt_ordinal[tempstr(fmt, s) - '0' + i], fmt->stream); + writestr_stream(fmt_ordinal[tempstr(fmt, s) - '0' + i], fmt->stream); } static bool fmt_thousand(format_stack fmt, int s, int i, bool b, bool o, int t) { - if (i == 3 && tempstr(fmt, s) > '0') { - if (b) - ecl_write_char(' ', fmt->stream); - fmt_write_numeral(fmt, s, 0); - writestr_stream(" hundred", fmt->stream); - --i; - s++; - b = TRUE; - if (o && (s > t)) - writestr_stream("th", fmt->stream); - } - if (i == 3) { - --i; - s++; - } - if (i == 2 && tempstr(fmt, s) > '0') { - if (b) - ecl_write_char(' ', fmt->stream); - if (tempstr(fmt, s) == '1') { - if (o && (s + 2 > t)) - fmt_write_ordinal(fmt, ++s, 10); - else - fmt_write_numeral(fmt, ++s, 10); - return(TRUE); - } else { - if (o && (s + 1 > t)) - fmt_write_ordinal(fmt, s, 20); - else - fmt_write_numeral(fmt, s, 20); - s++; - if (tempstr(fmt, s) > '0') { - ecl_write_char('-', fmt->stream); - if (o && s + 1 > t) - fmt_write_ordinal(fmt, s, 0); - else - fmt_write_numeral(fmt, s, 0); - } - return(TRUE); - } - } - if (i == 2) - s++; - if (tempstr(fmt, s) > '0') { - if (b) - ecl_write_char(' ', fmt->stream); - if (o && s + 1 > t) - fmt_write_ordinal(fmt, s, 0); - else - fmt_write_numeral(fmt, s, 0); - return(TRUE); - } - return(b); + if (i == 3 && tempstr(fmt, s) > '0') { + if (b) + ecl_write_char(' ', fmt->stream); + fmt_write_numeral(fmt, s, 0); + writestr_stream(" hundred", fmt->stream); + --i; + s++; + b = TRUE; + if (o && (s > t)) + writestr_stream("th", fmt->stream); + } + if (i == 3) { + --i; + s++; + } + if (i == 2 && tempstr(fmt, s) > '0') { + if (b) + ecl_write_char(' ', fmt->stream); + if (tempstr(fmt, s) == '1') { + if (o && (s + 2 > t)) + fmt_write_ordinal(fmt, ++s, 10); + else + fmt_write_numeral(fmt, ++s, 10); + return(TRUE); + } else { + if (o && (s + 1 > t)) + fmt_write_ordinal(fmt, s, 20); + else + fmt_write_numeral(fmt, s, 20); + s++; + if (tempstr(fmt, s) > '0') { + ecl_write_char('-', fmt->stream); + if (o && s + 1 > t) + fmt_write_ordinal(fmt, s, 0); + else + fmt_write_numeral(fmt, s, 0); + } + return(TRUE); + } + } + if (i == 2) + s++; + if (tempstr(fmt, s) > '0') { + if (b) + ecl_write_char(' ', fmt->stream); + if (o && s + 1 > t) + fmt_write_ordinal(fmt, s, 0); + else + fmt_write_numeral(fmt, s, 0); + return(TRUE); + } + return(b); } static bool fmt_nonillion(format_stack fmt, int s, int i, bool b, bool o, int t) { - int j; + int j; - for (; i > 3; i -= j) { - b = fmt_thousand(fmt, s, j = (i+2)%3+1, b, FALSE, t); - if (j != 3 || tempstr(fmt, s) != '0' || - tempstr(fmt, s+1) != '0' || tempstr(fmt, s+2) != '0') { - ecl_write_char(' ', fmt->stream); - writestr_stream(fmt_big_numeral[(i - 1)/3 - 1], - fmt->stream); - s += j; - if (o && s > t) - writestr_stream("th", fmt->stream); - } else - s += j; - } - return(fmt_thousand(fmt, s, i, b, o, t)); + for (; i > 3; i -= j) { + b = fmt_thousand(fmt, s, j = (i+2)%3+1, b, FALSE, t); + if (j != 3 || tempstr(fmt, s) != '0' || + tempstr(fmt, s+1) != '0' || tempstr(fmt, s+2) != '0') { + ecl_write_char(' ', fmt->stream); + writestr_stream(fmt_big_numeral[(i - 1)/3 - 1], + fmt->stream); + s += j; + if (o && s > t) + writestr_stream("th", fmt->stream); + } else + s += j; + } + return(fmt_thousand(fmt, s, i, b, o, t)); } static void fmt_roman(format_stack fmt, int i, int one, int five, int ten, bool colon) { - int j; + int j; - if (i == 0) - return; - if ((!colon && i < 4) || (colon && i < 5)) - for (j = 0; j < i; j++) - ecl_write_char(one, fmt->stream); - else if (!colon && i == 4) { - ecl_write_char(one, fmt->stream); - ecl_write_char(five, fmt->stream); - } else if ((!colon && i < 9) || colon) { - ecl_write_char(five, fmt->stream); - for (j = 5; j < i; j++) - ecl_write_char(one, fmt->stream); - } else if (!colon && i == 9) { - ecl_write_char(one, fmt->stream); - ecl_write_char(ten, fmt->stream); - } + if (i == 0) + return; + if ((!colon && i < 4) || (colon && i < 5)) + for (j = 0; j < i; j++) + ecl_write_char(one, fmt->stream); + else if (!colon && i == 4) { + ecl_write_char(one, fmt->stream); + ecl_write_char(five, fmt->stream); + } else if ((!colon && i < 9) || colon) { + ecl_write_char(five, fmt->stream); + for (j = 5; j < i; j++) + ecl_write_char(one, fmt->stream); + } else if (!colon && i == 9) { + ecl_write_char(one, fmt->stream); + ecl_write_char(ten, fmt->stream); + } } static void fmt_radix(format_stack fmt, bool colon, bool atsign) { - const cl_env_ptr env = ecl_process_env(); - int radix, mincol; - ecl_character padchar, commachar; - cl_object x; - int i, j, k; - int s, t; - bool b; + const cl_env_ptr env = ecl_process_env(); + int radix, mincol; + ecl_character padchar, commachar; + cl_object x; + int i, j, k; + int s, t; + bool b; - if (fmt->nparam == 0) { - x = fmt_advance(fmt); - assert_type_integer(x); - if (atsign) { - if (ECL_FIXNUMP(x)) - i = ecl_fixnum(x); - else - i = -1; - if ((!colon && (i <= 0 || i >= 4000)) || - (colon && (i <= 0 || i >= 5000))) { - fmt_integer(fmt, x, FALSE, FALSE, 10, 0, ' ', ','); - return; - } - fmt_roman(fmt, i/1000, 'M', '*', '*', colon); - fmt_roman(fmt, i%1000/100, 'C', 'D', 'M', colon); - fmt_roman(fmt, i%100/10, 'X', 'L', 'C', colon); - fmt_roman(fmt, i%10, 'I', 'V', 'X', colon); - return; - } - fmt_prepare_aux_stream(fmt); - ecl_bds_bind(env, @'*print-radix*', ECL_NIL); - ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(10)); - si_write_object(x, fmt->aux_stream); - ecl_bds_unwind_n(env, 2); - s = 0; - i = fmt->aux_string->base_string.fillp; - if (i == 1 && tempstr(fmt, s) == '0') { - writestr_stream("zero", fmt->stream); - if (colon) - writestr_stream("th", fmt->stream); - return; - } else if (tempstr(fmt, s) == '-') { - writestr_stream("minus ", fmt->stream); - --i; - s++; - } - t = fmt->aux_string->base_string.fillp; - for (; tempstr(fmt, --t) == '0' ;) ; - for (b = FALSE; i > 0; i -= j) { - b = fmt_nonillion(fmt, s, j = (i+29)%30+1, b, - i<=30&&colon, t); - s += j; - if (b && i > 30) { - for (k = (i - 1)/30; k > 0; --k) - writestr_stream(" nonillion", - fmt->stream); - if (colon && s > t) - writestr_stream("th", fmt->stream); - } - } - return; - } - ensure_param(fmt, 4); - radix = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(10))); - mincol = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(','))); - x = fmt_advance(fmt); - assert_type_integer(x); - if (radix < 0 || radix > 36) - FEerror("~D is illegal as a radix.", 1, ecl_make_fixnum(radix)); - fmt_integer(fmt, x, colon, atsign, radix, mincol, padchar, commachar); + if (fmt->nparam == 0) { + x = fmt_advance(fmt); + assert_type_integer(x); + if (atsign) { + if (ECL_FIXNUMP(x)) + i = ecl_fixnum(x); + else + i = -1; + if ((!colon && (i <= 0 || i >= 4000)) || + (colon && (i <= 0 || i >= 5000))) { + fmt_integer(fmt, x, FALSE, FALSE, 10, 0, ' ', ','); + return; + } + fmt_roman(fmt, i/1000, 'M', '*', '*', colon); + fmt_roman(fmt, i%1000/100, 'C', 'D', 'M', colon); + fmt_roman(fmt, i%100/10, 'X', 'L', 'C', colon); + fmt_roman(fmt, i%10, 'I', 'V', 'X', colon); + return; + } + fmt_prepare_aux_stream(fmt); + ecl_bds_bind(env, @'*print-radix*', ECL_NIL); + ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(10)); + si_write_object(x, fmt->aux_stream); + ecl_bds_unwind_n(env, 2); + s = 0; + i = fmt->aux_string->base_string.fillp; + if (i == 1 && tempstr(fmt, s) == '0') { + writestr_stream("zero", fmt->stream); + if (colon) + writestr_stream("th", fmt->stream); + return; + } else if (tempstr(fmt, s) == '-') { + writestr_stream("minus ", fmt->stream); + --i; + s++; + } + t = fmt->aux_string->base_string.fillp; + for (; tempstr(fmt, --t) == '0' ;) ; + for (b = FALSE; i > 0; i -= j) { + b = fmt_nonillion(fmt, s, j = (i+29)%30+1, b, + i<=30&&colon, t); + s += j; + if (b && i > 30) { + for (k = (i - 1)/30; k > 0; --k) + writestr_stream(" nonillion", + fmt->stream); + if (colon && s > t) + writestr_stream("th", fmt->stream); + } + } + return; + } + ensure_param(fmt, 4); + radix = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(10))); + mincol = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(','))); + x = fmt_advance(fmt); + assert_type_integer(x); + if (radix < 0 || radix > 36) + FEerror("~D is illegal as a radix.", 1, ecl_make_fixnum(radix)); + fmt_integer(fmt, x, colon, atsign, radix, mincol, padchar, commachar); } static void fmt_plural(format_stack fmt, bool colon, bool atsign) { - ensure_param(fmt, 0); - if (colon) { - fmt_back_up(fmt); - } - if (ecl_eql(fmt_advance(fmt), ecl_make_fixnum(1))) { - if (atsign) - ecl_write_char('y', fmt->stream); - } - else - if (atsign) - writestr_stream("ies", fmt->stream); - else - ecl_write_char('s', fmt->stream); + ensure_param(fmt, 0); + if (colon) { + fmt_back_up(fmt); + } + if (ecl_eql(fmt_advance(fmt), ecl_make_fixnum(1))) { + if (atsign) + ecl_write_char('y', fmt->stream); + } + else + if (atsign) + writestr_stream("ies", fmt->stream); + else + ecl_write_char('s', fmt->stream); } static void fmt_character(format_stack fmt, bool colon, bool atsign) { - cl_object x; - cl_index i; + cl_object x; + cl_index i; - ensure_param(fmt, 0); - x = fmt_advance(fmt); - x = ecl_check_cl_type(@'format',x,t_character); - if (!colon && !atsign) { - ecl_write_char(ECL_CHAR_CODE(x), fmt->stream); - } else { - fmt_prepare_aux_stream(fmt); - ecl_prin1(x, fmt->aux_stream); - if (!colon && atsign) - i = 0; - else - i = 2; - for (; i < fmt->aux_string->base_string.fillp; i++) - ecl_write_char(tempstr(fmt, i), fmt->stream); - } + ensure_param(fmt, 0); + x = fmt_advance(fmt); + x = ecl_check_cl_type(@'format',x,t_character); + if (!colon && !atsign) { + ecl_write_char(ECL_CHAR_CODE(x), fmt->stream); + } else { + fmt_prepare_aux_stream(fmt); + ecl_prin1(x, fmt->aux_stream); + if (!colon && atsign) + i = 0; + else + i = 2; + for (; i < fmt->aux_string->base_string.fillp; i++) + ecl_write_char(tempstr(fmt, i), fmt->stream); + } } /* The floating point precision is required to make the @@ -785,1465 +780,1465 @@ extern long double strtold(const char *nptr, char **endptr); static int edit_double(int n, DBL_TYPE d, int *sp, char *s, int *ep) { - char *exponent, buff[DBL_SIZE + 1]; - int length; + char *exponent, buff[DBL_SIZE + 1]; + int length; -ECL_WITHOUT_FPE_BEGIN { - unlikely_if (isnan(d) || !isfinite(d)) { - FEerror("Can't print a non-number.", 0); - } - if (n < -DBL_MAX_DIGITS) - n = DBL_MAX_DIGITS; - if (n < 0) { - DBL_TYPE aux; - n = -n; - do { - sprintf(buff, "%- *.*" EXP_STRING, n + 1 + 1 + DBL_EXPONENT_SIZE, n-1, d); - aux = strtod(buff, NULL); + ECL_WITHOUT_FPE_BEGIN { + unlikely_if (isnan(d) || !isfinite(d)) { + FEerror("Can't print a non-number.", 0); + } + if (n < -DBL_MAX_DIGITS) + n = DBL_MAX_DIGITS; + if (n < 0) { + DBL_TYPE aux; + n = -n; + do { + sprintf(buff, "%- *.*" EXP_STRING, n + 1 + 1 + DBL_EXPONENT_SIZE, n-1, d); + aux = strtod(buff, NULL); #ifdef ECL_LONG_FLOAT - if (n < LDBL_SIG) - aux = (double) aux; + if (n < LDBL_SIG) + aux = (double) aux; #endif - if (n < DBL_SIG) - aux = (float)aux; - n++; - } while (d != aux && n <= DBL_MAX_DIGITS); - n--; - } else { - sprintf(buff, "%- *.*" EXP_STRING, DBL_SIZE, - (n <= DBL_MAX_DIGITS)? (n-1) : (DBL_MAX_DIGITS-1), d); - } - exponent = strchr(buff, 'e'); + if (n < DBL_SIG) + aux = (float)aux; + n++; + } while (d != aux && n <= DBL_MAX_DIGITS); + n--; + } else { + sprintf(buff, "%- *.*" EXP_STRING, DBL_SIZE, + (n <= DBL_MAX_DIGITS)? (n-1) : (DBL_MAX_DIGITS-1), d); + } + exponent = strchr(buff, 'e'); - /* Get the exponent */ - *ep = strtol(exponent+1, NULL, 10); + /* Get the exponent */ + *ep = strtol(exponent+1, NULL, 10); - /* Get the sign */ - *sp = (buff[0] == '-') ? -1 : +1; + /* Get the sign */ + *sp = (buff[0] == '-') ? -1 : +1; - /* Get the digits of the mantissa */ - buff[2] = buff[1]; + /* Get the digits of the mantissa */ + buff[2] = buff[1]; - /* Get the actual number of digits in the mantissa */ - length = exponent - (buff + 2); + /* Get the actual number of digits in the mantissa */ + length = exponent - (buff + 2); - /* The output consists of a string {d1,d2,d3,...,dn} - with all N digits of the mantissa. If we ask for more - digits than there are, the last ones are set to zero. */ - if (n <= length) { - memcpy(s, buff+2, n); - } else { - cl_index i; - memcpy(s, buff+2, length); - for (i = length; i < n; i++) - s[i] = '0'; - } - s[n] = '\0'; -} ECL_WITHOUT_FPE_END; + /* The output consists of a string {d1,d2,d3,...,dn} + with all N digits of the mantissa. If we ask for more + digits than there are, the last ones are set to zero. */ + if (n <= length) { + memcpy(s, buff+2, n); + } else { + cl_index i; + memcpy(s, buff+2, length); + for (i = length; i < n; i++) + s[i] = '0'; + } + s[n] = '\0'; + } ECL_WITHOUT_FPE_END; - return length; + return length; } static void fmt_fix_float(format_stack fmt, bool colon, bool atsign) { - int w, d, k; - ecl_character overflowchar, padchar; - double f; - int sign; - char buff[256], *b, buff1[256]; - int exp; - int i, j; - cl_object x; - int n, m; + int w, d, k; + ecl_character overflowchar, padchar; + double f; + int sign; + char buff[256], *b, buff1[256]; + int exp; + int i, j; + cl_object x; + int n, m; - b = buff1 + 1; + b = buff1 + 1; - fmt_not_colon(fmt, colon); - ensure_param(fmt, 5); - w = set_param_positive(fmt, 0, "illegal width"); - d = set_param_positive(fmt, 1, "illegal number of digits"); - k = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - overflowchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR('\0'))); - padchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR(' '))); + fmt_not_colon(fmt, colon); + ensure_param(fmt, 5); + w = set_param_positive(fmt, 0, "illegal width"); + d = set_param_positive(fmt, 1, "illegal number of digits"); + k = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + overflowchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR('\0'))); + padchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR(' '))); - x = fmt_advance(fmt); - if (ECL_FIXNUMP(x) || - ecl_t_of(x) == t_bignum || - ecl_t_of(x) == t_ratio) - x = ecl_make_single_float(ecl_to_float(x)); - if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { - if (fmt->nparam > 1) fmt->nparam = 1; - fmt_back_up(fmt); - fmt_decimal(fmt, colon, atsign); - return; - } - if (ecl_t_of(x) == t_doublefloat) - n = 16; - else - n = 7; - f = ecl_to_double(x); - edit_double(n, f, &sign, buff, &exp); - if (exp + k > 100 || exp + k < -100 || d > 100) { - ecl_prin1(x, fmt->stream); - return; - } - if (d >= 0) - m = d + exp + k + 1; - else if (w >= 0) { - if (exp + k >= 0) - m = w - 1; - else - m = w + exp + k - 2; - if (sign < 0 || atsign) - --m; - if (m == 0) - m = 1; - } else - m = n; - if (m <= 0) { - if (m == 0 && buff[0] >= '5') { - exp++; - n = m = 1; - buff[0] = '1'; - } else - n = m = 0; - } else if (m < n) { - n = m; - edit_double(n, f, &sign, buff, &exp); - } - while (n >= 0) - if (buff[n - 1] == '0') - --n; - else - break; - exp += k; - j = 0; - if (exp >= 0) { - for (i = 0; i <= exp; i++) - b[j++] = i < n ? buff[i] : '0'; - b[j++] = '.'; - if (d >= 0) - for (m = i + d; i < m; i++) - b[j++] = i < n ? buff[i] : '0'; - else - for (; i < n; i++) - b[j++] = buff[i]; - } else { - b[j++] = '.'; - if (d >= 0) { - for (i = 0; i < (-exp) - 1 && i < d; i++) - b[j++] = '0'; - for (m = d - i, i = 0; i < m; i++) - b[j++] = i < n ? buff[i] : '0'; - } else if (n > 0) { - for (i = 0; i < (-exp) - 1; i++) - b[j++] = '0'; - for (i = 0; i < n; i++) - b[j++] = buff[i]; - } - } - b[j] = '\0'; - if (w >= 0) { - if (sign < 0 || atsign) - --w; - if (j > w && overflowchar != '\0') { - w = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - for (i = 0; i < w; i++) - ecl_write_char(overflowchar, fmt->stream); - return; - } - if (j < w && d < 0 && b[j-1] == '.') { - b[j++] = '0'; - b[j] = '\0'; - } - if (j < w && b[0] == '.') { - *--b = '0'; - j++; - } - for (i = j; i < w; i++) - ecl_write_char(padchar, fmt->stream); - } else { - if (b[0] == '.') { - *--b = '0'; - j++; - } - if (d < 0 && b[j-1] == '.') { - b[j++] = '0'; - b[j] = '\0'; - } - } - if (sign < 0) - ecl_write_char('-', fmt->stream); - else if (atsign) - ecl_write_char('+', fmt->stream); - writestr_stream(b, fmt->stream); + x = fmt_advance(fmt); + if (ECL_FIXNUMP(x) || + ecl_t_of(x) == t_bignum || + ecl_t_of(x) == t_ratio) + x = ecl_make_single_float(ecl_to_float(x)); + if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { + if (fmt->nparam > 1) fmt->nparam = 1; + fmt_back_up(fmt); + fmt_decimal(fmt, colon, atsign); + return; + } + if (ecl_t_of(x) == t_doublefloat) + n = 16; + else + n = 7; + f = ecl_to_double(x); + edit_double(n, f, &sign, buff, &exp); + if (exp + k > 100 || exp + k < -100 || d > 100) { + ecl_prin1(x, fmt->stream); + return; + } + if (d >= 0) + m = d + exp + k + 1; + else if (w >= 0) { + if (exp + k >= 0) + m = w - 1; + else + m = w + exp + k - 2; + if (sign < 0 || atsign) + --m; + if (m == 0) + m = 1; + } else + m = n; + if (m <= 0) { + if (m == 0 && buff[0] >= '5') { + exp++; + n = m = 1; + buff[0] = '1'; + } else + n = m = 0; + } else if (m < n) { + n = m; + edit_double(n, f, &sign, buff, &exp); + } + while (n >= 0) + if (buff[n - 1] == '0') + --n; + else + break; + exp += k; + j = 0; + if (exp >= 0) { + for (i = 0; i <= exp; i++) + b[j++] = i < n ? buff[i] : '0'; + b[j++] = '.'; + if (d >= 0) + for (m = i + d; i < m; i++) + b[j++] = i < n ? buff[i] : '0'; + else + for (; i < n; i++) + b[j++] = buff[i]; + } else { + b[j++] = '.'; + if (d >= 0) { + for (i = 0; i < (-exp) - 1 && i < d; i++) + b[j++] = '0'; + for (m = d - i, i = 0; i < m; i++) + b[j++] = i < n ? buff[i] : '0'; + } else if (n > 0) { + for (i = 0; i < (-exp) - 1; i++) + b[j++] = '0'; + for (i = 0; i < n; i++) + b[j++] = buff[i]; + } + } + b[j] = '\0'; + if (w >= 0) { + if (sign < 0 || atsign) + --w; + if (j > w && overflowchar != '\0') { + w = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + for (i = 0; i < w; i++) + ecl_write_char(overflowchar, fmt->stream); + return; + } + if (j < w && d < 0 && b[j-1] == '.') { + b[j++] = '0'; + b[j] = '\0'; + } + if (j < w && b[0] == '.') { + *--b = '0'; + j++; + } + for (i = j; i < w; i++) + ecl_write_char(padchar, fmt->stream); + } else { + if (b[0] == '.') { + *--b = '0'; + j++; + } + if (d < 0 && b[j-1] == '.') { + b[j++] = '0'; + b[j] = '\0'; + } + } + if (sign < 0) + ecl_write_char('-', fmt->stream); + else if (atsign) + ecl_write_char('+', fmt->stream); + writestr_stream(b, fmt->stream); } static int fmt_exponent_length(int e) { - int i; + int i; - if (e == 0) - return(1); - if (e < 0) - e = -e; - for (i = 0; e > 0; i++, e /= 10) - ; - return(i); + if (e == 0) + return(1); + if (e < 0) + e = -e; + for (i = 0; e > 0; i++, e /= 10) + ; + return(i); } static void fmt_exponent1(cl_object stream, int e) { - if (e == 0) - return; - fmt_exponent1(stream, e/10); - ecl_write_char('0' + e%10, stream); + if (e == 0) + return; + fmt_exponent1(stream, e/10); + ecl_write_char('0' + e%10, stream); } static void fmt_exponent(format_stack fmt, int e) { - if (e == 0) { - ecl_write_char('0', fmt->stream); - return; - } - if (e < 0) - e = -e; - fmt_exponent1(fmt->stream, e); + if (e == 0) { + ecl_write_char('0', fmt->stream); + return; + } + if (e < 0) + e = -e; + fmt_exponent1(fmt->stream, e); } static void fmt_exponential_float(format_stack fmt, bool colon, bool atsign) { - int w, d, e, k; - ecl_character overflowchar, padchar, exponentchar; - double f; - int sign; - char buff[256], *b, buff1[256]; - int exp; - int i, j; - cl_object x, y; - int n, m; - cl_type t; + int w, d, e, k; + ecl_character overflowchar, padchar, exponentchar; + double f; + int sign; + char buff[256], *b, buff1[256]; + int exp; + int i, j; + cl_object x, y; + int n, m; + cl_type t; - b = buff1 + 1; + b = buff1 + 1; - fmt_not_colon(fmt, colon); - ensure_param(fmt, 7); - w = set_param_positive(fmt, 0, "illegal width"); - d = set_param_positive(fmt, 1, "illegal number of digits"); - e = set_param_positive(fmt, 2, "illegal number of digits in exponent"); - k = ecl_to_fix(set_param(fmt, 3, INT, ecl_make_fixnum(1))); - overflowchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR('\0'))); - padchar = ECL_CHAR_CODE(set_param(fmt, 5, CHAR, ECL_CODE_CHAR(' '))); - exponentchar = ECL_CHAR_CODE(set_param(fmt, 6, CHAR, ECL_CODE_CHAR('\0'))); + fmt_not_colon(fmt, colon); + ensure_param(fmt, 7); + w = set_param_positive(fmt, 0, "illegal width"); + d = set_param_positive(fmt, 1, "illegal number of digits"); + e = set_param_positive(fmt, 2, "illegal number of digits in exponent"); + k = ecl_to_fix(set_param(fmt, 3, INT, ecl_make_fixnum(1))); + overflowchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR('\0'))); + padchar = ECL_CHAR_CODE(set_param(fmt, 5, CHAR, ECL_CODE_CHAR(' '))); + exponentchar = ECL_CHAR_CODE(set_param(fmt, 6, CHAR, ECL_CODE_CHAR('\0'))); - x = fmt_advance(fmt); - if (ECL_FIXNUMP(x) || - ecl_t_of(x) == t_bignum || - ecl_t_of(x) == t_ratio) - x = ecl_make_single_float(ecl_to_float(x)); - if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { - if (fmt->nparam > 1) fmt->nparam = 1; - fmt_back_up(fmt); - fmt_decimal(fmt, colon, atsign); - return; - } - if (ecl_t_of(x) == t_doublefloat) - n = 16; + x = fmt_advance(fmt); + if (ECL_FIXNUMP(x) || + ecl_t_of(x) == t_bignum || + ecl_t_of(x) == t_ratio) + x = ecl_make_single_float(ecl_to_float(x)); + if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { + if (fmt->nparam > 1) fmt->nparam = 1; + fmt_back_up(fmt); + fmt_decimal(fmt, colon, atsign); + return; + } + if (ecl_t_of(x) == t_doublefloat) + n = 16; + else + n = 7; + f = ecl_to_double(x); + edit_double(n, f, &sign, buff, &exp); + if (d >= 0) { + if (k > 0) { + if (!(k < d + 2)) + fmt_error(fmt, "illegal scale factor"); + m = d + 1; + } else { + if (!(k > -d)) + fmt_error(fmt, "illegal scale factor"); + m = d + k; + } + } else if (w >= 0) { + if (k > 0) + m = w - 1; + else + m = w + k - 1; + if (sign < 0 || atsign) + --m; + if (e >= 0) + m -= e + 2; + else + m -= fmt_exponent_length(e - k + 1) + 2; + } else + m = n; + if (m <= 0) { + if (m == 0 && buff[0] >= '5') { + exp++; + n = m = 1; + buff[0] = '1'; + } else + n = m = 0; + } else if (m < n) { + n = m; + edit_double(n, f, &sign, buff, &exp); + } + while (n >= 0) + if (buff[n - 1] == '0') + --n; + else + break; + exp = exp - k + 1; + j = 0; + if (k > 0) { + for (i = 0; i < k; i++) + b[j++] = i < n ? buff[i] : '0'; + b[j++] = '.'; + if (d >= 0) + for (m = i + (d - k + 1); i < m; i++) + b[j++] = i < n ? buff[i] : '0'; + else + for (; i < n; i++) + b[j++] = buff[i]; + } else { + b[j++] = '.'; + if (d >= 0) { + for (i = 0; i < -k && i < d; i++) + b[j++] = '0'; + for (m = d - i, i = 0; i < m; i++) + b[j++] = i < n ? buff[i] : '0'; + } else if (n > 0) { + for (i = 0; i < -k; i++) + b[j++] = '0'; + for (i = 0; i < n; i++) + b[j++] = buff[i]; + } + } + b[j] = '\0'; + if (w >= 0) { + if (sign < 0 || atsign) + --w; + i = fmt_exponent_length(exp); + if (e >= 0) { + if (i > e) { + if (overflowchar != '\0') + goto OVER; else - n = 7; - f = ecl_to_double(x); - edit_double(n, f, &sign, buff, &exp); - if (d >= 0) { - if (k > 0) { - if (!(k < d + 2)) - fmt_error(fmt, "illegal scale factor"); - m = d + 1; - } else { - if (!(k > -d)) - fmt_error(fmt, "illegal scale factor"); - m = d + k; - } - } else if (w >= 0) { - if (k > 0) - m = w - 1; - else - m = w + k - 1; - if (sign < 0 || atsign) - --m; - if (e >= 0) - m -= e + 2; - else - m -= fmt_exponent_length(e - k + 1) + 2; - } else - m = n; - if (m <= 0) { - if (m == 0 && buff[0] >= '5') { - exp++; - n = m = 1; - buff[0] = '1'; - } else - n = m = 0; - } else if (m < n) { - n = m; - edit_double(n, f, &sign, buff, &exp); - } - while (n >= 0) - if (buff[n - 1] == '0') - --n; - else - break; - exp = exp - k + 1; - j = 0; - if (k > 0) { - for (i = 0; i < k; i++) - b[j++] = i < n ? buff[i] : '0'; - b[j++] = '.'; - if (d >= 0) - for (m = i + (d - k + 1); i < m; i++) - b[j++] = i < n ? buff[i] : '0'; - else - for (; i < n; i++) - b[j++] = buff[i]; - } else { - b[j++] = '.'; - if (d >= 0) { - for (i = 0; i < -k && i < d; i++) - b[j++] = '0'; - for (m = d - i, i = 0; i < m; i++) - b[j++] = i < n ? buff[i] : '0'; - } else if (n > 0) { - for (i = 0; i < -k; i++) - b[j++] = '0'; - for (i = 0; i < n; i++) - b[j++] = buff[i]; - } - } - b[j] = '\0'; - if (w >= 0) { - if (sign < 0 || atsign) - --w; - i = fmt_exponent_length(exp); - if (e >= 0) { - if (i > e) { - if (overflowchar != '\0') - goto OVER; - else - e = i; - } - w -= e + 2; - } else - w -= i + 2; - if (j > w && overflowchar != '\0') - goto OVER; - if (j < w && b[0] == '.') { - *--b = '0'; - j++; - } - for (i = j; i < w; i++) - ecl_write_char(padchar, fmt->stream); - } else { - if (b[j-1] == '.') { - b[j++] = '0'; - b[j] = '\0'; - } - if (d < 0 && b[0] == '.') { - *--b = '0'; - j++; - } - } - if (sign < 0) - ecl_write_char('-', fmt->stream); - else if (atsign) - ecl_write_char('+', fmt->stream); - writestr_stream(b, fmt->stream); - y = ecl_symbol_value(@'*read-default-float-format*'); - if (exponentchar < 0) { - if (y == @'long-float') { + e = i; + } + w -= e + 2; + } else + w -= i + 2; + if (j > w && overflowchar != '\0') + goto OVER; + if (j < w && b[0] == '.') { + *--b = '0'; + j++; + } + for (i = j; i < w; i++) + ecl_write_char(padchar, fmt->stream); + } else { + if (b[j-1] == '.') { + b[j++] = '0'; + b[j] = '\0'; + } + if (d < 0 && b[0] == '.') { + *--b = '0'; + j++; + } + } + if (sign < 0) + ecl_write_char('-', fmt->stream); + else if (atsign) + ecl_write_char('+', fmt->stream); + writestr_stream(b, fmt->stream); + y = ecl_symbol_value(@'*read-default-float-format*'); + if (exponentchar < 0) { + if (y == @'long-float') { #ifdef ECL_LONG_FLOAT - t = t_longfloat; + t = t_longfloat; #else - t = t_doublefloat; + t = t_doublefloat; #endif - } else if (y == @'double-float') { - t = t_doublefloat; - } else if (y == @'single-float') { - t = t_singlefloat; - } else { - t = t_singlefloat; - } - if (ecl_t_of(x) == t) - exponentchar = 'E'; - else if (ecl_t_of(x) == t_singlefloat) - exponentchar = 'F'; + } else if (y == @'double-float') { + t = t_doublefloat; + } else if (y == @'single-float') { + t = t_singlefloat; + } else { + t = t_singlefloat; + } + if (ecl_t_of(x) == t) + exponentchar = 'E'; + else if (ecl_t_of(x) == t_singlefloat) + exponentchar = 'F'; #ifdef ECL_LONG_FLOAT - else if (ecl_t_of(x) == t_longfloat) - exponentchar = 'L'; + else if (ecl_t_of(x) == t_longfloat) + exponentchar = 'L'; #endif - else - exponentchar = 'D'; - } - ecl_write_char(exponentchar, fmt->stream); - if (exp < 0) - ecl_write_char('-', fmt->stream); - else - ecl_write_char('+', fmt->stream); - if (e >= 0) - for (i = e - fmt_exponent_length(exp); i > 0; --i) - ecl_write_char('0', fmt->stream); - fmt_exponent(fmt, exp); - return; + else + exponentchar = 'D'; + } + ecl_write_char(exponentchar, fmt->stream); + if (exp < 0) + ecl_write_char('-', fmt->stream); + else + ecl_write_char('+', fmt->stream); + if (e >= 0) + for (i = e - fmt_exponent_length(exp); i > 0; --i) + ecl_write_char('0', fmt->stream); + fmt_exponent(fmt, exp); + return; -OVER: - w = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - for (i = 0; i < w; i++) - ecl_write_char(overflowchar, fmt->stream); - return; + OVER: + w = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + for (i = 0; i < w; i++) + ecl_write_char(overflowchar, fmt->stream); + return; } static void fmt_general_float(format_stack fmt, bool colon, bool atsign) { - int w, d, e, k; - ecl_character overflowchar, padchar, exponentchar; - int sign, exp; - char buff[256]; - cl_object x; - int n, ee, ww, q, dd; + int w, d, e, k; + ecl_character overflowchar, padchar, exponentchar; + int sign, exp; + char buff[256]; + cl_object x; + int n, ee, ww, q, dd; - fmt_not_colon(fmt, colon); - ensure_param(fmt, 7); - w = set_param_positive(fmt, 0, "illegal width"); - d = set_param_positive(fmt, 1, "illegal number of digits"); - e = set_param_positive(fmt, 2, "illegal number of digits in exponent"); - k = ecl_to_fix(set_param(fmt, 3, INT, ecl_make_fixnum(1))); - overflowchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR('\0'))); - padchar = ECL_CHAR_CODE(set_param(fmt, 5, CHAR, ECL_CODE_CHAR(' '))); - exponentchar = ECL_CHAR_CODE(set_param(fmt, 6, CHAR, ECL_CODE_CHAR('\0'))); + fmt_not_colon(fmt, colon); + ensure_param(fmt, 7); + w = set_param_positive(fmt, 0, "illegal width"); + d = set_param_positive(fmt, 1, "illegal number of digits"); + e = set_param_positive(fmt, 2, "illegal number of digits in exponent"); + k = ecl_to_fix(set_param(fmt, 3, INT, ecl_make_fixnum(1))); + overflowchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR('\0'))); + padchar = ECL_CHAR_CODE(set_param(fmt, 5, CHAR, ECL_CODE_CHAR(' '))); + exponentchar = ECL_CHAR_CODE(set_param(fmt, 6, CHAR, ECL_CODE_CHAR('\0'))); - x = fmt_advance(fmt); - if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { - if (fmt->nparam > 1) fmt->nparam = 1; - fmt_back_up(fmt); - fmt_decimal(fmt, colon, atsign); - return; - } - if (ecl_t_of(x) == t_doublefloat) - q = 16; - else - q = 7; - edit_double(q, ecl_to_double(x), &sign, buff, &exp); - n = exp + 1; - while (q >= 0) - if (buff[q - 1] == '0') - --q; - else - break; - if (e >= 0) - ee = e + 2; - else - ee = 4; - ww = w - ee; - if (d < 0) { - d = n < 7 ? n : 7; - d = q > d ? q : d; - } - dd = d - n; - if (0 <= dd && dd <= d) { - fmt->nparam = 5; - fmt->param[0] = ecl_make_fixnum(ww); - fmt->param[1] = ecl_make_fixnum(dd); - fmt->param[2] = ECL_NIL; - fmt->param[3] = fmt->param[4]; - fmt->param[4] = fmt->param[5]; - fmt_back_up(fmt); - fmt_fix_float(fmt, colon, atsign); - if (w >= 0) - while (ww++ < w) - ecl_write_char(padchar, fmt->stream); - return; - } - fmt->param[1] = ecl_make_fixnum(d); - fmt_back_up(fmt); - fmt_exponential_float(fmt, colon, atsign); + x = fmt_advance(fmt); + if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { + if (fmt->nparam > 1) fmt->nparam = 1; + fmt_back_up(fmt); + fmt_decimal(fmt, colon, atsign); + return; + } + if (ecl_t_of(x) == t_doublefloat) + q = 16; + else + q = 7; + edit_double(q, ecl_to_double(x), &sign, buff, &exp); + n = exp + 1; + while (q >= 0) + if (buff[q - 1] == '0') + --q; + else + break; + if (e >= 0) + ee = e + 2; + else + ee = 4; + ww = w - ee; + if (d < 0) { + d = n < 7 ? n : 7; + d = q > d ? q : d; + } + dd = d - n; + if (0 <= dd && dd <= d) { + fmt->nparam = 5; + fmt->param[0] = ecl_make_fixnum(ww); + fmt->param[1] = ecl_make_fixnum(dd); + fmt->param[2] = ECL_NIL; + fmt->param[3] = fmt->param[4]; + fmt->param[4] = fmt->param[5]; + fmt_back_up(fmt); + fmt_fix_float(fmt, colon, atsign); + if (w >= 0) + while (ww++ < w) + ecl_write_char(padchar, fmt->stream); + return; + } + fmt->param[1] = ecl_make_fixnum(d); + fmt_back_up(fmt); + fmt_exponential_float(fmt, colon, atsign); } static void fmt_dollars_float(format_stack fmt, bool colon, bool atsign) { - int d, n, w; - ecl_character padchar; - double f; - int sign; - char buff[256]; - int exp; - int q, i; - cl_object x; + int d, n, w; + ecl_character padchar; + double f; + int sign; + char buff[256]; + int exp; + int q, i; + cl_object x; - ensure_param(fmt, 4); - d = set_param_positive(fmt, 0, "illegal number of digits"); - if (d < 0) d = 2; - n = set_param_positive(fmt, 1, "illegal number of digits"); - if (n < 0) n = 1; - w = set_param_positive(fmt, 2, "illegal width"); - if (w < 0) w = 0; - padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); - x = fmt_advance(fmt); - if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { - if (fmt->nparam < 3) - fmt->nparam = 0; - else { - fmt->nparam = 1; - fmt->param[0] = fmt->param[2]; - } - fmt_back_up(fmt); - fmt_decimal(fmt, colon, atsign); - return; - } - q = 7; - if (ecl_t_of(x) == t_doublefloat) - q = 16; - f = ecl_to_double(x); - edit_double(q, f, &sign, buff, &exp); - if ((q = exp + d + 1) > 0) - edit_double(q, f, &sign, buff, &exp); - exp++; - if (w > 100 || exp > 100 || exp < -100) { - fmt->nparam = 6; - fmt->param[0] = fmt->param[2]; - fmt->param[1] = ecl_make_fixnum(d + n - 1); - fmt->param[5] = fmt->param[3]; - fmt->param[2] = - fmt->param[3] = - fmt->param[4] = ECL_NIL; - fmt_back_up(fmt); - fmt_exponential_float(fmt, colon, atsign); - } - if (exp > n) - n = exp; - if (sign < 0 || atsign) - --w; - if (colon) { - if (sign < 0) - ecl_write_char('-', fmt->stream); - else if (atsign) - ecl_write_char('+', fmt->stream); - while (--w > n + d) - ecl_write_char(padchar, fmt->stream); - } else { - while (--w > n + d) - ecl_write_char(padchar, fmt->stream); - if (sign < 0) - ecl_write_char('-', fmt->stream); - else if (atsign) - ecl_write_char('+', fmt->stream); - } - for (i = n - exp; i > 0; --i) - ecl_write_char('0', fmt->stream); - for (i = 0; i < exp; i++) - ecl_write_char((i < q ? buff[i] : '0'), fmt->stream); - ecl_write_char('.', fmt->stream); - for (d += i; i < d; i++) - ecl_write_char((i < q ? buff[i] : '0'), fmt->stream); + ensure_param(fmt, 4); + d = set_param_positive(fmt, 0, "illegal number of digits"); + if (d < 0) d = 2; + n = set_param_positive(fmt, 1, "illegal number of digits"); + if (n < 0) n = 1; + w = set_param_positive(fmt, 2, "illegal width"); + if (w < 0) w = 0; + padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); + x = fmt_advance(fmt); + if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { + if (fmt->nparam < 3) + fmt->nparam = 0; + else { + fmt->nparam = 1; + fmt->param[0] = fmt->param[2]; + } + fmt_back_up(fmt); + fmt_decimal(fmt, colon, atsign); + return; + } + q = 7; + if (ecl_t_of(x) == t_doublefloat) + q = 16; + f = ecl_to_double(x); + edit_double(q, f, &sign, buff, &exp); + if ((q = exp + d + 1) > 0) + edit_double(q, f, &sign, buff, &exp); + exp++; + if (w > 100 || exp > 100 || exp < -100) { + fmt->nparam = 6; + fmt->param[0] = fmt->param[2]; + fmt->param[1] = ecl_make_fixnum(d + n - 1); + fmt->param[5] = fmt->param[3]; + fmt->param[2] = + fmt->param[3] = + fmt->param[4] = ECL_NIL; + fmt_back_up(fmt); + fmt_exponential_float(fmt, colon, atsign); + } + if (exp > n) + n = exp; + if (sign < 0 || atsign) + --w; + if (colon) { + if (sign < 0) + ecl_write_char('-', fmt->stream); + else if (atsign) + ecl_write_char('+', fmt->stream); + while (--w > n + d) + ecl_write_char(padchar, fmt->stream); + } else { + while (--w > n + d) + ecl_write_char(padchar, fmt->stream); + if (sign < 0) + ecl_write_char('-', fmt->stream); + else if (atsign) + ecl_write_char('+', fmt->stream); + } + for (i = n - exp; i > 0; --i) + ecl_write_char('0', fmt->stream); + for (i = 0; i < exp; i++) + ecl_write_char((i < q ? buff[i] : '0'), fmt->stream); + ecl_write_char('.', fmt->stream); + for (d += i; i < d; i++) + ecl_write_char((i < q ? buff[i] : '0'), fmt->stream); } static void fmt_percent(format_stack fmt, bool colon, bool atsign) { - int n, i; + int n, i; - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_not_colon(fmt, colon); - fmt_not_atsign(fmt, atsign); - while (n-- > 0) { - ecl_write_char('\n', fmt->stream); - if (n == 0) - for (i = fmt->indents; i > 0; --i) - ecl_write_char(' ', fmt->stream); - } + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_not_colon(fmt, colon); + fmt_not_atsign(fmt, atsign); + while (n-- > 0) { + ecl_write_char('\n', fmt->stream); + if (n == 0) + for (i = fmt->indents; i > 0; --i) + ecl_write_char(' ', fmt->stream); + } } static void fmt_ampersand(format_stack fmt, bool colon, bool atsign) { - int n; + int n; - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_not_colon(fmt, colon); - fmt_not_atsign(fmt, atsign); - if (n == 0) - return; - if (ecl_file_column(fmt->stream) != 0) - ecl_write_char('\n', fmt->stream); - while (--n > 0) - ecl_write_char('\n', fmt->stream); - fmt->indents = 0; + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_not_colon(fmt, colon); + fmt_not_atsign(fmt, atsign); + if (n == 0) + return; + if (ecl_file_column(fmt->stream) != 0) + ecl_write_char('\n', fmt->stream); + while (--n > 0) + ecl_write_char('\n', fmt->stream); + fmt->indents = 0; } static void fmt_bar(format_stack fmt, bool colon, bool atsign) { - int n; + int n; - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_not_colon(fmt, colon); - fmt_not_atsign(fmt, atsign); - while (n-- > 0) - ecl_write_char('\f', fmt->stream); + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_not_colon(fmt, colon); + fmt_not_atsign(fmt, atsign); + while (n-- > 0) + ecl_write_char('\f', fmt->stream); } static void fmt_tilde(format_stack fmt, bool colon, bool atsign) { - int n; + int n; - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_not_colon(fmt, colon); - fmt_not_atsign(fmt, atsign); - while (n-- > 0) - ecl_write_char('~', fmt->stream); + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_not_colon(fmt, colon); + fmt_not_atsign(fmt, atsign); + while (n-- > 0) + ecl_write_char('~', fmt->stream); } static void fmt_newline(format_stack fmt, bool colon, bool atsign) { - ensure_param(fmt, 0); - fmt_not_colon_atsign(fmt, colon, atsign); - if (atsign) - ecl_write_char('\n', fmt->stream); - while (fmt->ctl_index < fmt->ctl_end && isspace(ecl_char(fmt->ctl_str, fmt->ctl_index))) { - if (colon) - ecl_write_char(ecl_char(fmt->ctl_str, fmt->ctl_index), fmt->stream); - fmt->ctl_index++; - } + ensure_param(fmt, 0); + fmt_not_colon_atsign(fmt, colon, atsign); + if (atsign) + ecl_write_char('\n', fmt->stream); + while (fmt->ctl_index < fmt->ctl_end && isspace(ecl_char(fmt->ctl_str, fmt->ctl_index))) { + if (colon) + ecl_write_char(ecl_char(fmt->ctl_str, fmt->ctl_index), fmt->stream); + fmt->ctl_index++; + } } static void fmt_tabulate(format_stack fmt, bool colon, bool atsign) { - int colnum, colinc; - int c, i; + int colnum, colinc; + int c, i; - ensure_param(fmt, 2); - fmt_not_colon(fmt, colon); - colnum = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); - if (!atsign) { - c = ecl_file_column(fmt->stream); - if (c < 0) { - writestr_stream(" ", fmt->stream); - return; - } - if (c > colnum && colinc <= 0) - return; - while (c > colnum) - colnum += colinc; - for (i = colnum - c; i > 0; --i) - ecl_write_char(' ', fmt->stream); - } else { - for (i = colnum; i > 0; --i) - ecl_write_char(' ', fmt->stream); - c = ecl_file_column(fmt->stream); - if (c < 0 || colinc <= 0) - return; - colnum = 0; - while (c > colnum) - colnum += colinc; - for (i = colnum - c; i > 0; --i) - ecl_write_char(' ', fmt->stream); - } + ensure_param(fmt, 2); + fmt_not_colon(fmt, colon); + colnum = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); + if (!atsign) { + c = ecl_file_column(fmt->stream); + if (c < 0) { + writestr_stream(" ", fmt->stream); + return; + } + if (c > colnum && colinc <= 0) + return; + while (c > colnum) + colnum += colinc; + for (i = colnum - c; i > 0; --i) + ecl_write_char(' ', fmt->stream); + } else { + for (i = colnum; i > 0; --i) + ecl_write_char(' ', fmt->stream); + c = ecl_file_column(fmt->stream); + if (c < 0 || colinc <= 0) + return; + colnum = 0; + while (c > colnum) + colnum += colinc; + for (i = colnum - c; i > 0; --i) + ecl_write_char(' ', fmt->stream); + } } static void fmt_asterisk(format_stack fmt, bool colon, bool atsign) { - int n; + int n; - ensure_param(fmt, 1); - fmt_not_colon_atsign(fmt, colon, atsign); - if (atsign) { - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - fmt_go(fmt, n); - } else if (colon) { - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_go(fmt, fmt_index(fmt) - n); - } else { - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - while (n-- > 0) - fmt_advance(fmt); - } + ensure_param(fmt, 1); + fmt_not_colon_atsign(fmt, colon, atsign); + if (atsign) { + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + fmt_go(fmt, n); + } else if (colon) { + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_go(fmt, fmt_index(fmt) - n); + } else { + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + while (n-- > 0) + fmt_advance(fmt); + } } static void fmt_indirection(format_stack fmt, bool colon, bool atsign) { - cl_object s, l; - struct format_stack_struct fmt_old; - jmp_buf fmt_jmp_buf0; - int up_colon; + cl_object s, l; + struct format_stack_struct fmt_old; + jmp_buf fmt_jmp_buf0; + int up_colon; - ensure_param(fmt, 0); - fmt_not_colon(fmt, colon); - s = fmt_advance(fmt); - switch (ecl_t_of(s)) { + ensure_param(fmt, 0); + fmt_not_colon(fmt, colon); + s = fmt_advance(fmt); + switch (ecl_t_of(s)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - break; - default: - fmt_error(fmt, "control string expected"); - } - if (atsign) { - fmt_copy(&fmt_old, fmt); - fmt->jmp_buf = &fmt_jmp_buf0; - fmt->ctl_str = s; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - } else - format(fmt, 0, s->base_string.fillp); - fmt_copy1(fmt, &fmt_old); - } else { - l = fmt_advance(fmt); - fmt_copy(&fmt_old, fmt); - fmt_set_arg_list(fmt, l); - fmt->jmp_buf = &fmt_jmp_buf0; - fmt->ctl_str = s; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - } else - format(fmt, 0, s->base_string.fillp); - fmt_copy(fmt, &fmt_old); - } + case t_base_string: + break; + default: + fmt_error(fmt, "control string expected"); + } + if (atsign) { + fmt_copy(&fmt_old, fmt); + fmt->jmp_buf = &fmt_jmp_buf0; + fmt->ctl_str = s; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + } else + format(fmt, 0, s->base_string.fillp); + fmt_copy1(fmt, &fmt_old); + } else { + l = fmt_advance(fmt); + fmt_copy(&fmt_old, fmt); + fmt_set_arg_list(fmt, l); + fmt->jmp_buf = &fmt_jmp_buf0; + fmt->ctl_str = s; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + } else + format(fmt, 0, s->base_string.fillp); + fmt_copy(fmt, &fmt_old); + } } static void fmt_case(format_stack fmt, bool colon, bool atsign) { - cl_object x; - cl_index i; - int j; - ecl_character c; - struct format_stack_struct fmt_old; - jmp_buf fmt_jmp_buf0; - int up_colon; - bool b; + cl_object x; + cl_index i; + int j; + ecl_character c; + struct format_stack_struct fmt_old; + jmp_buf fmt_jmp_buf0; + int up_colon; + bool b; - x = ecl_make_string_output_stream(64, 1); - i = fmt->ctl_index; - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != ')' || ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~) expected"); - fmt_copy(&fmt_old, fmt); - fmt->stream = x; - fmt->jmp_buf = &fmt_jmp_buf0; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) - ; - else - format(fmt, i, j); - fmt_copy1(fmt, &fmt_old); - x = STRING_OUTPUT_STRING(x); - if (!colon && !atsign) - for (i = 0; i < x->base_string.fillp; i++) { - if (ecl_upper_case_p(c = ecl_char(x, i))) - c = ecl_char_downcase(c); - ecl_write_char(c, fmt->stream); - } - else if (colon && !atsign) - for (b = TRUE, i = 0; i < x->base_string.fillp; i++) { - if (ecl_lower_case_p(c = ecl_char(x, i))) { - if (b) - c = ecl_char_upcase(c); - b = FALSE; - } else if (ecl_upper_case_p(c)) { - if (!b) - c = ecl_char_downcase(c); - b = FALSE; - } else if (ecl_digitp(c,10) == -1) - b = TRUE; - ecl_write_char(c, fmt->stream); - } - else if (!colon && atsign) - for (b = TRUE, i = 0; i < x->base_string.fillp; i++) { - if (ecl_lower_case_p(c = ecl_char(x, i))) { - if (b) - c = ecl_char_upcase(c); - b = FALSE; - } else if (ecl_upper_case_p(c)) { - if (!b) - c = ecl_char_downcase(c); - b = FALSE; - } - ecl_write_char(c, fmt->stream); - } - else - for (i = 0; i < x->base_string.fillp; i++) { - if (ecl_lower_case_p(c = ecl_char(x, i))) - c = ecl_char_upcase(c); - ecl_write_char(c, fmt->stream); - } - if (up_colon) - ecl_longjmp(*fmt->jmp_buf, up_colon); + x = ecl_make_string_output_stream(64, 1); + i = fmt->ctl_index; + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != ')' || ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~) expected"); + fmt_copy(&fmt_old, fmt); + fmt->stream = x; + fmt->jmp_buf = &fmt_jmp_buf0; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) + ; + else + format(fmt, i, j); + fmt_copy1(fmt, &fmt_old); + x = STRING_OUTPUT_STRING(x); + if (!colon && !atsign) + for (i = 0; i < x->base_string.fillp; i++) { + if (ecl_upper_case_p(c = ecl_char(x, i))) + c = ecl_char_downcase(c); + ecl_write_char(c, fmt->stream); + } + else if (colon && !atsign) + for (b = TRUE, i = 0; i < x->base_string.fillp; i++) { + if (ecl_lower_case_p(c = ecl_char(x, i))) { + if (b) + c = ecl_char_upcase(c); + b = FALSE; + } else if (ecl_upper_case_p(c)) { + if (!b) + c = ecl_char_downcase(c); + b = FALSE; + } else if (ecl_digitp(c,10) == -1) + b = TRUE; + ecl_write_char(c, fmt->stream); + } + else if (!colon && atsign) + for (b = TRUE, i = 0; i < x->base_string.fillp; i++) { + if (ecl_lower_case_p(c = ecl_char(x, i))) { + if (b) + c = ecl_char_upcase(c); + b = FALSE; + } else if (ecl_upper_case_p(c)) { + if (!b) + c = ecl_char_downcase(c); + b = FALSE; + } + ecl_write_char(c, fmt->stream); + } + else + for (i = 0; i < x->base_string.fillp; i++) { + if (ecl_lower_case_p(c = ecl_char(x, i))) + c = ecl_char_upcase(c); + ecl_write_char(c, fmt->stream); + } + if (up_colon) + ecl_longjmp(*fmt->jmp_buf, up_colon); } static void fmt_conditional(format_stack fmt, bool colon, bool atsign) { - int i, j, k; - cl_object x; - int n; - bool done; - struct format_stack_struct fmt_old; + int i, j, k; + cl_object x; + int n; + bool done; + struct format_stack_struct fmt_old; - fmt_not_colon_atsign(fmt, colon, atsign); - if (colon) { - ensure_param(fmt, 0); - i = fmt->ctl_index; - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != ';' || ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~; expected"); - k = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --k) != ']' || ecl_char(fmt->ctl_str, --k) != '~') - fmt_error(fmt, "~~] expected"); - if (Null(fmt_advance(fmt))) { - fmt_copy(&fmt_old, fmt); - format(fmt, i, j); - fmt_copy1(fmt, &fmt_old); - } else { - fmt_copy(&fmt_old, fmt); - format(fmt, j + 2, k); - fmt_copy1(fmt, &fmt_old); - } - } else if (atsign) { - i = fmt->ctl_index; - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != ']' || ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~] expected"); - if (Null(fmt_advance(fmt))) - ; - else { - fmt_back_up(fmt); - fmt_copy(&fmt_old, fmt); - format(fmt, i, j); - fmt_copy1(fmt, &fmt_old); - } - } else { - ensure_param(fmt, 1); - if (fmt->nparam == 0) { - x = fmt_advance(fmt); - if (!ECL_FIXNUMP(x)) - fmt_error(fmt, "illegal argument for conditional"); - n = ecl_fixnum(x); - } else - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - i = fmt->ctl_index; - for (done = FALSE;; --n) { - j = fmt_skip(fmt); - for (k = j; ecl_char(fmt->ctl_str, --k) != '~';) - ; - if (n == 0) { - fmt_copy(&fmt_old, fmt); - format(fmt, i, k); - fmt_copy1(fmt, &fmt_old); - done = TRUE; - } - i = j; - if (ecl_char(fmt->ctl_str, --j) == ']') { - if (ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~] expected"); - return; - } - if (ecl_char(fmt->ctl_str, j) == ';') { - if (ecl_char(fmt->ctl_str, --j) == '~') - continue; - if (ecl_char(fmt->ctl_str, j) == ':') - goto ELSE; - } - fmt_error(fmt, "~~; or ~~] expected"); - } - ELSE: - if (ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~:; expected"); - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != ']' || ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~] expected"); - if (!done) { - fmt_copy(&fmt_old, fmt); - format(fmt, i, j); - fmt_copy1(fmt, &fmt_old); - } - } + fmt_not_colon_atsign(fmt, colon, atsign); + if (colon) { + ensure_param(fmt, 0); + i = fmt->ctl_index; + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != ';' || ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~; expected"); + k = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --k) != ']' || ecl_char(fmt->ctl_str, --k) != '~') + fmt_error(fmt, "~~] expected"); + if (Null(fmt_advance(fmt))) { + fmt_copy(&fmt_old, fmt); + format(fmt, i, j); + fmt_copy1(fmt, &fmt_old); + } else { + fmt_copy(&fmt_old, fmt); + format(fmt, j + 2, k); + fmt_copy1(fmt, &fmt_old); + } + } else if (atsign) { + i = fmt->ctl_index; + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != ']' || ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~] expected"); + if (Null(fmt_advance(fmt))) + ; + else { + fmt_back_up(fmt); + fmt_copy(&fmt_old, fmt); + format(fmt, i, j); + fmt_copy1(fmt, &fmt_old); + } + } else { + ensure_param(fmt, 1); + if (fmt->nparam == 0) { + x = fmt_advance(fmt); + if (!ECL_FIXNUMP(x)) + fmt_error(fmt, "illegal argument for conditional"); + n = ecl_fixnum(x); + } else + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + i = fmt->ctl_index; + for (done = FALSE;; --n) { + j = fmt_skip(fmt); + for (k = j; ecl_char(fmt->ctl_str, --k) != '~';) + ; + if (n == 0) { + fmt_copy(&fmt_old, fmt); + format(fmt, i, k); + fmt_copy1(fmt, &fmt_old); + done = TRUE; + } + i = j; + if (ecl_char(fmt->ctl_str, --j) == ']') { + if (ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~] expected"); + return; + } + if (ecl_char(fmt->ctl_str, j) == ';') { + if (ecl_char(fmt->ctl_str, --j) == '~') + continue; + if (ecl_char(fmt->ctl_str, j) == ':') + goto ELSE; + } + fmt_error(fmt, "~~; or ~~] expected"); + } + ELSE: + if (ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~:; expected"); + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != ']' || ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~] expected"); + if (!done) { + fmt_copy(&fmt_old, fmt); + format(fmt, i, j); + fmt_copy1(fmt, &fmt_old); + } + } } static void fmt_iteration(format_stack fmt, bool colon, bool atsign) { - int n, i; - volatile int j; - bool colon_close = FALSE; - cl_object l; - struct format_stack_struct fmt_old; - jmp_buf fmt_jmp_buf0; - int up_colon; + int n, i; + volatile int j; + bool colon_close = FALSE; + cl_object l; + struct format_stack_struct fmt_old; + jmp_buf fmt_jmp_buf0; + int up_colon; - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1000000))); - i = fmt->ctl_index; - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != '}') - fmt_error(fmt, "~~} expected"); - if (ecl_char(fmt->ctl_str, --j) == ':') { - colon_close = TRUE; - --j; - } - if (ecl_char(fmt->ctl_str, j) != '~') - fmt_error(fmt, "syntax error"); - if (!colon && !atsign) { - l = fmt_advance(fmt); - fmt_copy(&fmt_old, fmt); - fmt_set_arg_list(fmt, l); - fmt->jmp_buf = &fmt_jmp_buf0; - if (colon_close) - goto L1; - while (fmt_more_args_p(fmt)) { - L1: - if (n-- <= 0) - break; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - break; - } - format(fmt, i, j); - } - fmt_copy(fmt, &fmt_old); - } else if (colon && !atsign) { - int fl = 0; - volatile cl_object l0; - l0 = fmt_advance(fmt); - fmt_copy(&fmt_old, fmt); - for (l = l0; !ecl_endp(l); l = CDR(l)) - fl += ecl_length(CAR(l)); - fmt->jmp_buf = &fmt_jmp_buf0; - if (colon_close) - goto L2; - while (!ecl_endp(l0)) { - L2: - if (n-- <= 0) - break; - l = CAR(l0); - l0 = CDR(l0); - fmt_set_arg_list(fmt, l); - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - break; - else - continue; - } - format(fmt, i, j); - } - fmt_copy(fmt, &fmt_old); - } else if (!colon && atsign) { - fmt_copy(&fmt_old, fmt); - fmt->jmp_buf = &fmt_jmp_buf0; - if (colon_close) - goto L3; - while (fmt_more_args_p(fmt)) { - L3: - if (n-- <= 0) - break; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - break; - } - format(fmt, i, j); - } - fmt_copy1(fmt, &fmt_old); - } else if (colon && atsign) { - if (colon_close) - goto L4; - while (fmt_more_args_p(fmt)) { - L4: - if (n-- <= 0) - break; - l = fmt_advance(fmt); - fmt_copy(&fmt_old, fmt); - fmt_set_arg_list(fmt, l); - fmt->jmp_buf = &fmt_jmp_buf0; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - fmt_copy(fmt, &fmt_old); - if (--up_colon) - break; - else - continue; - } - format(fmt, i, j); - fmt_copy(fmt, &fmt_old); - } - } + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1000000))); + i = fmt->ctl_index; + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != '}') + fmt_error(fmt, "~~} expected"); + if (ecl_char(fmt->ctl_str, --j) == ':') { + colon_close = TRUE; + --j; + } + if (ecl_char(fmt->ctl_str, j) != '~') + fmt_error(fmt, "syntax error"); + if (!colon && !atsign) { + l = fmt_advance(fmt); + fmt_copy(&fmt_old, fmt); + fmt_set_arg_list(fmt, l); + fmt->jmp_buf = &fmt_jmp_buf0; + if (colon_close) + goto L1; + while (fmt_more_args_p(fmt)) { + L1: + if (n-- <= 0) + break; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + break; + } + format(fmt, i, j); + } + fmt_copy(fmt, &fmt_old); + } else if (colon && !atsign) { + int fl = 0; + volatile cl_object l0; + l0 = fmt_advance(fmt); + fmt_copy(&fmt_old, fmt); + for (l = l0; !ecl_endp(l); l = CDR(l)) + fl += ecl_length(CAR(l)); + fmt->jmp_buf = &fmt_jmp_buf0; + if (colon_close) + goto L2; + while (!ecl_endp(l0)) { + L2: + if (n-- <= 0) + break; + l = CAR(l0); + l0 = CDR(l0); + fmt_set_arg_list(fmt, l); + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + break; + else + continue; + } + format(fmt, i, j); + } + fmt_copy(fmt, &fmt_old); + } else if (!colon && atsign) { + fmt_copy(&fmt_old, fmt); + fmt->jmp_buf = &fmt_jmp_buf0; + if (colon_close) + goto L3; + while (fmt_more_args_p(fmt)) { + L3: + if (n-- <= 0) + break; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + break; + } + format(fmt, i, j); + } + fmt_copy1(fmt, &fmt_old); + } else if (colon && atsign) { + if (colon_close) + goto L4; + while (fmt_more_args_p(fmt)) { + L4: + if (n-- <= 0) + break; + l = fmt_advance(fmt); + fmt_copy(&fmt_old, fmt); + fmt_set_arg_list(fmt, l); + fmt->jmp_buf = &fmt_jmp_buf0; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + fmt_copy(fmt, &fmt_old); + if (--up_colon) + break; + else + continue; + } + format(fmt, i, j); + fmt_copy(fmt, &fmt_old); + } + } } static void fmt_justification(format_stack fmt, volatile bool colon, bool atsign) { - int mincol, colinc; - ecl_character minpad, padchar; - volatile cl_object fields; - cl_object p; - struct format_stack_struct fmt_old; - jmp_buf fmt_jmp_buf0; - volatile int i, j, k, l, m, j0, l0; - int up_colon; - volatile cl_object special = ECL_NIL; - volatile int spare_spaces, line_length; + int mincol, colinc; + ecl_character minpad, padchar; + volatile cl_object fields; + cl_object p; + struct format_stack_struct fmt_old; + jmp_buf fmt_jmp_buf0; + volatile int i, j, k, l, m, j0, l0; + int up_colon; + volatile cl_object special = ECL_NIL; + volatile int spare_spaces, line_length; - ensure_param(fmt, 4); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); - minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); + ensure_param(fmt, 4); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); + minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); - fields = ECL_NIL; - for (;;) { - cl_object this_field = ecl_make_string_output_stream(64, 1); - i = fmt->ctl_index; - j0 = j = fmt_skip(fmt); - while (ecl_char(fmt->ctl_str, --j) != '~') - ; + fields = ECL_NIL; + for (;;) { + cl_object this_field = ecl_make_string_output_stream(64, 1); + i = fmt->ctl_index; + j0 = j = fmt_skip(fmt); + while (ecl_char(fmt->ctl_str, --j) != '~') + ; - fmt_copy(&fmt_old, fmt); - fmt->jmp_buf = &fmt_jmp_buf0; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - fmt_copy1(fmt, &fmt_old); - while (ecl_char(fmt->ctl_str, --j0) != '>') - j0 = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j0) != '~') - fmt_error(fmt, "~~> expected"); - break; - } - fmt->stream = this_field; - format(fmt, i, j); - fields = CONS(STRING_OUTPUT_STRING(this_field), fields); - fmt_copy1(fmt, &fmt_old); + fmt_copy(&fmt_old, fmt); + fmt->jmp_buf = &fmt_jmp_buf0; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + fmt_copy1(fmt, &fmt_old); + while (ecl_char(fmt->ctl_str, --j0) != '>') + j0 = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j0) != '~') + fmt_error(fmt, "~~> expected"); + break; + } + fmt->stream = this_field; + format(fmt, i, j); + fields = CONS(STRING_OUTPUT_STRING(this_field), fields); + fmt_copy1(fmt, &fmt_old); - if (ecl_char(fmt->ctl_str, --j0) == '>') { - if (ecl_char(fmt->ctl_str, --j0) != '~') - fmt_error(fmt, "~~> expected"); - break; - } else if (ecl_char(fmt->ctl_str, j0) != ';') - fmt_error(fmt, "~~; expected"); - else if (ecl_char(fmt->ctl_str, --j0) == ':') { - if (ecl_length(fields) != 1 || !Null(special)) - fmt_error(fmt, "illegal ~~:;"); - special = CAR(fields); - fields = CDR(fields); - for (j = j0; ecl_char(fmt->ctl_str, j) != '~'; --j) - ; - fmt_copy(&fmt_old, fmt); - format(fmt, j, j0 + 2); - fmt_copy1(fmt, &fmt_old); - spare_spaces = fmt->spare_spaces; - line_length = fmt->line_length; - } else if (ecl_char(fmt->ctl_str, j0) != '~') - fmt_error(fmt, "~~; expected"); - } - /* - * Compute the length of items to be output. If the clause ~:; was - * found, the first item is not included. - */ - fields = cl_nreverse(fields); - for (p = fields, l = 0; p != ECL_NIL; p = CDR(p)) - l += CAR(p)->base_string.fillp; - /* - * Count the number of segments that need padding, "M". If the colon - * modifier, the first item needs padding. If the @@ modifier is - * present, the last modifier also needs padding. - */ - m = ecl_length(fields) - 1; - if (m <= 0 && !colon && !atsign) { - m = 0; - colon = TRUE; - } - if (colon) - m++; - if (atsign) - m++; - /* - * Count the minimal length in which the text fits. This length must - * the smallest integer of the form l = mincol + k * colinc. If the - * length exceeds the line length, the text before the ~:; is output - * first. - */ - l0 = l; - l += minpad * m; - for (k = 0; mincol + k * colinc < l; k++) - ; - l = mincol + k * colinc; - if (special != ECL_NIL && - ecl_file_column(fmt->stream) + l + spare_spaces > line_length) - ecl_princ(special, fmt->stream); - /* - * Output the text with the padding segments. The total number of - * padchars is kept in "l", and it is shared equally among all segments. - */ - l -= l0; - for (p = fields; p != ECL_NIL; p = CDR(p)) { - if (p != fields || colon) - for (j = l / m, l -= j, --m; j > 0; --j) - ecl_write_char(padchar, fmt->stream); - ecl_princ(CAR(p), fmt->stream); - } - if (atsign) - for (j = l; j > 0; --j) - ecl_write_char(padchar, fmt->stream); + if (ecl_char(fmt->ctl_str, --j0) == '>') { + if (ecl_char(fmt->ctl_str, --j0) != '~') + fmt_error(fmt, "~~> expected"); + break; + } else if (ecl_char(fmt->ctl_str, j0) != ';') + fmt_error(fmt, "~~; expected"); + else if (ecl_char(fmt->ctl_str, --j0) == ':') { + if (ecl_length(fields) != 1 || !Null(special)) + fmt_error(fmt, "illegal ~~:;"); + special = CAR(fields); + fields = CDR(fields); + for (j = j0; ecl_char(fmt->ctl_str, j) != '~'; --j) + ; + fmt_copy(&fmt_old, fmt); + format(fmt, j, j0 + 2); + fmt_copy1(fmt, &fmt_old); + spare_spaces = fmt->spare_spaces; + line_length = fmt->line_length; + } else if (ecl_char(fmt->ctl_str, j0) != '~') + fmt_error(fmt, "~~; expected"); + } + /* + * Compute the length of items to be output. If the clause ~:; was + * found, the first item is not included. + */ + fields = cl_nreverse(fields); + for (p = fields, l = 0; p != ECL_NIL; p = CDR(p)) + l += CAR(p)->base_string.fillp; + /* + * Count the number of segments that need padding, "M". If the colon + * modifier, the first item needs padding. If the @@ modifier is + * present, the last modifier also needs padding. + */ + m = ecl_length(fields) - 1; + if (m <= 0 && !colon && !atsign) { + m = 0; + colon = TRUE; + } + if (colon) + m++; + if (atsign) + m++; + /* + * Count the minimal length in which the text fits. This length must + * the smallest integer of the form l = mincol + k * colinc. If the + * length exceeds the line length, the text before the ~:; is output + * first. + */ + l0 = l; + l += minpad * m; + for (k = 0; mincol + k * colinc < l; k++) + ; + l = mincol + k * colinc; + if (special != ECL_NIL && + ecl_file_column(fmt->stream) + l + spare_spaces > line_length) + ecl_princ(special, fmt->stream); + /* + * Output the text with the padding segments. The total number of + * padchars is kept in "l", and it is shared equally among all segments. + */ + l -= l0; + for (p = fields; p != ECL_NIL; p = CDR(p)) { + if (p != fields || colon) + for (j = l / m, l -= j, --m; j > 0; --j) + ecl_write_char(padchar, fmt->stream); + ecl_princ(CAR(p), fmt->stream); + } + if (atsign) + for (j = l; j > 0; --j) + ecl_write_char(padchar, fmt->stream); } static void fmt_up_and_out(format_stack fmt, bool colon, bool atsign) { - int i, j, k; + int i, j, k; - ensure_param(fmt, 3); - fmt_not_atsign(fmt, atsign); - if (fmt->nparam == 0) { - if (!fmt_more_args_p(fmt)) - ecl_longjmp(*fmt->jmp_buf, ++colon); - } else if (fmt->nparam == 1) { - i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - if (i == 0) - ecl_longjmp(*fmt->jmp_buf, ++colon); - } else if (fmt->nparam == 2) { - i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - j = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); - if (i == j) - ecl_longjmp(*fmt->jmp_buf, ++colon); - } else { - i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - j = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); - k = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - if (i <= j && j <= k) - ecl_longjmp(*fmt->jmp_buf, ++colon); - } + ensure_param(fmt, 3); + fmt_not_atsign(fmt, atsign); + if (fmt->nparam == 0) { + if (!fmt_more_args_p(fmt)) + ecl_longjmp(*fmt->jmp_buf, ++colon); + } else if (fmt->nparam == 1) { + i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + if (i == 0) + ecl_longjmp(*fmt->jmp_buf, ++colon); + } else if (fmt->nparam == 2) { + i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + j = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); + if (i == j) + ecl_longjmp(*fmt->jmp_buf, ++colon); + } else { + i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + j = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); + k = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + if (i <= j && j <= k) + ecl_longjmp(*fmt->jmp_buf, ++colon); + } } static void fmt_semicolon(format_stack fmt, bool colon, bool atsign) { - fmt_not_atsign(fmt, atsign); - if (!colon) - fmt_error(fmt, "~~:; expected"); - ensure_param(fmt, 2); - fmt->spare_spaces = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - fmt->line_length = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(72))); + fmt_not_atsign(fmt, atsign); + if (!colon) + fmt_error(fmt, "~~:; expected"); + ensure_param(fmt, 2); + fmt->spare_spaces = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + fmt->line_length = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(72))); } @(defun si::formatter-aux (strm string &rest args) @ - @(return doformat(narg, strm, string, args, TRUE)) + @(return doformat(narg, strm, string, args, TRUE)) @) static cl_object doformat(cl_narg narg, cl_object strm, cl_object string, ecl_va_list args, bool in_formatter) { - struct format_stack_struct fmt; - jmp_buf fmt_jmp_buf0; - int colon; - cl_object output = cl_grab_rest_args(args); - while(!ecl_stringp(string)) + struct format_stack_struct fmt; + jmp_buf fmt_jmp_buf0; + int colon; + cl_object output = cl_grab_rest_args(args); + while(!ecl_stringp(string)) #ifdef ECL_UNICODE - string = ecl_type_error(@'format', "argument", string, @'string'); + string = ecl_type_error(@'format', "argument", string, @'string'); #else - string = ecl_type_error(@'format', "argument", string, @'base-string'); + string = ecl_type_error(@'format', "argument", string, @'base-string'); #endif - fmt.stream = strm; - fmt_set_arg_list(&fmt, output); - fmt.jmp_buf = &fmt_jmp_buf0; - if (ecl_symbol_value(@'si::*indent-formatted-output*') != ECL_NIL) - fmt.indents = ecl_file_column(strm); - else - fmt.indents = 0; - fmt.ctl_str = string; - fmt.aux_stream = get_aux_stream(); - fmt.aux_string = STRING_OUTPUT_STRING(fmt.aux_stream); - if ((colon = ecl_setjmp(*fmt.jmp_buf))) { - if (--colon) - fmt_error(&fmt, "illegal ~~:^"); - } else { - format(&fmt, 0, string->base_string.fillp); - ecl_force_output(strm); - } - ecl_process_env()->fmt_aux_stream = fmt.aux_stream; - if (!in_formatter) - output = ECL_NIL; - return output; + fmt.stream = strm; + fmt_set_arg_list(&fmt, output); + fmt.jmp_buf = &fmt_jmp_buf0; + if (ecl_symbol_value(@'si::*indent-formatted-output*') != ECL_NIL) + fmt.indents = ecl_file_column(strm); + else + fmt.indents = 0; + fmt.ctl_str = string; + fmt.aux_stream = get_aux_stream(); + fmt.aux_string = STRING_OUTPUT_STRING(fmt.aux_stream); + if ((colon = ecl_setjmp(*fmt.jmp_buf))) { + if (--colon) + fmt_error(&fmt, "illegal ~~:^"); + } else { + format(&fmt, 0, string->base_string.fillp); + ecl_force_output(strm); + } + ecl_process_env()->fmt_aux_stream = fmt.aux_stream; + if (!in_formatter) + output = ECL_NIL; + return output; } static void format(format_stack fmt, cl_index start, cl_index end) { - ecl_character c; - cl_index i, n; - bool colon, atsign; - cl_object x; + ecl_character c; + cl_index i, n; + bool colon, atsign; + cl_object x; - fmt->ctl_index = start; - fmt->ctl_end = end; + fmt->ctl_index = start; + fmt->ctl_end = end; -LOOP: - if (fmt->ctl_index >= fmt->ctl_end) - return; - if ((c = ctl_advance(fmt)) != '~') { - ecl_write_char(c, fmt->stream); - goto LOOP; - } - n = 0; - for (;;) { - switch (c = ctl_advance(fmt)) { - case ',': - fmt->param[n] = ECL_NIL; - break; + LOOP: + if (fmt->ctl_index >= fmt->ctl_end) + return; + if ((c = ctl_advance(fmt)) != '~') { + ecl_write_char(c, fmt->stream); + goto LOOP; + } + n = 0; + for (;;) { + switch (c = ctl_advance(fmt)) { + case ',': + fmt->param[n] = ECL_NIL; + break; - case '+': case '-': - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - i = fmt->ctl_index - 1; - do { - c = ctl_advance(fmt); - } while (ecl_digitp(c,10) != -1); - x = ecl_parse_integer(fmt->ctl_str, i, fmt->ctl_index, &i, 10); - INTEGER: - /* FIXME! A hack to solve the problem of bignums in arguments */ - if (x == OBJNULL || !ecl_numberp(x)) - fmt_error(fmt, "integer expected"); - if (ecl_number_compare(x, ecl_make_fixnum(FMT_VALUE_UPPER_LIMIT)) > 0) { - fmt->param[n] = ecl_make_fixnum(FMT_VALUE_UPPER_LIMIT); - } else if (ecl_number_compare(x, ecl_make_fixnum(FMT_VALUE_LOWER_LIMIT)) < 0) { - fmt->param[n] = ecl_make_fixnum(FMT_VALUE_LOWER_LIMIT); - } else { - fmt->param[n] = x; - } - if (ECL_FIXNUMP(x)) { - fmt->param[n] = x; - } else if (ecl_plusp(x)) { - fmt->param[n] = ecl_make_fixnum(MOST_POSITIVE_FIXNUM); - } else { - fmt->param[n] = ecl_make_fixnum(MOST_NEGATIVE_FIXNUM); - } - break; + case '+': case '-': + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + i = fmt->ctl_index - 1; + do { + c = ctl_advance(fmt); + } while (ecl_digitp(c,10) != -1); + x = ecl_parse_integer(fmt->ctl_str, i, fmt->ctl_index, &i, 10); + INTEGER: + /* FIXME! A hack to solve the problem of bignums in arguments */ + if (x == OBJNULL || !ecl_numberp(x)) + fmt_error(fmt, "integer expected"); + if (ecl_number_compare(x, ecl_make_fixnum(FMT_VALUE_UPPER_LIMIT)) > 0) { + fmt->param[n] = ecl_make_fixnum(FMT_VALUE_UPPER_LIMIT); + } else if (ecl_number_compare(x, ecl_make_fixnum(FMT_VALUE_LOWER_LIMIT)) < 0) { + fmt->param[n] = ecl_make_fixnum(FMT_VALUE_LOWER_LIMIT); + } else { + fmt->param[n] = x; + } + if (ECL_FIXNUMP(x)) { + fmt->param[n] = x; + } else if (ecl_plusp(x)) { + fmt->param[n] = ecl_make_fixnum(MOST_POSITIVE_FIXNUM); + } else { + fmt->param[n] = ecl_make_fixnum(MOST_NEGATIVE_FIXNUM); + } + break; - case '\'': - fmt->param[n] = ECL_CODE_CHAR(ctl_advance(fmt)); - c = ctl_advance(fmt); - break; + case '\'': + fmt->param[n] = ECL_CODE_CHAR(ctl_advance(fmt)); + c = ctl_advance(fmt); + break; - case 'v': case 'V': - x = fmt_advance(fmt); - c = ctl_advance(fmt); - if (ecl_t_of(x) == t_character) { - fmt->param[n] = x; - } else { - goto INTEGER; - } - break; + case 'v': case 'V': + x = fmt_advance(fmt); + c = ctl_advance(fmt); + if (ecl_t_of(x) == t_character) { + fmt->param[n] = x; + } else { + goto INTEGER; + } + break; - case '#': - fmt->param[n] = ecl_make_fixnum(fmt_args_left(fmt)); - c = ctl_advance(fmt); - break; + case '#': + fmt->param[n] = ecl_make_fixnum(fmt_args_left(fmt)); + c = ctl_advance(fmt); + break; - default: - if (n > 0) - fmt_error(fmt, "illegal ,"); - else - goto DIRECTIVE; - } - n++; - if (n == FMT_MAX_PARAM) - fmt_error(fmt, "too many parameters"); - if (c != ',') - break; - } + default: + if (n > 0) + fmt_error(fmt, "illegal ,"); + else + goto DIRECTIVE; + } + n++; + if (n == FMT_MAX_PARAM) + fmt_error(fmt, "too many parameters"); + if (c != ',') + break; + } -DIRECTIVE: - colon = atsign = FALSE; - if (c == ':') { - colon = TRUE; - c = ctl_advance(fmt); - } - if (c == '@@') { - atsign = TRUE; - c = ctl_advance(fmt); - } - fmt->nparam = n; - switch (c) { - case 'a': case 'A': - fmt_ascii(fmt, colon, atsign); - break; + DIRECTIVE: + colon = atsign = FALSE; + if (c == ':') { + colon = TRUE; + c = ctl_advance(fmt); + } + if (c == '@@') { + atsign = TRUE; + c = ctl_advance(fmt); + } + fmt->nparam = n; + switch (c) { + case 'a': case 'A': + fmt_ascii(fmt, colon, atsign); + break; - case 's': case 'S': - fmt_S_expression(fmt, colon, atsign); - break; + case 's': case 'S': + fmt_S_expression(fmt, colon, atsign); + break; - case 'd': case 'D': - fmt_decimal(fmt, colon, atsign); - break; + case 'd': case 'D': + fmt_decimal(fmt, colon, atsign); + break; - case 'b': case 'B': - fmt_binary(fmt, colon, atsign); - break; + case 'b': case 'B': + fmt_binary(fmt, colon, atsign); + break; - case 'o': case 'O': - fmt_octal(fmt, colon, atsign); - break; + case 'o': case 'O': + fmt_octal(fmt, colon, atsign); + break; - case 'x': case 'X': - fmt_hexadecimal(fmt, colon, atsign); - break; + case 'x': case 'X': + fmt_hexadecimal(fmt, colon, atsign); + break; - case 'r': case 'R': - fmt_radix(fmt, colon, atsign); - break; + case 'r': case 'R': + fmt_radix(fmt, colon, atsign); + break; - case 'p': case 'P': - fmt_plural(fmt, colon, atsign); - break; + case 'p': case 'P': + fmt_plural(fmt, colon, atsign); + break; - case 'c': case 'C': - fmt_character(fmt, colon, atsign); - break; + case 'c': case 'C': + fmt_character(fmt, colon, atsign); + break; - case 'f': case 'F': - fmt_fix_float(fmt, colon, atsign); - break; + case 'f': case 'F': + fmt_fix_float(fmt, colon, atsign); + break; - case 'e': case 'E': - fmt_exponential_float(fmt, colon, atsign); - break; + case 'e': case 'E': + fmt_exponential_float(fmt, colon, atsign); + break; - case 'g': case 'G': - fmt_general_float(fmt, colon, atsign); - break; + case 'g': case 'G': + fmt_general_float(fmt, colon, atsign); + break; - case '$': - fmt_dollars_float(fmt, colon, atsign); - break; + case '$': + fmt_dollars_float(fmt, colon, atsign); + break; - case '%': - fmt_percent(fmt, colon, atsign); - break; + case '%': + fmt_percent(fmt, colon, atsign); + break; - case '&': - fmt_ampersand(fmt, colon, atsign); - break; + case '&': + fmt_ampersand(fmt, colon, atsign); + break; - case '|': - fmt_bar(fmt, colon, atsign); - break; + case '|': + fmt_bar(fmt, colon, atsign); + break; - case '~': - fmt_tilde(fmt, colon, atsign); - break; + case '~': + fmt_tilde(fmt, colon, atsign); + break; - case '\n': - case '\r': - fmt_newline(fmt, colon, atsign); - break; + case '\n': + case '\r': + fmt_newline(fmt, colon, atsign); + break; - case 't': case 'T': - fmt_tabulate(fmt, colon, atsign); - break; + case 't': case 'T': + fmt_tabulate(fmt, colon, atsign); + break; - case '*': - fmt_asterisk(fmt, colon, atsign); - break; + case '*': + fmt_asterisk(fmt, colon, atsign); + break; - case '?': - fmt_indirection(fmt, colon, atsign); - break; + case '?': + fmt_indirection(fmt, colon, atsign); + break; - case '(': - fmt_case(fmt, colon, atsign); - break; + case '(': + fmt_case(fmt, colon, atsign); + break; - case '[': - fmt_conditional(fmt, colon, atsign); - break; + case '[': + fmt_conditional(fmt, colon, atsign); + break; - case '{': - fmt_iteration(fmt, colon, atsign); - break; + case '{': + fmt_iteration(fmt, colon, atsign); + break; - case '<': - fmt_justification(fmt, colon, atsign); - break; + case '<': + fmt_justification(fmt, colon, atsign); + break; - case '^': - fmt_up_and_out(fmt, colon, atsign); - break; + case '^': + fmt_up_and_out(fmt, colon, atsign); + break; - case ';': - fmt_semicolon(fmt, colon, atsign); - break; + case ';': + fmt_semicolon(fmt, colon, atsign); + break; - default: - fmt_error(fmt, "illegal directive"); - } - goto LOOP; + default: + fmt_error(fmt, "illegal directive"); + } + goto LOOP; } #endif /* !ECL_CMU_FORMAT */ @(defun format (strm string &rest args) - cl_object output = ECL_NIL; - int null_strm = 0; + cl_object output = ECL_NIL; + int null_strm = 0; @ - if (Null(strm)) { + if (Null(strm)) { #ifdef ECL_UNICODE - strm = ecl_alloc_adjustable_extended_string(64); + strm = ecl_alloc_adjustable_extended_string(64); #else - strm = ecl_alloc_adjustable_base_string(64); + strm = ecl_alloc_adjustable_base_string(64); #endif - null_strm = 1; - } else if (strm == ECL_T) { - strm = ecl_symbol_value(@'*standard-output*'); - } - if (ecl_stringp(strm)) { - output = strm; - if (!ECL_ARRAY_HAS_FILL_POINTER_P(output)) { - cl_error(7, @'si::format-error', - @':format-control', - make_constant_base_string( -"Cannot output to a non adjustable string."), - @':control-string', string, - @':offset', ecl_make_fixnum(0)); - } - strm = si_make_string_output_stream_from_string(strm); - if (null_strm == 0) - output = ECL_NIL; - } - if (!Null(cl_functionp(string))) { - cl_apply(3, string, strm, cl_grab_rest_args(args)); - } else { + null_strm = 1; + } else if (strm == ECL_T) { + strm = ecl_symbol_value(@'*standard-output*'); + } + if (ecl_stringp(strm)) { + output = strm; + if (!ECL_ARRAY_HAS_FILL_POINTER_P(output)) { + cl_error(7, @'si::format-error', + @':format-control', + make_constant_base_string( + "Cannot output to a non adjustable string."), + @':control-string', string, + @':offset', ecl_make_fixnum(0)); + } + strm = si_make_string_output_stream_from_string(strm); + if (null_strm == 0) + output = ECL_NIL; + } + if (!Null(cl_functionp(string))) { + cl_apply(3, string, strm, cl_grab_rest_args(args)); + } else { #ifdef ECL_CMU_FORMAT - _ecl_funcall4(@'si::formatter-aux', strm, string, - cl_grab_rest_args(args)); + _ecl_funcall4(@'si::formatter-aux', strm, string, + cl_grab_rest_args(args)); #else - doformat(narg, strm, string, args, FALSE); + doformat(narg, strm, string, args, FALSE); #endif - } - output = cl_copy_seq(output); - @(return output) + } + output = cl_copy_seq(output); + @(return output); @) diff --git a/src/doc/new-doc/developer-guide/sources.txi b/src/doc/new-doc/developer-guide/sources.txi index a223e73e0..a4ac104ff 100644 --- a/src/doc/new-doc/developer-guide/sources.txi +++ b/src/doc/new-doc/developer-guide/sources.txi @@ -57,3 +57,43 @@ auxiliaries used in compiled Lisp code @item compiler.d bytecode compiler + +@item disassembler.d +bytecodes disassembler utilities + +@item dpp.c +defun preprocessor + +@item ecl_constants.h +contstant values for all_symbols.d + +@item features.h +names of features compiled into ECL + +@item error.d +error handling + +@item eval.d +evaluation + +@item ffi/backtrace.d +C backtraces + +@item ffi/cdata.d +data for compiled files + +@item ffi/libraries.d +shared library and bundle opening / copying / closing + +@item ffi/mmap.d +mapping of binary files + +@item ffi.d +user defined data types and foreign functions interface + +@item file.d +file interface (implementation dependent) + +@item format.d +format (this isn't ANSI compliant, we need it for bootstrapping though) +