![[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] / researchv10dc / cmd / snocone|
Return to osnocone.sc CVS log | Up to [Research Unix] / researchv10dc / 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.