/* * APL system. * * There are four kinds of scalars: * - Booleans (0 or 1) * - Character (see below) * - Integer (long long int) * - Float (double) * Scalars are handled as rank-0 arrays. * * Arrays can have any rank up to MAXRANK. Everything is an array * (including scalars, as remarked above); an array is represented as * a header giving the type, rank, and refcount of the array, with an * indication of where the data is to be found. This can be kept * separately or it can be attached to the header. See the ARRAY * struct definition. * * There are two different representations used for text. * * To serialize text for purposes such as storing it in files, it must * be represented as an octet sequence. Our character set uses octet * values 32 through 122 (though there are two gaps in that range - 92 * and 96 are not used). Non-overstruck characters are represented as * single octets containing the relevant character code. Overstrikes * can be represented two ways. Overstrikes of 11 or fewer characters * are represented as a 0xff octet, followed by the overstruck codes, * in ascending numerical order, each stored in the low 7 bits of an * octet with the 0x80 bit set. Overstrikes of more than 11 * characters are represented as a 0xfe octet, followed by 11 octets * giving a bitmap of which codes are overstruck, with the 0x01 bit of * the first bitmap octet representing code 33, the 0x02 bit code 34, * the 0x01 bit of the second octet code 41, etc, with codes 92 and 96 * skipped, until the 0x80 bit of the last octet represents code 122. * In particular, each possible character or overstrike combination * has exactly one possible representation as an octet string. (There * are many octet strings that do not correspond to valid character * sequences (any octet sequence beginning with an octet in the * 0x00-0x1f range, for example).) * * Characters in memory, being operated on, are represented as ECHARs. * An ECHAR is a 12-byte data structure. It contains one octet which * is a type number, 1 through 12; if this number is 1 through 11, * then there are that many of the other 11 octets containing the * overstruck characters, with the extra octets, if any, undefined and * unused; if the type number is 12, then the other 11 octets hold a * bitmap, as described for serialization, above, without the leading * 0xfe octet. In a few places, where a representation for C's \0 * terminator as an ECHAR is convenient, it is represented with a type * octet of 0, with all 11 of the other octets undefined and unused. * * We store subscript vectors little-endian. That is, the subscript * corresponding to dims[0] varies fastest, which means that if APL * reports 2 3 4 for rho A, then A's dims[0] is 4, [1] is 3, and [2] * is 2, even though if V is 2 3 4, V->d[0] is 2, [1] is 3, and [2] is * 4. This means handling some things "backwards" in a few places, * notably perform__rho, do_subscript, and the [dim] syntax on * operators like , and /. */ #include #include #include #include #include #include #include #include #include #include #include #include extern const char *__progname; #define MAXRANK 31 #define MAXDIM 16777216 #define MAXELS 16777216 #define EPSILON (1e-7) typedef unsigned long long int ULLI; typedef long long int LLI; typedef LLI APLINT; #define APLINT_MAX ((LLI)((~(ULLI)0)>>1)) typedef double APLFLOAT; #define APLFLOAT_MAX DBL_MAX typedef enum { AT_ERR = 1, AT_BOOL, AT_INT, AT_FLOAT, AT_CHAR, } ATYPE; // Character values with special significance #define CH_SPACE 0x20 #define CH_RPAREN 0x22 #define CH_RBRACK 0x27 #define CH_AND 0x29 #define CH_DIVIDE 0x2b #define CH_COMMA 0x2c #define CH_PLUS 0x2d #define CH_DOT 0x2e #define CH_DIGIT_0 0x30 #define CH_DIGIT_1 0x31 #define CH_DIGIT_2 0x32 #define CH_DIGIT_3 0x33 #define CH_DIGIT_4 0x34 #define CH_DIGIT_5 0x35 #define CH_DIGIT_6 0x36 #define CH_DIGIT_7 0x37 #define CH_DIGIT_8 0x38 #define CH_DIGIT_9 0x39 #define CH_LPAREN 0x3a #define CH_LBRACK 0x3b #define CH_SEMICOLON 0x3c #define CH_TIMES 0x3d #define CH_NEGNUM 0x40 #define CH_MIN 0x44 #define CH_UNDER 0x46 #define CH_DELTA 0x48 #define CH_IOTA 0x49 #define CH_JOT 0x4a #define CH_QUOTE 0x4b #define CH_QUAD 0x4c #define CH_RHO 0x52 #define CH_MAX 0x53 #define CH_ASSIGN 0x5b #define CH_MINUS 0x5f #define CH_LETTER_A 0x61 #define CH_LETTER_B 0x62 #define CH_LETTER_C 0x63 #define CH_LETTER_D 0x64 #define CH_LETTER_E 0x65 #define CH_LETTER_F 0x66 #define CH_LETTER_G 0x67 #define CH_LETTER_H 0x68 #define CH_LETTER_I 0x69 #define CH_LETTER_J 0x6a #define CH_LETTER_K 0x6b #define CH_LETTER_L 0x6c #define CH_LETTER_M 0x6d #define CH_LETTER_N 0x6e #define CH_LETTER_O 0x6f #define CH_LETTER_P 0x70 #define CH_LETTER_Q 0x71 #define CH_LETTER_R 0x72 #define CH_LETTER_S 0x73 #define CH_LETTER_T 0x74 #define CH_LETTER_U 0x75 #define CH_LETTER_V 0x76 #define CH_LETTER_W 0x77 #define CH_LETTER_X 0x78 #define CH_LETTER_Y 0x79 #define CH_LETTER_Z 0x7a #define TT_NULL 1 #define TT_IDENT 2 #define TT_CHAR 3 #define TT_NUM 4 #define TT_STRING 5 #define TT_NONE 6 #define TT_END 7 typedef enum { SK_NONE = 1, SK_VAR, SK_FN, SK_LBL, } SYMKIND; typedef struct array ARRAY; typedef struct echar ECHAR; typedef struct ilstate ILSTATE; typedef struct sym SYM; typedef struct xstack XSTACK; typedef struct exctx EXCTX; typedef struct generic GENERIC; typedef struct xstate XSTATE; struct xstate { ARRAY *rhs; ECHAR *op; ARRAY *opdim; int brackn; ARRAY **brackv; ECHAR *brackend; ECHAR *bracksemi; ECHAR *bracke; } ; struct generic { ATYPE (*monadic_type)(ATYPE); ATYPE (*dyadic_type)(ATYPE, ATYPE); void (*perform_monadic)(ATYPE, void *, int, ATYPE, const void *, int); void (*perform_dyadic)(ATYPE, void *, int, ATYPE, const void *, int, ATYPE, const void *, int); } ; #define GENERIC_INIT(name) {\ &generic_##name##_m_type, \ &generic_##name##_d_type, \ &generic_##name##_m_perform, \ &generic_##name##_d_perform } struct exctx { const ECHAR *line; int linelen; int at; int len; } ; struct echar { unsigned char type; unsigned char data[11]; } ; struct xstack { XSTACK *link; XSTATE state; ECHAR *opener; ECHAR closer; } ; struct sym { SYM *link; ECHAR *name; unsigned int namelen; SYMKIND kind; union { // nothing for SK_NONE ARRAY *var; // SK_VAR // SK_FN not yet implemented // SK_LBL not yet implemented } u; } ; struct array { ATYPE type; int rank; int *dims; int els; int refs; void *d; } ; #define AD_BOOL(a) ((unsigned char *)(a)->d) #define AD_INT(a) ((APLINT *)(a)->d) #define AD_FLOAT(a) ((APLFLOAT *)(a)->d) #define AD_CHAR(a) ((ECHAR *)(a)->d) struct ilstate { ECHAR *b; ECHAR *eb; int a; int l; int pl; int c; int dl; int dc; int nl; int curcols; ECHAR *curb; int cura; int curdl; int curnl; int curcr; int curcc; } ; // The number of buffers used by (eg) c_to_ec_tmp. #define TEMPBUFS 8 static ILSTATE il; static struct winsize wsz; static void (*err_throw)(void); static const unsigned char bitmap_vec[88] = { 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f, 0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4a, 0x4b, 0x4c, 0x4d, 0x4e, 0x4f, 0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5a, 0x5b, 0x5d, 0x5e, 0x5f, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7a }; /* * Annoying. C99 specifies that later initializers override earlier, * but apparently that postdates 1.4T's compiler. And I haven't come * up with any way to do this mechanically without depending on that. * So, instead, we give up on consting this and build it at startup * time. */ static unsigned char bitmap_ivec[256]; static FILE *il_dbg; static unsigned char digits_map[11]; static unsigned char letters_map[11]; static unsigned char letters_digits_map[11]; static unsigned char digits_ch[10] = { CH_DIGIT_0, CH_DIGIT_1, CH_DIGIT_2, CH_DIGIT_3, CH_DIGIT_4, CH_DIGIT_5, CH_DIGIT_6, CH_DIGIT_7, CH_DIGIT_8, CH_DIGIT_9 }; static EXCTX execute_ctx; static SYM *syms = 0; static void get_wsz(void) { if (ioctl(1,TIOCGWINSZ,&wsz) < 0) { fprintf(stderr,"%s: can't TIOCGWINSZ: %s\n",__progname,strerror(errno)); } } static unsigned int bitvec_bytes(unsigned int bits) { return((bits+7)>>3); } static void bitvec_set(unsigned char *vec, unsigned int inx) { vec[inx>>3] |= 1 << (inx & 7); } static void bitvec_clr(unsigned char *vec, unsigned int inx) { vec[inx>>3] &= ~(1 << (inx & 7)); } static int bitvec_isset(const unsigned char *vec, unsigned int inx) { return((vec[inx>>3]>>(inx&7))&1); } static int c_to_ec_1(char c) { switch (c) { case ' ': return(0x20); break; case '': return(0x21); break; case ')': return(0x22); break; case '<': return(0x23); break; case '': return(0x24); break; case '=': return(0x25); break; case '>': return(0x26); break; case ']': return(0x27); break; case 'v': return(0x28); break; case '^': return(0x29); break; case '': return(0x2a); break; case '': return(0x2b); break; case ',': return(0x2c); break; case '+': return(0x2d); break; case '.': return(0x2e); break; case '/': return(0x2f); break; case '0': return(0x30); break; case '1': return(0x31); break; case '2': return(0x32); break; case '3': return(0x33); break; case '4': return(0x34); break; case '5': return(0x35); break; case '6': return(0x36); break; case '7': return(0x37); break; case '8': return(0x38); break; case '9': return(0x39); break; case '(': return(0x3a); break; case '[': return(0x3b); break; case ';': return(0x3c); break; case '': return(0x3d); break; case ':': return(0x3e); break; case '\\':return(0x3f); break; // many of 0x40-0x5f have no simple text form case '': return(0x40); break; case '_': return(0x46); break; case '\'':return(0x4b); break; case '*': return(0x50); break; case '?': return(0x51); break; case '~': return(0x54); break; // 0x5c: hole case '': return(0x5e); break; case '-': return(0x5f); break; // 0x60: hole case 'A': return(0x61); break; case 'B': return(0x62); break; case 'C': return(0x63); break; case 'D': return(0x64); break; case 'E': return(0x65); break; case 'F': return(0x66); break; case 'G': return(0x67); break; case 'H': return(0x68); break; case 'I': return(0x69); break; case 'J': return(0x6a); break; case 'K': return(0x6b); break; case 'L': return(0x6c); break; case 'M': return(0x6d); break; case 'N': return(0x6e); break; case 'O': return(0x6f); break; case 'P': return(0x70); break; case 'Q': return(0x71); break; case 'R': return(0x72); break; case 'S': return(0x73); break; case 'T': return(0x74); break; case 'U': return(0x75); break; case 'V': return(0x76); break; case 'W': return(0x77); break; case 'X': return(0x78); break; case 'Y': return(0x79); break; case 'Z': return(0x7a); break; } return(-1); } static ECHAR *c_to_ec_tmp(const char *s) { int l; static ECHAR *bufs[TEMPBUFS] = { 0 }; static int space[TEMPBUFS] = { 0 }; static int hand = 0; ECHAR *p; int i; int c; l = strlen(s) + 1; if (l > space[hand]) { free(bufs[hand]); space[hand] = l; bufs[hand] = malloc(l*sizeof(ECHAR)); } p = bufs[hand]; hand --; if (hand < 0) hand = TEMPBUFS - 1; l --; for (i=0;itype != b->type) return(0); if (a->type == 0) return(1); return(!bcmp(&a->data[0],&b->data[0],(a->type==12)?11:a->type)); } static int ec_equal_single(const ECHAR *ec, unsigned char ch) { if (ec->type != 1) return(0); return(ec->data[0]==ch); } static int ec_map_single(const ECHAR *ec, unsigned char *map) { int b; if (ec->type != 1) return(0); b = bitmap_ivec[ec->data[0]]; if (b == 0xff) return(0); return(bitvec_isset(map,b)); } static int ec_equal_double(const ECHAR *ec, unsigned char ch1, unsigned char ch2) { if (ec->type != 2) return(0); return( ((ec->data[0] == ch1) && (ec->data[1] == ch2)) || ((ec->data[0] == ch2) && (ec->data[1] == ch1)) ); } static int ec_map_double(const ECHAR *ec, unsigned char ch, unsigned char *map) { int b; if (ec->type != 2) return(0); if (ec->data[0] == ch) { ch = ec->data[1]; } else if (ec->data[1] == ch) { ch = ec->data[0]; } else { return(0); } b = bitmap_ivec[ch]; if (b == 0xff) return(0); return(bitvec_isset(map,b)); } static void ec_copy(const ECHAR *f, ECHAR *t, int n) { bcopy(f,t,n*sizeof(ECHAR)); } static void ec_fill(ECHAR *t, const ECHAR *f, int n) { for (;n>0;n--) *t++ = *f; } static void ec_dump(const ECHAR *e, FILE *f) { const char *pref; int i; switch (e->type) { case 0 ... 11: fprintf(f,"<"); pref = ""; for (i=0;itype;i++) { fprintf(f,"%s%02x",pref,e->data[i]); pref = "+"; } fprintf(f,">"); break; case 12: fprintf(f,"<"); pref = ""; for (i=0;i<88;i++) { if (bitvec_isset(e->data,i)) fprintf(f,"%s%02x",pref,bitmap_vec[i]); pref = "+"; } fprintf(f,">"); break; default: fprintf(f,"",e->type); break; } } static void ec_print(const ECHAR *s, int l) { int i; int any; if (il_dbg) fprintf(il_dbg," ec_print sending"); for (;l>0;s++,l--) { if ((s->type < 1) || (s->type > 12)) abort(); if (s->type == 12) { any = 0; for (i=88-1;i>=0;i--) { if (bitvec_isset(&s->data[0],i)) { if (any) { if (il_dbg) fprintf(il_dbg," \\b"); putchar(0x08); } if (il_dbg) fprintf(il_dbg," %02x",bitmap_vec[i]); putchar(bitmap_vec[i]); any = 1; } } } else { for (i=s->type-1;i>=0;i--) { if (il_dbg) fprintf(il_dbg," %02x",s->data[i]); putchar(s->data[i]); if (i) { if (il_dbg) fprintf(il_dbg," \\b"); putchar(0x08); } } } } if (il_dbg) fprintf(il_dbg," done\n"); } static void ec_overstrike(ECHAR *e, int c, int b) { int i; int j; if ((e->type == 1) && (e->data[0] == 0x20)) { e->data[0] = c; } else if (e->type == 12) { bitvec_set(e->data,b); } else { j = e->type; for (i=j-1;i>=0;i--) { if (c == e->data[i]) return; if (c > e->data[i]) j = i; } if (e->type == 11) { ECHAR t; t.type = 12; bzero(&t.data[0],11); bitvec_set(t.data,b); for (i=11-1;i>=0;i--) { b = bitmap_ivec[e->data[i]]; if (b == 0xff) abort(); bitvec_set(t.data,b); } *e = t; } else { if (j < e->type) bcopy(&e->data[j],&e->data[j+1],e->type-j); e->type ++; e->data[j] = c; } } } static ARRAY *error_array(const char *, ...) __attribute__((__format__(__printf__,1,2))); static ARRAY *error_array(const char *fmt, ...) { static ARRAY ea = { 0 }; va_list ap; char *s; ea.type = AT_ERR; ea.rank = -1; ea.dims = 0; ea.els = -1; ea.refs = 1; free(ea.d); va_start(ap,fmt); vasprintf(&s,fmt,ap); va_end(ap); ea.d = s; return(&ea); } static void array_drop(ARRAY *a) { if (!a || (a->type == AT_ERR)) return; a->refs --; if (a->refs > 0) return; if (a->refs < 0) abort(); free(a->dims); free(a->d); free(a); } static ARRAY *array_ref(ARRAY *a) { a->refs ++; return(a); } static ARRAY *new_array_internal(ATYPE at, int rank, const int *dims) { ARRAY *a; long long int cells; int x; cells = 1; if (rank) { for (x=0;x MAXDIM)) return(error_array("DIMENSION OUT OF RANGE")); cells *= dims[x]; if (cells > MAXELS) return(error_array("ARRAY CELL COUNT TOO LARGE")); } } a = malloc(sizeof(ARRAY)); a->type = at; a->rank = rank; if (rank) { a->dims = malloc(rank*sizeof(int)); bcopy(dims,a->dims,rank*sizeof(int)); } else { a->dims = 0; } a->els = cells; a->refs = 1; switch (at) { case AT_BOOL: a->d = malloc(bitvec_bytes(cells)); break; case AT_INT: a->d = malloc(cells*sizeof(APLINT)); break; case AT_FLOAT: a->d = malloc(cells*sizeof(APLFLOAT)); break; case AT_CHAR: a->d = malloc(cells*sizeof(ECHAR)); break; default: abort(); break; } if (a->d == 0) { array_drop(a); return(error_array("OUT OF MEMORY")); } return(a); } static ARRAY *new_array_l(ATYPE at, int rank, ...) { va_list ap; int x; int dims[MAXRANK]; if ((rank < 0) || (rank > MAXRANK)) abort(); va_start(ap,rank); for (x=0;x MAXRANK)) abort(); return(new_array_internal(at,rank,dims)); } static SYM *sym_lookup(const ECHAR *name, int namelen, int create) { SYM *s; int i; for <"sym"> (s=syms;s;s=s->link) { if (s->namelen != namelen) continue; for (i=namelen-1;i>=0;i--) if (! ec_equal(s->name+i,name+i)) continue <"sym">; return(s); } if (! create) return(0); s = malloc(sizeof(SYM)); s->namelen = namelen; s->name = malloc(namelen*sizeof(ECHAR)); ec_copy(name,s->name,namelen); s->kind = SK_NONE; s->link = syms; syms = s; return(s); } static void il_init(void) { struct termios tio; int fd; wsz.ws_col = 0; get_wsz(); if (wsz.ws_col == 0) { fprintf(stderr,"%s: No window size\n",__progname); exit(1); } if (wsz.ws_col < 10) { fprintf(stderr,"%s: window too narrow\n",__progname); exit(1); } il.b = 0; il.eb = 0; il.a = 0; il.l = 0; il.pl = 0; il.c = 0; il.curcols = wsz.ws_col; il.curb = 0; il.cura = 0; il.curdl = 0; il.curnl = 1; il.curcr = 0; il.curcc = 0; printf("\x1f" "overstrike:1\x0d"); tcgetattr(0,&tio); tio.c_lflag &= ~(ECHOKE|ECHOE|ECHOK|ECHO|ECHONL|ECHOPRT|ECHOCTL|ICANON); tio.c_cc[VMIN] = 1; tio.c_cc[VTIME] = 0; tcsetattr(0,TCSADRAIN|TCSASOFT,&tio); fd = open("apl.il.dbg",O_WRONLY|O_APPEND|O_TRUNC,0); if (fd < 0) { il_dbg = 0; } else { il_dbg = fdopen(fd,"a"); } } static void il_room(int l) { if (il.a < il.pl + l) { il.a = il.pl + l + 8; il.b = realloc(il.b,il.a*sizeof(ECHAR)); il.eb = il.b + il.pl; } } static void il_set_prefix(ECHAR *p) { int i; for (i=0;p[i].type;i++) ; il.pl = i; il_room(0); il.eb = il.b + il.pl; ec_copy(p,il.b,i); } static void il_del_at(int x, int n) { if ((x < 0) || (x+n > il.l)) abort(); if (x+n < il.l) ec_copy(il.eb+x+n,il.eb+x,il.l-(x+n)); il.l -= n; } static void il_transpose(void) { ECHAR t; if (il.c < 2) abort(); t = il.eb[il.c-2]; il.eb[il.c-2] = il.eb[il.c-1]; il.eb[il.c-1] = t; } static void il_printable(unsigned char c) { ECHAR *t; int b; if (c == ' ') { b = -1; } else { b = bitmap_ivec[c]; if (b == 0xff) abort(); } if (il.c == il.l) { il_room(il.l+1); t = &il.eb[il.c]; t->type = 1; t->data[0] = c; il.l ++; } else if (b >= 0) { ec_overstrike(&il.eb[il.c],c,b); } il.c ++; } static void il_insert_space(int at, int n) { ECHAR e; if ((at < 0) || (at > il.l)) abort(); il_room(il.l+n); if (at < il.l) ec_copy(il.eb+at,il.eb+at+n,il.l-at); e.type = 1; e.data[0] = 0x20; ec_fill(il.eb+at,&e,n); il.l += n; } static void il_cursto(int r, int c) { if (il_dbg) fprintf(il_dbg," cursto from r=%d c=%d to r=%d c=%d:",il.curcr,il.curcc,r,c); while (il.curcr > r) { if (il_dbg) fprintf(il_dbg," ^X"); putchar(0x18); il.curcr --; } while (il.curcr < r) { if (il_dbg) fprintf(il_dbg," ^N"); putchar(0x0e); il.curcr ++; } if ((c > 4) && (abs(c-il.curcc) > 5)) { if (il_dbg) fprintf(il_dbg," ^F-.%d.",c); putchar(0x06); printf("-.%d.",c); il.curcc = c; } else { if (1+c < il.curcc-c) { if (il_dbg) fprintf(il_dbg," ^M"); putchar(0x0d); il.curcc = 0; } while (il.curcc > c) { if (il_dbg) fprintf(il_dbg," ^H"); putchar(0x08); il.curcc --; } while (il.curcc < c) { if (il_dbg) fprintf(il_dbg," ^S"); putchar(0x13); il.curcc ++; } } if (il_dbg) fprintf(il_dbg," done\n"); } static void il_curstox(int x) { il_cursto(x/wsz.ws_col,x%wsz.ws_col); } static void il_end_next(void) { while (il.curcr < il.curnl-1) { putchar(0x0e); il.curcr ++; } putchar(0x0d); putchar(0x0a); } static void il_update(void) { int i; int j; int x0; int x1; int n; // Sanity check. if ((il.c < 0) || (il.l < 0) || (il.c > il.l)) abort(); // Compute dl and dc, which are l and c with the prefix included. il.dl = il.pl + il.l; il.dc = il.pl + il.c; if (il_dbg) { fprintf(il_dbg,"update\n"); fprintf(il_dbg," dl=%d dc=%d (pl=%d l=%d c=%d) cols=%d\n",il.dl,il.dc,il.pl,il.l,il.c,wsz.ws_col); n = (il.curcr * il.curcols) + il.curcc; fprintf(il_dbg," curdl=%d curc=%d (curcols=%d curcr=%d curcc=%d)\n",il.curdl,n,il.curcols,il.curcr,il.curcc); fprintf(il_dbg," cur data:"); for (i=0;i il.cura) { il.curb = realloc(il.curb,(il.cura=il.dl+16)*sizeof(ECHAR)); if (il_dbg) fprintf(il_dbg," grew curb\n"); } x0 = 0; while ((x0 < il.dl) && (x0 < il.curdl) && ec_equal(&il.b[x0],&il.curb[x0])) x0 ++; if (il_dbg) fprintf(il_dbg," initial equal up to %d\n",x0); if ((x0 != il.dl) || (il.dl != il.curdl)) { while (1) { x1 = x0; while ((x1 < il.dl) && (x1 < il.curdl) && ec_equal(&il.b[x1],&il.curb[x1])) x1 ++; if (il_dbg) fprintf(il_dbg," end of equal %d\n",x1); if (x1 > x0) x0 = x1; if (x0 == il.dl) { if (il_dbg) fprintf(il_dbg," at end of new\n"); if (x0 < il.curdl) { if (il_dbg) fprintf(il_dbg," clearing extra: %d\n",il.curdl-x0); j = il.curdl / wsz.ws_col; i = x0 / wsz.ws_col; while (j > i) { il_cursto(j,0); putchar(0x03); j --; } if (il_dbg) fprintf(il_dbg," clearing\n"); il_cursto(i,x0%wsz.ws_col); putchar(0x03); } break; } while ((x1 < il.dl) && (x1 < il.curdl) && !ec_equal(&il.b[x1],&il.curb[x1])) x1 ++; if (il_dbg) fprintf(il_dbg," end of difference %d\n",x1); if ((x1 == il.curdl) && (x1 < il.dl)) { x1 = il.dl; if (il_dbg) fprintf(il_dbg," extending into new, end now %d\n",x1); } while (x0 < x1) { i = x0 / wsz.ws_col; j = x0 % wsz.ws_col; il_cursto(i,j); n = wsz.ws_col - j; if (n > x1-x0) n = x1 - x0; if (il_dbg) fprintf(il_dbg," printing %d from %d, sending \"^^",n,x0); putchar(0x1e); if (n != 1) { if (il_dbg) fprintf(il_dbg,"%d",n); printf("%d",n); } putchar(' '); if (il_dbg) fprintf(il_dbg," \"\n"); ec_print(&il.b[x0],n); ec_copy(&il.b[x0],&il.curb[x0],n); il.curcc += n; if (il.curcc >= wsz.ws_col) { il.curcc = 0; il.curcr ++; } x0 += n; } } } il.curdl = il.dl; il_curstox(il.dc); il.curnl = il.curdl / wsz.ws_col; if (il_dbg) fprintf(il_dbg," update done\n"); } static void il_new_line(void) { il.l = 0; il.c = 0; il.curdl = 0; il.curnl = 1; il.curcr = 0; il.curcc = 0; } /* * Formats: * * Format Takes Function * @1c int Prints char * @c ECHAR Prints char * @o nothing @c on execute_ctx.line[execute_ctx.at] * @%s char * Prints (mapping of) C string * * Non-escapes in format are always mapped. */ static int apl_vasprintf(ECHAR **sp, const char *fmt, va_list ap) { ECHAR *o; int oa; int ol; ECHAR *ec; int cc; ECHAR *o_append(void) { if (ol >= oa) o = realloc(o,(oa=ol+8)*sizeof(ECHAR)); return(&o[ol++]); } o = 0; oa = 0; ol = 0; while (*fmt) { if (*fmt != '@') { cc = c_to_ec_1(*fmt); if (cc < 0) abort(); ec = o_append(); ec->type = 1; ec->data[0] = cc; fmt ++; continue; } if (fmt[1] == 'c') { ec = o_append(); *ec = va_arg(ap,ECHAR); fmt += 2; continue; } if (fmt[1] == 'o') { ec = o_append(); *ec = execute_ctx.line[execute_ctx.at]; fmt += 2; continue; } if ((fmt[1] == '1') && (fmt[2] == 'c')) { ec = o_append(); cc = va_arg(ap,int); if ((cc < 0) || (cc > 255) || (bitmap_ivec[cc] == 0xff)) abort(); ec->type = 1; ec->data[0] = cc; fmt += 3; continue; } if ((fmt[1] == '%') && (fmt[2] == 's')) { const unsigned char *cs; cs = va_arg(ap,const char *); for (;(cc=*cs);cs++) { cc = c_to_ec_1(cc); if (cc < 0) abort(); ec = o_append(); ec->type = 1; ec->data[0] = cc; } fmt += 3; continue; } abort(); } *sp = o; return(ol); } static void exec_err_immediate(const ECHAR *, int, int, int, const char *, ...) __attribute__((__noreturn__)); static void exec_err_immediate(const ECHAR *line, int ll, int at, int n, const char *fmt, ...) { ECHAR *s; int l; va_list ap; int i; va_start(ap,fmt); l = apl_vasprintf(&s,fmt,ap); va_end(ap); ec_print(s,l); free(s); printf("\n"); if (line) { ec_print(line,ll); printf("\n"); for (i=at;i>0;i--) putchar(CH_SPACE); for (i=n;i>0;i--) putchar(CH_AND); printf("\n"); } (*err_throw)(); abort(); } static void exec_err_ctx(const char *, ...) __attribute__((__noreturn__)); static void exec_err_ctx(const char *fmt, ...) { ECHAR *s; int l; va_list ap; int i; va_start(ap,fmt); l = apl_vasprintf(&s,fmt,ap); va_end(ap); ec_print(s,l); free(s); printf("\n"); if (execute_ctx.line) { ec_print(execute_ctx.line,execute_ctx.linelen); printf("\n"); for (i=execute_ctx.at;i>0;i--) putchar(CH_SPACE); for (i=execute_ctx.len;i>0;i--) putchar(CH_AND); printf("\n"); } (*err_throw)(); abort(); } static ARRAY *promote_array(ARRAY *a, ATYPE t) { ARRAY *n; int i; switch (a->type) { case AT_BOOL: switch (t) { case AT_BOOL: return(a); break; case AT_INT: n = new_array_v(AT_INT,a->rank,a->dims); if (n->type == AT_ERR) break; for (i=a->els-1;i>=0;i--) AD_INT(n)[i] = bitvec_isset(AD_BOOL(a),i) ? 1 : 0; break; case AT_FLOAT: n = new_array_v(AT_FLOAT,a->rank,a->dims); if (n->type == AT_ERR) break; for (i=a->els-1;i>=0;i--) AD_FLOAT(n)[i] = bitvec_isset(AD_BOOL(a),i) ? 1 : 0; break; case AT_CHAR: return(0); break; default: abort(); break; } break; case AT_INT: switch (t) { case AT_BOOL: case AT_INT: return(a); break; case AT_FLOAT: n = new_array_v(AT_FLOAT,a->rank,a->dims); if (n->type == AT_ERR) break; for (i=a->els-1;i>=0;i--) AD_FLOAT(n)[i] = AD_INT(a)[i]; return(n); break; case AT_CHAR: return(0); break; default: abort(); break; } break; case AT_FLOAT: switch (t) { case AT_BOOL: case AT_INT: case AT_FLOAT: return(a); break; case AT_CHAR: return(0); break; default: abort(); break; } break; case AT_CHAR: switch (t) { case AT_CHAR: return(a); break; case AT_BOOL: case AT_INT: case AT_FLOAT: return(0); break; default: abort(); break; } break; default: abort(); break; } array_drop(a); return(n); } static ARRAY *grow_vector(ARRAY *a, int newsize) { int nb; if (a->rank != 1) abort(); if (newsize <= a->dims[0]) return(a); switch (a->type) { case AT_BOOL: nb = bitvec_bytes(newsize); if (nb == bitvec_bytes(a->dims[0])) return(a); a->d = realloc(a->d,nb); a->dims[0] = newsize; break; case AT_INT: a->d = realloc(a->d,newsize*sizeof(APLINT)); a->dims[0] = newsize; break; case AT_FLOAT: a->d = realloc(a->d,newsize*sizeof(APLFLOAT)); a->dims[0] = newsize; break; case AT_CHAR: a->d = realloc(a->d,newsize*sizeof(ECHAR)); a->dims[0] = newsize; break; default: abort(); break; } if (a->d == 0) { array_drop(a); return(error_array("OUT OF MEMORY")); } return(a); } static void reverse_vector(ARRAY *a) { int i; int j; if (a->rank != 1) abort(); for (i=a->dims[0]-1,j=0;i>j;i--,j++) { switch (a->type) { case AT_BOOL: if (bitvec_isset(AD_BOOL(a),i)) { if (! bitvec_isset(AD_BOOL(a),j)) { bitvec_clr(AD_BOOL(a),i); bitvec_set(AD_BOOL(a),j); } } else { if (bitvec_isset(AD_BOOL(a),j)) { bitvec_set(AD_BOOL(a),i); bitvec_clr(AD_BOOL(a),j); } } break; case AT_INT: { APLINT t; t = AD_INT(a)[i]; AD_INT(a)[i] = AD_INT(a)[j]; AD_INT(a)[j] = t; } break; case AT_FLOAT: { APLFLOAT t; t = AD_FLOAT(a)[i]; AD_FLOAT(a)[i] = AD_FLOAT(a)[j]; AD_FLOAT(a)[j] = t; } break; case AT_CHAR: { ECHAR t; t = AD_CHAR(a)[i]; AD_CHAR(a)[i] = AD_CHAR(a)[j]; AD_CHAR(a)[j] = t; } break; default: abort(); break; } } } static void domain_error(void) __attribute__((__noreturn__)); static void domain_error(void) { exec_err_ctx("@o: DOMAIN ERROR"); } static ARRAY *perform__comma_catenate(ARRAY *lhs, ARRAY *rhs, APLINT dim) { array_drop(lhs); array_drop(rhs); (void)dim; printf("%lld\n",(LLI)dim); exec_err_ctx("CATENATE NOT IMPLEMENTED"); } static ARRAY *perform__comma_laminate(ARRAY *lhs, ARRAY *rhs, APLINT dim) { array_drop(lhs); array_drop(rhs); (void)dim; printf("%lld\n",(LLI)dim); exec_err_ctx("LAMINATE NOT IMPLEMENTED"); } static ARRAY *perform__comma(ARRAY *lhs, ARRAY *rhs, ARRAY *dim) { ARRAY *r; int nb; if (dim) { if (! lhs) { exec_err_ctx("MONADIC @o[] NOT IMPLEMENTED"); } if (dim->els != 1) abort(); switch (dim->type) { case AT_FLOAT: { APLFLOAT f; f = AD_FLOAT(dim)[0]; if (f <= 0) exec_err_ctx(",[] DIMENSION OUT OF RANGE"); if (abs(f-(APLINT)(f+.5)) < EPSILON) { APLINT i; i = f + .5; if (0) { case AT_INT: i = AD_INT(dim)[0]; } if (0) { case AT_BOOL: i = bitvec_isset(AD_BOOL(dim),0) ? 1 : 0; } return(perform__comma_catenate(lhs,rhs,i)); } return(perform__comma_laminate(lhs,rhs,floor(f))); } break; default: abort(); break; } } if (lhs) { return(perform__comma_catenate(lhs,rhs,-1)); } else { r = new_array_l(rhs->type,1,rhs->els); if (r->els > 0) { switch (rhs->type) { case AT_BOOL: nb = bitvec_bytes(r->els); break; case AT_INT: nb = r->els * sizeof(APLINT); break; case AT_FLOAT: nb = r->els * sizeof(APLFLOAT); break; case AT_CHAR: nb = r->els * sizeof(ECHAR); break; default: abort(); break; } bcopy(rhs->d,r->d,nb); } } return(r); } static ARRAY *perform__iota(ARRAY *lhs, ARRAY *rhs) { ARRAY *r; int i; LLI n; if (lhs) { exec_err_ctx("@o: DYADIC NOT IMPLEMENTED"); } else if (rhs->els < 1) { exec_err_ctx("@o: TOO FEW ARGUMENT ELEMENTS"); } else if (rhs->els > 1) { exec_err_ctx("@o: TOO MANY ARGUMENT ELEMENTS"); } else { switch (rhs->type) { case AT_INT: n = AD_INT(rhs)[0]; break; case AT_BOOL: n = bitvec_isset(AD_BOOL(rhs),0) ? 1 : 0; break; default: domain_error(); break; } if ((n < 0) || (n > MAXDIM)) domain_error(); r = new_array_l(AT_INT,1,(int)n); if (r->type != AT_ERR) for (i=n-1;i>=0;i--) AD_INT(r)[i] = i + 1; array_drop(rhs); return(r); } } static void copy_value_sametype(ARRAY *t, int tx, ARRAY *f, int fx) { switch (t->type) { case AT_FLOAT: AD_FLOAT(t)[tx] = AD_FLOAT(f)[fx]; break; case AT_INT: AD_INT(t)[tx] = AD_INT(f)[fx]; break; case AT_BOOL: if (bitvec_isset(AD_BOOL(f),fx)) bitvec_set(AD_BOOL(t),tx); else bitvec_clr(AD_BOOL(t),tx); break; case AT_CHAR: AD_CHAR(t)[tx] = AD_CHAR(f)[fx]; break; default: abort(); break; } } static ARRAY *perform__rho(ARRAY *lhs, ARRAY *rhs) { ARRAY *r; int i; APLINT d; int dims[MAXRANK]; long long int cells; int j; if (lhs) { if (lhs->els < 1) exec_err_ctx("@o: NO DIMENSIONS"); if (lhs->els > MAXRANK) exec_err_ctx("@o: TOO MANY DIMENSIONS"); cells = 1; j = 0; switch (lhs->type) { case AT_FLOAT: case AT_CHAR: exec_err_ctx("@o: DIMENSIONS MUST BE INTEGERS"); break; case AT_INT: // [i] backwards from [j] - see file header comment for (i=lhs->els-1;i>=0;i--) { d = AD_INT(lhs)[i]; if ((d < 0) || (d > MAXDIM)) exec_err_ctx("@o: DIMENSION OUT OF RANGE"); dims[j++] = d; cells *= d; if (cells > MAXDIM) exec_err_ctx("@o: ARRAY CELL COUNT TOO LARGE"); } break; case AT_BOOL: // [i] backwards from [j] - see file header comment for (i=lhs->els-1;i>=0;i--) { d = bitvec_isset(AD_BOOL(lhs),i) ? 1 : 0; dims[j++] = d; cells *= d; } break; default: abort(); break; } r = new_array_v(rhs->type,lhs->els,&dims[0]); if ((r->type != AT_ERR) && (r->els > 0)) { if (rhs->els < 1) exec_err_ctx("@o: NO ELEMENTS TO RESHAPE"); j = 0; for (i=0;iels;i++) { if (j >= rhs->els) j = 0; copy_value_sametype(r,i,rhs,j++); } } } else { r = new_array_l(AT_INT,1,rhs->rank); if (r->type != AT_ERR) { j = 0; // [i] backwards from [j] - see file header comment for (i=rhs->rank-1;i>=0;i--) AD_INT(r)[j++] = rhs->dims[i]; } array_drop(rhs); } return(r); } /* * Monadic: just call doit for each element; the result has the same * shape as the argument. (It may or may not have the same type * * Dyadic: the operands must have the same shape, or one of them must * be either rank 0 or rank 1 with just one element. If one is rank 0 * and the other is rank 1 with one element, we produce a result with * rank 1 and one element. */ static ARRAY *perform_generic(ARRAY *lhs, ARRAY *rhs, GENERIC *op) { __label__ throwto; void (*save_throw)(void); ATYPE rt; ARRAY *r; int i; int ones; void throw(void) { goto throwto; } r = 0; if (0) { throwto:; array_drop(r); err_throw = save_throw; (*err_throw)(); abort(); } save_throw = err_throw; err_throw = &throw; if (! lhs) { rt = (*op->monadic_type)(rhs->type); if (rt == AT_ERR) exec_err_ctx("@o: WRONG ARGUMENT TYPE"); r = new_array_v(rt,rhs->rank,rhs->dims); if (r->type != AT_ERR) { for (i=rhs->els-1;i>=0;i--) { (*op->perform_monadic)(rt,r->d,i,rhs->type,rhs->d,i); } } } else { rt = (*op->dyadic_type)(lhs->type,rhs->type); if (rt == AT_ERR) exec_err_ctx("@o: WRONG ARGUMENT TYPE"); ones = ( ( (lhs->rank == 0) || ( (lhs->rank == 1) && (lhs->els == 1) ) ) ? 2 : 0) | ( ( (rhs->rank == 0) || ( (rhs->rank == 1) && (rhs->els == 1) ) ) ? 1 : 0); switch (ones) { case 3: if (lhs->rank || rhs->rank) { r = new_array_l(rt,1,1); } else { r = new_array_l(rt,0); } if (r->type == AT_ERR) break; (*op->perform_dyadic)(rt,r->d,0,lhs->type,lhs->d,0,rhs->type,rhs->d,0); break; case 2: r = new_array_v(rt,rhs->rank,rhs->dims); if (r->type == AT_ERR) break; for (i=r->els-1;i>=0;i--) (*op->perform_dyadic)(rt,r->d,i,lhs->type,lhs->d,0,rhs->type,rhs->d,i); break; case 1: r = new_array_v(rt,lhs->rank,lhs->dims); if (r->type == AT_ERR) break; for (i=r->els-1;i>=0;i--) (*op->perform_dyadic)(rt,r->d,i,lhs->type,lhs->d,i,rhs->type,rhs->d,0); break; case 0: if (rhs->rank != lhs->rank) exec_err_ctx("@o: ARGUMENT CONFORMABILITY"); for (i=rhs->rank-1;i>=0;i--) if (lhs->dims[i] != rhs->dims[i]) exec_err_ctx("@o: ARGUMENT CONFORMABILITY"); r = new_array_v(rt,lhs->rank,lhs->dims); if (r->type == AT_ERR) break; for (i=r->els-1;i>=0;i--) (*op->perform_dyadic)(rt,r->d,i,lhs->type,lhs->d,i,rhs->type,rhs->d,i); break; } } err_throw = save_throw; array_drop(lhs); array_drop(rhs); return(r); } static ATYPE generic_arith_m_type(ATYPE at) { switch (at) { case AT_FLOAT: case AT_INT: return(at); break; case AT_BOOL: return(AT_INT); break; case AT_CHAR: return(AT_ERR); break; default: abort(); break; } } static ATYPE generic_arith_d_type(ATYPE lt, ATYPE rt) { switch (lt) { case AT_FLOAT: switch (rt) { case AT_FLOAT: case AT_INT: case AT_BOOL: return(AT_FLOAT); break; case AT_CHAR: return(AT_ERR); break; default: abort(); break; } break; case AT_INT: switch (rt) { case AT_FLOAT: return(AT_FLOAT); break; case AT_INT: case AT_BOOL: return(AT_INT); break; case AT_CHAR: return(AT_ERR); break; default: abort(); break; } break; case AT_BOOL: switch (rt) { case AT_FLOAT: return(AT_FLOAT); break; case AT_INT: case AT_BOOL: return(AT_INT); break; case AT_CHAR: return(AT_ERR); break; default: abort(); break; } break; case AT_CHAR: return(AT_ERR); break; default: abort(); break; } } static ATYPE generic_minmax_m_type(ATYPE at) { switch (at) { case AT_FLOAT: return(AT_INT); break; case AT_INT: case AT_BOOL: return(at); break; case AT_CHAR: return(AT_ERR); break; default: abort(); break; } } static ATYPE generic_plus_m_type(ATYPE at) { switch (at) { case AT_FLOAT: case AT_INT: case AT_BOOL: return(at); break; case AT_CHAR: return(AT_ERR); break; default: abort(); break; } } static void generic_plus_m_perform(ATYPE ot, void *od, int ox, ATYPE at, const void *ad, int ax) { if (ot != at) abort(); switch (ot) { case AT_FLOAT: ((APLFLOAT *)od)[ox] = ((const APLFLOAT *)ad)[ax]; break; case AT_INT: ((APLINT *)od)[ox] = ((const APLINT *)ad)[ax]; break; case AT_BOOL: if (bitvec_isset(ad,ax)) bitvec_set(od,ox); else bitvec_clr(od,ox); break; default: abort(); break; } } static void generic_plus_d_perform(ATYPE ot, void *od, int ox, ATYPE lt, const void *ld, int lx, ATYPE rt, const void *rd, int rx) { switch (ot) { case AT_FLOAT: { APLFLOAT f; switch (lt) { case AT_FLOAT: f = ((const APLFLOAT *)ld)[lx]; break; case AT_INT: f = ((const APLINT *)ld)[lx]; break; case AT_BOOL: f = bitvec_isset(ld,lx) ? 1 : 0; break; default: abort(); break; } switch (rt) { case AT_FLOAT: f += ((const APLFLOAT *)rd)[rx]; break; case AT_INT: f += ((const APLINT *)rd)[rx]; break; case AT_BOOL: f += bitvec_isset(rd,rx) ? 1 : 0; break; default: abort(); break; } ((APLFLOAT *)od)[ox] = f; } break; case AT_INT: { APLINT i; switch (lt) { case AT_INT: i = ((const APLINT *)ld)[lx]; break; case AT_BOOL: i = bitvec_isset(ld,lx) ? 1 : 0; break; default: abort(); break; } switch (rt) { case AT_INT: i += ((const APLINT *)rd)[rx]; break; case AT_BOOL: i += bitvec_isset(rd,rx) ? 1 : 0; break; default: abort(); break; } ((APLINT *)od)[ox] = i; } break; default: abort(); break; } } #define generic_plus_d_type generic_arith_d_type static GENERIC generic_plus = GENERIC_INIT(plus); static void generic_minus_m_perform(ATYPE ot, void *od, int ox, ATYPE at, const void *ad, int ax) { (void)ot; switch (at) { case AT_FLOAT: ((APLFLOAT *)od)[ox] = - ((const APLFLOAT *)ad)[ax]; break; case AT_INT: ((APLINT *)od)[ox] = - ((const APLINT *)ad)[ax]; break; case AT_BOOL: ((APLINT *)od)[ox] = bitvec_isset(ad,ax) ? -1 : 0; default: abort(); break; } } static void generic_minus_d_perform(ATYPE ot, void *od, int ox, ATYPE lt, const void *ld, int lx, ATYPE rt, const void *rd, int rx) { switch (ot) { case AT_FLOAT: { APLFLOAT f; switch (lt) { case AT_FLOAT: f = ((const APLFLOAT *)ld)[lx]; break; case AT_INT: f = ((const APLINT *)ld)[lx]; break; case AT_BOOL: f = bitvec_isset(ld,lx) ? 1 : 0; break; default: abort(); break; } switch (rt) { case AT_FLOAT: f -= ((const APLFLOAT *)rd)[rx]; break; case AT_INT: f -= ((const APLINT *)rd)[rx]; break; case AT_BOOL: f -= bitvec_isset(rd,rx) ? 1 : 0; break; default: abort(); break; } ((APLFLOAT *)od)[ox] = f; } break; case AT_INT: { APLINT i; switch (lt) { case AT_INT: i = ((const APLINT *)ld)[lx]; break; case AT_BOOL: i = bitvec_isset(ld,lx) ? 1 : 0; break; default: abort(); break; } switch (rt) { case AT_INT: i -= ((const APLINT *)rd)[rx]; break; case AT_BOOL: i -= bitvec_isset(rd,rx) ? 1 : 0; break; default: abort(); break; } ((APLINT *)od)[ox] = i; } break; default: abort(); break; } } #define generic_minus_m_type generic_arith_m_type #define generic_minus_d_type generic_arith_d_type static GENERIC generic_minus = GENERIC_INIT(minus); static ATYPE generic_times_m_type(ATYPE at) { switch (at) { case AT_FLOAT: case AT_INT: return(AT_INT); break; case AT_BOOL: return(AT_BOOL); break; case AT_CHAR: return(AT_ERR); break; default: abort(); break; } } static void generic_times_m_perform(ATYPE ot, void *od, int ox, ATYPE at, const void *ad, int ax) { (void)ot; switch (at) { case AT_FLOAT: { APLFLOAT f; f = ((const APLFLOAT *)ad)[ax]; ((APLINT *)od)[ox] = (f < 0) ? -1 : (f > 0) ? 1 : 0; } break; case AT_INT: { APLINT i; i = ((const APLINT *)ad)[ax]; ((APLINT *)od)[ox] = (i < 0) ? -1 : (i > 0) ? 1 : 0; } break; case AT_BOOL: if (bitvec_isset(ad,ax)) bitvec_set(od,ox); else bitvec_clr(od,ox); break; default: abort(); break; } } static void generic_times_d_perform(ATYPE ot, void *od, int ox, ATYPE lt, const void *ld, int lx, ATYPE rt, const void *rd, int rx) { switch (ot) { case AT_FLOAT: { APLFLOAT f; switch (lt) { case AT_FLOAT: f = ((const APLFLOAT *)ld)[lx]; break; case AT_INT: f = ((const APLINT *)ld)[lx]; break; case AT_BOOL: f = bitvec_isset(ld,lx) ? 1 : 0; break; default: abort(); break; } switch (rt) { case AT_FLOAT: f *= ((const APLFLOAT *)rd)[rx]; break; case AT_INT: f *= ((const APLINT *)rd)[rx]; break; case AT_BOOL: f *= bitvec_isset(rd,rx) ? 1 : 0; break; default: abort(); break; } ((APLFLOAT *)od)[ox] = f; } break; case AT_INT: { APLINT i; switch (lt) { case AT_INT: i = ((const APLINT *)ld)[lx]; break; case AT_BOOL: i = bitvec_isset(ld,lx) ? 1 : 0; break; default: abort(); break; } switch (rt) { case AT_INT: i *= ((const APLINT *)rd)[rx]; break; case AT_BOOL: i *= bitvec_isset(rd,rx) ? 1 : 0; break; default: abort(); break; } ((APLINT *)od)[ox] = i; } break; default: abort(); break; } } #define generic_times_d_type generic_arith_d_type static GENERIC generic_times = GENERIC_INIT(times); static ATYPE generic_divide_m_type(ATYPE at) { switch (at) { case AT_FLOAT: case AT_INT: return(AT_FLOAT); break; case AT_BOOL: return(AT_BOOL); break; case AT_CHAR: return(AT_ERR); break; default: abort(); break; } } static ATYPE generic_divide_d_type(ATYPE lt, ATYPE rt) { switch (lt) { case AT_FLOAT: switch (rt) { case AT_FLOAT: case AT_INT: case AT_BOOL: return(AT_FLOAT); break; case AT_CHAR: return(AT_ERR); break; default: abort(); break; } break; case AT_INT: switch (rt) { case AT_FLOAT: case AT_INT: return(AT_FLOAT); break; case AT_BOOL: return(AT_INT); break; case AT_CHAR: return(AT_ERR); break; default: abort(); break; } break; case AT_BOOL: switch (rt) { case AT_FLOAT: case AT_INT: return(AT_FLOAT); break; case AT_BOOL: return(AT_BOOL); break; case AT_CHAR: return(AT_ERR); break; default: abort(); break; } break; case AT_CHAR: return(AT_ERR); break; default: abort(); break; } } static void generic_divide_m_perform(ATYPE ot, void *od, int ox, ATYPE at, const void *ad, int ax) { (void)ot; switch (at) { case AT_FLOAT: { APLFLOAT f; f = ((const APLFLOAT *)ad)[ax]; if (f == 0) domain_error(); ((APLFLOAT *)od)[ox] = 1 / f; } break; case AT_INT: { APLINT i; i = ((const APLINT *)ad)[ax]; if (i == 0) domain_error(); ((APLFLOAT *)od)[ox] = 1.0 / i; } break; case AT_BOOL: if (bitvec_isset(ad,ax)) bitvec_set(od,ox); else domain_error(); break; default: abort(); break; } } static void generic_divide_d_perform(ATYPE ot, void *od, int ox, ATYPE lt, const void *ld, int lx, ATYPE rt, const void *rd, int rx) { switch (ot) { case AT_FLOAT: { APLFLOAT n; APLFLOAT d; switch (lt) { case AT_FLOAT: n = ((const APLFLOAT *)ld)[lx]; break; case AT_INT: n = ((const APLINT *)ld)[lx]; break; case AT_BOOL: n = bitvec_isset(ld,lx) ? 1 : 0; break; default: abort(); break; } switch (rt) { case AT_FLOAT: d = ((const APLFLOAT *)rd)[rx]; break; case AT_INT: d = ((const APLINT *)rd)[rx]; break; case AT_BOOL: d = bitvec_isset(rd,rx) ? 1 : 0; break; default: abort(); break; } if (d == 0) domain_error(); ((APLFLOAT *)od)[ox] = n / d; } break; case AT_INT: { APLINT n; switch (lt) { case AT_INT: n = ((const APLINT *)ld)[lx]; break; default: abort(); break; } switch (rt) { case AT_BOOL: if (! bitvec_isset(rd,rx)) domain_error(); break; default: abort(); break; } ((APLINT *)od)[ox] = n; } break; case AT_BOOL: { switch (rt) { case AT_BOOL: if (! bitvec_isset(rd,rx)) domain_error(); break; default: abort(); break; } switch (lt) { case AT_BOOL: if (bitvec_isset(ld,lx)) bitvec_set(od,ox); else bitvec_clr(od,ox); break; default: abort(); break; } } break; default: abort(); break; } } static GENERIC generic_divide = GENERIC_INIT(divide); static void generic_min_m_perform(ATYPE ot, void *od, int ox, ATYPE at, const void *ad, int ax) { (void)ot; switch (at) { case AT_FLOAT: ((APLINT *)od)[ox] = floor(((const APLFLOAT *)ad)[ax]+EPSILON); break; case AT_INT: ((APLINT *)od)[ox] = ((const APLINT *)ad)[ax]; break; case AT_BOOL: if (bitvec_isset(ad,ax)) bitvec_set(od,ox); else bitvec_clr(od,ox); break; default: abort(); break; } } static void generic_min_d_perform(ATYPE ot, void *od, int ox, ATYPE lt, const void *ld, int lx, ATYPE rt, const void *rd, int rx) { switch (ot) { case AT_FLOAT: { APLFLOAT f1; APLFLOAT f2; switch (lt) { case AT_FLOAT: f1 = ((const APLFLOAT *)ld)[lx]; break; case AT_INT: f1 = ((const APLINT *)ld)[lx]; break; case AT_BOOL: f1 = bitvec_isset(ld,lx) ? 1 : 0; break; default: abort(); break; } switch (rt) { case AT_FLOAT: f2 = ((const APLFLOAT *)rd)[rx]; break; case AT_INT: f2 = ((const APLINT *)rd)[rx]; break; case AT_BOOL: f2 = bitvec_isset(rd,rx) ? 1 : 0; break; default: abort(); break; } ((APLFLOAT *)od)[ox] = (f1 < f2) ? f1 : f2; } break; case AT_INT: { APLINT i1; APLINT i2; switch (lt) { case AT_INT: i1 = ((const APLINT *)ld)[lx]; break; case AT_BOOL: i1 = bitvec_isset(ld,lx) ? 1 : 0; break; default: abort(); break; } switch (rt) { case AT_INT: i2 = ((const APLINT *)rd)[rx]; break; case AT_BOOL: i2 = bitvec_isset(rd,rx) ? 1 : 0; break; default: abort(); break; } ((APLINT *)od)[ox] = (i1 < i2) ? i1 : i2; } break; default: abort(); break; } } #define generic_min_m_type generic_minmax_m_type #define generic_min_d_type generic_arith_d_type static GENERIC generic_min = GENERIC_INIT(min); static void generic_max_m_perform(ATYPE ot, void *od, int ox, ATYPE at, const void *ad, int ax) { (void)ot; switch (at) { case AT_FLOAT: ((APLINT *)od)[ox] = ceil(((const APLFLOAT *)ad)[ax]-EPSILON); break; case AT_INT: ((APLINT *)od)[ox] = ((const APLINT *)ad)[ax]; break; case AT_BOOL: if (bitvec_isset(ad,ax)) bitvec_set(od,ox); else bitvec_clr(od,ox); break; default: abort(); break; } } static void generic_max_d_perform(ATYPE ot, void *od, int ox, ATYPE lt, const void *ld, int lx, ATYPE rt, const void *rd, int rx) { switch (ot) { case AT_FLOAT: { APLFLOAT f1; APLFLOAT f2; switch (lt) { case AT_FLOAT: f1 = ((const APLFLOAT *)ld)[lx]; break; case AT_INT: f1 = ((const APLINT *)ld)[lx]; break; case AT_BOOL: f1 = bitvec_isset(ld,lx) ? 1 : 0; break; default: abort(); break; } switch (rt) { case AT_FLOAT: f2 = ((const APLFLOAT *)rd)[rx]; break; case AT_INT: f2 = ((const APLINT *)rd)[rx]; break; case AT_BOOL: f2 = bitvec_isset(rd,rx) ? 1 : 0; break; default: abort(); break; } ((APLFLOAT *)od)[ox] = (f1 > f2) ? f1 : f2; } break; case AT_INT: { APLINT i1; APLINT i2; switch (lt) { case AT_INT: i1 = ((const APLINT *)ld)[lx]; break; case AT_BOOL: i1 = bitvec_isset(ld,lx) ? 1 : 0; break; default: abort(); break; } switch (rt) { case AT_INT: i2 = ((const APLINT *)rd)[rx]; break; case AT_BOOL: i2 = bitvec_isset(rd,rx) ? 1 : 0; break; default: abort(); break; } ((APLINT *)od)[ox] = (i1 > i2) ? i1 : i2; } break; default: abort(); break; } } #define generic_max_m_type generic_minmax_m_type #define generic_max_d_type generic_arith_d_type static GENERIC generic_max = GENERIC_INIT(max); static GENERIC *lookup_generic(const ECHAR *op) { if (op->type == 1) { switch (op->data[0]) { case CH_DIVIDE: return(&generic_divide); break; case CH_PLUS: return(&generic_plus); break; case CH_TIMES: return(&generic_times); break; case CH_MIN: return(&generic_min); break; case CH_MAX: return(&generic_max); break; case CH_MINUS: return(&generic_minus); break; } } return(0); } static ARRAY *perform_op(ARRAY *lhs, XSTATE *xs) { if (xs->opdim) { if (xs->op->type == 1) { switch (xs->op->data[0]) { case CH_COMMA: return(perform__comma(lhs,xs->rhs,xs->opdim)); break; } } exec_err_ctx("@%s @c[] NOT IMPLEMENTED",lhs?"DYADIC":"MONADIC",*xs->op); } else { if (xs->op->type == 1) { switch (xs->op->data[0]) { case CH_COMMA: return(perform__comma(lhs,xs->rhs,0)); break; case CH_IOTA: return(perform__iota(lhs,xs->rhs)); break; case CH_RHO: return(perform__rho(lhs,xs->rhs)); break; default: { GENERIC *g; g = lookup_generic(xs->op); if (g) return(perform_generic(lhs,xs->rhs,g)); } break; } } exec_err_ctx("@%s @c NOT IMPLEMENTED",lhs?"DYADIC":"MONADIC",*xs->op); } } static void xstate_init(XSTATE *xs) { xs->rhs = 0; xs->op = 0; xs->opdim = 0; xs->brackn = 0; xs->brackv = 0; } static void xstate_drop_brack(XSTATE *xs) { int i; for (i=xs->brackn-1;i>=0;i--) array_drop(xs->brackv[i]); free(xs->brackv); xs->brackn = 0; xs->brackv = 0; } static void xstate_freesub(XSTATE *xs) { array_drop(xs->rhs); array_drop(xs->opdim); xstate_drop_brack(xs); } static void xstate_brack_append(XSTATE *xs, ARRAY *a) { if (a && (a->type == AT_CHAR)) exec_err_ctx("SUBSCRIPTS MUST BE NUMERIC"); xs->brackn ++; xs->brackv = realloc(xs->brackv,xs->brackn*sizeof(ARRAY *)); xs->brackv[xs->brackn-1] = a; } #ifdef DEBUG_SUBSCRIPT static void dump_array(FILE *, ARRAY *, const char *, ...) __attribute__((__format__(__printf__,3,4))); static void dump_array(FILE *to, ARRAY *arr, const char *fmt, ...) { va_list ap; const char *sep; int i; int r(int o, int d) { int adv; int a; int n; int i; int j; if (d < 0) { fprintf(to," %lld",(LLI)AD_INT(arr)[o]); return(1); } adv = 0; n = arr->dims[d]; for (i=0;i0;j--) putc('\n',to); a = r(o,d-1); adv += a; o += a; } return(adv); } if (arr->type != AT_INT) { fprintf(to,"Dumping non-int array\n"); return; } va_start(ap,fmt); vfprintf(to,fmt,ap); va_end(ap); fprintf(to,": ["); sep = ""; for (i=arr->rank-1;i>=0;i--) { fprintf(to,"%s%d",sep,arr->dims[i]); sep = " "; } fprintf(to,"]\n"); r(0,arr->rank-1); putc('\n',to); } #endif /* * This is conceptually simple, but relatively complicated to * implement. * * In A[S1;S2;...;Sn], calling the returned array R: * * n must equal A's rank. Any completely omitted S arrays are taken to * be 1D vectors holding 1 through the max value for that dimension of * A. The dimensions of R are the concatenations of the dimensions of * the Si. That is, (rho) R is ((rho)S1),((rho)S2),...,(rho)Sn - and, * of course, the rank of R is the sum of the ranks of the Si. * * Some examples: * * A * 11 12 13 14 15 * 21 22 23 24 25 * 31 32 33 34 35 * (rho) A * 3 5 * A[1;2 3] * 12 13 * (rho) A[1;2 3] * 2 * A[,1;2 3] * 12 13 * (rho) A[,1;2 3] * 1 2 * A[1 2;3] * 13 23 * (rho) A[1 2;3] * 2 * A[1 2;,3] * 13 * 23 * (rho) A[1 2;,3] * 2 1 * A[1 3; 2 3 (rho) 2 3 1 1 4 5] * 12 13 11 * 11 14 15 * * 32 33 31 * 31 34 35 * (rho) A[1 3; 2 3 (rho) 2 3 1 1 4 5] * 2 2 3 * * There is no way to _reorder_ the dimensions here. For that, use * transpose - for fully general use, dyadic transpose. * * n is the new array, the one we return. nr is its rank. nd is its * dimensions. ns is its subscript vector and nsub its corresponding * linear subscript. ar is a's rank; as and asub are a's subscript * vector and linear subscript. In order to compute subscripts in a, * we map each subscript of n to which subscript array - which element * of subv[] - and which subscript of that array it corresponds to. * This is done with subinx (subv[] subscript) and subsub (subscript * in that array). * * Thus, ns[i] turns into array subv[subinx[i]] subscript subsub[i]. * * We optimize computing linear subscripts with multiplicative values. * Given an array X of rank xr and a vector of subscripts xs[] in it, * we compute a (conceptual) vector xm[] such that changing xs[i] from * N to M means changing x's linear subscript xlin by (M-N)*xm[i]. * * alin and nlin are the linear subscripts for a and n; am is the Xm[] * vector for a. We don't actually need an nm[] vector for n, because * we count with nlin and ns[] in parallel. * * Rather than having a separate Xs[] and Xm[] vector for each element * of subv, we keep each in a single vector, indexed by the dimension * of n they're relevant to; these variables are sub_s[] and sub_m[]. * We do keep a separate slin[], indexed by subv[] index. * * We compensate for 1-origin indexing by initializing the Xlin values * suitably. * * This code assumes we can mutate subv[] - not the arrays pointed to, * the vector of pointers itself. */ static ARRAY *do_subscript(ARRAY *a, int subn, ARRAY **subv) { ARRAY *n; int nr; int nd[MAXRANK]; int ns[MAXRANK]; int nlin; int ar; int as[MAXRANK]; int am[MAXRANK]; int alin; int subinx[MAXRANK]; int subsub[MAXRANK]; int sub_s[MAXRANK]; int sub_m[MAXRANK]; int slin[MAXRANK]; int i; int j; int k; int v; ARRAY *s; APLINT d; ULLI cells; #ifdef DEBUG_SUBSCRIPT static FILE *f = 0; #endif if (a->type != AT_INT) exec_err_ctx("SUBSCRIPTING CURRENTLY FOR INTEGER ARRAYS ONLY"); ar = a->rank; if (subn != ar) exec_err_ctx("SUBSCRIPT COUNT WRONG"); cells = 1; k = 0; /* * subv subscripts conceptually go backwards - see the file header * comment - but don't actually, because subv is built right-to-left * and thus is already reversed. */ for (i=0;idims[i-1] : 1; s = subv[i]; if (! s) { s = new_array_l(AT_INT,1,a->dims[i]); for (j=a->dims[i]-1;j>=0;j--) AD_INT(s)[j] = j + 1; subv[i] = s; } switch (s->type) { case AT_INT: break; case AT_BOOL: s = promote_array(s,AT_INT); subv[i] = s; break; default: exec_err_ctx("SUBSCRIPTS MUST BE INTEGERS"); break; } for (j=0;jrank;j++) { if (k >= MAXRANK) exec_err_ctx("TOO MANY DIMENSIONS"); d = s->dims[j]; if ((d < 0) || (d > MAXDIM)) exec_err_ctx("DIMENSION OUT OF RANGE"); subinx[k] = i; subsub[k] = j; nd[k] = d; ns[k] = 1; sub_s[k] = 1; sub_m[k] = j ? sub_m[k-1] * s->dims[j-1] : 1; cells *= d; if (cells > MAXELS) exec_err_ctx("ARRAY CELL COUNT TOO LARGE"); k ++; } slin[i] = 0; for (j=s->els-1;j>=0;j--) { d = AD_INT(s)[j]; if ((d < 1) || (d > a->dims[i])) exec_err_ctx("SUBSCRIPT OUT OF RANGE"); } as[i] = s->rank ? 1 : AD_INT(s)[0]; } nr = k; #ifdef DEBUG_SUBSCRIPT if (! f) { f = fopen("subscript.dbg","w"); setlinebuf(f); } fprintf(f,"---- do_subscript beginning\n"); dump_array(f,a,"Input"); for (i=0;i=0;i--) alin += (as[i] - 1) * am[i]; #ifdef DEBUG_SUBSCRIPT fprintf(f,"alin = %d\n",alin); #endif n = new_array_v(a->type,nr,&nd[0]); if (n->type == AT_ERR) exec_err_ctx("@%s",(const char *)n->d); if (n->els != cells) abort(); if (n->els < 1) { #ifdef DEBUG_SUBSCRIPT fprintf(f,"---- no elements, nothing to do!\n"); #endif return(n); } if (n->rank < 1) { #ifdef DEBUG_SUBSCRIPT fprintf(f,"---- scalar, copying just one element\n"); #endif copy_value_sametype(n,0,a,alin); return(n); } for (i=nr-1;i>=0;i--) ns[i] = 1; nlin = 0; while (1) { #ifdef DEBUG_SUBSCRIPT fprintf(f,"nlin = %d ns =",nlin); for (j=0;j=0;j--) { k = subinx[j]; if ((k < 0) || (k >= subn)) abort(); v = slin[k] += (ns[j] - sub_s[j]) * sub_m[j]; sub_s[j] = ns[j]; if (subsub[j] == 0) { s = subv[k]; if ((v < 0) || (v >= s->els)) abort(); v = AD_INT(s)[v]; if ((v < 1) || (v > a->dims[k])) abort(); alin += (v - as[k]) * am[k]; as[k] = v; } } #ifdef DEBUG_SUBSCRIPT fprintf(f,"alin = %d as =",alin); for (k=0;k= a->els)) abort(); copy_value_sametype(n,nlin,a,alin); nlin ++; if (nlin >= cells) break; j = 0; while (1) { if (j >= cells) abort(); ns[j] ++; if (ns[j] <= nd[j]) break; ns[j] = 1; j ++; } } return(n); } static ARRAY *execute_tokenized(ECHAR *line, unsigned char *tok, int len) { __label__ errto; void (*save_throw)(void); int t1; int t0; XSTATE xs; ECHAR *lastop; unsigned char digits[64]; int digits_n; unsigned char edigits[8]; int edigits_n; int dot; int neg_n; int neg_e; int i; int j; ARRAY *val; int vt; int vs; APLINT v_i; APLFLOAT v_f; XSTACK *stack; int tt; int moreval; int val_reverse; void throw(void) { goto errto; } void do_unary(void) { if (xs.op) { if (! xs.rhs) abort(); execute_ctx.at = xs.op - line; execute_ctx.len = 1; xs.rhs = perform_op(0,&xs); if (xs.rhs->type == AT_ERR) exec_err_ctx("@o: @%s",(const char *)xs.rhs->d); xs.op = 0; lastop = 0; } } save_throw = err_throw; err_throw = &throw; if (0) { errto:; array_drop(val); xstate_freesub(&xs); while (stack) { XSTACK *t; t = stack; stack = t->link; xstate_freesub(&t->state); free(t); } err_throw = save_throw; (*err_throw)(); abort(); } xstate_init(&xs); lastop = 0; val = 0; stack = 0; execute_ctx.line = line; execute_ctx.linelen = len; t0 = len; while (1) { if (t0 > 0) { t1 = --t0; for (;(t0>=0)&&(tok[t0]==tok[t1]);t0--) ; t0 ++; t1 ++; if (t1 == t0) abort(); tt = tok[t0] >> 1; } else if (t0 == 0) { t0 --; tt = TT_END; } else { break; } if (tt == TT_NULL) continue; if (val && (tt != moreval)) { if (vs >= 0) { if (val->rank != 1) abort(); if (vs == 1) { free(val->dims); val->dims = 0; val->els = 1; val->rank = 0; } else { val->dims[0] = vs; val->els = vs; if (val_reverse) reverse_vector(val); } } if (xs.brackn > 0) { execute_ctx.at = xs.brackend - line; execute_ctx.len = 1; val = do_subscript(val,xs.brackn,xs.brackv); xstate_drop_brack(&xs); } if (xs.rhs) { if (xs.op) { execute_ctx.at = xs.op - line; execute_ctx.len = 1; xs.rhs = perform_op(val,&xs); array_drop(xs.opdim); xs.opdim = 0; if (xs.rhs->type == AT_ERR) exec_err_ctx("@o: @%s",(const char *)xs.rhs->d); lastop = xs.op; xs.op = 0; val = 0; } else { exec_err_immediate(line,len,t0,1,"CONSECUTIVE VALUES"); } } else { xs.rhs = val; val = 0; } } moreval = TT_NONE; switch (tt) { case TT_END: if (xs.rhs) { do_unary(); } else { exec_err_immediate(line,len,t0,1,"MISSING OPERAND"); } break; case TT_IDENT: if ( (t0 > 0) && ((tok[t0-1] >> 1) == TT_CHAR) && ec_equal_single(line+t0-1,CH_QUAD) ) { exec_err_immediate(line,len,t0-1,t1-t0,"SYSTEM FUNCTIONS NOT IMPLEMENTED"); } if (xs.rhs && xs.op && ec_equal_single(xs.op,CH_ASSIGN)) { SYM *s; s = sym_lookup(line+t0,t1-t0,1); if (! s) exec_err_immediate(line,len,t0,t1-t0,"CAN'T CREATE SYMBOL"); switch (s->kind) { case SK_NONE: break; case SK_VAR: array_drop(s->u.var); break; default: abort(); break; } s->kind = SK_VAR; s->u.var = array_ref(xs.rhs); lastop = xs.op; xs.op = 0; } else { SYM *s; s = sym_lookup(line+t0,t1-t0,0); if (! s) exec_err_immediate(line,len,t0,t1-t0,"UNDEFINED SYMBOL"); if (s->kind != SK_VAR) abort(); val = array_ref(s->u.var); moreval = TT_NONE; vs = -1; continue; } break; case TT_CHAR: if (ec_equal_single(line+t0,CH_RPAREN)) { XSTACK *s; if (xs.rhs && !xs.op) exec_err_immediate(line,len,t1,1,"MISSING OPERATOR"); s = malloc(sizeof(XSTACK)); s->state = xs; s->opener = line + t0; s->closer.type = 1; s->closer.data[0] = CH_LPAREN; s->link = stack; xstate_init(&xs); stack = s; } else if (ec_equal_single(line+t0,CH_RBRACK)) { XSTACK *s; if (xs.rhs && !xs.op) exec_err_immediate(line,len,t1,1,"MISSING OPERATOR"); if (xs.brackn > 0) exec_err_immediate(line,len,t1,1,"[...][...] NOT IMPLEMENTED"); s = malloc(sizeof(XSTACK)); s->state = xs; s->state.brackend = line + t0; s->state.bracksemi = s->state.brackend; s->opener = line + t0; s->closer.type = 1; s->closer.data[0] = CH_LBRACK; s->link = stack; xstate_init(&xs); stack = s; } else if (stack && ec_equal(line+t0,&stack->closer)) { XSTACK *s; do_unary(); s = stack; stack = s->link; if (s->closer.type != 1) abort(); switch (s->closer.data[0]) { case CH_LPAREN: val = xs.rhs; xs.rhs = 0; xstate_freesub(&xs); xs = s->state; moreval = TT_NONE; vs = -1; continue; break; case CH_LBRACK: execute_ctx.at = t0; execute_ctx.len = (s->state.bracksemi - line) - t0; xstate_brack_append(&s->state,xs.rhs); xs.rhs = 0; if (xs.brackn > 0) abort(); // [ ][ ] not implemented! xstate_freesub(&xs); xs = s->state; val = 0; moreval = TT_NONE; continue; break; default: abort(); break; } } else if ( ec_equal_single(line+t0,CH_LPAREN) || ec_equal_single(line+t0,CH_LBRACK) ) { if (! stack) exec_err_immediate(line,len,t0,1,"UNCLOSED @c",line[t0]); execute_ctx.at = t0; execute_ctx.len = (stack->opener - (line+t0)) + 1; exec_err_ctx("IMPROPERLY NESTED @c ... @c",line[t0],*stack->opener); } else if (ec_equal_single(line+t0,CH_SEMICOLON)) { if (stack && ec_equal_single(&stack->closer,CH_LBRACK)) { do_unary(); execute_ctx.at = t0; execute_ctx.len = (stack->state.bracksemi - line) - t0; xstate_brack_append(&stack->state,xs.rhs); stack->state.bracksemi = line + t1; xstate_init(&xs); } else { exec_err_immediate(line,len,t0,t1-t0,"MIXED OUTPUT NOT IMPLEMENTED"); } } else { if (xs.brackn > 0) { if (ec_equal_single(line+t0,CH_COMMA)) { if ((xs.brackn > 1) || !xs.brackv[0] || (xs.brackv[0]->els != 1)) { exec_err_immediate(line,len,t0,t1-t0,",[] REQUIRES EXACTLY ONE SUBSCRIPT"); } do_unary(); xs.opdim = array_ref(xs.brackv[0]); xstate_drop_brack(&xs); } else { exec_err_immediate(line,len,t0,t1-t0,"@c[ ] NOT IMPLEMENTED",line[t0]); } } if (xs.rhs) { do_unary(); xs.op = line + t0; } else { exec_err_immediate(line,len,t0,1,"MISSING OPERAND"); } } break; case TT_NUM: digits_n = 0; edigits_n = -1; dot = -1; neg_n = 0; neg_e = 0; // Syntax checking done at token-splitting time, not here. for (i=t0;i { for (dv=10-1;dv>=0;dv--) { if (ec_equal_single(line+i,digits_ch[dv])) break <"found">; } abort(); } while (0); if (edigits_n < 0) { digvec = &digits[0]; np = &digits_n; max = sizeof(digits); } else { digvec = &edigits[0]; np = &edigits_n; max = sizeof(edigits); } if ((np[0] == 1) && (digvec[0] == 0) && (dv == 0)) { // nothing } else if (np[0] < max) { digvec[np[0]++] = dv; } else if (edigits_n < 0) { np[0] ++; } else { exec_err_immediate(line,len,t0,t1-t0,"NUMERIC EXPONENT OUT OF RANGE"); } } } if ((dot < 0) && (edigits_n < 0)) { // Integer if it's within range, float if not. int digv; int usefloat; v_i = 0; usefloat = 0; for (i=0;i APLFLOAT_MAX/10) { exec_err_immediate(line,len,t0,t1-t0,"FLOATING MANTISSA OVERFLOW"); } v_f = (v_f * 10) + digv; } else { if ( (v_i > APLINT_MAX/10) || ( (v_i == APLINT_MAX/10) && (digv > APLINT_MAX%10) ) ) { v_f = v_i; usefloat = 1; i --; continue; } v_i = (v_i * 10) + digv; } } if (neg_n) { if (usefloat) v_f = - v_f; else v_i = - v_i; } if (usefloat) { vt = AT_FLOAT; } else if ((v_i < 0) || (v_i > 1)) { vt = AT_INT; } else { vt = AT_BOOL; } } else { int e; int digv; v_f = 0; for (i=0;i DBL_MAX/10) { exec_err_immediate(line,len,t0,t1-t0,"FLOATING MANTISSA OVERFLOW"); } v_f = (v_f * 10) + digv; } e = 0; for (i=0;i= 0) e -= digits_n - dot; if (neg_n) v_f = - v_f; v_f *= pow(10,e); vt = AT_FLOAT; } if (! val) { vs = 0; val = new_array_l(vt,1,8); if (val->type == AT_ERR) { exec_err_immediate(line,len,t0,t1-t0,"ARRAY CREATE FAILED: @%s",(const char *)val->d); } val_reverse = 1; } else { val = promote_array(val,vt); if (val->type == AT_ERR) { exec_err_immediate(line,len,t0,t1-t0,"ARRAY PROMOTE FAILED: @%s",(const char *)val->d); } } if (vs >= val->dims[0]) { val = grow_vector(val,vs+8); if (val->type == AT_ERR) { exec_err_immediate(line,len,t0,t1-t0,"ARRAY GROW FAILED: @%s",(const char *)val->d); } } switch (val->type) { case AT_FLOAT: AD_FLOAT(val)[vs++] = (vt != AT_FLOAT) ? v_i : v_f; break; case AT_INT: AD_INT(val)[vs++] = v_i; break; case AT_BOOL: if (v_i) bitvec_set(AD_BOOL(val),vs); else bitvec_clr(AD_BOOL(val),vs); vs ++; break; default: abort(); break; } moreval = TT_NUM; break; case TT_STRING: t0 ++; t1 --; vs = t1 - t0; val = new_array_l(AT_CHAR,1,vs); if (val->type == AT_ERR) { exec_err_immediate(line,len,t0,t1-t0,"LITERAL CREATE FAILED: @%s",(const char *)val->d); } val_reverse = 0; j = 0; for (i=t0;idims[0] = j; val->els = j; t0 --; break; default: abort(); break; } } if (stack) { execute_ctx.at = stack->opener - execute_ctx.line; execute_ctx.len = 1; exec_err_ctx("UNPAIRED @c",*stack->opener); } err_throw = save_throw; { ARRAY *r; if (xs.rhs && (!lastop || !ec_equal_single(lastop,CH_ASSIGN))) { r = xs.rhs; xs.rhs = 0; } else { r = 0; } xstate_freesub(&xs); return(r); } } static void syscommand(ECHAR *body, int len) { exec_err_immediate(body,len,0,1,"SYSTEM COMMANDS NOT IMPLEMENTED"); } #ifdef DEBUG_TOKENIZE static void dump_tokenization(const ECHAR *text, const unsigned char *tok, int len) { int i; ec_print(text,len); putchar('\n'); for (i=0;i> 1) { case TT_NULL: putchar(CH_JOT); break; case TT_IDENT: putchar(CH_LETTER_I); break; case TT_CHAR: putchar(CH_LETTER_C); break; case TT_NUM: putchar(CH_LETTER_N); break; case TT_STRING: putchar(CH_LETTER_S); break; default: putchar(0x51); break; } if (tok[i] & 1) { putchar(0x08); putchar(CH_UNDER); } } putchar('\n'); } #endif static unsigned char num_map(char c) { switch (c) { case '-': return(CH_NEGNUM); break; case '.': return(CH_DOT); break; case 'e': return(CH_LETTER_E); break; case '0': return(CH_DIGIT_0); break; case '1': return(CH_DIGIT_1); break; case '2': return(CH_DIGIT_2); break; case '3': return(CH_DIGIT_3); break; case '4': return(CH_DIGIT_4); break; case '5': return(CH_DIGIT_5); break; case '6': return(CH_DIGIT_6); break; case '7': return(CH_DIGIT_7); break; case '8': return(CH_DIGIT_8); break; case '9': return(CH_DIGIT_9); break; default: abort(); break; } } static void print_num_map(const char *s, int n) { int i; for (i=0;i 2.3e45. if ((s[i] == '+') && (i > 0) && (s[i-1] == 'e')) continue; putchar(num_map(s[i])); } } static int print_recursive(void (*printone)(const void *, int), const void *d, int x, const int *dims, int dx) { int i; int n; int adv; int a; int j; if (dx < 0) { (*printone)(d,x); return(1); } adv = 0; n = dims[dx]; for (i=0;i0;j--) putchar('\n'); } else { (*printone)(0,0); } } a = print_recursive(printone,d,x,dims,dx-1); adv += a; x += a; } return(adv); } static void print_value_bool(const void *d, int x) { if (! d) { putchar(CH_SPACE); return; } putchar(bitvec_isset(d,x)?CH_DIGIT_1:CH_DIGIT_0); } static void print_value_int(const void *d, int x) { char sv[64]; int l; if (! d) { putchar(CH_SPACE); return; } l = snprintf(&sv[0],sizeof(sv),"%lld",(LLI)((const APLINT *)d)[x]); print_num_map(&sv[0],l); } static void print_value_float(const void *d, int x) { char sv[64]; int l; if (! d) { putchar(CH_SPACE); return; } l = snprintf(&sv[0],sizeof(sv),"%g",(double)((const APLFLOAT *)d)[x]); print_num_map(&sv[0],l); } static void print_value_char(const void *d, int x) { if (! d) return; ec_print(((const ECHAR *)d)+x,1); } static void print_value(ARRAY *v) { if (!v || (v->els < 1)) return; switch (v->type) { case AT_BOOL: print_recursive(&print_value_bool,v->d,0,v->dims,v->rank-1); break; case AT_INT: print_recursive(&print_value_int,v->d,0,v->dims,v->rank-1); break; case AT_FLOAT: print_recursive(&print_value_float,v->d,0,v->dims,v->rank-1); break; case AT_CHAR: print_recursive(&print_value_char,v->d,0,v->dims,v->rank-1); break; default: abort(); break; } putchar('\n'); } static void execute_line(ECHAR *line, int len) { __label__ errto; unsigned char *tok; int tflip; unsigned int *indir; int i; void throw(void) { goto errto; } tok = 0; err_throw = &throw; if ((len > 0) && ec_equal_single(line,CH_RPAREN)) { syscommand(line,len); err_throw = 0; return; } tok = malloc(len); indir = malloc(len*sizeof(*indir)); tflip = 0; i = 0; while (i < len) { do <"token"> { if ( ec_equal_single(line+i,CH_NEGNUM) || ec_map_single(line+i,&digits_map[0]) || ( ec_equal_single(line+i,CH_DOT) && (i+1 < len) && ec_map_single(line+i+1,&digits_map[0]) ) ) { int ndig; int dot; int inexp; int neg; int negexp; int expdig; int j; j = i; if (ec_equal_single(line+i,CH_NEGNUM)) { neg = 1; j ++; } else { neg = 0; } ndig = 0; dot = -1; inexp = 0; while (1) { if (j >= len) break; if (ec_equal_single(line+j,CH_NEGNUM)) { if (inexp ? (negexp || (expdig > 0)) : (neg || ndig || (dot >= 0))) exec_err_immediate(line,len,j,1,"INVALID NEGATION"); if (inexp) negexp = 1; else neg = 1; } else if (ec_equal_single(line+j,CH_DOT)) { if ((dot >= 0) || inexp) break; dot = ndig; } else if (ec_equal_single(line+j,CH_LETTER_E)) { if (inexp) break; inexp = 1; negexp = 0; expdig = 0; } else if (ec_map_single(line+j,&digits_map[0])) { if (inexp) { expdig ++; } else { ndig ++; } } else { break; } j ++; } if ((ndig < 1) || (inexp && (expdig < 1))) exec_err_immediate(line,len,i,j-i,"INVALID NUMBER"); memset(tok+i,(TT_NUM*2)+tflip,j-i); i = j; break <"token">; } if ( ec_equal_single(line+i,CH_DELTA) || ec_map_single(line+i,&letters_map[0]) || ec_equal_double(line+i,CH_DELTA,CH_UNDER) || ec_map_double(line+i,CH_UNDER,&letters_map[0]) ) { int j; j = i + 1; while ( (j < len) && ( ec_equal_single(line+j,CH_DELTA) || ec_map_single(line+j,&letters_digits_map[0]) || ec_equal_double(line+j,CH_DELTA,CH_UNDER) || ec_map_double(line+j,CH_UNDER,&letters_map[0]) ) ) j ++; memset(tok+i,(TT_IDENT*2)+tflip,j-i); i = j; break <"token">; } else if (ec_equal_single(line+i,CH_QUOTE)) { int j; j = i + 1; while (1) { if (j >= len) exec_err_immediate(line,len,i,1,"UNCLOSED '"); if (ec_equal_single(line+j,CH_QUOTE)) { if ((j+1 < len) && ec_equal_single(line+j+1,CH_QUOTE)) { j += 2; } else { break; } } j ++; } j ++; memset(tok+i,(TT_STRING*2)+tflip,j-i); i = j; break <"token">; } else if (ec_equal_single(line+i,CH_SPACE)) { tok[i++] = (TT_NULL * 2) + tflip; break <"token">; } else { tok[i++] = (TT_CHAR*2) + tflip; break <"token">; } } while (0); tflip = ! tflip; } #ifdef DEBUG_TOKENIZE dump_tokenization(line,tok,len); #endif print_value(execute_tokenized(line,tok,len)); errto:; free(tok); free(indir); err_throw = 0; } static void il_finish_line(void) { il_end_next(); if (il.l > 0) execute_line(il.eb,il.l); il_new_line(); } static void il_typein(unsigned char c) { switch (c) { case 0x01: // ^A il.c = 0; break; case 0x02: // ^B if (il.c > 0) il.c --; break; case 0x04: // ^D il_del_at(il.c,1); break; case 0x05: // ^E il.c = il.l; break; case 0x06: // ^F if (il.c < il.l) il.c ++; break; case 0x08: // ^H case 0x7f: // DEL if (il.c > 0) { il.c --; il_del_at(il.c,1); } break; case 0x09: // ^I il_insert_space(il.c,1); break; case 0x0a: // ^J case 0x0d: // ^M il_finish_line(); break; case 0x0b: // ^K il_del_at(il.c,il.l-il.c); break; case 0x0c: // ^L il.curcols = -1; // XXX break; case 0x14: // ^T il_transpose(); break; default: if ((c >= 32) && (c <= 122) && (c != 92) && (c != 96)) { il_printable(c); } else { putchar(0x07); } break; } } static void il_input(void) { unsigned char rbuf[256]; int nr; int i; fflush(0); nr = read(0,&rbuf[0],sizeof(rbuf)); if (nr == 0) exit(0); if (nr < 0) { switch (errno) { case EINTR: return; break; } fprintf(stderr,"%s: input read: %s\n",__progname,strerror(errno)); exit(1); } for (i=0;i= 256)) abort(); c = bitmap_ivec[c]; if (c == 0xff) abort(); bitvec_set(map,c); } va_end(ap); } static void or_charmap(unsigned char *dst, const unsigned char *src1, const unsigned char *src2) { int i; for (i=11-1;i>=0;i--) dst[i] = src1[i] | src2[i]; } static void setup_data(void) { int i; // See the comment on bitmap_ivec. :- memset(&bitmap_ivec[0],0xff,256); for (i=88-1;i>=0;i--) bitmap_ivec[bitmap_vec[i]] = i; // Now that bitmap_ivec is set up, set up the maps. setup_charmap(&digits_map[0], CH_DIGIT_0,CH_DIGIT_1,CH_DIGIT_2,CH_DIGIT_3,CH_DIGIT_4, CH_DIGIT_5,CH_DIGIT_6,CH_DIGIT_7,CH_DIGIT_8,CH_DIGIT_9,0); setup_charmap(&letters_map[0], CH_LETTER_A,CH_LETTER_B,CH_LETTER_C,CH_LETTER_D,CH_LETTER_E, CH_LETTER_F,CH_LETTER_G,CH_LETTER_H,CH_LETTER_I,CH_LETTER_J, CH_LETTER_K,CH_LETTER_L,CH_LETTER_M,CH_LETTER_N,CH_LETTER_O, CH_LETTER_P,CH_LETTER_Q,CH_LETTER_R,CH_LETTER_S,CH_LETTER_T, CH_LETTER_U,CH_LETTER_V,CH_LETTER_W,CH_LETTER_X,CH_LETTER_Y, CH_LETTER_Z,CH_DELTA,0); or_charmap(&letters_digits_map[0],&letters_map[0],&digits_map[0]); } int main(void); int main(void) { printf("\r\n"); setup_data(); il_init(); il_set_prefix(c_to_ec_tmp(" ")); while (1) { il_update(); il_input(); } return(0); }