From 8417f93d2e895068e996780211c2aef8c851b5e6 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 31 Jul 2003 16:37:46 +0000 Subject: [PATCH] FORMATTER implemented. FORMAT ported from CMUCL and optionally included when --with-cmuformat is used at configuration time. --- src/CHANGELOG | 7 + src/bare.lsp.in | 2 +- src/c/all_symbols.d | 6 +- src/c/disassembler.d | 17 +- src/c/file.d | 6 + src/c/format.d | 83 +- src/c/load.d | 8 +- src/c/main.d | 11 +- src/c/num_co.d | 10 +- src/c/symbols_list.h | 10 + src/c/unixsys.d | 4 +- src/clos/combin.lsp | 3 +- src/clos/conditions.lsp | 21 +- src/clos/generic.lsp | 2 +- src/clos/standard.lsp | 1 - src/cmp/cmpdefs.lsp | 2 +- src/compile.lsp.in | 2 +- src/configure | 14 +- src/configure.in | 6 + src/h/config.h.in | 3 + src/h/external.h | 46 +- src/h/internal.h | 44 + src/lsp/defsys.lsp.in | 2 + src/lsp/format.lsp | 3017 +++++++++++++++++++++++++++++++++++++++ src/lsp/iolib.lsp | 5 + src/lsp/load.lsp.in | 62 +- src/lsp/predlib.lsp | 5 +- 27 files changed, 3266 insertions(+), 133 deletions(-) create mode 100644 src/lsp/format.lsp diff --git a/src/CHANGELOG b/src/CHANGELOG index 09af41b26..2be4514be 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1496,6 +1496,10 @@ ECLS 0.9b the file is not found using SEARCH-LIST, then the current directory is tried. + - Two implementations of FORMAT are supplied: the old one written in + C and a port of the code in CMUCL. The last one is selected with + the flag --with-cmuformat. + * ANSI compatibility: - DIRECTORY now understands :WILD, :UP, :WILD-INFERIORS, and, as an @@ -1543,6 +1547,9 @@ ECLS 0.9b been almost fully implemented. Still missing are the class redefinition and instance obsolence protocols. + - FORMATTER has been implemented, and ERROR/CERROR now accept as + "datum" the functions produced by FORMATTER. + TODO: ===== diff --git a/src/bare.lsp.in b/src/bare.lsp.in index f6354357c..acb775e63 100644 --- a/src/bare.lsp.in +++ b/src/bare.lsp.in @@ -14,7 +14,7 @@ ;;; * Load Common-Lisp base library ;;; (if (member "ECL-MIN" *features* :test #'string-equal) - (load "@abs_builddir@/lsp/load.lsp")) + (load "@abs_builddir@/lsp/load.lsp" :verbose nil)) (defun si::process-command-args () ) ;;; diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index 501149d33..1ccae9aea 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -72,9 +72,9 @@ mangle_name(cl_object output, char *source, int l) p = (cl_symbol_initializer*)symbol - cl_symbols; if (p >= 0 && p <= cl_num_symbols_in_core) { found = Ct; - output = @format(3, Cnil, - make_constant_string("((cl_object)(cl_symbols+~A))"), - MAKE_FIXNUM(p)); + output = cl_format(3, Cnil, + make_constant_string("((cl_object)(cl_symbols+~A))"), + MAKE_FIXNUM(p)); @(return found output maxarg) } } else { diff --git a/src/c/disassembler.d b/src/c/disassembler.d index a18cf3520..838322e36 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -260,11 +260,13 @@ disassemble_msetq(cl_object *vector) } else newline = TRUE; if (FIXNUMP(var)) { - @format(4, Ct, make_constant_string("MSETQ\t~D,VALUES(~D)"), - var, MAKE_FIXNUM(i)); + cl_format(4, Ct, + make_constant_string("MSETQ\t~D,VALUES(~D)"), + var, MAKE_FIXNUM(i)); } else { - @format(4, Ct, make_constant_string("MSETQS\t~A,VALUES(~D)"), - var, MAKE_FIXNUM(i)); + cl_format(4, Ct, + make_constant_string("MSETQS\t~A,VALUES(~D)"), + var, MAKE_FIXNUM(i)); } } return vector; @@ -307,8 +309,9 @@ disassemble_tagbody(cl_object *vector) { print_noarg("TAGBODY"); for (i=0; i #include "internal.h" +#ifndef ECL_CMU_FORMAT #define FMT_MAX_PARAM 8 typedef struct format_stack_struct { cl_object stream; @@ -89,15 +90,16 @@ get_aux_stream(void) } end_critical_section(); return stream; -} +} static void fmt_error(format_stack fmt, const char *s) { - FEerror("Format error: ~A.~%~V@@TV~%\"~A\"~%", - 3, make_constant_string(s), - MAKE_FIXNUM(&fmt->ctl_str[fmt->ctl_index] - (char *)fmt->string->string.self), - fmt->string); + cl_error(7, @'si::format-error', + @':format-control', make_constant_string(s), + @':control-string', fmt->string, + @':offset', MAKE_FIXNUM(&fmt->ctl_str[fmt->ctl_index] - + (char *)fmt->string->string.self)); } static int @@ -1770,25 +1772,18 @@ fmt_semicolon(format_stack fmt, bool colon, bool atsign) fmt->line_length = set_param(fmt, 1, INT, 72); } -@(defun format (strm string &rest args) - cl_object x = OBJNULL; +@(defun si::formatter-aux (strm string &rest args) +@ + @(return doformat(narg, strm, string, args, TRUE)) +@) + + +static cl_object +doformat(int narg, cl_object strm, cl_object string, cl_va_list args, bool in_formatter) +{ struct format_stack_struct fmt; jmp_buf fmt_jmp_buf0; int colon; -@ - if (Null(strm)) { - strm = make_string_output_stream(64); - x = strm->stream.object0; - } else if (strm == Ct) - strm = symbol_value(@'*standard-output*'); - else if (type_of(strm) == t_string) { - x = strm; - if (!x->string.hasfillp) - FEerror("The string ~S doesn't have a fill-pointer.", 1, x); - strm = make_string_output_stream(0); - strm->stream.object0 = x; - x = OBJNULL; - } assert_type_string(string); fmt.stream = strm; fmt.base = cl_stack_index(); @@ -1813,8 +1808,15 @@ fmt_semicolon(format_stack fmt, bool colon, bool atsign) } cl_stack_set_index(fmt.base); fmt_aux_stream = fmt.aux_stream; - @(return (x == OBJNULL? Cnil : x)) -@) + args = Cnil; + if (in_formatter) { + while (fmt.index < fmt.end) { + args = CONS(cl_stack[fmt.index++], args); + } + args = cl_nreverse(args); + } + return args; +} static void format(format_stack fmt, const char *str, cl_index end) @@ -2046,3 +2048,38 @@ init_format(void) SYM_VAL(@'si::*indent-formatted-output*') = Cnil; } +#endif /* !ECL_CMU_FORMAT */ + +@(defun format (strm string &rest args) + cl_object output = Cnil; +@ + if (Null(strm)) { + strm = cl_alloc_adjustable_string(64); + } else if (strm == Ct) { + strm = symbol_value(@'*standard-output*'); + } + if (type_of(strm) == t_string) { + output = strm; + if (!output->string.hasfillp) { + cl_error(7, @'si::format-error', + @':format-control', + make_constant_string( +"Cannot output to a non adjustable string."), + @':control-string', string, + @':offset', MAKE_FIXNUM(0)); + } + strm = make_string_output_stream(0); + strm->stream.object0 = output; + } + if (!Null(cl_functionp(string))) { + cl_apply(3, string, strm, cl_grab_rest_args(args)); + } else { +#ifdef ECL_CMU_FORMAT + cl_funcall(4, @'si::formatter-aux', strm, string, + cl_grab_rest_args(args)); +#else + doformat(narg, strm, string, args, FALSE); +#endif + } + @(return output) +@) diff --git a/src/c/load.d b/src/c/load.d index 885a4f37a..775503421 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -182,8 +182,8 @@ si_load_source(cl_object source, cl_object verbose, cl_object print) } NOT_A_FILENAME: if (verbose != Cnil) { - @fresh-line(0); - @format(3, Ct, make_simple_string(";;; Loading ~s~%"), filename); + cl_format(3, Ct, make_simple_string("~&;;; Loading ~s~%"), + filename); } bds_bind(@'*package*', symbol_value(@'*package*')); bds_bind(@'*load-pathname*', pathname); @@ -197,8 +197,8 @@ NOT_A_FILENAME: FEerror("LOAD: Could not load file ~S (Error: ~S)", 2, filename, ok); if (print != Cnil) { - @fresh-line(0); - @format(3, Ct, make_simple_string(";;; Loading ~s~%"), filename); + cl_format(3, Ct, make_simple_string("~&;;; Loading ~s~%"), + filename); } @(return pathname) @) diff --git a/src/c/main.d b/src/c/main.d index 7fc7e5935..5f00db9e0 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -116,7 +116,9 @@ cl_boot(int argc, char **argv) init_multival(); init_cmpaux(); init_main(); +#ifndef ECL_CMU_FORMAT init_format(); +#endif init_interrupt(); #ifdef RUNTIME SYM_VAL(@'*features*') = CONS(make_keyword("RUNTIME"), SYM_VAL(@'*features*')); @@ -217,8 +219,8 @@ si_setenv(cl_object var, cl_object value) ret_val = setenv(var->string.self, value->string.self, 1); #else cl_object temp = - cl_format(4, Cnil, make_simple_string("~A=~A"), - var, value); + cl_format(4, Cnil, make_simple_string("~A=~A"), var, + value); putenv(temp->string.self); #endif } @@ -267,11 +269,9 @@ init_main(void) #ifdef PDE ADD_FEATURE("PDE"); #endif - #ifdef ECL_FFI ADD_FEATURE("FFI"); #endif - #ifdef unix ADD_FEATURE("UNIX"); #endif @@ -284,6 +284,9 @@ init_main(void) #ifdef MSDOS ADD_FEATURE("MS-DOS"); #endif +#ifdef ECL_CMU_FORMAT + ADD_FEATURE("CMU-FORMAT"); +#endif /* This is assumed in all systems */ ADD_FEATURE("IEEE-FLOATING-POINT"); diff --git a/src/c/num_co.d b/src/c/num_co.d index a9c8a41ac..10adf2940 100644 --- a/src/c/num_co.d +++ b/src/c/num_co.d @@ -722,7 +722,7 @@ cl_decode_float(cl_object x) s = 0; } d = frexp(d, &e); - x = make_shortfloat(d); + x = make_longfloat(d); break; } default: @@ -760,7 +760,7 @@ cl_float_radix(cl_object x) if (t != t_shortfloat && t != t_longfloat) FEtype_error_float(x); - @(return MAKE_FIXNUM(2)) + @(return MAKE_FIXNUM(FLT_RADIX)) } @(defun float_sign (x &optional (y x)) @@ -793,10 +793,10 @@ cl_float_digits(cl_object x) { switch (type_of(x)) { case t_shortfloat: - x = MAKE_FIXNUM(6); + x = MAKE_FIXNUM(FLT_MANT_DIG); break; case t_longfloat: - x = MAKE_FIXNUM(14); + x = MAKE_FIXNUM(DBL_MANT_DIG); break; default: FEtype_error_float(x); @@ -810,8 +810,10 @@ cl_float_precision(cl_object x) switch (type_of(x)) { case t_shortfloat: x = (sf(x) == 0.0) ? MAKE_FIXNUM(0) : MAKE_FIXNUM(24); + break; case t_longfloat: x = (lf(x) == 0.0) ? MAKE_FIXNUM(0) : MAKE_FIXNUM(53); + break; default: FEtype_error_float(x); } diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 40879f613..8b918bbd5 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -5,6 +5,9 @@ struct { const char *name, *translation; } #else +#ifndef ECL_CMU_FORMAT +extern cl_object si_formatter_aux _ARGS((int narg, cl_object strm, cl_object string, ...)); +#endif #define SYS_ #define KEY_ cl_symbol_initializer @@ -395,6 +398,7 @@ cl_symbols[] = { {"FMAKUNBOUND", CL_ORDINARY, cl_fmakunbound, 1}, {"FORCE-OUTPUT", CL_ORDINARY, cl_force_output, -1}, {"FORMAT", CL_ORDINARY, cl_format, -1}, +{"FORMATTER", CL_ORDINARY, NULL, -1}, {"FOURTH", CL_ORDINARY, cl_cadddr, 1}, {"FRESH-LINE", CL_ORDINARY, cl_fresh_line, -1}, {"FROUND", CL_ORDINARY, NULL, -1}, @@ -1052,6 +1056,8 @@ cl_symbols[] = { {SYS_ "FILE-KIND", SI_ORDINARY, si_file_kind, 2}, {SYS_ "FILL-POINTER-SET", SI_ORDINARY, si_fill_pointer_set, 2}, {SYS_ "FIXNUMP", SI_ORDINARY, si_fixnump, 1}, +{SYS_ "FORMAT-ERROR", SI_ORDINARY, NULL, -1}, +{SYS_ "FORMATTER-AUX", SI_ORDINARY, si_formatter_aux, -1}, {SYS_ "FRS-BDS", SI_ORDINARY, si_frs_bds, 1}, {SYS_ "FRS-CLASS", SI_ORDINARY, si_frs_class, 1}, {SYS_ "FRS-IHS", SI_ORDINARY, si_frs_ihs, 1}, @@ -1256,6 +1262,7 @@ cl_symbols[] = { {KEY_ "CATCHALL", KEYWORD, NULL, -1}, {KEY_ "CIRCLE", KEYWORD, NULL, -1}, {KEY_ "COMPILE-TOPLEVEL", KEYWORD, NULL, -1}, +{KEY_ "CONTROL-STRING", CL_ORDINARY, NULL, -1}, {KEY_ "CREATE", KEYWORD, NULL, -1}, {KEY_ "DATUM", KEYWORD, NULL, -1}, {KEY_ "DEFAULT", KEYWORD, NULL, -1}, @@ -1297,6 +1304,7 @@ cl_symbols[] = { {KEY_ "NEWEST", KEYWORD, NULL, -1}, {KEY_ "NICKNAMES", KEYWORD, NULL, -1}, {KEY_ "OBJECT", KEYWORD, NULL, -1}, +{KEY_ "OFFSET", KEYWORD, NULL, -1}, {KEY_ "OUTPUT", KEYWORD, NULL, -1}, {KEY_ "OVERWRITE", KEYWORD, NULL, -1}, {KEY_ "PACKAGE", KEYWORD, NULL, -1}, @@ -1367,6 +1375,8 @@ cl_symbols[] = { {KEY_ "LINK", KEYWORD, NULL, -1}, {KEY_ "SPECIAL", KEYWORD, NULL, -1}, +{SYS_ "FILE-COLUMN", SI_ORDINARY, si_file_column, 1}, + /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1}}; diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 9817f836c..a83a24e19 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -25,8 +25,8 @@ si_system(cl_object cmd) volatile int code; assert_type_string(cmd); - s = cmd->string.self; - code = system((const char *)s); + cmd = copy_simple_string(cmd); + code = system((const char *)(cmd->string.self)); /* FIXME! Are there any limits for system()? */ /* if (cmd->string.fillp >= 1024) FEerror("Too long command line: ~S.", 1, cmd);*/ diff --git a/src/clos/combin.lsp b/src/clos/combin.lsp index d5dc2bcc6..de0ebcc0a 100644 --- a/src/clos/combin.lsp +++ b/src/clos/combin.lsp @@ -326,7 +326,6 @@ (defun define-simple-method-combination (name &key documentation identity-with-one-argument (operator name)) - (declare (si::c-local)) `(define-method-combination ,name (&optional (order :MOST-SPECIFIC-FIRST)) ((around (:AROUND)) @@ -349,7 +348,7 @@ (declare (si::c-local)) (flet ((syntax-error () (error "~S is not a valid DEFINE-METHOD-COMBINATION form" - whole))) + form))) (destructuring-bind (name lambda-list method-groups &rest body &aux (group-names '()) (group-checks '()) diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index bb09c8293..05116ae63 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -435,7 +435,7 @@ strings." datum) ((symbolp datum) ;roughly, (subtypep datum 'CONDITION) (apply #'make-condition datum arguments)) - ((stringp datum) + ((or (stringp datum) (functionp datum)) (make-condition default-type :FORMAT-CONTROL datum :FORMAT-ARGUMENTS arguments)) @@ -608,6 +608,25 @@ returns with NIL." ;;; (define-condition simple-program-error (simple-condition program-error) ()) +(define-condition format-error (error) + ((control-string :reader format-error-control-string + :initarg :control-string + #+cmu-format :initform + #+cmu-format *default-format-error-control-string*) + (offset :reader format-error-offset :initarg :offset + #+cmu-format :initform + #+cmu-format *default-format-error-offset*) + (print-banner :reader format-error-print-banner :initarg :print-banner + :initform t)) + (:report (lambda (condition stream) + (cl:format stream + "~:[~;Error in format: ~]~ + ~?~@[~% ~A~% ~V@T^~]" + (format-error-print-banner condition) + (simple-error-format-control condition) + (simple-error-format-arguments condition) + (format-error-control-string condition) + (format-error-offset condition))))) (defmacro handler-case (form &rest cases) diff --git a/src/clos/generic.lsp b/src/clos/generic.lsp index 94ba29e51..589a17f9c 100644 --- a/src/clos/generic.lsp +++ b/src/clos/generic.lsp @@ -215,7 +215,7 @@ option" l))))) (defun parse-legal-declaration (decl) - (declare (si::c-local)) + ;(declare (si::c-local)) (unless (eq (first decl) 'OPTIMIZE) (error "The only declaration allowed is optimize")) (dolist (first (rest decl)) diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index 9b37b9583..36c342c13 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -261,7 +261,6 @@ a class metaobject, use REDEFINE-CLASS instead.")) (defun help-ensure-class (&rest options &key (metaclass 'standard-class) direct-superclasses &allow-other-keys) - (declare (si::c-local)) (remf options :metaclass) (remf options :direct-superclasses) (setf metaclass (coerce-to-class metaclass) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index a0ce190c8..d5824959a 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -286,7 +286,7 @@ The default value is NIL.") ;;; though &optional, &rest, and &key return types are simply ignored. ;;; (defvar *function-declarations* nil) -(defvar *allow-c-local-declaration* nil) +(defvar *allow-c-local-declaration* t) (defvar *alien-declarations* nil) (defvar *notinline* nil) diff --git a/src/compile.lsp.in b/src/compile.lsp.in index 73e18ff45..f78e468e8 100644 --- a/src/compile.lsp.in +++ b/src/compile.lsp.in @@ -11,7 +11,7 @@ ;;; ;;; * Ensure that we have the whole of Common-Lisp to compile ;;; -(load "bare.lsp") +(load "bare.lsp" :verbose nil) ;;; ;;; * Dump documentation diff --git a/src/configure b/src/configure index 64aafc086..7342e1ce4 100755 --- a/src/configure +++ b/src/configure @@ -869,6 +869,7 @@ Optional Packages: --with-gmp=args Configure supplied GMP library with arguments. --with-config-file=f Supply configuration for a cross compiler. --with-oldloop Use the old MIT LOOP macro. +--with-cmuformat Use the FORMAT routine from CMUCL. --with-clos-streams Allow user defined stream objects. --with-ffi Run-time foreign data manipulation. --with-x use the X Window System @@ -1454,6 +1455,12 @@ if test "${with_oldloop+set}" = set; then oldloop="yes" fi; +# Check whether --with-cmuformat or --without-cmuformat was given. +if test "${with_cmuformat+set}" = set; then + withval="$with_cmuformat" + cmuformat="yes" +fi; + # Check whether --with-clos-streams or --without-clos-streams was given. if test "${with_clos_streams+set}" = set; then withval="$with_clos_streams" @@ -3860,7 +3867,6 @@ case "${host_os}" in ;; esac CFLAGS="${CFLAGS} -D${thehost}" -echo ${CFLAGS} echo "$as_me:$LINENO: checking for ld flags when building shared libraries" >&5 echo $ECHO_N "checking for ld flags when building shared libraries... $ECHO_C" >&6 if test "${shared}" = "yes"; then @@ -4133,6 +4139,12 @@ if test "${oldloop}"; then #define ECL_OLD_LOOP 1 _ACEOF +fi +if test "${cmuformat}"; then + cat >>confdefs.h <<\_ACEOF +#define ECL_CMU_FORMAT 1 +_ACEOF + fi if test "${closstreams}"; then cat >>confdefs.h <<\_ACEOF diff --git a/src/configure.in b/src/configure.in index 490acf9f7..ba9c5561c 100644 --- a/src/configure.in +++ b/src/configure.in @@ -85,6 +85,9 @@ AC_ARG_ENABLE(shared, AC_ARG_WITH(oldloop, [--with-oldloop Use the old MIT LOOP macro.], oldloop="yes") +AC_ARG_WITH(cmuformat, + [--with-cmuformat Use the FORMAT routine from CMUCL.], + cmuformat="yes") AC_ARG_WITH(clos-streams, [--with-clos-streams Allow user defined stream objects.], closstreams="yes") @@ -208,6 +211,9 @@ fi if test "${oldloop}"; then AC_DEFINE(ECL_OLD_LOOP) fi +if test "${cmuformat}"; then + AC_DEFINE(ECL_CMU_FORMAT) +fi if test "${closstreams}"; then AC_DEFINE(ECL_CLOS_STREAMS) fi diff --git a/src/h/config.h.in b/src/h/config.h.in index 22155a1d3..3f1f4a1c7 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -122,6 +122,9 @@ typedef unsigned @CL_FIXNUM_TYPE@ cl_hashkey; /* Allow STREAM operations to work on arbitrary objects */ #undef ECL_CLOS_STREAMS +/* Use CMU Common-Lisp's FORMAT routine */ +#undef ECL_CMU_FORMAT + /* * SYSTEM FEATURES: */ diff --git a/src/h/external.h b/src/h/external.h index f88684173..1b70985cf 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -55,7 +55,6 @@ extern void *cl_alloc_align(cl_index size, cl_index align); #define cl_alloc_atomic_align(x,s) cl_alloc_align(x,s) #define ecl_register_static_root(x) ecl_register_root(x); #endif /* GBC_BOEHM */ -extern void init_alloc(void); /* all_symbols */ @@ -72,7 +71,6 @@ typedef union { } cl_symbol_initializer; extern cl_symbol_initializer cl_symbols[]; extern cl_index cl_num_symbols_in_core; -extern void init_all_symbols(void); /* apply.c */ @@ -111,7 +109,6 @@ extern void array_allocself(cl_object x); extern void adjust_displaced(cl_object x, ptrdiff_t diff); extern cl_elttype array_elttype(cl_object x); extern cl_elttype get_elttype(cl_object x); -extern void init_array(void); /* assignment.c */ @@ -125,13 +122,6 @@ extern cl_object si_put_sysprop(cl_object sym, cl_object prop, cl_object value); extern cl_object si_rem_sysprop(cl_object sym, cl_object prop); extern void clear_compiler_properties(cl_object sym); -extern void init_assignment(void); - - -/* backq.c */ - -extern void init_backq(void); - /* big.c */ @@ -150,7 +140,6 @@ extern cl_object big_plus(cl_object x, cl_object y); extern cl_object big_normalize(cl_object x); extern double big_to_double(cl_object x); extern long big_to_long(cl_object x); -extern void init_big(void); /* cfun.c */ @@ -208,7 +197,6 @@ extern int char_cmp(cl_object x, cl_object y); extern bool char_equal(cl_object x, cl_object y); extern int char_compare(cl_object x, cl_object y); extern short digit_weight(int w, int r); -extern void init_character(void); /* clos.c */ @@ -218,7 +206,6 @@ extern cl_object cl_find_class _ARGS((int narg, cl_object name, ...)); extern cl_object class_class; extern cl_object class_object; extern cl_object class_built_in; -extern void init_clos(void); #endif /* cmpaux.c */ @@ -239,7 +226,6 @@ extern void cl_go(cl_object tag_id, cl_object label) __attribute__((noreturn,reg extern void cl_parse_key(cl_va_list args, int nkey, cl_object *keys, cl_object *vars, cl_object *rest, bool allow_other_keys); extern cl_object cl_grab_rest_args(cl_va_list args); extern void check_other_key(cl_object l, int n, ...); -extern void init_cmpaux(void); /* compiler.c */ @@ -252,7 +238,6 @@ extern cl_object si_process_declarations _ARGS((int narg, cl_object body, ...)); extern cl_object make_lambda(cl_object name, cl_object lambda); extern cl_object eval(cl_object form, cl_object *bytecodes, cl_object env); -extern void init_compiler(void); /* interpreter.c */ @@ -273,7 +258,6 @@ extern void cl_stack_pop_values(int n); extern cl_object lex_env; extern cl_object lambda_apply(int narg, cl_object fun); extern cl_object *interpret(cl_object *memory); -extern void init_interpreter(void); /* disassembler.c */ @@ -311,7 +295,6 @@ extern cl_object CEerror(char *err_str, int narg, ...); extern void illegal_index(cl_object x, cl_object i); extern void FEtype_error_symbol(cl_object obj) __attribute__((noreturn,regparm(2))); extern void FElibc_error(const char *msg, int narg, ...) __attribute__((noreturn)); -extern void init_error(void); /* eval.c */ @@ -332,7 +315,6 @@ extern cl_object cl_constantp(int narg, cl_object arg, ...); extern cl_object cl_apply_from_stack(cl_index narg, cl_object fun); extern cl_object link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list args); extern cl_object cl_safe_eval(cl_object form, cl_object *bytecodes, cl_object env, cl_object err_value); -extern void init_eval(void); /* ffi.c */ @@ -368,6 +350,7 @@ extern cl_object cl_open _ARGS((int narg, cl_object filename, ...)); extern cl_object cl_file_position _ARGS((int narg, cl_object file_stream, ...)); extern cl_object si_do_write_sequence(cl_object string, cl_object stream, cl_object start, cl_object end); extern cl_object si_do_read_sequence(cl_object string, cl_object stream, cl_object start, cl_object end); +extern cl_object si_file_column(cl_object strm); extern bool input_stream_p(cl_object strm); extern bool output_stream_p(cl_object strm); @@ -394,14 +377,11 @@ extern long file_position(cl_object strm); extern long file_position_set(cl_object strm, long disp); extern long file_length(cl_object strm); extern int file_column(cl_object strm); -extern void init_file(void); /* format.c */ -extern cl_object cl_format _ARGS((int narg, volatile cl_object strm, cl_object string, ...)); -extern void init_format(void); - +extern cl_object cl_format _ARGS((int narg, cl_object stream, cl_object string, ...)); /* gbc.c */ @@ -418,7 +398,6 @@ extern cl_object (*GC_enter_hook)(void); extern cl_object (*GC_exit_hook)(void); extern void ecl_register_root(cl_object *p); extern void ecl_gc(cl_type t); -extern void init_GC(void); #endif #ifdef GBC_BOEHM @@ -462,7 +441,6 @@ extern cl_hashkey hash_eql(cl_object x); extern cl_hashkey hash_equal(cl_object x); extern void sethash(cl_object key, cl_object hashtable, cl_object value); extern void extend_hashtable(cl_object hashtable); -extern void init_hash(void); extern cl_object gethash(cl_object key, cl_object hash); extern cl_object gethash_safe(cl_object key, cl_object hash, cl_object def); extern bool remhash(cl_object key, cl_object hash); @@ -594,8 +572,6 @@ extern cl_object si_load_source(cl_object file, cl_object verbose, cl_object pri extern cl_object si_load_binary(cl_object file, cl_object verbose, cl_object print); extern cl_object cl_load _ARGS((int narg, cl_object pathname, ...)); -extern void init_load(void); - /* lwp.c */ #ifdef THREADS @@ -641,7 +617,6 @@ extern cl_object cl_macroexpand_1 _ARGS((int narg, cl_object form, ...)); extern cl_object search_macro(cl_object name, cl_object env); extern cl_object macro_expand1(cl_object form, cl_object env); extern cl_object macro_expand(cl_object form, cl_object env); -extern void init_macros(void); /* main.c */ @@ -672,7 +647,6 @@ extern cl_object cl_mapcon _ARGS((int narg, cl_object fun, ...)); extern cl_object cl_values_list(cl_object list); extern cl_object cl_values _ARGS((int narg, ...)); -extern void init_multival(void); /* num_arith.c */ @@ -713,8 +687,6 @@ extern cl_object make_shortfloat(float f); extern cl_object make_longfloat(double f); extern cl_object make_complex(cl_object r, cl_object i); extern double number_to_double(cl_object x); -extern void init_number(void); - /* num_co.c */ @@ -748,7 +720,6 @@ extern cl_object floor2(cl_object x, cl_object y); extern cl_object ceiling2(cl_object x, cl_object y); extern cl_object truncate2(cl_object x, cl_object y); extern cl_object round2(cl_object x, cl_object y); -extern void init_num_co(void); /* num_comp.c */ @@ -764,7 +735,6 @@ extern cl_object cl_min _ARGS((int narg, cl_object min, ...)); extern int number_equalp(cl_object x, cl_object y); extern int number_compare(cl_object x, cl_object y); -extern void init_num_comp(void); /* num_log.c */ @@ -788,7 +758,6 @@ extern cl_object cl_logand _ARGS((int narg, ...)); extern cl_object cl_logeqv _ARGS((int narg, ...)); extern cl_object ecl_ash(cl_object x, cl_fixnum w); -extern void init_num_log(void); /* num_pred.c */ @@ -812,7 +781,6 @@ extern cl_object cl_random_state_p(cl_object x); extern cl_object cl_random _ARGS((int narg, cl_object x, ...)); extern cl_object cl_make_random_state _ARGS((int narg, ...)); extern cl_object make_random_state(cl_object rs); -extern void init_num_rand(void); /* num_sfun.c */ @@ -836,7 +804,6 @@ extern cl_object cl_cosh(cl_object x); extern cl_object cl_tanh(cl_object x); extern cl_object cl_atan _ARGS((int narg, cl_object x, ...)); extern cl_object cl_log _ARGS((int narg, cl_object x, ...)); -extern void init_num_sfun(void); /* package.c */ @@ -886,7 +853,6 @@ extern void shadowing_import(cl_object s, cl_object p); extern void shadow(cl_object s, cl_object p); extern void use_package(cl_object x0, cl_object p); extern void unuse_package(cl_object x0, cl_object p); -extern void init_package(void); /* pathname.c */ @@ -922,7 +888,6 @@ extern cl_object coerce_to_file_pathname(cl_object pathname); extern cl_object coerce_to_filename(cl_object pathname); extern cl_object merge_pathnames(cl_object path, cl_object defaults, cl_object default_version); extern bool logical_hostname_p(cl_object host); -extern void init_pathname(void); /* predicate.c */ @@ -988,7 +953,6 @@ extern cl_object terpri(cl_object strm); extern void write_string(cl_object strng, cl_object strm); extern void princ_str(const char *s, cl_object sym); extern void princ_char(int c, cl_object sym); -extern void init_print(void); /* profile.c */ @@ -1039,7 +1003,6 @@ extern cl_object ecl_current_readtable(void); extern int ecl_current_read_base(void); extern char ecl_current_read_default_float_format(void); extern cl_object c_string_to_object(const char *s); -extern void init_read(void); extern cl_object read_VV(cl_object block, void *entry); @@ -1098,7 +1061,6 @@ extern void unwind(frame_ptr fr) __attribute__((noreturn,regparm(2))); extern frame_ptr frs_sch(cl_object frame_id); extern frame_ptr frs_sch_catch(cl_object frame_id); extern cl_object new_frame_id(void); -extern void init_stacks(int *); /* string.c */ @@ -1195,7 +1157,6 @@ extern cl_object symbol_value(cl_object s); extern cl_object ecl_getf(cl_object place, cl_object indicator, cl_object deflt); extern cl_object ecl_get(cl_object s, cl_object p, cl_object d); extern bool keywordp(cl_object s); -extern void init_symbol(void); /* tclBasic.c */ @@ -1254,7 +1215,6 @@ extern cl_object si_get_local_time_zone(); extern cl_object si_daylight_saving_time_p _ARGS((int narg, ...)); extern cl_object UTC_time_to_universal_time(cl_fixnum i); -extern void init_unixtime(void); /* tkMain.c */ @@ -1292,7 +1252,6 @@ extern void assert_type_vector(cl_object p); extern void assert_type_list(cl_object p); extern void assert_type_proper_list(cl_object p); extern cl_object cl_type_of(cl_object x); -extern void init_typespec(void); extern void FEtype_error_character(cl_object x) __attribute__((noreturn,regparm(2))); extern void FEtype_error_cons(cl_object x) __attribute__((noreturn,regparm(2))); @@ -1338,7 +1297,6 @@ extern int interrupt_enable; extern int interrupt_flag; extern void signal_catcher(int sig, int code, int scp); extern void enable_interrupt(void); -extern void init_interrupt(void); /* unixsys.c */ diff --git a/src/h/internal.h b/src/h/internal.h index eabb6395c..6b9d768bf 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -20,6 +20,50 @@ extern "C" { * FUNCTIONS, VARIABLES AND TYPES NOT FOR GENERAL USE * * -------------------------------------------------------------------- */ +/* booting */ +extern void init_all_symbols(void); +extern void init_alloc(void); +extern void init_array(void); +extern void init_assignment(void); +extern void init_backq(void); +extern void init_big(void); +extern void init_character(void); +#ifdef CLOS +extern void init_clos(void); +#endif +extern void init_cmpaux(void); +extern void init_compiler(void); +extern void init_error(void); +extern void init_eval(void); +extern void init_file(void); +#ifndef ECL_CMU_FORMAT +extern void init_format(void); +#endif +#ifndef GBC_BOEHM +extern void init_GC(void); +#endif +extern void init_hash(void); +extern void init_interpreter(void); +extern void init_load(void); +extern void init_macros(void); +extern void init_multival(void); +extern void init_number(void); +extern void init_num_co(void); +extern void init_num_comp(void); +extern void init_num_log(void); +extern void init_num_rand(void); +extern void init_num_sfun(void); +extern void init_package(void); +extern void init_pathname(void); +extern void init_print(void); +extern void init_read(void); +extern void init_stacks(int *); +extern void init_symbol(void); +extern void init_unixtime(void); +extern void init_typespec(void); +extern void init_interrupt(void); + + /* all_symbols.d */ extern cl_index cl_num_symbols_in_core; diff --git a/src/lsp/defsys.lsp.in b/src/lsp/defsys.lsp.in index 09601758f..e7d5d5f2a 100644 --- a/src/lsp/defsys.lsp.in +++ b/src/lsp/defsys.lsp.in @@ -32,6 +32,8 @@ (loop () () ()) #-old-loop (loop2 () () ()) +#+cmu-format + (format () () ()) (defpackage () () ()) (ffi () () ()) #-runtime diff --git a/src/lsp/format.lsp b/src/lsp/format.lsp new file mode 100644 index 000000000..89249ae4f --- /dev/null +++ b/src/lsp/format.lsp @@ -0,0 +1,3017 @@ +;;; -*- Package: FORMAT -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +;;; +;;; ********************************************************************** +;;; +;;; Functions to implement FORMAT and FORMATTER for CMU Common Lisp. +;;; +;;; Written by William Lott, with lots of stuff stolen from the previous +;;; version by David Adam and later rewritten by Bill Maddox. +;;; + +(in-package "SYS") + +(eval-when (compile eval) + +#+ecl-min +(defmacro handler-bind (bindings &body body) + `(progn ,@body)) + +;;;; The Once-Only macro: + +;;; Once-Only -- Interface +;;; +;;; Once-Only is a utility useful in writing source transforms and macros. +;;; It provides an easy way to wrap a let around some code to ensure that some +;;; forms are only evaluated once. +;;; +(defmacro once-only (specs &body body) + "Once-Only ({(Var Value-Expression)}*) Form* + Create a Let* which evaluates each Value-Expression, binding a temporary + variable to the result, and wrapping the Let* around the result of the + evaluation of Body. Within the body, each Var is bound to the corresponding + temporary variable." + (labels ((frob (specs body) + (if (null specs) + `(progn ,@body) + (let ((spec (first specs))) + (when (/= (length spec) 2) + (error "Malformed Once-Only binding spec: ~S." spec)) + (let ((name (first spec)) + (exp-temp (gensym))) + `(let ((,exp-temp ,(second spec)) + (,name (gensym "OO-"))) + `(let ((,,name ,,exp-temp)) + ,,(frob (rest specs) body)))))))) + (frob specs body))) + +;;;; The Collect macro: + +;;; Collect-Normal-Expander -- Internal +;;; +;;; This function does the real work of macroexpansion for normal collection +;;; macros. N-Value is the name of the variable which holds the current +;;; value. Fun is the function which does collection. Forms is the list of +;;; forms whose values we are supposed to collect. +;;; +(defun collect-normal-expander (n-value fun forms) + `(progn + ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms) + ,n-value)) + +;;; Collect-List-Expander -- Internal +;;; +;;; This function deals with the list collection case. N-Tail is the pointer +;;; to the current tail of the list, which is NIL if the list is empty. +;;; +(defun collect-list-expander (n-value n-tail forms) + (let ((n-res (gensym))) + `(progn + ,@(mapcar #'(lambda (form) + `(let ((,n-res (cons ,form nil))) + (cond (,n-tail + (setf (cdr ,n-tail) ,n-res) + (setq ,n-tail ,n-res)) + (t + (setq ,n-tail ,n-res ,n-value ,n-res))))) + forms) + ,n-value))) + + +;;; Collect -- Public +;;; +;;; The ultimate collection macro... +;;; +(defmacro collect (collections &body body) + "Collect ({(Name [Initial-Value] [Function])}*) {Form}* + Collect some values somehow. Each of the collections specifies a bunch of + things which collected during the evaluation of the body of the form. The + name of the collection is used to define a local macro, a la MACROLET. + Within the body, this macro will evaluate each of its arguments and collect + the result, returning the current value after the collection is done. The + body is evaluated as a PROGN; to get the final values when you are done, just + call the collection macro with no arguments. + + Initial-Value is the value that the collection starts out with, which + defaults to NIL. Function is the function which does the collection. It is + a function which will accept two arguments: the value to be collected and the + current collection. The result of the function is made the new value for the + collection. As a totally magical special-case, the Function may be Collect, + which tells us to build a list in forward order; this is the default. If an + Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the + end. Note that Function may be anything that can appear in the functional + position, including macros and lambdas." + + (let ((macros ()) + (binds ())) + (dolist (spec collections) + (unless (<= 1 (length spec) 3) + (error "Malformed collection specifier: ~S." spec)) + (let ((n-value (gensym)) + (name (first spec)) + (default (second spec)) + (kind (or (third spec) 'collect))) + (push `(,n-value ,default) binds) + (if (eq kind 'collect) + (let ((n-tail (gensym))) + (if default + (push `(,n-tail (last ,n-value)) binds) + (push n-tail binds)) + (push `(,name (&rest args) + (collect-list-expander ',n-value ',n-tail args)) + macros)) + (push `(,name (&rest args) + (collect-normal-expander ',n-value ',kind args)) + macros)))) + `(macrolet ,macros (let* ,(nreverse binds) ,@body)))) +) + +;;;; Float printing. + +;;; +;;; Written by Bill Maddox +;;; +;;; +;;; +;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does most of +;;; the work for all printing of floating point numbers in the printer and in +;;; FORMAT. It converts a floating point number to a string in a free or +;;; fixed format with no exponent. The interpretation of the arguments is as +;;; follows: +;;; +;;; X - The floating point number to convert, which must not be +;;; negative. +;;; WIDTH - The preferred field width, used to determine the number +;;; of fraction digits to produce if the FDIGITS parameter +;;; is unspecified or NIL. If the non-fraction digits and the +;;; decimal point alone exceed this width, no fraction digits +;;; will be produced unless a non-NIL value of FDIGITS has been +;;; specified. Field overflow is not considerd an error at this +;;; level. +;;; FDIGITS - The number of fractional digits to produce. Insignificant +;;; trailing zeroes may be introduced as needed. May be +;;; unspecified or NIL, in which case as many digits as possible +;;; are generated, subject to the constraint that there are no +;;; trailing zeroes. +;;; SCALE - If this parameter is specified or non-NIL, then the number +;;; printed is (* x (expt 10 scale)). This scaling is exact, +;;; and cannot lose precision. +;;; FMIN - This parameter, if specified or non-NIL, is the minimum +;;; number of fraction digits which will be produced, regardless +;;; of the value of WIDTH or FDIGITS. This feature is used by +;;; the ~E format directive to prevent complete loss of +;;; significance in the printed value due to a bogus choice of +;;; scale factor. +;;; +;;; Most of the optional arguments are for the benefit for FORMAT and are not +;;; used by the printer. +;;; +;;; Returns: +;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT) +;;; where the results have the following interpretation: +;;; +;;; DIGIT-STRING - The decimal representation of X, with decimal point. +;;; DIGIT-LENGTH - The length of the string DIGIT-STRING. +;;; LEADING-POINT - True if the first character of DIGIT-STRING is the +;;; decimal point. +;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the +;;; decimal point. +;;; POINT-POS - The position of the digit preceding the decimal +;;; point. Zero indicates point before first digit. +;;; +;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy. +;;; Specifically, the decimal number printed is the closest possible +;;; approximation to the true value of the binary number to be printed from +;;; among all decimal representations with the same number of digits. In +;;; free-format output, i.e. with the number of digits unconstrained, it is +;;; guaranteed that all the information is preserved, so that a properly- +;;; rounding reader can reconstruct the original binary number, bit-for-bit, +;;; from its printed decimal representation. Furthermore, only as many digits +;;; as necessary to satisfy this condition will be printed. +;;; +;;; +;;; FLOAT-STRING actually generates the digits for positive numbers. The +;;; algorithm is essentially that of algorithm Dragon4 in "How to Print +;;; Floating-Point Numbers Accurately" by Steele and White. The current +;;; (draft) version of this paper may be found in [CMUC]tradix.press. +;;; DO NOT EVEN THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING +;;; THE PAPER! + +(defvar *digits* "0123456789") + +(defun flonum-to-string (x &optional width fdigits scale fmin) + (cond ((zerop x) + ;;zero is a special case which float-string cannot handle + (if fdigits + (let ((s (make-string (1+ fdigits) :initial-element #\0))) + (setf (schar s 0) #\.) + (values s (length s) t (zerop fdigits) 0)) + (values "." 1 t t 0))) + (t + (multiple-value-bind (sig exp) + (integer-decode-float x) + (let* ((precision (float-precision x)) + (digits (float-digits x)) + (fudge (- digits precision)) + (width (if width (max width 1) nil))) + (float-string (ash sig (- fudge)) (+ exp fudge) precision width + fdigits scale fmin)))))) + + +(defun float-string (fraction exponent precision width fdigits scale fmin) + (declare (si::c-local)) + (let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0) + (digits 0) (decpnt 0) (cutoff nil) (roundup nil) u low high + (digit-string (make-array 50 :element-type 'base-char + :fill-pointer 0 :adjustable t))) + ;;Represent fraction as r/s, error bounds as m+/s and m-/s. + ;;Rational arithmetic avoids loss of precision in subsequent calculations. + (cond ((> exponent 0) + (setq r (ash fraction exponent)) + (setq m- (ash 1 exponent)) + (setq m+ m-)) + ((< exponent 0) + (setq s (ash 1 (- exponent))))) + ;;adjust the error bounds m+ and m- for unequal gaps + (when (= fraction (ash 1 precision)) + (setq m+ (ash m+ 1)) + (setq r (ash r 1)) + (setq s (ash s 1))) + ;;scale value by requested amount, and update error bounds + (when scale + (if (minusp scale) + (let ((scale-factor (expt 10 (- scale)))) + (setq s (* s scale-factor))) + (let ((scale-factor (expt 10 scale))) + (setq r (* r scale-factor)) + (setq m+ (* m+ scale-factor)) + (setq m- (* m- scale-factor))))) + ;;scale r and s and compute initial k, the base 10 logarithm of r + (do () + ((>= r (ceiling s 10))) + (decf k) + (setq r (* r 10)) + (setq m- (* m- 10)) + (setq m+ (* m+ 10))) + (do ()(nil) + (do () + ((< (+ (ash r 1) m+) (ash s 1))) + (setq s (* s 10)) + (incf k)) + ;;determine number of fraction digits to generate + (cond (fdigits + ;;use specified number of fraction digits + (setq cutoff (- fdigits)) + ;;don't allow less than fmin fraction digits + (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin)))) + (width + ;;use as many fraction digits as width will permit + ;;but force at least fmin digits even if width will be exceeded + (if (< k 0) + (setq cutoff (- 1 width)) + (setq cutoff (1+ (- k width)))) + (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin))))) + ;;If we decided to cut off digit generation before precision has + ;;been exhausted, rounding the last digit may cause a carry propagation. + ;;We can prevent this, preserving left-to-right digit generation, with + ;;a few magical adjustments to m- and m+. Of course, correct rounding + ;;is also preserved. + (when (or fdigits width) + (let ((a (- cutoff k)) + (y s)) + (if (>= a 0) + (dotimes (i a) (setq y (* y 10))) + (dotimes (i (- a)) (setq y (ceiling y 10)))) + (setq m- (max y m-)) + (setq m+ (max y m+)) + (when (= m+ y) (setq roundup t)))) + (when (< (+ (ash r 1) m+) (ash s 1)) (return))) + ;;zero-fill before fraction if no integer part + (when (< k 0) + (setq decpnt digits) + (vector-push-extend #\. digit-string) + (dotimes (i (- k)) + (incf digits) (vector-push-extend #\0 digit-string))) + ;;generate the significant digits + (do ()(nil) + (decf k) + (when (= k -1) + (vector-push-extend #\. digit-string) + (setq decpnt digits)) + (multiple-value-setq (u r) (truncate (* r 10) s)) + (setq m- (* m- 10)) + (setq m+ (* m+ 10)) + (setq low (< (ash r 1) m-)) + (if roundup + (setq high (>= (ash r 1) (- (ash s 1) m+))) + (setq high (> (ash r 1) (- (ash s 1) m+)))) + ;;stop when either precision is exhausted or we have printed as many + ;;fraction digits as permitted + (when (or low high (and cutoff (<= k cutoff))) (return)) + (vector-push-extend (char *digits* u) digit-string) + (incf digits)) + ;;if cutoff occured before first digit, then no digits generated at all + (when (or (not cutoff) (>= k cutoff)) + ;;last digit may need rounding + (vector-push-extend (char *digits* + (cond ((and low (not high)) u) + ((and high (not low)) (1+ u)) + (t (if (<= (ash r 1) s) u (1+ u))))) + digit-string) + (incf digits)) + ;;zero-fill after integer part if no fraction + (when (>= k 0) + (dotimes (i k) (incf digits) (vector-push-extend #\0 digit-string)) + (vector-push-extend #\. digit-string) + (setq decpnt digits)) + ;;add trailing zeroes to pad fraction if fdigits specified + (when fdigits + (dotimes (i (- fdigits (- digits decpnt))) + (incf digits) + (vector-push-extend #\0 digit-string))) + ;;all done + (values digit-string (1+ digits) (= decpnt 0) (= decpnt digits) decpnt))) + +;;; SCALE-EXPONENT -- Internal +;;; +;;; Given a non-negative floating point number, SCALE-EXPONENT returns a new +;;; floating point number Z in the range (0.1, 1.0] and an exponent E such +;;; that Z * 10^E is (approximately) equal to the original number. There may +;;; be some loss of precision due the floating point representation. The +;;; scaling is always done with long float arithmetic, which helps printing of +;;; lesser precisions as well as avoiding generic arithmetic. +;;; +;;; When computing our initial scale factor using EXPT, we pull out part of +;;; the computation to avoid over/under flow. When denormalized, we must pull +;;; out a large factor, since there is more negative exponent range than +;;; positive range. +;;; +(defun scale-exponent (original-x) + (let* ((x (coerce original-x 'long-float))) + (multiple-value-bind (sig exponent) + (decode-float x) + (declare (ignore sig)) + (if (= x 0.0l0) + (values (float 0.0l0 original-x) 1) + (let* ((ex (round (* exponent (log 2l0 10)))) + (x (if (minusp ex) + (if #-ecl(float-denormalized-p x) + #+ecl(< least-negative-normalized-long-float + x + least-positive-normalized-long-float) + #-long-float + (* x 1.0l16 (expt 10.0l0 (- (- ex) 16))) + #+long-float + (* x 1.0l18 (expt 10.0l0 (- (- ex) 18))) + (* x 10.0l0 (expt 10.0l0 (- (- ex) 1)))) + (/ x 10.0l0 (expt 10.0l0 (1- ex)))))) + (do ((d 10.0l0 (* d 10.0l0)) + (y x (/ x d)) + (ex ex (1+ ex))) + ((< y 1.0l0) + (do ((m 10.0l0 (* m 10.0l0)) + (z y (* y m)) + (ex ex (1- ex))) + ((>= z 0.1l0) + (values (float z original-x) ex)))))))))) + +(defstruct (format-directive + #-ecl(:print-function %print-format-directive) + #+ecl :named + #+ecl(:type vector)) + (string (required-argument) :type simple-string) + (start (required-argument) :type (and unsigned-byte fixnum)) + (end (required-argument) :type (and unsigned-byte fixnum)) + (character (required-argument) :type base-char) + (colonp nil :type (member t nil)) + (atsignp nil :type (member t nil)) + (params nil :type list)) + +#-ecl +(defun %print-format-directive (struct stream depth) + (declare (ignore depth)) + (print-unreadable-object (struct stream) + (write-string (format-directive-string struct) stream + :start (format-directive-start struct) + :end (format-directive-end struct)))) + +#+formatter +(defvar *format-directive-expanders* + (make-array char-code-limit :initial-element nil)) +(defvar *format-directive-interpreters* + (make-array char-code-limit :initial-element nil)) + +(defvar *default-format-error-control-string* nil) +(defvar *default-format-error-offset* nil) + +;; The condition FORMAT-ERROR is found later in conditions.lsp + + +;;;; TOKENIZE-CONTROL-STRING + +(defun tokenize-control-string (string) + (declare (simple-string string) + (si::c-local)) + (let ((index 0) + (end (length string)) + (result nil)) + (loop + (let ((next-directive (or (position #\~ string :start index) end))) + (when (> next-directive index) + (push (subseq string index next-directive) result)) + (when (= next-directive end) + (return)) + (let ((directive (parse-directive string next-directive))) + (push directive result) + (setf index (format-directive-end directive))))) + (nreverse result))) + +(defun parse-directive (string start) + (declare (si::c-local)) + (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil) + (end (length string))) + (flet ((get-char () + (if (= posn end) + (error 'format-error + :complaint "String ended before directive was found." + :control-string string + :offset start) + (schar string posn)))) + (loop + (let ((char (get-char))) + (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-)) + (multiple-value-bind + (param new-posn) + (parse-integer string :start posn :junk-allowed t) + (push (cons posn param) params) + (setf posn new-posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return))))) + ((or (char= char #\v) (char= char #\V)) + (push (cons posn :arg) params) + (incf posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return)))) + ((char= char #\#) + (push (cons posn :remaining) params) + (incf posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return)))) + ((char= char #\') + (incf posn) + (push (cons posn (get-char)) params) + (incf posn) + (unless (char= (get-char) #\,) + (decf posn))) + ((char= char #\,) + (push (cons posn nil) params)) + ((char= char #\:) + (if colonp + (error 'format-error + :complaint "Too many colons supplied." + :control-string string + :offset posn) + (setf colonp t))) + ((char= char #\@) + (if atsignp + (error 'format-error + :complaint "Too many at-signs supplied." + :control-string string + :offset posn) + (setf atsignp t))) + (t + (when (char= (schar string (1- posn)) #\,) + (push (cons (1- posn) nil) params)) + (return)))) + (incf posn)) + (let ((char (get-char))) + (when (char= char #\/) + (let ((closing-slash (position #\/ string :start (1+ posn)))) + (if closing-slash + (setf posn closing-slash) + (error 'format-error + :complaint "No matching closing slash." + :control-string string + :offset posn)))) + (make-format-directive + :string string :start start :end (1+ posn) + :character (char-upcase char) + :colonp colonp :atsignp atsignp + :params (nreverse params)))))) + + +;;;; Specials used to communicate information. + +;;; *UP-UP-AND-OUT-ALLOWED* -- internal. +;;; +;;; Used both by the expansion stuff and the interpreter stuff. When it is +;;; non-NIL, up-up-and-out (~:^) is allowed. Otherwise, ~:^ isn't allowed. +;;; +(defvar *up-up-and-out-allowed* nil) + +;;; *LOGICAL-BLOCK-POPPER* -- internal. +;;; +;;; Used by the interpreter stuff. When it non-NIL, its a function that will +;;; invoke PPRINT-POP in the right lexical environemnt. +;;; +(defvar *logical-block-popper* nil) + +;;; *EXPANDER-NEXT-ARG-MACRO* -- internal. +;;; +;;; Used by the expander stuff. This is bindable so that ~<...~:> +;;; can change it. +;;; +#+formatter +(defvar *expander-next-arg-macro* 'expander-next-arg) + +;;; *ONLY-SIMPLE-ARGS* -- internal. +;;; +;;; Used by the expander stuff. Initially starts as T, and gets set to NIL +;;; if someone needs to do something strange with the arg list (like use +;;; the rest, or something). +;;; +(defvar *only-simple-args*) + +;;; *ORIG-ARGS-AVAILABLE* -- internal. +;;; +;;; Used by the expander stuff. We do an initial pass with this as NIL. +;;; If someone doesn't like this, they (throw 'need-orig-args nil) and we try +;;; again with it bound to T. If this is T, we don't try to do anything +;;; fancy with args. +;;; +(defvar *orig-args-available* nil) + +;;; *SIMPLE-ARGS* -- internal. +;;; +;;; Used by the expander stuff. List of (symbol . offset) for simple args. +;;; +(defvar *simple-args*) + + + + +;;;; FORMAT + +#-ecl +(defun format (destination control-string &rest format-arguments) + "Provides various facilities for formatting output. + CONTROL-STRING contains a string to be output, possibly with embedded + directives, which are flagged with the escape character \"~\". Directives + generally expand into additional text to be output, usually consuming one + or more of the FORMAT-ARGUMENTS in the process. A few useful directives + are: + ~A or ~nA Prints one argument as if by PRINC + ~S or ~nS Prints one argument as if by PRIN1 + ~D or ~nD Prints one argument as a decimal integer + ~% Does a TERPRI + ~& Does a FRESH-LINE + + where n is the width of the field in which the object is printed. + + DESTINATION controls where the result will go. If DESTINATION is T, then + the output is sent to the standard output stream. If it is NIL, then the + output is returned in a string as the value of the call. Otherwise, + DESTINATION must be a stream to which the output will be sent. + + Example: (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\" + + FORMAT has many additional capabilities not described here. Consult + Section 22.3 (Formatted Output) of the ANSI Common Lisp standard for + details." + (etypecase destination + (null + (with-output-to-string (stream) + (formatter-aux stream control-string format-arguments))) + (string + (with-output-to-string (stream destination) + (formatter-aux stream control-string format-arguments))) + ((member t) + (formatter-aux *standard-output* control-string format-arguments) + nil) + (stream + (formatter-aux destination control-string format-arguments) + nil))) + +(defun formatter-aux (stream string-or-fun orig-args &optional (args orig-args)) + (if (functionp string-or-fun) + (apply string-or-fun stream args) + (catch 'up-and-out + (let* ((string (etypecase string-or-fun + (simple-string + string-or-fun) + (string + (coerce string-or-fun 'simple-string)))) + (*default-format-error-control-string* string) + (*logical-block-popper* nil)) + (interpret-directive-list stream (tokenize-control-string string) + orig-args args))))) + +(defun interpret-directive-list (stream directives orig-args args) + (declare (si::c-local)) + (if directives + (let ((directive (car directives))) + (etypecase directive + (simple-string + (write-string directive stream) + (interpret-directive-list stream (cdr directives) orig-args args)) + (#-ecl format-directive #+ecl vector + (multiple-value-bind + (new-directives new-args) + (let ((function + (svref *format-directive-interpreters* + (char-code (format-directive-character + directive)))) + (*default-format-error-offset* + (1- (format-directive-end directive)))) + (unless function + (error 'format-error + :complaint "Unknown format directive.")) + (multiple-value-bind + (new-directives new-args) + (funcall function stream directive + (cdr directives) orig-args args) + (values new-directives new-args))) + (interpret-directive-list stream new-directives + orig-args new-args))))) + args)) + + +;;;; FORMATTER + +#+formatter +(progn +(defmacro formatter (control-string) + `#',(%formatter control-string)) + +(defun %formatter (control-string) + (declare (si::c-local)) + (block nil + (catch 'need-orig-args + (let* ((*simple-args* nil) + (*only-simple-args* t) + (guts (expand-control-string control-string)) + (args nil)) + (dolist (arg *simple-args*) + (push `(,(car arg) + (error + 'format-error + :complaint "Required argument missing" + :control-string ,control-string + :offset ,(cdr arg))) + args)) + (return `(lambda (stream &optional ,@args &rest args) + ,guts + args)))) + (let ((*orig-args-available* t) + (*only-simple-args* nil)) + `(lambda (stream &rest orig-args) + (let ((args orig-args)) + ,(expand-control-string control-string) + args))))) + +(defun expand-control-string (string) + (declare (si::c-local)) + (let* ((string (etypecase string + (simple-string + string) + (string + (coerce string 'simple-string)))) + (*default-format-error-control-string* string) + (directives (tokenize-control-string string))) + `(block nil + ,@(expand-directive-list directives)))) + +(defun expand-directive-list (directives) + (declare (si::c-local)) + (let ((results nil) + (remaining-directives directives)) + (loop + (unless remaining-directives + (return)) + (multiple-value-bind + (form new-directives) + (expand-directive (car remaining-directives) + (cdr remaining-directives)) + (push form results) + (setf remaining-directives new-directives))) + (reverse results))) + +(defun expand-directive (directive more-directives) + (declare (si::c-local)) + (etypecase directive + (format-directive + (let ((expander + (aref *format-directive-expanders* + (char-code (format-directive-character directive)))) + (*default-format-error-offset* + (1- (format-directive-end directive)))) + (if expander + (funcall expander directive more-directives) + (error 'format-error + :complaint "Unknown directive.")))) + (simple-string + (values `(write-string ,directive stream) + more-directives)))) + +(defun expand-next-arg (&optional offset) + (declare (si::c-local)) + (if (or *orig-args-available* (not *only-simple-args*)) + `(,*expander-next-arg-macro* + ,*default-format-error-control-string* + ,(or offset *default-format-error-offset*)) + (let ((symbol (gensym "FORMAT-ARG-"))) + (push (cons symbol (or offset *default-format-error-offset*)) + *simple-args*) + symbol))) + +(defun need-hairy-args () + (declare (si::c-local)) + (when *only-simple-args* + )) + + +;;;; Format directive definition macros and runtime support. + +(defmacro expander-next-arg (string offset) + `(if args + (pop args) + (error 'format-error + :complaint "No more arguments." + :control-string ,string + :offset ,offset))) + +(defmacro expander-pprint-next-arg (string offset) + `(progn + (when (null args) + (error 'format-error + :complaint "No more arguments." + :control-string ,string + :offset ,offset)) + (pprint-pop) + (pop args))) +);#+formatter + +(eval-when (:compile-toplevel :execute) + +;;; NEXT-ARG -- internal. +;;; +;;; This macro is used to extract the next argument from the current arg list. +;;; This is the version used by format directive interpreters. +;;; +(defmacro next-arg (&optional offset) + `(progn + (when (null args) + (error 'format-error + :complaint "No more arguments." + ,@(when offset + `(:offset ,offset)))) + (when *logical-block-popper* + (funcall *logical-block-popper*)) + (pop args))) + +(defmacro def-complex-format-directive (char lambda-list &body body) + #-formatter + nil + #+formatter + (let ((defun-name (intern #+ecl + (si:string-concatenate char "-FORMAT-DIRECTIVE-EXPANDER") + #-ecl + (cl:format nil + "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER" + char))) + (directive (gensym)) + (directives (if lambda-list (car (last lambda-list)) (gensym)))) + `(progn + (defun ,defun-name (,directive ,directives) + ,@(if lambda-list + `((let ,(mapcar #'(lambda (var) + `(,var + (,(intern (concatenate + 'string + "FORMAT-DIRECTIVE-" + (symbol-name var)) + (symbol-package 'foo)) + ,directive))) + (butlast lambda-list)) + ,@body)) + `((declare (ignore ,directive ,directives)) + ,@body))) + (%set-format-directive-expander ,char #',defun-name)))) + +(defmacro def-format-directive (char lambda-list &body body) + #-formatter + nil + #+formatter + (let ((directives (gensym)) + (declarations nil) + (body-without-decls body)) + (loop + (let ((form (car body-without-decls))) + (unless (and (consp form) (eq (car form) 'declare)) + (return)) + (push (pop body-without-decls) declarations))) + (setf declarations (reverse declarations)) + `(def-complex-format-directive ,char (,@lambda-list ,directives) + ,@declarations + (values (progn ,@body-without-decls) + ,directives)))) + +(defmacro expand-bind-defaults (specs params &body body) + (once-only ((params params)) + (if specs + (collect ((expander-bindings) (runtime-bindings)) + (dolist (spec specs) + (destructuring-bind (var default) spec + (let ((symbol (gensym))) + (expander-bindings + `(,var ',symbol)) + (runtime-bindings + `(list ',symbol + (let* ((param-and-offset (pop ,params)) + (offset (car param-and-offset)) + (param (cdr param-and-offset))) + (case param + (:arg `(or ,(expand-next-arg offset) + ,,default)) + (:remaining + (setf *only-simple-args* nil) + '(length args)) + ((nil) ,default) + (t param)))))))) + `(let ,(expander-bindings) + `(let ,(list ,@(runtime-bindings)) + ,@(if ,params + (error 'format-error + :complaint + "Too many parameters, expected no more than ~D" + :arguments (list ,(length specs)) + :offset (caar ,params))) + ,,@body))) + `(progn + (when ,params + (error 'format-error + :complaint "Too many parameters, expected no more than 0" + :offset (caar ,params))) + ,@body)))) + +(defmacro def-complex-format-interpreter (char lambda-list &body body) + (let ((defun-name + (intern #+ecl + (si:string-concatenate char "-FORMAT-DIRECTIVE-INTERPRETER") + #-ecl + (cl:format nil "~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER" + char))) + (directive (gensym)) + (directives (if lambda-list (car (last lambda-list)) (gensym)))) + `(progn + (defun ,defun-name (stream ,directive ,directives orig-args args) + (declare (ignorable stream orig-args args)) + ,@(if lambda-list + `((let ,(mapcar #'(lambda (var) + `(,var + (,(intern (concatenate + 'string + "FORMAT-DIRECTIVE-" + (symbol-name var)) + (symbol-package 'foo)) + ,directive))) + (butlast lambda-list)) + (values (progn ,@body) args))) + `((declare (ignore ,directive ,directives)) + ,@body))) + (%set-format-directive-interpreter ,char #',defun-name)))) + +(defmacro def-format-interpreter (char lambda-list &body body) + (let ((directives (gensym))) + `(def-complex-format-interpreter ,char (,@lambda-list ,directives) + ,@body + ,directives))) + +(defmacro interpret-bind-defaults (specs params &body body) + (once-only ((params params)) + (collect ((bindings)) + (dolist (spec specs) + (destructuring-bind (var default) spec + (bindings `(,var (let* ((param-and-offset (pop ,params)) + (offset (car param-and-offset)) + (param (cdr param-and-offset))) + (case param + (:arg (next-arg offset)) + (:remaining (length args)) + ((nil) ,default) + (t param))))))) + `(let* ,(bindings) + (when ,params + (error 'format-error + :complaint + "Too many parameters, expected no more than ~D" + :arguments (list ,(length specs)) + :offset (caar ,params))) + ,@body)))) + +); eval-when + +#+formatter +(defun %set-format-directive-expander (char fn) + (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn) + char) + +(defun %set-format-directive-interpreter (char fn) + (declare (si::c-local)) + (setf (aref *format-directive-interpreters* + (char-code (char-upcase char))) + fn) + char) + +(defun find-directive (directives kind stop-at-semi) + (declare (si::c-local)) + (if directives + (let ((next (car directives))) + (if (format-directive-p next) + (let ((char (format-directive-character next))) + (if (or (char= kind char) + (and stop-at-semi (char= char #\;))) + (car directives) + (find-directive + (cdr (flet ((after (char) + (member (find-directive (cdr directives) + char + nil) + directives))) + (case char + (#\( (after #\))) + (#\< (after #\>)) + (#\[ (after #\])) + (#\{ (after #\})) + (t directives)))) + kind stop-at-semi))) + (find-directive (cdr directives) kind stop-at-semi))))) + + +;;;; Simple outputting noise. + +(defun format-write-field (stream string mincol colinc minpad padchar padleft) + #-formatter + (declare (si::c-local)) + (unless padleft + (write-string string stream)) + (dotimes (i minpad) + (write-char padchar stream)) + (and mincol minpad colinc + (do ((chars (+ (length string) minpad) (+ chars colinc))) + ((>= chars mincol)) + (dotimes (i colinc) + (write-char padchar stream)))) + (when padleft + (write-string string stream))) + +(defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar) + #-formatter + (declare (si::c-local)) + (format-write-field stream + (if (or arg (not colonp)) + (princ-to-string arg) + "()") + mincol colinc minpad padchar atsignp)) + +(def-format-directive #\A (colonp atsignp params) + (if params + (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) + params + `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp + ,mincol ,colinc ,minpad ,padchar)) + `(princ ,(if colonp + `(or ,(expand-next-arg) "()") + (expand-next-arg)) + stream))) + +(def-format-interpreter #\A (colonp atsignp params) + (if params + (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) + params + (format-princ stream (next-arg) colonp atsignp + mincol colinc minpad padchar)) + (princ (if colonp (or (next-arg) "()") (next-arg)) stream))) + +(defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar) + #-formatter + (declare (si::c-local)) + (format-write-field stream + (if (or arg (not colonp)) + (prin1-to-string arg) + "()") + mincol colinc minpad padchar atsignp)) + +(def-format-directive #\S (colonp atsignp params) + (cond (params + (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) + params + `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp + ,mincol ,colinc ,minpad ,padchar))) + (colonp + `(let ((arg ,(expand-next-arg))) + (if arg + (prin1 arg stream) + (princ "()" stream)))) + (t + `(prin1 ,(expand-next-arg) stream)))) + +(def-format-interpreter #\S (colonp atsignp params) + (cond (params + (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) + params + (format-prin1 stream (next-arg) colonp atsignp + mincol colinc minpad padchar))) + (colonp + (let ((arg (next-arg))) + (if arg + (prin1 arg stream) + (princ "()" stream)))) + (t + (prin1 (next-arg) stream)))) + +(def-format-directive #\C (colonp atsignp params) + (expand-bind-defaults () params + (if colonp + `(format-print-named-character ,(expand-next-arg) stream) + (if atsignp + `(prin1 ,(expand-next-arg) stream) + `(write-char ,(expand-next-arg) stream))))) + +(def-format-interpreter #\C (colonp atsignp params) + (interpret-bind-defaults () params + (if colonp + (format-print-named-character (next-arg) stream) + (if atsignp + (prin1 (next-arg) stream) + (write-char (next-arg) stream))))) + +(defun format-print-named-character (char stream) + #-formatter + (declare (si::c-local)) + (let* ((name (char-name char))) + (cond (name + (write-string (string-capitalize name) stream)) + ((<= 0 (char-code char) 31) + ;; Print control characters as "^" + (write-char #\^ stream) + (write-char (code-char (+ 64 (char-code char))) stream)) + (t + (write-char char stream))))) + +(def-format-directive #\W (colonp atsignp params) + (expand-bind-defaults () params + (if (or colonp atsignp) + `(let (,@(when colonp + '((*print-pretty* t))) + ,@(when atsignp + '((*print-level* nil) + (*print-length* nil)))) + (output-object ,(expand-next-arg) stream)) + `(output-object ,(expand-next-arg) stream)))) + +(def-format-interpreter #\W (colonp atsignp params) + (interpret-bind-defaults () params + (let ((*print-pretty* (or colonp *print-pretty*)) + (*print-level* (and atsignp *print-level*)) + (*print-length* (and atsignp *print-length*))) + (output-object (next-arg) stream)))) + + +;;;; Integer outputting. + +;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing +;;; directives. The parameters are interpreted as defined for ~D. +;;; +(defun format-print-integer (stream number print-commas-p print-sign-p + radix mincol padchar commachar commainterval) + #-formatter + (declare (si::c-local)) + (let ((*print-base* radix) + (*print-radix* nil)) + (if (integerp number) + (let* ((text (princ-to-string (abs number))) + (commaed (if print-commas-p + (format-add-commas text commachar commainterval) + text)) + (signed (cond ((minusp number) + (concatenate 'string "-" commaed)) + (print-sign-p + (concatenate 'string "+" commaed)) + (t commaed)))) + ;; colinc = 1, minpad = 0, padleft = t + (format-write-field stream signed mincol 1 0 padchar t)) + (princ number stream)))) + +(defun format-add-commas (string commachar commainterval) + #-formatter + (declare (si::c-local)) + (let ((length (length string))) + (multiple-value-bind (commas extra) + (truncate (1- length) commainterval) + (let ((new-string (make-string (+ length commas))) + (first-comma (1+ extra))) + (replace new-string string :end1 first-comma :end2 first-comma) + (do ((src first-comma (+ src commainterval)) + (dst first-comma (+ dst commainterval 1))) + ((= src length)) + (setf (schar new-string dst) commachar) + (replace new-string string :start1 (1+ dst) + :start2 src :end2 (+ src commainterval))) + new-string)))) + +#+formatter +(defun expand-format-integer (base colonp atsignp params) + (if (or colonp atsignp params) + (expand-bind-defaults + ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) + params + `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp + ,base ,mincol ,padchar ,commachar + ,commainterval)) + `(write ,(expand-next-arg) :stream stream :base ,base :radix nil + :escape nil))) + +(eval-when (:compile-toplevel :execute) +(defmacro interpret-format-integer (base) + `(if (or colonp atsignp params) + (interpret-bind-defaults + ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) + params + (format-print-integer stream (next-arg) colonp atsignp ,base mincol + padchar commachar commainterval)) + (write (next-arg) :stream stream :base ,base :radix nil :escape nil))) +) + +(def-format-directive #\D (colonp atsignp params) + (expand-format-integer 10 colonp atsignp params)) + +(def-format-interpreter #\D (colonp atsignp params) + (interpret-format-integer 10)) + +(def-format-directive #\B (colonp atsignp params) + (expand-format-integer 2 colonp atsignp params)) + +(def-format-interpreter #\B (colonp atsignp params) + (interpret-format-integer 2)) + +(def-format-directive #\O (colonp atsignp params) + (expand-format-integer 8 colonp atsignp params)) + +(def-format-interpreter #\O (colonp atsignp params) + (interpret-format-integer 8)) + +(def-format-directive #\X (colonp atsignp params) + (expand-format-integer 16 colonp atsignp params)) + +(def-format-interpreter #\X (colonp atsignp params) + (interpret-format-integer 16)) + +(def-format-directive #\R (colonp atsignp params) + (if params + (expand-bind-defaults + ((base 10) (mincol 0) (padchar #\space) (commachar #\,) + (commainterval 3)) + params + `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp + ,base ,mincol + ,padchar ,commachar ,commainterval)) + (if atsignp + (if colonp + `(format-print-old-roman stream ,(expand-next-arg)) + `(format-print-roman stream ,(expand-next-arg))) + (if colonp + `(format-print-ordinal stream ,(expand-next-arg)) + `(format-print-cardinal stream ,(expand-next-arg)))))) + +(def-format-interpreter #\R (colonp atsignp params) + (if params + (interpret-bind-defaults + ((base 10) (mincol 0) (padchar #\space) (commachar #\,) + (commainterval 3)) + params + (format-print-integer stream (next-arg) colonp atsignp base mincol + padchar commachar commainterval)) + (if atsignp + (if colonp + (format-print-old-roman stream (next-arg)) + (format-print-roman stream (next-arg))) + (if colonp + (format-print-ordinal stream (next-arg)) + (format-print-cardinal stream (next-arg)))))) + + +(defconstant cardinal-ones + #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) + +(defconstant cardinal-tens + #(nil nil "twenty" "thirty" "forty" + "fifty" "sixty" "seventy" "eighty" "ninety")) + +(defconstant cardinal-teens + #("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD + "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) + +(defconstant cardinal-periods + #("" " thousand" " million" " billion" " trillion" " quadrillion" + " quintillion" " sextillion" " septillion" " octillion" " nonillion" + " decillion" " undecillion" " duodecillion" " tredecillion" + " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion" + " octodecillion" " novemdecillion" " vigintillion")) + +(defconstant ordinal-ones + #(nil "first" "second" "third" "fourth" + "fifth" "sixth" "seventh" "eighth" "ninth") + "Table of ordinal ones-place digits in English") + +(defconstant ordinal-tens + #(nil "tenth" "twentieth" "thirtieth" "fortieth" + "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth") + "Table of ordinal tens-place digits in English") + +(defun format-print-small-cardinal (stream n) + #-formatter + (declare (si::c-local)) + (multiple-value-bind + (hundreds rem) (truncate n 100) + (when (plusp hundreds) + (write-string (svref cardinal-ones hundreds) stream) + (write-string " hundred" stream) + (when (plusp rem) + (write-char #\space stream))) + (when (plusp rem) + (multiple-value-bind (tens ones) + (truncate rem 10) + (cond ((< 1 tens) + (write-string (svref cardinal-tens tens) stream) + (when (plusp ones) + (write-char #\- stream) + (write-string (svref cardinal-ones ones) stream))) + ((= tens 1) + (write-string (svref cardinal-teens ones) stream)) + ((plusp ones) + (write-string (svref cardinal-ones ones) stream))))))) + +(defun format-print-cardinal (stream n) + #-formatter + (declare (si::c-local)) + (cond ((minusp n) + (write-string "negative " stream) + (format-print-cardinal-aux stream (- n) 0 n)) + ((zerop n) + (write-string "zero" stream)) + (t + (format-print-cardinal-aux stream n 0 n)))) + +(defun format-print-cardinal-aux (stream n period err) + (declare (si::c-local)) + (multiple-value-bind (beyond here) (truncate n 1000) + (unless (<= period 20) + (error "Number too large to print in English: ~:D" err)) + (unless (zerop beyond) + (format-print-cardinal-aux stream beyond (1+ period) err)) + (unless (zerop here) + (unless (zerop beyond) + (write-char #\space stream)) + (format-print-small-cardinal stream here) + (write-string (svref cardinal-periods period) stream)))) + +(defun format-print-ordinal (stream n) + #-formatter + (declare (si::c-local)) + (when (minusp n) + (write-string "negative " stream)) + (let ((number (abs n))) + (multiple-value-bind + (top bot) (truncate number 100) + (unless (zerop top) + (format-print-cardinal stream (- number bot))) + (when (and (plusp top) (plusp bot)) + (write-char #\space stream)) + (multiple-value-bind + (tens ones) (truncate bot 10) + (cond ((= bot 12) (write-string "twelfth" stream)) + ((= tens 1) + (write-string (svref cardinal-teens ones) stream);;;RAD + (write-string "th" stream)) + ((and (zerop tens) (plusp ones)) + (write-string (svref ordinal-ones ones) stream)) + ((and (zerop ones)(plusp tens)) + (write-string (svref ordinal-tens tens) stream)) + ((plusp bot) + (write-string (svref cardinal-tens tens) stream) + (write-char #\- stream) + (write-string (svref ordinal-ones ones) stream)) + ((plusp number) + (write-string "th" stream)) + (t + (write-string "zeroth" stream))))))) + +;;; Print Roman numerals + +(defun format-print-old-roman (stream n) + #-formatter + (declare (si::c-local)) + (unless (< 0 n 5000) + (error "Number too large to print in old Roman numerals: ~:D" n)) + (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) + (val-list '(500 100 50 10 5 1) (cdr val-list)) + (cur-char #\M (car char-list)) + (cur-val 1000 (car val-list)) + (start n (do ((i start (progn + (write-char cur-char stream) + (- i cur-val)))) + ((< i cur-val) i)))) + ((zerop start)))) + +(defun format-print-roman (stream n) + #-formatter + (declare (si::c-local)) + (unless (< 0 n 4000) + (error "Number too large to print in Roman numerals: ~:D" n)) + (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) + (val-list '(500 100 50 10 5 1) (cdr val-list)) + (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars)) + (sub-val '(100 10 10 1 1 0) (cdr sub-val)) + (cur-char #\M (car char-list)) + (cur-val 1000 (car val-list)) + (cur-sub-char #\C (car sub-chars)) + (cur-sub-val 100 (car sub-val)) + (start n (do ((i start (progn + (write-char cur-char stream) + (- i cur-val)))) + ((< i cur-val) + (cond ((<= (- cur-val cur-sub-val) i) + (write-char cur-sub-char stream) + (write-char cur-char stream) + (- i (- cur-val cur-sub-val))) + (t i)))))) + ((zerop start)))) + + +;;;; Plural. + +(def-format-directive #\P (colonp atsignp params end) + (expand-bind-defaults () params + (let ((arg (cond + ((not colonp) + (expand-next-arg)) + (*orig-args-available* + `(if (eq orig-args args) + (error 'format-error + :complaint "No previous argument." + :offset ,(1- end)) + (do ((arg-ptr orig-args (cdr arg-ptr))) + ((eq (cdr arg-ptr) args) + (car arg-ptr))))) + (*only-simple-args* + (unless *simple-args* + (error 'format-error + :complaint "No previous argument.")) + (caar *simple-args*)) + (t + (throw 'need-orig-args nil))))) + (if atsignp + `(write-string (if (eql ,arg 1) "y" "ies") stream) + `(unless (eql ,arg 1) (write-char #\s stream)))))) + +(def-format-interpreter #\P (colonp atsignp params) + (interpret-bind-defaults () params + (let ((arg (if colonp + (if (eq orig-args args) + (error 'format-error + :complaint "No previous argument.") + (do ((arg-ptr orig-args (cdr arg-ptr))) + ((eq (cdr arg-ptr) args) + (car arg-ptr)))) + (next-arg)))) + (if atsignp + (write-string (if (eql arg 1) "y" "ies") stream) + (unless (eql arg 1) (write-char #\s stream)))))) + + +;;;; Floating point noise. + +(defun decimal-string (n) + #-formatter + (declare (si::c-local)) + (write-to-string n :base 10 :radix nil :escape nil)) + +(def-format-directive #\F (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "Cannot specify the colon modifier with this directive.")) + (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params + `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp))) + +(def-format-interpreter #\F (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "Cannot specify the colon modifier with this directive.")) + (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) + params + (format-fixed stream (next-arg) w d k ovf pad atsignp))) + +(defun format-fixed (stream number w d k ovf pad atsign) + #-formatter + (declare (si::c-local)) + (if (numberp number) + (if (floatp number) + (format-fixed-aux stream number w d k ovf pad atsign) + (if (rationalp number) + (format-fixed-aux stream + (coerce number 'single-float) + w d k ovf pad atsign) + (format-write-field stream + (decimal-string number) + w 1 0 #\space t))) + (format-princ stream number nil nil w 1 0 pad))) + + +;;; We return true if we overflowed, so that ~G can output the overflow char +;;; instead of spaces. +;;; +(defun format-fixed-aux (stream number w d k ovf pad atsign) + (declare (si::c-local)) + (cond + #-ecl + ((or (not (or w d)) + (and (floatp number) + (or (float-infinity-p number) + (float-nan-p number)))) + (prin1 number stream) + nil) + (t + (let ((spaceleft w)) + (when (and w (or atsign (minusp number))) (decf spaceleft)) + (multiple-value-bind + (str len lpoint tpoint) + (sys::flonum-to-string (abs number) spaceleft d k) + ;;if caller specifically requested no fraction digits, suppress the + ;;optional trailing zero + (when (and d (zerop d)) (setq tpoint nil)) + (when w + (decf spaceleft len) + ;;optional leading zero + (when lpoint + (if (or (> spaceleft 0) tpoint) ;force at least one digit + (decf spaceleft) + (setq lpoint nil))) + ;;optional trailing zero + (when tpoint + (if (> spaceleft 0) + (decf spaceleft) + (setq tpoint nil)))) + (cond ((and w (< spaceleft 0) ovf) + ;;field width overflow + (dotimes (i w) (write-char ovf stream)) + t) + (t + (when w (dotimes (i spaceleft) (write-char pad stream))) + (if (minusp number) + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (when lpoint (write-char #\0 stream)) + (write-string str stream) + (when tpoint (write-char #\0 stream)) + nil))))))) + +(def-format-directive #\E (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "Cannot specify the colon modifier with this directive.")) + (expand-bind-defaults + ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) + params + `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark + ,atsignp))) + +(def-format-interpreter #\E (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "Cannot specify the colon modifier with this directive.")) + (interpret-bind-defaults + ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) + params + (format-exponential stream (next-arg) w d e k ovf pad mark atsignp))) + +(defun format-exponential (stream number w d e k ovf pad marker atsign) + #-formatter + (declare (si::c-local)) + (if (numberp number) + (if (floatp number) + (format-exp-aux stream number w d e k ovf pad marker atsign) + (if (rationalp number) + (format-exp-aux stream + (coerce number 'single-float) + w d e k ovf pad marker atsign) + (format-write-field stream + (decimal-string number) + w 1 0 #\space t))) + (format-princ stream number nil nil w 1 0 pad))) + + +(defun format-exponent-marker (number) + #-formatter + (declare (si::c-local)) + (if (typep number *read-default-float-format*) + #\e + (typecase number + (single-float #\f) + (double-float #\d) + (short-float #\s) + (long-float #\l)))) + +;;;Here we prevent the scale factor from shifting all significance out of +;;;a number to the right. We allow insignificant zeroes to be shifted in +;;;to the left right, athough it is an error to specify k and d such that this +;;;occurs. Perhaps we should detect both these condtions and flag them as +;;;errors. As for now, we let the user get away with it, and merely guarantee +;;;that at least one significant digit will appear. + +;;; toy@rtp.ericsson.se: The Hyperspec seems to say that the exponent +;;; marker is always printed. Make it so. Also, the original version +;;; causes errors when printing infinities or NaN's. The Hyperspec is +;;; silent here, so let's just print out infinities and NaN's instead +;;; of causing an error. +(defun format-exp-aux (stream number w d e k ovf pad marker atsign) + (declare (si::c-local)) + (if #-ecl + (and (floatp number) + (or (float-infinity-p number) + (float-nan-p number))) + #+ecl nil + (prin1 number stream) + (multiple-value-bind (num expt) + (sys::scale-exponent (abs number)) + (let* ((expt (- expt k)) + (estr (decimal-string (abs expt))) + (elen (if e (max (length estr) e) (length estr))) + (fdig (if d (if (plusp k) (1+ (- d k)) d) nil)) + (fmin (if (minusp k) (- 1 k) nil)) + (spaceleft (if w + (- w 2 elen + (if (or atsign (minusp number)) + 1 0)) + nil))) + (if (and w ovf e (> elen e)) ;exponent overflow + (dotimes (i w) (write-char ovf stream)) + (multiple-value-bind + (fstr flen lpoint) + (sys::flonum-to-string num spaceleft fdig k fmin) + (when w + (decf spaceleft flen) + (when lpoint + (if (> spaceleft 0) + (decf spaceleft) + (setq lpoint nil)))) + (cond ((and w (< spaceleft 0) ovf) + ;;significand overflow + (dotimes (i w) (write-char ovf stream))) + (t (when w + (dotimes (i spaceleft) (write-char pad stream))) + (if (minusp number) + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (when lpoint (write-char #\0 stream)) + (write-string fstr stream) + (write-char (if marker + marker + (format-exponent-marker number)) + stream) + (write-char (if (minusp expt) #\- #\+) stream) + (when e + ;;zero-fill before exponent if necessary + (dotimes (i (- e (length estr))) + (write-char #\0 stream))) + (write-string estr stream))))))))) + +(def-format-directive #\G (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "Cannot specify the colon modifier with this directive.")) + (expand-bind-defaults + ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil)) + params + `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp))) + +(def-format-interpreter #\G (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "Cannot specify the colon modifier with this directive.")) + (interpret-bind-defaults + ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil)) + params + (format-general stream (next-arg) w d e k ovf pad mark atsignp))) + +(defun format-general (stream number w d e k ovf pad marker atsign) + #-formatter + (declare (si::c-local)) + (if (numberp number) + (if (floatp number) + (format-general-aux stream number w d e k ovf pad marker atsign) + (if (rationalp number) + (format-general-aux stream + (coerce number 'single-float) + w d e k ovf pad marker atsign) + (format-write-field stream + (decimal-string number) + w 1 0 #\space t))) + (format-princ stream number nil nil w 1 0 pad))) + + +;;; toy@rtp.ericsson.se: Same change as for format-exp-aux. +(defun format-general-aux (stream number w d e k ovf pad marker atsign) + (declare (si::c-local)) + (if #-ecl + (and (floatp number) + (or (float-infinity-p number) + (float-nan-p number))) + #+ecl nil + (prin1 number stream) + (multiple-value-bind (ignore n) + (sys::scale-exponent (abs number)) + (declare (ignore ignore)) + ;;Default d if omitted. The procedure is taken directly + ;;from the definition given in the manual, and is not + ;;very efficient, since we generate the digits twice. + ;;Future maintainers are encouraged to improve on this. + (unless d + (multiple-value-bind (str len) + (sys::flonum-to-string (abs number)) + (declare (ignore str)) + (let ((q (if (= len 1) 1 (1- len)))) + (setq d (max q (min n 7)))))) + (let* ((ee (if e (+ e 2) 4)) + (ww (if w (- w ee) nil)) + (dd (- d n))) + (cond ((<= 0 dd d) + (let ((char (if (format-fixed-aux stream number ww dd nil + ovf pad atsign) + ovf + #\space))) + (dotimes (i ee) (write-char char stream)))) + (t + (format-exp-aux stream number w d e (or k 1) + ovf pad marker atsign))))))) + +(def-format-directive #\$ (colonp atsignp params) + (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params + `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp + ,atsignp))) + +(def-format-interpreter #\$ (colonp atsignp params) + (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params + (format-dollars stream (next-arg) d n w pad colonp atsignp))) + +(defun format-dollars (stream number d n w pad colon atsign) + #-formatter + (declare (si::c-local)) + (if (rationalp number) (setq number (coerce number 'single-float))) + (if (floatp number) + (let* ((signstr (if (minusp number) "-" (if atsign "+" ""))) + (signlen (length signstr))) + (multiple-value-bind (str strlen ig2 ig3 pointplace) + (sys::flonum-to-string number nil d nil) + (declare (ignore ig2 ig3)) + (when colon (write-string signstr stream)) + (dotimes (i (- w signlen (max 0 (- n pointplace)) strlen)) + (write-char pad stream)) + (unless colon (write-string signstr stream)) + (dotimes (i (- n pointplace)) (write-char #\0 stream)) + (write-string str stream))) + (format-write-field stream + (decimal-string number) + w 1 0 #\space t))) + + +;;;; line/page breaks and other stuff like that. + +(def-format-directive #\% (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "Cannot specify either colon or atsign for this directive.")) + (if params + (expand-bind-defaults ((count 1)) params + `(dotimes (i ,count) + (terpri stream))) + '(terpri stream))) + +(def-format-interpreter #\% (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "Cannot specify either colon or atsign for this directive.")) + (interpret-bind-defaults ((count 1)) params + (dotimes (i count) + (terpri stream)))) + +(def-format-directive #\& (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "Cannot specify either colon or atsign for this directive.")) + (if params + (expand-bind-defaults ((count 1)) params + `(progn + (fresh-line stream) + (dotimes (i (1- ,count)) + (terpri stream)))) + '(fresh-line stream))) + +(def-format-interpreter #\& (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "Cannot specify either colon or atsign for this directive.")) + (interpret-bind-defaults ((count 1)) params + (fresh-line stream) + (dotimes (i (1- count)) + (terpri stream)))) + +(def-format-directive #\| (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "Cannot specify either colon or atsign for this directive.")) + (if params + (expand-bind-defaults ((count 1)) params + `(dotimes (i ,count) + (write-char #\page stream))) + '(write-char #\page stream))) + +(def-format-interpreter #\| (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "Cannot specify either colon or atsign for this directive.")) + (interpret-bind-defaults ((count 1)) params + (dotimes (i count) + (write-char #\page stream)))) + +(def-format-directive #\~ (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "Cannot specify either colon or atsign for this directive.")) + (if params + (expand-bind-defaults ((count 1)) params + `(dotimes (i ,count) + (write-char #\~ stream))) + '(write-char #\~ stream))) + +(def-format-interpreter #\~ (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "Cannot specify either colon or atsign for this directive.")) + (interpret-bind-defaults ((count 1)) params + (dotimes (i count) + (write-char #\~ stream)))) + +(def-complex-format-directive #\newline (colonp atsignp params directives) + (when (and colonp atsignp) + (error 'format-error + :complaint + "Cannot specify both colon and atsign for this directive.")) + (values (expand-bind-defaults () params + (if atsignp + '(write-char #\newline stream) + nil)) + (if (and (not colonp) + directives + (simple-string-p (car directives))) + (cons (string-left-trim '(#\space #\newline #\tab) + (car directives)) + (cdr directives)) + directives))) + +(def-complex-format-interpreter #\newline (colonp atsignp params directives) + (when (and colonp atsignp) + (error 'format-error + :complaint + "Cannot specify both colon and atsign for this directive.")) + (interpret-bind-defaults () params + (when atsignp + (write-char #\newline stream))) + (if (and (not colonp) + directives + (simple-string-p (car directives))) + (cons (string-left-trim '(#\space #\newline #\tab) + (car directives)) + (cdr directives)) + directives)) + + +;;;; Tab and simple pretty-printing noise. + +(def-format-directive #\T (colonp atsignp params) + (if colonp + (expand-bind-defaults ((n 1) (m 1)) params + `(pprint-tab ,(if atsignp :section-relative :section) + ,n ,m stream)) + (if atsignp + (expand-bind-defaults ((colrel 1) (colinc 1)) params + `(format-relative-tab stream ,colrel ,colinc)) + (expand-bind-defaults ((colnum 1) (colinc 1)) params + `(format-absolute-tab stream ,colnum ,colinc))))) + +(def-format-interpreter #\T (colonp atsignp params) + (if colonp + (interpret-bind-defaults ((n 1) (m 1)) params + (pprint-tab (if atsignp :section-relative :section) n m stream)) + (if atsignp + (interpret-bind-defaults ((colrel 1) (colinc 1)) params + (format-relative-tab stream colrel colinc)) + (interpret-bind-defaults ((colnum 1) (colinc 1)) params + (format-absolute-tab stream colnum colinc))))) + +(defun output-spaces (stream n) + #-formatter + (declare (si::c-local)) + (let ((spaces #.(make-string 100 :initial-element #\space))) + (loop + (when (< n (length spaces)) + (return)) + (write-string spaces stream) + (decf n (length spaces))) + (write-string spaces stream :end n))) + +(defun format-relative-tab (stream colrel colinc) + #-formatter + (declare (si::c-local)) + (if #-ecl(pp:pretty-stream-p stream) #+ecl nil + (pprint-tab :line-relative colrel colinc stream) + (let* ((cur (#-ecl sys::charpos #+ecl sys::file-column stream)) + (spaces (if (and cur (plusp colinc)) + (- (* (ceiling (+ cur colrel) colinc) colinc) cur) + colrel))) + (output-spaces stream spaces)))) + +(defun format-absolute-tab (stream colnum colinc) + #-formatter + (declare (si::c-local)) + (if #-ecl(pp:pretty-stream-p stream) #+ecl nil + (pprint-tab :line colnum colinc stream) + (let ((cur (#-ecl sys::charpos #+ecl sys:file-column stream))) + (cond ((null cur) + (write-string " " stream)) + ((< cur colnum) + (output-spaces stream (- colnum cur))) + (t + (unless (zerop colinc) + (output-spaces stream + (- colinc (rem (- cur colnum) colinc))))))))) + +(def-format-directive #\_ (colonp atsignp params) + (expand-bind-defaults () params + `(pprint-newline ,(if colonp + (if atsignp + :mandatory + :fill) + (if atsignp + :miser + :linear)) + stream))) + +(def-format-interpreter #\_ (colonp atsignp params) + (interpret-bind-defaults () params + (pprint-newline (if colonp + (if atsignp + :mandatory + :fill) + (if atsignp + :miser + :linear)) + stream))) + +(def-format-directive #\I (colonp atsignp params) + (when atsignp + (error 'format-error + :complaint "Cannot specify the at-sign modifier.")) + (expand-bind-defaults ((n 0)) params + `(pprint-indent ,(if colonp :current :block) ,n stream))) + +(def-format-interpreter #\I (colonp atsignp params) + (when atsignp + (error 'format-error + :complaint "Cannot specify the at-sign modifier.")) + (interpret-bind-defaults ((n 0)) params + (pprint-indent (if colonp :current :block) n stream))) + + +;;;; * + +(def-format-directive #\* (colonp atsignp params end) + (if atsignp + (if colonp + (error 'format-error + :complaint "Cannot specify both colon and at-sign.") + (expand-bind-defaults ((posn 0)) params + (unless *orig-args-available* + (throw 'need-orig-args nil)) + `(if (<= 0 ,posn (length orig-args)) + (setf args (nthcdr ,posn orig-args)) + (error 'format-error + :complaint "Index ~D out of bounds. Should have been ~ + between 0 and ~D." + :arguments (list ,posn (length orig-args)) + :offset ,(1- end))))) + (if colonp + (expand-bind-defaults ((n 1)) params + (unless *orig-args-available* + (throw 'need-orig-args nil)) + `(do ((cur-posn 0 (1+ cur-posn)) + (arg-ptr orig-args (cdr arg-ptr))) + ((eq arg-ptr args) + (let ((new-posn (- cur-posn ,n))) + (if (<= 0 new-posn (length orig-args)) + (setf args (nthcdr new-posn orig-args)) + (error 'format-error + :complaint + "Index ~D out of bounds. Should have been ~ + between 0 and ~D." + :arguments + (list new-posn (length orig-args)) + :offset ,(1- end))))))) + (if params + (expand-bind-defaults ((n 1)) params + (setf *only-simple-args* nil) + `(dotimes (i ,n) + ,(expand-next-arg))) + (expand-next-arg))))) + +(def-format-interpreter #\* (colonp atsignp params) + (if atsignp + (if colonp + (error 'format-error + :complaint "Cannot specify both colon and at-sign.") + (interpret-bind-defaults ((posn 0)) params + (if (<= 0 posn (length orig-args)) + (setf args (nthcdr posn orig-args)) + (error 'format-error + :complaint "Index ~D out of bounds. Should have been ~ + between 0 and ~D." + :arguments (list posn (length orig-args)))))) + (if colonp + (interpret-bind-defaults ((n 1)) params + (do ((cur-posn 0 (1+ cur-posn)) + (arg-ptr orig-args (cdr arg-ptr))) + ((eq arg-ptr args) + (let ((new-posn (- cur-posn n))) + (if (<= 0 new-posn (length orig-args)) + (setf args (nthcdr new-posn orig-args)) + (error 'format-error + :complaint + "Index ~D out of bounds. Should have been ~ + between 0 and ~D." + :arguments + (list new-posn (length orig-args)))))))) + (interpret-bind-defaults ((n 1)) params + (dotimes (i n) + (next-arg)))))) + + +;;;; Indirection. + +(def-format-directive #\? (colonp atsignp params string end) + (when colonp + (error 'format-error + :complaint "Cannot specify the colon modifier.")) + (expand-bind-defaults () params + `(handler-bind + ((format-error + #'(lambda (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :arguments (list condition) + :print-banner nil + :control-string ,string + :offset ,(1- end))))) + ,(if atsignp + (if *orig-args-available* + `(setf args (formatter-aux stream ,(expand-next-arg) orig-args args)) + (throw 'need-orig-args nil)) + `(formatter-aux stream ,(expand-next-arg) ,(expand-next-arg)))))) + +(def-format-interpreter #\? (colonp atsignp params string end) + (when colonp + (error 'format-error + :complaint "Cannot specify the colon modifier.")) + (interpret-bind-defaults () params + (handler-bind + ((format-error + #'(lambda (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :arguments (list condition) + :print-banner nil + :control-string string + :offset (1- end))))) + (if atsignp + (setf args (formatter-aux stream (next-arg) orig-args args)) + (formatter-aux stream (next-arg) (next-arg)))))) + + +;;;; Capitalization. + +(defun nstring-capitalize-first (s) + (let ((where (position-if #'alpha-char-p s))) + (when where + (nstring-capitalize s :start 0 :end where)) + s)) + +(def-complex-format-directive #\( (colonp atsignp params directives) + (let ((close (find-directive directives #\) nil))) + (unless close + (error 'format-error + :complaint "No corresponding close paren.")) + (let* ((posn (position close directives)) + (before (subseq directives 0 posn)) + (after (nthcdr (1+ posn) directives))) + (values + (expand-bind-defaults () params + #-ecl + `(let ((stream (make-case-frob-stream stream + ,(if colonp + (if atsignp + :upcase + :capitalize) + (if atsignp + :capitalize-first + :downcase))))) + ,@(expand-directive-list before)) + #+ecl + `(princ + (,(if colonp + (if atsignp 'nstring-upcase 'nstring-capitalize) + (if atsignp 'nstring-capitalize-first 'nstring-downcase)) + (with-output-to-string (stream) + ,@(expand-directive-list before))) + stream)) + after)))) + +(def-complex-format-interpreter #\( (colonp atsignp params directives) + (let ((close (find-directive directives #\) nil))) + (unless close + (error 'format-error + :complaint "No corresponding close paren.")) + (interpret-bind-defaults () params + #-ecl + (let* ((posn (position close directives)) + (before (subseq directives 0 posn)) + (after (nthcdr (1+ posn) directives)) + (stream (make-case-frob-stream stream + (if colonp + (if atsignp + :upcase + :capitalize) + (if atsignp + :capitalize-first + :downcase))))) + (setf args (interpret-directive-list stream before orig-args args)) + after) + #+ecl + (let* ((posn (position close directives)) + (before (subseq directives 0 posn)) + (after (nthcdr (1+ posn) directives))) + (princ + (funcall (if colonp + (if atsignp + 'nstring-upcase + 'nstring-capitalize) + (if atsignp + 'nstring-capitalize-first + 'nstring-downcase)) + (with-output-to-string (stream) + (setf args (interpret-directive-list stream before + orig-args args)))) + stream) + after)))) + +(def-complex-format-directive #\) () + (error 'format-error + :complaint "No corresponding open paren.")) + +(def-complex-format-interpreter #\) () + (error 'format-error + :complaint "No corresponding open paren.")) + + +;;;; Conditionals + +(defun parse-conditional-directive (directives) + #-formatter + (declare (si::c-local)) + (let ((sublists nil) + (last-semi-with-colon-p nil) + (remaining directives)) + (loop + (let ((close-or-semi (find-directive remaining #\] t))) + (unless close-or-semi + (error 'format-error + :complaint "No corresponding close bracket.")) + (let ((posn (position close-or-semi remaining))) + (push (subseq remaining 0 posn) sublists) + (setf remaining (nthcdr (1+ posn) remaining)) + (when (char= (format-directive-character close-or-semi) #\]) + (return)) + (setf last-semi-with-colon-p + (format-directive-colonp close-or-semi))))) + (values sublists last-semi-with-colon-p remaining))) + +(def-complex-format-directive #\[ (colonp atsignp params directives) + (multiple-value-bind + (sublists last-semi-with-colon-p remaining) + (parse-conditional-directive directives) + (values + (if atsignp + (if colonp + (error 'format-error + :complaint + "Cannot specify both the colon and at-sign modifiers.") + (if (cdr sublists) + (error 'format-error + :complaint + "Can only specify one section") + (expand-bind-defaults () params + (expand-maybe-conditional (car sublists))))) + (if colonp + (if (= (length sublists) 2) + (expand-bind-defaults () params + (expand-true-false-conditional (car sublists) + (cadr sublists))) + (error 'format-error + :complaint + "Must specify exactly two sections.")) + (expand-bind-defaults ((index (expand-next-arg))) params + (setf *only-simple-args* nil) + (let ((clauses nil)) + (when last-semi-with-colon-p + (push `(t ,@(expand-directive-list (pop sublists))) + clauses)) + (let ((count (length sublists))) + (dolist (sublist sublists) + (push `(,(decf count) + ,@(expand-directive-list sublist)) + clauses))) + `(case ,index ,@clauses))))) + remaining))) + +(defun expand-maybe-conditional (sublist) + #-formatter + (declare (si::c-local)) + (flet ((hairy () + `(let ((prev-args args) + (arg ,(expand-next-arg))) + (when arg + (setf args prev-args) + ,@(expand-directive-list sublist))))) + (if *only-simple-args* + (multiple-value-bind + (guts new-args) + (let ((*simple-args* *simple-args*)) + (values (expand-directive-list sublist) + *simple-args*)) + (cond ((eq *simple-args* (cdr new-args)) + (setf *simple-args* new-args) + `(when ,(caar new-args) + ,@guts)) + (t + (setf *only-simple-args* nil) + (hairy)))) + (hairy)))) + +(defun expand-true-false-conditional (true false) + #-formatter + (declare (si::c-local)) + (let ((arg (expand-next-arg))) + (flet ((hairy () + `(if ,arg + (progn + ,@(expand-directive-list true)) + (progn + ,@(expand-directive-list false))))) + (if *only-simple-args* + (multiple-value-bind + (true-guts true-args true-simple) + (let ((*simple-args* *simple-args*) + (*only-simple-args* t)) + (values (expand-directive-list true) + *simple-args* + *only-simple-args*)) + (multiple-value-bind + (false-guts false-args false-simple) + (let ((*simple-args* *simple-args*) + (*only-simple-args* t)) + (values (expand-directive-list false) + *simple-args* + *only-simple-args*)) + (if (= (length true-args) (length false-args)) + `(if ,arg + (progn + ,@true-guts) + ,(do ((false false-args (cdr false)) + (true true-args (cdr true)) + (bindings nil (cons `(,(caar false) ,(caar true)) + bindings))) + ((eq true *simple-args*) + (setf *simple-args* true-args) + (setf *only-simple-args* + (and true-simple false-simple)) + (if bindings + `(let ,bindings + ,@false-guts) + `(progn + ,@false-guts))))) + (progn + (setf *only-simple-args* nil) + (hairy))))) + (hairy))))) + + + +(def-complex-format-interpreter #\[ (colonp atsignp params directives) + (multiple-value-bind + (sublists last-semi-with-colon-p remaining) + (parse-conditional-directive directives) + (setf args + (if atsignp + (if colonp + (error 'format-error + :complaint + "Cannot specify both the colon and at-sign modifiers.") + (if (cdr sublists) + (error 'format-error + :complaint + "Can only specify one section") + (interpret-bind-defaults () params + (let ((prev-args args) + (arg (next-arg))) + (if arg + (interpret-directive-list stream + (car sublists) + orig-args + prev-args) + args))))) + (if colonp + (if (= (length sublists) 2) + (interpret-bind-defaults () params + (if (next-arg) + (interpret-directive-list stream (car sublists) + orig-args args) + (interpret-directive-list stream (cadr sublists) + orig-args args))) + (error 'format-error + :complaint + "Must specify exactly two sections.")) + (interpret-bind-defaults ((index (next-arg))) params + (let* ((default (and last-semi-with-colon-p + (pop sublists))) + (last (1- (length sublists))) + (sublist + (if (<= 0 index last) + (nth (- last index) sublists) + default))) + (interpret-directive-list stream sublist orig-args + args)))))) + remaining)) + +(def-complex-format-directive #\; () + (error 'format-error + :complaint + "~~; not contained within either ~~[...~~] or ~~<...~~>.")) + +(def-complex-format-interpreter #\; () + (error 'format-error + :complaint + "~~; not contained within either ~~[...~~] or ~~<...~~>.")) + +(def-complex-format-interpreter #\] () + (error 'format-error + :complaint + "No corresponding open bracket.")) + +(def-complex-format-directive #\] () + (error 'format-error + :complaint + "No corresponding open bracket.")) + + +;;;; Up-and-out. + +(defvar *outside-args*) + +(def-format-directive #\^ (colonp atsignp params) + (when atsignp + (error 'format-error + :complaint "Cannot specify the at-sign modifier.")) + (when (and colonp (not *up-up-and-out-allowed*)) + (error 'format-error + :complaint "Attempt to use ~~:^ outside a ~~:{...~~} construct.")) + `(when ,(case (length params) + (0 (if colonp + '(null outside-args) + (progn + (setf *only-simple-args* nil) + '(null args)))) + (1 (expand-bind-defaults ((count 0)) params + `(zerop ,count))) + (2 (expand-bind-defaults ((arg1 0) (arg2 0)) params + `(= ,arg1 ,arg2))) + (t (expand-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params + `(<= ,arg1 ,arg2 ,arg3)))) + ,(if colonp + '(return-from outside-loop nil) + '(return)))) + +(def-format-interpreter #\^ (colonp atsignp params) + (when atsignp + (error 'format-error + :complaint "Cannot specify the at-sign modifier.")) + (when (and colonp (not *up-up-and-out-allowed*)) + (error 'format-error + :complaint "Attempt to use ~~:^ outside a ~~:{...~~} construct.")) + (when (case (length params) + (0 (if colonp + (null *outside-args*) + (null args))) + (1 (interpret-bind-defaults ((count 0)) params + (zerop count))) + (2 (interpret-bind-defaults ((arg1 0) (arg2 0)) params + (= arg1 arg2))) + (t (interpret-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params + (<= arg1 arg2 arg3)))) + (throw (if colonp 'up-up-and-out 'up-and-out) + args))) + + +;;;; Iteration. + +(def-complex-format-directive #\{ (colonp atsignp params string end directives) + (let ((close (find-directive directives #\} nil))) + (unless close + (error 'format-error + :complaint + "No corresponding close brace.")) + (let* ((closed-with-colon (format-directive-colonp close)) + (posn (position close directives))) + (labels + ((compute-insides () + (if (zerop posn) + (if *orig-args-available* + `((handler-bind + ((format-error + #'(lambda (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :arguments (list condition) + :print-banner nil + :control-string ,string + :offset ,(1- end))))) + (setf args + (formatter-aux stream inside-string orig-args args)))) + (throw 'need-orig-args nil)) + (let ((*up-up-and-out-allowed* colonp)) + (expand-directive-list (subseq directives 0 posn))))) + (compute-loop-aux (count) + (when atsignp + (setf *only-simple-args* nil)) + `(loop + ,@(unless closed-with-colon + '((when (null args) + (return)))) + ,@(when count + `((when (and ,count (minusp (decf ,count))) + (return)))) + ,@(if colonp + (let ((*expander-next-arg-macro* 'expander-next-arg) + (*only-simple-args* nil) + (*orig-args-available* t)) + `((let* ((orig-args ,(expand-next-arg)) + (outside-args args) + (args orig-args)) + (declare (ignorable orig-args outside-args args)) + (block nil + ,@(compute-insides))))) + (compute-insides)) + ,@(when closed-with-colon + '((when (null args) + (return)))))) + (compute-loop () + (if params + (expand-bind-defaults ((count nil)) params + (compute-loop-aux count)) + (compute-loop-aux nil))) + (compute-block () + (if colonp + `(block outside-loop + ,(compute-loop)) + (compute-loop))) + (compute-bindings () + (if atsignp + (compute-block) + `(let* ((orig-args ,(expand-next-arg)) + (args orig-args)) + (declare (ignorable orig-args args)) + ,(let ((*expander-next-arg-macro* 'expander-next-arg) + (*only-simple-args* nil) + (*orig-args-available* t)) + (compute-block)))))) + (values (if (zerop posn) + `(let ((inside-string ,(expand-next-arg))) + ,(compute-bindings)) + (compute-bindings)) + (nthcdr (1+ posn) directives)))))) + +(def-complex-format-interpreter #\{ + (colonp atsignp params string end directives) + (let ((close (find-directive directives #\} nil))) + (unless close + (error 'format-error + :complaint + "No corresponding close brace.")) + (interpret-bind-defaults ((max-count nil)) params + (let* ((closed-with-colon (format-directive-colonp close)) + (posn (position close directives)) + (insides (if (zerop posn) + (next-arg) + (subseq directives 0 posn))) + (*up-up-and-out-allowed* colonp)) + (labels + ((do-guts (orig-args args) + (if (zerop posn) + (handler-bind + ((format-error + #'(lambda (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :arguments (list condition) + :print-banner nil + :control-string string + :offset (1- end))))) + (formatter-aux stream insides orig-args args)) + (interpret-directive-list stream insides + orig-args args))) + (bind-args (orig-args args) + (if colonp + (let* ((arg (next-arg)) + (*logical-block-popper* nil) + (*outside-args* args)) + (catch 'up-and-out + (do-guts arg arg) + args)) + (do-guts orig-args args))) + (do-loop (orig-args args) + (catch (if colonp 'up-up-and-out 'up-and-out) + (loop + (when (and (not closed-with-colon) (null args)) + (return)) + (when (and max-count (minusp (decf max-count))) + (return)) + (setf args (bind-args orig-args args)) + (when (and closed-with-colon (null args)) + (return))) + args))) + (if atsignp + (setf args (do-loop orig-args args)) + (let ((arg (next-arg)) + (*logical-block-popper* nil)) + (do-loop arg arg))) + (nthcdr (1+ posn) directives)))))) + +(def-complex-format-directive #\} () + (error 'format-error + :complaint "No corresponding open brace.")) + +(def-complex-format-interpreter #\} () + (error 'format-error + :complaint "No corresponding open brace.")) + + + +;;;; Justification. + +(defparameter *illegal-inside-justification* + (mapcar (lambda (x) (parse-directive x 0)) + '("~W" "~:W" "~@W" "~:@W" + "~_" "~:_" "~@_" "~:@_" + "~:>" "~:@>" + "~I" "~:I" "~@I" "~:@I" + "~:T" "~:@T"))) + +(defun illegal-inside-justification-p (directive) + (member directive *illegal-inside-justification* + :test (lambda (x y) + (and (format-directive-p x) + (format-directive-p y) + (eql (format-directive-character x) (format-directive-character y)) + (eql (format-directive-colonp x) (format-directive-colonp y)) + (eql (format-directive-atsignp x) (format-directive-atsignp y)))))) + +(def-complex-format-directive #\< (colonp atsignp params string end directives) + (multiple-value-bind + (segments first-semi close remaining) + (parse-format-justification directives) + (values + (if (format-directive-colonp close) + (multiple-value-bind + (prefix per-line-p insides suffix) + (parse-format-logical-block segments colonp first-semi + close params string end) + (expand-format-logical-block prefix per-line-p insides + suffix atsignp)) + (let ((count (reduce #'+ (mapcar (lambda (x) + (count-if #'illegal-inside-justification-p x)) + segments)))) + (when (> count 0) + ;; ANSI specifies that "an error is signalled" in this + ;; situation. + (error 'format-error + :complaint "~D illegal directive~:P found inside justification block" + :arguments (list count))) + (expand-format-justification segments colonp atsignp + first-semi params))) + remaining))) + +(def-complex-format-interpreter #\< + (colonp atsignp params string end directives) + (multiple-value-bind + (segments first-semi close remaining) + (parse-format-justification directives) + (setf args + (if (format-directive-colonp close) + (multiple-value-bind + (prefix per-line-p insides suffix) + (parse-format-logical-block segments colonp first-semi + close params string end) + (interpret-format-logical-block stream orig-args args + prefix per-line-p insides + suffix atsignp)) + (let ((count (reduce #'+ (mapcar (lambda (x) + (count-if #'illegal-inside-justification-p x)) + segments)))) + (when (> count 0) + ;; ANSI specifies that "an error is signalled" in this + ;; situation. + (error 'format-error + :complaint "~D illegal directive~:P found inside justification block" + :arguments (list count))) + (interpret-format-justification stream orig-args args + segments colonp atsignp + first-semi params)))) + remaining)) + +(defun parse-format-justification (directives) + #-formatter + (declare (si::c-local)) + (let ((first-semi nil) + (close nil) + (remaining directives)) + (collect ((segments)) + (loop + (let ((close-or-semi (find-directive remaining #\> t))) + (unless close-or-semi + (error 'format-error + :complaint "No corresponding close bracket.")) + (let ((posn (position close-or-semi remaining))) + (segments (subseq remaining 0 posn)) + (setf remaining (nthcdr (1+ posn) remaining))) + (when (char= (format-directive-character close-or-semi) + #\>) + (setf close close-or-semi) + (return)) + (unless first-semi + (setf first-semi close-or-semi)))) + (values (segments) first-semi close remaining)))) + +(defun expand-format-justification (segments colonp atsignp first-semi params) + #-formatter + (declare (si::c-local)) + (let ((newline-segment-p + (and first-semi + (format-directive-colonp first-semi)))) + (expand-bind-defaults + ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + params + `(let ((segments nil) + ,@(when newline-segment-p + '((newline-segment nil) + (extra-space 0) + (line-len 72)))) + (block nil + ,@(when newline-segment-p + `((setf newline-segment + (with-output-to-string (stream) + ,@(expand-directive-list (pop segments)))) + ,(expand-bind-defaults + ((extra 0) + (line-len '(or #-ecl (sys::line-length stream) 72))) + (format-directive-params first-semi) + `(setf extra-space ,extra line-len ,line-len)))) + ,@(mapcar #'(lambda (segment) + `(push (with-output-to-string (stream) + ,@(expand-directive-list segment)) + segments)) + segments)) + (format-justification stream + ,@(if newline-segment-p + '(newline-segment extra-space line-len) + '(nil 0 0)) + segments ,colonp ,atsignp + ,mincol ,colinc ,minpad ,padchar))))) + +(defun interpret-format-justification + (stream orig-args args segments colonp atsignp first-semi params) + #-formatter + (declare (si::c-local)) + (interpret-bind-defaults + ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + params + (let ((newline-string nil) + (strings nil) + (extra-space 0) + (line-len 0)) + (setf args + (catch 'up-and-out + (when (and first-semi (format-directive-colonp first-semi)) + (interpret-bind-defaults + ((extra 0) + (len (or #-ecl (sys::line-length stream) 72))) + (format-directive-params first-semi) + (setf newline-string + (with-output-to-string (stream) + (setf args + (interpret-directive-list stream + (pop segments) + orig-args + args)))) + (setf extra-space extra) + (setf line-len len))) + (dolist (segment segments) + (push (with-output-to-string (stream) + (setf args + (interpret-directive-list stream segment + orig-args args))) + strings)) + args)) + (format-justification stream newline-string extra-space line-len strings + colonp atsignp mincol colinc minpad padchar))) + args) + +(defun format-justification (stream newline-prefix extra-space line-len strings + pad-left pad-right mincol colinc minpad padchar) + #-formatter + (declare (si::c-local)) + (setf strings (reverse strings)) + (when (and (not pad-left) (not pad-right) (null (cdr strings))) + (setf pad-left t)) + (let* ((num-gaps (+ (1- (length strings)) + (if pad-left 1 0) + (if pad-right 1 0))) + (chars (+ (* num-gaps minpad) + (loop + for string in strings + summing (length string)))) + (length (if (> chars mincol) + (+ mincol (* (ceiling (- chars mincol) colinc) colinc)) + mincol)) + (padding (- length chars))) + (when (and newline-prefix + (> (+ (or (#-ecl sys::charpos #+ecl sys:file-column stream) 0) + length extra-space) + line-len)) + (write-string newline-prefix stream)) + (flet ((do-padding () + (let ((pad-len (truncate padding num-gaps))) + (decf padding pad-len) + (decf num-gaps) + (dotimes (i pad-len) (write-char padchar stream))))) + (when pad-left + (do-padding)) + (when strings + (write-string (car strings) stream) + (dolist (string (cdr strings)) + (do-padding) + (write-string string stream))) + (when pad-right + (do-padding))))) + +(defun parse-format-logical-block + (segments colonp first-semi close params string end) + #-formatter + (declare (si::c-local)) + (when params + (error 'format-error + :complaint "No parameters can be supplied with ~~<...~~:>." + :offset (caar params))) + (multiple-value-bind + (prefix insides suffix) + (multiple-value-bind (prefix-default suffix-default) + (if colonp (values "(" ")") (values nil nil)) + (flet ((extract-string (list prefix-p) + (let ((directive (find-if #'format-directive-p list))) + (if directive + (error 'format-error + :complaint + "Cannot include format directives inside the ~ + ~:[suffix~;prefix~] segment of ~~<...~~:>" + :arguments (list prefix-p) + :offset (1- (format-directive-end directive))) + (apply #'concatenate 'string list))))) + (case (length segments) + (0 (values prefix-default nil suffix-default)) + (1 (values prefix-default (car segments) suffix-default)) + (2 (values (extract-string (car segments) t) + (cadr segments) suffix-default)) + (3 (values (extract-string (car segments) t) + (cadr segments) + (extract-string (caddr segments) nil))) + (t + (error 'format-error + :complaint "Too many segments for ~~<...~~:>."))))) + (when (format-directive-atsignp close) + (setf insides + (add-fill-style-newlines insides + string + (if first-semi + (format-directive-end first-semi) + end)))) + (values prefix + (and first-semi (format-directive-atsignp first-semi)) + insides + suffix))) + +(defun add-fill-style-newlines (list string offset) + (if list + (let ((directive (car list))) + (if (simple-string-p directive) + (nconc (add-fill-style-newlines-aux directive string offset) + (add-fill-style-newlines (cdr list) + string + (+ offset (length directive)))) + (cons directive + (add-fill-style-newlines (cdr list) + string + (format-directive-end directive))))) + nil)) + +(defun add-fill-style-newlines-aux (literal string offset) + (declare (si::c-local)) + (let ((end (length literal)) + (posn 0)) + (collect ((results)) + (loop + (let ((blank (position #\space literal :start posn))) + (when (null blank) + (results (subseq literal posn)) + (return)) + (let ((non-blank (or (position #\space literal :start blank + :test #'char/=) + end))) + (results (subseq literal posn non-blank)) + (results (make-format-directive + :string string :character #\_ + :start (+ offset non-blank) :end (+ offset non-blank) + :colonp t :atsignp nil :params nil)) + (setf posn non-blank)) + (when (= posn end) + (return)))) + (results)))) + +#+formatter +(defun expand-format-logical-block (prefix per-line-p insides suffix atsignp) + `(let ((arg ,(if atsignp 'args (expand-next-arg)))) + ,@(when atsignp + (setf *only-simple-args* nil) + '((setf args nil))) + (pprint-logical-block + (stream arg + ,(if per-line-p :per-line-prefix :prefix) ,prefix + :suffix ,suffix) + (let ((args arg) + ,@(unless atsignp + `((orig-args arg)))) + (declare (ignorable args ,@(unless atsignp '(orig-args)))) + (block nil + ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg) + (*only-simple-args* nil) + (*orig-args-available* t)) + (expand-directive-list insides))))))) + +(defun interpret-format-logical-block + (stream orig-args args prefix per-line-p insides suffix atsignp) + #-formatter + (declare (si::c-local)) + (let ((arg (if atsignp args (next-arg)))) + (if per-line-p + (pprint-logical-block + (stream arg :per-line-prefix prefix :suffix suffix) + (let ((*logical-block-popper* #'(lambda () (pprint-pop)))) + (catch 'up-and-out + (interpret-directive-list stream insides + (if atsignp orig-args arg) + arg)))) + (pprint-logical-block (stream arg :prefix prefix :suffix suffix) + (let ((*logical-block-popper* #'(lambda () (pprint-pop)))) + (catch 'up-and-out + (interpret-directive-list stream insides + (if atsignp orig-args arg) + arg)))))) + (if atsignp nil args)) + +(def-complex-format-directive #\> () + (error 'format-error + :complaint "No corresponding open bracket.")) + + +;;;; User-defined method. + +(def-format-directive #\/ (string start end colonp atsignp params) + (let ((symbol (extract-user-function-name string start end))) + (collect ((param-names) (bindings)) + (dolist (param-and-offset params) + (let ((param (cdr param-and-offset))) + (let ((param-name (gensym))) + (param-names param-name) + (bindings `(,param-name + ,(case param + (:arg (expand-next-arg)) + (:remaining '(length args)) + (t param))))))) + `(let ,(bindings) + (,symbol stream ,(expand-next-arg) ,colonp ,atsignp + ,@(param-names)))))) + +(def-format-interpreter #\/ (string start end colonp atsignp params) + (let ((symbol (extract-user-function-name string start end))) + (collect ((args)) + (dolist (param-and-offset params) + (let ((param (cdr param-and-offset))) + (case param + (:arg (args (next-arg))) + (:remaining (args (length args))) + (t (args param))))) + (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args))))) + +(defun extract-user-function-name (string start end) + #-formatter + (declare (si::c-local)) + (let ((slash (position #\/ string :start start :end (1- end) + :from-end t))) + (unless slash + (error 'format-error + :complaint "Malformed ~~/ directive.")) + (let* ((name (string-upcase (let ((foo string)) + ;; Hack alert: This is to keep the compiler + ;; quit about deleting code inside the subseq + ;; expansion. + (subseq foo (1+ slash) (1- end))))) + (first-colon (position #\: name)) + (second-colon (if first-colon (position #\: name :start (1+ first-colon)))) + (package-name (if first-colon + (subseq name 0 first-colon) + "COMMON-LISP-USER")) + (package (find-package package-name))) + (unless package + (error 'format-error + :complaint "No package named ~S" + :arguments (list package-name))) + (intern (cond + ((and second-colon (= second-colon (1+ first-colon))) + (subseq name (1+ second-colon))) + (first-colon + (subseq name (1+ first-colon))) + (t name)) + package)))) + + +;;;; Compile-time checking of format arguments and control string + +;;; +;;; Return the min/max numbers of arguments required for a call to +;;; FORMAT with control string FORMAT-STRING, null if we can't tell, +;;; or a string with an error message if parsing the control string +;;; causes a FORMAT-ERROR. +;;; +;;; This is called from FORMAT deftransforms. +;;; +(defun min/max-format-arguments-count (string) + #-formatter + (declare (si::c-local)) + (handler-case + (catch 'give-up + ;; For the side effect of validating the control string. + (%formatter string) + (%min/max-format-args (tokenize-control-string string))) + (format-error (e) + (format nil "~a" e)))) + +(defun %min/max-format-args (directives) + #-formatter + (declare (si::c-local)) + (let ((min-req 0) (max-req 0)) + (flet ((incf-both (&optional (n 1)) + (incf min-req n) + (incf max-req n))) + (loop + (let ((dir (pop directives))) + (when (null dir) + (return (values min-req max-req))) + (when (format-directive-p dir) + (incf-both (count :arg (format-directive-params dir) :key #'cdr)) + (let ((c (format-directive-character dir))) + (cond ((find c "ABCDEFGORSWX$/") + (incf-both)) + ((char= c #\P) + (unless (format-directive-colonp dir) + (incf-both))) + ((or (find c "IT%&|_<>();") (char= c #\newline))) + ((char= c #\[) + (multiple-value-bind (min max remaining) + (%min/max-conditional-args dir directives) + (setq directives remaining) + (incf min-req min) + (incf max-req max))) + ((char= c #\{) + (multiple-value-bind (min max remaining) + (%min/max-iteration-args dir directives) + (setq directives remaining) + (incf min-req min) + (incf max-req max))) + ((char= c #\?) + (cond ((format-directive-atsignp dir) + (incf min-req) + (setq max-req most-positive-fixnum)) + (t (incf-both 2)))) + (t (throw 'give-up nil)))))))))) + +;;; +;;; ANSI: if arg is out of range, no clause is selected. That means +;;; the minimum number of args required for the interior of ~[~] is +;;; always zero. +;;; +(defun %min/max-conditional-args (conditional directives) + #-formatter + (declare (si::c-local)) + (multiple-value-bind (sublists last-semi-with-colon-p remaining) + (parse-conditional-directive directives) + (declare (ignore last-semi-with-colon-p)) + (let ((sub-max (loop for s in sublists maximize + (nth-value 1 (%min/max-format-args s)))) + (min-req 1) + max-req) + (cond ((format-directive-atsignp conditional) + (setq max-req (max 1 sub-max))) + ((loop for p in (format-directive-params conditional) + thereis (or (integerp (cdr p)) + (memq (cdr p) '(:remaining :arg)))) + (setq min-req 0) + (setq max-req sub-max)) + (t + (setq max-req (1+ sub-max)))) + (values min-req max-req remaining)))) + +(defun %min/max-iteration-args (iteration directives) + #-formatter + (declare (si::c-local)) + (let* ((close (find-directive directives #\} nil)) + (posn (position close directives)) + (remaining (nthcdr (1+ posn) directives))) + (if (format-directive-atsignp iteration) + (values (if (zerop posn) 1 0) most-positive-fixnum remaining) + (let ((nreq (if (zerop posn) 2 1))) + (values nreq nreq remaining))))) + + diff --git a/src/lsp/iolib.lsp b/src/lsp/iolib.lsp index 6e08a9228..2dd4b049a 100644 --- a/src/lsp/iolib.lsp +++ b/src/lsp/iolib.lsp @@ -249,3 +249,8 @@ the one defined in the ANSI standard. *print-base* is 10, *print-array* is t, (*read-suppress* nil) (*readtable* (copy-readtable (si::standard-readtable)))) ,@body)) + +#-formatter +(defmacro formatter (control-string) + `#'(lambda (*standard-output* &rest args) + (si::formatter-aux *standard-output* ,control-string args))) diff --git a/src/lsp/load.lsp.in b/src/lsp/load.lsp.in index e2c704863..b5007f132 100644 --- a/src/lsp/load.lsp.in +++ b/src/lsp/load.lsp.in @@ -1,36 +1,38 @@ -(load "@abs_srcdir@/export.lsp" :verbose t) -(load "@abs_srcdir@/defmacro.lsp" :verbose t) -(load "@abs_srcdir@/helpfile.lsp" :verbose t) -(load "@abs_srcdir@/evalmacros.lsp" :verbose t) -(load "@abs_srcdir@/module.lsp" :verbose t) -(load "@abs_srcdir@/autoload.lsp" :verbose t) -(load "@abs_srcdir@/describe.lsp" :verbose t) -(load "@abs_srcdir@/setf.lsp" :verbose t) -(load "@abs_srcdir@/predlib.lsp" :verbose t) -(load "@abs_srcdir@/arraylib.lsp" :verbose t) -(load "@abs_srcdir@/assert.lsp" :verbose t) -(load "@abs_srcdir@/defstruct.lsp" :verbose t) -(load "@abs_srcdir@/iolib.lsp" :verbose t) -(load "@abs_srcdir@/listlib.lsp" :verbose t) -(load "@abs_srcdir@/mislib.lsp" :verbose t) -(load "@abs_srcdir@/numlib.lsp" :verbose t) -(load "@abs_srcdir@/packlib.lsp" :verbose t) -(load "@abs_srcdir@/seq.lsp" :verbose t) -(load "@abs_srcdir@/seqlib.lsp" :verbose t) -(load "@abs_srcdir@/trace.lsp" :verbose t) -(load "@abs_srcdir@/ansi.lsp" :verbose t) +(load "@abs_srcdir@/export.lsp" :verbose nil) +(load "@abs_srcdir@/defmacro.lsp" :verbose nil) +(load "@abs_srcdir@/helpfile.lsp" :verbose nil) +(load "@abs_srcdir@/evalmacros.lsp" :verbose nil) +(load "@abs_srcdir@/module.lsp" :verbose nil) +(load "@abs_srcdir@/autoload.lsp" :verbose nil) +(load "@abs_srcdir@/describe.lsp" :verbose nil) +(load "@abs_srcdir@/setf.lsp" :verbose nil) +(load "@abs_srcdir@/predlib.lsp" :verbose nil) +(load "@abs_srcdir@/arraylib.lsp" :verbose nil) +(load "@abs_srcdir@/assert.lsp" :verbose nil) +(load "@abs_srcdir@/defstruct.lsp" :verbose nil) +(load "@abs_srcdir@/iolib.lsp" :verbose nil) +(load "@abs_srcdir@/listlib.lsp" :verbose nil) +(load "@abs_srcdir@/mislib.lsp" :verbose nil) +(load "@abs_srcdir@/numlib.lsp" :verbose nil) +(load "@abs_srcdir@/packlib.lsp" :verbose nil) +(load "@abs_srcdir@/seq.lsp" :verbose nil) +(load "@abs_srcdir@/seqlib.lsp" :verbose nil) +(load "@abs_srcdir@/trace.lsp" :verbose nil) +(load "@abs_srcdir@/ansi.lsp" :verbose nil) #+old-loop -(load "@abs_srcdir@/loop.lsp" :verbose t) +(load "@abs_srcdir@/loop.lsp" :verbose nil) #-old-loop -(load "@abs_srcdir@/loop2.lsp" :verbose t) -(load "@abs_srcdir@/defpackage.lsp" :verbose t) -(load "@abs_srcdir@/ffi.lsp" :verbose t) +(load "@abs_srcdir@/loop2.lsp" :verbose nil) +#+cmu-format +(load "@abs_srcdir@/format.lsp" :verbose nil) +(load "@abs_srcdir@/defpackage.lsp" :verbose nil) +(load "@abs_srcdir@/ffi.lsp" :verbose nil) #+ffi -(load "@abs_srcdir@/ffi-objects.lsp" :verbose t) +(load "@abs_srcdir@/ffi-objects.lsp" :verbose nil) #+threads -(load "@abs_srcdir@/thread.lsp" :verbose t) +(load "@abs_srcdir@/thread.lsp" :verbose nil) #+tk -(load "@abs_srcdir@/tk-init.lsp" :verbose t) -(load "@abs_builddir@/config.lsp" :verbose t) -(load "@abs_srcdir@/top.lsp" :verbose t) +(load "@abs_srcdir@/tk-init.lsp" :verbose nil) +(load "@abs_builddir@/config.lsp" :verbose nil) +(load "@abs_srcdir@/top.lsp" :verbose nil) diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index f2a418f6a..6ae5e6c37 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -608,7 +608,7 @@ if not possible." ;; and tag all types to which it belongs. ;; (defun register-member-type (object) - (declare (si::c-local)) + ;(declare (si::c-local)) (let ((pos (assoc object *member-types*))) (or (and pos (cdr pos)) ;; We convert number into intervals, so that (AND INTEGER (NOT @@ -870,8 +870,7 @@ if not possible." ;; *ELEMENTARY-TYPES* and *MEMBER-TYPES*. ;; (defun canonical-type (type) - (declare (notinline clos::classp) - (si::c-local)) + (declare (notinline clos::classp)) (cond ((find-registered-tag type)) ((eq type 'T) -1) ((eq type 'NIL) 0)