NODE *lreadchars(NODE *args) { unsigned int c, i; char *strhead, *strptr; NODETYPES type = STRING; c = (unsigned int)getint(pos_int_arg(args)); if (stopping_flag == THROWING) return UNBOUND; charmode_on(); input_blocking++; #ifndef TIOCSTI if (!setjmp(iblk_buf)) #endif { strhead = malloc((size_t)(c + 2)); strptr = strhead + 1; fread(strptr, 1, (int)c, readstream); setstrrefcnt(strhead, 0); } input_blocking = 0; #ifndef TIOCSTI if (stopping_flag == THROWING) return(UNBOUND); #endif if (feof(readstream)) { free(strhead); return(NIL); } for (i = 0; i < c; i++) if (getparity(strptr[i])) type = BACKSLASH_STRING; return(make_strnode(strptr, strhead, (int)c, type, strnzcpy)); }
NODE *lvbarredp(NODE *args) { char i; NODE *arg; arg = char_arg(args); if (NOT_THROWING) { i = *getstrptr(arg); return torf(getparity(i)); } return(UNBOUND); }
NODE *lreadchar(NODE *args) { #ifdef WIN32 MSG msg; #endif /* WIN32 */ char c; if (readchar_lookahead_buf >= 0) { c = (char)readchar_lookahead_buf; readchar_lookahead_buf = -1; return(make_strnode((char *)&c, (struct string_block *)NULL, 1, (getparity(c) ? BACKSLASH_STRING : STRING), strnzcpy)); } charmode_on(); input_blocking++; #ifdef HAVE_WX if (interactive && readstream==stdin) { reading_char_now = 1; c = getFromWX(); reading_char_now = 0; } else c = (char)getc(readstream); #else #ifndef TIOCSTI if (!setjmp(iblk_buf)) #endif { #ifdef mac csetmode(C_RAW, stdin); while ((c = (char)getc(readstream)) == EOF && readstream == stdin); csetmode(C_ECHO, stdin); #else /* !mac */ #ifdef ibm if (interactive && readstream==stdin) #ifndef WIN32 c = (char)getch(); #else /* WIN32 */ { win32_update_text(); if (!char_avail) while(GetMessage(&msg, NULL, 0, 0)) { TranslateMessage(&msg); DispatchMessage(&msg); if (char_avail) break; } c = buffered_char; char_avail = 0; } #endif /* WIN32 */ else
NODE *lreadchar() { char c; charmode_on(); input_blocking++; #ifndef TIOCSTI if (!setjmp(iblk_buf)) #endif #ifdef mac csetmode(C_RAW, stdin); while ((c = (char)getc(readstream)) == EOF && readstream == stdin); csetmode(C_ECHO, stdin); #else #ifdef ibm if (interactive && readstream==stdin) c = (char)getch(); else c = (char)getc(readstream); if (c == 17) { /* control-q */ to_pending = 0; err_logo(STOP_ERROR,NIL); } if (c == 23) { /* control-w */ logo_pause(); return(lreadchar()); } #else c = (char)getc(readstream); #endif #endif input_blocking = 0; if (feof(readstream)) { return(NIL); } return(make_strnode(&c, (char *)NULL, 1, (getparity(c) ? STRING : BACKSLASH_STRING), strnzcpy)); }
NODE *runparse_node(NODE *nd, NODE **ndsptr) { NODE *outline = NIL, *tnode = NIL, *lastnode = NIL, *snd; char *wptr, *tptr; struct string_block *whead; int wlen, wcnt, tcnt, isnumb, gotdot; NODETYPES wtyp; BOOLEAN monadic_minus = FALSE; if (nd == Minus_Tight) return cons(nd, NIL); snd = cnv_node_to_strnode(nd); wptr = getstrptr(snd); wlen = getstrlen(snd); wtyp = nodetype(snd); wcnt = 0; whead = getstrhead(snd); while (wcnt < wlen) { if (*wptr == ';') { *ndsptr = NIL; break; } if (*wptr == '"') { tcnt = 0; tptr = ++wptr; wcnt++; while (wcnt < wlen && !parens(*wptr)) { if (wtyp == BACKSLASH_STRING && getparity(*wptr)) wtyp = PUNBOUND; /* flag for "\( case */ wptr++, wcnt++, tcnt++; } if (wtyp == PUNBOUND) { wtyp = BACKSLASH_STRING; tnode = cons(make_quote(intern(make_strnode(tptr, NULL, tcnt, wtyp, noparity_strnzcpy))), NIL); } else tnode = cons(make_quote(intern(make_strnode(tptr, whead, tcnt, wtyp, strnzcpy))), NIL); } else if (*wptr == ':') { tcnt = 0; tptr = ++wptr; wcnt++; while (wcnt < wlen && !parens(*wptr) && !infixs(*wptr)) wptr++, wcnt++, tcnt++; tnode = cons(make_colon(intern(make_strnode(tptr, whead, tcnt, wtyp, strnzcpy))), NIL); } else if (wcnt == 0 && *wptr == '-' && monadic_minus == FALSE && wcnt+1 < wlen && !white_space(*(wptr+1))) { /* minus sign with space before and no space after is unary */ tnode = cons(make_intnode((FIXNUM)0), NIL); monadic_minus = TRUE; } else if (parens(*wptr) || infixs(*wptr)) { if (monadic_minus) tnode = cons(Minus_Tight, NIL); else if (wcnt+1 < wlen && ((*wptr == '<' && (*(wptr+1) == '=' || *(wptr+1) == '>')) || (*wptr == '>' && *(wptr+1) == '='))) { tnode = cons(intern(make_strnode(wptr, whead, 2, STRING, strnzcpy)), NIL); wptr++, wcnt++; } else tnode = cons(intern(make_strnode(wptr, whead, 1, STRING, strnzcpy)), NIL); monadic_minus = FALSE; wptr++, wcnt++; } else { tcnt = 0; tptr = wptr; /* isnumb 4 means nothing yet; * 0 means digits so far, 1 means just saw * 'e' so minus can be next, 2 means no longer * eligible even if an 'e' comes along */ isnumb = 4; gotdot = 0; if (*wptr == '?') { isnumb = 3; /* turn ?5 to (? 5) */ wptr++, wcnt++, tcnt++; } while (wcnt < wlen && !parens(*wptr) && (!infixs(*wptr) || (isnumb == 1 && (*wptr == '-' || *wptr == '+')))) { if (isnumb == 4 && isdigit(*wptr)) isnumb = 0; if (isnumb == 0 && tcnt > 0 && (*wptr == 'e' || *wptr == 'E')) isnumb = 1; else if (!(isdigit(*wptr) || (!gotdot && *wptr == '.')) || isnumb == 1) isnumb = 2; if (*wptr == '.') gotdot++; wptr++, wcnt++, tcnt++; } if (isnumb == 3 && tcnt > 1) { /* ?5 syntax */ NODE *qmtnode; qmtnode = cons_list(0, Left_Paren, Query, cnv_node_to_numnode (make_strnode(tptr+1, whead, tcnt-1, wtyp, strnzcpy)), END_OF_LIST); if (outline == NIL) { outline = qmtnode; } else { setcdr(lastnode, qmtnode); } lastnode = cddr(qmtnode); tnode = cons(Right_Paren, NIL); } else if (isnumb < 2 && tcnt > 0) { tnode = cons(cnv_node_to_numnode(make_strnode(tptr, whead, tcnt, wtyp, strnzcpy)), NIL); } else tnode = cons(intern(make_strnode(tptr, whead, tcnt, wtyp, strnzcpy)), NIL); } if (outline == NIL) outline = tnode; else setcdr(lastnode, tnode); lastnode = tnode; } return(outline); }
NODE *parser_iterate(char **inln, char *inlimit, struct string_block *inhead, BOOLEAN semi, int endchar) { char ch, *wptr = NULL; static char terminate = '\0'; /* KLUDGE */ NODE *outline = NIL, *lastnode = NIL, *tnode = NIL; int windex = 0, vbar = 0; NODETYPES this_type = STRING; BOOLEAN broken = FALSE; do { /* get the current character and increase pointer */ ch = **inln; if (!vbar && windex == 0) wptr = *inln; if (++(*inln) >= inlimit) *inln = &terminate; /* skip through comments and line continuations */ while (!vbar && ((semi && ch == ';') || #ifdef WIN32 (ch == '~' && (**inln == 012 || **inln == 015)))) { while (ch == '~' && (**inln == 012 || **inln == 015)) { #else (ch == '~' && **inln == '\n'))) { while (ch == '~' && **inln == '\n') { #endif if (++(*inln) >= inlimit) *inln = &terminate; ch = **inln; if (windex == 0) wptr = *inln; else { if (**inln == ']' || **inln == '[' || **inln == '{' || **inln == '}') { ch = ' '; break; } else { broken = TRUE; } } if (++(*inln) >= inlimit) *inln = &terminate; } if (semi && ch == ';') { #ifdef WIN32 if (**inln != 012 && **inln != 015) #else if (**inln != '\n') #endif do { ch = **inln; if (windex == 0) wptr = *inln; else broken = TRUE; if (++(*inln) >= inlimit) *inln = &terminate; } #ifdef WIN32 while (ch != '\0' && ch != '~' && **inln != 012 && **inln != 015); #else /* !Win32 */ while (ch != '\0' && ch != '~' && **inln != '\n'); #endif if (ch != '\0' && ch != '~') ch = '\n'; } } /* flag that this word will be of BACKSLASH_STRING type */ if (getparity(ch)) this_type = BACKSLASH_STRING; if (ch == '|') { vbar = !vbar; this_type = VBAR_STRING; broken = TRUE; /* so we'll copy the chars */ } else if (vbar || (!white_space(ch) && ch != ']' && ch != '{' && ch != '}' && ch != '[')) windex++; if (vbar) continue; else if (ch == endchar) break; else if (ch == ']') err_logo(UNEXPECTED_BRACKET, NIL); else if (ch == '}') err_logo(UNEXPECTED_BRACE, NIL); /* if this is a '[', parse a new list */ else if (ch == '[') { tnode = cons(parser_iterate(inln,inlimit,inhead,semi,']'), NIL); if (**inln == '\0') ch = '\0'; } else if (ch == '{') { tnode = cons(list_to_array (parser_iterate(inln,inlimit,inhead,semi,'}')), NIL); if (**inln == '@') { int i = 0, sign = 1; (*inln)++; if (**inln == '-') { sign = -1; (*inln)++; } while ((ch = **inln) >= '0' && ch <= '9') { i = (i*10) + ch - '0'; (*inln)++; } setarrorg(car(tnode),sign*i); } if (**inln == '\0') ch = '\0'; } /* if this character or the next one will terminate string, make the word */ else if (white_space(ch) || **inln == ']' || **inln == '[' || **inln == '{' || **inln == '}') { if (windex > 0 || this_type == VBAR_STRING) { if (broken == FALSE) tnode = cons(make_strnode(wptr, inhead, windex, this_type, strnzcpy), NIL); else { tnode = cons(make_strnode(wptr, (struct string_block *)NULL, windex, this_type, (semi ? mend_strnzcpy : mend_nosemi)), NIL); broken = FALSE; } this_type = STRING; windex = 0; } } /* put the word onto the end of the return list */ if (tnode != NIL) { if (outline == NIL) outline = tnode; else setcdr(lastnode, tnode); lastnode = tnode; tnode = NIL; } } while (ch); return(outline); } NODE *parser(NODE *nd, BOOLEAN semi) { NODE *rtn; int slen; char *lnsav; rtn = cnv_node_to_strnode(nd); slen = getstrlen(rtn); lnsav = getstrptr(rtn); rtn = parser_iterate(&lnsav,lnsav + slen,getstrhead(rtn),semi,-1); return(rtn); } NODE *lparse(NODE *args) { NODE *arg, *val = UNBOUND; arg = string_arg(args); if (NOT_THROWING) { val = parser(arg, FALSE); } return(val); }