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