![[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.