![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to snocone.sc CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / snocone|
Return to snocone.sc CVS log | Up to [Research Unix] / researchv10no / cmd / snocone |
1.1 ! root 1: DATA("b(op,l,r)") ! 2: DATA("u(op,r)") ! 3: DATA("i_fcall(name,head,tail)") ! 4: DATA("fcall(name,args,l,r)") ! 5: DATA("argexp(exp,next)") ! 6: ! 7: stack = TABLE() ! 8: bconv = TABLE(30) ! 9: deflist = TABLE(50) ! 10: inctab = TABLE() ! 11: stno_tab = TABLE(100) ! 12: ! 13: # The "binfo" structure contains the information needed to ! 14: # map Snocone binary operators into SNOBOL4 binary operators. ! 15: # The significance of the fields is as follows: ! 16: # ! 17: # out The corresponding SNOBOL4 operator ! 18: # lp The operator priority when it's on the left ! 19: # side of a precedence comparison ! 20: # rp The operator priority when it's on the right ! 21: # side of a precedence comparison. lp is always ! 22: # equal to rp or rp-1; if equal, the operator is ! 23: # left-associative, otherwise right-associative. ! 24: # slp Like lp, but for the SNOBOL4 operator ! 25: # srp Like rp, but for the SNOBOL4 operator ! 26: # fn Non-null if this operator translates into a ! 27: # call to a built-in function instead of an operator. ! 28: DATA("binfo(out,lp,rp,slp,srp,fn)") ! 29: ! 30: # Paren isn't really an operator, but precedence comparisons ! 31: # work out more easily if bconv has an entry for them. ! 32: bconv['('] = par_binfo = binfo('',0) ! 33: ! 34: bconv['='] = binfo('=',1,2,0,1) ! 35: bconv['?'] = binfo('?',2,2,1,1) ! 36: bconv['|'] = binfo('|',3,3,2,2) ! 37: bconv['||'] = or_binfo = binfo('',4,4,0,0,1) ! 38: bconv['&&'] = cat_binfo = binfo(' ',5,5,4,4) ! 39: bconv['>'] = binfo('GT',6,6,0,0,1) ! 40: bconv['<'] = binfo('LT',6,6,0,0,1) ! 41: bconv['>='] = binfo('GE',6,6,0,0,1) ! 42: bconv['<='] = binfo('LE',6,6,0,0,1) ! 43: bconv['=='] = binfo('EQ',6,6,0,0,1) ! 44: bconv['!='] = binfo('NE',6,6,0,0,1) ! 45: bconv['::'] = binfo('IDENT',6,6,0,0,1) ! 46: bconv[':!:'] = binfo('DIFFER',6,6,0,0,1) ! 47: bconv[':>:'] = binfo('LGT',6,6,0,0,1) ! 48: bconv[':<:'] = binfo('LLT',6,6,0,0,1) ! 49: bconv[':>=:'] = binfo('LGE',6,6,0,0,1) ! 50: bconv[':<=:'] = binfo('LLE',6,6,0,0,1) ! 51: bconv[':==:'] = binfo('LEQ',6,6,0,0,1) ! 52: bconv[':!=:'] = binfo('LNE',6,6,0,0,1) ! 53: bconv['+'] = binfo('+',7,7,5,5) ! 54: bconv['-'] = binfo('-',7,7,5,5) ! 55: bconv['/'] = binfo('/',8,8,7,7) ! 56: bconv['*'] = binfo('*',8,8,8,8) ! 57: bconv['%'] = binfo('REMDR',8,8,0,0,1) ! 58: bconv['^'] = binfo('**',9,10,10,11) ! 59: bconv['.'] = binfo('.',10,10,11,11) ! 60: bconv['$'] = binfo('$',10,10,11,11) ! 61: ! 62: ht = char(9) ! 63: optblank = nspan(" " && ht) ! 64: blank = SPAN(" " && ht) ! 65: digits = "0123456789" ! 66: letters = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_" ! 67: ! 68: integer = SPAN(digits) ! 69: exponent = ANY("eEdD") && (ANY("+-") | "") && integer ! 70: real = integer && "." && (integer | "") && (exponent | "") | ! 71: integer && exponent | "." && integer && (exponent | "") ! 72: number = real | integer ! 73: ! 74: string = ANY("'" && '"') $ squote && BREAK(*squote) && LEN(1) ! 75: ! 76: constant = number | string ! 77: identifier = ANY(letters) && nspan(letters && digits) ! 78: unaryop = ANY("+-*&@~?.$") ! 79: binaryop = "==" | "!=" | "<=" | ">=" | "&&" | "||" | ":==:" | ! 80: ":!=:" | ":>:" | ":<:" | ":>=" | ":<=:" | "::" | ":!:" | ! 81: ANY("+-*/<>=^.$?|%") ! 82: ! 83: fcall = identifier . *mkfcall() && optblank && ! 84: (("(" && list(*exp . *invoke(.mkarg), optblank && ",") && ! 85: optblank && ")" . *invoke(.endfc)) | ! 86: ("[" && list(*exp . *invoke(.mkarg), optblank && ",") && ! 87: optblank && "]" . *invoke(.endfc) . *invoke(.mkarray))) ! 88: ! 89: term = optblank && (constant . *push() . *dotck() | ! 90: identifier . *push() | "(" && *exp && optblank && ")" | fcall) ! 91: operand = term | optblank && unaryop . *push() && ! 92: *operand . *invoke(.unop) ! 93: exp = "" . *begexp() && *operand && ! 94: ARBNO(optblank && binaryop . *push() . *invoke(.mkbinfo) && ! 95: *operand . *invoke(.binop)) && "" . *endexp() ! 96: ! 97: label = optblank && identifier . lab . *emitlab(lab) && optblank && ":" ! 98: ! 99: clausend = ANY("{}") . del | RPOS(0) ! 100: ! 101: clause = FENCE && ARBNO(label) && optblank && ! 102: ("if" . cl_type && optblank && "(" && *exp && optblank && ")" | ! 103: "while" . cl_type && optblank && "(" && *exp && optblank && ")" | ! 104: (kw("return") | kw("freturn") | kw("nreturn")) . cl_type && ! 105: optblank && ("" . *push() | *exp) && ! 106: optblank && clausend | ! 107: "go" && optblank && "to" && blank && ! 108: identifier . dest . *invoke(.gocl) | ! 109: ("{" | "}") . cl_type | ! 110: ("do" | kw("else")) . cl_type && (SPAN(" " && ht) | RPOS(0)) | ! 111: "procedure" . cl_type && blank && identifier . fname | ! 112: "struct" . cl_type && blank && identifier . stname | ! 113: "for" . cl_type && optblank && ! 114: "(" && *exp && optblank && "," && *exp && optblank && ! 115: "," && *exp && optblank && ")" | ! 116: RPOS(0) . cl_type && *invoke(.emiteos) | ! 117: *exp && optblank && clausend . *invoke(.expcl)) ! 118: ! 119: gl_files = TABLE() ! 120: gl_lines = TABLE() ! 121: gl_index = -1 ! 122: ! 123: emit_stno = 0 ! 124: ! 125: &STLIMIT = 1000000000 ! 126: # ! 127: # save the current state -- we really begin execution here. ! 128: EXIT(3) ! 129: # ! 130: # Establish a starting point for input files ! 131: gl_arg = HOST(3) - 1 ! 132: if (~HOST (2, HOST(3))) { ! 133: OUTPUT = "snocone: nothing to compile" ! 134: go to END ! 135: } ! 136: ! 137: if (~gl_nextfile()) { ! 138: go to END ! 139: } ! 140: # ! 141: # establish the "object" file ! 142: outfile = "a.out" ! 143: &ERRLIMIT = &ERRLIMIT + 1 ! 144: savexit = SETEXIT() ! 145: if (~OUTPUT(.outf,-1,outfile)) { ! 146: OUTPUT = "cannot write " && outfile ! 147: go to END ! 148: } ! 149: &ERRLIMIT = &ERRLIMIT - 1 ! 150: SETEXIT (savexit) ! 151: ! 152: outf = "#!/usr/bin/spitbol -s16k" ! 153: outf = "-in4096" ! 154: # ! 155: # Permanent prologue ! 156: emitlab("MAIN.") ! 157: # ! 158: # The main loop. We expect to read a series of statements. ! 159: while (nclause (1)) { ! 160: if (IDENT (cl_type, "procedure")) ! 161: funct() ! 162: else if (IDENT (cl_type, "struct")) ! 163: dostruct() ! 164: else ! 165: dostmt() ! 166: } ! 167: ! 168: ! 169: # Epilogue ! 170: EXIT: ! 171: emitg("END") ! 172: emitlab("START.") ! 173: emit("CODE('START.')") ! 174: for (i = 1, i <= deflist[0], i = i + 1) { ! 175: emiteos() ! 176: emit(deflist[i]) ! 177: } ! 178: ! 179: # put out code to trap run-time errors ! 180: emiteos() ! 181: emit("&ERRLIMIT = 1") ! 182: emiteos() ! 183: emit("SETEXIT(.err.exit)") ! 184: ! 185: # put out code to assign the statement map ! 186: emiteos() ! 187: emit ("err.map = '") ! 188: while (bst_stab ? LEN(50) . bst_chunk = "") { ! 189: emit (bst_chunk && "'") ! 190: emiteos() ! 191: emitlab("+") ! 192: emit("'") ! 193: } ! 194: emit (bst_stab && "'") ! 195: ! 196: emitg("MAIN.") ! 197: emiteos() ! 198: ! 199: # Epilogue ! 200: INPUT(.inf,-2,'/usr/lib/snocone/epilogue') ! 201: while (line = inf) ! 202: outf = line ! 203: ENDFILE(-2) ! 204: ! 205: ENDFILE(-1) ! 206: HOST (1, "chmod +x " && outfile) ! 207: ! 208: ! 209: ! 210: # subroutines ! 211: ! 212: ! 213: ! 214: ! 215: # like span, but the pattern returned ! 216: # can also match the null string ! 217: procedure nspan (str) { ! 218: return SPAN (str) | "" ! 219: } ! 220: ! 221: # a pattern that matches a list of zero or more ! 222: # "item"s separated by "delim"s ! 223: procedure list (item, delim) { ! 224: return item && ARBNO (delim && item) | "" ! 225: } ! 226: ! 227: # a pattern that matches the keyword given by the ! 228: # argument, insisting that it be followed by a non-letter. ! 229: procedure kw (s) { ! 230: return SPAN(letters) $ dummy && ! 231: CONVERT("ident(dummy,'" && s && "')", "EXPRESSION") ! 232: } ! 233: ! 234: # return the name of the (new) top stack element ! 235: procedure push() { ! 236: stackptr = stackptr + 1 ! 237: nreturn .stack[stackptr] ! 238: } ! 239: ! 240: # return the value of the (old) top stack element ! 241: procedure pop() { ! 242: pop = stack[stackptr] ! 243: stack[stackptr] = "" ! 244: stackptr = stackptr - 1 ! 245: } ! 246: ! 247: # return the name of the stack element n away from the top ! 248: procedure peek (n) { ! 249: if (n >= stackptr) ! 250: go to err ! 251: nreturn .stack[stackptr - n] ! 252: } ! 253: ! 254: # top() ! 255: # return the name of the top stack element ! 256: procedure top() { ! 257: nreturn .stack[stackptr] ! 258: } ! 259: ! 260: # isbin(x) ! 261: # is x a structure describing a binary operator? ! 262: # things like == and ||, which syntactically look ! 263: # more like functions than operators in their snobol form, ! 264: # are considered not to be operators. ! 265: procedure isbin (x) { ! 266: if (DIFFER (DATATYPE (x), 'B') || DIFFER (fn (op (x)))) ! 267: freturn ! 268: } ! 269: ! 270: # isneg(x) ! 271: # is x a structure describing a unary negation operator? ! 272: procedure isneg (x) { ! 273: if (DIFFER (DATATYPE (x), 'U') || DIFFER (op (x), '~')) ! 274: freturn ! 275: } ! 276: ! 277: # ! 278: # print an expression in snobol form ! 279: procedure dprint (x) op, l, r, d, i, del { ! 280: d = DATATYPE(x) ! 281: if (IDENT (d, 'STRING')) { ! 282: emit (x) ! 283: return ! 284: } ! 285: ! 286: if (IDENT (d, 'U')) { ! 287: # unary operator ! 288: emit (op (x)) ! 289: if (isbin(r(x))) ! 290: emit('(') ! 291: dprint(r(x)) ! 292: if (isbin(r(x))) ! 293: emit(')') ! 294: return ! 295: } ! 296: ! 297: ! 298: if (IDENT (d, 'FCALL')) { ! 299: # function call or array reference ! 300: emit (name (x)) ! 301: emit (l (x)) ! 302: r = args (x) ! 303: while (DIFFER (r)) { ! 304: emit (del) ! 305: dprint (exp (r)) ! 306: del = ',' ! 307: r = next (r) ! 308: } ! 309: emit (r (x)) ! 310: return ! 311: } ! 312: ! 313: if (IDENT (d, 'B')) { ! 314: # binary operator ! 315: op = op (x) ! 316: if (IDENT (op, or_binfo)) { ! 317: emit ('(') ! 318: bprint (x) ! 319: emit (')') ! 320: return ! 321: } ! 322: l = isbin(l(x)) && slp(op(l(x))) < srp(op) && 1 || "" ! 323: r = isbin(r(x)) && slp(op) > srp(op(r(x))) && 1 || "" ! 324: ! 325: # check for [f](a,b) ! 326: if (DIFFER (fn (op))) { ! 327: emit(out(op)) ! 328: emit('(') ! 329: dprint(l(x)) ! 330: emit(',') ! 331: dprint(r(x)) ! 332: emit(')') ! 333: return ! 334: } ! 335: ! 336: # ordinary binary operator ! 337: if (DIFFER (l)) ! 338: emit ('(') ! 339: dprint(l(x)) ! 340: if (DIFFER (l)) ! 341: emit (')') ! 342: emitb(out(op)) ! 343: if (DIFFER(r)) ! 344: emit('(') ! 345: dprint(r(x)) ! 346: if (DIFFER(r)) ! 347: emit(')') ! 348: return ! 349: } ! 350: ! 351: # unknown datatype -- this "shouldn't happen" ! 352: i = 1 ! 353: emit(d) ! 354: emit ('(') ! 355: while (dprint (APPLY (FIELD (d, i), x))) { ! 356: i = i + 1 ! 357: emit (',') ! 358: } ! 359: emit (')') ! 360: } ! 361: ! 362: # bprint(x) ! 363: # subroutine of dprint -- used to handle printing of ! 364: # things of the form (a,b), which are inherently ! 365: # associative and can therefore be grouped as follows ! 366: # ((a,b),c) <=> (a,(b,c)) <=> (a,b,c) ! 367: procedure bprint (x) { ! 368: if (DIFFER (DATATYPE(x), 'B') || DIFFER (op(x), or_binfo)) { ! 369: dprint (x) ! 370: return ! 371: } ! 372: bprint(l(x)) ! 373: emit(',') ! 374: bprint(r(x)) ! 375: } ! 376: ! 377: # sprint(x) ! 378: # like dprint, but print in a form appropriate for ! 379: # an entire statement. This procedure exists ! 380: # because if the top level operator is a concatenation, ! 381: # it is necessary to enclose the whole thing in parentheses. ! 382: # Otherwise it would be mistaken for a pattern match. ! 383: procedure sprint (x) { ! 384: if (IDENT(DATATYPE(x),'B') && IDENT(op(x),cat_binfo)) ! 385: emit('(') ! 386: dprint(x) ! 387: if (IDENT(DATATYPE(x),'B') && IDENT(op(x),cat_binfo)) ! 388: emit(')') ! 389: emiteob() ! 390: } ! 391: ! 392: # invoke(f) ! 393: # call an argument-free function in a context where ! 394: # a name is required, such as arb . *invoke(.foo) ! 395: procedure invoke (f) { ! 396: APPLY (f) ! 397: nreturn .dummy ! 398: } ! 399: ! 400: # a unary operator has been detected during parsing ! 401: procedure unop() r, op { ! 402: r = pop() ! 403: op = pop() ! 404: push() = u(op,r) ! 405: } ! 406: ! 407: # mkfcall() ! 408: # Parsing has detected the beginning of a function call ! 409: procedure mkfcall() { ! 410: push() = i_fcall() ! 411: nreturn .name(top()) ! 412: } ! 413: ! 414: # parsing has detected an argument to a function ! 415: procedure mkarg() x, f { ! 416: x = argexp(pop(),"") ! 417: f = top() ! 418: if (DIFFER(tail(f))) ! 419: next(tail(f)) = x ! 420: tail(f) = x ! 421: head(f) = IDENT(head(f)) && x ! 422: } ! 423: ! 424: # parsing has detected the end of a function call ! 425: procedure endfc() f { ! 426: f = pop() ! 427: push() = fcall(name(f),head(f),'(',')') ! 428: } ! 429: ! 430: # the fcall at the head of the stack is really an array ! 431: procedure mkarray() t { ! 432: t = top() ! 433: l(t) = '<' ! 434: r(t) = '>' ! 435: } ! 436: ! 437: # the beginning of an expression has been detected ! 438: procedure begexp() { ! 439: push() = bconv['('] ! 440: nreturn .dummy ! 441: } ! 442: ! 443: # a binary operator has been detected. We handle ! 444: # precedence here rather than in the grammar ! 445: # because it is less work. ! 446: procedure binop() l, r, op, newr, newop { ! 447: while (lp(peek(3)) >= rp(peek(1))) { ! 448: newr = pop() ! 449: newop = pop() ! 450: r = pop() ! 451: op = pop() ! 452: l = pop() ! 453: push() = b(op,l,r) ! 454: push() = newop ! 455: push() = newr ! 456: } ! 457: } ! 458: ! 459: # the end of an expression has been detected ! 460: procedure endexp() l, r, op { ! 461: while (DIFFER (peek (1), par_binfo)) { ! 462: r = pop() ! 463: op = pop() ! 464: l = pop() ! 465: push() = b(op,l,r) ! 466: } ! 467: r = pop() ! 468: pop() ! 469: push() = r ! 470: nreturn .dummy ! 471: } ! 472: ! 473: # locate the binfo structure that describes the ! 474: # binary operator whose input character representation ! 475: # has been placed on the top of the stack. ! 476: procedure mkbinfo() op { ! 477: op = bconv[pop()] ! 478: if (IDENT(op)) ! 479: go to err ! 480: push() = op ! 481: } ! 482: ! 483: # dotck() ! 484: # if necessary, append a leading zero to a floating-point ! 485: # constant that begins with a decimal point. The idea ! 486: # that .5 is syntactically correct but semantically illegal ! 487: # is just too scary to leave in. ! 488: procedure dotck() { ! 489: top() ? FENCE && '.' = '0.' ! 490: nreturn .dummy ! 491: } ! 492: ! 493: # write label l to the output ! 494: procedure emitlab (l) { ! 495: if (DIFFER(l)) { ! 496: emiteos() ! 497: st_lab = l ! 498: } ! 499: nreturn .dummy ! 500: } ! 501: ! 502: # put string s in the output ! 503: procedure emit (s) { ! 504: if (DIFFER(emit_eob)) ! 505: emiteos() ! 506: st_body = st_body && s ! 507: } ! 508: ! 509: # we are done with the body of the generated statement ! 510: procedure emiteob() { ! 511: if (IDENT (emit_eob)) { ! 512: buildstab (emit_stno, gi_file, gi_line) ! 513: emit_eob = 1 ! 514: } ! 515: } ! 516: ! 517: # write success branch l ! 518: procedure emits (l) { ! 519: emiteob() ! 520: st_s = l ! 521: } ! 522: ! 523: # emitf(l) ! 524: # write failure branch l ! 525: procedure emitf (l) { ! 526: emiteob() ! 527: st_f = l ! 528: } ! 529: ! 530: # write unconditional branch l ! 531: procedure emitg (l) { ! 532: emiteob() ! 533: st_s = IDENT(st_s) && l ! 534: st_f = IDENT(st_f) && l ! 535: } ! 536: ! 537: # write s surrounded by blanks ! 538: procedure emitb (s) { ! 539: emit(' ') ! 540: if (DIFFER (s, ' ')) { ! 541: emit (s) ! 542: emit(' ') ! 543: } ! 544: } ! 545: ! 546: # emiteos()out,goto ! 547: # we are done with the entire statement ! 548: procedure emiteos() out, goto, s, del { ! 549: emit_eob = "" ! 550: if (DIFFER(st_lab) || DIFFER(st_body) || DIFFER(st_s) || DIFFER(st_f)) { ! 551: emit_stno = emit_stno + 1 ! 552: out = st_lab && " " && st_body ! 553: if (DIFFER (st_s) || DIFFER (st_f)) { ! 554: goto = " :" ! 555: if (IDENT (st_s, st_f)) ! 556: goto = goto && "(" && st_s && ")" ! 557: else { ! 558: if (DIFFER (st_s)) ! 559: goto = goto && "S(" && st_s && ")" ! 560: if (DIFFER (st_f)) ! 561: goto = goto && "F(" && st_f && ")" ! 562: } ! 563: } ! 564: out = out && goto ! 565: while (SIZE(out) >= 70 && (out ? FENCE && ! 566: (ARBNO(BREAK(" '" && '"') && ! 567: (" " | ANY("'" && '"') $ del && ! 568: BREAK(*del) && LEN(1))) $ s && ! 569: *(SIZE(s) > 50)) . outf = "+")) ! 570: {} ! 571: outf = out ! 572: st_lab = st_body = st_s = st_f = "" ! 573: } ! 574: } ! 575: ! 576: # attempt to read an input line, taking #include into account ! 577: procedure getline() x, file, del, dir { ! 578: do { ! 579: # Try to read a line from the current file ! 580: while (x = gl_in) { ! 581: ! 582: # We have a line: count it ! 583: gl_line = gl_line + 1 ! 584: ! 585: # If it's not an include statement, we're done. ! 586: if (~(x ? FENCE && "#" && *optblank && "include" && ! 587: *optblank && ANY('"<{' && "'") $ del && ! 588: BREAK(*REPLACE(del,'<{','>}')) . file && ! 589: LEN (1) && *optblank && RPOS(0))) ! 590: return x ! 591: ! 592: # If the name is enclosed in quotes and ! 593: # relative, then it is relative to the ! 594: # directory containing the currently included ! 595: # file, if any. If it is enclosed in brackets, ! 596: # it is relative to a canonical directory. ! 597: if ("'" && '"' ? del) { ! 598: if (SUBSTR (file, 1, 1) :!=: '/') { ! 599: if ((gl_file && '/') ? FENCE && ! 600: (BREAKX('/') && LEN(1)) . dir && ! 601: BREAK('/') && LEN(1) && RPOS(0)) ! 602: file = dir && file ! 603: } ! 604: } else ! 605: file = "/usr/lib/snocone/" && file ! 606: ! 607: # If the name was enclosed by single quotes ! 608: # or set brackets, ensure the particular file ! 609: # was included only once. Right now, we're pretty ! 610: # literal-minded about when two files are really ! 611: # the same: 'x' and './x' are different, for instance. ! 612: if (('"<' ? del) || IDENT (inctab[file])) { ! 613: inctab[file] = 1 ! 614: gl_open (file) ! 615: } ! 616: } ! 617: ! 618: # We've reached the end of this file. ! 619: gl_close() ! 620: } while (gl_index >= 0 || gl_nextfile()); ! 621: ! 622: freturn ! 623: } ! 624: ! 625: procedure gl_nextfile() { ! 626: gl_arg = gl_arg + 1 ! 627: if (~gl_open (HOST (2, gl_arg))) ! 628: freturn ! 629: } ! 630: ! 631: procedure gl_close() { ! 632: ENDFILE (gl_index) ! 633: gl_index = gl_index - 1 ! 634: gl_file = gl_files[gl_index] ! 635: gl_line = gl_lines[gl_index] ! 636: if (gl_index >= 0) ! 637: INPUT(.gl_in, gl_index) ! 638: gl_files[gl_index] = gl_lines[gl_index] = "" ! 639: } ! 640: ! 641: procedure gl_open (file) t { ! 642: gl_files[gl_index] = gl_file ! 643: gl_lines[gl_index] = gl_line ! 644: gl_index = gl_index + 1 ! 645: gl_line = 0 ! 646: gl_file = file ! 647: &ERRLIMIT = &ERRLIMIT + 1 ! 648: t = SETEXIT() ! 649: if (INPUT (.gl_in, gl_index, file)) { ! 650: SETEXIT(t) ! 651: &ERRLIMIT = &ERRLIMIT - 1 ! 652: return ! 653: } ! 654: SETEXIT(t) ! 655: gl_close() ! 656: error ("cannot read " && file) ! 657: freturn ! 658: } ! 659: ! 660: # Attempt to read an input line, return on ultimate failure. ! 661: # This procedure strips comments and handles continuation lines. ! 662: procedure getinput (recur) del, line { ! 663: ! 664: # have we already encountered the last EOF? ! 665: if (DIFFER (gi_eof)) ! 666: freturn ! 667: ! 668: if (line = line && getline()) { ! 669: ! 670: # if this is the first line, remember its identity ! 671: if (IDENT (recur)) { ! 672: gi_file = gl_file ! 673: gi_line = gl_line ! 674: } ! 675: ! 676: # strip comments ! 677: line ? ! 678: FENCE && ! 679: (ARBNO (BREAK ("'" && '"') && ! 680: LEN(1) $ del && BREAK (*del) && LEN(1)) && ! 681: BREAK ("'" && '"#')) . line && "#" ! 682: ! 683: # check for continuation ! 684: if (line? ANY("@$%^&*(-+=[<>|~,?:") && optblank && RPOS(0)) ! 685: line = line && getinput(1) ! 686: ! 687: return line ! 688: } ! 689: ! 690: # we're out of input - signal final eof ! 691: gi_eof = 1 ! 692: freturn ! 693: } ! 694: ! 695: # phrase() ! 696: # return the next phrase from the input ! 697: procedure phrase() del { ! 698: if (ph_buf ? FENCE && optblank && RPOS(0)) { ! 699: if (ph_buf = phbuf && getinput()) ! 700: return phrase() ! 701: else ! 702: freturn ! 703: } ! 704: ! 705: if (ph_buf ? FENCE && ! 706: (ARBNO(BREAK('"' && "'") && LEN(1) $ del && BREAK(*del) && ! 707: LEN(1)) && BREAK('"' && "';")) . phrase && ';' = '') ! 708: return ! 709: ! 710: phrase = ph_buf ! 711: ph_buf = '' ! 712: } ! 713: ! 714: # return a new label ! 715: procedure newlab() { ! 716: nl_count = nl_count + 1 ! 717: return "L." && nl_count ! 718: } ! 719: ! 720: # return a new label and place it on the current statement. ! 721: # If the current statement already has a label, use that. ! 722: procedure marklab() { ! 723: if (DIFFER (st_lab) && IDENT (emit_eob)) ! 724: return st_lab ! 725: marklab = newlab() ! 726: emitlab (marklab) ! 727: } ! 728: ! 729: # little routines to indicate what type of clause was read ! 730: ! 731: # expression clause ! 732: procedure expcl() { ! 733: cl_type = "exp" ! 734: } ! 735: ! 736: # goto clause ! 737: procedure gocl() { ! 738: cl_type = "goto" ! 739: } ! 740: ! 741: # read a new clause and classify it ! 742: # if end of input, error unless "okeof" argument is non-null, ! 743: # in which case we merely fail ! 744: # if rep_clause is set, give us the last clause again ! 745: procedure nclause (okeof) del { ! 746: nclause_start: ! 747: if (DIFFER (rep_clause)) { ! 748: rep_clause = "" ! 749: if (IDENT (eof)) ! 750: return ! 751: else ! 752: freturn ! 753: } ! 754: if (linebuf ? FENCE && *optblank && RPOS(0)) { ! 755: if (linebuf = phrase()) ! 756: go to nclause_start ! 757: ! 758: # end of input ! 759: if (IDENT(okeof)) { ! 760: error ('premature EOF') ! 761: go to EXIT ! 762: } ! 763: eof = 1 ! 764: freturn ! 765: } ! 766: ! 767: # we really have some input ! 768: if (linebuf ? clause = del) ! 769: return ! 770: error("syntax error") ! 771: linebuf = "" ! 772: go to nclause_start ! 773: } ! 774: ! 775: procedure error (msg) prefix { ! 776: if (IDENT (gl_file)) ! 777: prefix = "snocone" ! 778: else ! 779: prefix = gl_file && "(" && gl_line && ")" ! 780: terminal = prefix && ": " && msg ! 781: &CODE = 1 ! 782: } ! 783: ! 784: # handle a statement ! 785: procedure dostmt() lab, lab2, e1, e2, e3, flip { ! 786: ! 787: if (IDENT(cl_type,"exp")) { ! 788: # The clause is an expression, ! 789: # so that's the whole statement ! 790: sprint(pop()) ! 791: return ! 792: } ! 793: ! 794: # It might be a sequence of statements in braces ! 795: if (IDENT(cl_type,"{")) { ! 796: nclause() ! 797: while (DIFFER (cl_type, "}")) { ! 798: dostmt() ! 799: nclause() ! 800: } ! 801: return ! 802: } ! 803: ! 804: # It might be a goto statement ! 805: if (IDENT (cl_type, "goto")) { ! 806: emitg (dest) ! 807: return ! 808: } ! 809: ! 810: # It might be an if statement ! 811: if (IDENT(cl_type,"if")) { ! 812: e1 = pop() ! 813: ! 814: # optimize "if (~expr)" ! 815: if (isneg (e1)) { ! 816: flip = 1 ! 817: e1 = r(e1) ! 818: } ! 819: ! 820: sprint(e1) ! 821: ! 822: # Check for if(...)goto ! 823: nclause() ! 824: if (IDENT(cl_type,"goto")) { ! 825: if (IDENT (flip)) ! 826: emits(dest) ! 827: else ! 828: emitf(dest) ! 829: ! 830: # In the case of if (e) goto l; else ... ! 831: # we can pretend the else wasn't there ! 832: if (~nclause(1) || DIFFER (cl_type, "else")) { ! 833: rep_clause = 1 ! 834: emitlab (lab) ! 835: return ! 836: } ! 837: nclause() ! 838: dostmt() ! 839: return ! 840: } ! 841: ! 842: # Not if...goto, emit conditional jump over ! 843: # the statement which follows. ! 844: lab = newlab() ! 845: if (IDENT (flip)) ! 846: emitf(lab) ! 847: else ! 848: emits(lab) ! 849: dostmt() ! 850: ! 851: # Check for else clause ! 852: if (nclause (1) && IDENT (cl_type, "else")) { ! 853: ! 854: # There is indeed an else clause ! 855: lab2 = newlab() ! 856: emitg(lab2) ! 857: emitlab(lab) ! 858: nclause() ! 859: dostmt() ! 860: emitlab(lab2) ! 861: return ! 862: } ! 863: ! 864: # No else clause; we must look at this clause again later ! 865: rep_clause = 1 ! 866: emitlab(lab) ! 867: return ! 868: } ! 869: ! 870: # Check for a while clause ! 871: if (IDENT(cl_type,"while")) { ! 872: lab = marklab() ! 873: ! 874: # optimize "while(~exp)" ! 875: e1 = pop() ! 876: if (isneg (e1)) { ! 877: flip = 1 ! 878: e1 = r(e1) ! 879: } ! 880: ! 881: sprint(e1) ! 882: lab2 = newlab() ! 883: if (IDENT (flip)) ! 884: emitf(lab2) ! 885: else ! 886: emits(lab2) ! 887: nclause() ! 888: dostmt() ! 889: emitg(lab) ! 890: emitlab(lab2) ! 891: return ! 892: } ! 893: ! 894: # Check for a do clause ! 895: if (IDENT(cl_type,"do")) { ! 896: lab = marklab() ! 897: nclause() ! 898: dostmt() ! 899: nclause() ! 900: if (DIFFER(cl_type,"while")) { ! 901: error ("expected 'while', found " && cl_type) ! 902: rep_clause = 1 ! 903: return ! 904: } ! 905: e1 = pop() ! 906: if (isneg (e1)) { ! 907: flip = 1 ! 908: e1 = r (e1) ! 909: } ! 910: sprint(e1) ! 911: if (IDENT (flip)) ! 912: emits (lab) ! 913: else ! 914: emitf (lab) ! 915: return ! 916: } ! 917: ! 918: # Check for a "for" clause ! 919: if (IDENT(cl_type,"for")) { ! 920: e3 = pop() ! 921: e2 = pop() ! 922: e1 = pop() ! 923: sprint(e1) ! 924: emiteob() ! 925: lab = marklab() ! 926: lab2 = newlab() ! 927: if (isneg (e2)) { ! 928: flip = 1 ! 929: e2 = r (e2) ! 930: } ! 931: sprint(e2) ! 932: if (IDENT (flip)) ! 933: emitf (lab2) ! 934: else ! 935: emits (lab2) ! 936: nclause() ! 937: dostmt() ! 938: sprint(e3) ! 939: emitg(lab) ! 940: emitlab(lab2) ! 941: return ! 942: } ! 943: ! 944: # could be some kind of return statement ! 945: if (cl_type ? "return") { ! 946: e1 = pop() ! 947: if (DIFFER(e1)) { ! 948: if (DIFFER(fname)) ! 949: e1 = b(bconv["="],fname,e1) ! 950: sprint(e1) ! 951: } ! 952: emitg (REPLACE(cl_type, ! 953: "abcdefghijklmnopqrstuvwxyz", ! 954: "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) ! 955: return ! 956: } ! 957: ! 958: # could even be a null statement ! 959: if (IDENT(cl_type)) ! 960: return ! 961: ! 962: error("bad " && cl_type && " clause, ignored") ! 963: } ! 964: ! 965: # We have seen "struct" -- parse the 'declaration' ! 966: procedure dostruct() args { ! 967: if (expect ('{')) { ! 968: args = getlist ('}') ! 969: deflist[deflist[0] = deflist[0] + 1] = ! 970: "DATA('" && stname && "(" && args && ")')" ! 971: } else ! 972: error ("bad structure definition") ! 973: expect ('}') ! 974: } ! 975: ! 976: # We have seen "procedure" -- we must now parse the header ! 977: procedure funct() args, locals, flabel { ! 978: if (expect('(')) { ! 979: if (~(args = getlist(')'))) ! 980: go to fu_error ! 981: expect(')') ! 982: if (~(locals = getlist('{'))) ! 983: go to fu_error ! 984: } ! 985: ! 986: deflist[deflist[0] = deflist[0] + 1] = ! 987: "DEFINE('" && fname && '(' && args && ')' && locals && "')" ! 988: ! 989: # if we just emitted the end of a previous procedure, ! 990: # we can jump around this one in one go ! 991: if (IDENT (emit_eob) && st_lab ? ".END") { ! 992: flabel = st_lab ! 993: st_lab = "" ! 994: emitlab(fname) ! 995: nclause() ! 996: dostmt() ! 997: emitg("RETURN") ! 998: emitlab(flabel) ! 999: return ! 1000: } ! 1001: ! 1002: emitg(fname && '.END') ! 1003: emitlab(fname) ! 1004: nclause() ! 1005: dostmt() ! 1006: emitg("RETURN") ! 1007: emitlab(fname && '.END') ! 1008: return ! 1009: ! 1010: fu_error: ! 1011: error("bad function definition") ! 1012: } ! 1013: ! 1014: # the input should now contain something matching "p" ! 1015: # possibly surrounded by white space. If not, fail ! 1016: procedure expect (p) { ! 1017: ! 1018: # throw away blank lines ! 1019: while (linebuf ? FENCE && optblank && RPOS (0)) { ! 1020: if (~(linebuf = phrase())) ! 1021: freturn ! 1022: } ! 1023: ! 1024: # try to match the given pattern, possibly preceded by white space ! 1025: if (linebuf ? FENCE && optblank && *p = "") ! 1026: return ! 1027: ! 1028: # didn't match: fail ! 1029: freturn ! 1030: } ! 1031: ! 1032: # expect an identifier in the input; return it. ! 1033: procedure getid() { ! 1034: if (expect (*identifier . getid)) ! 1035: return ! 1036: freturn ! 1037: } ! 1038: ! 1039: # expect a list of identifiers followed by tail ! 1040: procedure getlist (tail) del { ! 1041: getlist_start: ! 1042: if (expect(tail)) { ! 1043: linebuf = tail && linebuf ! 1044: return ! 1045: } ! 1046: if (getlist = getlist && del && getid()) { ! 1047: expect(',') ! 1048: del = ',' ! 1049: go to getlist_start ! 1050: } ! 1051: if (expect(tail)) ! 1052: return ! 1053: freturn ! 1054: } ! 1055: ! 1056: # This procedure is called once for each output statement. ! 1057: # It maintains the correspondence between Snocone and SNOBOL4 ! 1058: # statements, which is inserted into the output for debugging. ! 1059: procedure buildstab (stmt, file, line) desc, pad { ! 1060: pad = DUPL ("?", stmt - bst_stmt - 1) ! 1061: bst_stab = bst_stab && pad ! 1062: if (IDENT (file, bst_file)) { ! 1063: if (DIFFER(pad) || line != bst_line + 1) ! 1064: desc = line ! 1065: } else ! 1066: desc = file && ":" && line ! 1067: bst_stab = bst_stab && desc && "," ! 1068: bst_stmt = stmt ! 1069: bst_file = file ! 1070: bst_line = line ! 1071: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.