![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to osnocone.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 osnocone.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 && optblank && ! 105: ("" . *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: # ! 154: # Permanent prologue ! 155: emitlab("MAIN.") ! 156: # ! 157: # The main loop. We expect to read a series of statements. ! 158: while (nclause (1)) { ! 159: if (ident (cl_type, "procedure")) ! 160: funct() ! 161: else if (ident (cl_type, "struct")) ! 162: dostruct() ! 163: else ! 164: dostmt() ! 165: } ! 166: ! 167: ! 168: # Epilogue ! 169: exit: ! 170: emitg("END") ! 171: emitlab("START.") ! 172: emit("CODE('START.')") ! 173: for (i = 1, i <= deflist[0], i = i + 1) { ! 174: emiteos() ! 175: emit(deflist[i]) ! 176: } ! 177: ! 178: # put out code to trap run-time errors ! 179: emiteos() ! 180: emit("&ERRLIMIT = 1") ! 181: emiteos() ! 182: emit("SETEXIT(.err.exit)") ! 183: ! 184: # put out code to assign the statement map ! 185: emiteos() ! 186: emit ("err.map = '") ! 187: while (bst_stab ? len(50) . bst_chunk = "") { ! 188: emit (bst_chunk && "'") ! 189: emiteos() ! 190: emitlab("+") ! 191: emit("'") ! 192: } ! 193: emit (bst_stab && "'") ! 194: ! 195: emitg("MAIN.") ! 196: emiteos() ! 197: ! 198: # Epilogue ! 199: input(.inf,-2,'/usr/lib/snocone/epilogue') ! 200: while (line = inf) ! 201: outf = line ! 202: endfile(-2) ! 203: ! 204: endfile(-1) ! 205: host (1, "chmod +x " && outfile) ! 206: ! 207: ! 208: ! 209: # subroutines ! 210: ! 211: ! 212: ! 213: ! 214: # like span, but the pattern returned ! 215: # can also match the null string ! 216: procedure nspan (str) { ! 217: return span (str) | "" ! 218: } ! 219: ! 220: # a pattern that matches a list of zero or more ! 221: # "item"s separated by "delim"s ! 222: procedure list (item, delim) { ! 223: return item && arbno (delim && item) | "" ! 224: } ! 225: ! 226: # a pattern that matches the keyword given by the ! 227: # argument, insisting that it be followed by a non-letter. ! 228: procedure kw (s) { ! 229: return span(letters) $ dummy && ! 230: convert("ident(dummy,'" && s && "')", "EXPRESSION") ! 231: } ! 232: ! 233: # return the name of the (new) top stack element ! 234: procedure push() { ! 235: stackptr = stackptr + 1 ! 236: nreturn .stack[stackptr] ! 237: } ! 238: ! 239: # return the value of the (old) top stack element ! 240: procedure pop() { ! 241: pop = stack[stackptr] ! 242: stack[stackptr] = "" ! 243: stackptr = stackptr - 1 ! 244: } ! 245: ! 246: # return the name of the stack element n away from the top ! 247: procedure peek (n) { ! 248: if (n >= stackptr) ! 249: go to err ! 250: nreturn .stack[stackptr - n] ! 251: } ! 252: ! 253: # top() ! 254: # return the name of the top stack element ! 255: procedure top() { ! 256: nreturn .stack[stackptr] ! 257: } ! 258: ! 259: # isbin(x) ! 260: # is x a structure describing a binary operator? ! 261: # things like == and ||, which syntactically look ! 262: # more like functions than operators in their snobol form, ! 263: # are considered not to be operators. ! 264: procedure isbin (x) { ! 265: if (differ (datatype (x), 'B') || differ (fn (op (x)))) ! 266: freturn ! 267: } ! 268: ! 269: # isneg(x) ! 270: # is x a structure describing a unary negation operator? ! 271: procedure isneg (x) { ! 272: if (differ (datatype (x), 'U') || differ (op (x), '~')) ! 273: freturn ! 274: } ! 275: ! 276: # ! 277: # print an expression in snobol form ! 278: procedure dprint (x) op, l, r, d, i, del { ! 279: d = datatype(x) ! 280: if (ident (d, 'STRING')) { ! 281: emit (x) ! 282: return ! 283: } ! 284: ! 285: if (ident (d, 'U')) { ! 286: # unary operator ! 287: emit (op (x)) ! 288: if (isbin(r(x))) ! 289: emit('(') ! 290: dprint(r(x)) ! 291: if (isbin(r(x))) ! 292: emit(')') ! 293: return ! 294: } ! 295: ! 296: ! 297: if (ident (d, 'FCALL')) { ! 298: # function call or array reference ! 299: emit (name (x)) ! 300: emit (l (x)) ! 301: r = args (x) ! 302: while (differ (r)) { ! 303: emit (del) ! 304: dprint (exp (r)) ! 305: del = ',' ! 306: r = next (r) ! 307: } ! 308: emit (r (x)) ! 309: return ! 310: } ! 311: ! 312: if (ident (d, 'B')) { ! 313: # binary operator ! 314: op = op (x) ! 315: if (ident (op, or_binfo)) { ! 316: emit ('(') ! 317: bprint (x) ! 318: emit (')') ! 319: return ! 320: } ! 321: l = isbin(l(x)) && slp(op(l(x))) < srp(op) && 1 || "" ! 322: r = isbin(r(x)) && slp(op) > srp(op(r(x))) && 1 || "" ! 323: ! 324: # check for [f](a,b) ! 325: if (differ (fn (op))) { ! 326: emit(out(op)) ! 327: emit('(') ! 328: dprint(l(x)) ! 329: emit(',') ! 330: dprint(r(x)) ! 331: emit(')') ! 332: return ! 333: } ! 334: ! 335: # ordinary binary operator ! 336: if (differ (l)) ! 337: emit ('(') ! 338: dprint(l(x)) ! 339: if (differ (l)) ! 340: emit (')') ! 341: emitb(out(op)) ! 342: if (differ(r)) ! 343: emit('(') ! 344: dprint(r(x)) ! 345: if (differ(r)) ! 346: emit(')') ! 347: return ! 348: } ! 349: ! 350: # unknown datatype -- this "shouldn't happen" ! 351: i = 1 ! 352: emit(d) ! 353: emit ('(') ! 354: while (dprint (apply (field (d, i), x))) { ! 355: i = i + 1 ! 356: emit (',') ! 357: } ! 358: emit (')') ! 359: } ! 360: ! 361: # bprint(x) ! 362: # subroutine of dprint -- used to handle printing of ! 363: # things of the form (a,b), which are inherently ! 364: # associative and can therefore be grouped as follows ! 365: # ((a,b),c) <=> (a,(b,c)) <=> (a,b,c) ! 366: procedure bprint (x) { ! 367: if (differ (datatype(x), 'B') || differ (op(x), or_binfo)) { ! 368: dprint (x) ! 369: return ! 370: } ! 371: bprint(l(x)) ! 372: emit(',') ! 373: bprint(r(x)) ! 374: } ! 375: ! 376: # sprint(x) ! 377: # like dprint, but print in a form appropriate for ! 378: # an entire statement. This procedure exists ! 379: # because if the top level operator is a concatenation, ! 380: # it is necessary to enclose the whole thing in parentheses. ! 381: # Otherwise it would be mistaken for a pattern match. ! 382: procedure sprint (x) { ! 383: if (ident(datatype(x),'B') && ident(op(x),cat_binfo)) ! 384: emit('(') ! 385: dprint(x) ! 386: if (ident(datatype(x),'B') && ident(op(x),cat_binfo)) ! 387: emit(')') ! 388: emiteob() ! 389: } ! 390: ! 391: # invoke(f) ! 392: # call an argument-free function in a context where ! 393: # a name is required, such as arb . *invoke(.foo) ! 394: procedure invoke (f) { ! 395: apply (f) ! 396: nreturn .dummy ! 397: } ! 398: ! 399: # a unary operator has been detected during parsing ! 400: procedure unop() r, op { ! 401: r = pop() ! 402: op = pop() ! 403: push() = u(op,r) ! 404: } ! 405: ! 406: # mkfcall() ! 407: # Parsing has detected the beginning of a function call ! 408: procedure mkfcall() { ! 409: push() = i_fcall() ! 410: nreturn .name(top()) ! 411: } ! 412: ! 413: # parsing has detected an argument to a function ! 414: procedure mkarg() x, f { ! 415: x = argexp(pop(),"") ! 416: f = top() ! 417: if (differ(tail(f))) ! 418: next(tail(f)) = x ! 419: tail(f) = x ! 420: head(f) = ident(head(f)) && x ! 421: } ! 422: ! 423: # parsing has detected the end of a function call ! 424: procedure endfc() f { ! 425: f = pop() ! 426: push() = fcall(name(f),head(f),'(',')') ! 427: } ! 428: ! 429: # the fcall at the head of the stack is really an array ! 430: procedure mkarray() t { ! 431: t = top() ! 432: l(t) = '<' ! 433: r(t) = '>' ! 434: } ! 435: ! 436: # the beginning of an expression has been detected ! 437: procedure begexp() { ! 438: push() = bconv['('] ! 439: nreturn .dummy ! 440: } ! 441: ! 442: # a binary operator has been detected. We handle ! 443: # precedence here rather than in the grammar ! 444: # because it is less work. ! 445: procedure binop() l, r, op, newr, newop { ! 446: while (lp(peek(3)) >= rp(peek(1))) { ! 447: newr = pop() ! 448: newop = pop() ! 449: r = pop() ! 450: op = pop() ! 451: l = pop() ! 452: push() = b(op,l,r) ! 453: push() = newop ! 454: push() = newr ! 455: } ! 456: } ! 457: ! 458: # the end of an expression has been detected ! 459: procedure endexp() l, r, op { ! 460: while (differ (peek (1), par_binfo)) { ! 461: r = pop() ! 462: op = pop() ! 463: l = pop() ! 464: push() = b(op,l,r) ! 465: } ! 466: r = pop() ! 467: pop() ! 468: push() = r ! 469: nreturn .dummy ! 470: } ! 471: ! 472: # locate the binfo structure that describes the ! 473: # binary operator whose input character representation ! 474: # has been placed on the top of the stack. ! 475: procedure mkbinfo() op { ! 476: op = bconv[pop()] ! 477: if (ident(op)) ! 478: go to err ! 479: push() = op ! 480: } ! 481: ! 482: # dotck() ! 483: # if necessary, append a leading zero to a floating-point ! 484: # constant that begins with a decimal point. The idea ! 485: # that .5 is syntactically correct but semantically illegal ! 486: # is just too scary to leave in. ! 487: procedure dotck() { ! 488: top() ? fence && '.' = '0.' ! 489: nreturn .dummy ! 490: } ! 491: ! 492: # write label l to the output ! 493: procedure emitlab (l) { ! 494: if (differ(l)) { ! 495: emiteos() ! 496: st_lab = l ! 497: } ! 498: nreturn .dummy ! 499: } ! 500: ! 501: # put string s in the output ! 502: procedure emit (s) { ! 503: if (differ(emit_eob)) ! 504: emiteos() ! 505: st_body = st_body && s ! 506: } ! 507: ! 508: # we are done with the body of the generated statement ! 509: procedure emiteob() { ! 510: if (ident (emit_eob)) { ! 511: buildstab (emit_stno, gi_file, gi_line) ! 512: emit_eob = 1 ! 513: } ! 514: } ! 515: ! 516: # write success branch l ! 517: procedure emits (l) { ! 518: emiteob() ! 519: st_s = l ! 520: } ! 521: ! 522: # emitf(l) ! 523: # write failure branch l ! 524: procedure emitf (l) { ! 525: emiteob() ! 526: st_f = l ! 527: } ! 528: ! 529: # write unconditional branch l ! 530: procedure emitg (l) { ! 531: emiteob() ! 532: st_s = ident(st_s) && l ! 533: st_f = ident(st_f) && l ! 534: } ! 535: ! 536: # write s surrounded by blanks ! 537: procedure emitb (s) { ! 538: emit(' ') ! 539: if (differ (s, ' ')) { ! 540: emit (s) ! 541: emit(' ') ! 542: } ! 543: } ! 544: ! 545: # emiteos()out,goto ! 546: # we are done with the entire statement ! 547: procedure emiteos() out, goto, s, del { ! 548: emit_eob = "" ! 549: if (differ(st_lab) || differ(st_body) || differ(st_s) || differ(st_f)) { ! 550: emit_stno = emit_stno + 1 ! 551: out = st_lab && " " && st_body ! 552: if (differ (st_s) || differ (st_f)) { ! 553: goto = " :" ! 554: if (ident (st_s, st_f)) ! 555: goto = goto && "(" && st_s && ")" ! 556: else { ! 557: if (differ (st_s)) ! 558: goto = goto && "S(" && st_s && ")" ! 559: if (differ (st_f)) ! 560: goto = goto && "F(" && st_f && ")" ! 561: } ! 562: } ! 563: out = out && goto ! 564: while (size(out) >= 70) { ! 565: 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 && arbno(break('"' && "';") && fence && ! 706: (any('"' && "'")$del && break(*del) && len(1) | ! 707: "")).phrase && ';' = '') ! 708: return ! 709: phrase = ph_buf ! 710: ph_buf = '' ! 711: } ! 712: ! 713: # return a new label ! 714: procedure newlab() { ! 715: nl_count = nl_count + 1 ! 716: return "L." && nl_count ! 717: } ! 718: ! 719: # return a new label and place it on the current statement. ! 720: # If the current statement already has a label, use that. ! 721: procedure marklab() { ! 722: if (differ (st_lab) && ident (emit_eob)) ! 723: return st_lab ! 724: marklab = newlab() ! 725: emitlab (marklab) ! 726: } ! 727: ! 728: # little routines to indicate what type of clause was read ! 729: ! 730: # expression clause ! 731: procedure expcl() { ! 732: cl_type = "exp" ! 733: } ! 734: ! 735: # goto clause ! 736: procedure gocl() { ! 737: cl_type = "goto" ! 738: } ! 739: ! 740: # read a new clause and classify it ! 741: # if end of input, error unless "okeof" argument is non-null, ! 742: # in which case we merely fail ! 743: # if rep_clause is set, give us the last clause again ! 744: procedure nclause (okeof) del { ! 745: nclause_start: ! 746: if (differ (rep_clause)) { ! 747: rep_clause = "" ! 748: if (ident (eof)) ! 749: return ! 750: else ! 751: freturn ! 752: } ! 753: if (linebuf ? fence && *optblank && rpos(0)) { ! 754: if (linebuf = phrase()) ! 755: go to nclause_start ! 756: ! 757: # end of input ! 758: if (ident(okeof)) { ! 759: error ('premature EOF') ! 760: go to exit ! 761: } ! 762: eof = 1 ! 763: freturn ! 764: } ! 765: ! 766: # we really have some input ! 767: if (linebuf ? clause = del) ! 768: return ! 769: error("syntax error") ! 770: linebuf = "" ! 771: go to nclause_start ! 772: } ! 773: ! 774: procedure error (msg) prefix { ! 775: if (ident (gl_file)) ! 776: prefix = "snocone" ! 777: else ! 778: prefix = gl_file && "(" && gl_line && ")" ! 779: terminal = prefix && ": " && msg ! 780: &code = 1 ! 781: } ! 782: ! 783: # handle a statement ! 784: procedure dostmt() lab, lab2, e1, e2, e3, flip { ! 785: ! 786: if (ident(cl_type,"exp")) { ! 787: # The clause is an expression, ! 788: # so that's the whole statement ! 789: sprint(pop()) ! 790: return ! 791: } ! 792: ! 793: # It might be a sequence of statements in braces ! 794: if (ident(cl_type,"{")) { ! 795: nclause() ! 796: while (differ (cl_type, "}")) { ! 797: dostmt() ! 798: nclause() ! 799: } ! 800: return ! 801: } ! 802: ! 803: # It might be a goto statement ! 804: if (ident (cl_type, "goto")) { ! 805: emitg (dest) ! 806: return ! 807: } ! 808: ! 809: # It might be an if statement ! 810: if (ident(cl_type,"if")) { ! 811: e1 = pop() ! 812: ! 813: # optimize "if (~expr)" ! 814: if (isneg (e1)) { ! 815: flip = 1 ! 816: e1 = r(e1) ! 817: } ! 818: ! 819: sprint(e1) ! 820: ! 821: # Check for if(...)goto ! 822: nclause() ! 823: if (ident(cl_type,"goto")) { ! 824: if (ident (flip)) ! 825: emits(dest) ! 826: else ! 827: emitf(dest) ! 828: ! 829: # In the case of if (e) goto l; else ... ! 830: # we can pretend the else wasn't there ! 831: if (~nclause(1) || differ (cl_type, "else")) { ! 832: rep_clause = 1 ! 833: emitlab (lab) ! 834: return ! 835: } ! 836: nclause() ! 837: dostmt() ! 838: return ! 839: } ! 840: ! 841: # Not if...goto, emit conditional jump over ! 842: # the statement which follows. ! 843: lab = newlab() ! 844: if (ident (flip)) ! 845: emitf(lab) ! 846: else ! 847: emits(lab) ! 848: dostmt() ! 849: ! 850: # Check for else clause ! 851: if (nclause (1) && ident (cl_type, "else")) { ! 852: ! 853: # There is indeed an else clause ! 854: lab2 = newlab() ! 855: emitg(lab2) ! 856: emitlab(lab) ! 857: nclause() ! 858: dostmt() ! 859: emitlab(lab2) ! 860: return ! 861: } ! 862: ! 863: # No else clause; we must look at this clause again later ! 864: rep_clause = 1 ! 865: emitlab(lab) ! 866: return ! 867: } ! 868: ! 869: # Check for a while clause ! 870: if (ident(cl_type,"while")) { ! 871: lab = marklab() ! 872: ! 873: # optimize "while(~exp)" ! 874: e1 = pop() ! 875: if (isneg (e1)) { ! 876: flip = 1 ! 877: e1 = r(e1) ! 878: } ! 879: ! 880: sprint(e1) ! 881: lab2 = newlab() ! 882: if (ident (flip)) ! 883: emitf(lab2) ! 884: else ! 885: emits(lab2) ! 886: nclause() ! 887: dostmt() ! 888: emitg(lab) ! 889: emitlab(lab2) ! 890: return ! 891: } ! 892: ! 893: # Check for a do clause ! 894: if (ident(cl_type,"do")) { ! 895: lab = marklab() ! 896: nclause() ! 897: dostmt() ! 898: nclause() ! 899: if (differ(cl_type,"while")) { ! 900: error ("expected 'while', found " && cl_type) ! 901: rep_clause = 1 ! 902: return ! 903: } ! 904: e1 = pop() ! 905: if (isneg (e1)) { ! 906: flip = 1 ! 907: e1 = r (e1) ! 908: } ! 909: sprint(e1) ! 910: if (ident (flip)) ! 911: emits (lab) ! 912: else ! 913: emitf (lab) ! 914: return ! 915: } ! 916: ! 917: # Check for a "for" clause ! 918: if (ident(cl_type,"for")) { ! 919: e3 = pop() ! 920: e2 = pop() ! 921: e1 = pop() ! 922: sprint(e1) ! 923: emiteob() ! 924: lab = marklab() ! 925: lab2 = newlab() ! 926: if (isneg (e2)) { ! 927: flip = 1 ! 928: e2 = r (e2) ! 929: } ! 930: sprint(e2) ! 931: if (ident (flip)) ! 932: emitf (lab2) ! 933: else ! 934: emits (lab2) ! 935: nclause() ! 936: dostmt() ! 937: sprint(e3) ! 938: emitg(lab) ! 939: emitlab(lab2) ! 940: return ! 941: } ! 942: ! 943: # could be some kind of return statement ! 944: if (cl_type ? "return") { ! 945: e1 = pop() ! 946: if (differ(e1)) { ! 947: if (differ(fname)) ! 948: e1 = b(bconv["="],fname,e1) ! 949: sprint(e1) ! 950: } ! 951: emitg (replace(cl_type, ! 952: "abcdefghijklmnopqrstuvwxyz", ! 953: "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) ! 954: return ! 955: } ! 956: ! 957: # could even be a null statement ! 958: if (ident(cl_type)) ! 959: return ! 960: ! 961: error("bad " && cl_type && " clause, ignored") ! 962: } ! 963: ! 964: # We have seen "struct" -- parse the 'declaration' ! 965: procedure dostruct() args { ! 966: if (expect ('{')) { ! 967: args = getlist ('}') ! 968: deflist[deflist[0] = deflist[0] + 1] = ! 969: "DATA('" && stname && "(" && args && ")')" ! 970: } else ! 971: error ("bad structure definition") ! 972: expect ('}') ! 973: } ! 974: ! 975: # We have seen "procedure" -- we must now parse the header ! 976: procedure funct() args, locals, flabel { ! 977: if (expect('(')) { ! 978: if (~(args = getlist(')'))) ! 979: go to fu_error ! 980: expect(')') ! 981: if (~(locals = getlist('{'))) ! 982: go to fu_error ! 983: } ! 984: ! 985: deflist[deflist[0] = deflist[0] + 1] = ! 986: "DEFINE('" && fname && '(' && args && ')' && locals && "')" ! 987: ! 988: # if we just emitted the end of a previous procedure, ! 989: # we can jump around this one in one go ! 990: if (ident (emit_eob) && st_lab ? ".END") { ! 991: flabel = st_lab ! 992: st_lab = "" ! 993: emitlab(fname) ! 994: nclause() ! 995: dostmt() ! 996: emitg("RETURN") ! 997: emitlab(flabel) ! 998: return ! 999: } ! 1000: ! 1001: emitg(fname && '.END') ! 1002: emitlab(fname) ! 1003: nclause() ! 1004: dostmt() ! 1005: emitg("RETURN") ! 1006: emitlab(fname && '.END') ! 1007: return ! 1008: ! 1009: fu_error: ! 1010: error("bad function definition") ! 1011: } ! 1012: ! 1013: # the input should now contain something matching "p" ! 1014: # possibly surrounded by white space. If not, fail ! 1015: procedure expect (p) { ! 1016: ! 1017: # throw away blank lines ! 1018: while (linebuf ? fence && optblank && rpos (0)) { ! 1019: if (~(linebuf = phrase())) ! 1020: freturn ! 1021: } ! 1022: ! 1023: # try to match the given pattern, possibly preceded by white space ! 1024: if (linebuf ? fence && optblank && *p = "") ! 1025: return ! 1026: ! 1027: # didn't match: fail ! 1028: freturn ! 1029: } ! 1030: ! 1031: # expect an identifier in the input; return it. ! 1032: procedure getid() { ! 1033: if (expect (*identifier . getid)) ! 1034: return ! 1035: freturn ! 1036: } ! 1037: ! 1038: # expect a list of identifiers followed by tail ! 1039: procedure getlist (tail) del { ! 1040: getlist_start: ! 1041: if (expect(tail)) { ! 1042: linebuf = tail && linebuf ! 1043: return ! 1044: } ! 1045: if (getlist = getlist && del && getid()) { ! 1046: expect(',') ! 1047: del = ',' ! 1048: go to getlist_start ! 1049: } ! 1050: if (expect(tail)) ! 1051: return ! 1052: freturn ! 1053: } ! 1054: ! 1055: # This procedure is called once for each output statement. ! 1056: # It maintains the correspondence between Snocone and SNOBOL4 ! 1057: # statements, which is inserted into the output for debugging. ! 1058: procedure buildstab (stmt, file, line) desc, pad { ! 1059: pad = dupl ("?", stmt - bst_stmt - 1) ! 1060: bst_stab = bst_stab && pad ! 1061: if (ident (file, bst_file)) { ! 1062: if (differ(pad) || line != bst_line + 1) ! 1063: desc = line ! 1064: } else ! 1065: desc = file && ":" && line ! 1066: bst_stab = bst_stab && desc && "," ! 1067: bst_stmt = stmt ! 1068: bst_file = file ! 1069: bst_line = line ! 1070: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.