From 4ae4db93da671248060221ba925e8ac2743e218f Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Fri, 11 Feb 2005 09:26:37 +0000 Subject: [PATCH] Placeholder routines for implementing backquotes using macros. Not yet finished --- src/c/backq.d | 80 +++-------- src/c/print.d | 324 +++++++++++++++++++++---------------------- src/c/read.d | 53 +++++-- src/c/symbols_list.h | 7 +- 4 files changed, 224 insertions(+), 240 deletions(-) diff --git a/src/c/backq.d b/src/c/backq.d index b1812292e..950f5189c 100644 --- a/src/c/backq.d +++ b/src/c/backq.d @@ -19,9 +19,6 @@ /******************************* ------- ******************************/ -/* #define attach(x) (*px = CONS(x, *px)) */ -#define attach(s) CDR(x) = CONS(s, CDR(x)); - #define QUOTE 1 #define EVAL 2 #define LIST 3 @@ -60,11 +57,11 @@ _cl_backq_cdr(cl_object *px) if (ATOM(x)) return(QUOTE); - if (CAR(x) == @'si::,') { - *px = CDR(x); + if (CAR(x) == @'si::unquote') { + *px = CADR(x); return(EVAL); } - if (CAR(x) == @'si::,@' || CAR(x) == @'si::,.') + if (CAR(x) == @'si::unquote-splice' || CAR(x) == @'si::unquote-nsplice') FEerror(",@@ or ,. has appeared in an illegal position.", 0); { cl_object ax, dx; a = _cl_backq_car(&CAR(x)); @@ -126,7 +123,7 @@ _cl_backq_cdr(cl_object *px) } if (a == EVAL) return(LIST); - attach(@'list'); + CDR(x) = CONS(@'list', CDR(x)); break; case LISTX: @@ -136,15 +133,15 @@ _cl_backq_cdr(cl_object *px) } if (a == EVAL) return(LISTX); - attach(@'list*'); + CDR(x) = CONS(@'list*', CDR(x)); break; case APPEND: - attach(@'append'); + CDR(x) = CONS(@'append', CDR(x)); break; case NCONC: - attach(@'nconc'); + CDR(x) = CONS(@'nconc', CDR(x)); break; default: @@ -189,16 +186,16 @@ _cl_backq_car(cl_object *px) if (ATOM(x)) return(QUOTE); - if (CAR(x) == @'si::,') { - *px = CDR(x); + if (CAR(x) == @'si::unquote') { + *px = CADR(x); return(EVAL); } - if (CAR(x) == @'si::,@') { - *px = CDR(x); + if (CAR(x) == @'si::unquote-splice') { + *px = CADR(x); return(APPEND); } - if (CAR(x) == @'si::,.') { - *px = CDR(x); + if (CAR(x) == @'si::unquote-nsplice') { + *px = CADR(x); return(NCONC); } d = _cl_backq_cdr(px); @@ -208,22 +205,18 @@ _cl_backq_car(cl_object *px) return(d); case LIST: -/* attach(@'list'); */ *px = CONS(@'list', *px); break; case LISTX: -/* attach(@'list*'); */ *px = CONS(@'list*', *px); break; case APPEND: -/* attach(@'append'); */ *px = CONS(@'append', *px); break; case NCONC: -/* attach(@'nconc'); */ *px = CONS(@'nconc', *px); break; @@ -246,50 +239,17 @@ backq(cl_object x) return(x); } -static -cl_object comma_reader(cl_object in, cl_object c) +static cl_object +quasiquote_macro(cl_object whole, cl_object env) { - cl_object x, y; - cl_fixnum backq_level = fix(SYM_VAL(@'si::*backq-level*')); - - if (backq_level <= 0) - FEreader_error("A comma has appeared out of a backquote.", in, 0); - /* Read character but skip spaces & complain at EOF */ - c = cl_peek_char(2,Ct,in); - if (c == CODE_CHAR('@@')) { - x = @'si::,@'; - ecl_read_char(in); - } else if (c == CODE_CHAR('.')) { - x = @'si::,.'; - ecl_read_char(in); - } else - x = @'si::,'; - ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level-1)); - y = read_object(in); - ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level)); - @(return CONS(x, y)) + if (length(whole) != 2) { + FEprogram_error("Syntax error: ~S.", 1, whole); + } + @(return backq(CADR(whole))) } -static -cl_object backquote_reader(cl_object in, cl_object c) -{ - cl_fixnum backq_level = fix(SYM_VAL(@'si::*backq-level*')); - ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level+1)); - in = read_object(in); - ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level)); - @(return backq(in)) -} - -#define make_cf(f) cl_make_cfun((f), Cnil, NULL, 2); - void init_backq(void) { - cl_object r; - - r = cl_core.standard_readtable; - r->readtable.table['`'].syntax_type = cat_terminating; - r->readtable.table['`'].macro = make_cf(backquote_reader); - r->readtable.table[','].syntax_type = cat_terminating; - r->readtable.table[','].macro = make_cf(comma_reader); + cl_def_c_macro(@'si::quasiquote', quasiquote_macro, 2); } diff --git a/src/c/print.d b/src/c/print.d index 804d0a359..84eafd0a8 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -816,6 +816,127 @@ write_character(int i, cl_object stream) } } +static void +write_array(bool vector, cl_object x, cl_object stream) +{ + const cl_index *adims; + cl_index subscripts[ARANKLIM]; + cl_fixnum n, j, m, k, i; + cl_fixnum print_length; + cl_fixnum print_level; + bool readably = ecl_print_readably(); + + if (vector) { + adims = &x->vector.fillp; + n = 1; + } else { + adims = x->array.dims; + n = x->array.rank; + } + if (readably) { + print_length = MOST_POSITIVE_FIXNUM; + print_level = MOST_POSITIVE_FIXNUM; + } else { + if (!ecl_print_array()) { + write_str(vector? "#', stream); + return; + } + print_level = ecl_print_level(); + print_length = ecl_print_length(); + } + write_ch('#', stream); + if (print_level == 0) + return; + if (readably) { + write_ch('A', stream); + write_ch('(', stream); + si_write_object_recursive(ecl_elttype_to_symbol(x->array.elttype), stream); + write_ch(INDENT, stream); + if (n > 0) { + write_ch('(', stream); + for (j=0; j= n) { + /* We can write the elements of the array */ + print_level -= n; + bds_bind(@'*print-level*', MAKE_FIXNUM(print_level)); + } else { + /* The elements of the array are not printed */ + n = print_level; + print_level = -1; + } + for (j = 0; j < n; j++) + subscripts[j] = 0; + for (m = 0, j = 0;;) { + for (i = j; i < n; i++) { + if (subscripts[i] == 0) { + WRITE_MARK(stream); + write_ch('(', stream); + WRITE_SET_INDENT(stream); + if (adims[i] == 0) { + write_ch(')', stream); + WRITE_UNMARK(stream); + j = i-1; + k = 0; + goto INC; + } + } + if (subscripts[i] > 0) + write_ch(INDENT, stream); + if (subscripts[i] >= print_length) { + write_str("...)", stream); + WRITE_UNMARK(stream); + k=adims[i]-subscripts[i]; + subscripts[i] = 0; + for (j = i+1; j < n; j++) + k *= adims[j]; + j = i-1; + goto INC; + } + } + /* FIXME: This conses! */ + if (print_level >= 0) + si_write_object_recursive(aref(x, m), stream); + else + write_ch('#', stream); + j = n-1; + k = 1; + + INC: + while (j >= 0) { + if (++subscripts[j] < adims[j]) + break; + subscripts[j] = 0; + write_ch(')', stream); + WRITE_UNMARK(stream); + --j; + } + if (j < 0) + break; + m += k; + } + if (print_level >= 0) { + bds_unwind1(); + } + if (readably) { + write_ch(')', stream); + } +} + cl_object si_write_ugly_object(cl_object x, cl_object stream) { @@ -907,165 +1028,14 @@ si_write_ugly_object(cl_object x, cl_object stream) write_symbol(x, stream); break; - case t_array: { - cl_index subscripts[ARANKLIM]; - cl_fixnum n, j, m, k, i; - cl_fixnum print_length; - cl_fixnum print_level; - bool readably = ecl_print_readably(); - - if (readably) { - print_length = MOST_POSITIVE_FIXNUM; - print_level = MOST_POSITIVE_FIXNUM; - } else { - if (!ecl_print_array()) { - write_str("#', stream); - break; - } - print_level = ecl_print_level(); - print_length = ecl_print_length(); - } - write_ch('#', stream); - if (print_level == 0) - break; - n = x->array.rank; - if (readably) { - write_ch('A', stream); - write_ch('(', stream); - si_write_object_recursive(ecl_elttype_to_symbol(x->array.elttype), stream); - write_ch(INDENT, stream); - if (n > 0) { - write_ch('(', stream); - for (j=0; jarray.dims[j]), stream); - if (j < n-1) - write_ch(INDENT, stream); - } - write_ch(')', stream); - } else - si_write_object_recursive(Cnil, stream); - write_ch(INDENT, stream); - } else { - write_decimal(n, stream); - write_ch('A', stream); - } - if (print_level >= n) { - /* We can write the elements of the array */ - print_level -= n; - bds_bind(@'*print-level*', MAKE_FIXNUM(print_level)); - } else { - /* The elements of the array are not printed */ - n = print_level; - print_level = -1; - } - for (j = 0; j < n; j++) - subscripts[j] = 0; - for (m = 0, j = 0;;) { - for (i = j; i < n; i++) { - if (subscripts[i] == 0) { - WRITE_MARK(stream); - write_ch('(', stream); - WRITE_SET_INDENT(stream); - if (x->array.dims[i] == 0) { - write_ch(')', stream); - WRITE_UNMARK(stream); - j = i-1; - k = 0; - goto INC; - } - } - if (subscripts[i] > 0) - write_ch(INDENT, stream); - if (subscripts[i] >= print_length) { - write_str("...)", stream); - WRITE_UNMARK(stream); - write_ch(INDENT, stream); - k=x->array.dims[i]-subscripts[i]; - subscripts[i] = 0; - for (j = i+1; j < n; j++) - k *= x->array.dims[j]; - j = i-1; - goto INC; - } - } - /* FIXME: This conses! */ - if (print_level >= 0) - si_write_object_recursive(aref(x, m), stream); - else - write_ch('#', stream); - j = n-1; - k = 1; - - INC: - while (j >= 0) { - if (++subscripts[j] < x->array.dims[j]) - break; - subscripts[j] = 0; - write_ch(')', stream); - WRITE_UNMARK(stream); - --j; - } - if (j < 0) - break; - m += k; - } - if (print_level >= 0) { - bds_unwind1(); - } - if (readably) { - write_ch(')', stream); - } + case t_array: + write_array(0, x, stream); break; - } - case t_vector: { - cl_fixnum print_length, print_level; - bool readably = ecl_print_readably(); - cl_index n = x->vector.fillp; - if (readably) { - print_length = MOST_POSITIVE_FIXNUM; - print_level = MOST_POSITIVE_FIXNUM; - } else { - if (!ecl_print_array()) { - write_str("#vector.dim, stream); - write_ch(' ', stream); - write_addr(x, stream); - write_ch('>', stream); - break; - } - print_level = ecl_print_level(); - print_length = ecl_print_length(); - } - write_ch('#', stream); - if (print_level == 0) - break; - WRITE_MARK(stream); - write_ch('(', stream); - WRITE_SET_INDENT(stream); - if (n > 0) { - if (print_length == 0) { - write_str("...)", stream); - break; - } - bds_bind(@'*print-level*', MAKE_FIXNUM(print_level-1)); - si_write_object_recursive(aref(x, 0), stream); - for (ndx = 1; ndx < x->vector.fillp; ndx++) { - write_ch(INDENT, stream); - if (ndx >= print_length) { - write_str("...", stream); - break; - } - si_write_object_recursive(aref(x, ndx), stream); - } - bds_unwind1(); - } - write_ch(')', stream); - WRITE_UNMARK(stream); + case t_vector: + write_array(1, x, stream); break; - } + case t_string: if (!ecl_print_escape() && !ecl_print_readably()) { for (ndx = 0; ndx < x->string.fillp; ndx++) @@ -1105,16 +1075,38 @@ si_write_ugly_object(cl_object x, cl_object stream) x = CDR(x); return si_write_object_recursive(x, stream); } - if (CAR(x) == @'quote' && CONSP(CDR(x)) && Null(CDDR(x))) { - write_ch('\'', stream); - x = CADR(x); - return si_write_object_recursive(x, stream); - } - if (CAR(x) == @'function' && CONSP(CDR(x)) && Null(CDDR(x))) { - write_ch('#', stream); - write_ch('\'', stream); - x = CADR(x); - return si_write_object_recursive(x, stream); + if (CONSP(CDR(x)) && Null(CDDR(x))) { + if (CAR(x) == @'quote') { + write_ch('\'', stream); + x = CADR(x); + return si_write_object_recursive(x, stream); + } + if (CAR(x) == @'function') { + write_ch('#', stream); + write_ch('\'', stream); + x = CADR(x); + return si_write_object_recursive(x, stream); + } + if (CAR(x) == @'si::quasiquote') { + write_ch('`', stream); + x = CADR(x); + return si_write_object_recursive(x, stream); + } + if (CAR(x) == @'si::unquote') { + write_ch(',', stream); + x = CADR(x); + return si_write_object_recursive(x, stream); + } + if (CAR(x) == @'si::unquote-splice') { + write_str(",@@", stream); + x = CADR(x); + return si_write_object_recursive(x, stream); + } + if (CAR(x) == @'si::unquote-nsplice') { + write_str(",.", stream); + x = CADR(x); + return si_write_object_recursive(x, stream); + } } circle = ecl_print_circle(); if (ecl_print_readably()) { diff --git a/src/c/read.d b/src/c/read.d index 3140f6de6..78e4e2479 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -461,6 +461,47 @@ left_parenthesis_reader(cl_object in, cl_object character) const char c = ')'; @(return do_read_delimited_list(c, in, 0)) } + +/* + * BACKQUOTE READER + */ + +static +cl_object comma_reader(cl_object in, cl_object c) +{ + cl_object x, y; + cl_fixnum backq_level = fix(SYM_VAL(@'si::*backq-level*')); + + if (backq_level <= 0) + FEreader_error("A comma has appeared out of a backquote.", in, 0); + /* Read character but skip spaces & complain at EOF */ + c = cl_peek_char(2,Ct,in); + if (c == CODE_CHAR('@@')) { + x = @'si::unquote-splice'; + ecl_read_char(in); + } else if (c == CODE_CHAR('.')) { + x = @'si::unquote-nsplice'; + ecl_read_char(in); + } else { + x = @'si::unquote'; + } + ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level-1)); + y = read_object(in); + ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level)); + return cl_list(2, x, y); +} + +static +cl_object backquote_reader(cl_object in, cl_object c) +{ + cl_fixnum backq_level = fix(SYM_VAL(@'si::*backq-level*')); + ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level+1)); + in = read_object(in); + ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level)); + @(return cl_macroexpand_1(2, cl_list(2, @'si::quasiquote', in), Cnil)); +} + + /* read_string(delim, in) reads a simple string terminated by character code delim @@ -701,13 +742,7 @@ sharp_left_parenthesis_reader(cl_object in, cl_object c, cl_object d) a = _cl_backq_car(&x); if (a == APPEND || a == NCONC) FEreader_error(",at or ,. has appeared in an illegal position.", in, 0); - if (a == QUOTE) { - v = funcall(4, @'make-array', cl_list(1, cl_length(x)), - @':initial-contents', x); - } else { - v = cl_list(4, @'si::,', @'apply', - CONS(@'quote', CONS(@'vector', Cnil)), x); - } + v = cl_list(3, @'coerce', x, @'vector'); } else if (fixed_size) { v = cl_alloc_simple_vector(dim, aet_object); v->vector.self.t = (cl_object *)cl_alloc_align(dim * sizeof(cl_object), sizeof(cl_object)); @@ -1769,17 +1804,13 @@ init_read(void) rtab['('].macro = make_cf2(left_parenthesis_reader); rtab[')'].syntax_type = cat_terminating; rtab[')'].macro = make_cf2(right_parenthesis_reader); -/* rtab[','].syntax_type = cat_terminating; rtab[','].macro = make_cf2(comma_reader); -*/ rtab[';'].syntax_type = cat_terminating; rtab[';'].macro = make_cf2(semicolon_reader); rtab['\\'].syntax_type = cat_single_escape; -/* rtab['`'].syntax_type = cat_terminating; rtab['`'].macro = make_cf2(backquote_reader); -*/ rtab['|'].syntax_type = cat_multiple_escape; /* rtab['|'].macro = make_cf2(vertical_bar_reader); diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index b10c6205f..0dad23a89 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1055,9 +1055,9 @@ cl_symbols[] = { {SYS_ "*STEP-LEVEL*", SI_SPECIAL, OBJNULL, -1, MAKE_FIXNUM(0)}, {SYS_ "*STEP-ACTION*", SI_SPECIAL, OBJNULL, -1, Cnil}, {SYS_ ".", SI_ORDINARY, NULL, -1, OBJNULL}, -{SYS_ ",", SI_ORDINARY, NULL, -1, OBJNULL}, -{SYS_ ",.", SI_ORDINARY, NULL, -1, OBJNULL}, -{SYS_ ",@", SI_ORDINARY, NULL, -1, OBJNULL}, +{SYS_ "UNQUOTE", SI_ORDINARY, NULL, -1, OBJNULL}, +{SYS_ "UNQUOTE-NSPLICE", SI_ORDINARY, NULL, -1, OBJNULL}, +{SYS_ "UNQUOTE-SPLICE", SI_ORDINARY, NULL, -1, OBJNULL}, {SYS_ "ALLOCATE-RAW-INSTANCE", SI_ORDINARY, si_allocate_raw_instance, 3, OBJNULL}, {SYS_ "ARGC", SI_ORDINARY, si_argc, 0, OBJNULL}, {SYS_ "ARGV", SI_ORDINARY, si_argv, 1, OBJNULL}, @@ -1479,6 +1479,7 @@ cl_symbols[] = { #endif {SYS_ "WHILE", SI_ORDINARY, NULL, -1, OBJNULL}, +{SYS_ "QUASIQUOTE", SI_ORDINARY, NULL, -1, OBJNULL}, /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}};