DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / gpcp-linux.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Fix preverification error on jvm when used procedure types
[gpcp-linux.git] / gpcp / JavaMaker.cp
1 (* ============================================================ *)
2 (* JavaMaker is the concrete class for emitting java *)
3 (* class files. *)
4 (* Diane Corney - September,2000. *)
5 (* ============================================================ *)
6
7 MODULE JavaMaker;
8
9 IMPORT
10 GPCPcopyright,
11 ASCII,
12 Error,
13 Console,
14 L := LitValue,
15 CPascalS,
16 FileNames,
17 ClassMaker,
18 JavaBase,
19 ClassUtil,
20 JsmnUtil,
21 Cst := CompState,
22 Jvm := JVMcodes,
23 Ju := JavaUtil,
24 Bi := Builtin,
25 Sy := Symbols,
26 Id := IdDesc,
27 Ty := TypeDesc,
28 Xp := ExprDesc,
29 St := StatDesc;
30
31 (* ------------------------------------ *)
32
33 TYPE JavaWorkList* =
34 POINTER TO
35 RECORD (JavaBase.ClassEmitter)
36 (* --------------------------- *
37 * mod* : Id.BlkId; *
38 * --------------------------- *)
39 tide : INTEGER;
40 high : INTEGER;
41 work : POINTER TO ARRAY OF JavaEmitter;
42 END;
43
44 (* ------------------------------------ *)
45
46 TYPE JavaEmitter* =
47 POINTER TO ABSTRACT
48 RECORD (JavaBase.ClassEmitter)
49 (* --------------------------- *
50 * mod* : Id.BlkId; *
51 * --------------------------- *)
52 outF : Ju.JavaFile;
53 END;
54
55 (* ------------------------------------ *)
56
57 TYPE JavaModEmitter* =
58 POINTER TO
59 RECORD (JavaEmitter);
60 (* --------------------------- *
61 * mod* : Id.BlkId; *
62 * outF : JavaBase.JavaFile; *
63 * --------------------------- *)
64 END;
65
66 (* ------------------------------------ *)
67
68 TYPE JavaRecEmitter* =
69 POINTER TO
70 RECORD (JavaEmitter)
71 (* --------------------------- *
72 * mod* : Id.BlkId; *
73 * outF : Ju.JavaFile; *
74 * --------------------------- *)
75 recT : Ty.Record;
76 END;
77
78 (* ------------------------------------ *)
79
80 TYPE JavaProcTypeEmitter* =
81 POINTER TO
82 RECORD (JavaEmitter)
83 (* --------------------------- *
84 * mod* : Id.BlkId; *
85 * outF : Ju.JavaFile; *
86 * --------------------------- *)
87 prcT : Ty.Procedure;
88 END;
89
90 (* ------------------------------------ *)
91
92 TYPE JavaAssembler* =
93 POINTER TO
94 RECORD (ClassMaker.Assembler)
95 END;
96
97
98 (* ------------------------------------ *)
99
100 VAR
101 asmList : L.CharOpenSeq;
102 currentLoopLabel : Ju.Label;
103
104 (* ============================================================ *)
105
106 PROCEDURE Append(list : JavaWorkList;
107 emit : JavaEmitter);
108 VAR temp : POINTER TO ARRAY OF JavaEmitter;
109 i : INTEGER;
110 BEGIN
111 IF list.tide > list.high THEN (* must expand *)
112 temp := list.work;
113 list.high := list.high * 2 + 1;
114 NEW(list.work, (list.high+1));
115 FOR i := 0 TO list.tide-1 DO list.work[i] := temp[i] END;
116 END;
117 list.work[list.tide] := emit; INC(list.tide);
118 END Append;
119
120 (* ============================================================ *)
121
122 PROCEDURE newJavaEmitter*(mod : Id.BlkId) : JavaWorkList;
123 VAR emitter : JavaWorkList;
124 modEmit : JavaModEmitter;
125 modName : L.CharOpen;
126 BEGIN
127 modName := Sy.getName.ChPtr(mod);
128 (*
129 * Allocate a new worklist object.
130 *)
131 NEW(emitter);
132 emitter.mod := mod;
133 NEW(emitter.work, 4);
134 emitter.tide := 0;
135 emitter.high := 3;
136 JavaBase.worklist := emitter;
137 (*
138 * Allocate a JavaModEmitter to be first item
139 * on the worklist. All later items will be of
140 * JavaRecEmitter type.
141 *)
142 NEW(modEmit);
143 modEmit.mod := mod;
144 (*
145 * Now append the mod-emitter to the worklist.
146 *)
147 Append(emitter, modEmit);
148 RETURN emitter;
149 END newJavaEmitter;
150
151 (* ============================================================ *)
152
153 PROCEDURE newJavaAsm*() : JavaAssembler;
154 VAR asm : JavaAssembler;
155 BEGIN
156 NEW(asm);
157 L.ResetCharOpenSeq(asmList);
158 RETURN asm;
159 END newJavaAsm;
160
161 (* ============================================================ *)
162
163 PROCEDURE (list : JavaWorkList)AddNewRecEmitter*(inTp : Ty.Record);
164 VAR emit : JavaRecEmitter;
165 BEGIN
166 NEW(emit);
167 emit.mod := list.mod;
168 (*
169 * Set the current record type for this class.
170 *)
171 emit.recT := inTp;
172 (*
173 * Now append the new RecEmitter to the worklist.
174 *)
175 Append(list, emit);
176 END AddNewRecEmitter;
177
178 (* ============================================================ *)
179
180 PROCEDURE (list : JavaWorkList)AddNewProcTypeEmitter*(inTp : Ty.Procedure);
181 VAR emit : JavaProcTypeEmitter;
182 BEGIN
183 NEW(emit);
184 emit.mod := list.mod;
185 (*
186 * Set the current record type for this class.
187 *)
188 emit.prcT := inTp;
189 (*
190 * Now append the new RecEmitter to the worklist.
191 *)
192 Append(list, emit);
193 END AddNewProcTypeEmitter;
194
195 (* ============================================================ *)
196 (* Mainline emitter, consumes worklist emitting assembler *)
197 (* files until the worklist is empty. *)
198 (* ============================================================ *)
199
200 PROCEDURE (this : JavaWorkList)Emit*();
201 VAR ix : INTEGER;
202 BEGIN
203 (*
204 * First construct the base class-name string in the BlkId.
205 *)
206 Ju.Init();
207 Ju.MkBlkName(this.mod);
208
209 ix := 0;
210 WHILE ix < this.tide DO
211 this.work[ix].Emit();
212 INC(ix);
213 END;
214 END Emit;
215
216 (* ============================================================ *)
217 (* Creates basic imports for java.lang, and inserts a few type *)
218 (* descriptors for Object, Exception, and String. *)
219 (* ============================================================ *)
220
221 PROCEDURE (this : JavaWorkList)Init*();
222 VAR tId : Id.TypId;
223 blk : Id.BlkId;
224 obj : Id.TypId;
225 cls : Id.TypId;
226 str : Id.TypId;
227 exc : Id.TypId;
228 xhr : Id.TypId;
229 BEGIN
230 (*
231 * Create import descriptor for java.lang
232 *)
233 Bi.MkDummyImport("java_lang", "java.lang", blk);
234 Cst.SetSysLib(blk);
235 (*
236 * Create various classes.
237 *)
238 Bi.MkDummyClass("Object", blk, Ty.isAbs, obj);
239 Cst.ntvObj := obj.type;
240 Bi.MkDummyClass("String", blk, Ty.noAtt, str);
241 Cst.ntvStr := str.type;
242 Bi.MkDummyClass("Exception", blk, Ty.extns, exc);
243 Cst.ntvExc := exc.type;
244 Bi.MkDummyClass("Class", blk, Ty.noAtt, cls);
245 Cst.ntvTyp := cls.type;
246 (*
247 * Create import descriptor for CP.RTS
248 *)
249 Bi.MkDummyImport("RTS", "", blk);
250 Bi.MkDummyAlias("NativeType", blk, cls.type, Cst.clsId);
251 Bi.MkDummyAlias("NativeObject", blk, obj.type, Cst.objId);
252 Bi.MkDummyAlias("NativeString", blk, str.type, Cst.strId);
253 Bi.MkDummyAlias("NativeException", blk, exc.type, Cst.excId);
254
255 Bi.MkDummyVar("dblPosInfinity",blk,Bi.realTp,Cst.dblInf);
256 Bi.MkDummyVar("dblNegInfinity",blk,Bi.realTp,Cst.dblNInf);
257 Bi.MkDummyVar("fltPosInfinity",blk,Bi.sReaTp,Cst.fltInf);
258 Bi.MkDummyVar("fltNegInfinity",blk,Bi.sReaTp,Cst.fltNInf);
259 INCL(blk.xAttr, Sy.need);
260 (*
261 * Uplevel addressing stuff.
262 *)
263 Bi.MkDummyImport("$CPJrts$", "CP.CPJrts", blk);
264 Bi.MkDummyClass("XHR", blk, Ty.isAbs, xhr);
265 Cst.rtsXHR := xhr.type;
266 Cst.xhrId.recTyp := Cst.rtsXHR;
267 Cst.xhrId.type := Cst.rtsXHR;
268 END Init;
269
270 (* ============================================================ *)
271
272 PROCEDURE (this : JavaWorkList)ObjectFeatures*();
273 VAR prcSig : Ty.Procedure;
274 thePar : Id.ParId;
275 BEGIN
276 NEW(prcSig);
277 prcSig.retType := Cst.strId.type;
278 Id.InitParSeq(prcSig.formals, 2);
279 Bi.MkDummyMethodAndInsert("toString", prcSig, Cst.ntvObj, Cst.sysLib, Sy.pubMode, Sy.var, Id.extns);
280
281 NEW(prcSig);
282 prcSig.retType := Bi.intTp;
283 Id.InitParSeq(prcSig.formals, 2);
284 Bi.MkDummyMethodAndInsert("hashCode", prcSig, Cst.ntvObj, Cst.sysLib, Sy.pubMode, Sy.var, Id.extns);
285
286 NEW(prcSig);
287 prcSig.retType := Cst.ntvObj;
288 Id.InitParSeq(prcSig.formals, 2);
289 Bi.MkDummyMethodAndInsert("clone", prcSig, Cst.ntvObj, Cst.sysLib, Sy.protect, Sy.var, Id.extns);
290
291 NEW(prcSig);
292 NEW(thePar);
293 prcSig.retType := Bi.boolTp;
294 Id.InitParSeq(prcSig.formals, 2);
295 thePar.parMod := Sy.val;
296 thePar.type := Cst.ntvObj;
297 thePar.varOrd := 1;
298 Id.AppendParam(prcSig.formals, thePar);
299 Bi.MkDummyMethodAndInsert("equals", prcSig, Cst.ntvObj, Cst.sysLib, Sy.pubMode, Sy.var, Id.extns);
300 END ObjectFeatures;
301
302 (* ============================================================ *)
303 PROCEDURE (this : JavaAssembler)Assemble*();
304 VAR ix : INTEGER;
305 BEGIN
306 IF asmList.tide > 0 THEN
307 Cst.Message("Jasmin Assmbler no longer supported");
308 Cst.Message("The following jasmin text files were created:");
309 FOR ix := 0 TO asmList.tide-1 DO
310 Console.Write(ASCII.HT);
311 Console.WriteString(asmList.a[ix]^);
312 Console.WriteLn;
313 END;
314 END;
315 END Assemble;
316
317 (* ============================================================ *)
318
319 PROCEDURE (t : JavaEmitter)EmitBody(f : Ju.JavaFile),NEW,ABSTRACT;
320 PROCEDURE^ (e : JavaEmitter)EmitProc(proc : Id.Procs),NEW;
321 PROCEDURE^ (e : JavaEmitter)EmitStat(stat : Sy.Stmt; OUT ok : BOOLEAN),NEW;
322 PROCEDURE^ (e : JavaEmitter)PushCall(callX : Xp.CallX),NEW;
323 PROCEDURE^ (e : JavaEmitter)PushValue(exp : Sy.Expr; typ : Sy.Type),NEW;
324 PROCEDURE^ (e : JavaEmitter)FallFalse(exp : Sy.Expr; tLb : Ju.Label),NEW;
325 PROCEDURE^ (e : JavaEmitter)ValueCopy(act : Sy.Expr; fmT : Sy.Type),NEW;
326 PROCEDURE^ (e : JavaEmitter)PushArg(act : Sy.Expr;
327 frm : Id.ParId;
328 VAR seq : Sy.ExprSeq),NEW;
329
330 (* ============================================================ *)
331
332 PROCEDURE (t : JavaRecEmitter)CopyProc(),NEW;
333 VAR out : Ju.JavaFile;
334 junk : INTEGER;
335 indx : INTEGER;
336 idnt : Sy.Idnt;
337 fTyp : Sy.Type;
338
339 BEGIN
340 (*
341 * Emit the copy procedure "__copy__()
342 *)
343 out := t.outF;
344 out.CopyProcHead(t.recT);
345 junk := out.newLocal(); (* create space for two locals *)
346 junk := out.newLocal();
347 (*
348 * Recurse to super class, if necessary.
349 *)
350 IF (t.recT.baseTp # NIL) &
351 (t.recT.baseTp IS Ty.Record) &
352 ~t.recT.baseTp.isNativeObj() THEN
353 out.Code(Jvm.opc_aload_0);
354 out.Code(Jvm.opc_aload_1);
355 out.ValRecCopy(t.recT.baseTp(Ty.Record));
356 END;
357 (*
358 * Emit field-by-field copy.
359 *)
360 FOR indx := 0 TO t.recT.fields.tide-1 DO
361 idnt := t.recT.fields.a[indx];
362 fTyp := idnt.type;
363 out.Code(Jvm.opc_aload_0);
364 IF (fTyp.kind = Ty.recTp) OR
365 (fTyp.kind = Ty.arrTp) THEN
366 out.PutGetF(Jvm.opc_getfield, t.recT, idnt(Id.FldId));
367 END;
368 out.Code(Jvm.opc_aload_1);
369 out.PutGetF(Jvm.opc_getfield, t.recT, idnt(Id.FldId));
370 WITH fTyp : Ty.Array DO
371 out.ValArrCopy(fTyp);
372 | fTyp : Ty.Record DO
373 out.ValRecCopy(fTyp);
374 ELSE
375 out.PutGetF(Jvm.opc_putfield, t.recT, idnt(Id.FldId));
376 END;
377 END;
378 out.VoidTail();
379 END CopyProc;
380
381 (* ============================================================ *)
382
383 PROCEDURE (this : JavaProcTypeEmitter)EmitBody(out : Ju.JavaFile);
384 (** Create the assembler for a class file for this proc-type wrapper. *)
385 VAR pType : Ty.Procedure; (* The procedure type that is being emitted *)
386 proxy : Ty.Record; (* The record that stands for the proc-type *)
387 invoke : Id.MthId; (* The abstract invoke method for this *)
388 junk : INTEGER;
389 BEGIN
390 pType := this.prcT;
391 proxy := pType.hostClass;
392 proxy.idnt := pType.idnt;
393 proxy.recAtt := Ty.isAbs;
394 out.StartRecClass(proxy);
395
396 (* Emit the no-arg constructor *)
397 out.RecMakeInit(proxy, NIL);
398 out.CallSuperCtor(proxy, NIL);
399 out.VoidTail();
400
401 out.CopyProcHead(proxy);
402 junk := out.newLocal();
403 junk := out.newLocal();
404 out.VoidTail();
405
406 (* Emit the abstract Invoke method *)
407 invoke := Ju.getProcVarInvoke(pType);
408 Ju.MkProcName(invoke);
409 Ju.RenumberLocals(invoke);
410 out.theP := invoke;
411 out.StartProc(invoke);
412 out.EndProc();
413 END EmitBody;
414
415 (* ============================================================ *)
416
417 PROCEDURE (this : JavaRecEmitter)EmitBody(out : Ju.JavaFile);
418 (** Create the assembler for a class file for this record. *)
419 VAR index : INTEGER;
420 parIx : INTEGER;
421 clsId : Sy.Idnt;
422 ident : Sy.Idnt;
423 ctorD : Id.PrcId;
424 sCtor : Id.PrcId;
425 sCtTy : Ty.Procedure;
426 baseT : Sy.Type;
427 field : Id.FldId;
428 method : Id.MthId;
429 record : Ty.Record;
430 impRec : Sy.Idnt;
431 attr : INTEGER;
432 form : Id.ParId;
433 expr : Sy.Expr;
434 live : BOOLEAN;
435 retn : Sy.Type;
436 BEGIN
437 record := this.recT;
438 out.StartRecClass(record);
439 (*
440 * Emit all the fields ...
441 *)
442 out.InitFields(record.fields.tide);
443 FOR index := 0 TO record.fields.tide-1 DO
444 out.EmitField(record.fields.a[index](Id.FldId));
445 END;
446 out.InitMethods(record.methods.tide+2);
447 (*
448 * Emit the no-arg constructor
449 *)
450 IF ~(Sy.noNew IN record.xAttr) &
451 ~(Sy.xCtor IN record.xAttr) THEN
452 out.RecMakeInit(record, NIL);
453 out.CallSuperCtor(record, NIL);
454 out.VoidTail();
455 END;
456 (*
457 * Emit constructors with args
458 *)
459 FOR index := 0 TO record.statics.tide-1 DO
460 sCtTy := NIL;
461 ctorD := record.statics.a[index](Id.PrcId);
462 out.RecMakeInit(record, ctorD);
463 (*
464 * Copy args for super constructors with args.
465 *)
466 IF ctorD # NIL THEN
467 sCtor := ctorD.basCll.sprCtor(Id.PrcId);
468 IF sCtor # NIL THEN
469 sCtTy := sCtor.type(Ty.Procedure);
470 IF sCtTy.xName = NIL THEN Ju.MkCallAttr(sCtor, sCtTy) END;
471 FOR parIx := 0 TO ctorD.basCll.actuals.tide-1 DO
472 form := sCtTy.formals.a[parIx];
473 expr := ctorD.basCll.actuals.a[parIx];
474 this.PushArg(expr, form, ctorD.basCll.actuals);
475 END;
476 END;
477 END;
478 (*
479 * Now call the super constructor
480 *)
481 out.CallSuperCtor(record, sCtTy);
482 IF (ctorD # NIL) & (ctorD.body # NIL) THEN
483 IF ctorD.rescue # NIL THEN out.Try END;
484 this.EmitStat(ctorD.body, live);
485 IF ctorD.rescue # NIL THEN
486 out.Catch(ctorD);
487 this.EmitStat(ctorD.rescue, live);
488 END;
489 END;
490 out.EndProc();
491 END;
492 IF ~(Sy.noCpy IN record.xAttr) THEN this.CopyProc() END;
493 (*
494 * Emit all the (non-forward) methods ...
495 *)
496 FOR index := 0 TO record.methods.tide-1 DO
497 ident := record.methods.a[index];
498 method := ident(Id.MthId);
499 IF method.kind = Id.conMth THEN
500 IF method.scopeNm = NIL THEN
501 Ju.MkProcName(method);
502 Ju.RenumberLocals(method);
503 END;
504 this.EmitProc(method)
505 END;
506 END;
507 END EmitBody;
508
509 (* ============================================================ *)
510
511 PROCEDURE (this : JavaModEmitter)EmitBody(out : Ju.JavaFile);
512 (** Create the assembler for a class file for this module. *)
513 VAR index : INTEGER;
514 objIx : INTEGER;
515 proc : Id.Procs;
516 type : Sy.Type;
517 varId : Id.VarId;
518 returned : BOOLEAN;
519 BEGIN
520 out.StartModClass(this.mod);
521 FOR index := 0 TO this.mod.procs.tide-1 DO
522 (*
523 * Create the mangled name for all non-forward procedures
524 *)
525 proc := this.mod.procs.a[index];
526 IF (proc.kind = Id.conPrc) OR
527 (proc.kind = Id.conMth) THEN
528 Ju.MkProcName(proc);
529 Ju.RenumberLocals(proc);
530 END;
531 END;
532 (*
533 * Do all the fields (ie. static vars)
534 *)
535 out.InitFields(this.mod.locals.tide);
536 FOR index := 0 TO this.mod.locals.tide-1 DO
537 varId := this.mod.locals.a[index](Id.VarId);
538 out.EmitField(varId);
539 END;
540 (*
541 FOR index := 0 TO this.mod.procs.tide-1 DO
542 (*
543 * Create the mangled name for all non-forward procedures
544 *)
545 proc := this.mod.procs.a[index];
546 IF (proc.kind = Id.conPrc) OR
547 (proc.kind = Id.conMth) THEN
548 Ju.MkProcName(proc);
549 Ju.RenumberLocals(proc);
550 END;
551 END;
552 *)
553 (*
554 * Do all the procs, including <init> and <clinit>
555 *)
556 out.InitMethods(this.mod.procs.tide+3);
557 out.ModNoArgInit();
558 out.ClinitHead();
559 out.InitVars(this.mod);
560 IF this.mod.main THEN
561 (*
562 * Emit <clinit>, and module body as main()
563 *)
564 out.VoidTail();
565 out.MainHead();
566 this.EmitStat(this.mod.modBody, returned);
567 IF returned THEN
568 this.EmitStat(this.mod.modClose, returned);
569 END;
570 out.VoidTail();
571 ELSE
572 (*
573 * Emit single <clinit> incorporating module body
574 *)
575 this.EmitStat(this.mod.modBody, returned);
576 out.VoidTail();
577 END;
578 (*
579 * Emit all of the static procedures
580 *)
581 FOR index := 0 TO this.mod.procs.tide-1 DO
582 proc := this.mod.procs.a[index];
583 IF (proc.kind = Id.conPrc) &
584 (proc.dfScp.kind = Id.modId) THEN this.EmitProc(proc) END;
585 END;
586 (*
587 * And now, just in case exported types have been missed ...
588 * For example, if they are unreferenced in this module.
589 *)
590 FOR index := 0 TO this.mod.expRecs.tide-1 DO
591 type := this.mod.expRecs.a[index];
592 IF type.xName = NIL THEN
593 WITH type : Ty.Record DO
594 Ju.MkRecName(type);
595 | type : Ty.Procedure DO
596 Ju.MkProcTypeName(type);
597 END;
598 END;
599 END;
600 END EmitBody;
601
602 (* ============================================================ *)
603
604 PROCEDURE (this : JavaEmitter)Emit*();
605 (** Create the assembler for a class file for this module. *)
606 VAR fileName : FileNames.NameString;
607 cf : ClassUtil.ClassFile;
608 jf : JsmnUtil.JsmnFile;
609 BEGIN
610 (*
611 * Create the classFile structure, and open the output file.
612 * The default for the JVM target is to write a class file
613 * directly. The -jasmin option writes a jasmin output file
614 * but does not call the (now unavailable) assembler.
615 *)
616 IF Cst.doCode & ~Cst.doJsmn THEN
617 WITH this : JavaModEmitter DO
618 L.ToStr(this.mod.xName, fileName);
619 | this : JavaRecEmitter DO
620 L.ToStr(this.recT.xName, fileName);
621 | this : JavaProcTypeEmitter DO
622 L.ToStr(this.prcT.xName, fileName);
623 END;
624 fileName := fileName + ".class";
625 cf := ClassUtil.newClassFile(fileName);
626 this.outF := cf;
627 ELSE
628 WITH this : JavaModEmitter DO
629 Sy.getName.Of(this.mod, fileName);
630 | this : JavaRecEmitter DO
631 FileNames.StripUpToLast("/", this.recT.xName, fileName);
632 | this : JavaProcTypeEmitter DO
633 FileNames.StripUpToLast("/", this.prcT.xName, fileName);
634 END;
635 fileName := fileName + ".j";
636 jf := JsmnUtil.newJsmnFile(fileName);
637 this.outF := jf;
638 (*
639 * Add this file to the list to assemble
640 *)
641 L.AppendCharOpen(asmList, L.strToCharOpen(fileName));
642 END;
643 IF this.outF = NIL THEN
644 CPascalS.SemError.Report(177, 0, 0);
645 Error.WriteString("Cannot create out-file <" + fileName + ">");
646 Error.WriteLn;
647 RETURN;
648 ELSE
649 IF Cst.verbose THEN Cst.Message("Created "+ fileName) END;
650 this.outF.Header(Cst.srcNam);
651 this.EmitBody(this.outF);
652 this.outF.Dump();
653 END;
654 END Emit;
655
656 (* ============================================================ *)
657 (* Shared code-emission methods *)
658 (* ============================================================ *)
659
660 PROCEDURE (e : JavaEmitter)EmitProc(proc : Id.Procs),NEW;
661 VAR out : Ju.JavaFile;
662 live : BOOLEAN;
663 retn : Sy.Type;
664 indx : INTEGER;
665 nest : Id.Procs;
666 procName : FileNames.NameString;
667 BEGIN
668 (*
669 * Recursively emit nested procedures first.
670 *)
671 FOR indx := 0 TO proc.nestPs.tide-1 DO
672 nest := proc.nestPs.a[indx];
673 IF nest.kind = Id.conPrc THEN e.EmitProc(nest) END;
674 END;
675 out := e.outF;
676 out.theP := proc;
677 out.StartProc(proc);
678 (*
679 * Output the body if not ABSTRACT
680 *)
681 IF ~out.isAbstract() THEN
682 (*
683 * Initialize any locals which need this.
684 *)
685 out.InitVars(proc);
686 IF proc.rescue # NIL THEN out.Try END;
687 (*
688 * Finally! Emit the method body.
689 *)
690 e.EmitStat(proc.body, live);
691 (*
692 * For proper procedure which reach the fall-
693 * through ending, copy OUT params and return.
694 *)
695 IF live & proc.type.isProperProcType() THEN
696 out.FixOutPars(proc, retn);
697 out.Return(retn);
698 END;
699 IF proc.rescue # NIL THEN
700 out.Catch(proc);
701 e.EmitStat(proc.rescue, live);
702 IF live & proc.type.isProperProcType() THEN
703 out.FixOutPars(proc, retn);
704 out.Return(retn);
705 END;
706 END;
707 END;
708 out.EndProc();
709 END EmitProc;
710
711 (* ============================================================ *)
712 (* Expression Handling Methods *)
713 (* ============================================================ *)
714
715 PROCEDURE longValue(lit : Sy.Expr) : LONGINT;
716 BEGIN
717 RETURN lit(Xp.LeafX).value.long();
718 END longValue;
719
720 PROCEDURE intValue(lit : Sy.Expr) : INTEGER;
721 BEGIN
722 RETURN lit(Xp.LeafX).value.int();
723 END intValue;
724
725 PROCEDURE isStrExp(exp : Sy.Expr) : BOOLEAN;
726 BEGIN
727 RETURN (exp.type = Bi.strTp) &
728 (exp.kind # Xp.mkStr) OR
729 exp.type.isNativeStr();
730 END isStrExp;
731
732 (* ============================================================ *)
733
734 PROCEDURE (e : JavaEmitter)UbyteClear(),NEW;
735 VAR out : Ju.JavaFile;
736 BEGIN
737 out := e.outF;
738 out.PushInt(255);
739 out.Code(Jvm.opc_iand);
740 END UbyteClear;
741
742 (* ============================================================ *)
743
744 PROCEDURE (e : JavaEmitter)newLeaf(rd : INTEGER; tp : Sy.Type) : Xp.IdLeaf,NEW;
745 VAR id : Id.LocId;
746 BEGIN
747 id := Id.newLocId();
748 id.varOrd := rd;
749 id.type := tp;
750 id.dfScp := e.outF.getScope();
751 RETURN Xp.mkIdLeaf(id);
752 END newLeaf;
753
754 (* ============================================================ *)
755
756 PROCEDURE RevTest(tst : INTEGER) : INTEGER;
757 BEGIN
758 CASE tst OF
759 | Xp.equal : RETURN Xp.notEq;
760 | Xp.notEq : RETURN Xp.equal;
761 | Xp.greT : RETURN Xp.lessEq;
762 | Xp.lessT : RETURN Xp.greEq;
763 | Xp.greEq : RETURN Xp.lessT;
764 | Xp.lessEq : RETURN Xp.greT;
765 END;
766 END RevTest;
767
768 (* ============================================================ *)
769
770 PROCEDURE (e : JavaEmitter)DoCmp(cmpE : INTEGER;
771 tLab : Ju.Label;
772 type : Sy.Type),NEW;
773 (** Compare two TOS elems and jump to tLab if true. *)
774 (* ------------------------------------------------- *)
775 VAR out : Ju.JavaFile;
776 code : INTEGER;
777 tNum : INTEGER;
778 (* ------------------------------------------------- *)
779 PROCEDURE test(t : INTEGER) : INTEGER;
780 BEGIN
781 CASE t OF
782 | Xp.greT : RETURN Jvm.opc_ifgt;
783 | Xp.greEq : RETURN Jvm.opc_ifge;
784 | Xp.notEq : RETURN Jvm.opc_ifne;
785 | Xp.lessEq : RETURN Jvm.opc_ifle;
786 | Xp.lessT : RETURN Jvm.opc_iflt;
787 | Xp.equal : RETURN Jvm.opc_ifeq;
788 END;
789 END test;
790 (* ------------------------------------------------- *)
791 BEGIN
792 out := e.outF;
793 code := test(cmpE); (* default code *)
794 WITH type : Ty.Base DO
795 tNum := type.tpOrd;
796 CASE tNum OF
797 | Ty.strN, Ty.sStrN : out.CallRTS(Ju.StrCmp,2,1);
798 | Ty.realN : out.Code(Jvm.opc_dcmpl);
799 | Ty.sReaN : out.Code(Jvm.opc_fcmpl);
800 | Ty.lIntN : out.Code(Jvm.opc_lcmp);
801 | Ty.anyRec, Ty.anyPtr :
802 CASE cmpE OF
803 | Xp.notEq : code := Jvm.opc_if_acmpne;
804 | Xp.equal : code := Jvm.opc_if_acmpeq;
805 END;
806 ELSE (* Ty.boolN,Ty.sChrN,Ty.charN,Ty.byteN,Ty.sIntN,Ty.intN,Ty.setN *)
807 CASE cmpE OF
808 | Xp.greT : code := Jvm.opc_if_icmpgt; (* override default code *)
809 | Xp.greEq : code := Jvm.opc_if_icmpge;
810 | Xp.notEq : code := Jvm.opc_if_icmpne;
811 | Xp.lessEq : code := Jvm.opc_if_icmple;
812 | Xp.lessT : code := Jvm.opc_if_icmplt;
813 | Xp.equal : code := Jvm.opc_if_icmpeq;
814 END;
815 END;
816 ELSE (* This must be a reference or string comparison *)
817 IF type.isCharArrayType() THEN out.CallRTS(Ju.StrCmp,2,1);
818 ELSIF cmpE = Xp.equal THEN code := Jvm.opc_if_acmpeq;
819 ELSIF cmpE = Xp.notEq THEN code := Jvm.opc_if_acmpne;
820 END;
821 END;
822 out.CodeLb(code, tLab);
823 END DoCmp;
824
825 (* ================= old code =========================== *
826 * IF type IS Ty.Base THEN
827 * tNum := type(Ty.Base).tpOrd;
828 * IF (tNum = Ty.strN) OR (tNum = Ty.sStrN) THEN
829 * out.CallRTS(Ju.StrCmp,2,1);
830 * ELSIF tNum = Ty.realN THEN
831 * out.Code(Jvm.opc_dcmpl);
832 * ELSIF tNum = Ty.sReaN THEN
833 * out.Code(Jvm.opc_fcmpl);
834 * ELSIF tNum = Ty.lIntN THEN
835 * out.Code(Jvm.opc_lcmp);
836 * ELSE (* Common, integer cases use separate instructions *)
837 * CASE cmpE OF
838 * | Xp.greT : code := Jvm.opc_if_icmpgt; (* override default *)
839 * | Xp.greEq : code := Jvm.opc_if_icmpge;
840 * | Xp.notEq : code := Jvm.opc_if_icmpne;
841 * | Xp.lessEq : code := Jvm.opc_if_icmple;
842 * | Xp.lessT : code := Jvm.opc_if_icmplt;
843 * | Xp.equal : code := Jvm.opc_if_icmpeq;
844 * END;
845 * END;
846 * ELSE (* This must be a reference or string comparison *)
847 * IF type.isCharArrayType() THEN
848 * out.CallRTS(Ju.StrCmp,2,1);
849 * ELSIF cmpE = Xp.equal THEN
850 * code := Jvm.opc_if_acmpeq;
851 * ELSIF cmpE = Xp.notEq THEN
852 * code := Jvm.opc_if_acmpne;
853 * END;
854 * END;
855 * out.CodeLb(code, tLab);
856 *END DoCmp;
857 * ================= old code =========================== *)
858
859 (* ---------------------------------------------------- *)
860
861 PROCEDURE (e : JavaEmitter)SetCmp(lOp,rOp : Sy.Expr;
862 theLabl : Ju.Label;
863 theTest : INTEGER),NEW;
864 VAR out : Ju.JavaFile;
865 l,r : INTEGER;
866 xit : Ju.Label;
867 BEGIN
868 out := e.outF;
869 e.PushValue(lOp, Bi.setTp);
870 CASE theTest OF
871 (* ---------------------------------- *)
872 | Xp.equal:
873 e.PushValue(rOp, Bi.setTp);
874 out.CodeLb(Jvm.opc_if_icmpeq, theLabl);
875 (* ---------------------------------- *)
876 | Xp.notEq :
877 e.PushValue(rOp, Bi.setTp);
878 out.CodeLb(Jvm.opc_if_icmpne, theLabl);
879 (* ---------------------------------- *)
880 | Xp.greEq, Xp.lessEq :
881 (*
882 * The semantics are implemented by the identities
883 *
884 * (L <= R) == (L AND R = L)
885 * (L >= R) == (L OR R = L)
886 *)
887 out.Code(Jvm.opc_dup);
888 e.PushValue(rOp, Bi.setTp);
889 IF theTest = Xp.greEq THEN
890 out.Code(Jvm.opc_ior);
891 ELSE
892 out.Code(Jvm.opc_iand);
893 END;
894 out.CodeLb(Jvm.opc_if_icmpeq, theLabl);
895 (* ---------------------------------- *)
896 | Xp.greT, Xp.lessT :
897 (*
898 * The semantics are implemented by the identities
899 *
900 * (L < R) == (L AND R = L) AND NOT (L = R)
901 * (L > R) == (L OR R = L) AND NOT (L = R)
902 *)
903 l := out.newLocal();
904 r := out.newLocal();
905 xit := out.newLabel();
906 out.Code(Jvm.opc_dup); (* ... L,L *)
907 out.Code(Jvm.opc_dup); (* ... L,L,L *)
908 out.StoreLocal(l, Bi.setTp); (* ... L,L, *)
909 e.PushValue(rOp, Bi.setTp); (* ... L,L,R *)
910 out.Code(Jvm.opc_dup); (* ... L,L,R,R *)
911 out.StoreLocal(r, Bi.setTp); (* ... L,L,R *)
912 IF theTest = Xp.greT THEN
913 out.Code(Jvm.opc_ior); (* ... L,LvR *)
914 ELSE
915 out.Code(Jvm.opc_iand); (* ... L,L^R *)
916 END;
917 out.CodeLb(Jvm.opc_if_icmpne, xit);
918 out.LoadLocal(l, Bi.setTp); (* ... L@R,l *)
919 out.LoadLocal(r, Bi.setTp); (* ... L@R,l,r *)
920 out.CodeLb(Jvm.opc_if_icmpne, theLabl);
921 out.ReleaseLocal(r);
922 out.ReleaseLocal(l);
923 out.DefLab(xit);
924 END;
925 END SetCmp;
926
927 (* ---------------------------------------------------- *)
928
929 PROCEDURE (e : JavaEmitter)BinCmp(exp : Sy.Expr;
930 tst : INTEGER;
931 rev : BOOLEAN; (* reverse sense *)
932 lab : Ju.Label),NEW;
933 VAR binOp : Xp.BinaryX;
934 lType : Sy.Type;
935 BEGIN
936 binOp := exp(Xp.BinaryX);
937 lType := binOp.lKid.type;
938 IF rev THEN tst := RevTest(tst) END;
939 IF lType = Bi.setTp THEN (* only partially ordered *)
940 e.SetCmp(binOp.lKid, binOp.rKid, lab, tst);
941 ELSE (* a totally ordered type *)
942 e.PushValue(binOp.lKid, lType);
943 IF isStrExp(binOp.lKid) THEN
944 e.outF.CallRTS(Ju.StrToChrOpen,1,1);
945 END;
946 e.PushValue(binOp.rKid, binOp.rKid.type);
947 IF isStrExp(binOp.rKid) THEN
948 e.outF.CallRTS(Ju.StrToChrOpen,1,1);
949 END;
950 e.DoCmp(tst, lab, lType);
951 END;
952 END BinCmp;
953
954 (* ---------------------------------------------------- *)
955
956 PROCEDURE (e : JavaEmitter)FallTrue(exp : Sy.Expr; fLb : Ju.Label),NEW;
957 (** Evaluate exp, fall through if true, jump to fLab otherwise *)
958 VAR binOp : Xp.BinaryX;
959 label : Ju.Label;
960 out : Ju.JavaFile;
961 BEGIN
962 out := e.outF;
963 CASE exp.kind OF
964 | Xp.tBool : (* just do nothing *)
965 | Xp.fBool :
966 out.CodeLb(Jvm.opc_goto, fLb);
967 | Xp.blNot :
968 e.FallFalse(exp(Xp.UnaryX).kid, fLb);
969 | Xp.greT, Xp.greEq, Xp.notEq, Xp.lessEq, Xp.lessT, Xp.equal :
970 e.BinCmp(exp, exp.kind, TRUE, fLb);
971 | Xp.blOr :
972 binOp := exp(Xp.BinaryX);
973 label := out.newLabel();
974 e.FallFalse(binOp.lKid, label);
975 e.FallTrue(binOp.rKid, fLb);
976 out.DefLab(label);
977 | Xp.blAnd :
978 binOp := exp(Xp.BinaryX);
979 e.FallTrue(binOp.lKid, fLb);
980 e.FallTrue(binOp.rKid, fLb);
981 | Xp.isOp :
982 binOp := exp(Xp.BinaryX);
983 e.PushValue(binOp.lKid, binOp.lKid.type);
984 out.CodeT(Jvm.opc_instanceof, binOp.rKid(Xp.IdLeaf).ident.type);
985 out.CodeLb(Jvm.opc_ifeq, fLb);
986 | Xp.inOp :
987 binOp := exp(Xp.BinaryX);
988 out.Code(Jvm.opc_iconst_1);
989 e.PushValue(binOp.lKid, binOp.lKid.type);
990 out.Code(Jvm.opc_ishl);
991 out.Code(Jvm.opc_dup);
992 e.PushValue(binOp.rKid, binOp.rKid.type);
993 out.Code(Jvm.opc_iand);
994 out.CodeLb(Jvm.opc_if_icmpne, fLb);
995 ELSE (* Xp.fnCll, Xp.qualId, Xp.index, Xp.selct *)
996 e.PushValue(exp, exp.type); (* boolean variable *)
997 out.CodeLb(Jvm.opc_ifeq, fLb);
998 END;
999 END FallTrue;
1000
1001 (* ---------------------------------------------------- *)
1002
1003 PROCEDURE (e : JavaEmitter)FallFalse(exp : Sy.Expr; tLb : Ju.Label),NEW;
1004 (** Evaluate exp, fall through if false, jump to tLb otherwise *)
1005 VAR binOp : Xp.BinaryX;
1006 label : Ju.Label;
1007 out : Ju.JavaFile;
1008 BEGIN
1009 out := e.outF;
1010 CASE exp.kind OF
1011 | Xp.fBool : (* just do nothing *)
1012 | Xp.tBool :
1013 out.CodeLb(Jvm.opc_goto, tLb);
1014 | Xp.blNot :
1015 e.FallTrue(exp(Xp.UnaryX).kid, tLb);
1016 | Xp.greT, Xp.greEq, Xp.notEq, Xp.lessEq, Xp.lessT, Xp.equal :
1017 e.BinCmp(exp, exp.kind, FALSE, tLb);
1018 | Xp.blOr :
1019 binOp := exp(Xp.BinaryX);
1020 e.FallFalse(binOp.lKid, tLb);
1021 e.FallFalse(binOp.rKid, tLb);
1022 | Xp.blAnd :
1023 label := out.newLabel();
1024 binOp := exp(Xp.BinaryX);
1025 e.FallTrue(binOp.lKid, label);
1026 e.FallFalse(binOp.rKid, tLb);
1027 out.DefLab(label);
1028 | Xp.isOp :
1029 binOp := exp(Xp.BinaryX);
1030 e.PushValue(binOp.lKid, binOp.lKid.type);
1031 out.CodeT(Jvm.opc_instanceof, binOp.rKid(Xp.IdLeaf).ident.type);
1032 out.CodeLb(Jvm.opc_ifne, tLb);
1033 | Xp.inOp :
1034 binOp := exp(Xp.BinaryX);
1035 out.Code(Jvm.opc_iconst_1);
1036 e.PushValue(binOp.lKid, binOp.lKid.type);
1037 out.Code(Jvm.opc_ishl);
1038 out.Code(Jvm.opc_dup);
1039 e.PushValue(binOp.rKid, binOp.rKid.type);
1040 out.Code(Jvm.opc_iand);
1041 out.CodeLb(Jvm.opc_if_icmpeq, tLb);
1042 ELSE (* Xp.fnCll, Xp.qualId, Xp.index, Xp.selct *)
1043 e.PushValue(exp, exp.type); (* boolean variable *)
1044 out.CodeLb(Jvm.opc_ifne, tLb);
1045 END;
1046 END FallFalse;
1047
1048 (* ============================================================ *)
1049
1050 PROCEDURE (e : JavaEmitter)PushUnary(exp : Xp.UnaryX; dst : Sy.Type),NEW;
1051 VAR dNum : INTEGER;
1052 code : INTEGER;
1053 labl : Ju.Label;
1054 out : Ju.JavaFile;
1055 (* ------------------------------------- *)
1056 PROCEDURE MkBox(emt : JavaEmitter; exp : Xp.UnaryX);
1057 VAR dst : Sy.Type;
1058 src : Sy.Type;
1059 out : Ju.JavaFile;
1060 BEGIN
1061 out := emt.outF;
1062 src := exp.kid.type;
1063 dst := exp.type(Ty.Pointer).boundTp;
1064 IF isStrExp(exp.kid) THEN
1065 emt.PushValue(exp.kid, src);
1066 out.CallRTS(Ju.StrToChrOpen,1,1);
1067 ELSE
1068 emt.ValueCopy(exp.kid, dst);
1069 END;
1070 END MkBox;
1071 (* ------------------------------------- *)
1072 BEGIN
1073 IF exp.kind = Xp.mkBox THEN MkBox(e,exp); RETURN END; (* PRE-EMPTIVE RET *)
1074 e.PushValue(exp.kid, exp.kid.type);
1075 out := e.outF;
1076 CASE exp.kind OF
1077 | Xp.mkStr, Xp.deref : (* skip *)
1078 | Xp.tCheck :
1079 out.CodeT(Jvm.opc_checkcast, exp.type.boundRecTp()(Ty.Record));
1080 | Xp.mkNStr :
1081 IF ~isStrExp(exp.kid) THEN
1082 out.CallRTS(Ju.ChrsToStr,1,1);
1083 END;
1084 | Xp.strChk : (* Some range checks required *)
1085 out.Code(Jvm.opc_dup);
1086 out.CallRTS(Ju.StrCheck,1,0);
1087 | Xp.compl :
1088 out.Code(Jvm.opc_iconst_m1);
1089 out.Code(Jvm.opc_ixor);
1090 | Xp.neg :
1091 dNum := dst(Ty.Base).tpOrd;
1092 IF dNum = Ty.realN THEN
1093 code := Jvm.opc_dneg;
1094 ELSIF dNum = Ty.sReaN THEN
1095 code := Jvm.opc_fneg;
1096 ELSIF dNum = Ty.lIntN THEN
1097 code := Jvm.opc_lneg;
1098 ELSE (* all INTEGER cases *)
1099 code := Jvm.opc_ineg;
1100 END;
1101 out.Code(code);
1102 | Xp.absVl :
1103 dNum := dst(Ty.Base).tpOrd;
1104 IF dNum = Ty.realN THEN
1105 out.Code(Jvm.opc_dup2);
1106 out.Code(Jvm.opc_dconst_0);
1107 out.Code(Jvm.opc_dcmpg);
1108 code := Jvm.opc_dneg;
1109 ELSIF dNum = Ty.sReaN THEN
1110 out.Code(Jvm.opc_dup);
1111 out.Code(Jvm.opc_fconst_0);
1112 out.Code(Jvm.opc_fcmpg);
1113 code := Jvm.opc_fneg;
1114 ELSIF dNum = Ty.lIntN THEN
1115 out.Code(Jvm.opc_dup2);
1116 out.Code(Jvm.opc_lconst_0);
1117 out.Code(Jvm.opc_lcmp);
1118 code := Jvm.opc_lneg;
1119 ELSE (* all INTEGER cases *)
1120 out.Code(Jvm.opc_dup);
1121 code := Jvm.opc_ineg;
1122 END;
1123 labl := out.newLabel();
1124 out.CodeLb(Jvm.opc_ifge, labl); (* NOT ifle, Aug2001 *)
1125 out.Code(code);
1126 out.DefLab(labl);
1127 | Xp.entVl :
1128 dNum := dst(Ty.Base).tpOrd;
1129 IF dNum = Ty.sReaN THEN out.Code(Jvm.opc_f2d) END;
1130 (*
1131 // We _could_ check if the value is >= 0.0, and
1132 // skip the call in that case, falling through
1133 // into the round-to-zero mode opc_d2l.
1134 *)
1135 out.CallRTS(Ju.DFloor,1,1);
1136 out.Code(Jvm.opc_d2l);
1137 | Xp.capCh :
1138 out.CallRTS(Ju.ToUpper,1,1);
1139 | Xp.blNot :
1140 out.Code(Jvm.opc_iconst_1);
1141 out.Code(Jvm.opc_ixor);
1142 | Xp.strLen :
1143 out.CallRTS(Ju.StrLen,1,1);
1144 | Xp.oddTst :
1145 IF exp.kid.type.isLongType() THEN out.Code(Jvm.opc_l2i) END;
1146 out.Code(Jvm.opc_iconst_1);
1147 out.Code(Jvm.opc_iand);
1148 | Xp.getTp :
1149 out.CallGetClass();
1150 END;
1151 END PushUnary;
1152
1153 (* ============================================================ *)
1154
1155 PROCEDURE (e : JavaEmitter)PushVecElemHandle(lOp,rOp : Sy.Expr),NEW;
1156 VAR vTp : Ty.Vector;
1157 eTp : Sy.Type;
1158 tde : INTEGER;
1159 out : Ju.JavaFile;
1160 xLb : Ju.Label;
1161 BEGIN
1162 out := e.outF;
1163 vTp := lOp.type(Ty.Vector);
1164 eTp := vTp.elemTp;
1165 tde := out.newLocal();
1166 xLb := out.newLabel();
1167
1168 e.PushValue(lOp, eTp); (* vRef ... *)
1169 out.Code(Jvm.opc_dup); (* vRef, vRef ... *)
1170 out.GetVecLen(); (* tide, vRef ... *)
1171 out.StoreLocal(tde, Bi.intTp); (* vRef ... *)
1172
1173 e.outF.GetVecArr(eTp); (* arr ... *)
1174 e.PushValue(rOp, Bi.intTp); (* idx, arr ... *)
1175 out.Code(Jvm.opc_dup); (* idx, idx, arr ... *)
1176 out.LoadLocal(tde, Bi.intTp); (* tide, idx, idx, arr ... *)
1177
1178 out.CodeLb(Jvm.opc_if_icmplt, xLb);
1179 out.Trap("Vector index out of bounds");
1180
1181 out.DefLab(xLb); (* idx, arr ... *)
1182 out.ReleaseLocal(tde);
1183 END PushVecElemHandle;
1184
1185 (* ============================================================ *)
1186
1187 (* Assert: lOp is already pushed. *)
1188 PROCEDURE ShiftInt(kind : INTEGER; e : JavaEmitter; lOp : Sy.Expr; rOp : Sy.Expr);
1189 VAR indx : INTEGER;
1190 out : Ju.JavaFile;
1191 shrLab, fixLab, s31Lab, exitLb : Ju.Label;
1192 BEGIN
1193 out := e.outF;
1194 IF rOp.kind = Xp.numLt THEN
1195 indx := intValue(rOp);
1196 IF indx = 0 THEN (* skip *)
1197 ELSIF indx < -31 THEN (* right shift out *)
1198 IF kind = Xp.ashInt THEN
1199 out.PushInt(31);
1200 out.Code(Jvm.opc_ishr);
1201 ELSE
1202 out.Code(Jvm.opc_pop);
1203 out.PushInt(0);
1204 END;
1205 ELSIF indx < 0 THEN (* right shift *)
1206 out.PushInt(-indx);
1207 IF kind = Xp.ashInt THEN (* arith shift *)
1208 out.Code(Jvm.opc_ishr);
1209 ELSE (* logical shift *)
1210 out.Code(Jvm.opc_iushr);
1211 END;
1212 ELSIF indx > 31 THEN (* result is zero *)
1213 out.Code(Jvm.opc_pop);
1214 out.PushInt(0);
1215 ELSE (* a left shift *)
1216 out.PushInt(indx);
1217 out.Code(Jvm.opc_ishl);
1218 END;
1219 ELSE (* variable sized shift *)
1220 shrLab := out.newLabel();
1221 fixLab := out.newLabel();
1222 s31Lab := out.newLabel();
1223 exitLb := out.newLabel();
1224 (*
1225 * This is a variable shift. Do it the hard way.
1226 * First, check the sign of the right hand op.
1227 *)
1228 e.PushValue(rOp, Bi.intTp); (* TOS: rOp, lOp, ... *)
1229 out.Code(Jvm.opc_dup); (* TOS: rOp, rOp, lOp, ... *)
1230 out.CodeLb(Jvm.opc_iflt, shrLab); (* TOS: rOp, lOp, ... *)
1231 (*
1232 * Positive selector ==> shift left;
1233 * But first: a range check ...
1234 *)
1235 out.Code(Jvm.opc_dup); (* TOS: rOp, rOp, lOp, ... *)
1236 out.PushInt(31); (* TOS: 31, rOp, rOp, lOp, ... *)
1237 out.CodeLb(Jvm.opc_if_icmpgt, fixLab); (* TOS: rOp, lOp, ... *)
1238 out.Code(Jvm.opc_ishl); (* TOS: rslt, ... *)
1239 out.CodeLb(Jvm.opc_goto, exitLb);
1240 (*
1241 * Out of range shift, set result to zero.
1242 *)
1243 out.DefLab(fixLab); (* TOS: rOp, lOp, ... *)
1244 out.Code(Jvm.opc_pop2); (* TOS: ... *)
1245 out.PushInt(0); (* TOS: 0, ... *)
1246 out.CodeLb(Jvm.opc_goto, exitLb);
1247 (*
1248 * Out of range, rslt = rOp >> 31.
1249 *)
1250 out.DefLab(s31Lab); (* TOS: rOp, lOp, ... *)
1251 out.Code(Jvm.opc_pop); (* TOS: lOp, ... *)
1252 out.PushInt(31); (* TOS: 31, lOp, ... *)
1253 out.Code(Jvm.opc_ishr);
1254 out.CodeLb(Jvm.opc_goto, exitLb);
1255 (*
1256 * Negative selector ==> shift right;
1257 *)
1258 out.DefLab(shrLab); (* TOS: rOp, lOp, ... *)
1259 out.Code(Jvm.opc_ineg); (* TOS: -rOp, lOp, ... *)
1260 out.Code(Jvm.opc_dup); (* TOS: -rOp, -rOp, lOp, ... *)
1261 out.PushInt(31); (* TOS: 31, -rOp, -rOp, lOp, ...*)
1262 IF kind = Xp.lshInt THEN (* LSH *)
1263 out.CodeLb(Jvm.opc_if_icmpgt, fixLab); (* TOS: -rOp, lOp, ... *)
1264 out.Code(Jvm.opc_iushr); (* TOS: rslt, ... *)
1265 ELSE (* ASH *) (* TOS: 31, rOp, rOp, lOp, ... *)
1266 out.CodeLb(Jvm.opc_if_icmpgt, s31Lab); (* TOS: rOp, lOp, ... *)
1267 out.Code(Jvm.opc_ishr); (* TOS: rslt, ... *)
1268 END;
1269 out.DefLab(exitLb);
1270 END;
1271 END ShiftInt;
1272
1273 (* ============================================================ *)
1274
1275 (* Assert: lOp is already pushed. *)
1276 PROCEDURE ShiftLong(kind : INTEGER; e : JavaEmitter; lOp : Sy.Expr; rOp : Sy.Expr);
1277 VAR indx : INTEGER;
1278 out : Ju.JavaFile;
1279 shrLab, fixLab, s63Lab, exitLb : Ju.Label;
1280 BEGIN
1281 out := e.outF;
1282 IF rOp.kind = Xp.numLt THEN
1283 indx := intValue(rOp);
1284 IF indx = 0 THEN (* skip *)
1285 ELSIF indx < -63 THEN (* right shift out *)
1286 IF kind = Xp.ashInt THEN
1287 out.PushInt(63);
1288 out.Code(Jvm.opc_lshr);
1289 ELSE
1290 out.Code(Jvm.opc_pop2);
1291 out.PushLong(0);
1292 END;
1293 ELSIF indx < 0 THEN (* right shift *)
1294 out.PushInt(-indx);
1295 IF kind = Xp.ashInt THEN (* arith shift *)
1296 out.Code(Jvm.opc_lshr);
1297 ELSE (* logical shift *)
1298 out.Code(Jvm.opc_lushr);
1299 END;
1300 ELSIF indx > 63 THEN (* result is zero *)
1301 out.Code(Jvm.opc_pop2);
1302 out.PushLong(0);
1303 ELSE (* a left shift *)
1304 out.PushInt(indx);
1305 out.Code(Jvm.opc_lshl);
1306 END;
1307 ELSE (* variable sized shift *)
1308 shrLab := out.newLabel();
1309 fixLab := out.newLabel();
1310 s63Lab := out.newLabel();
1311 exitLb := out.newLabel();
1312 (*
1313 * This is a variable shift. Do it the hard way.
1314 * First, check the sign of the right hand op.
1315 *)
1316 e.PushValue(rOp, Bi.intTp); (* TOS: rOp, lOp, ... *)
1317 out.Code(Jvm.opc_dup); (* TOS: rOp, rOp, lOp, ... *)
1318 out.CodeLb(Jvm.opc_iflt, shrLab); (* TOS: rOp, lOp, ... *)
1319 (*
1320 * Positive selector ==> shift left;
1321 * But first: a range check ...
1322 *)
1323 out.Code(Jvm.opc_dup); (* TOS: rOp, rOp, lOp, ... *)
1324 out.PushInt(63); (* TOS: 63, rOp, rOp, lOp, ... *)
1325 out.CodeLb(Jvm.opc_if_icmpgt, fixLab); (* TOS: rOp, lOp, ... *)
1326 out.Code(Jvm.opc_lshl); (* TOS: rslt, ... *)
1327 out.CodeLb(Jvm.opc_goto, exitLb);
1328 (*
1329 * Out of range shift, set result to zero.
1330 *)
1331 out.DefLab(fixLab); (* TOS: rOp, lOp, ... *)
1332 out.Code(Jvm.opc_pop); (* TOS: lOp, ... *)
1333 out.Code(Jvm.opc_pop2); (* TOS: ... *)
1334 out.PushLong(0); (* TOS: 0, ... *)
1335 out.CodeLb(Jvm.opc_goto, exitLb);
1336 (*
1337 * Out of range, rslt = rOp >> 63.
1338 *)
1339 out.DefLab(s63Lab); (* TOS: rOp, lOp, ... *)
1340 out.Code(Jvm.opc_pop); (* TOS: lOp, ... *)
1341 out.PushInt(63); (* TOS: 63, lOp, ... *)
1342 out.Code(Jvm.opc_lshr);
1343 out.CodeLb(Jvm.opc_goto, exitLb);
1344 (*
1345 * Negative selector ==> shift right;
1346 *)
1347 out.DefLab(shrLab); (* TOS: rOp, lOp, ... *)
1348 out.Code(Jvm.opc_ineg); (* TOS: -rOp, lOp, ... *)
1349 out.Code(Jvm.opc_dup); (* TOS: -rOp, -rOp, lOp, ... *)
1350 out.PushInt(63); (* TOS: 63, -rOp, -rOp, lOp, ...*)
1351 IF kind = Xp.lshInt THEN (* LSH *)
1352 out.CodeLb(Jvm.opc_if_icmpgt, fixLab); (* TOS: -rOp, lOp, ... *)
1353 out.Code(Jvm.opc_lushr); (* TOS: rslt, ... *)
1354 ELSE (* ASH *) (* TOS: 31, rOp, rOp, lOp, ... *)
1355 out.CodeLb(Jvm.opc_if_icmpgt, s63Lab); (* TOS: rOp, lOp, ... *)
1356 out.Code(Jvm.opc_lshr); (* TOS: rslt, ... *)
1357 END;
1358 out.DefLab(exitLb);
1359 END;
1360 END ShiftLong;
1361
1362 (* ============================================================ *)
1363 (* Assert: lOp is already pushed. *)
1364 PROCEDURE RotateInt(e : JavaEmitter; lOp : Sy.Expr; rOp : Sy.Expr);
1365 VAR
1366 temp, ixSv : INTEGER; (* local vars *)
1367 indx : INTEGER; (* literal index *)
1368 rtSz : INTEGER;
1369 out : Ju.JavaFile;
1370 BEGIN
1371 out := e.outF;
1372 IF lOp.type = Bi.sIntTp THEN
1373 rtSz := 16;
1374 out.ConvertDn(Bi.intTp, Bi.charTp);
1375 ELSIF (lOp.type = Bi.byteTp) OR (lOp.type = Bi.uBytTp) THEN
1376 rtSz := 8;
1377 out.ConvertDn(Bi.intTp, Bi.uBytTp);
1378 ELSE
1379 rtSz := 32;
1380 END;
1381 temp := out.newLocal();
1382 IF rOp.kind = Xp.numLt THEN
1383 indx := intValue(rOp) MOD rtSz;
1384 IF indx = 0 THEN (* skip *)
1385 ELSE (*
1386 * Rotation is achieved by means of the identity
1387 * Forall 0 <= n < rtSz:
1388 * ROT(a, n) = LSH(a,n) bitwiseOR LSH(a,n-rtSz);
1389 *)
1390 out.Code(Jvm.opc_dup);
1391 out.StoreLocal(temp, Bi.intTp);
1392 out.PushInt(indx);
1393 out.Code(Jvm.opc_ishl);
1394 out.LoadLocal(temp, Bi.intTp);
1395 out.PushInt(rtSz - indx);
1396 out.Code(Jvm.opc_iushr);
1397 out.Code(Jvm.opc_ior);
1398 out.ConvertDn(Bi.intTp, lOp.type);
1399 END;
1400 ELSE
1401 ixSv := out.newLocal();
1402 out.Code(Jvm.opc_dup); (* TOS: lOp, lOp, ... *)
1403 out.StoreLocal(temp, Bi.intTp); (* TOS: lOp, ... *)
1404 e.PushValue(rOp, rOp.type); (* TOS: rOp, lOp, ... *)
1405 out.PushInt(rtSz-1); (* TOS: 31, rOp, lOp, ... *)
1406 out.Code(Jvm.opc_iand); (* TOS: rOp', lOp, ... *)
1407 out.Code(Jvm.opc_dup); (* TOS: rOp', rOp', lOp, ... *)
1408 out.StoreLocal(ixSv, Bi.intTp); (* TOS: rOp', lOp, ... *)
1409 out.Code(Jvm.opc_ishl); (* TOS: lRz, ... *)
1410 out.LoadLocal(temp, Bi.intTp); (* TOS: lOp, lRz, ... *)
1411 out.PushInt(rtSz); (* TOS: 32, lOp, lRz, ... *)
1412 out.LoadLocal(ixSv, Bi.intTp); (* TOS: rOp',32, lOp, lRz, ... *)
1413 out.Code(Jvm.opc_isub); (* TOS: rOp'', lOp, lRz, ... *)
1414 out.Code(Jvm.opc_iushr); (* TOS: rRz, lRz, ... *)
1415 out.Code(Jvm.opc_ior); (* TOS: ROT(lOp, rOp), ... *)
1416 out.ReleaseLocal(ixSv);
1417 out.ConvertDn(Bi.intTp, lOp.type);
1418 END;
1419 out.ReleaseLocal(temp);
1420 END RotateInt;
1421
1422 (* ============================================================ *)
1423
1424 (* Assert: lOp is already pushed. *)
1425 PROCEDURE RotateLong(e : JavaEmitter; lOp : Sy.Expr; rOp : Sy.Expr);
1426 VAR
1427 tmp1,tmp2, ixSv : INTEGER; (* local vars *)
1428 indx : INTEGER; (* literal index *)
1429 out : Ju.JavaFile;
1430 BEGIN
1431 out := e.outF;
1432 tmp1 := out.newLocal(); (* Pair of locals *)
1433 tmp2 := out.newLocal();
1434 IF rOp.kind = Xp.numLt THEN
1435 indx := intValue(rOp) MOD 64;
1436 IF indx = 0 THEN (* skip *)
1437 ELSE (*
1438 * Rotation is achieved by means of the identity
1439 * Forall 0 <= n < rtSz:
1440 * ROT(a, n) = LSH(a,n) bitwiseOR LSH(a,n-rtSz);
1441 *)
1442 out.Code(Jvm.opc_dup2);
1443 out.StoreLocal(tmp1, Bi.lIntTp);
1444 out.PushInt(indx);
1445 out.Code(Jvm.opc_lshl);
1446 out.LoadLocal(tmp1, Bi.lIntTp);
1447 out.PushInt(64 - indx);
1448 out.Code(Jvm.opc_lushr);
1449 out.Code(Jvm.opc_lor);
1450 END;
1451 ELSE
1452 ixSv := out.newLocal();
1453 out.Code(Jvm.opc_dup2); (* TOS: lOp, lOp, ... *)
1454 out.StoreLocal(tmp1, Bi.lIntTp); (* TOS: lOp, ... *)
1455 e.PushValue(rOp, rOp.type); (* TOS: rOp, lOp, ... *)
1456 out.PushInt(63); (* TOS: 31, rOp, lOp, ... *)
1457 out.Code(Jvm.opc_iand); (* TOS: rOp', lOp, ... *)
1458 out.Code(Jvm.opc_dup); (* TOS: rOp', rOp', lOp, ... *)
1459 out.StoreLocal(ixSv, Bi.intTp); (* TOS: rOp', lOp, ... *)
1460 out.Code(Jvm.opc_lshl); (* TOS: lRz, ... *)
1461 out.LoadLocal(tmp1, Bi.lIntTp); (* TOS: lOp, lRz, ... *)
1462 out.PushInt(64); (* TOS: 32, lOp, lRz, ... *)
1463 out.LoadLocal(ixSv, Bi.intTp); (* TOS: rOp',32, lOp, lRz, ... *)
1464 out.Code(Jvm.opc_isub); (* TOS: rOp'', lOp, lRz, ... *)
1465 out.Code(Jvm.opc_lushr); (* TOS: rRz, lRz, ... *)
1466 out.Code(Jvm.opc_lor); (* TOS: ROT(lOp, rOp), ... *)
1467 out.ReleaseLocal(ixSv);
1468 END;
1469 out.ReleaseLocal(tmp2);
1470 out.ReleaseLocal(tmp1);
1471 END RotateLong;
1472
1473 (* ============================================================ *)
1474
1475 PROCEDURE (e : JavaEmitter)PushBinary(exp : Xp.BinaryX; dst : Sy.Type),NEW;
1476 VAR out : Ju.JavaFile;
1477 lOp : Sy.Expr;
1478 rOp : Sy.Expr;
1479
1480 dNum : INTEGER;
1481 sNum : INTEGER;
1482 code : INTEGER;
1483 indx : INTEGER;
1484 rLit : LONGINT;
1485 exLb : Ju.Label;
1486 tpLb : Ju.Label;
1487 long : BOOLEAN;
1488 (* -------------------------------- *)
1489 PROCEDURE plusCode(tNnm : INTEGER) : INTEGER;
1490 BEGIN
1491 CASE tNnm OF
1492 | Ty.realN : RETURN Jvm.opc_dadd;
1493 | Ty.sReaN : RETURN Jvm.opc_fadd;
1494 | Ty.lIntN : RETURN Jvm.opc_ladd;
1495 ELSE RETURN Jvm.opc_iadd;
1496 END;
1497 END plusCode;
1498 (* -------------------------------- *)
1499 PROCEDURE minusCode(tNnm : INTEGER) : INTEGER;
1500 BEGIN
1501 CASE tNnm OF
1502 | Ty.realN : RETURN Jvm.opc_dsub;
1503 | Ty.sReaN : RETURN Jvm.opc_fsub;
1504 | Ty.lIntN : RETURN Jvm.opc_lsub;
1505 ELSE RETURN Jvm.opc_isub;
1506 END;
1507 END minusCode;
1508 (* -------------------------------- *)
1509 PROCEDURE multCode(tNnm : INTEGER) : INTEGER;
1510 BEGIN
1511 CASE tNnm OF
1512 | Ty.realN : RETURN Jvm.opc_dmul;
1513 | Ty.sReaN : RETURN Jvm.opc_fmul;
1514 | Ty.lIntN : RETURN Jvm.opc_lmul;
1515 ELSE RETURN Jvm.opc_imul;
1516 END;
1517 END multCode;
1518 (* -------------------------------- *)
1519 BEGIN (* PushBinary *)
1520 out := e.outF;
1521 lOp := exp.lKid;
1522 rOp := exp.rKid;
1523 CASE exp.kind OF
1524 (* -------------------------------- *)
1525 | Xp.index :
1526 IF exp.lKid.type IS Ty.Vector THEN
1527 e.PushVecElemHandle(lOp, rOp);
1528 out.GetVecElement(dst); (* load the element *)
1529 ELSE
1530 IF rOp.type = NIL THEN rOp.type := Bi.intTp END;
1531 e.PushValue(lOp, lOp.type); (* push arr. desig. *)
1532 e.PushValue(rOp, rOp.type); (* push index value *)
1533 out.GetElement(lOp.type(Ty.Array).elemTp); (* load the element *)
1534 IF dst = Bi.uBytTp THEN e.UbyteClear() END;
1535 END;
1536 (* -------------------------------- *)
1537 | Xp.range : (* set i..j range ... *)
1538 (* We want to create an integer with bits-- *)
1539 (* [0...01...10...0] *)
1540 (* MSB==31 j i 0==LSB *)
1541 (* One method is A *)
1542 (* 1) [0..010........0] 1 << (j+1) *)
1543 (* 2) [1..110........0] negate(1) *)
1544 (* 3) [0.......010...0] 1 << i *)
1545 (* 4) [1.......110...0] negate(3) *)
1546 (* 5) [0...01...10...0] (2)xor(4) *)
1547 (* Another method is B *)
1548 (* 1) [1.............1] -1 *)
1549 (* 2) [0...01........1] (1) >>> (31-j) *)
1550 (* 3) [0........01...1] (2) >> i *)
1551 (* 4) [0...01...10...0] (3) << i *)
1552 (* --------------------------------------------- *
1553 * (* *
1554 * * Method A *
1555 * *) *
1556 * out.Code(Jvm.opc_iconst_1); *
1557 * out.Code(Jvm.opc_iconst_1); *
1558 * e.PushValue(rOp, Bi.intTp); *
1559 * (* Do unsigned less than 32 test here *) *
1560 * out.Code(Jvm.opc_iadd); *
1561 * out.Code(Jvm.opc_ishl); *
1562 * out.Code(Jvm.opc_ineg); *
1563 * out.Code(Jvm.opc_iconst_1); *
1564 * e.PushValue(lOp, Bi.intTp); *
1565 * (* Do unsigned less than 32 test here *) *
1566 * out.Code(Jvm.opc_ishl); *
1567 * out.Code(Jvm.opc_ineg); *
1568 * out.Code(Jvm.opc_ixor); *
1569 * -------------------------------------------- *)
1570 (*
1571 * Method B
1572 *)
1573 IF rOp.kind = Xp.numLt THEN
1574 (* out.PushInt(-1 >>> (31 - intValue(rOp))); *)
1575 out.PushInt(ORD({0 .. intValue(rOp)}));
1576 ELSE
1577 out.Code(Jvm.opc_iconst_m1);
1578 out.PushInt(31);
1579 e.PushValue(rOp, Bi.intTp);
1580 (* Do unsigned less than 32 test here ...*)
1581 out.Code(Jvm.opc_isub);
1582 out.Code(Jvm.opc_iushr);
1583 END;
1584 IF lOp.kind = Xp.numLt THEN
1585 (* out.PushInt(-1 << intValue(lOp)); *)
1586 out.PushInt(ORD({intValue(lOp) .. 31}));
1587 out.Code(Jvm.opc_iand);
1588 ELSE
1589 e.PushValue(lOp, Bi.intTp);
1590 (* Do unsigned less than 32 test here ...*)
1591 out.Code(Jvm.opc_dup_x1);
1592 out.Code(Jvm.opc_ishr);
1593 out.Code(Jvm.opc_swap);
1594 out.Code(Jvm.opc_ishl);
1595 END;
1596 (* -------------------------------- *)
1597 | Xp.lenOf :
1598 e.PushValue(lOp, lOp.type);
1599 IF lOp.type IS Ty.Vector THEN
1600 out.GetVecLen();
1601 ELSE
1602 FOR indx := 0 TO intValue(rOp) - 1 DO
1603 out.Code(Jvm.opc_iconst_0);
1604 out.Code(Jvm.opc_aaload);
1605 END;
1606 out.Code(Jvm.opc_arraylength);
1607 END;
1608 (* -------------------------------- *)
1609 | Xp.maxOf, Xp.minOf :
1610 long := dst.isLongType();
1611 tpLb := out.newLabel();
1612 exLb := out.newLabel();
1613 (*
1614 * Push left operand, duplicate
1615 * stack is (top) lOp lOp ...
1616 *)
1617 e.PushValue(lOp, dst);
1618 IF long THEN
1619 out.Code(Jvm.opc_dup2);
1620 ELSE
1621 out.Code(Jvm.opc_dup);
1622 END;
1623 (*
1624 * Push right operand
1625 * stack is (top) rOp lOp lOp ...
1626 *)
1627 e.PushValue(rOp, dst);
1628 (*
1629 * Duplicate and stow
1630 * stack is (top) rOp lOp rOp lOp ...
1631 *)
1632 IF long THEN
1633 out.Code(Jvm.opc_dup2_x2);
1634 ELSE
1635 out.Code(Jvm.opc_dup_x1);
1636 END;
1637 (*
1638 * Compare two top items and jump
1639 * stack is (top) rOp lOp ...
1640 *)
1641 IF exp.kind = Xp.maxOf THEN
1642 e.DoCmp(Xp.lessT, tpLb, dst);
1643 ELSE
1644 e.DoCmp(Xp.greT, tpLb, dst);
1645 END;
1646 indx := out.getDepth();
1647 (*
1648 * Discard top item
1649 * stack is (top) lOp ...
1650 *)
1651 IF long THEN
1652 out.Code(Jvm.opc_pop2);
1653 ELSE
1654 out.Code(Jvm.opc_pop);
1655 END;
1656 out.CodeLb(Jvm.opc_goto, exLb);
1657 out.DefLab(tpLb);
1658 out.setDepth(indx);
1659 (*
1660 * Swap top two items and discard top
1661 * stack is (top) rOp ...
1662 *)
1663 IF long THEN
1664 out.Code(Jvm.opc_dup2_x2);
1665 out.Code(Jvm.opc_pop2);
1666 out.Code(Jvm.opc_pop2);
1667 ELSE
1668 out.Code(Jvm.opc_swap);
1669 out.Code(Jvm.opc_pop);
1670 END;
1671 out.DefLab(exLb);
1672 (* -------------------------------- *)
1673 | Xp.bitAnd :
1674 e.PushValue(lOp, dst);
1675 e.PushValue(rOp, dst);
1676 (*
1677 * A literal bitAnd might be a long
1678 * operation, from a folded MOD.
1679 *)
1680 IF dst.isLongType() THEN
1681 out.Code(Jvm.opc_land);
1682 ELSE
1683 out.Code(Jvm.opc_iand);
1684 END;
1685 (* -------------------------------- *)
1686 | Xp.bitOr :
1687 e.PushValue(lOp, dst);
1688 e.PushValue(rOp, dst);
1689 out.Code(Jvm.opc_ior);
1690 (* -------------------------------- *)
1691 | Xp.bitXor :
1692 e.PushValue(lOp, dst);
1693 e.PushValue(rOp, dst);
1694 out.Code(Jvm.opc_ixor);
1695 (* -------------------------------- *)
1696 | Xp.plus :
1697 dNum := dst(Ty.Base).tpOrd;
1698 e.PushValue(lOp, dst);
1699 e.PushValue(rOp, dst);
1700 out.Code(plusCode(dNum));
1701 (* -------------------------------- *)
1702 | Xp.minus :
1703 dNum := dst(Ty.Base).tpOrd;
1704 e.PushValue(lOp, dst);
1705 e.PushValue(rOp, dst);
1706 out.Code(minusCode(dNum));
1707 (* -------------------------------- *)
1708 | Xp.mult :
1709 dNum := dst(Ty.Base).tpOrd;
1710 e.PushValue(lOp, dst);
1711 e.PushValue(rOp, dst);
1712 out.Code(multCode(dNum));
1713 (* -------------------------------- *)
1714 | Xp.slash :
1715 e.PushValue(lOp, dst);
1716 e.PushValue(rOp, dst);
1717 out.Code(Jvm.opc_ddiv);
1718 (* -------------------------------- *)
1719 | Xp.modOp :
1720 dNum := dst(Ty.Base).tpOrd;
1721 e.PushValue(lOp, dst);
1722 e.PushValue(rOp, dst);
1723 IF dNum = Ty.lIntN THEN
1724 out.CallRTS(Ju.ModL,4,2);
1725 ELSE
1726 out.CallRTS(Ju.ModI,2,1);
1727 END;
1728 (* -------------------------------- *)
1729 | Xp.divOp :
1730 (*
1731 * dNum := dst(Ty.Base).tpOrd;
1732 * e.PushValue(lOp, dst);
1733 * e.PushValue(rOp, dst);
1734 * IF dNum = Ty.lIntN THEN
1735 * out.CallRTS(Ju.DivL,4,2);
1736 * ELSE
1737 * out.CallRTS(Ju.DivI,2,1);
1738 * END;
1739 *
1740 * Alternative, inline code ...
1741 *)
1742 e.PushValue(lOp, dst);
1743 long := dst(Ty.Base).tpOrd = Ty.lIntN;
1744 IF (rOp.kind = Xp.numLt) & (longValue(rOp) > 0) THEN
1745 tpLb := out.newLabel();
1746 IF long THEN
1747 rLit := longValue(rOp);
1748 out.Code(Jvm.opc_dup2);
1749 out.PushLong(0);
1750 out.Code(Jvm.opc_lcmp);
1751 out.CodeLb(Jvm.opc_ifge, tpLb);
1752 out.PushLong(rLit-1);
1753 out.Code(Jvm.opc_lsub);
1754 out.DefLab(tpLb);
1755 out.PushLong(rLit);
1756 out.Code(Jvm.opc_ldiv);
1757 ELSE
1758 indx := intValue(rOp);
1759 out.Code(Jvm.opc_dup);
1760 out.CodeLb(Jvm.opc_ifge, tpLb);
1761 out.PushInt(indx-1);
1762 out.Code(Jvm.opc_isub);
1763 out.DefLab(tpLb);
1764 out.PushInt(indx);
1765 out.Code(Jvm.opc_idiv);
1766 END;
1767 ELSE
1768 e.PushValue(rOp, dst);
1769 IF long THEN
1770 out.CallRTS(Ju.DivL,4,2);
1771 ELSE
1772 out.CallRTS(Ju.DivI,2,1);
1773 END;
1774 END;
1775 (* -------------------------------- *)
1776 | Xp.rem0op :
1777 dNum := dst(Ty.Base).tpOrd;
1778 e.PushValue(lOp, dst);
1779 e.PushValue(rOp, dst);
1780 IF dNum = Ty.lIntN THEN
1781 out.Code(Jvm.opc_lrem);
1782 ELSE
1783 out.Code(Jvm.opc_irem);
1784 END;
1785 (* -------------------------------- *)
1786 | Xp.div0op :
1787 dNum := dst(Ty.Base).tpOrd;
1788 e.PushValue(lOp, dst);
1789 e.PushValue(rOp, dst);
1790 IF dNum = Ty.lIntN THEN
1791 out.Code(Jvm.opc_ldiv);
1792 ELSE
1793 out.Code(Jvm.opc_idiv);
1794 END;
1795 (* -------------------------------- *)
1796 | Xp.blOr, Xp.blAnd, Xp.greT, Xp.greEq,
1797 Xp.notEq, Xp.lessEq, Xp.lessT, Xp.equal, Xp.inOp :
1798 tpLb := out.newLabel();
1799 exLb := out.newLabel();
1800 (*
1801 * Jumping code is mandated for blOr and blAnd...
1802 *
1803 * For the Relational Ops this next seems crude, but
1804 * appears to be the only way that the JVM allows
1805 * construction of boolean values.
1806 *)
1807 e.FallTrue(exp, tpLb);
1808 out.Code(Jvm.opc_iconst_1);
1809 out.CodeLb(Jvm.opc_goto, exLb);
1810 out.DefLab(tpLb);
1811 out.Code(Jvm.opc_iconst_0);
1812 out.DefLab(exLb);
1813 (* -------------------------------- *)
1814 | Xp.isOp :
1815 e.PushValue(lOp, lOp.type);
1816 out.CodeT(Jvm.opc_instanceof, rOp(Xp.IdLeaf).ident.type);
1817 (* -------------------------------- *)
1818 | Xp.rotInt :
1819 e.PushValue(lOp, lOp.type);
1820 IF lOp.type = Bi.lIntTp THEN
1821 RotateLong(e, lOp, rOp);
1822 ELSE
1823 RotateInt(e, lOp, rOp);
1824 END;
1825 (* -------------------------------- *)
1826 | Xp.ashInt, Xp.lshInt :
1827 long := dst.isLongType();
1828 e.PushValue(lOp, lOp.type);
1829 IF long THEN
1830 ShiftLong(exp.kind, e, lOp, rOp);
1831 ELSE
1832 ShiftInt(exp.kind, e, lOp, rOp);
1833 END;
1834 (* -------------------------------- *)
1835 | Xp.strCat :
1836 e.PushValue(lOp, lOp.type);
1837 e.PushValue(rOp, rOp.type);
1838 IF (lOp.type = Bi.strTp) &
1839 (lOp.kind # Xp.mkStr) OR
1840 lOp.type.isNativeStr() THEN
1841 IF (rOp.type = Bi.strTp) &
1842 (rOp.kind # Xp.mkStr) OR
1843 rOp.type.isNativeStr() THEN
1844 out.CallRTS(Ju.StrCatSS,2,1);
1845 ELSE
1846 out.CallRTS(Ju.StrCatSA, 2, 1);
1847 END;
1848 ELSE
1849 IF (rOp.type = Bi.strTp) &
1850 (rOp.kind # Xp.mkStr) OR
1851 rOp.type.isNativeStr() THEN
1852 out.CallRTS(Ju.StrCatAS, 2, 1);
1853 ELSE
1854 out.CallRTS(Ju.StrCatAA, 2, 1);
1855 END;
1856 END;
1857 (* -------------------------------- *)
1858 END;
1859 END PushBinary;
1860
1861 (* ============================================================ *)
1862
1863 PROCEDURE (e : JavaEmitter)PushValue(exp : Sy.Expr; typ : Sy.Type),NEW;
1864 VAR out : Ju.JavaFile;
1865 rec : Ty.Record;
1866 ix : INTEGER;
1867 elm : Sy.Expr;
1868 emt : BOOLEAN; (* ==> more than one set element expr *)
1869 BEGIN
1870 out := e.outF;
1871 WITH exp : Xp.IdLeaf DO
1872 IF exp.isProcLit() THEN
1873 out.MakeAndPushProcLitValue(exp, typ(Ty.Procedure));
1874 ELSIF exp.kind = Xp.typOf THEN
1875 out.LoadType(exp.ident);
1876 ELSE
1877 out.GetVar(exp.ident);
1878 IF typ = Bi.uBytTp THEN e.UbyteClear() END;
1879 END;
1880 | exp : Xp.SetExp DO
1881 emt := TRUE;
1882 (*
1883 * Write out the constant part, if there is one.
1884 *)
1885 IF exp.value # NIL THEN
1886 out.PushInt(exp.value.int()); (* const part *)
1887 emt := FALSE;
1888 END;
1889 (*
1890 * Write out the element expressions.
1891 * taking the union with any part emitted already.
1892 *)
1893 FOR ix := 0 TO exp.varSeq.tide-1 DO
1894 elm := exp.varSeq.a[ix];
1895 IF elm.kind = Xp.range THEN
1896 e.PushValue(elm, Bi.intTp);
1897 ELSE
1898 out.PushInt(1);
1899 e.PushValue(exp.varSeq.a[ix], Bi.intTp);
1900 out.Code(Jvm.opc_ishl);
1901 END;
1902 IF ~emt THEN out.Code(Jvm.opc_ior) END;
1903 emt := FALSE;
1904 END;
1905 (*
1906 * If neither of the above emitted anything, emit zero!
1907 *)
1908 IF emt THEN out.Code(Jvm.opc_iconst_0) END;
1909 | exp : Xp.LeafX DO
1910 CASE exp.kind OF
1911 | Xp.tBool : out.Code(Jvm.opc_iconst_1);
1912 | Xp.fBool : out.Code(Jvm.opc_iconst_0);
1913 | Xp.nilLt : out.Code(Jvm.opc_aconst_null);
1914 | Xp.charLt : out.PushInt(ORD(exp.value.char()));
1915 | Xp.setLt : out.PushInt(exp.value.int());
1916 | Xp.numLt :
1917 IF typ = Bi.lIntTp THEN
1918 out.PushLong(exp.value.long());
1919 ELSE
1920 out.PushInt(exp.value.int());
1921 END;
1922 | Xp.realLt :
1923 IF typ = Bi.realTp THEN
1924 out.PushReal(exp.value.real());
1925 ELSE
1926 out.PushSReal(exp.value.real());
1927 END;
1928 | Xp.strLt :
1929 IF (typ = Bi.charTp) OR (typ = Bi.sChrTp) THEN
1930 out.PushInt(ORD(exp.value.chr0()));
1931 ELSE
1932 out.PushStr(exp.value.chOpen());
1933 END;
1934 | Xp.infLt :
1935 IF typ = Bi.realTp THEN
1936 out.GetVar(Cst.dblInf);
1937 ELSE
1938 out.GetVar(Cst.fltInf);
1939 END;
1940 | Xp.nInfLt :
1941 IF typ = Bi.realTp THEN
1942 out.GetVar(Cst.dblNInf);
1943 ELSE
1944 out.GetVar(Cst.fltNInf);
1945 END;
1946 END;
1947 | exp : Xp.CallX DO
1948 e.PushCall(exp);
1949 | exp : Xp.IdentX DO
1950 e.PushValue(exp.kid, exp.kid.type);
1951 IF exp.kind = Xp.selct THEN
1952 rec := exp.kid.type(Ty.Record);
1953 out.PutGetF(Jvm.opc_getfield, rec, exp.ident(Id.FldId));
1954 IF typ = Bi.uBytTp THEN e.UbyteClear() END;
1955 ELSIF exp.kind = Xp.cvrtUp THEN
1956 out.ConvertUp(exp.kid.type, typ);
1957 ELSIF exp.kind = Xp.cvrtDn THEN
1958 out.ConvertDn(exp.kid.type, typ);
1959 END;
1960 | exp : Xp.UnaryX DO
1961 e.PushUnary(exp, typ);
1962 | exp : Xp.BinaryX DO
1963 e.PushBinary(exp, typ);
1964 END;
1965 END PushValue;
1966
1967 (* ---------------------------------------------------- *)
1968
1969 PROCEDURE SwapHandle(out : Ju.JavaFile; exp : Sy.Expr; long : BOOLEAN);
1970 (* Precondition: exp must be a variable designator *)
1971 (* A value is below a handle of 0,1,2 words. Swap val to top *)
1972 VAR hSiz : INTEGER;
1973 idnt : Sy.Idnt;
1974 type : Sy.Type;
1975 BEGIN
1976 type := exp.type;
1977 IF (type IS Ty.Record) OR
1978 ((type IS Ty.Array) & (type.kind # Ty.vecTp)) THEN
1979 hSiz := 1;
1980 ELSE
1981 WITH exp : Xp.IdLeaf DO
1982 idnt := exp.ident;
1983 WITH idnt : Id.LocId DO
1984 IF Id.uplevA IN idnt.locAtt THEN hSiz := 1 ELSE hSiz := 0 END;
1985 ELSE
1986 hSiz := 0;
1987 END;
1988 | exp : Xp.BinaryX DO
1989 hSiz := 2;
1990 ELSE
1991 hSiz := 1;
1992 END; (* -------------------- *)
1993 END; (* -------------------- *)
1994 (* Before ==> After *)
1995 IF hSiz = 1 THEN (* -------------------- *)
1996 IF ~long THEN (* [hndl] ==> [valu] *)
1997 out.Code(Jvm.opc_swap); (* [valu] [hndl] *)
1998 (* -------------------- *)
1999 ELSE (* [hndl] ==> [val2] *)
2000 out.Code(Jvm.opc_dup_x2); (* [val2] [val1] *)
2001 out.Code(Jvm.opc_pop); (* [val1] [hndl] *)
2002 END; (* -------------------- *)
2003 ELSIF hSiz = 2 THEN (* -------------------- *)
2004 IF ~long THEN (* [indx] ==> [valu] *)
2005 out.Code(Jvm.opc_dup2_x1); (* [hndl] [indx] *)
2006 out.Code(Jvm.opc_pop2); (* [valu] [hndl] *)
2007 (* -------------------- *)
2008 ELSE (* [indx] ==> [val2] *)
2009 out.Code(Jvm.opc_dup2_x2); (* [hdnl] [val1] *)
2010 out.Code(Jvm.opc_pop2); (* [val2] [indx] *)
2011 END; (* [val1] [hndl] *)
2012 (* ELSE nothing to do *) (* -------------------- *)
2013 END;
2014 END SwapHandle;
2015
2016 (* -------------------------------------------- *)
2017
2018 PROCEDURE (e : JavaEmitter)PushHandle(exp : Sy.Expr; typ : Sy.Type),NEW;
2019 (* Precondition: exp must be a variable designator *)
2020 VAR idnt : Sy.Idnt;
2021 BEGIN
2022 ASSERT(exp.isVarDesig());
2023 IF (typ IS Ty.Record) OR ((typ IS Ty.Array) & (typ.kind # Ty.vecTp)) THEN
2024 e.PushValue(exp, typ);
2025 ELSE
2026 WITH exp : Xp.IdentX DO
2027 e.PushValue(exp.kid, exp.kid.type);
2028 | exp : Xp.BinaryX DO
2029 IF exp.lKid.type IS Ty.Vector THEN
2030 e.PushVecElemHandle(exp.lKid, exp.rKid);
2031 (*
2032 * e.PushValue(exp.lKid, exp.lKid.type);
2033 * e.outF.GetVecArr(exp.lKid.type(Ty.Vector).elemTp);
2034 * e.PushValue(exp.rKid, Bi.intTp);
2035 *)
2036 ELSE
2037 e.PushValue(exp.lKid, exp.lKid.type);
2038 e.PushValue(exp.rKid, Bi.intTp);
2039 END;
2040 | exp : Xp.IdLeaf DO
2041 idnt := exp.ident;
2042 WITH idnt : Id.LocId DO (* check if implemented inside XHR *)
2043 IF Id.uplevA IN idnt.locAtt THEN e.outF.XhrHandle(idnt) END;
2044 ELSE (* skip *)
2045 END;
2046 END;
2047 END;
2048 END PushHandle;
2049
2050 (* ---------------------------------------------------- *)
2051
2052 PROCEDURE (e : JavaEmitter)ScalarAssign(exp : Sy.Expr),NEW;
2053 VAR out : Ju.JavaFile;
2054 rec : Ty.Record;
2055 BEGIN
2056 out := e.outF;
2057 WITH exp : Xp.IdLeaf DO
2058 (* stack has ... value, (top) *)
2059 out.PutVar(exp.ident);
2060 | exp : Xp.IdentX DO
2061 (* stack has ... obj-ref, value, (top) *)
2062 rec := exp.kid.type(Ty.Record);
2063 out.PutGetF(Jvm.opc_putfield, rec, exp.ident(Id.FldId));
2064 | exp : Xp.BinaryX DO
2065 (* stack has ... arr-ref, index, value, (top) *)
2066 IF exp.lKid.type IS Ty.Vector THEN
2067 out.PutVecElement(exp.type);
2068 ELSE
2069 out.PutElement(exp.type);
2070 END;
2071 ELSE
2072 Console.WriteString("BAD SCALAR ASSIGN"); Console.WriteLn;
2073 exp.Diagnose(0);
2074 ASSERT(FALSE);
2075 END;
2076 END ScalarAssign;
2077
2078 (* ---------------------------------------------------- *)
2079
2080 PROCEDURE (e : JavaEmitter)ValueCopy(act : Sy.Expr; fmT : Sy.Type),NEW;
2081 VAR out : Ju.JavaFile;
2082 BEGIN
2083 (*
2084 * Copy this actual, where fmT is either an array or record.
2085 *)
2086 out := e.outF;
2087 WITH fmT : Ty.Record DO
2088 out.MkNewRecord(fmT); (* (top) dst... *)
2089 out.Code(Jvm.opc_dup); (* (top) dst,dst... *)
2090 e.PushValue(act, fmT); (* (top) src,dst,dst... *)
2091 out.ValRecCopy(fmT); (* (top) dst... *)
2092 | fmT : Ty.Array DO
2093 (*
2094 * Array case: ordinary value copy
2095 *)
2096 IF fmT.length = 0 THEN (* open array case *)
2097 e.PushValue(act, fmT); (* (top) src... *)
2098 out.Code(Jvm.opc_dup); (* (top) src,src... *)
2099 IF act.kind = Xp.mkStr THEN
2100 out.CallRTS(Ju.StrLP1,1,1); (* (top) len,src... *)
2101 out.Alloc1d(Bi.charTp); (* (top) dst,src... *)
2102 ELSE
2103 out.MkArrayCopy(fmT); (* (top) dst,src... *)
2104 END;
2105 out.Code(Jvm.opc_dup_x1); (* dst,src,dst... *)
2106 out.Code(Jvm.opc_swap); (* (top) src,dst,dst... *)
2107 ELSE (* fixed array case *)
2108 out.MkNewFixedArray(fmT.elemTp, fmT.length);
2109 out.Code(Jvm.opc_dup); (* (top) dst,dst... *)
2110 e.PushValue(act, fmT); (* (top) src,dst,dst... *)
2111 END;
2112 IF act.kind = Xp.mkStr THEN
2113 out.CallRTS(Ju.StrVal, 2, 0); (* (top) dst... *)
2114 ELSE
2115 out.ValArrCopy(fmT); (* (top) dst... *)
2116 END;
2117 ELSE
2118 e.PushValue(act, fmT);
2119 END;
2120 END ValueCopy;
2121
2122 (* ---------------------------------------------------- *)
2123
2124 PROCEDURE (e : JavaEmitter)StringCopy(act : Sy.Expr; fmT : Ty.Array),NEW;
2125 VAR out : Ju.JavaFile;
2126 BEGIN
2127 out := e.outF;
2128 IF act.kind = Xp.mkStr THEN
2129 e.ValueCopy(act, fmT);
2130 ELSIF fmT.length = 0 THEN (* str passed to open array *)
2131 e.PushValue(act, fmT);
2132 out.CallRTS(Ju.StrToChrOpen,1,1);
2133 ELSE (* str passed to fixed array *)
2134 out.MkNewFixedArray(Bi.charTp, fmT.length);
2135 out.Code(Jvm.opc_dup);
2136 e.PushValue(act, fmT);
2137 out.CallRTS(Ju.StrToChrs,2,0);
2138 END;
2139 END StringCopy;
2140
2141 (* ============================================================ *)
2142
2143 PROCEDURE (e : JavaEmitter)Invoke(exp : Sy.Expr; typ : Ty.Procedure),NEW;
2144 VAR code : INTEGER;
2145 prcI : Id.PrcId;
2146 mthI : Id.MthId;
2147 BEGIN
2148 IF exp.isProcVar() THEN
2149 mthI := Ju.getProcVarInvoke(exp.type(Ty.Procedure));
2150 code := Jvm.opc_invokevirtual;
2151 e.outF.CallIT(code, mthI, typ);
2152 ELSE
2153 WITH exp : Xp.IdLeaf DO (* qualid *)
2154 prcI := exp.ident(Id.PrcId);
2155 IF prcI.kind = Id.ctorP THEN
2156 code := Jvm.opc_invokespecial;
2157 ELSE
2158 code := Jvm.opc_invokestatic;
2159 END;
2160 e.outF.CallIT(code, prcI, typ);
2161 | exp : Xp.IdentX DO (* selct *)
2162 mthI := exp.ident(Id.MthId);
2163 IF exp.kind = Xp.sprMrk THEN
2164 code := Jvm.opc_invokespecial;
2165 ELSIF mthI.bndType.isInterfaceType() THEN
2166 code := Jvm.opc_invokeinterface;
2167 ELSE
2168 code := Jvm.opc_invokevirtual;
2169 END;
2170 e.outF.CallIT(code, mthI, typ);
2171 IF Id.covar IN mthI.mthAtt THEN
2172 e.outF.CodeT(Jvm.opc_checkcast, typ.retType);
2173 END;
2174 END;
2175 END;
2176 END Invoke;
2177
2178 (* ---------------------------------------------------- *)
2179
2180 PROCEDURE (e : JavaEmitter)PushAndGetReturn(act : Sy.Expr;
2181 typ : Sy.Type;
2182 OUT ret : Sy.Expr),NEW;
2183 (* ----------------------------------------- *)
2184 VAR out : Ju.JavaFile;
2185 local : INTEGER;
2186 recXp : Sy.Expr;
2187 array : Sy.Expr;
2188 index : Sy.Expr;
2189 (* ----------------------------------------- *)
2190 PROCEDURE simple(x : Sy.Expr) : BOOLEAN;
2191 BEGIN
2192 IF x.kind = Xp.deref THEN x := x(Xp.UnaryX).kid END;
2193 RETURN x IS Xp.LeafX; (* IdLeaf or LeafX *)
2194 END simple;
2195 (* ----------------------------------------- *)
2196 BEGIN
2197 (*
2198 * Assert: the expression is a (possibly complex)
2199 * variable designator. Is some part of the handle
2200 * worth saving? Note saving is mandatory for calls.
2201 *)
2202 out := e.outF;
2203 ret := act;
2204 WITH act : Xp.IdLeaf DO
2205 (*
2206 * This is a simple variable. Result will be
2207 * stored directly using the same expression.
2208 *)
2209 e.PushValue(act, typ);
2210 | act : Xp.IdentX DO
2211 ASSERT(act.kind = Xp.selct);
2212 (*
2213 * This is a field select. If the handle is
2214 * sufficiently complicated it will be saved.
2215 *)
2216 recXp := act.kid;
2217 e.PushValue(recXp, recXp.type);
2218 IF ~simple(recXp) THEN
2219 local := out.newLocal();
2220 out.Code(Jvm.opc_dup);
2221 out.StoreLocal(local, NIL);
2222 (*
2223 * The restore expression is a mutated
2224 * version of the original expression.
2225 *)
2226 act.kid := e.newLeaf(local, recXp.type);
2227 act.kid.type := recXp.type;
2228 END;
2229 out.PutGetF(Jvm.opc_getfield,
2230 recXp.type(Ty.Record), act.ident(Id.FldId));
2231 | act : Xp.BinaryX DO
2232 ASSERT(act.kind = Xp.index);
2233 (*
2234 * This is an index select. If the handle, or
2235 * index (or both) are complicated they are saved.
2236 *)
2237 array := act.lKid;
2238 index := act.rKid;
2239 e.PushValue(array, array.type);
2240 IF simple(array) THEN (* don't save handle *)
2241 e.PushValue(index, Bi.intTp);
2242 IF ~simple(index) THEN (* must save index *)
2243 local := out.newLocal();
2244 out.Code(Jvm.opc_dup);
2245 out.StoreLocal(local, Bi.intTp); (* #### *)
2246 act.rKid := e.newLeaf(local, Bi.intTp);
2247 act.rKid.type := Bi.intTp;
2248 END;
2249 ELSE (* must save handle *)
2250 local := out.newLocal();
2251 out.Code(Jvm.opc_dup);
2252 out.StoreLocal(local, NIL);
2253 act.lKid := e.newLeaf(local, array.type);
2254 act.lKid.type := array.type;
2255 e.PushValue(index, Bi.intTp);
2256 IF ~simple(index) THEN (* save index as well *)
2257 local := out.newLocal();
2258 out.Code(Jvm.opc_dup);
2259 out.StoreLocal(local, Bi.intTp); (* #### *)
2260 act.rKid := e.newLeaf(local, Bi.intTp);
2261 act.rKid.type := Bi.intTp;
2262 END;
2263 END;
2264 out.GetElement(typ);
2265 ELSE
2266 act.Diagnose(0); THROW("Bad PushAndGetReturn");
2267 END;
2268 END PushAndGetReturn;
2269
2270 (* ---------------------------------------------------- *)
2271
2272 PROCEDURE (e : JavaEmitter)PushArg(act : Sy.Expr;
2273 frm : Id.ParId;
2274 VAR seq : Sy.ExprSeq),NEW;
2275 (* ------------------------- *)
2276 VAR idExp : Xp.IdentX;
2277 out : Ju.JavaFile;
2278 local : INTEGER;
2279 (* ----------------------------------------- *)
2280 PROCEDURE boxNumber(exp : Sy.Expr) : INTEGER;
2281 BEGIN
2282 RETURN exp(Xp.IdLeaf).ident(Id.ParId).boxOrd;
2283 END boxNumber;
2284 (* ----------------------------------------- *)
2285 PROCEDURE boxedPar(exp : Sy.Expr) : BOOLEAN;
2286 VAR idnt : Sy.Idnt;
2287 BEGIN
2288 WITH exp : Xp.IdLeaf DO
2289 idnt := exp.ident;
2290 WITH idnt : Id.ParId DO
2291 RETURN (idnt.boxOrd # Ju.retMarker) & Ju.needsBox(idnt);
2292 ELSE
2293 RETURN FALSE;
2294 END;
2295 ELSE
2296 RETURN FALSE;
2297 END;
2298 END boxedPar;
2299 (* ----------------------------------------- *)
2300 BEGIN
2301 out := e.outF;
2302 IF Ju.needsBox(frm) THEN (* value is returned *)
2303 NEW(idExp);
2304 idExp.ident := frm;
2305 IF frm.parMod = Sy.out THEN (* no value push *)
2306 idExp.kid := act;
2307 ELSE
2308 e.PushAndGetReturn(act, frm.type, idExp.kid);
2309 END;
2310 IF frm.boxOrd # Ju.retMarker THEN
2311 (* ==> out value but not in return slot *)
2312 frm.rtsTmp := out.newLocal();
2313 IF boxedPar(act) THEN
2314 out.LoadLocal(boxNumber(act), NIL);
2315 ELSE
2316 out.MkNewFixedArray(frm.type, 1);
2317 END;
2318 out.Code(Jvm.opc_dup);
2319 out.StoreLocal(frm.rtsTmp, NIL);
2320 END;
2321 Sy.AppendExpr(seq, idExp);
2322 ELSIF (frm.type IS Ty.Array) &
2323 ((act.type = Bi.strTp) OR act.type.isNativeStr()) THEN
2324 e.StringCopy(act, frm.type(Ty.Array)); (* special string case *)
2325 ELSIF (frm.parMod = Sy.val) &
2326 ((frm.type IS Ty.Record) OR
2327 (* #### *)
2328 ((frm.type IS Ty.Array) & (frm.type.kind # Ty.vecTp))) THEN
2329 (* #### *)
2330 e.ValueCopy(act, frm.type);
2331 ELSE
2332 e.PushValue(act, frm.type);
2333 END;
2334 END PushArg;
2335
2336 (* ---------------------------------------------------- *)
2337
2338 PROCEDURE (e : JavaEmitter)CopyOut(exp : Sy.Expr; idD : Sy.Idnt),NEW;
2339 VAR out : Ju.JavaFile;
2340 par : Id.ParId;
2341 BEGIN
2342 (* Assert : this is an unboxed type *)
2343 out := e.outF;
2344 par := idD(Id.ParId);
2345 e.PushHandle(exp, par.type);
2346 IF par.boxOrd # Ju.retMarker THEN
2347 out.LoadLocal(par.rtsTmp, NIL);
2348 out.Code(Jvm.opc_iconst_0);
2349 out.GetElement(par.type);
2350 ELSE (* result is below handle *)
2351 SwapHandle(out, exp, par.type.isLongType());
2352 END;
2353 e.ScalarAssign(exp);
2354 END CopyOut;
2355
2356 (* ============================================================ *)
2357 (* Possible structures of procedure call expressions are: *)
2358 (* ============================================================ *)
2359 (* o o *)
2360 (* / / *)
2361 (* [CallX] [CallX] *)
2362 (* / +--- actuals --> ... / +--- actuals *)
2363 (* / / *)
2364 (* [IdentX] [IdLeaf] *)
2365 (* / +--- ident ---> [Procs] +--- ident ---> [Procs] *)
2366 (* / *)
2367 (* kid expr *)
2368 (* *)
2369 (* ============================================================ *)
2370 (* only the right hand case can be a standard proc or function *)
2371 (* ============================================================ *)
2372
2373 PROCEDURE (e : JavaEmitter)PushCall(callX : Xp.CallX),NEW;
2374 VAR jFile : Ju.JavaFile;
2375 mark0 : INTEGER; (* local ord limit on entry *)
2376 tide0 : INTEGER; (* parameter tide on entry *)
2377 index : INTEGER; (* just a counter for loops *)
2378 prVar : BOOLEAN; (* Procedure variable call *)
2379 formT : Ty.Procedure; (* formal type of procedure *)
2380 formP : Id.ParId; (* current formal parameter *)
2381 prExp : Sy.Expr;
2382 idExp : Xp.IdentX;
2383 (* ---------------------------------------------------- *)
2384 PROCEDURE CheckCall(expr : Sy.Expr; pTyp : Ty.Procedure);
2385 VAR prcI : Id.PrcId;
2386 mthI : Id.MthId;
2387 idnt : Sy.Idnt;
2388 BEGIN
2389 WITH expr : Xp.IdLeaf DO (* qualid *)
2390 idnt := expr.ident;
2391 WITH idnt : Id.PrcId DO
2392 (* prcI := expr.ident(Id.PrcId); *)
2393 IF pTyp.xName = NIL THEN Ju.MkCallAttr(idnt, pTyp) END;
2394 | idnt : Id.AbVar DO
2395 mthI := Ju.getProcVarInvoke(pTyp);
2396 IF mthI.type.xName = NIL THEN Ju.MkCallAttr(mthI, mthI.type(Ty.Procedure)) END;
2397 END;
2398 | expr : Xp.IdentX DO (* selct *)
2399 idnt := expr.ident;
2400 WITH idnt : Id.MthId DO
2401 IF pTyp.xName = NIL THEN Ju.MkCallAttr(idnt, pTyp) END;
2402 | idnt : Id.FldId DO
2403 mthI := Ju.getProcVarInvoke(pTyp);
2404 IF mthI.type.xName = NIL THEN Ju.MkCallAttr(mthI, mthI.type(Ty.Procedure)) END;
2405 END;
2406 END;
2407 END CheckCall;
2408 (* ---------------------------------------------------- *)
2409 PROCEDURE isNested(exp : Xp.IdLeaf) : BOOLEAN;
2410 BEGIN
2411 RETURN exp.ident(Id.PrcId).lxDepth > 0;
2412 END isNested;
2413 (* ---------------------------------------------------- *)
2414 BEGIN
2415 jFile := e.outF;
2416 mark0 := jFile.markTop();
2417 tide0 := callX.actuals.tide;
2418 prExp := callX.kid;
2419 formT := prExp.type(Ty.Procedure);
2420 (*
2421 * Before we push any arguments, we must ensure that
2422 * the formal-type name is computed, and the first
2423 * out-value is moved to the return-slot, if possible.
2424 *)
2425 prVar := prExp.isProcVar();
2426 CheckCall(prExp, formT);
2427 (*
2428 * We must first deal with the receiver if this is a method.
2429 *)
2430 IF prVar THEN
2431 e.PushValue(prExp, prExp.type);
2432 formT := Ju.getProcVarInvoke(formT).type(Ty.Procedure);
2433 ELSIF formT.receiver # NIL THEN
2434 idExp := prExp(Xp.IdentX);
2435 formP := idExp.ident(Id.MthId).rcvFrm;
2436 e.PushArg(idExp.kid, formP, callX.actuals);
2437 ELSE
2438 WITH prExp : Xp.IdLeaf DO
2439 IF prExp.ident.kind = Id.ctorP THEN
2440 jFile.CodeT(Jvm.opc_new, callX.type);
2441 jFile.Code(Jvm.opc_dup);
2442 ELSIF isNested(prExp) THEN
2443 jFile.PushStaticLink(prExp.ident(Id.Procs));
2444 END;
2445 ELSE (* skip *)
2446 END;
2447 END;
2448 (*
2449 * We push the arguments from left to right.
2450 * New IdentX expressions are appended to the argument
2451 * list to describe how to save any returned values.
2452 *)
2453 FOR index := 0 TO tide0-1 DO
2454 formP := formT.formals.a[index];
2455 e.PushArg(callX.actuals.a[index], formP, callX.actuals);
2456 END;
2457 (*
2458 * Now emit the actual call instruction(s)
2459 *)
2460 e.Invoke(prExp, formT);
2461 (*
2462 * Now we save any out arguments from the appended exprs.
2463 *)
2464 FOR index := tide0 TO callX.actuals.tide-1 DO
2465 prExp := callX.actuals.a[index];
2466 idExp := prExp(Xp.IdentX);
2467 e.CopyOut(idExp.kid, idExp.ident);
2468 END;
2469 jFile.ReleaseAll(mark0);
2470 (*
2471 * Normally an CallX expression can only be evaluated once,
2472 * so it does not matter if PushCall() is not idempotent.
2473 * However, there is a pathological case if a predicate in a
2474 * while loop has a function call with OUT formals. Since the
2475 * GPCP method of laying out while loops evaluates the test
2476 * twice, the actual list must be reset to its original length.
2477 *)
2478 callX.actuals.ResetTo(tide0);
2479 END PushCall;
2480
2481 (* ---------------------------------------------------- *)
2482
2483 PROCEDURE IncByLit(out : Ju.JavaFile; ord : INTEGER; inc : INTEGER);
2484 BEGIN
2485 IF (ord < 256) & (inc >= -128) & (inc <= 127) THEN
2486 out.CodeInc(ord, inc);
2487 ELSE
2488 out.LoadLocal(ord, Bi.intTp);
2489 out.PushInt(inc);
2490 out.Code(Jvm.opc_iadd);
2491 out.StoreLocal(ord, Bi.intTp);
2492 END;
2493 END IncByLit;
2494
2495 PROCEDURE LitIncLocal(out : Ju.JavaFile; proc, vOrd, incr : INTEGER);
2496 BEGIN
2497 IF proc = Bi.decP THEN incr := -incr END;
2498 IncByLit(out, vOrd, incr);
2499 END LitIncLocal;
2500
2501 (* ------------------------------------------ *)
2502
2503 PROCEDURE (e : JavaEmitter)EmitStdProc(callX : Xp.CallX),NEW;
2504 CONST fMsg = "Assertion failure ";
2505 VAR out : Ju.JavaFile;
2506 prId : Id.PrcId;
2507 flId : Id.FldId;
2508 pOrd : INTEGER;
2509 arg0 : Sy.Expr;
2510 argX : Sy.Expr;
2511 dstT : Sy.Type;
2512 idX0 : Sy.Idnt;
2513 argN : INTEGER;
2514 numL : INTEGER;
2515 incr : INTEGER;
2516 vRef : INTEGER;
2517 tide : INTEGER;
2518 okLb : Ju.Label;
2519 long : BOOLEAN;
2520 c : INTEGER;
2521 BEGIN
2522 out := e.outF;
2523 prId := callX.kid(Xp.IdLeaf).ident(Id.PrcId);
2524 arg0 := callX.actuals.a[0]; (* Always need at least one arg *)
2525 argN := callX.actuals.tide;
2526
2527 pOrd := prId.stdOrd;
2528 CASE pOrd OF
2529 (* --------------------------- *)
2530 | Bi.asrtP :
2531 okLb := out.newLabel();
2532 e.FallFalse(arg0, okLb);
2533 (*
2534 * If expression evaluates to false, fall
2535 * into the error code, else skip to okLb.
2536 *)
2537 IF argN > 1 THEN
2538 numL := intValue(callX.actuals.a[1]);
2539 out.Trap(fMsg + L.intToCharOpen(numL)^);
2540 ELSE
2541 numL := callX.token.lin;
2542 out.Trap(fMsg + Cst.srcNam +":"+ L.intToCharOpen(numL)^);
2543 END;
2544 out.DefLab(okLb);
2545 (* --------------------------- *)
2546 | Bi.incP, Bi.decP :
2547 argX := callX.actuals.a[1];
2548 dstT := arg0.type;
2549 long := dstT.isLongType();
2550 (*
2551 * Is this a local variable?
2552 * There is a special instruction for incrementing
2553 * word-sized local variables, provided the increment is
2554 * by a literal 8-bit amount, and local index is 8-bit.
2555 *)
2556 e.PushHandle(arg0, dstT);
2557 WITH arg0 : Xp.IdLeaf DO
2558
2559 idX0 := arg0.ident;
2560 WITH idX0 : Id.LocId DO
2561 IF Id.uplevA IN idX0.locAtt THEN (* uplevel addressing case *)
2562 out.Code(Jvm.opc_dup); (* handle is one slot only *)
2563 out.PutGetX(Jvm.opc_getfield, idX0);
2564 ELSIF (argX.kind = Xp.numLt) & ~long THEN (* PREMATURE EXIT *)
2565 LitIncLocal(out, pOrd, idX0.varOrd, intValue(argX)); RETURN;
2566 ELSE
2567 out.LoadLocal(idX0.varOrd, dstT);
2568 END;
2569 ELSE
2570 e.PushValue(arg0, dstT);
2571 END;
2572 | arg0 : Xp.IdentX DO
2573 flId := arg0.ident(Id.FldId);
2574 out.Code(Jvm.opc_dup); (* handle is one slot only *)
2575 out.PutGetF(Jvm.opc_getfield, arg0.kid.type(Ty.Record), flId);
2576 | arg0 : Xp.BinaryX DO
2577 out.Code(Jvm.opc_dup2); (* handle is two slots here *)
2578 out.GetElement(dstT);
2579 END;
2580 e.PushValue(argX, dstT);
2581 IF long THEN
2582 IF pOrd = Bi.incP THEN c := Jvm.opc_ladd ELSE c := Jvm.opc_lsub END;
2583 ELSE
2584 IF pOrd = Bi.incP THEN c := Jvm.opc_iadd ELSE c := Jvm.opc_isub END;
2585 END;
2586 out.Code(c);
2587 e.ScalarAssign(arg0);
2588 (* --------------------------- *)
2589 | Bi.cutP :
2590 (* ------------------------------------- *
2591 * Emit the code ...
2592 * <push vector ref>
2593 * dup
2594 * getfield CP/CPJvec/VecBase/tide I // tide, vRef ...
2595 * <push arg1> // arg1, tide, vRef ...
2596 * dup_x1 // arg1, tide, arg1, vRef ...
2597 * if_icmpge okLb // arg1, vRef ...
2598 * <throw index trap>
2599 * okLb: // arg1, vRef ...
2600 * putfield CP/CPJvec/VecBase/tide I // (empty)
2601 * ------------------------------------- *)
2602 argX := callX.actuals.a[1];
2603 okLb := out.newLabel();
2604 e.PushValue(arg0, arg0.type);
2605 out.Code(Jvm.opc_dup);
2606 out.GetVecLen();
2607 e.PushValue(argX, Bi.intTp);
2608 out.Code(Jvm.opc_dup_x1);
2609
2610 out.Code(Jvm.opc_iconst_1); (* Chop the sign bit *)
2611 out.Code(Jvm.opc_ishl); (* asserting, for *)
2612 out.Code(Jvm.opc_iconst_1); (* correctness, that *)
2613 out.Code(Jvm.opc_iushr); (* argX >> minInt. *)
2614
2615 out.CodeLb(Jvm.opc_if_icmpge, okLb);
2616 out.Trap("Vector index out of bounds");
2617 out.DefLab(okLb);
2618 out.PutVecLen();
2619 (* --------------------------- *)
2620 | Bi.apndP :
2621 (* -------------------------------------- *
2622 * Emit the code ...
2623 * <push vector ref>
2624 * dup
2625 * astore R // vRef ...
2626 * getfield CP/CPJvec/VecBase/tide I // tide ...
2627 * istore T
2628 * aload R // vRef ...
2629 * getfield CP/CPJvec/VecXXX/elems [X // elems ...
2630 * arraylength // aLen ...
2631 * iload T // tide, aLen ...
2632 * if_icmpgt okLb
2633 * aload R // vRef
2634 * <call expand()>
2635 * okLb:
2636 * aload R // vRef
2637 * getfield CP/CPJvec/VecXXX/elems [X // elems ...
2638 * iload T // tide, elems ...
2639 * <push arg1> // arg1, tide, elems ...
2640 * Xastore
2641 * aload R // vRef ...
2642 * iload T // tide, vRef ...
2643 * iconst_1 // 1, tide, vRef ...
2644 * iadd // tide', vRef ...
2645 * putfield CP/CPJvec/VecBase/tide I // (empty)
2646 * -------------------------------------- *)
2647 argX := callX.actuals.a[1];
2648 dstT := arg0.type(Ty.Vector).elemTp;
2649 vRef := out.newLocal();
2650 tide := out.newLocal();
2651 okLb := out.newLabel();
2652 e.PushValue(arg0, arg0.type);
2653 out.Code(Jvm.opc_dup);
2654 out.StoreLocal(vRef, NIL);
2655 out.GetVecLen();
2656 out.StoreLocal(tide, Bi.intTp);
2657 out.LoadLocal(vRef, NIL);
2658 out.GetVecArr(dstT);
2659 out.Code(Jvm.opc_arraylength);
2660 out.LoadLocal(tide, Bi.intTp);
2661 out.CodeLb(Jvm.opc_if_icmpgt, okLb);
2662 out.LoadLocal(vRef, NIL);
2663 out.InvokeExpand(dstT);
2664 out.DefLab(okLb);
2665 out.LoadLocal(vRef, NIL);
2666 out.GetVecArr(dstT);
2667 out.LoadLocal(tide, Bi.intTp);
2668 e.ValueCopy(argX, dstT);
2669 out.PutVecElement(dstT);
2670 out.LoadLocal(vRef, NIL);
2671 out.LoadLocal(tide, Bi.intTp);
2672 out.Code(Jvm.opc_iconst_1);
2673 out.Code(Jvm.opc_iadd);
2674 out.PutVecLen();
2675 out.ReleaseLocal(tide);
2676 out.ReleaseLocal(vRef);
2677 (* --------------------------- *)
2678 | Bi.exclP, Bi.inclP :
2679 dstT := arg0.type;
2680 argX := callX.actuals.a[1];
2681
2682 e.PushHandle(arg0, dstT);
2683 WITH arg0 : Xp.IdLeaf DO
2684 idX0 := arg0.ident;
2685 WITH idX0 : Id.LocId DO
2686 IF Id.uplevA IN idX0.locAtt THEN (* uplevel addressing case *)
2687 out.Code(Jvm.opc_dup); (* handle is one slot only *)
2688 out.PutGetX(Jvm.opc_getfield, idX0);
2689 ELSE
2690 out.LoadLocal(idX0.varOrd, dstT);
2691 END;
2692 ELSE
2693 e.PushValue(arg0, dstT);
2694 END;
2695 | arg0 : Xp.BinaryX DO
2696 ASSERT(arg0.kind = Xp.index);
2697 out.Code(Jvm.opc_dup2);
2698 out.GetElement(dstT);
2699 | arg0 : Xp.IdentX DO
2700 ASSERT(arg0.kind = Xp.selct);
2701 out.Code(Jvm.opc_dup);
2702 out.PutGetF(Jvm.opc_getfield,
2703 arg0.kid.type(Ty.Record), arg0.ident(Id.FldId));
2704 END;
2705 IF argX.kind = Xp.numLt THEN
2706 out.PushInt(ORD({intValue(argX)}));
2707 ELSE
2708 out.Code(Jvm.opc_iconst_1);
2709 e.PushValue(argX, Bi.intTp);
2710 out.Code(Jvm.opc_ishl);
2711 END;
2712 IF pOrd = Bi.inclP THEN
2713 out.Code(Jvm.opc_ior);
2714 ELSE
2715 out.Code(Jvm.opc_iconst_m1);
2716 out.Code(Jvm.opc_ixor);
2717 out.Code(Jvm.opc_iand);
2718 END;
2719 e.ScalarAssign(arg0);
2720 (* --------------------------- *)
2721 | Bi.haltP :
2722 out.PushInt(intValue(arg0));
2723 out.CallRTS(Ju.SysExit,1,0);
2724 out.PushJunkAndReturn();
2725 (* --------------------------- *)
2726 | Bi.throwP :
2727 IF Cst.ntvExc.assignCompat(arg0) THEN
2728 e.PushValue(arg0, Cst.ntvExc);
2729 out.Code(Jvm.opc_athrow);
2730 ELSE
2731 out.MkNewException();
2732 out.Code(Jvm.opc_dup);
2733 e.PushValue(arg0, Cst.ntvStr);
2734 out.InitException();
2735 out.Code(Jvm.opc_athrow);
2736 END;
2737 (* --------------------------- *)
2738 | Bi.newP :
2739 (*
2740 * arg0 is a pointer to a Record or Array, or else a vector type.
2741 *)
2742 e.PushHandle(arg0, arg0.type);
2743 IF argN = 1 THEN
2744 (*
2745 * No LEN argument implies either:
2746 * pointer to record, OR
2747 * pointer to a fixed array.
2748 *)
2749 dstT := arg0.type(Ty.Pointer).boundTp;
2750 WITH dstT : Ty.Record DO
2751 out.MkNewRecord(dstT);
2752 | dstT : Ty.Array DO
2753 out.MkNewFixedArray(dstT.elemTp, dstT.length);
2754 END;
2755 ELSIF arg0.type.kind = Ty.ptrTp THEN
2756 FOR numL := 1 TO argN-1 DO
2757 argX := callX.actuals.a[numL];
2758 e.PushValue(argX, Bi.intTp);
2759 END;
2760 dstT := arg0.type(Ty.Pointer).boundTp;
2761 out.MkNewOpenArray(dstT(Ty.Array), argN-1);
2762 ELSE (* must be a vector type *)
2763 dstT := arg0.type(Ty.Vector).elemTp;
2764 out.MkVecRec(dstT);
2765 out.Code(Jvm.opc_dup);
2766 e.PushValue(callX.actuals.a[1], Bi.intTp);
2767 out.MkVecArr(dstT);
2768 END;
2769 e.ScalarAssign(arg0);
2770 (* --------------------------- *)
2771 END;
2772 END EmitStdProc;
2773
2774 (* ============================================================ *)
2775 (* Statement Handling Methods *)
2776 (* ============================================================ *)
2777
2778 PROCEDURE (e : JavaEmitter)EmitAssign(stat : St.Assign),NEW;
2779 VAR lhTyp : Sy.Type;
2780 BEGIN
2781 (*
2782 * This is a value assign in CP.
2783 *)
2784 lhTyp := stat.lhsX.type;
2785 e.PushHandle(stat.lhsX, lhTyp);
2786 e.PushValue(stat.rhsX, lhTyp);
2787 WITH lhTyp : Ty.Vector DO
2788 e.ScalarAssign(stat.lhsX);
2789 | lhTyp : Ty.Array DO
2790 IF stat.rhsX.kind = Xp.mkStr THEN
2791 e.outF.CallRTS(Ju.StrVal, 2, 0);
2792 ELSIF stat.rhsX.type = Bi.strTp THEN
2793 e.outF.CallRTS(Ju.StrToChrs,2, 0);
2794 ELSE
2795 e.outF.ValArrCopy(lhTyp);
2796 END;
2797 | lhTyp : Ty.Record DO
2798 e.outF.ValRecCopy(lhTyp);
2799 ELSE
2800 e.ScalarAssign(stat.lhsX);
2801 END;
2802 END EmitAssign;
2803
2804 (* ---------------------------------------------------- *)
2805
2806 PROCEDURE (e : JavaEmitter)EmitCall(stat : St.ProcCall),NEW;
2807 VAR expr : Xp.CallX; (* the stat call expression *)
2808 BEGIN
2809 expr := stat.expr(Xp.CallX);
2810 IF (expr.kind = Xp.prCall) & expr.kid.isStdProc() THEN
2811 e.EmitStdProc(expr);
2812 ELSE
2813 e.PushCall(expr);
2814 END;
2815 END EmitCall;
2816
2817 (* ---------------------------------------------------- *)
2818
2819 PROCEDURE (e : JavaEmitter)EmitIf(stat : St.Choice; OUT ok : BOOLEAN),NEW;
2820 VAR out : Ju.JavaFile;
2821 high : INTEGER; (* Branch count. *)
2822 exLb : Ju.Label; (* Exit label *)
2823 nxtP : Ju.Label; (* Next predicate *)
2824 indx : INTEGER;
2825 live : BOOLEAN; (* then is live *)
2826 else : BOOLEAN; (* else not seen *)
2827 then : Sy.Stmt;
2828 pred : Sy.Expr;
2829 BEGIN
2830 ok := FALSE;
2831 out := e.outF;
2832 exLb := out.newLabel();
2833 else := FALSE;
2834 high := stat.preds.tide - 1;
2835 FOR indx := 0 TO high DO
2836 live := TRUE;
2837 pred := stat.preds.a[indx];
2838 then := stat.blocks.a[indx];
2839 nxtP := out.newLabel();
2840 IF pred = NIL THEN else := TRUE ELSE e.FallTrue(pred, nxtP) END;
2841 IF then # NIL THEN e.EmitStat(then, live) END;
2842 IF live THEN
2843 ok := TRUE;
2844 IF indx < high THEN out.CodeLb(Jvm.opc_goto, exLb) END;
2845 END;
2846 out.DefLab(nxtP);
2847 END;
2848 (*
2849 * If not ELSE has been seen, then control flow is still live!
2850 *)
2851 IF ~else THEN ok := TRUE END;
2852 out.DefLab(exLb);
2853 END EmitIf;
2854
2855 (* ---------------------------------------------------- *)
2856
2857 PROCEDURE (e : JavaEmitter)EmitRanges
2858 (locV : INTEGER; (* select Var *)
2859 stat : St.CaseSt; (* case stat *)
2860 minR : INTEGER; (* min rng-ix *)
2861 maxR : INTEGER; (* max rng-ix *)
2862 minI : INTEGER; (* min index *)
2863 maxI : INTEGER; (* max index *)
2864 labs : ARRAY OF Ju.Label),NEW;
2865 (* --------------------------------------------------------- *
2866 * This procedure emits the code for a single,
2867 * dense range of selector values in the label-list.
2868 * --------------------------------------------------------- *)
2869 VAR out : Ju.JavaFile;
2870 loIx : INTEGER; (* low selector value for dense range *)
2871 hiIx : INTEGER; (* high selector value for dense range *)
2872 rNum : INTEGER; (* total number of ranges in the group *)
2873 peel : INTEGER; (* max index of range to be peeled off *)
2874 indx : INTEGER;
2875 pos : INTEGER;
2876 rnge : St.Triple;
2877 dfLb : Ju.Label;
2878 lab : Ju.Label;
2879 BEGIN
2880 out := e.outF;
2881 dfLb := labs[0];
2882 rNum := maxR - minR + 1;
2883 rnge := stat.labels.a[minR];
2884 IF rNum = 1 THEN (* single range only *)
2885 lab := labs[rnge.ord+1];
2886 out.EmitOneRange(locV, rnge.loC, rnge.hiC, minI, maxI, dfLb, lab);
2887 ELSIF rNum < 4 THEN
2888 (*
2889 * Two or three ranges only.
2890 * Peel off the lowest of the ranges, and recurse.
2891 *)
2892 loIx := rnge.loC;
2893 peel := rnge.hiC;
2894 out.LoadLocal(locV, Bi.intTp);
2895 (*
2896 * There are a number of special cases
2897 * that can benefit from special code.
2898 *)
2899 IF loIx = peel THEN
2900 (*
2901 * A singleton. Leave minI unchanged, unless peel = minI.
2902 *)
2903 out.PushInt(peel);
2904 out.CodeLb(Jvm.opc_if_icmpeq, labs[rnge.ord + 1]);
2905 IF minI = peel THEN minI := peel+1 END;
2906 INC(minR);
2907 ELSIF loIx = minI THEN
2908 (*
2909 * A range starting at the minimum selector value.
2910 *)
2911 out.PushInt(peel);
2912 out.CodeLb(Jvm.opc_if_icmple, labs[rnge.ord + 1]);
2913 minI := peel+1;
2914 INC(minR);
2915 ELSE
2916 (*
2917 * We must peel the default range from minI to loIx.
2918 *)
2919 out.PushInt(loIx);
2920 out.CodeLb(Jvm.opc_if_icmplt, dfLb);
2921 minI := loIx; (* and minR is unchanged! *)
2922 END;
2923 e.EmitRanges(locV, stat, minR, maxR, minI, maxI, labs);
2924 ELSE
2925 (*
2926 * Four or more ranges. Emit a dispatch table.
2927 *)
2928 loIx := rnge.loC; (* low of min-range *)
2929 hiIx := stat.labels.a[maxR].hiC; (* high of max-range *)
2930 out.LoadLocal(locV, Bi.intTp);
2931 out.CodeSwitch(loIx, hiIx, dfLb);
2932 pos := 0;
2933 FOR indx := minR TO maxR DO
2934 rnge := stat.labels.a[indx];
2935 WHILE loIx < rnge.loC DO
2936 out.AddSwitchLab(labs[0],pos); INC(pos); INC(loIx);
2937 END;
2938 WHILE loIx <= rnge.hiC DO
2939 out.AddSwitchLab(labs[rnge.ord+1],pos); INC(pos); INC(loIx);
2940 END;
2941 END;
2942 out.LstDef(labs[0]);
2943 END;
2944 END EmitRanges;
2945
2946 (* ---------------------------------------------------- *)
2947
2948 PROCEDURE (e : JavaEmitter)EmitGroups
2949 (locV : INTEGER; (* select vOrd *)
2950 stat : St.CaseSt; (* case stat *)
2951 minG : INTEGER; (* min grp-indx *)
2952 maxG : INTEGER; (* max grp-indx *)
2953 minI : INTEGER; (* min index *)
2954 maxI : INTEGER; (* max index *)
2955 labs : ARRAY OF Ju.Label),NEW;
2956 (* --------------------------------------------------------- *
2957 * This function emits the branching code which sits on top
2958 * of the selection code for each dense range of case values.
2959 * --------------------------------------------------------- *)
2960 VAR out : Ju.JavaFile;
2961 newLb : Ju.Label;
2962 midPt : INTEGER;
2963 group : St.Triple;
2964 range : St.Triple;
2965 BEGIN
2966 IF maxG = -1 THEN RETURN; (* Empty case statment *)
2967 ELSIF minG = maxG THEN (* only one remaining dense group *)
2968 group := stat.groups.a[minG];
2969 e.EmitRanges(locV, stat, group.loC, group.hiC, minI, maxI, labs);
2970 ELSE
2971 (*
2972 * We must bifurcate the group range, and recurse.
2973 * We will split the value range at the lower limit
2974 * of the low-range of the upper half-group.
2975 *)
2976 midPt := (minG + maxG + 1) DIV 2;
2977 group := stat.groups.a[midPt];
2978 range := stat.labels.a[group.loC];
2979 (*
2980 * Test and branch at range.loC
2981 *)
2982 out := e.outF;
2983 newLb := out.newLabel();
2984 out.LoadLocal(locV, Bi.intTp);
2985 out.PushInt(range.loC);
2986 out.CodeLb(Jvm.opc_if_icmpge, newLb);
2987 (*
2988 * Recurse!
2989 *)
2990 e.EmitGroups(locV, stat, minG, midPt-1, minI, range.loC-1, labs);
2991 out.DefLab(newLb);
2992 e.EmitGroups(locV, stat, midPt, maxG, range.loC, maxI, labs);
2993 END;
2994 END EmitGroups;
2995
2996 (* ---------------------------------------------------- *)
2997
2998 PROCEDURE (e : JavaEmitter)EmitCase(stat : St.CaseSt; OUT ok : BOOLEAN),NEW;
2999 VAR out : Ju.JavaFile;
3000 indx : INTEGER;
3001 dfLb : Ju.Label;
3002 exLb : Ju.Label;
3003 selV : INTEGER;
3004 live : BOOLEAN;
3005 minI : INTEGER;
3006 maxI : INTEGER;
3007 labs : POINTER TO ARRAY OF Ju.Label;
3008 BEGIN
3009 (* ---------------------------------------------------------- *
3010 * CaseSt* = POINTER TO RECORD (Sy.Stmt)
3011 * (* ----------------------------------------- *
3012 * * kind- : INTEGER; (* tag for unions *)
3013 * * token* : S.Token; (* stmt first tok *)
3014 * * ----------------------------------------- *)
3015 * select* : Sy.Expr; (* case selector *)
3016 * chrSel* : BOOLEAN; (* ==> use chars *)
3017 * blocks* : Sy.StmtSeq; (* case bodies *)
3018 * elsBlk* : Sy.Stmt; (* elseCase | NIL *)
3019 * labels* : TripleSeq; (* label seqence *)
3020 * groups- : TripleSeq; (* dense groups *)
3021 * END;
3022 * --------------------------------------------------------- *
3023 * Notes on the semantics of this structure. "blocks" holds *
3024 * an ordered list of case statement code blocks. "labels" *
3025 * is a list of ranges, intially in textual order,with flds *
3026 * loC, hiC and ord corresponding to the range min, max and *
3027 * the selected block ordinal number. This list is later *
3028 * sorted on the loC value, and adjacent values merged if *
3029 * they select the same block. The "groups" list of triples *
3030 * groups ranges into dense subranges in the selector space *
3031 * The fields loC, hiC, and ord to hold the lower and upper *
3032 * indices into the labels list, and the number of non- *
3033 * default values in the group. Groups are guaranteed to *
3034 * have density (nonDefN / (max-min+1)) > DENSITY *
3035 * --------------------------------------------------------- *)
3036 ok := FALSE;
3037 out := e.outF;
3038 exLb := out.newLabel();
3039 NEW(labs,stat.blocks.tide+1);
3040 out.getLabelRange(labs);
3041 selV := out.newLocal();
3042
3043 IF stat.chrSel THEN
3044 minI := 0; maxI := ORD(MAX(CHAR));
3045 ELSE
3046 minI := MIN(INTEGER);
3047 maxI := MAX(INTEGER);
3048 END;
3049
3050 (*
3051 * Push the selector value, and save in local variable;
3052 *)
3053 e.PushValue(stat.select, stat.select.type);
3054 out.StoreLocal(selV, Bi.intTp);
3055 e.EmitGroups(selV, stat, 0, stat.groups.tide-1, minI, maxI, labs);
3056 (*
3057 * Now we emit the code for the cases.
3058 * If any branch returns, then exLb is reachable.
3059 *)
3060 FOR indx := 0 TO stat.blocks.tide-1 DO
3061 out.DefLab(labs[indx + 1]);
3062 e.EmitStat(stat.blocks.a[indx], live);
3063 IF live THEN
3064 ok := TRUE;
3065 out.CodeLb(Jvm.opc_goto, exLb);
3066 END;
3067 END;
3068 (*
3069 * Now we emit the code for the elespart.
3070 * If the elsepart returns then exLb is reachable.
3071 *)
3072 out.DefLabC(labs[0], "Default case");
3073 IF stat.elsBlk # NIL THEN
3074 e.EmitStat(stat.elsBlk, live);
3075 IF live THEN ok := TRUE END;
3076 ELSE
3077 out.CaseTrap(selV);
3078 END;
3079 out.ReleaseLocal(selV);
3080 IF ok THEN out.DefLabC(exLb, "Case exit label") END;
3081 END EmitCase;
3082
3083 (* ---------------------------------------------------- *)
3084
3085 PROCEDURE (e : JavaEmitter)
3086 EmitWhile(stat : St.TestLoop; OUT ok : BOOLEAN),NEW;
3087 VAR out : Ju.JavaFile;
3088 lpLb : Ju.Label;
3089 exLb : Ju.Label;
3090 BEGIN
3091 out := e.outF;
3092 lpLb := out.newLabel();
3093 exLb := out.newLabel();
3094 e.FallTrue(stat.test, exLb); (* goto exLb if eval false *)
3095 out.DefLabC(lpLb, "Loop header");
3096 e.EmitStat(stat.body, ok);
3097 IF ok THEN e.FallFalse(stat.test, lpLb) END;
3098 out.DefLabC(exLb, "Loop exit");
3099 END EmitWhile;
3100
3101 (* ---------------------------------------------------- *)
3102
3103 PROCEDURE (e : JavaEmitter)
3104 EmitRepeat(stat : St.TestLoop; OUT ok : BOOLEAN),NEW;
3105 VAR out : Ju.JavaFile;
3106 lpLb : Ju.Label;
3107 BEGIN
3108 out := e.outF;
3109 lpLb := out.newLabel();
3110 out.DefLabC(lpLb, "Loop header");
3111 e.EmitStat(stat.body, ok);
3112 IF ok THEN e.FallTrue(stat.test, lpLb) END; (* exit on eval true *)
3113 END EmitRepeat;
3114
3115 (* ---------------------------------------------------- *)
3116
3117 PROCEDURE (e : JavaEmitter)EmitFor(stat : St.ForLoop; OUT ok : BOOLEAN),NEW;
3118 (* ----------------------------------------------------------- *
3119 * This code has been split into the four cases:
3120 * - long control variable, counting up;
3121 * - long control variable, counting down;
3122 * - int control variable, counting up;
3123 * - int control variable, counting down;
3124 * Of course, it is possible to fold all of this, and have
3125 * tests everywhere, but the following is cleaner, and easier
3126 * to enhance in the future.
3127 *
3128 * Note carefully the use of ForLoop::isSimple(). It is
3129 * essential to use exactly the same function here as is
3130 * used by ForLoop::flowAttr() for initialization analysis.
3131 * If this were not the case, the verifier could barf.
3132 * ----------------------------------------------------------- *)
3133 PROCEDURE SetVar(cv : Id.AbVar; ln : BOOLEAN; ou : Ju.JavaFile);
3134 BEGIN
3135 WITH cv : Id.LocId DO (* check if implemented inside XHR *)
3136 IF Id.uplevA IN cv.locAtt THEN
3137 ou.XhrHandle(cv);
3138 IF ~ln THEN
3139 ou.Code(Jvm.opc_swap);
3140 ELSE
3141 ou.Code(Jvm.opc_dup_x2);
3142 ou.Code(Jvm.opc_pop);
3143 END;
3144 END;
3145 ELSE (* skip *)
3146 END;
3147 ou.PutVar(cv);
3148 END SetVar;
3149 (* ----------------------------------------------------------- *)
3150 PROCEDURE LongForUp(e: JavaEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
3151 VAR out : Ju.JavaFile;
3152 cVar : Id.AbVar;
3153 top1 : INTEGER;
3154 top2 : INTEGER;
3155 exLb : Ju.Label;
3156 lpLb : Ju.Label;
3157 step : LONGINT;
3158 smpl : BOOLEAN;
3159 BEGIN
3160 out := e.outF;
3161 lpLb := out.newLabel();
3162 exLb := out.newLabel();
3163 cVar := stat.cVar(Id.AbVar);
3164 step := longValue(stat.byXp);
3165 smpl := stat.isSimple();
3166 IF smpl THEN
3167 out.PushLong(longValue(stat.loXp));
3168 SetVar(cVar, TRUE, out);
3169 top1 := -1; (* keep the verifier happy! *)
3170 top2 := -1; (* keep the verifier happy! *)
3171 ELSE
3172 top1 := out.newLocal(); (* actually a pair of locals *)
3173 top2 := out.newLocal();
3174 e.PushValue(stat.hiXp, Bi.lIntTp);
3175 out.Code(Jvm.opc_dup2);
3176 out.StoreLocal(top1, Bi.lIntTp);
3177 e.PushValue(stat.loXp, Bi.lIntTp);
3178 out.Code(Jvm.opc_dup2);
3179 SetVar(cVar, TRUE, out);
3180 (*
3181 * The top test is NEVER inside the loop.
3182 *)
3183 e.DoCmp(Xp.lessT, exLb, Bi.lIntTp);
3184 END;
3185 out.DefLabC(lpLb, "Loop header");
3186 (*
3187 * Emit the code body.
3188 * Stack contents are (top) hi, ...
3189 * and exactly the same on the backedge.
3190 *)
3191 e.EmitStat(stat.body, ok);
3192 (*
3193 * If the body returns ... do an exit test.
3194 *)
3195 IF ok THEN
3196 IF smpl THEN
3197 out.PushLong(longValue(stat.hiXp));
3198 ELSE
3199 out.LoadLocal(top1, Bi.lIntTp);
3200 END;
3201 out.GetVar(cVar); (* (top) cv,hi *)
3202 out.PushLong(step);
3203 out.Code(Jvm.opc_ladd); (* (top) cv',hi *)
3204 out.Code(Jvm.opc_dup2); (* (top) cv',cv',hi *)
3205 SetVar(cVar, TRUE, out);
3206 e.DoCmp(Xp.greEq, lpLb, Bi.lIntTp);
3207 END;
3208 (*
3209 * The exit label.
3210 *)
3211 out.DefLabC(exLb, "Loop trailer");
3212 END LongForUp;
3213
3214 (* ----------------------------------------- *)
3215
3216 PROCEDURE LongForDn(e: JavaEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
3217 VAR out : Ju.JavaFile;
3218 cVar : Id.AbVar;
3219 top1 : INTEGER;
3220 top2 : INTEGER;
3221 exLb : Ju.Label;
3222 lpLb : Ju.Label;
3223 step : LONGINT;
3224 smpl : BOOLEAN;
3225 BEGIN
3226 out := e.outF;
3227 lpLb := out.newLabel();
3228 exLb := out.newLabel();
3229 cVar := stat.cVar(Id.AbVar);
3230 step := longValue(stat.byXp);
3231 smpl := stat.isSimple();
3232 IF smpl THEN
3233 out.PushLong(longValue(stat.loXp));
3234 SetVar(cVar, TRUE, out);
3235 top1 := -1; (* keep the verifier happy! *)
3236 top2 := -1; (* keep the verifier happy! *)
3237 ELSE
3238 top1 := out.newLocal(); (* actually a pair of locals *)
3239 top2 := out.newLocal();
3240 e.PushValue(stat.hiXp, Bi.lIntTp);
3241 out.Code(Jvm.opc_dup2);
3242 out.StoreLocal(top1, Bi.lIntTp);
3243 e.PushValue(stat.loXp, Bi.lIntTp);
3244 out.Code(Jvm.opc_dup2);
3245 SetVar(cVar, TRUE, out);
3246 (*
3247 * The top test is NEVER inside the loop.
3248 *)
3249 e.DoCmp(Xp.greT, exLb, Bi.lIntTp);
3250 END;
3251 out.DefLabC(lpLb, "Loop header");
3252 (*
3253 * Emit the code body.
3254 * Stack contents are (top) hi, ...
3255 * and exactly the same on the backedge.
3256 *)
3257 e.EmitStat(stat.body, ok);
3258 (*
3259 * If the body returns ... do an exit test.
3260 *)
3261 IF ok THEN
3262 IF smpl THEN
3263 out.PushLong(longValue(stat.hiXp));
3264 ELSE
3265 out.LoadLocal(top1, Bi.lIntTp);
3266 END;
3267 out.GetVar(cVar); (* (top) cv,hi *)
3268 out.PushLong(step);
3269 out.Code(Jvm.opc_ladd); (* (top) cv',hi *)
3270 out.Code(Jvm.opc_dup2); (* (top) cv',cv',hi *)
3271 SetVar(cVar, TRUE, out);
3272 e.DoCmp(Xp.lessEq, lpLb, Bi.lIntTp);
3273 END;
3274 (*
3275 * The exit label.
3276 *)
3277 out.DefLabC(exLb, "Loop trailer");
3278 END LongForDn;
3279
3280 (* ----------------------------------------- *)
3281
3282 PROCEDURE IntForUp(e: JavaEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
3283 VAR out : Ju.JavaFile;
3284 cVar : Id.AbVar;
3285 topV : INTEGER;
3286 exLb : Ju.Label;
3287 lpLb : Ju.Label;
3288 step : INTEGER;
3289 smpl : BOOLEAN;
3290 BEGIN
3291 (*
3292 * This is the common case, so we work a bit harder.
3293 *)
3294 out := e.outF;
3295 lpLb := out.newLabel();
3296 exLb := out.newLabel();
3297 cVar := stat.cVar(Id.AbVar);
3298 step := intValue(stat.byXp);
3299 smpl := stat.isSimple();
3300 IF smpl THEN
3301 out.PushInt(intValue(stat.loXp));
3302 SetVar(cVar, FALSE, out);
3303 topV := -1; (* keep the verifier happy! *)
3304 ELSE
3305 topV := out.newLocal();
3306 e.PushValue(stat.hiXp, Bi.intTp);
3307 out.Code(Jvm.opc_dup);
3308 out.StoreLocal(topV, Bi.intTp);
3309 e.PushValue(stat.loXp, Bi.intTp);
3310 out.Code(Jvm.opc_dup);
3311 SetVar(cVar, FALSE, out);
3312 (*
3313 * The top test is NEVER inside the loop.
3314 *)
3315 e.DoCmp(Xp.lessT, exLb, Bi.intTp);
3316 END;
3317 out.DefLabC(lpLb, "Loop header");
3318 (*
3319 * Emit the code body.
3320 *)
3321 e.EmitStat(stat.body, ok);
3322 (*
3323 * If the body returns ... do an exit test.
3324 *)
3325 IF ok THEN
3326 IF smpl THEN
3327 out.PushInt(intValue(stat.hiXp));
3328 ELSE
3329 out.LoadLocal(topV, Bi.intTp);
3330 END;
3331 out.GetVar(cVar); (* (top) cv,hi *)
3332 out.PushInt(step);
3333 out.Code(Jvm.opc_iadd); (* (top) cv',hi *)
3334 out.Code(Jvm.opc_dup); (* (top) cv',cv',hi *)
3335 SetVar(cVar, FALSE, out);
3336 e.DoCmp(Xp.greEq, lpLb, Bi.intTp);
3337 END;
3338 (*
3339 * The exit label.
3340 *)
3341 out.DefLabC(exLb, "Loop trailer");
3342 END IntForUp;
3343
3344 (* ----------------------------------------- *)
3345
3346 PROCEDURE IntForDn(e: JavaEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
3347 VAR out : Ju.JavaFile;
3348 cVar : Id.AbVar;
3349 topV : INTEGER;
3350 exLb : Ju.Label;
3351 lpLb : Ju.Label;
3352 step : INTEGER;
3353 smpl : BOOLEAN;
3354 BEGIN
3355 out := e.outF;
3356 lpLb := out.newLabel();
3357 exLb := out.newLabel();
3358 cVar := stat.cVar(Id.AbVar);
3359 step := intValue(stat.byXp);
3360 topV := out.newLocal();
3361 smpl := stat.isSimple();
3362 IF smpl THEN
3363 out.PushInt(intValue(stat.loXp));
3364 SetVar(cVar, FALSE, out);
3365 topV := -1; (* keep the verifier happy! *)
3366 ELSE
3367 e.PushValue(stat.hiXp, Bi.intTp);
3368 out.Code(Jvm.opc_dup);
3369 out.StoreLocal(topV, Bi.intTp);
3370 e.PushValue(stat.loXp, Bi.intTp);
3371 out.Code(Jvm.opc_dup);
3372 SetVar(cVar, FALSE, out);
3373 (*
3374 * The top test is NEVER inside the loop.
3375 *)
3376 e.DoCmp(Xp.greT, exLb, Bi.intTp);
3377 END;
3378 out.DefLabC(lpLb, "Loop header");
3379 (*
3380 * Emit the code body.
3381 *)
3382 e.EmitStat(stat.body, ok);
3383 (*
3384 * If the body returns ... do an exit test.
3385 *)
3386 IF ok THEN
3387 IF smpl THEN
3388 out.PushInt(intValue(stat.hiXp));
3389 ELSE
3390 out.LoadLocal(topV, Bi.intTp);
3391 END;
3392 out.GetVar(cVar); (* (top) cv,hi *)
3393 out.PushInt(step);
3394 out.Code(Jvm.opc_iadd); (* (top) cv',hi *)
3395 out.Code(Jvm.opc_dup); (* (top) cv',cv',hi *)
3396 SetVar(cVar, FALSE, out);
3397 e.DoCmp(Xp.lessEq, lpLb, Bi.intTp);
3398 END;
3399 (*
3400 * The exit label.
3401 *)
3402 out.DefLabC(exLb, "Loop trailer");
3403 END IntForDn;
3404
3405 (* ----------------------------------------- *)
3406 BEGIN (* body of EmitFor *)
3407 IF stat.cVar.type.isLongType() THEN
3408 IF longValue(stat.byXp) > 0 THEN LongForUp(e, stat, ok);
3409 ELSE LongForDn(e, stat, ok);
3410 END;
3411 ELSE
3412 IF longValue(stat.byXp) > 0 THEN IntForUp(e, stat, ok);
3413 ELSE IntForDn(e, stat, ok);
3414 END;
3415 END;
3416 END EmitFor;
3417
3418 (* ---------------------------------------------------- *)
3419
3420 PROCEDURE (e : JavaEmitter)
3421 EmitLoop(stat : St.TestLoop; OUT ok : BOOLEAN),NEW;
3422 VAR out : Ju.JavaFile;
3423 lpLb : Ju.Label;
3424 tmpLb : Ju.Label;
3425 BEGIN
3426 out := e.outF;
3427 lpLb := out.newLabel();
3428 tmpLb := currentLoopLabel;
3429 currentLoopLabel := out.newLabel();
3430 out.DefLabC(lpLb, "Loop header");
3431 e.EmitStat(stat.body, ok);
3432 IF ok THEN out.CodeLb(Jvm.opc_goto, lpLb) END;
3433 out.DefLabC(currentLoopLabel, "Loop exit");
3434 currentLoopLabel := tmpLb;
3435 END EmitLoop;
3436
3437 (* ---------------------------------------------------- *)
3438
3439 PROCEDURE (e : JavaEmitter)EmitWith(stat : St.Choice; OUT ok : BOOLEAN),NEW;
3440 VAR out : Ju.JavaFile;
3441 high : INTEGER; (* Branch count. *)
3442 exLb : Ju.Label; (* Exit label *)
3443 nxtP : Ju.Label; (* Next predicate *)
3444 indx : INTEGER;
3445 live : BOOLEAN;
3446 then : Sy.Stmt;
3447 pred : Sy.Expr;
3448 tVar : Id.LocId;
3449 (* --------------------------- *)
3450 PROCEDURE WithTest(je : JavaEmitter;
3451 os : Ju.JavaFile;
3452 pr : Sy.Expr;
3453 nx : Ju.Label;
3454 tm : INTEGER);
3455 VAR bX : Xp.BinaryX;
3456 ty : Sy.Type;
3457 BEGIN
3458 bX := pr(Xp.BinaryX);
3459 ty := bX.rKid(Xp.IdLeaf).ident.type;
3460 je.PushValue(bX.lKid, bX.lKid.type);
3461 os.CodeT(Jvm.opc_instanceof, ty);
3462 os.CodeLb(Jvm.opc_ifeq, nx);
3463 (*
3464 * We must also generate a checkcast, because the verifier
3465 * seems to understand the typeflow consequences of the
3466 * checkcast bytecode, but not instanceof.
3467 *)
3468 je.PushValue(bX.lKid, bX.lKid.type);
3469 os.CodeT(Jvm.opc_checkcast, ty);
3470 os.StoreLocal(tm, ty);
3471 END WithTest;
3472 (* --------------------------- *)
3473 BEGIN
3474 tVar := NIL;
3475 pred := NIL;
3476 ok := FALSE;
3477 out := e.outF;
3478 exLb := out.newLabel();
3479 high := stat.preds.tide - 1;
3480 FOR indx := 0 TO high DO
3481 live := TRUE;
3482 pred := stat.preds.a[indx];
3483 then := stat.blocks.a[indx];
3484 tVar := stat.temps.a[indx](Id.LocId);
3485 nxtP := out.newLabel();
3486 IF pred # NIL THEN
3487 tVar.varOrd := out.newLocal();
3488 WithTest(e, out, pred, nxtP, tVar.varOrd);
3489 END;
3490 IF then # NIL THEN e.EmitStat(then, live) END;
3491 IF live THEN
3492 ok := TRUE;
3493 (*
3494 * If this is not the else case, skip over the
3495 * later cases, or jump over the WITH ELSE trap.
3496 *)
3497 IF pred # NIL THEN out.CodeLb(Jvm.opc_goto, exLb) END;
3498 END;
3499 IF tVar # NIL THEN out.ReleaseLocal(tVar.varOrd) END;
3500 out.DefLab(nxtP);
3501 END;
3502 IF pred # NIL THEN out.WithTrap(pred(Xp.BinaryX).lKid(Xp.IdLeaf).ident) END;
3503 out.DefLab(exLb);
3504 END EmitWith;
3505
3506 (* ---------------------------------------------------- *)
3507
3508 PROCEDURE (e : JavaEmitter)EmitExit(stat : St.ExitSt),NEW;
3509 BEGIN
3510 e.outF.CodeLb(Jvm.opc_goto, currentLoopLabel);
3511 END EmitExit;
3512
3513 (* ---------------------------------------------------- *)
3514
3515 PROCEDURE (e : JavaEmitter)EmitReturn(stat : St.Return),NEW;
3516 VAR out : Ju.JavaFile;
3517 pId : Id.Procs;
3518 ret : Sy.Type;
3519 BEGIN
3520 out := e.outF;
3521 pId := out.getScope()(Id.Procs);
3522 (*
3523 * Because the return slot may be used for the first
3524 * OUT or VAR parameter, the real return type might
3525 * be different to that shown in the formal type.
3526 * FixOutPars() returns this real return type.
3527 *)
3528 IF (stat.retX # NIL) &
3529 (pId.kind # Id.ctorP) THEN e.PushValue(stat.retX, stat.retX.type) END;
3530 out.FixOutPars(pId, ret);
3531 out.Return(ret);
3532 END EmitReturn;
3533
3534 (* ---------------------------------------------------- *)
3535
3536 PROCEDURE (e : JavaEmitter)EmitBlock(stat : St.Block; OUT ok : BOOLEAN),NEW;
3537 VAR index, limit : INTEGER;
3538 BEGIN
3539 ok := TRUE;
3540 index := 0;
3541 limit := stat.sequ.tide;
3542 WHILE ok & (index < limit) DO
3543 e.EmitStat(stat.sequ.a[index], ok);
3544 INC(index);
3545 END;
3546 END EmitBlock;
3547
3548 (* ---------------------------------------------------- *)
3549 (* ---------------------------------------------------- *)
3550
3551 PROCEDURE (e : JavaEmitter)EmitStat(stat : Sy.Stmt; OUT ok : BOOLEAN),NEW;
3552 VAR depth : INTEGER;
3553 BEGIN
3554 IF (stat = NIL) OR (stat.kind = St.emptyS) THEN ok := TRUE; RETURN END;
3555 IF stat.kind # St.blockS THEN
3556 e.outF.Line(stat.token.lin);
3557 END;
3558 depth := e.outF.getDepth();
3559 CASE stat.kind OF
3560 | St.assignS : e.EmitAssign(stat(St.Assign)); ok := TRUE;
3561 | St.procCall : e.EmitCall(stat(St.ProcCall)); ok := TRUE;
3562 | St.ifStat : e.EmitIf(stat(St.Choice), ok);
3563 | St.caseS : e.EmitCase(stat(St.CaseSt), ok);
3564 | St.whileS : e.EmitWhile(stat(St.TestLoop), ok);
3565 | St.repeatS : e.EmitRepeat(stat(St.TestLoop), ok);
3566 | St.forStat : e.EmitFor(stat(St.ForLoop), ok);
3567 | St.loopS : e.EmitLoop(stat(St.TestLoop), ok);
3568 | St.withS : e.EmitWith(stat(St.Choice), ok);
3569 | St.exitS : e.EmitExit(stat(St.ExitSt)); ok := TRUE;
3570 | St.returnS : e.EmitReturn(stat(St.Return)); ok := FALSE;
3571 | St.blockS : e.EmitBlock(stat(St.Block), ok);
3572 END;
3573 e.outF.setDepth(depth);
3574 END EmitStat;
3575
3576
3577 (* ============================================================ *)
3578 (* ============================================================ *)
3579 END JavaMaker.
3580 (* ============================================================ *)
3581 (* ============================================================ *)
[FORK] Old GPCP with patches
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024