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