diff options
Diffstat (limited to 'src/runtime')
49 files changed, 40315 insertions, 0 deletions
diff --git a/src/runtime/Makefile b/src/runtime/Makefile new file mode 100644 index 0000000..ffa63e8 --- /dev/null +++ b/src/runtime/Makefile @@ -0,0 +1,514 @@ +# Makefile for the Icon run-time system. + +include ../../Makedefs + + +HDRS = ../h/define.h ../h/config.h ../h/typedefs.h ../h/monitor.h\ + ../h/cstructs.h ../h/cpuconf.h ../h/grttin.h\ + ../h/rmacros.h ../h/rexterns.h ../h/rstructs.h \ + ../h/rproto.h ../h/mproto.h ../h/sys.h + +GRAPHICSHDRS = ../h/graphics.h ../h/xwin.h ../h/mswin.h + +COBJS = ../common/long.o ../common/time.o \ + ../common/rswitch.o ../common/xwindow.o \ + ../common/alloc.o ../common/filepart.o ../common/munix.o + + +default: iconx +all: iconx comp_all + +$(COBJS): + cd ../common; $(MAKE) + + +#################################################################### +# +# Make entries for iconx +# + +XOBJS = xcnv.o xdata.o xdef.o xerrmsg.o xextcall.o xfconv.o xfload.o xfmath.o\ + xfmisc.o xfmonitr.o xfscan.o xfstr.o xfstranl.o xfstruct.o xfsys.o\ + xfwindow.o ximain.o ximisc.o xinit.o xinterp.o xinvoke.o\ + xkeyword.o xlmisc.o xoarith.o xoasgn.o xocat.o xocomp.o\ + xomisc.o xoref.o xoset.o xovalue.o xralc.o xrcoexpr.o xrcomp.o\ + xrdebug.o xrlrgint.o xrmemmgt.o xrmisc.o xrstruct.o xrsys.o\ + xrwinrsc.o xrwinsys.o xrwindow.o xrcolor.o xrimage.o + +OBJS = $(XOBJS) $(COBJS) + +iconx: $(OBJS) + cd ../common; $(MAKE) + $(CC) $(RLINK) -o iconx $(OBJS) $(XL) $(RLIBS) $(TL) + cp iconx ../../bin + strip $(SFLAGS) ../../bin/iconx$(EXE) + +xcnv.o: cnv.r $(HDRS) + ../../bin/rtt -x cnv.r + $(CC) -c $(CFLAGS) xcnv.c + rm xcnv.c + +xdata.o: data.r $(HDRS) ../h/kdefs.h ../h/fdefs.h ../h/odefs.h + ../../bin/rtt -x data.r + $(CC) -c $(CFLAGS) xdata.c + rm xdata.c + +xdef.o: def.r $(HDRS) + ../../bin/rtt -x def.r + $(CC) -c $(CFLAGS) xdef.c + rm xdef.c + +xerrmsg.o: errmsg.r $(HDRS) + ../../bin/rtt -x errmsg.r + $(CC) -c $(CFLAGS) xerrmsg.c + rm xerrmsg.c + +xextcall.o: extcall.r $(HDRS) + ../../bin/rtt -x extcall.r + $(CC) -c $(CFLAGS) xextcall.c + rm xextcall.c + +xfconv.o: fconv.r $(HDRS) + ../../bin/rtt -x fconv.r + $(CC) -c $(CFLAGS) xfconv.c + rm xfconv.c + +xfload.o: fload.r $(HDRS) + ../../bin/rtt -x fload.r + $(CC) -c $(CFLAGS) xfload.c + rm xfload.c + +xfmath.o: fmath.r $(HDRS) + ../../bin/rtt -x fmath.r + $(CC) -c $(CFLAGS) xfmath.c + rm xfmath.c + +xfmisc.o: fmisc.r $(HDRS) + ../../bin/rtt -x fmisc.r + $(CC) -c $(CFLAGS) xfmisc.c + rm xfmisc.c + +xfmonitr.o: fmonitr.r $(HDRS) + ../../bin/rtt -x fmonitr.r + $(CC) -c $(CFLAGS) xfmonitr.c + rm xfmonitr.c + +xfscan.o: fscan.r $(HDRS) + ../../bin/rtt -x fscan.r + $(CC) -c $(CFLAGS) xfscan.c + rm xfscan.c + +xfstr.o: fstr.r $(HDRS) + ../../bin/rtt -x fstr.r + $(CC) -c $(CFLAGS) xfstr.c + rm xfstr.c + +xfstranl.o: fstranl.r $(HDRS) + ../../bin/rtt -x fstranl.r + $(CC) -c $(CFLAGS) xfstranl.c + rm xfstranl.c + +xfstruct.o: fstruct.r $(HDRS) + ../../bin/rtt -x fstruct.r + $(CC) -c $(CFLAGS) xfstruct.c + rm xfstruct.c + +xfsys.o: fsys.r $(HDRS) + ../../bin/rtt -x fsys.r + $(CC) -c $(CFLAGS) xfsys.c + rm xfsys.c + +xfwindow.o: fwindow.r $(HDRS) $(GRAPHICSHDRS) + ../../bin/rtt -x fwindow.r + $(CC) -c $(CFLAGS) xfwindow.c + rm xfwindow.c + +ximain.o: imain.r $(HDRS) ../h/version.h + ../../bin/rtt -x imain.r + $(CC) -c $(CFLAGS) ximain.c + rm ximain.c + +ximisc.o: imisc.r $(HDRS) + ../../bin/rtt -x imisc.r + $(CC) -c $(CFLAGS) ximisc.c + rm ximisc.c + +xinit.o: init.r $(HDRS) ../h/odefs.h ../h/version.h + ../../bin/rtt -x init.r + $(CC) -c $(CFLAGS) xinit.c + rm xinit.c + +xinterp.o: interp.r $(HDRS) + ../../bin/rtt -x interp.r + $(CC) -c $(CFLAGS) xinterp.c + rm xinterp.c + +xinvoke.o: invoke.r $(HDRS) + ../../bin/rtt -x invoke.r + $(CC) -c $(CFLAGS) xinvoke.c + rm xinvoke.c + +xkeyword.o: keyword.r $(HDRS) ../h/features.h ../h/version.h + ../../bin/rtt -x keyword.r + $(CC) -c $(CFLAGS) xkeyword.c + rm xkeyword.c + +xlmisc.o: lmisc.r $(HDRS) + ../../bin/rtt -x lmisc.r + $(CC) -c $(CFLAGS) xlmisc.c + rm xlmisc.c + +xoarith.o: oarith.r $(HDRS) + ../../bin/rtt -x oarith.r + $(CC) -c $(CFLAGS) xoarith.c + rm xoarith.c + +xoasgn.o: oasgn.r $(HDRS) + ../../bin/rtt -x oasgn.r + $(CC) -c $(CFLAGS) xoasgn.c + rm xoasgn.c + +xocat.o: ocat.r $(HDRS) + ../../bin/rtt -x ocat.r + $(CC) -c $(CFLAGS) xocat.c + rm xocat.c + +xocomp.o: ocomp.r $(HDRS) + ../../bin/rtt -x ocomp.r + $(CC) -c $(CFLAGS) xocomp.c + rm xocomp.c + +xomisc.o: omisc.r $(HDRS) + ../../bin/rtt -x omisc.r + $(CC) -c $(CFLAGS) xomisc.c + rm xomisc.c + +xoref.o: oref.r $(HDRS) + ../../bin/rtt -x oref.r + $(CC) -c $(CFLAGS) xoref.c + rm xoref.c + +xoset.o: oset.r $(HDRS) + ../../bin/rtt -x oset.r + $(CC) -c $(CFLAGS) xoset.c + rm xoset.c + +xovalue.o: ovalue.r $(HDRS) + ../../bin/rtt -x ovalue.r + $(CC) -c $(CFLAGS) xovalue.c + rm xovalue.c + +xralc.o: ralc.r $(HDRS) + ../../bin/rtt -x ralc.r + $(CC) -c $(CFLAGS) xralc.c + rm xralc.c + +xrcoexpr.o: rcoexpr.r $(HDRS) + ../../bin/rtt -x rcoexpr.r + $(CC) -c $(CFLAGS) xrcoexpr.c + rm xrcoexpr.c + +xrcomp.o: rcomp.r $(HDRS) + ../../bin/rtt -x rcomp.r + $(CC) -c $(CFLAGS) xrcomp.c + rm xrcomp.c + +xrdebug.o: rdebug.r $(HDRS) + ../../bin/rtt -x rdebug.r + $(CC) -c $(CFLAGS) xrdebug.c + rm xrdebug.c + +xrlrgint.o: rlrgint.r $(HDRS) + ../../bin/rtt -x rlrgint.r + $(CC) -c $(CFLAGS) xrlrgint.c + rm xrlrgint.c + +xrmemmgt.o: rmemmgt.r $(HDRS) + ../../bin/rtt -x rmemmgt.r + $(CC) -c $(CFLAGS) xrmemmgt.c + rm xrmemmgt.c + +xrmisc.o: rmisc.r $(HDRS) + ../../bin/rtt -x rmisc.r + $(CC) -c $(CFLAGS) xrmisc.c + rm xrmisc.c + +xrstruct.o: rstruct.r $(HDRS) + ../../bin/rtt -x rstruct.r + $(CC) -c $(CFLAGS) xrstruct.c + rm xrstruct.c + +xrsys.o: rsys.r $(HDRS) + ../../bin/rtt -x rsys.r + $(CC) -c $(CFLAGS) xrsys.c + rm xrsys.c + +xrwinrsc.o: rwinrsc.r $(HDRS) $(GRAPHICSHDRS) rxrsc.ri + ../../bin/rtt -x rwinrsc.r + $(CC) -c $(CFLAGS) xrwinrsc.c + rm xrwinrsc.c + +xrwinsys.o: rwinsys.r $(HDRS) $(GRAPHICSHDRS) rxwin.ri + ../../bin/rtt -x rwinsys.r + $(CC) -c $(CFLAGS) xrwinsys.c + rm xrwinsys.c + +xrwindow.o: rwindow.r $(HDRS) $(GRAPHICSHDRS) + ../../bin/rtt -x rwindow.r + $(CC) -c $(CFLAGS) xrwindow.c + rm xrwindow.c + +xrcolor.o: rcolor.r $(HDRS) $(GRAPHICSHDRS) + ../../bin/rtt -x rcolor.r + $(CC) -c $(CFLAGS) xrcolor.c + rm xrcolor.c + +xrimage.o: rimage.r $(HDRS) $(GRAPHICSHDRS) + ../../bin/rtt -x rimage.r + $(CC) -c $(CFLAGS) xrimage.c + rm xrimage.c + + +#################################################################### +# +# Make entries for the compiler library +# + +comp_all: $(COBJS) db_lib + +db_lib: rt.db rt.a + +# +# if rt.db is missing or any header files have been updated, recreate +# rt.db from scratch along with the .o files. +# +rt.db: $(HDRS) + rm -f rt.db rt.a + ../../bin/rtt cnv.r data.r def.r errmsg.r fconv.r fload.r fmath.r\ + fmisc.r fmonitr.r fscan.r fstr.r fstranl.r fstruct.r\ + fsys.r fwindow.r init.r invoke.r keyword.r\ + lmisc.r oarith.r oasgn.r ocat.r ocomp.r omisc.r\ + oref.r oset.r ovalue.r ralc.r rcoexpr.r rcomp.r\ + rdebug.r rlrgint.r rmemmgt.r rmisc.r rstruct.r\ + rsys.r rwinrsc.r rwinsys.r rwindow.r rcolor.r rimage.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +rt.a: ../common/rswitch.o ../common/long.o ../common/time.o\ + cnv.o data.o def.o errmsg.o fconv.o fload.o fmath.o fmisc.o fmonitr.o \ + fscan.o fstr.o fstranl.o fstruct.o fsys.o fwindow.o init.o invoke.o\ + keyword.o lmisc.o oarith.o oasgn.o ocat.o ocomp.o omisc.o oref.o oset.o\ + ovalue.o ralc.o rcoexpr.o rcomp.o rdebug.o rlrgint.o rmemmgt.o\ + rmisc.o rstruct.o rsys.o rwinrsc.o rwinsys.o\ + rwindow.o rcolor.o rimage.o ../common/xwindow.o ../common/alloc.o + rm -f rt.a + ar qc rt.a `sed 's/$$/.o/' rttcur.lst` ../common/rswitch.o\ + ../common/long.o ../common/time.o\ + ../common/xwindow.o ../common/alloc.o + ranlib rt.a 2>/dev/null || : + cp -p rt.a rt.db ../common/dlrgint.o ../../bin + +cnv.o: cnv.r $(HDRS) + ../../bin/rtt cnv.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +data.o: data.r $(HDRS) + ../../bin/rtt data.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +def.o: def.r $(HDRS) + ../../bin/rtt def.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +errmsg.o: errmsg.r $(HDRS) + ../../bin/rtt errmsg.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +fconv.o: fconv.r $(HDRS) + ../../bin/rtt fconv.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +fload.o: fload.r $(HDRS) + ../../bin/rtt fload.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +fmath.o: fmath.r $(HDRS) + ../../bin/rtt fmath.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +fmisc.o: fmisc.r $(HDRS) + ../../bin/rtt fmisc.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +fmonitr.o: fmonitr.r $(HDRS) + ../../bin/rtt fmonitr.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +fscan.o: fscan.r $(HDRS) + ../../bin/rtt fscan.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +fstr.o: fstr.r $(HDRS) + ../../bin/rtt fstr.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +fstranl.o: fstranl.r $(HDRS) + ../../bin/rtt fstranl.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +fstruct.o: fstruct.r $(HDRS) + ../../bin/rtt fstruct.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +fsys.o: fsys.r $(HDRS) + ../../bin/rtt fsys.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +fwindow.o: fwindow.r $(HDRS) $(GRAPHICSHDRS) + ../../bin/rtt fwindow.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +init.o: init.r $(HDRS) + ../../bin/rtt init.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +invoke.o: invoke.r $(HDRS) + ../../bin/rtt invoke.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +keyword.o: keyword.r $(HDRS) + ../../bin/rtt keyword.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +lmisc.o: lmisc.r $(HDRS) + ../../bin/rtt lmisc.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +oarith.o: oarith.r $(HDRS) + ../../bin/rtt oarith.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +oasgn.o: oasgn.r $(HDRS) + ../../bin/rtt oasgn.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +ocat.o: ocat.r $(HDRS) + ../../bin/rtt ocat.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +ocomp.o: ocomp.r $(HDRS) + ../../bin/rtt ocomp.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +omisc.o: omisc.r $(HDRS) + ../../bin/rtt omisc.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +oref.o: oref.r $(HDRS) + ../../bin/rtt oref.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +oset.o: oset.r $(HDRS) + ../../bin/rtt oset.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +ovalue.o: ovalue.r $(HDRS) + ../../bin/rtt ovalue.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +ralc.o: ralc.r $(HDRS) + ../../bin/rtt ralc.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +rcoexpr.o: rcoexpr.r $(HDRS) + ../../bin/rtt rcoexpr.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +rcomp.o: rcomp.r $(HDRS) + ../../bin/rtt rcomp.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +rdebug.o: rdebug.r $(HDRS) + ../../bin/rtt rdebug.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +rlrgint.o: rlrgint.r $(HDRS) + ../../bin/rtt rlrgint.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +rmemmgt.o: rmemmgt.r $(HDRS) + ../../bin/rtt rmemmgt.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +rmisc.o: rmisc.r $(HDRS) + ../../bin/rtt rmisc.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +rstruct.o: rstruct.r $(HDRS) + ../../bin/rtt rstruct.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +rsys.o: rsys.r $(HDRS) + ../../bin/rtt rsys.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +rwinrsc.o: rwinrsc.r $(HDRS) $(GRAPHICSHDRS) + ../../bin/rtt rwinrsc.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +rwinsys.o: rwinsys.r $(HDRS) $(GRAPHICSHDRS) + ../../bin/rtt rwinsys.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +rwindow.o: rwindow.r $(HDRS) $(GRAPHICSHDRS) + ../../bin/rtt rwindow.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +rcolor.o: rcolor.r $(HDRS) $(GRAPHICSHDRS) + ../../bin/rtt rcolor.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` + +rimage.o: rimage.r $(HDRS) $(GRAPHICSHDRS) + ../../bin/rtt rimage.r + $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` + rm `sed 's/$$/.c/' rttcur.lst` diff --git a/src/runtime/cnv.r b/src/runtime/cnv.r new file mode 100644 index 0000000..23e1767 --- /dev/null +++ b/src/runtime/cnv.r @@ -0,0 +1,1157 @@ +/* + * cnv.r -- Conversion routines: + * + * cnv_c_dbl, cnv_c_int, cnv_c_str, cnv_cset, cnv_ec_int, + * cnv_eint, cnv_int, cnv_real, cnv_str, cnv_tcset, cnv_tstr, deref, + * getdbl, strprc, bi_strprc + * + * Service routines: itos, ston, radix, cvpos + * + * Philosophy: certain redundancy is present which could be avoided, + * and nested conversion calls are avoided due to the importance of + * minimizing these routines' costs. + * + * Assumed: the C compiler must handle assignments of C integers to + * C double variables and vice-versa. Hopefully production C compilers + * have managed to eliminate bugs related to these assignments. + * + * Note: calls beginning with EV are empty macros unless EventMon + * is defined. + */ + +#define tonum(c) (isdigit(c) ? (c)-'0' : 10+(((c)|(040))-'a')) + +/* + * Prototypes for static functions. + */ +static void cstos (unsigned int *cs, dptr dp, char *s); +static void itos (C_integer num, dptr dp, char *s); +static int ston (dptr sp, union numeric *result); +static int tmp_str (char *sbuf, dptr s, dptr d); + +/* + * cnv_c_dbl - cnv:C_double(*s, *d), convert a value directly into a C double + */ +int cnv_c_dbl(s, d) +dptr s; +double *d; + { + tended struct descrip result, cnvstr; + char sbuf[MaxCvtLen]; + union numeric numrc; + + type_case *s of { + real: { + GetReal(s, *d); + return 1; + } + integer: { + +#ifdef LargeInts + if (Type(*s) == T_Lrgint) + *d = bigtoreal(s); + else +#endif /* LargeInts */ + + *d = IntVal(*s); + + return 1; + } + string: { + /* fall through */ + } + cset: { + tmp_str(sbuf, s, &cnvstr); + s = &cnvstr; + } + default: { + return 0; + } + } + + /* + * s is now an string. + */ + switch( ston(s, &numrc) ) { + case T_Integer: + *d = numrc.integer; + return 1; + +#ifdef LargeInts + case T_Lrgint: + result.dword = D_Lrgint; + BlkLoc(result) = (union block *)numrc.big; + *d = bigtoreal(&result); + return 1; +#endif /* LargeInts */ + + case T_Real: + *d = numrc.real; + return 1; + default: + return 0; + } + } + +/* + * cnv_c_int - cnv:C_integer(*s, *d), convert a value directly into a C_integer + */ +int cnv_c_int(s, d) +dptr s; +C_integer *d; + { + tended struct descrip cnvstr, result; + union numeric numrc; + char sbuf[MaxCvtLen]; + + type_case *s of { + integer: { + +#ifdef LargeInts + if (Type(*s) == T_Lrgint) { + return 0; + } +#endif /* LargeInts */ + + *d = IntVal(*s); + return 1; + } + real: { + double dbl; + GetReal(s,dbl); + if (dbl > MaxLong || dbl < MinLong) { + return 0; + } + *d = dbl; + return 1; + } + string: { + /* fall through */ + } + cset: { + tmp_str(sbuf, s, &cnvstr); + s = &cnvstr; + } + default: { + return 0; + } + } + + /* + * s is now a string. + */ + switch( ston(s, &numrc) ) { + case T_Integer: { + *d = numrc.integer; + return 1; + } + case T_Real: { + double dbl = numrc.real; + if (dbl > MaxLong || dbl < MinLong) { + return 0; + } + *d = dbl; + return 1; + } + default: + return 0; + } + } + +/* + * cnv_c_str - cnv:C_string(*s, *d), convert a value into a C (and Icon) string + */ +int cnv_c_str(s, d) +dptr s; +dptr d; + { + /* + * Get the string to the end of the string region and append a '\0'. + */ + + if (!is:string(*s)) { + if (!cnv_str(s, d)) { + return 0; + } + } + else { + *d = *s; + } + + /* + * See if the end of d is already at the end of the string region + * and there is room for one more byte. + */ + if ((StrLoc(*d) + StrLen(*d) == strfree) && (strfree != strend)) { + Protect(alcstr("\0", 1), fatalerr(0,NULL)); + ++StrLen(*d); + } + else { + register word slen = StrLen(*d); + register char *sp, *dp; + Protect(dp = alcstr(NULL,slen+1), fatalerr(0,NULL)); + StrLen(*d) = StrLen(*d)+1; + sp = StrLoc(*d); + StrLoc(*d) = dp; + while (slen-- > 0) + *dp++ = *sp++; + *dp = '\0'; + } + + return 1; + } + +/* + * cnv_cset - cnv:cset(*s, *d), convert to a cset + */ +int cnv_cset(s, d) +dptr s, d; + { + tended struct descrip str; + char sbuf[MaxCvtLen]; + register C_integer l; + register char *s1; /* does not need to be tended */ + + EVValD(s, E_Aconv); + EVValD(&csetdesc, E_Tconv); + + if (is:cset(*s)) { + *d = *s; + EVValD(s, E_Nconv); + return 1; + } + /* + * convert to a string and then add its contents to the cset + */ + if (tmp_str(sbuf, s, &str)) { + Protect(BlkLoc(*d) = (union block *)alccset(), fatalerr(0,NULL)); + d->dword = D_Cset; + s1 = StrLoc(str); + l = StrLen(str); + while(l--) { + Setb(*s1, *d); + s1++; + } + EVValD(d, E_Sconv); + return 1; + } + else { + EVValD(s, E_Fconv); + return 0; + } + } + +/* + * cnv_ec_int - cnv:(exact)C_integer(*s, *d), convert to an exact C integer + */ +int cnv_ec_int(s, d) +dptr s; +C_integer *d; + { + tended struct descrip cnvstr; + union numeric numrc; + char sbuf[MaxCvtLen]; + + type_case *s of { + integer: { + +#ifdef LargeInts + if (Type(*s) == T_Lrgint) { + return 0; + } +#endif /* LargeInts */ + *d = IntVal(*s); + return 1; + } + string: { + /* fall through */ + } + cset: { + tmp_str(sbuf, s, &cnvstr); + s = &cnvstr; + } + default: { + return 0; + } + } + + /* + * s is now a string. + */ + if (ston(s, &numrc) == T_Integer) { + *d = numrc.integer; + return 1; + } + else { + return 0; + } + } + +/* + * cnv_eint - cnv:(exact)integer(*s, *d), convert to an exact integer + */ +int cnv_eint(s, d) +dptr s, d; + { + tended struct descrip cnvstr; + char sbuf[MaxCvtLen]; + union numeric numrc; + + type_case *s of { + integer: { + *d = *s; + return 1; + } + string: { + /* fall through */ + } + cset: { + tmp_str(sbuf, s, &cnvstr); + s = &cnvstr; + } + default: { + return 0; + } + } + + /* + * s is now a string. + */ + switch (ston(s, &numrc)) { + case T_Integer: + MakeInt(numrc.integer, d); + return 1; + +#ifdef LargeInts + case T_Lrgint: + d->dword = D_Lrgint; + BlkLoc(*d) = (union block *)numrc.big; + return 1; +#endif /* LargeInts */ + + default: + return 0; + } + } + +/* + * cnv_int - cnv:integer(*s, *d), convert to integer + */ +int cnv_int(s, d) +dptr s, d; + { + tended struct descrip cnvstr; + char sbuf[MaxCvtLen]; + union numeric numrc; + + EVValD(s, E_Aconv); + EVValD(&zerodesc, E_Tconv); + + type_case *s of { + integer: { + *d = *s; + EVValD(s, E_Nconv); + return 1; + } + real: { + double dbl; + GetReal(s,dbl); + if (dbl > MaxLong || dbl < MinLong) { + +#ifdef LargeInts + if (realtobig(s, d) == Succeeded) { + EVValD(d, E_Sconv); + return 1; + } + else { + EVValD(s, E_Fconv); + return 0; + } +#else /* LargeInts */ + EVValD(s, E_Fconv); + return 0; +#endif /* LargeInts */ + } + MakeInt((word)dbl,d); + EVValD(d, E_Sconv); + return 1; + } + string: { + /* fall through */ + } + cset: { + tmp_str(sbuf, s, &cnvstr); + s = &cnvstr; + } + default: { + EVValD(s, E_Fconv); + return 0; + } + } + + /* + * s is now a string. + */ + switch( ston(s, &numrc) ) { + +#ifdef LargeInts + case T_Lrgint: + d->dword = D_Lrgint; + BlkLoc(*d) = (union block *)numrc.big; + EVValD(d, E_Sconv); + return 1; +#endif /* LargeInts */ + + case T_Integer: + MakeInt(numrc.integer,d); + EVValD(d, E_Sconv); + return 1; + case T_Real: { + double dbl = numrc.real; + if (dbl > MaxLong || dbl < MinLong) { + +#ifdef LargeInts + if (realtobig(s, d) == Succeeded) { + EVValD(d, E_Sconv); + return 1; + } + else { + EVValD(s, E_Fconv); + return 0; + } +#else /* LargeInts */ + EVValD(s, E_Fconv); + return 0; +#endif /* LargeInts */ + } + MakeInt((word)dbl,d); + EVValD(d, E_Sconv); + return 1; + } + default: + EVValD(s, E_Fconv); + return 0; + } + } + +/* + * cnv_real - cnv:real(*s, *d), convert to real + */ +int cnv_real(s, d) +dptr s, d; + { + double dbl; + + EVValD(s, E_Aconv); + EVValD(&rzerodesc, E_Tconv); + + if (cnv_c_dbl(s, &dbl)) { + Protect(BlkLoc(*d) = (union block *)alcreal(dbl), fatalerr(0,NULL)); + d->dword = D_Real; + EVValD(d, E_Sconv); + return 1; + } + else + EVValD(s, E_Fconv); + return 0; + } + +/* + * cnv_str - cnv:string(*s, *d), convert to a string + */ +int cnv_str(s, d) +dptr s, d; + { + char sbuf[MaxCvtLen]; + + EVValD(s, E_Aconv); + EVValD(&emptystr, E_Tconv); + + type_case *s of { + string: { + *d = *s; + EVValD(s, E_Nconv); + return 1; + } + integer: { + +#ifdef LargeInts + if (Type(*s) == T_Lrgint) { + word slen; + word dlen; + + slen = (BlkLoc(*s)->bignumblk.lsd - BlkLoc(*s)->bignumblk.msd +1); + dlen = slen * NB * 0.3010299956639812; /* 1 / log2(10) */ + bigtos(s,d); + } + else +#endif /* LargeInts */ + + itos(IntVal(*s), d, sbuf); + } + real: { + double res; + GetReal(s, res); + rtos(res, d, sbuf); + } + cset: + cstos(BlkLoc(*s)->cset.bits, d, sbuf); + default: { + EVValD(s, E_Fconv); + return 0; + } + } + Protect(StrLoc(*d) = alcstr(StrLoc(*d), StrLen(*d)), fatalerr(0,NULL)); + EVValD(d, E_Sconv); + return 1; + } + +/* + * cnv_tcset - cnv:tmp_cset(*s, *d), convert to a temporary cset + */ +int cnv_tcset(cbuf, s, d) +struct b_cset *cbuf; +dptr s, d; + { + struct descrip tmpstr; + char sbuf[MaxCvtLen]; + register char *s1; + C_integer l; + + EVValD(s, E_Aconv); + EVValD(&csetdesc, E_Tconv); + + if (is:cset(*s)) { + *d = *s; + EVValD(s, E_Nconv); + return 1; + } + if (tmp_str(sbuf, s, &tmpstr)) { + for (l = 0; l < CsetSize; l++) + cbuf->bits[l] = 0; + d->dword = D_Cset; + BlkLoc(*d) = (union block *)cbuf; + s1 = StrLoc(tmpstr); + l = StrLen(tmpstr); + while(l--) { + Setb(*s1, *d); + s1++; + } + EVValD(d, E_Sconv); + return 1; + } + else { + EVValD(s, E_Fconv); + return 0; + } + } + +/* + * cnv_tstr - cnv:tmp_string(*s, *d), convert to a temporary string + */ +int cnv_tstr(sbuf, s, d) +char *sbuf; +dptr s; +dptr d; + { + EVValD(s, E_Aconv); + EVValD(&emptystr, E_Tconv); + + if (is:string(*s)) { + *d = *s; + EVValD(s, E_Nconv); + return 1; + } + else if (tmp_str(sbuf, s, d)) { + EVValD(d, E_Sconv); + return 1; + } + else { + EVValD(s, E_Fconv); + return 0; + } + } + +/* + * deref - dereference a descriptor. + */ +void deref(s, d) +dptr s, d; + { + /* + * no allocation is done, so nothing need be tended. + */ + register union block *bp; + struct descrip v; + register union block **ep; + int res; + + if (!is:variable(*s)) { + *d = *s; + } + else type_case *s of { + tvsubs: { + /* + * A substring trapped variable is being dereferenced. + * Point bp to the trapped variable block and v to + * the string. + */ + bp = BlkLoc(*s); + deref(&bp->tvsubs.ssvar, &v); + if (!is:string(v)) + fatalerr(103, &v); + if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(v)) + fatalerr(205, NULL); + /* + * Make a descriptor for the substring by getting the + * length and pointing into the string. + */ + StrLen(*d) = bp->tvsubs.sslen; + StrLoc(*d) = StrLoc(v) + bp->tvsubs.sspos - 1; + } + + tvtbl: { + /* + * Look up the element in the table. + */ + bp = BlkLoc(*s); + ep = memb(bp->tvtbl.clink,&bp->tvtbl.tref,bp->tvtbl.hashnum,&res); + if (res == 1) + *d = (*ep)->telem.tval; /* found; use value */ + else + *d = bp->tvtbl.clink->table.defvalue; /* nope; use default */ + } + + kywdint: + kywdpos: + kywdsubj: + kywdevent: + kywdwin: + kywdstr: + *d = *VarLoc(*s); + + default: + /* + * An ordinary variable is being dereferenced. + */ + *d = *(dptr)((word *)VarLoc(*s) + Offset(*s)); + } + } + +/* + * getdbl - return as a double the value inside a real block. + */ +double getdbl(dp) +dptr dp; + { + double d; + GetReal(dp, d); + return d; + } + +/* + * tmp_str - Convert to temporary string. + */ +static int tmp_str(sbuf, s, d) +char *sbuf; +dptr s; +dptr d; + { + type_case *s of { + string: + *d = *s; + integer: { + +#ifdef LargeInts + if (Type(*s) == T_Lrgint) { + word slen; + word dlen; + + slen = (BlkLoc(*s)->bignumblk.lsd - BlkLoc(*s)->bignumblk.msd +1); + dlen = slen * NB * 0.3010299956639812; /* 1 / log2(10) */ + bigtos(s,d); + } + else +#endif /* LargeInts */ + + itos(IntVal(*s), d, sbuf); + } + real: { + double res; + GetReal(s, res); + rtos(res, d, sbuf); + } + cset: + cstos(BlkLoc(*s)->cset.bits, d, sbuf); + default: + return 0; + } + return 1; + } + +/* + * dp_pnmcmp - do a string comparison of a descriptor to the procedure + * name in a pstrnm struct; used in call to qsearch(). + */ +int dp_pnmcmp(pne,dp) +struct pstrnm *pne; +struct descrip *dp; +{ + struct descrip d; + StrLen(d) = strlen(pne->pstrep); + StrLoc(d) = pne->pstrep; + return lexcmp(&d,dp); +} + +/* + * bi_strprc - convert a string to a (built-in) function or operator. + */ +struct b_proc *bi_strprc(s, arity) +dptr s; +C_integer arity; + { + C_integer i; + struct pstrnm *pp; + + if (!StrLen(*s)) + return NULL; + + /* + * See if the string represents an operator. In this case the arity + * of the operator must match the one given. + */ + if (!isalpha(*StrLoc(*s))) { + for (i = 0; i < op_tbl_sz; ++i) + if (eq(s, &op_tbl[i].pname) && (arity == op_tbl[i].nparam || + op_tbl[i].nparam == -1)) + return &op_tbl[i]; + return NULL; + } + + /* + * See if the string represents a built-in function. + */ +#if COMPILER + for (i = 0; i < n_globals; ++i) + if (eq(s, &gnames[i])) + return builtins[i]; /* may be null */ +#else /* COMPILER */ + pp = (struct pstrnm *)qsearch((char *)s,(char *)pntab,pnsize, + sizeof(struct pstrnm),dp_pnmcmp); + if (pp!=NULL) + return (struct b_proc *)pp->pblock; +#endif /* !COMPILER */ + + return NULL; + } + +/* + * strprc - convert a string to a procedure. + */ +struct b_proc *strprc(s, arity) +dptr s; +C_integer arity; + { + C_integer i; + + /* + * See if the string is the name of a global variable. + */ + for (i = 0; i < n_globals; ++i) + if (eq(s, &gnames[i])) { + if (is:proc(globals[i])) + return (struct b_proc *)BlkLoc(globals[i]); + else + return NULL; + } + + return bi_strprc(s,arity); + } + +/* + * Service routines + */ + +/* + * itos - convert the integer num into a string using s as a buffer and + * making q a descriptor for the resulting string. + */ + +static void itos(num, dp, s) +C_integer num; +dptr dp; +char *s; + { + register char *p; + long ival; + static char *maxneg = MaxNegInt; + + p = s + MaxCvtLen - 1; + ival = num; + + *p = '\0'; + if (num >= 0L) + do { + *--p = ival % 10L + '0'; + ival /= 10L; + } while (ival != 0L); + else { + if (ival == -ival) { /* max negative value */ + p -= strlen (maxneg); + sprintf (p, "%s", maxneg); + } + else { + ival = -ival; + do { + *--p = '0' + (ival % 10L); + ival /= 10L; + } while (ival != 0L); + *--p = '-'; + } + } + + StrLen(*dp) = s + MaxCvtLen - 1 - p; + StrLoc(*dp) = p; + } + + +/* + * ston - convert a string to a numeric quantity if possible. + * Returns a typecode or CvtFail. Its answer is in the dptr, + * unless its a double, in which case its in the union numeric + * (we do this to avoid allocating a block for a real + * that will later be used directly as a C_double). + */ +static int ston(sp, result) +dptr sp; +union numeric *result; + { + register char *s = StrLoc(*sp), *end_s; + register int c; + int realflag = 0; /* indicates a real number */ + char msign = '+'; /* sign of mantissa */ + char esign = '+'; /* sign of exponent */ + double mantissa = 0; /* scaled mantissa with no fractional part */ + long lresult = 0; /* integer result */ + int scale = 0; /* number of decimal places to shift mantissa */ + int digits = 0; /* total number of digits seen */ + int sdigits = 0; /* number of significant digits seen */ + int exponent = 0; /* exponent part of real number */ + double fiveto; /* holds 5^scale */ + double power; /* holds successive squares of 5 to compute fiveto */ + int err_no; + char *ssave; /* holds original ptr for bigradix */ + + if (StrLen(*sp) == 0) + return CvtFail; + end_s = s + StrLen(*sp); + c = *s++; + + /* + * Skip leading white space. + */ + while (isspace(c)) + if (s < end_s) + c = *s++; + else + return CvtFail; + + /* + * Check for sign. + */ + if (c == '+' || c == '-') { + msign = c; + c = (s < end_s) ? *s++ : ' '; + } + + ssave = s - 1; /* set pointer to beginning of digits in case it's needed */ + + /* + * Get integer part of mantissa. + */ + while (isdigit(c)) { + digits++; + if (mantissa < Big) { + mantissa = mantissa * 10 + (c - '0'); + lresult = lresult * 10 + (c - '0'); + if (mantissa > 0.0) + sdigits++; + } + else + scale++; + c = (s < end_s) ? *s++ : ' '; + } + + /* + * Check for based integer. + */ + if (c == 'r' || c == 'R') { + int rv; +#ifdef LargeInts + rv = bigradix((int)msign, (int)mantissa, s, end_s, result); + if (rv == Error) + fatalerr(0, NULL); +#else /* LargeInts */ + rv = radix((int)msign, (int)mantissa, s, end_s, result); +#endif /* LargeInts */ + return rv; + } + + /* + * Get fractional part of mantissa. + */ + if (c == '.') { + realflag++; + c = (s < end_s) ? *s++ : ' '; + while (isdigit(c)) { + digits++; + if (mantissa < Big) { + mantissa = mantissa * 10 + (c - '0'); + lresult = lresult * 10 + (c - '0'); + scale--; + if (mantissa > 0.0) + sdigits++; + } + c = (s < end_s) ? *s++ : ' '; + } + } + + /* + * Check that at least one digit has been seen so far. + */ + if (digits == 0) + return CvtFail; + + /* + * Get exponent part. + */ + if (c == 'e' || c == 'E') { + realflag++; + c = (s < end_s) ? *s++ : ' '; + if (c == '+' || c == '-') { + esign = c; + c = (s < end_s) ? *s++ : ' '; + } + if (!isdigit(c)) + return CvtFail; + while (isdigit(c)) { + exponent = exponent * 10 + (c - '0'); + c = (s < end_s) ? *s++ : ' '; + } + scale += (esign == '+') ? exponent : -exponent; + } + + /* + * Skip trailing white space and make sure there is nothing else left + * in the string. Note, if we have already reached end-of-string, + * c has been set to a space. + */ + while (isspace(c) && s < end_s) + c = *s++; + if (!isspace(c)) + return CvtFail; + + /* + * Test for integer. + */ + if (!realflag && !scale && mantissa >= MinLong && mantissa <= MaxLong) { + result->integer = (msign == '+' ? lresult : -lresult); + return T_Integer; + } + +#ifdef LargeInts + /* + * Test for bignum. + */ +#if COMPILER + if (largeints) +#endif /* COMPILER */ + if (!realflag) { + int rv; + rv = bigradix((int)msign, 10, ssave, end_s, result); + if (rv == Error) + fatalerr(0, NULL); + return rv; + } +#endif /* LargeInts */ + + if (!realflag) + return CvtFail; /* don't promote to real if integer format */ + + /* + * Rough tests for overflow and underflow. + */ + if (sdigits + scale > LogHuge) + return CvtFail; + + if (sdigits + scale < -LogHuge) { + result->real = 0.0; + return T_Real; + } + + /* + * Put the number together by multiplying the mantissa by 5^scale and + * then using ldexp() to multiply by 2^scale. + */ + + exponent = (scale > 0)? scale : -scale; + fiveto = 1.0; + power = 5.0; + for (;;) { + if (exponent & 01) + fiveto *= power; + exponent >>= 1; + if (exponent == 0) + break; + power *= power; + } + if (scale > 0) + mantissa *= fiveto; + else + mantissa /= fiveto; + + err_no = 0; + mantissa = ldexp(mantissa, scale); + if (err_no > 0 && mantissa > 0) + /* + * ldexp caused overflow. + */ + return CvtFail; + + if (msign == '-') + mantissa = -mantissa; + result->real = mantissa; + return T_Real; + } + +#if COMPILER || !(defined LargeInts) +/* + * radix - convert string s in radix r into an integer in *result. sign + * will be either '+' or '-'. + */ +int radix(sign, r, s, end_s, result) +int sign; +register int r; +register char *s; +register char *end_s; +union numeric *result; + { + register int c; + long num; + + if (r < 2 || r > 36) + return CvtFail; + c = (s < end_s) ? *s++ : ' '; + num = 0L; + while (isalnum(c)) { + c = tonum(c); + if (c >= r) + return CvtFail; + num = num * r + c; + c = (s < end_s) ? *s++ : ' '; + } + + /* + * Skip trailing white space and make sure there is nothing else left + * in the string. Note, if we have already reached end-of-string, + * c has been set to a space. + */ + while (isspace(c) && s < end_s) + c = *s++; + if (!isspace(c)) + return CvtFail; + + result->integer = (sign == '+' ? num : -num); + + return T_Integer; + } +#endif /* COMPILER || !(defined LargeInts) */ + + +/* + * cvpos - convert position to strictly positive position + * given length. + */ + +word cvpos(pos, len) +long pos; +register long len; + { + register word p; + + /* + * Make sure the position is in the range of an int. (?) + */ + if ((long)(p = pos) != pos) + return CvtFail; + /* + * Make sure the position is within range. + */ + if (p < -len || p > len + 1) + return CvtFail; + /* + * If the position is greater than zero, just return it. Otherwise, + * convert the zero/negative position. + */ + if (pos > 0) + return p; + return (len + p + 1); + } + +double dblZero = 0.0; + +/* + * rtos - convert the real number n into a string using s as a buffer and + * making a descriptor for the resulting string. + */ +void rtos(n, dp, s) +double n; +dptr dp; +char *s; + { + s++; /* leave room for leading zero */ + sprintf(s, "%.*g", Precision, n + dblZero); /* format, avoiding -0 */ + + /* + * Now clean up possible messes. + */ + while (*s == ' ') /* delete leading blanks */ + s++; + if (*s == '.') { /* prefix 0 to initial period */ + s--; + *s = '0'; + } + else if (!strchr(s, '.') && !strchr(s,'e') && !strchr(s,'E')) + strcat(s, ".0"); /* if no decimal point or exp. */ + if (s[strlen(s) - 1] == '.') /* if decimal point is at end ... */ + strcat(s, "0"); + StrLen(*dp) = strlen(s); + StrLoc(*dp) = s; + } + +/* + * cstos - convert the cset bit array pointed at by cs into a string using + * s as a buffer and making a descriptor for the resulting string. + */ + +static void cstos(cs, dp, s) +unsigned int *cs; +dptr dp; +char *s; + { + register unsigned int w; + register int j, i; + register char *p; + + p = s; + for (i = 0; i < CsetSize; i++) { + if (cs[i]) + for (j=i*IntBits, w=cs[i]; w; j++, w >>= 1) + if (w & 01) + *p++ = (char)j; + } + *p = '\0'; + + StrLen(*dp) = p - s; + StrLoc(*dp) = s; + } diff --git a/src/runtime/data.r b/src/runtime/data.r new file mode 100644 index 0000000..1a276bd --- /dev/null +++ b/src/runtime/data.r @@ -0,0 +1,401 @@ +/* + * data.r -- Various interpreter data tables. + */ + +#if !COMPILER + +struct b_proc Bnoproc; + +#ifdef EventMon +struct b_iproc mt_llist = { + 6, (sizeof(struct b_proc) - sizeof(struct descrip)), Ollist, + 0, -1, 0, 0, {sizeof( "[...]")-1, "[...]"}}; +#endif /* EventMon */ + + +/* + * External declarations for function blocks. + */ + +#define FncDef(p,n) extern struct b_proc Cat(B,p); +#define FncDefV(p) extern struct b_proc Cat(B,p); +#passthru #undef exit +#undef exit +#include "../h/fdefs.h" +#undef FncDef +#undef FncDefV + +#define OpDef(p,n,s,u) extern struct b_proc Cat(B,p); +#include "../h/odefs.h" +#undef OpDef + +extern struct b_proc Bbscan; +extern struct b_proc Bescan; +extern struct b_proc Bfield; +extern struct b_proc Blimit; +extern struct b_proc Bllist; + + + + +struct b_proc *opblks[] = { + NULL, +#define OpDef(p,n,s,u) Cat(&B,p), +#include "../h/odefs.h" +#undef OpDef + &Bbscan, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + &Bescan, + NULL, + &Bfield, + NULL, + NULL, + NULL, + NULL, + NULL, + &Blimit, + &Bllist, + NULL, + NULL, + NULL + }; + +/* + * Array of names and corresponding functions. + * Operators are kept in a similar table, op_tbl. + */ + +struct pstrnm pntab[] = { + +#define FncDef(p,n) Lit(p), Cat(&B,p), +#define FncDefV(p) Lit(p), Cat(&B,p), +#include "../h/fdefs.h" +#undef FncDef +#undef FncDefV + + 0, 0 + }; + +int pnsize = (sizeof(pntab) / sizeof(struct pstrnm)) - 1; + +#endif /* COMPILER */ + +/* + * Structures for built-in values. Parts of some of these structures are + * initialized later. Since some C compilers cannot handle any partial + * initializations, all parts are initialized later if any have to be. + */ + +/* + * blankcs; a cset consisting solely of ' '. + */ +struct b_cset blankcs = { + T_Cset, + 1, + cset_display(0, 0, 01, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0) + }; + +/* + * lparcs; a cset consisting solely of '('. + */ +struct b_cset lparcs = { + T_Cset, + 1, + cset_display(0, 0, 0400, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0) + }; + +/* + * rparcs; a cset consisting solely of ')'. + */ +struct b_cset rparcs = { + T_Cset, + 1, + cset_display(0, 0, 01000, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0) + }; + +/* + * fullcs - all 256 bits on. + */ +struct b_cset fullcs = { + T_Cset, + 256, + cset_display(~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0, + ~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0) + }; + +#if !COMPILER + +/* + * Built-in csets + */ + +/* + * &digits; bits corresponding to 0-9 are on. + */ +struct b_cset k_digits = { + T_Cset, + 10, + + cset_display(0, 0, 0, 0x3ff, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0) + }; + +/* + * Cset for &lcase; bits corresponding to lowercase letters are on. + */ +struct b_cset k_lcase = { + T_Cset, + 26, + + cset_display(0, 0, 0, 0, 0, 0, ~01, 03777, + 0, 0, 0, 0, 0, 0, 0, 0) + }; + +/* + * &ucase; bits corresponding to uppercase characters are on. + */ +struct b_cset k_ucase = { + T_Cset, + 26, + + cset_display(0, 0, 0, 0, ~01, 03777, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0) + }; + +/* + * &letters; bits corresponding to letters are on. + */ +struct b_cset k_letters = { + T_Cset, + 52, + + cset_display(0, 0, 0, 0, ~01, 03777, ~01, 03777, + 0, 0, 0, 0, 0, 0, 0, 0) + }; +#endif /* COMPILER */ + +/* + * Built-in files. + */ + +#ifndef MultiThread +struct b_file k_errout = {T_File, NULL, Fs_Write}; /* &errout */ +struct b_file k_input = {T_File, NULL, Fs_Read}; /* &input */ +struct b_file k_output = {T_File, NULL, Fs_Write}; /* &output */ +#endif /* MultiThread */ + +#ifdef EventMon +/* + * Real block needed for event monitoring. + */ +struct b_real realzero = {T_Real, 0.0}; +#endif /* EventMon */ + +/* + * Keyword variables. + */ +#ifndef MultiThread +struct descrip kywd_err = {D_Integer}; /* &error */ +struct descrip kywd_pos = {D_Integer}; /* &pos */ +struct descrip kywd_prog; /* &progname */ +struct descrip k_subject; /* &subject */ +struct descrip kywd_ran = {D_Integer}; /* &random */ +struct descrip kywd_trc = {D_Integer}; /* &trace */ +struct descrip k_eventcode = {D_Null}; /* &eventcode */ +struct descrip k_eventsource = {D_Null};/* &eventsource */ +struct descrip k_eventvalue = {D_Null}; /* &eventvalue */ + +#endif /* MultiThread */ + +#ifdef FncTrace +struct descrip kywd_ftrc = {D_Integer}; /* &ftrace */ +#endif /* FncTrace */ + +struct descrip kywd_dmp = {D_Integer}; /* &dump */ + +struct descrip nullptr = + {F_Ptr | F_Nqual}; /* descriptor with null block pointer */ +struct descrip trashcan; /* descriptor that is never read */ + +/* + * Various constant descriptors. + */ + +struct descrip blank; /* one-character blank string */ +struct descrip emptystr; /* zero-length empty string */ +struct descrip lcase; /* string of lowercase letters */ +struct descrip letr; /* "r" */ +struct descrip nulldesc = {D_Null}; /* null value */ +struct descrip onedesc = {D_Integer}; /* integer 1 */ +struct descrip ucase; /* string of uppercase letters */ +struct descrip zerodesc = {D_Integer}; /* integer 0 */ + +#ifdef EventMon +/* + * Descriptors used by event monitoring. + */ +struct descrip csetdesc = {D_Cset}; +struct descrip eventdesc; +struct descrip rzerodesc = {D_Real}; +#endif /* EventMon */ + +/* + * An array of all characters for use in making one-character strings. + */ + +unsigned char allchars[256] = { + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, + 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, + 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, + 96, 97, 98, 99,100,101,102,103,104,105,106,107,108,109,110,111, + 112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127, + 128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143, + 144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159, + 160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175, + 176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191, + 192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207, + 208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223, + 224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239, + 240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255, +}; + +/* + * Run-time error numbers and text. + */ +struct errtab errtab[] = { + + 101, "integer expected or out of range", + 102, "numeric expected", + 103, "string expected", + 104, "cset expected", + 105, "file expected", + 106, "procedure or integer expected", + 107, "record expected", + 108, "list expected", + 109, "string or file expected", + 110, "string or list expected", + 111, "variable expected", + 112, "invalid type to size operation", + 113, "invalid type to random operation", + 114, "invalid type to subscript operation", + 115, "structure expected", + 116, "invalid type to element generator", + 117, "missing main procedure", + 118, "co-expression expected", + 119, "set expected", + 120, "two csets or two sets expected", + 121, "function not supported", + 122, "set or table expected", + 123, "invalid type", + 124, "table expected", + 125, "list, record, or set expected", + 126, "list or record expected", + +#ifdef Graphics + 140, "window expected", + 141, "program terminated by window manager", + 142, "attempt to read/write on closed window", + 143, "malformed event queue", + 144, "window system error", + 145, "bad window attribute", + 146, "incorrect number of arguments to drawing function", + 147, "window attribute cannot be read or written as requested", +#endif /* Graphics */ + +#ifdef FAttrib + 160, "bad file attribute", +#endif /* FAttrib */ + + 201, "division by zero", + 202, "remaindering by zero", + 203, "integer overflow", + 204, "real overflow, underflow, or division by zero", + 205, "invalid value", + 206, "negative first argument to real exponentiation", + 207, "invalid field name", + 208, "second and third arguments to map of unequal length", + 209, "invalid second argument to open", + 210, "non-ascending arguments to detab/entab", + 211, "by value equal to zero", + 212, "attempt to read file not open for reading", + 213, "attempt to write file not open for writing", + 214, "input/output error", + 215, "attempt to refresh &main", + 216, "external function not found", + + 301, "evaluation stack overflow", + 302, "memory violation", + 303, "inadequate space for evaluation stack", + 304, "inadequate space in qualifier list", + 305, "inadequate space for static allocation", + 306, "inadequate space in string region", + 307, "inadequate space in block region", + 308, "system stack overflow in co-expression", + +#ifndef Coexpr + 401, "co-expressions not implemented", +#endif /* Coexpr */ + 402, "program not compiled with debugging option", + + 500, "program malfunction", /* for use by runerr() */ + 600, "vidget usage error", /* yeah! */ + + 0, "" + }; + +#if !COMPILER +#define OpDef(p,n,s,u) int Cat(O,p) (dptr cargp); +#include "../h/odefs.h" +#undef OpDef + +/* + * When an opcode n has a subroutine call associated with it, the + * nth word here is the routine to call. + */ + +int (*optab[])() = { + err, +#define OpDef(p,n,s,u) Cat(O,p), +#include "../h/odefs.h" +#undef OpDef + Obscan, + err, + err, + err, + err, + err, + Ocreate, + err, + err, + err, + err, + Oescan, + err, + Ofield + }; + +/* + * Keyword function look-up table. + */ +#define KDef(p,n) int Cat(K,p) (dptr cargp); +#include "../h/kdefs.h" +#undef KDef + +int (*keytab[])() = { + err, +#define KDef(p,n) Cat(K,p), +#include "../h/kdefs.h" + }; +#endif /* !COMPILER */ diff --git a/src/runtime/def.r b/src/runtime/def.r new file mode 100644 index 0000000..012aab4 --- /dev/null +++ b/src/runtime/def.r @@ -0,0 +1,168 @@ +/* + * def.r -- defaulting conversion routines. + */ + +/* + * DefConvert - macro for general form of defaulting conversion. + */ +#begdef DefConvert(default, dftype, destype, converter, body) +int default(s,df,d) +dptr s; +dftype df; +destype d; + { + if (is:null(*s)) { + body + return 1; + } + else + return converter(s,d); /* I really mean cnv:type */ + } +#enddef + +/* + * def_c_dbl - def:C_double(*s, df, *d), convert to C double with a + * default value. Default is of type C double; if used, just copy to + * destination. + */ + +#begdef C_DblAsgn + *d = df; +#enddef + +DefConvert(def_c_dbl, double, double *, cnv_c_dbl, C_DblAsgn) + +/* + * def_c_int - def:C_integer(*s, df, *d), convert to C_integer with a + * default value. Default type C_integer; if used, just copy to + * destination. + */ +#begdef C_IntAsgn + *d = df; +#enddef + +DefConvert(def_c_int, C_integer, C_integer *, cnv_c_int, C_IntAsgn) + +/* + * def_c_str - def:C_string(*s, df, *d), convert to (tended) C string with + * a default value. Default is of type "char *"; if used, point destination + * descriptor to it. + */ + +#begdef C_StrAsgn + StrLen(*d) = strlen(df); + StrLoc(*d) = (char *)df; +#enddef + +DefConvert(def_c_str, char *, dptr, cnv_c_str, C_StrAsgn) + +/* + * def_cset - def:cset(*s, *df, *d), convert to cset with a default value. + * Default is of type "struct b_cset *"; if used, point destination descriptor + * to it. + */ + +#begdef CsetAsgn + d->dword = D_Cset; + BlkLoc(*d) = (union block *)df; +#enddef + +DefConvert(def_cset, struct b_cset *, dptr, cnv_cset, CsetAsgn) + +/* + * def_ec_int - def:(exact)C_integer(*s, df, *d), convert to C Integer + * with a default value, but disallow conversions from reals. Default + * is of type C_Integer; if used, just copy to destination. + */ + +#begdef EC_IntAsgn + *d = df; +#enddef + +DefConvert(def_ec_int, C_integer, C_integer *, cnv_ec_int, EC_IntAsgn) + +/* + * def_eint - def:(exact)integer(*s, df, *d), convert to C_integer + * with a default value, but disallow conversions from reals. Default + * is of type C_Integer; if used, assign it to the destination descriptor. + */ + +#begdef EintAsgn + d->dword = D_Integer; + IntVal(*d) = df; +#enddef + +DefConvert(def_eint, C_integer, dptr, cnv_eint, EintAsgn) + +/* + * def_int - def:integer(*s, df, *d), convert to integer with a default + * value. Default is of type C_integer; if used, assign it to the + * destination descriptor. + */ + +#begdef IntAsgn + d->dword = D_Integer; + IntVal(*d) = df; +#enddef + +DefConvert(def_int, C_integer, dptr, cnv_int, IntAsgn) + +/* + * def_real - def:real(*s, df, *d), convert to real with a default value. + * Default is of type double; if used, allocate real block and point + * destination descriptor to it. + */ + +#begdef RealAsgn + Protect(BlkLoc(*d) = (union block *)alcreal(df), fatalerr(0,NULL)); + d->dword = D_Real; +#enddef + +DefConvert(def_real, double, dptr, cnv_real, RealAsgn) + +/* + * def_str - def:string(*s, *df, *d), convert to string with a default + * value. Default is of type "struct descrip *"; if used, copy the + * decriptor value to the destination. + */ + +#begdef StrAsgn + *d = *df; +#enddef + +DefConvert(def_str, dptr, dptr, cnv_str, StrAsgn) + +/* + * def_tcset - def:tmp_cset(*s, *df, *d), conversion to temporary cset with + * a default value. Default is of type "struct b_cset *"; if used, + * point destination descriptor to it. Note that this routine needs + * a cset buffer (cset block) to perform an actual conversion. + */ +int def_tcset(cbuf, s, df, d) +struct b_cset *cbuf, *df; +dptr s, d; +{ + if (is:null(*s)) { + d->dword = D_Cset; + BlkLoc(*d) = (union block *)df; + return 1; + } + return cnv_tcset(cbuf, s, d); + } + +/* + * def_tstr - def:tmp_string(*s, *df, *d), conversion to temporary string + * with a default value. Default is of type "struct descrip *"; if used, + * copy it to destination descriptor. Note that this routine needs + * a string buffer to perform an actual conversion. + */ +int def_tstr(sbuf, s, df, d) +char *sbuf; +dptr s, df, d; + { + if (is:null(*s)) { + *d = *df; + return 1; + } + return cnv_tstr(sbuf, s, d); + } diff --git a/src/runtime/errmsg.r b/src/runtime/errmsg.r new file mode 100644 index 0000000..7095781 --- /dev/null +++ b/src/runtime/errmsg.r @@ -0,0 +1,119 @@ +/* + * errmsg.r -- err_msg, irunerr, drunerr + */ + +extern struct errtab errtab[]; /* error numbers and messages */ + +/* + * err_msg - print run-time error message, performing trace back if required. + * This function underlies the rtt runerr() construct. + */ +void err_msg(n, v) +int n; +dptr v; +{ + register struct errtab *p; + + if (n == 0) { + k_errornumber = t_errornumber; + k_errorvalue = t_errorvalue; + have_errval = t_have_val; + } + else { + k_errornumber = n; + if (v == NULL) { + k_errorvalue = nulldesc; + have_errval = 0; + } + else { + k_errorvalue = *v; + have_errval = 1; + } + } + + k_errortext = ""; + for (p = errtab; p->err_no > 0; p++) + if (p->err_no == k_errornumber) { + k_errortext = p->errmsg; + break; + } + + EVVal((word)k_errornumber,E_Error); + + if (pfp != NULL) { + if (IntVal(kywd_err) == 0 || !err_conv) { + fprintf(stderr, "\nRun-time error %d\n", k_errornumber); +#if COMPILER + if (line_info) + fprintf(stderr, "File %s; Line %d\n", file_name, line_num); +#else /* COMPILER */ + fprintf(stderr, "File %s; Line %ld\n", findfile(ipc.opnd), + (long)findline(ipc.opnd)); +#endif /* COMPILER */ + } + else { + IntVal(kywd_err)--; + return; + } + } + else + fprintf(stderr, "\nRun-time error %d in startup code\n", n); + fprintf(stderr, "%s\n", k_errortext); + + if (have_errval) { + fprintf(stderr, "offending value: "); + outimage(stderr, &k_errorvalue, 0); + putc('\n', stderr); + } + + if (!debug_info) + c_exit(EXIT_FAILURE); + + if (pfp == NULL) { /* skip if start-up problem */ + if (dodump) + abort(); + c_exit(EXIT_FAILURE); + } + + fprintf(stderr, "Traceback:\n"); + tracebk(pfp, glbl_argp); + fflush(stderr); + if (dodump) + abort(); + c_exit(EXIT_FAILURE); +} + +/* + * irunerr - print an error message when the offending value is a C_integer + * rather than a descriptor. + */ +void irunerr(n, v) +int n; +C_integer v; + { + t_errornumber = n; + IntVal(t_errorvalue) = v; + t_errorvalue.dword = D_Integer; + t_have_val = 1; + err_msg(0,NULL); + } + +/* + * drunerr - print an error message when the offending value is a C double + * rather than a descriptor. + */ +void drunerr(n, v) +int n; +double v; + { + union block *bp; + + bp = (union block *)alcreal(v); + if (bp != NULL) { + t_errornumber = n; + BlkLoc(t_errorvalue) = bp; + t_errorvalue.dword = D_Real; + t_have_val = 1; + } + err_msg(0,NULL); + } diff --git a/src/runtime/extcall.r b/src/runtime/extcall.r new file mode 100644 index 0000000..5652416 --- /dev/null +++ b/src/runtime/extcall.r @@ -0,0 +1,21 @@ +/* + * extcall.r + */ + +#if !COMPILER +#ifdef ExternalFunctions + +/* + * extcall - stub procedure for external call interface. + */ +dptr extcall(dargv, argc, ip) +dptr dargv; +int argc; +int *ip; + { + *ip = 216; /* no external function to find */ + return (dptr)NULL; + } + +#endif /* ExternalFunctions */ +#endif /* !COMPILER */ diff --git a/src/runtime/fconv.r b/src/runtime/fconv.r new file mode 100644 index 0000000..7c3a3ff --- /dev/null +++ b/src/runtime/fconv.r @@ -0,0 +1,260 @@ +/* + * fconv.r -- abs, cset, integer, numeric, proc, real, string. + */ + +"abs(N) - produces the absolute value of N." + +function{1} abs(n) + /* + * If n is convertible to a (large or small) integer or real, + * this code returns -n if n is negative + */ + if cnv:(exact)C_integer(n) then { + abstract { + return integer + } + inline { + C_integer i; + extern int over_flow; + + if (n >= 0) + i = n; + else { + i = neg(n); + if (over_flow) { +#ifdef LargeInts + struct descrip tmp; + MakeInt(n,&tmp); + if (bigneg(&tmp, &result) == Error) /* alcbignum failed */ + runerr(0); + return result; +#else /* LargeInts */ + irunerr(203,n); + errorfail; +#endif /* LargeInts */ + } + } + return C_integer i; + } + } + + +#ifdef LargeInts + else if cnv:(exact)integer(n) then { + abstract { + return integer + } + inline { + if (BlkLoc(n)->bignumblk.sign == 0) + result = n; + else { + if (bigneg(&n, &result) == Error) /* alcbignum failed */ + runerr(0); + } + return result; + } + } +#endif /* LargeInts */ + + else if cnv:C_double(n) then { + abstract { + return real + } + inline { + return C_double Abs(n); + } + } + else + runerr(102,n) +end + + +/* + * The convertible types cset, integer, real, and string are identical + * enough to be expansions of a single macro, parameterized by type. + */ +#begdef ReturnYourselfAs(t) +#t "(x) - produces a value of type " #t " resulting from the conversion of x, " + "but fails if the conversion is not possible." +function{0,1} t(x) + + if cnv:t(x) then { + abstract { + return t + } + inline { + return x; + } + } + else { + abstract { + return empty_type + } + inline { + fail; + } + } +end + +#enddef + +ReturnYourselfAs(cset) /* cset(x) - convert to cset or fail */ +ReturnYourselfAs(integer) /* integer(x) - convert to integer or fail */ +ReturnYourselfAs(real) /* real(x) - convert to real or fail */ +ReturnYourselfAs(string) /* string(x) - convert to string or fail */ + + + +"numeric(x) - produces an integer or real number resulting from the " +"type conversion of x, but fails if the conversion is not possible." + +function{0,1} numeric(n) + + if cnv:(exact)integer(n) then { + abstract { + return integer + } + inline { + return n; + } + } + else if cnv:real(n) then { + abstract { + return real + } + inline { + return n; + } + } + else { + abstract { + return empty_type + } + inline { + fail; + } + } +end + + +"proc(x,i) - convert x to a procedure if possible; use i to resolve " +"ambiguous string names." + +#ifdef MultiThread +function{0,1} proc(x,i,c) +#else /* MultiThread */ +function{0,1} proc(x,i) +#endif /* MultiThread */ + +#ifdef MultiThread + if is:coexpr(x) then { + abstract { + return proc + } + inline { + struct b_coexpr *ce = NULL; + struct b_proc *bp = NULL; + struct pf_marker *fp; + dptr dp=NULL; + if (BlkLoc(x) != BlkLoc(k_current)) { + ce = (struct b_coexpr *)BlkLoc(x); + dp = ce->es_argp; + if (dp == NULL) fail; + bp = (struct b_proc *)BlkLoc(*(dp)); + } + else + bp = (struct b_proc *)BlkLoc(*(glbl_argp)); + return proc(bp); + } + } +#endif /* MultiThread */ + + if is:proc(x) then { + abstract { + return proc + } + inline { + +#ifdef MultiThread + if (!is:null(c)) { + struct progstate *p; + if (!is:coexpr(c)) runerr(118,c); + /* + * Test to see whether a given procedure belongs to a given + * program. Currently this is a sleazy pointer arithmetic check. + */ + p = BlkLoc(c)->coexpr.program; + if (! InRange(p, BlkLoc(x)->proc.entryp.icode, + (char *)p + p->hsize)) + fail; + } +#endif /* MultiThread */ + return x; + } + } + + else if cnv:tmp_string(x) then { + /* + * i must be 0, 1, 2, or 3; it defaults to 1. + */ + if !def:C_integer(i, 1) then + runerr(101, i) + inline { + if (i < 0 || i > 3) { + irunerr(205, i); + errorfail; + } + } + + abstract { + return proc + } + inline { + struct b_proc *prc; + +#ifdef MultiThread + struct progstate *prog, *savedprog; + + savedprog = curpstate; + if (is:null(c)) { + prog = curpstate; + } + else if (is:coexpr(c)) { + prog = BlkLoc(c)->coexpr.program; + } + else { + runerr(118,c); + } + + ENTERPSTATE(prog); +#endif /* MultiThread */ + + /* + * Attempt to convert Arg0 to a procedure descriptor using i to + * discriminate between procedures with the same names. If i + * is zero, only check builtins and ignore user procedures. + * Fail if the conversion isn't successful. + */ + if (i == 0) + prc = bi_strprc(&x, 0); + else + prc = strprc(&x, i); + +#ifdef MultiThread + ENTERPSTATE(savedprog); +#endif /* MultiThread */ + if (prc == NULL) + fail; + else + return proc(prc); + } + } + else { + abstract { + return empty_type + } + inline { + fail; + } + } +end diff --git a/src/runtime/fload.r b/src/runtime/fload.r new file mode 100644 index 0000000..dfb9fcc --- /dev/null +++ b/src/runtime/fload.r @@ -0,0 +1,221 @@ +/* + * File: fload.r + * Contents: loadfunc. + * + * This file contains loadfunc(), the dynamic loading function for + * Unix systems having the <dlfcn.h> interface. + * + * from Icon: + * p := loadfunc(filename, funcname) + * p(arg1, arg2, ...) + * + * in C: + * int func(int argc, dptr argv) + * return -1 for failure, 0 for success, >0 for error + * argc is number of true args not including argv[0] + * argv[0] is for return value; others are true args + */ + +#ifdef LoadFunc + +#ifndef RTLD_LAZY /* normally from <dlfcn.h> */ + #define RTLD_LAZY 1 +#endif /* RTLD_LAZY */ + +#ifdef FreeBSD + /* + * If DL_GETERRNO exists, this is an FreeBSD 1.1.5 or 2.0 + * which lacks dlerror(); supply a substitute. + */ + #passthru #ifdef DL_GETERRNO + char *dlerror(void) + { + int no; + + if (0 == dlctl(NULL, DL_GETERRNO, &no)) + return(strerror(no)); + else + return(NULL); + } + #passthru #endif +#endif /* __FreeBSD__ */ + +int glue(); +int makefunc (dptr d, char *name, int (*func)()); + +"loadfunc(filename,funcname) - load C function dynamically." + +function{0,1} loadfunc(filename,funcname) + + if !cnv:C_string(filename) then + runerr(103, filename) + if !cnv:C_string(funcname) then + runerr(103, funcname) + + abstract { + return proc + } + body + { + int (*func)(); + static char *curfile; + static void *handle; + char *funcname2; + + /* + * Get a library handle, reusing it over successive calls. + */ + if (!handle || !curfile || strcmp(filename, curfile) != 0) { + if (curfile) + free((pointer)curfile); /* free the old file name */ + curfile = salloc(filename); /* save the new name */ + handle = dlopen(filename, RTLD_LAZY); /* get the handle */ + } + /* + * Load the function. Diagnose both library and function errors here. + */ + if (handle) { + func = (int (*)())dlsym(handle, funcname); + if (!func) { + /* + * If no function, try again by prepending an underscore. + * (for OpenBSD and similar systems.) + */ + funcname2 = malloc(strlen(funcname) + 2); + if (funcname2) { + *funcname2 = '_'; + strcpy(funcname2 + 1, funcname); + func = (int (*)())dlsym(handle, funcname2); + free(funcname2); + } + } + } + if (!handle || !func) { + fprintf(stderr, "\nloadfunc(\"%s\",\"%s\"): %s\n", + filename, funcname, dlerror()); + runerr(216); + } + /* + * Build and return a proc descriptor. + */ + if (!makefunc(&result, funcname, func)) + runerr(305); + return result; + } +end + +/* + * makefunc(d, name, func) -- make function descriptor in d. + * + * Returns 0 if memory could not be allocated. + */ +int makefunc(d, name, func) +dptr d; +char *name; +int (*func)(); + { + struct b_proc *blk; + + blk = (struct b_proc *)malloc(sizeof(struct b_proc)); + if (!blk) + return 0; + blk->title = T_Proc; + blk->blksize = sizeof(struct b_proc); + +#if COMPILER + blk->ccode = glue; /* set code addr to glue routine */ +#else /* COMPILER */ + blk->entryp.ccode = glue; /* set code addr to glue routine */ +#endif /* COMPILER */ + + blk->nparam = -1; /* varargs flag */ + blk->ndynam = -1; /* treat as built-in function */ + blk->nstatic = 0; + blk->fstatic = 0; + blk->pname.dword = strlen(name); + blk->pname.vword.sptr = salloc(name); + blk->lnames[0].dword = 0; + blk->lnames[0].vword.sptr = (char *)func; + /* save func addr in lnames[0] vword */ + d->dword = D_Proc; /* build proc descriptor */ + d->vword.bptr = (union block *)blk; + return 1; + } + +/* + * This glue routine is called when a loaded function is invoked. + * It digs the actual C code address out of the proc block, and calls that. + */ + +#if COMPILER + +int glue(argc, dargv, rslt, succ_cont) +int argc; +dptr dargv; +dptr rslt; +continuation succ_cont; + { + int i, status, (*func)(); + struct b_proc *blk; + struct descrip r; + tended struct descrip p; + + dargv--; /* reset pointer to proc entry */ + for (i = 0; i <= argc; i++) + deref(&dargv[i], &dargv[i]); /* dereference args including proc */ + + blk = (struct b_proc *)dargv[0].vword.bptr; /* proc block address */ + func = (int (*)())blk->lnames[0].vword.sptr; /* entry point address */ + + p = dargv[0]; /* save proc for traceback */ + dargv[0] = nulldesc; /* set default return value */ + status = (*func)(argc, dargv); /* call func */ + + if (status == 0) { + *rslt = dargv[0]; + Return; /* success */ + } + + if (status < 0) + Fail; /* failure */ + + r = dargv[0]; /* save result value */ + dargv[0] = p; /* restore proc for traceback */ + if (is:null(r)) + RunErr(status, NULL); /* error, no value */ + RunErr(status, &r); /* error, with value */ + } + +#else /* COMPILER */ + +int glue(argc, dargv) +int argc; +dptr dargv; + { + int status, (*func)(); + struct b_proc *blk; + struct descrip r; + tended struct descrip p; + + blk = (struct b_proc *)dargv[0].vword.bptr; /* proc block address */ + func = (int (*)())blk->lnames[0].vword.sptr; /* entry point address */ + + p = dargv[0]; /* save proc for traceback */ + dargv[0] = nulldesc; /* set default return value */ + status = (*func)(argc, dargv); /* call func */ + + if (status == 0) + Return; /* success */ + if (status < 0) + Fail; /* failure */ + + r = dargv[0]; /* save result value */ + dargv[0] = p; /* restore proc for traceback */ + if (is:null(r)) + RunErr(status, NULL); /* error, no value */ + RunErr(status, &r); /* error, with value */ + } + +#endif /* COMPILER */ + +#endif /* LoadFunc */ diff --git a/src/runtime/fmath.r b/src/runtime/fmath.r new file mode 100644 index 0000000..2098044 --- /dev/null +++ b/src/runtime/fmath.r @@ -0,0 +1,114 @@ +/* + * fmath.r -- sin, cos, tan, acos, asin, atan, dtor, rtod, exp, log, sqrt + */ + +/* + * Most of the math ops are simple calls to underlying C functions, + * sometimes with additional error checking to avoid and/or detect + * various C runtime errors. + */ +#begdef MathOp(funcname,ccode,comment,pre,post) +#funcname "(r)" comment +function{1} funcname(x) + + if !cnv:C_double(x) then + runerr(102, x) + + abstract { + return real + } + inline { + double y; + pre /* Pre math-operation range checking */ + errno = 0; + y = ccode(x); + post /* Post math-operation C library error detection */ + return C_double y; + } +end +#enddef + + +#define aroundone if (x < -1.0 || x > 1.0) {drunerr(205, x); errorfail;} +#define positive if (x < 0) {drunerr(205, x); errorfail;} + +#define erange if (errno == ERANGE) runerr(204); +#define edom if (errno == EDOM) runerr(205); + +MathOp(sin, sin, ", x in radians.", ;, ;) +MathOp(cos, cos, ", x in radians.", ;, ;) +MathOp(tan, tan, ", x in radians.", ; , erange) +MathOp(acos,acos, ", x in radians.", aroundone, edom) +MathOp(asin,asin, ", x in radians.", aroundone, edom) +MathOp(exp, exp, " - e^x.", ; , erange) +MathOp(sqrt,sqrt, " - square root of x.", positive, edom) +#define DTOR(x) ((x) * Pi / 180) +#define RTOD(x) ((x) * 180 / Pi) +MathOp(dtor,DTOR, " - convert x from degrees to radians.", ; , ;) +MathOp(rtod,RTOD, " - convert x from radians to degrees.", ; , ;) + + + +"atan(r1,r2) -- r1, r2 in radians; if r2 is present, produces atan2(r1,r2)." + +function{1} atan(x,y) + + if !cnv:C_double(x) then + runerr(102, x) + + abstract { + return real + } + if is:null(y) then + inline { + return C_double atan(x); + } + if !cnv:C_double(y) then + runerr(102, y) + inline { + return C_double atan2(x,y); + } +end + + +"log(r1,r2) - logarithm of r1 to base r2." + +function{1} log(x,b) + + if !cnv:C_double(x) then + runerr(102, x) + + abstract { + return real + } + inline { + if (x <= 0.0) { + drunerr(205, x); + errorfail; + } + } + if is:null(b) then + inline { + return C_double log(x); + } + else { + if !cnv:C_double(b) then + runerr(102, b) + body { + static double lastbase = 0.0; + static double divisor; + + if (b <= 1.0) { + drunerr(205, b); + errorfail; + } + if (b != lastbase) { + divisor = log(b); + lastbase = b; + } + x = log(x) / divisor; + return C_double x; + } + } +end + diff --git a/src/runtime/fmisc.r b/src/runtime/fmisc.r new file mode 100644 index 0000000..6691241 --- /dev/null +++ b/src/runtime/fmisc.r @@ -0,0 +1,2204 @@ +/* + * File: fmisc.r + * Contents: + * args, char, collect, copy, display, function, iand, icom, image, ior, + * ishift, ixor, [keyword], [load], ord, name, runerr, seq, sort, sortf, + * type, variable + */ +#if !COMPILER +#include "../h/opdefs.h" +#endif /* !COMPILER */ + +"args(p) - produce number of arguments for procedure p." + +function{1} args(x) + + if !is:proc(x) then + runerr(106, x) + + abstract { + return integer + } + inline { + return C_integer ((struct b_proc *)BlkLoc(x))->nparam; + } +end + +#if !COMPILER +#ifdef ExternalFunctions + +/* + * callout - call a C library routine (or any C routine that doesn't call Icon) + * with an argument count and a list of descriptors. This routine + * doesn't build a procedure frame to prepare for calling Icon back. + */ +function{1} callout(x[nargs]) + body { + dptr retval; + int signal; + + /* + * Little cheat here. Although this is a var-arg procedure, we need + * at least one argument to get started: pretend there is a null on + * the stack. NOTE: Actually, at present, varargs functions always + * have at least one argument, so this doesn't plug the hole. + */ + if (nargs < 1) + runerr(103, nulldesc); + + /* + * Call the 'C routine caller' with a pointer to an array of descriptors. + * Note that these are being left on the stack. We are passing + * the name of the routine as part of the convention of calling + * routines with an argc/argv technique. + */ + signal = -1; /* presume successful completiong */ + retval = extcall(x, nargs, &signal); + if (signal >= 0) { + if (retval == NULL) + runerr(signal); + else + runerr(signal, *retval); + } + if (retval != NULL) { + return *retval; + } + else + fail; + } +end + +#endif /* ExternalFunctions */ +#endif /* !COMPILER */ + + +"char(i) - produce a string consisting of character i." + +function{1} char(i) + + if !cnv:C_integer(i) then + runerr(101,i) + abstract { + return string + } + body { + if (i < 0 || i > 255) { + irunerr(205, i); + errorfail; + } + return string(1, (char *)&allchars[i & 0xFF]); + } +end + + +"collect(i1,i2) - call garbage collector to ensure i2 bytes in region i1." +" no longer works." + +function{1} collect(region, bytes) + + if !def:C_integer(region, (C_integer)0) then + runerr(101, region) + if !def:C_integer(bytes, (C_integer)0) then + runerr(101, bytes) + + abstract { + return null + } + body { + if (bytes < 0) { + irunerr(205, bytes); + errorfail; + } + switch (region) { + case 0: + collect(0); + break; + case Static: + collect(Static); /* i2 ignored if i1==Static */ + break; + case Strings: + if (DiffPtrs(strend,strfree) >= bytes) + collect(Strings); /* force unneded collection */ + else if (!reserve(Strings, bytes)) /* collect & reserve bytes */ + fail; + break; + case Blocks: + if (DiffPtrs(blkend,blkfree) >= bytes) + collect(Blocks); /* force unneded collection */ + else if (!reserve(Blocks, bytes)) /* collect & reserve bytes */ + fail; + break; + default: + irunerr(205, region); + errorfail; + } + return nulldesc; + } +end + + +"copy(x) - make a copy of object x." + +function{1} copy(x) + abstract { + return type(x) + } + type_case x of { + null: + string: + cset: + integer: + real: + file: + proc: + coexpr: + inline { + /* + * Copy the null value, integers, long integers, reals, files, + * csets, procedures, and such by copying the descriptor. + * Note that for integers, this results in the assignment + * of a value, for the other types, a pointer is directed to + * a data block. + */ + return x; + } + + list: + inline { + /* + * Pass the buck to cplist to copy a list. + */ + if (cplist(&x, &result, (word)1, BlkLoc(x)->list.size + 1) ==Error) + runerr(0); + return result; + } + table: { + body { +#ifdef TableFix + if (cptable(&x, &result, BlkLoc(x)->table.size) == Error) + runerr(0); + return result; +#else /* TableFix */ + register int i; + register word slotnum; + tended union block *src; + tended union block *dst; + tended struct b_slots *seg; + tended struct b_telem *ep, *prev; + struct b_telem *te; + /* + * Copy a Table. First, allocate and copy header and slot blocks. + */ + src = BlkLoc(x); + dst = hmake(T_Table, src->table.mask + 1, src->table.size); + if (dst == NULL) + runerr(0); + dst->table.size = src->table.size; + dst->table.mask = src->table.mask; + dst->table.defvalue = src->table.defvalue; + for (i = 0; i < HSegs && src->table.hdir[i] != NULL; i++) + memcpy((char *)dst->table.hdir[i], (char *)src->table.hdir[i], + src->table.hdir[i]->blksize); + /* + * Work down the chain of element blocks in each bucket + * and create identical chains in new table. + */ + for (i = 0; i < HSegs && (seg = dst->table.hdir[i]) != NULL; i++) + for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--) { + prev = NULL; + for (ep = (struct b_telem *)seg->hslots[slotnum]; + ep != NULL; ep = (struct b_telem *)ep->clink) { + Protect(te = alctelem(), runerr(0)); + *te = *ep; /* copy table entry */ + if (prev == NULL) + seg->hslots[slotnum] = (union block *)te; + else + prev->clink = (union block *)te; + te->clink = ep->clink; + prev = te; + } + } + + if (TooSparse(dst)) + hshrink(dst); + Desc_EVValD(dst, E_Tcreate, D_Table); + return table(dst); +#endif /* TableFix */ + } + } + + set: { + body { + /* + * Pass the buck to cpset to copy a set. + */ + if (cpset(&x, &result, BlkLoc(x)->set.size) == Error) + runerr(0); + return result; + } + } + + record: { + body { + /* + * Note, these pointers don't need to be tended, because they are + * not used until after allocation is complete. + */ + struct b_record *new_rec; + tended struct b_record *old_rec; + dptr d1, d2; + int i; + + /* + * Allocate space for the new record and copy the old + * one into it. + */ + old_rec = (struct b_record *)BlkLoc(x); + i = old_rec->recdesc->proc.nfields; + + /* #%#% param changed ? */ + Protect(new_rec = alcrecd(i,old_rec->recdesc), runerr(0)); + d1 = new_rec->fields; + d2 = old_rec->fields; + while (i--) + *d1++ = *d2++; + Desc_EVValD(new_rec, E_Rcreate, D_Record); + return record(new_rec); + } + } + + default: body { + runerr(123,x); + } + } +end + + +"display(i,f) - display local variables of i most recent" +" procedure activations, plus global variables." +" Output to file f (default &errout)." + +#ifdef MultiThread +function{1} display(i,f,c) + declare { + struct b_coexpr *ce = NULL; + struct progstate *prog, *savedprog; + } +#else /* MultiThread */ +function{1} display(i,f) +#endif /* MultiThread */ + + if !def:C_integer(i,(C_integer)k_level) then + runerr(101, i) + + if is:null(f) then + inline { + f.dword = D_File; + BlkLoc(f) = (union block *)&k_errout; + } + else if !is:file(f) then + runerr(105, f) + +#ifdef MultiThread + if !is:null(c) then inline { + if (!is:coexpr(c)) runerr(118,c); + else if (BlkLoc(c) != BlkLoc(k_current)) + ce = (struct b_coexpr *)BlkLoc(c); + savedprog = curpstate; + } +#endif /* MultiThread */ + + abstract { + return null + } + + body { + FILE *std_f; + int r; + + if (!debug_info) + runerr(402); + + /* + * Produce error if file cannot be written. + */ + std_f = BlkLoc(f)->file.fd; + if ((BlkLoc(f)->file.status & Fs_Write) == 0) + runerr(213, f); + + /* + * Produce error if i is negative; constrain i to be <= &level. + */ + if (i < 0) { + irunerr(205, i); + errorfail; + } + else if (i > k_level) + i = k_level; + + fprintf(std_f,"co-expression_%ld(%ld)\n\n", + (long)BlkLoc(k_current)->coexpr.id, + (long)BlkLoc(k_current)->coexpr.size); + fflush(std_f); +#ifdef MultiThread + if (ce) { + if ((ce->es_pfp == NULL) || (ce->es_argp == NULL)) fail; + ENTERPSTATE(ce->program); + r = xdisp(ce->es_pfp, ce->es_argp, (int)i, std_f); + ENTERPSTATE(savedprog); + } + else +#endif /* MultiThread */ + r = xdisp(pfp, glbl_argp, (int)i, std_f); + if (r == Failed) + runerr(305); + return nulldesc; + } +end + + +"errorclear() - clear error condition." + +function{1} errorclear() + abstract { + return null + } + body { + k_errornumber = 0; + k_errortext = ""; + k_errorvalue = nulldesc; + have_errval = 0; + return nulldesc; + } +end + +#if !COMPILER + +"function() - generate the names of the functions." + +function{*} function() + abstract { + return string + } + body { + register int i; + + for (i = 0; i<pnsize; i++) { + suspend string(strlen(pntab[i].pstrep), pntab[i].pstrep); + } + fail; + } +end +#endif /* !COMPILER */ + + +/* + * the bitwise operators are identical enough to be expansions + * of a macro. + */ + +#begdef bitop(func_name, c_op, operation) +#func_name "(i,j) - produce bitwise " operation " of i and j." +function{1} func_name(i,j) + /* + * i and j must be integers + */ + if !cnv:integer(i) then + runerr(101,i) + if !cnv:integer(j) then + runerr(101,j) + + abstract { + return integer + } + inline { +#ifdef LargeInts + if ((Type(i)==T_Lrgint) || (Type(j)==T_Lrgint)) { + big_ ## c_op(i,j); + } + else +#endif /* LargeInts */ + return C_integer IntVal(i) c_op IntVal(j); + } +end +#enddef + +#define bitand & +#define bitor | +#define bitxor ^ +#begdef big_bitand(x,y) +{ + if (bigand(&x, &y, &result) == Error) /* alcbignum failed */ + runerr(0); + return result; +} +#enddef +#begdef big_bitor(x,y) +{ + if (bigor(&x, &y, &result) == Error) /* alcbignum failed */ + runerr(0); + return result; +} +#enddef +#begdef big_bitxor(x,y) +{ + if (bigxor(&x, &y, &result) == Error) /* alcbignum failed */ + runerr(0); + return result; +} +#enddef + +bitop(iand, bitand, "AND") /* iand(i,j) bitwise "and" of i and j */ +bitop(ior, bitor, "inclusive OR") /* ior(i,j) bitwise "or" of i and j */ +bitop(ixor, bitxor, "exclusive OR") /* ixor(i,j) bitwise "xor" of i and j */ + + +"icom(i) - produce bitwise complement (one's complement) of i." + +function{1} icom(i) + /* + * i must be an integer + */ + if !cnv:integer(i) then + runerr(101, i) + + abstract { + return integer + } + inline { +#ifdef LargeInts + if (Type(i) == T_Lrgint) { + struct descrip td; + + td.dword = D_Integer; + IntVal(td) = -1; + if (bigsub(&td, &i, &result) == Error) /* alcbignum failed */ + runerr(0); + return result; + } + else +#endif /* LargeInts */ + return C_integer ~IntVal(i); + } +end + + +"image(x) - return string image of object x." +/* + * All the interesting work happens in getimage() + */ +function{1} image(x) + abstract { + return string + } + inline { + if (getimage(&x,&result) == Error) + runerr(0); + return result; + } +end + + +"ishift(i,j) - produce i shifted j bit positions (left if j<0, right if j>0)." + +function{1} ishift(i,j) + + if !cnv:integer(i) then + runerr(101, i) + if !cnv:integer(j) then + runerr(101, j) + + abstract { + return integer + } + body { + uword ci; /* shift in 0s, even if negative */ + C_integer cj; +#ifdef LargeInts + if (Type(j) == T_Lrgint) + runerr(101,j); + cj = IntVal(j); + if (Type(i) == T_Lrgint || cj >= WordBits + || ((ci=(uword)IntVal(i))!=0 && cj>0 && (ci >= (1<<(WordBits-cj-1))))) { + if (bigshift(&i, &j, &result) == Error) /* alcbignum failed */ + runerr(0); + return result; + } +#else /* LargeInts */ + ci = (uword)IntVal(i); + cj = IntVal(j); +#endif /* LargeInts */ + /* + * Check for a shift of WordSize or greater; handle specially because + * this is beyond C's defined behavior. Otherwise shift as requested. + */ + if (cj >= WordBits) + return C_integer 0; + if (cj <= -WordBits) + return C_integer ((IntVal(i) >= 0) ? 0 : -1); + if (cj >= 0) + return C_integer ci << cj; + if (IntVal(i) >= 0) + return C_integer ci >> -cj; + /*else*/ + return C_integer ~(~ci >> -cj); /* sign extending shift */ + } +end + + +"ord(s) - produce integer ordinal (value) of single character." + +function{1} ord(s) + if !cnv:tmp_string(s) then + runerr(103, s) + abstract { + return integer + } + body { + if (StrLen(s) != 1) + runerr(205, s); + return C_integer (*StrLoc(s) & 0xFF); + } +end + + +"name(v) - return the name of a variable." + +#ifdef MultiThread +function{1} name(underef v, c) + declare { + struct progstate *prog, *savedprog; + } +#else /* MultiThread */ +function{1} name(underef v) +#endif /* MultiThread */ + /* + * v must be a variable + */ + if !is:variable(v) then + runerr(111, v); + + abstract { + return string + } + + body { + C_integer i; + if (!debug_info) + runerr(402); + +#ifdef MultiThread + savedprog = curpstate; + if (is:null(c)) { + prog = curpstate; + } + else if (is:coexpr(c)) { + prog = BlkLoc(c)->coexpr.program; + } + else { + runerr(118,c); + } + + ENTERPSTATE(prog); +#endif /* MultiThread */ + i = get_name(&v, &result); /* return val ? #%#% */ + +#ifdef MultiThread + ENTERPSTATE(savedprog); +#endif /* MultiThread */ + + if (i == Error) + runerr(0); + return result; + } +end + + +"runerr(i,x) - produce runtime error i with value x." + +function{} runerr(i,x[n]) + + if !cnv:C_integer(i) then + runerr(101,i) + body { + if (i <= 0) { + irunerr(205,i); + errorfail; + } + if (n == 0) + runerr((int)i); + else + runerr((int)i, x[0]); + } +end + +"seq(i, j) - generate i, i+j, i+2*j, ... ." + +function{1,*} seq(from, by) + + if !def:C_integer(from, 1) then + runerr(101, from) + if !def:C_integer(by, 1) then + runerr(101, by) + abstract { + return integer + } + body { + word seq_lb = 0, seq_ub = 0; + + /* + * Produce error if by is 0, i.e., an infinite sequence of from's. + */ + if (by > 0) { + seq_lb = MinLong + by; + seq_ub = MaxLong; + } + else if (by < 0) { + seq_lb = MinLong; + seq_ub = MaxLong + by; + } + else if (by == 0) { + irunerr(211, by); + errorfail; + } + + /* + * Suspend sequence, stopping when largest or smallest integer + * is reached. + */ + do { + suspend C_integer from; + from += by; + } + while (from >= seq_lb && from <= seq_ub); + +#if !COMPILER + { + /* + * Suspending wipes out some things needed by the trace back code to + * render the offending expression. Restore them. + */ + lastop = Op_Invoke; + xnargs = 2; + xargp = r_args; + r_args[0].dword = D_Proc; + r_args[0].vword.bptr = (union block *)&Bseq; + } +#endif /* COMPILER */ + + runerr(203); + } +end + +"serial(x) - return serial number of structure." + +function {0,1} serial(x) + abstract { + return integer + } + + type_case x of { + list: inline { + return C_integer BlkLoc(x)->list.id; + } + set: inline { + return C_integer BlkLoc(x)->set.id; + } + table: inline { + return C_integer BlkLoc(x)->table.id; + } + record: inline { + return C_integer BlkLoc(x)->record.id; + } + coexpr: inline { + return C_integer BlkLoc(x)->coexpr.id; + } +#ifdef Graphics + file: inline { + if (BlkLoc(x)->file.status & Fs_Window) { + wsp ws = ((wbp)(BlkLoc(x)->file.fd))->window; + return C_integer ws->serial; + } + else { + fail; + } + } +#endif /* Graphics */ + default: + inline { fail; } + } +end + +"sort(x,i) - sort structure x by method i (for tables)" + +function{1} sort(t, i) + type_case t of { + list: { + abstract { + return type(t) + } + body { + register word size; + + /* + * Sort the list by copying it into a new list and then using + * qsort to sort the descriptors. (That was easy!) + */ + size = BlkLoc(t)->list.size; + if (cplist(&t, &result, (word)1, size + 1) == Error) + runerr(0); + qsort((char *)BlkLoc(result)->list.listhead->lelem.lslots, + (int)size, sizeof(struct descrip), (int (*)()) anycmp); + + Desc_EVValD(BlkLoc(result), E_Lcreate, D_List); + return result; + } + } + + record: { + abstract { + return new list(store[type(t).all_fields]) + } + body { + register dptr d1; + register word size; + tended struct b_list *lp; + union block *ep, *bp; + register int i; + /* + * Create a list the size of the record, copy each element into + * the list, and then sort the list using qsort as in list + * sorting and return the sorted list. + */ + size = BlkLoc(t)->record.recdesc->proc.nfields; + + Protect(lp = alclist(size), runerr(0)); + Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); + lp->listhead = lp->listtail = ep; +#ifdef ListFix + ep->lelem.listprev = ep->lelem.listnext = (union block *) lp; +#endif /* ListFix */ + bp = BlkLoc(t); /* need not be tended if not set until now */ + + if (size > 0) { /* only need to sort non-empty records */ + d1 = lp->listhead->lelem.lslots; + for (i = 0; i < size; i++) + *d1++ = bp->record.fields[i]; + qsort((char *)lp->listhead->lelem.lslots,(int)size, + sizeof(struct descrip), (int (*)())anycmp); + } + + Desc_EVValD(lp, E_Lcreate, D_List); + return list(lp); + } + } + + set: { + abstract { + return new list(store[type(t).set_elem]) + } + body { + register dptr d1; + register word size; + register int j, k; + tended struct b_list *lp; + union block *ep, *bp; + register struct b_slots *seg; + /* + * Create a list the size of the set, copy each element into + * the list, and then sort the list using qsort as in list + * sorting and return the sorted list. + */ + size = BlkLoc(t)->set.size; + + Protect(lp = alclist(size), runerr(0)); + Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); + lp->listhead = lp->listtail = ep; +#ifdef ListFix + ep->lelem.listprev = ep->lelem.listnext = (union block *)lp; +#endif /* ListFix */ + bp = BlkLoc(t); /* need not be tended if not set until now */ + + if (size > 0) { /* only need to sort non-empty sets */ + d1 = lp->listhead->lelem.lslots; + for (j = 0; j < HSegs && (seg = bp->table.hdir[j]) != NULL; j++) + for (k = segsize[j] - 1; k >= 0; k--) + for (ep = seg->hslots[k]; ep != NULL; ep= ep->telem.clink) + *d1++ = ep->selem.setmem; + qsort((char *)lp->listhead->lelem.lslots,(int)size, + sizeof(struct descrip), (int (*)())anycmp); + } + + Desc_EVValD(lp, E_Lcreate, D_List); + return list(lp); + } + } + + table: { + abstract { + return new list(new list(store[type(t).tbl_key ++ + type(t).tbl_val]) ++ store[type(t).tbl_key ++ type(t).tbl_val]) + } + if !def:C_integer(i, 1) then + runerr(101, i) + body { + register dptr d1; + register word size; + register int j, k, n; + tended struct b_table *bp; + tended struct b_list *lp, *tp; + tended union block *ep, *ev; + tended struct b_slots *seg; + + switch ((int)i) { + + /* + * Cases 1 and 2 are as in early versions of Icon + */ + case 1: + case 2: + { + /* + * The list resulting from the sort will have as many elements + * as the table has, so get that value and also make a valid + * list block size out of it. + */ + size = BlkLoc(t)->table.size; + + /* + * Make sure, now, that there's enough room for all the + * allocations we're going to need. + */ + if (!reserve(Blocks, (word)(sizeof(struct b_list) + + sizeof(struct b_lelem) + (size - 1) * sizeof(struct descrip) + + size * sizeof(struct b_list) + + size * (sizeof(struct b_lelem) + sizeof(struct descrip))))) + runerr(0); + /* + * Point bp at the table header block of the table to be sorted + * and point lp at a newly allocated list + * that will hold the the result of sorting the table. + */ + bp = (struct b_table *)BlkLoc(t); + Protect(lp = alclist(size), runerr(0)); + Protect(ep=(union block *)alclstb(size,(word)0,size),runerr(0)); + lp->listtail = lp->listhead = ep; +#ifdef ListFix + ep->lelem.listprev = ep->lelem.listnext = (union block *) lp; +#endif /* ListFix */ + /* + * If the table is empty, there is no need to sort anything. + */ + if (size <= 0) + break; + /* + * Traverse the element chain for each table bucket. For each + * element, allocate a two-element list and put the table + * entry value in the first element and the assigned value in + * the second element. The two-element list is assigned to + * the descriptor that d1 points at. When this is done, the + * list of two-element lists is complete, but unsorted. + */ + + n = 0; /* list index */ + for (j = 0; j < HSegs && (seg = bp->hdir[j]) != NULL; j++) + for (k = segsize[j] - 1; k >= 0; k--) + for (ep= seg->hslots[k]; +#ifdef TableFix + BlkType(ep) == T_Telem; +#else /* TableFix */ + ep != NULL; +#endif /* TableFix */ + ep = ep->telem.clink){ + Protect(tp = alclist((word)2), runerr(0)); + Protect(ev = (union block *)alclstb((word)2, + (word)0, (word)2), runerr(0)); + tp->listhead = tp->listtail = ev; +#ifdef ListFix + ev->lelem.listprev = ev->lelem.listnext = + (union block *)tp; +#endif /* ListFix */ + tp->listhead->lelem.lslots[0] = ep->telem.tref; + tp->listhead->lelem.lslots[1] = ep->telem.tval; + d1 = &lp->listhead->lelem.lslots[n++]; + d1->dword = D_List; + BlkLoc(*d1) = (union block *)tp; + } + /* + * Sort the resulting two-element list using the sorting + * function determined by i. + */ + if (i == 1) + qsort((char *)lp->listhead->lelem.lslots, (int)size, + sizeof(struct descrip), (int (*)())trefcmp); + else + qsort((char *)lp->listhead->lelem.lslots, (int)size, + sizeof(struct descrip), (int (*)())tvalcmp); + break; /* from cases 1 and 2 */ + } + /* + * Cases 3 and 4 were introduced in Version 5.10. + */ + case 3 : + case 4 : + { + /* + * The list resulting from the sort will have twice as many + * elements as the table has, so get that value and also make + * a valid list block size out of it. + */ + size = BlkLoc(t)->table.size * 2; + + /* + * Point bp at the table header block of the table to be sorted + * and point lp at a newly allocated list + * that will hold the the result of sorting the table. + */ + bp = (struct b_table *)BlkLoc(t); + Protect(lp = alclist(size), runerr(0)); + Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); + lp->listhead = lp->listtail = ep; +#ifdef ListFix + ep->lelem.listprev = ep->lelem.listnext = (union block *)lp; +#endif /* ListFix */ + /* + * If the table is empty there's no need to sort anything. + */ + if (size <= 0) + break; + + /* + * Point d1 at the start of the list elements in the new list + * element block in preparation for use as an index into the list. + */ + d1 = lp->listhead->lelem.lslots; + /* + * Traverse the element chain for each table bucket. For each + * table element copy the the entry descriptor and the value + * descriptor into adjacent descriptors in the lslots array + * in the list element block. + * When this is done we now need to sort this list. + */ + + for (j = 0; j < HSegs && (seg = bp->hdir[j]) != NULL; j++) + for (k = segsize[j] - 1; k >= 0; k--) + for (ep = seg->hslots[k]; +#ifdef TableFix + BlkType(ep) == T_Telem; +#else /* TableFix */ + ep != NULL; +#endif /* TableFix */ + ep = ep->telem.clink) { + *d1++ = ep->telem.tref; + *d1++ = ep->telem.tval; + } + /* + * Sort the resulting two-element list using the + * sorting function determined by i. + */ + if (i == 3) + qsort((char *)lp->listhead->lelem.lslots, (int)size / 2, + (2 * sizeof(struct descrip)), (int (*)())trcmp3); + else + qsort((char *)lp->listhead->lelem.lslots, (int)size / 2, + (2 * sizeof(struct descrip)), (int (*)())tvcmp4); + break; /* from case 3 or 4 */ + } + + default: { + irunerr(205, i); + errorfail; + } + + } /* end of switch statement */ + + /* + * Make result point at the sorted list. + */ + + Desc_EVValD(lp, E_Lcreate, D_List); + return list(lp); + } + } + + default: + runerr(115, t); /* structure expected */ + } +end + +/* + * trefcmp(d1,d2) - compare two-element lists on first field. + */ + +int trefcmp(d1,d2) +dptr d1, d2; + { + +#ifdef DeBug + if (d1->dword != D_List || d2->dword != D_List) + syserr("trefcmp: internal consistency check fails."); +#endif /* DeBug */ + + return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[0]), + &(BlkLoc(*d2)->list.listhead->lelem.lslots[0]))); + } + +/* + * tvalcmp(d1,d2) - compare two-element lists on second field. + */ + +int tvalcmp(d1,d2) +dptr d1, d2; + { + +#ifdef DeBug + if (d1->dword != D_List || d2->dword != D_List) + syserr("tvalcmp: internal consistency check fails."); +#endif /* DeBug */ + + return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[1]), + &(BlkLoc(*d2)->list.listhead->lelem.lslots[1]))); + } + +/* + * The following two routines are used to compare descriptor pairs in the + * experimental table sort. + * + * trcmp3(dp1,dp2) + */ + +int trcmp3(dp1,dp2) +struct dpair *dp1,*dp2; +{ + return (anycmp(&((*dp1).dr),&((*dp2).dr))); +} +/* + * tvcmp4(dp1,dp2) + */ + +int tvcmp4(dp1,dp2) +struct dpair *dp1,*dp2; + + { + return (anycmp(&((*dp1).dv),&((*dp2).dv))); + } + + +"sortf(x,i) - sort list or set x on field i of each member" + +function{1} sortf(t, i) + type_case t of { + list: { + abstract { + return type(t) + } + if !def:C_integer(i, 1) then + runerr (101, i) + body { + register word size; + extern word sort_field; + + if (i == 0) { + irunerr(205, i); + errorfail; + } + /* + * Sort the list by copying it into a new list and then using + * qsort to sort the descriptors. (That was easy!) + */ + size = BlkLoc(t)->list.size; + if (cplist(&t, &result, (word)1, size + 1) == Error) + runerr(0); + sort_field = i; + qsort((char *)BlkLoc(result)->list.listhead->lelem.lslots, + (int)size, sizeof(struct descrip), (int (*)()) nthcmp); + + Desc_EVValD(BlkLoc(result), E_Lcreate, D_List); + return result; + } + } + + record: { + abstract { + return new list(any_value) + } + if !def:C_integer(i, 1) then + runerr(101, i) + body { + register dptr d1; + register word size; + tended struct b_list *lp; + union block *ep, *bp; + register int j; + extern word sort_field; + + if (i == 0) { + irunerr(205, i); + errorfail; + } + /* + * Create a list the size of the record, copy each element into + * the list, and then sort the list using qsort as in list + * sorting and return the sorted list. + */ + size = BlkLoc(t)->record.recdesc->proc.nfields; + + Protect(lp = alclist(size), runerr(0)); + Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); + lp->listhead = lp->listtail = ep; +#ifdef ListFix + ep->lelem.listprev = ep->lelem.listnext = (union block *) lp; +#endif /* ListFix */ + bp = BlkLoc(t); /* need not be tended if not set until now */ + + if (size > 0) { /* only need to sort non-empty records */ + d1 = lp->listhead->lelem.lslots; + for (j = 0; j < size; j++) + *d1++ = bp->record.fields[j]; + sort_field = i; + qsort((char *)lp->listhead->lelem.lslots,(int)size, + sizeof(struct descrip), (int (*)())nthcmp); + } + + Desc_EVValD(lp, E_Lcreate, D_List); + return list(lp); + } + } + + set: { + abstract { + return new list(store[type(t).set_elem]) + } + if !def:C_integer(i, 1) then + runerr (101, i) + body { + register dptr d1; + register word size; + register int j, k; + tended struct b_list *lp; + union block *ep, *bp; + register struct b_slots *seg; + extern word sort_field; + + if (i == 0) { + irunerr(205, i); + errorfail; + } + /* + * Create a list the size of the set, copy each element into + * the list, and then sort the list using qsort as in list + * sorting and return the sorted list. + */ + size = BlkLoc(t)->set.size; + + Protect(lp = alclist(size), runerr(0)); + Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); + lp->listhead = lp->listtail = ep; +#ifdef ListFix + ep->lelem.listprev = ep->lelem.listnext = (union block *)lp; +#endif /* ListFix */ + bp = BlkLoc(t); /* need not be tended if not set until now */ + + if (size > 0) { /* only need to sort non-empty sets */ + d1 = lp->listhead->lelem.lslots; + for (j = 0; j < HSegs && (seg = bp->table.hdir[j]) != NULL; j++) + for (k = segsize[j] - 1; k >= 0; k--) + for (ep = seg->hslots[k]; ep != NULL; ep= ep->telem.clink) + *d1++ = ep->selem.setmem; + sort_field = i; + qsort((char *)lp->listhead->lelem.lslots,(int)size, + sizeof(struct descrip), (int (*)())nthcmp); + } + + Desc_EVValD(lp, E_Lcreate, D_List); + return list(lp); + } + } + + default: + runerr(125, t); /* list, record, or set expected */ + } +end + +/* + * nthcmp(d1,d2) - compare two descriptors on their nth fields. + */ +word sort_field; /* field number, set by sort function */ +static dptr nth (dptr d); + +int nthcmp(d1,d2) +dptr d1, d2; + { + int t1, t2, rv; + dptr e1, e2; + + t1 = Type(*d1); + t2 = Type(*d2); + if (t1 == t2 && (t1 == T_Record || t1 == T_List)) { + e1 = nth(d1); /* get nth field, or NULL if none such */ + e2 = nth(d2); + if (e1 == NULL) { + if (e2 != NULL) + return -1; /* no-nth-field is < any nth field */ + } + else if (e2 == NULL) + return 1; /* any nth field is > no-nth-field */ + else { + /* + * Both had an nth field. If they're unequal, that decides. + */ + rv = anycmp(nth(d1), nth(d2)); + if (rv != 0) + return rv; + } + } + /* + * Comparison of nth fields was either impossible or indecisive. + * Settle it by comparing the descriptors directly. + */ + return anycmp(d1, d2); + } + +/* + * nth(d) - return the nth field of d, if any. (sort_field is "n".) + */ +static dptr nth(d) +dptr d; + { + union block *bp; + struct b_list *lp; + word i, j; + dptr rv; + + rv = NULL; + if (d->dword == D_Record) { + /* + * Find the nth field of a record. + */ + bp = BlkLoc(*d); + i = cvpos((long)sort_field, (long)(bp->record.recdesc->proc.nfields)); + if (i != CvtFail && i <= bp->record.recdesc->proc.nfields) + rv = &bp->record.fields[i-1]; + } + else if (d->dword == D_List) { + /* + * Find the nth element of a list. + */ + lp = (struct b_list *)BlkLoc(*d); + i = cvpos ((long)sort_field, (long)lp->size); + if (i != CvtFail && i <= lp->size) { + /* + * Locate the correct list-element block. + */ + bp = lp->listhead; + j = 1; + while (i >= j + bp->lelem.nused) { + j += bp->lelem.nused; + bp = bp->lelem.listnext; + } + /* + * Locate the desired element. + */ + i += bp->lelem.first - j; + if (i >= bp->lelem.nslots) + i -= bp->lelem.nslots; + rv = &bp->lelem.lslots[i]; + } + } + return rv; + } + + +"type(x) - return type of x as a string." + +function{1} type(x) + abstract { + return string + } + type_case x of { + string: inline { return C_string "string"; } + null: inline { return C_string "null"; } + integer: inline { return C_string "integer"; } + real: inline { return C_string "real"; } + cset: inline { return C_string "cset"; } + file: + inline { +#ifdef Graphics + if (BlkLoc(x)->file.status & Fs_Window) + return C_string "window"; +#endif /* Graphics */ + return C_string "file"; + } + proc: inline { return C_string "procedure"; } + list: inline { return C_string "list"; } + table: inline { return C_string "table"; } + set: inline { return C_string "set"; } + record: inline { return BlkLoc(x)->record.recdesc->proc.recname; } + coexpr: inline { return C_string "co-expression"; } + default: + inline { +#if !COMPILER + if (!Qual(x) && (Type(x)==T_External)) { + return C_string "external"; + } + else +#endif /* !COMPILER */ + runerr(123,x); + } + } +end + + +"variable(s) - find the variable with name s and return a" +" variable descriptor which points to its value." + +#ifdef MultiThread +function{0,1} variable(s,c,i) +#else /* MultiThread */ +function{0,1} variable(s) +#endif /* MultiThread */ + + if !cnv:C_string(s) then + runerr(103, s) + +#ifdef MultiThread + if !def:C_integer(i,0) then + runerr(101,i) +#endif /* MultiThread */ + + abstract { + return variable + } + + body { + register int rv; + +#ifdef MultiThread + struct progstate *prog, *savedprog; + struct pf_marker *tmp_pfp = pfp; + dptr tmp_argp = glbl_argp; + + savedprog = curpstate; + if (!is:null(c)) { + if (is:coexpr(c)) { + prog = BlkLoc(c)->coexpr.program; + pfp = BlkLoc(c)->coexpr.es_pfp; + glbl_argp = BlkLoc(c)->coexpr.es_argp; + ENTERPSTATE(prog); + } + else { + runerr(118, c); + } + } + + /* + * Produce error if i is negative + */ + if (i < 0) { + irunerr(205, i); + errorfail; + } + + while (i--) { + if (pfp == NULL) fail; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + } +#endif /* MultiThread */ + + rv = getvar(s, &result); + +#ifdef MultiThread + if (is:coexpr(c)) { + ENTERPSTATE(savedprog); + pfp = tmp_pfp; + glbl_argp = tmp_argp; + + if ((rv == LocalName) || (rv == StaticName)) { + Deref(result); + } + } +#endif /* MultiThread */ + + if (rv != Failed) + return result; + else + fail; + } +end + +#ifdef MultiThread + +"cofail(CE) - transmit a co-expression failure to CE" + +function{0,1} cofail(CE) + abstract { + return any_value + } + if is:null(CE) then + body { + struct b_coexpr *ce = topact((struct b_coexpr *)BlkLoc(k_current)); + if (ce != NULL) { + CE.dword = D_Coexpr; + BlkLoc(CE) = (union block *)ce; + } + else runerr(118,CE); + } + else if !is:coexpr(CE) then + runerr(118,CE) + body { + struct b_coexpr *ncp = (struct b_coexpr *)BlkLoc(CE); + if (co_chng(ncp, NULL, &result, A_Cofail, 1) == A_Cofail) fail; + return result; + } +end + + +"fieldnames(r) - generate the fieldnames of record r" + +function{*} fieldnames(r) + abstract { + return string + } + if !is:record(r) then runerr(107,r) + body { + int i; + for(i=0;i<BlkLoc(r)->record.recdesc->proc.nfields;i++) { + suspend BlkLoc(r)->record.recdesc->proc.lnames[i]; + } + fail; + } +end + + +"localnames(ce,i) - produce the names of local variables" +" in the procedure activation i levels up in ce" +function{*} localnames(ce,i) + declare { + tended struct descrip d; + } + abstract { + return string + } + if is:null(ce) then inline { + d = k_current; + BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ + } + else if is:proc(ce) then inline { + int j; + struct b_proc *cproc = (struct b_proc *)BlkLoc(ce); + for(j = 0; j < cproc->ndynam; j++) { + result = cproc->lnames[j + cproc->nparam]; + suspend result; + } + fail; + } + else if is:coexpr(ce) then inline { + d = ce; + BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ + } + else runerr(118, ce) + if !def:C_integer(i,0) then + runerr(101,i) + body { +#if !COMPILER + int j; + dptr arg; + struct b_proc *cproc; + struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp; + + if (thePfp == NULL) fail; + + /* + * Produce error if i is negative + */ + if (i < 0) { + irunerr(205, i); + errorfail; + } + + while (i--) { + thePfp = thePfp->pf_pfp; + if (thePfp == NULL) fail; + } + + arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1]; + cproc = (struct b_proc *)BlkLoc(arg[0]); + for(j = 0; j < cproc->ndynam; j++) { + result = cproc->lnames[j + cproc->nparam]; + suspend result; + } +#endif /* !COMPILER */ + fail; + } +end + + + +"staticnames(ce,i) - produce the names of static variables" +" in the current procedure activation in ce" + +function{*} staticnames(ce,i) + declare { + tended struct descrip d; + } + abstract { + return string + } + if is:null(ce) then inline { + d = k_current; + BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ + } + else if is:proc(ce) then inline { + int j; + struct b_proc *cproc = (struct b_proc *)BlkLoc(ce); + for(j = 0; j < cproc->nstatic; j++) { + result = cproc->lnames[j + cproc->nparam + cproc->ndynam]; + suspend result; + } + fail; + } + else if is:coexpr(ce) then inline { + d = ce; + BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ + } + else runerr(118,ce) + if !def:C_integer(i,0) then + runerr(101,i) + body { +#if !COMPILER + int j; + dptr arg; + struct b_proc *cproc; + struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp; + if (thePfp == NULL) fail; + + /* + * Produce error if i is negative + */ + if (i < 0) { + irunerr(205, i); + errorfail; + } + + while (i--) { + thePfp = thePfp->pf_pfp; + if (thePfp == NULL) fail; + } + + arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1]; + cproc = (struct b_proc *)BlkLoc(arg[0]); + for(j=0; j < cproc->nstatic; j++) { + result = cproc->lnames[j + cproc->nparam + cproc->ndynam]; + suspend result; + } +#endif /* !COMPILER */ + fail; + } +end + +"paramnames(ce,i) - produce the names of the parameters" +" in the current procedure activation in ce" + +function{1,*} paramnames(ce,i) + declare { + tended struct descrip d; + } + abstract { + return string + } + if is:null(ce) then inline { + d = k_main; + BlkLoc(k_main)->coexpr.es_pfp = pfp; /* sync w/ current value */ + } + else if is:proc(ce) then inline { + int j; + struct b_proc *cproc = (struct b_proc *)BlkLoc(ce); + for(j = 0; j < cproc->nparam; j++) { + result = cproc->lnames[j]; + suspend result; + } + fail; + } + else if is:coexpr(ce) then inline { + d = ce; + BlkLoc(k_main)->coexpr.es_pfp = pfp; /* sync w/ current value */ + } + else runerr(118,ce) + if !def:C_integer(i,0) then + runerr(101,i) + body { +#if !COMPILER + int j; + dptr arg; + struct b_proc *cproc; + struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp; + + if (thePfp == NULL) fail; + + /* + * Produce error if i is negative + */ + if (i < 0) { + irunerr(205, i); + errorfail; + } + + while (i--) { + thePfp = thePfp->pf_pfp; + if (thePfp == NULL) fail; + } + + arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1]; + cproc = (struct b_proc *)BlkLoc(arg[0]); + for(j = 0; j < cproc->nparam; j++) { + result = cproc->lnames[j]; + suspend result; + } +#endif /* !COMPILER */ + fail; + } +end + + +"load(s,arglist,input,output,error,blocksize,stringsize,stacksize) - load" +" an icode file corresponding to string s as a co-expression." + +function{1} load(s,arglist,infile,outfile,errfile, + blocksize, stringsize, stacksize) + declare { + tended char *loadstring; + C_integer _bs_, _ss_, _stk_; + } + if !cnv:C_string(s,loadstring) then + runerr(103,s) + if !def:C_integer(blocksize,abrsize,_bs_) then + runerr(101,blocksize) + if !def:C_integer(stringsize,ssize,_ss_) then + runerr(101,stringsize) + if !def:C_integer(stacksize,mstksize,_stk_) then + runerr(101,stacksize) + abstract { + return coexpr + } + body { + word *stack; + struct progstate *pstate; + char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; + register struct b_coexpr *sblkp; + register struct b_refresh *rblkp; + struct ef_marker *newefp; + register dptr dp, ndp, dsp; + register word *newsp, *savedsp; + int na, nl, i, j, num_fileargs = 0; + struct b_file *theInput = NULL, *theOutput = NULL, *theError = NULL; + struct b_proc *cproc; + extern char *prog_name; + + /* + * Fragments of pseudo-icode to get loaded programs started, + * and to handle termination. + */ + static word pstart[7]; + static word *lterm; + + inst tipc; + + tipc.opnd = pstart; + *tipc.op++ = Op_Noop; /* aligns Invokes operand */ /* ?cj? */ + *tipc.op++ = Op_Invoke; + *tipc.opnd++ = 1; + *tipc.op++ = Op_Coret; + *tipc.op++ = Op_Efail; + + lterm = (word *)(tipc.op); + + *tipc.op++ = Op_Cofail; + *tipc.op++ = Op_Agoto; + *tipc.opnd = (word)lterm; + + prog_name = loadstring; /* set up for &progname */ + + /* + * arglist must be a list + */ + if (!is:null(arglist) && !is:list(arglist)) + runerr(108,arglist); + + /* + * input, output, and error must be files + */ + if (is:null(infile)) + theInput = &(curpstate->K_input); + else { + if (!is:file(infile)) + runerr(105,infile); + else theInput = &(BlkLoc(infile)->file); + } + if (is:null(outfile)) + theOutput = &(curpstate->K_output); + else { + if (!is:file(outfile)) + runerr(105,outfile); + else theOutput = &(BlkLoc(outfile)->file); + } + if (is:null(errfile)) + theError = &(curpstate->K_errout); + else { + if (!is:file(errfile)) + runerr(105,errfile); + else theError = &(BlkLoc(errfile)->file); + } + + stack = + (word *)(sblkp = loadicode(loadstring,theInput,theOutput,theError, + _bs_,_ss_,_stk_)); + if(!stack) { + fail; + } + pstate = sblkp->program; + pstate->parent = curpstate; + pstate->parentdesc = k_main; + + savedsp = sp; + sp = stack + Wsizeof(struct b_coexpr) + + Wsizeof(struct progstate) + pstate->hsize/WordSize; + if (pstate->hsize % WordSize) sp++; + +#ifdef UpStack + sblkp->cstate[0] = + ((word)((char *)sblkp + (mstksize - (sizeof(*sblkp)+sizeof(struct progstate)+pstate->hsize))/2) + &~((word)WordSize*StackAlign-1)); +#else /* UpStack */ + sblkp->cstate[0] = + ((word)((char *)sblkp + mstksize - WordSize + sizeof(struct progstate) + pstate->hsize) + &~((word)WordSize*StackAlign-1)); +#endif /* UpStack */ + + sblkp->es_argp = NULL; + sblkp->es_gfp = NULL; + pstate->Mainhead->freshblk = nulldesc;/* &main has no refresh block. */ + /* This really is a bug. */ + + /* + * Set up expression frame marker to contain execution of the + * main procedure. If failure occurs in this context, control + * is transferred to lterm, the address of an ... + */ + newefp = (struct ef_marker *)(sp+1); +#if IntBits != WordBits + newefp->ef_failure.op = (int *)lterm; +#else /* IntBits != WordBits */ + newefp->ef_failure.op = lterm; +#endif /* IntBits != WordBits */ + + newefp->ef_gfp = 0; + newefp->ef_efp = 0; + newefp->ef_ilevel = ilevel/*1*/; + sp += Wsizeof(*newefp) - 1; + sblkp->es_efp = newefp; + + /* + * The first global variable holds the value of "main". If it + * is not of type procedure, this is noted as run-time error 117. + * Otherwise, this value is pushed on the stack. + */ + if (pstate->Globals[0].dword != D_Proc) + fatalerr(117, NULL); + + PushDesc(pstate->Globals[0]); + + /* + * Create a list from arguments using Ollist and push a descriptor + * onto new stack. Then create procedure frame on new stack. Push + * two new null descriptors, and set sblkp->es_sp when all finished. + */ + if (!is:null(arglist)) { + PushDesc(arglist); + pstate->Glbl_argp = (dptr)(sp - 1); + } + else { + PushNull; + pstate->Glbl_argp = (dptr)(sp - 1); + { + dptr tmpargp = (dptr) (sp - 1); + Ollist(0, tmpargp); + sp = (word *)tmpargp + 1; + } + } + sblkp->es_sp = (word *)sp; + sblkp->es_ipc.opnd = pstart; + + result.dword = D_Coexpr; + BlkLoc(result) = (union block *)sblkp; + sp = savedsp; + return result; + } +end + + +"parent(ce) - given a ce, return &main for that ce's parent" + +function{1} parent(ce) + if is:null(ce) then inline { ce = k_current; } + else if !is:coexpr(ce) then runerr(118,ce) + abstract { + return coexpr + } + body { + if (BlkLoc(ce)->coexpr.program->parent == NULL) fail; + + result.dword = D_Coexpr; + BlkLoc(result) = + (union block *)(BlkLoc(ce)->coexpr.program->parent->Mainhead); + return result; + } +end + +#ifdef EventMon + +"eventmask(ce,cs) - given a ce, get or set that program's event mask" + +function{1} eventmask(ce,cs) + if !is:coexpr(ce) then runerr(118,ce) + + if is:null(cs) then { + abstract { + return cset++null + } + body { + result = BlkLoc(ce)->coexpr.program->eventmask; + return result; + } + } + else if !cnv:cset(cs) then runerr(104,cs) + else { + abstract { + return cset + } + body { + ((struct b_coexpr *)BlkLoc(ce))->program->eventmask = cs; + return cs; + } + } +end +#endif /* EventMon */ + + +"globalnames(ce) - produce the names of identifiers global to ce" + +function{*} globalnames(ce) + declare { + struct progstate *ps; + } + abstract { + return string + } + if is:null(ce) then inline { ps = curpstate; } + else if is:coexpr(ce) then + inline { ps = BlkLoc(ce)->coexpr.program; } + else runerr(118,ce) + body { + struct descrip *dp; + for (dp = ps->Gnames; dp != ps->Egnames; dp++) { + suspend *dp; + } + fail; + } +end + +"keyword(kname,ce) - produce a keyword in ce's thread" +function{*} keyword(keyname,ce) + declare { + tended struct descrip d; + tended char *kyname; + } + abstract { + return any_value + } + if !cnv:C_string(keyname,kyname) then runerr(103,keyname) + if is:null(ce) then inline { + d = k_current; + BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ + BlkLoc(k_current)->coexpr.es_ipc.opnd = ipc.opnd; + } + else if is:coexpr(ce) then + inline { d = ce; } + else runerr(118, ce) + body { + struct progstate *p = BlkLoc(d)->coexpr.program; + char *kname = kyname; + if (kname[0] == '&') kname++; + if (strcmp(kname,"allocated") == 0) { + suspend C_integer stattotal + p->stringtotal + p->blocktotal; + suspend C_integer stattotal; + suspend C_integer p->stringtotal; + return C_integer p->blocktotal; + } + else if (strcmp(kname,"collections") == 0) { + suspend C_integer p->colltot; + suspend C_integer p->collstat; + suspend C_integer p->collstr; + return C_integer p->collblk; + } + else if (strcmp(kname,"column") == 0) { + struct progstate *savedp = curpstate; + int i; + ENTERPSTATE(p); + i = findcol(BlkLoc(d)->coexpr.es_ipc.opnd); + ENTERPSTATE(savedp); + return C_integer i; + } + else if (strcmp(kname,"current") == 0) { + return p->K_current; + } + else if (strcmp(kname,"error") == 0) { + return kywdint(&(p->Kywd_err)); + } + else if (strcmp(kname,"errornumber") == 0) { + return C_integer p->K_errornumber; + } + else if (strcmp(kname,"errortext") == 0) { + return C_string p->K_errortext; + } + else if (strcmp(kname,"errorvalue") == 0) { + return p->K_errorvalue; + } + else if (strcmp(kname,"errout") == 0) { + return file(&(p->K_errout)); + } + else if (strcmp(kname,"eventcode") == 0) { + return kywdevent(&(p->eventcode)); + } + else if (strcmp(kname,"eventsource") == 0) { + return kywdevent(&(p->eventsource)); + } + else if (strcmp(kname,"eventvalue") == 0) { + return kywdevent(&(p->eventval)); + } + else if (strcmp(kname,"file") == 0) { + struct progstate *savedp = curpstate; + struct descrip s; + ENTERPSTATE(p); + StrLoc(s) = findfile(BlkLoc(d)->coexpr.es_ipc.opnd); + StrLen(s) = strlen(StrLoc(s)); + ENTERPSTATE(savedp); + if (!strcmp(StrLoc(s),"?")) fail; + return s; + } + else if (strcmp(kname,"input") == 0) { + return file(&(p->K_input)); + } + else if (strcmp(kname,"level") == 0) { + /* + * Bug; levels aren't maintained per program yet. + * But shouldn't they be per co-expression, not per program? + */ + } + else if (strcmp(kname,"line") == 0) { + struct progstate *savedp = curpstate; + int i; + ENTERPSTATE(p); + i = findline(BlkLoc(d)->coexpr.es_ipc.opnd); + ENTERPSTATE(savedp); + return C_integer i; + } + else if (strcmp(kname,"main") == 0) { + return p->K_main; + } + else if (strcmp(kname,"output") == 0) { + return file(&(p->K_output)); + } + else if (strcmp(kname,"pos") == 0) { + return kywdpos(&(p->Kywd_pos)); + } + else if (strcmp(kname,"progname") == 0) { + return kywdstr(&(p->Kywd_prog)); + } + else if (strcmp(kname,"random") == 0) { + return kywdint(&(p->Kywd_ran)); + } + else if (strcmp(kname,"regions") == 0) { + word allRegions = 0; + struct region *rp; + + suspend C_integer 0; + for (rp = p->stringregion; rp; rp = rp->next) + allRegions += DiffPtrs(rp->end,rp->base); + for (rp = p->stringregion->prev; rp; rp = rp->prev) + allRegions += DiffPtrs(rp->end,rp->base); + suspend C_integer allRegions; + + allRegions = 0; + for (rp = p->blockregion; rp; rp = rp->next) + allRegions += DiffPtrs(rp->end,rp->base); + for (rp = p->blockregion->prev; rp; rp = rp->prev) + allRegions += DiffPtrs(rp->end,rp->base); + return C_integer allRegions; + } + else if (strcmp(kname,"source") == 0) { + return coexpr(topact((struct b_coexpr *)BlkLoc(BlkLoc(d)->coexpr.program->K_current))); +/* + if (BlkLoc(d)->coexpr.es_actstk) + return coexpr(topact((struct b_coexpr *)BlkLoc(d))); + else return BlkLoc(d)->coexpr.program->parent->K_main; +*/ + } + else if (strcmp(kname,"storage") == 0) { + word allRegions = 0; + struct region *rp; + suspend C_integer 0; + for (rp = p->stringregion; rp; rp = rp->next) + allRegions += DiffPtrs(rp->free,rp->base); + for (rp = p->stringregion->prev; rp; rp = rp->prev) + allRegions += DiffPtrs(rp->free,rp->base); + suspend C_integer allRegions; + + allRegions = 0; + for (rp = p->blockregion; rp; rp = rp->next) + allRegions += DiffPtrs(rp->free,rp->base); + for (rp = p->blockregion->prev; rp; rp = rp->prev) + allRegions += DiffPtrs(rp->free,rp->base); + return C_integer allRegions; + } + else if (strcmp(kname,"subject") == 0) { + return kywdsubj(&(p->ksub)); + } + else if (strcmp(kname,"trace") == 0) { + return kywdint(&(p->Kywd_trc)); + } +#ifdef Graphics + else if (strcmp(kname,"window") == 0) { + return kywdwin(&(p->Kywd_xwin[XKey_Window])); + } + else if (strcmp(kname,"col") == 0) { + return kywdint(&(p->AmperCol)); + } + else if (strcmp(kname,"row") == 0) { + return kywdint(&(p->AmperRow)); + } + else if (strcmp(kname,"x") == 0) { + return kywdint(&(p->AmperX)); + } + else if (strcmp(kname,"y") == 0) { + return kywdint(&(p->AmperY)); + } + else if (strcmp(kname,"interval") == 0) { + return kywdint(&(p->AmperInterval)); + } + else if (strcmp(kname,"control") == 0) { + if (p->Xmod_Control) + return nulldesc; + else + fail; + } + else if (strcmp(kname,"shift") == 0) { + if (p->Xmod_Shift) + return nulldesc; + else + fail; + } + else if (strcmp(kname,"meta") == 0) { + if (p->Xmod_Meta) + return nulldesc; + else + fail; + } +#endif /* Graphics */ + runerr(205, keyname); + } +end +#ifdef EventMon + +"opmask(ce,cs) - get or set ce's program's opcode mask" + +function{1} opmask(ce,cs) + if !is:coexpr(ce) then runerr(118,ce) + + if is:null(cs) then { + abstract { + return cset++null + } + body { + result = BlkLoc(ce)->coexpr.program->opcodemask; + return result; + } + } + else if !cnv:cset(cs) then runerr(104,cs) + else { + abstract { + return cset + } + body { + ((struct b_coexpr *)BlkLoc(ce))->program->opcodemask = cs; + return cs; + } + } +end +#endif /* EventMon */ + + +"structure(x) -- generate all structures allocated in program x" +function {*} structure(x) + + if !is:coexpr(x) then + runerr(118, x) + + abstract { + return list ++ set ++ table ++ record + } + + body { + tended char *bp; + char *free; + tended struct descrip descr; + word type; + struct region *theregion, *rp; + +#ifdef MultiThread + theregion = ((struct b_coexpr *)BlkLoc(x))->program->blockregion; +#else + theregion = curblock; +#endif + for(rp = theregion; rp; rp = rp->next) { + bp = rp->base; + free = rp->free; + while (bp < free) { + type = BlkType(bp); + switch (type) { + case T_List: + case T_Set: + case T_Table: + case T_Record: { + BlkLoc(descr) = (union block *)bp; + descr.dword = type | F_Ptr | D_Typecode; + suspend descr; + } + } + bp += BlkSize(bp); + } + } + for(rp = theregion->prev; rp; rp = rp->prev) { + bp = rp->base; + free = rp->free; + while (bp < free) { + type = BlkType(bp); + switch (type) { + case T_List: + case T_Set: + case T_Table: + case T_Record: { + BlkLoc(descr) = (union block *)bp; + descr.dword = type | F_Ptr | D_Typecode; + suspend descr; + } + } + bp += BlkSize(bp); + } + } + fail; + } +end + + +#endif /* MultiThread */ diff --git a/src/runtime/fmonitr.r b/src/runtime/fmonitr.r new file mode 100644 index 0000000..8eeb95e --- /dev/null +++ b/src/runtime/fmonitr.r @@ -0,0 +1,273 @@ +/* + * fmonitr.r -- event, EvGet + * + * This file contains event monitoring code, used only if EventMon + * (event monitoring) is defined. Event monitoring is normally is + * not enabled. + */ + +#ifdef EventMon + +/* + * Prototypes. + */ + +void mmrefresh (void); + +#define evforget() + + +char typech[MaxType+1]; /* output character for each type */ + +int noMTevents; /* don't produce events in EVAsgn */ + +#ifdef MultiThread + +static char scopechars[] = "+:^-"; + +/* + * Special event function for E_Assign; allocates out of monitor's heap. + */ +void EVAsgn(dx) +dptr dx; +{ + int i; + dptr procname; + struct progstate *parent = curpstate->parent; + struct region *rp = curpstate->stringregion; + +#if COMPILER + procname = &(PFDebug(*pfp)->proc->pname); +#else /* COMPILER */ + procname = &((&BlkLoc(*glbl_argp)->proc)->pname); +#endif /* COMPILER */ + /* + * call get_name, allocating out of the monitor if necessary. + */ + curpstate->stringregion = parent->stringregion; + parent->stringregion = rp; + noMTevents++; + i = get_name(dx,&(parent->eventval)); + + if (i == GlobalName) { + if (reserve(Strings, StrLen(parent->eventval) + 1) == NULL) + syserr("event monitoring out-of-memory error"); + StrLoc(parent->eventval) = + alcstr(StrLoc(parent->eventval), StrLen(parent->eventval)); + alcstr("+",1); + StrLen(parent->eventval)++; + } + else if (i == StaticName || i == LocalName || i == ParamName) { + if (!reserve(Strings, StrLen(parent->eventval) + StrLen(*procname) + 1)) + syserr("event monitoring out-of-memory error"); + StrLoc(parent->eventval) = + alcstr(StrLoc(parent->eventval), StrLen(parent->eventval)); + alcstr(scopechars+i,1); + alcstr(StrLoc(*procname), StrLen(*procname)); + StrLen(parent->eventval) += StrLen(*procname) + 1; + } + else if (i == Error) { + noMTevents--; + return; /* should be more violent than this */ + } + + parent->stringregion = curpstate->stringregion; + curpstate->stringregion = rp; + noMTevents--; + actparent(E_Assign); +} + + +/* + * event(x, y, C) -- generate an event at the program level. + */ + +"event(x, y, C) - create event with event code x and event value y." + +function{0,1} event(x,y,ce) + body { + struct progstate *dest; + + if (is:null(x)) { + x = curpstate->eventcode; + if (is:null(y)) y = curpstate->eventval; + } + if (is:null(ce) && is:coexpr(curpstate->parentdesc)) + ce = curpstate->parentdesc; + else if (!is:coexpr(ce)) runerr(118,ce); + dest = BlkLoc(ce)->coexpr.program; + dest->eventcode = x; + dest->eventval = y; + if (mt_activate(&(dest->eventcode),&result, + (struct b_coexpr *)BlkLoc(ce)) == A_Cofail) { + fail; + } + return result; + } +end + +/* + * EvGet(c) - user function for reading event streams. + */ + +"EvGet(c,flag) - read through the next event token having a code matched " +" by cset c." + +/* + * EvGet returns the code of the matched token. These keywords are also set: + * &eventcode token code + * &eventvalue token value + */ +function{0,1} EvGet(cs,flag) + if !def:cset(cs,fullcs) then + runerr(104,cs) + + body { + register int c; + tended struct descrip dummy; + struct progstate *p; + + /* + * Be sure an eventsource is available + */ + if (!is:coexpr(curpstate->eventsource)) + runerr(118,curpstate->eventsource); + + /* + * If our event source is a child of ours, assign its event mask. + */ + p = BlkLoc(curpstate->eventsource)->coexpr.program; + if (p->parent == curpstate) + p->eventmask = cs; + +#ifdef Graphics + if (Testb((word)E_MXevent, cs) && + is:file(kywd_xwin[XKey_Window])) { + wbp _w_ = (wbp)BlkLoc(kywd_xwin[XKey_Window])->file.fd; + pollctr = pollevent(); + if (pollctr == -1) + fatalerr(141, NULL); + if (BlkLoc(_w_->window->listp)->list.size > 0) { + c = wgetevent(_w_, &curpstate->eventval); + if (c == 0) { + StrLen(curpstate->eventcode) = 1; + StrLoc(curpstate->eventcode) = + (char *)&allchars[E_MXevent & 0xFF]; + return curpstate->eventcode; + } + else if (c == -1) + runerr(141); + else + runerr(143); + } + } +#endif /* Graphics */ + + /* + * Loop until we read an event allowed. + */ + while (1) { + /* + * Activate the event source to produce the next event. + */ + dummy = cs; + if (mt_activate(&dummy, &curpstate->eventcode, + (struct b_coexpr *)BlkLoc(curpstate->eventsource)) == + A_Cofail) fail; + deref(&curpstate->eventcode, &curpstate->eventcode); + if (!is:string(curpstate->eventcode) || + StrLen(curpstate->eventcode) != 1) { + /* + * this event is out-of-band data; return or reject it + * depending on whether flag is null. + */ + if (!is:null(flag)) + return curpstate->eventcode; + else continue; + } + + switch(*StrLoc(curpstate->eventcode)) { + case E_Cofail: case E_Coret: { + if (BlkLoc(curpstate->eventsource)->coexpr.id == 1) { + fail; + } + } + } + + return curpstate->eventcode; + } + } +end + +#endif /* MultiThread */ + +/* + * EVInit() - initialization. + */ + +void EVInit() + { + int i; + + /* + * Initialize the typech array, which is used if either file-based + * or MT-based event monitoring is enabled. + */ + + for (i = 0; i <= MaxType; i++) + typech[i] = '?'; /* initialize with error character */ + +#ifdef LargeInts + typech[T_Lrgint] = E_Lrgint; /* long integer */ +#endif /* LargeInts */ + + typech[T_Real] = E_Real; /* real number */ + typech[T_Cset] = E_Cset; /* cset */ + typech[T_File] = E_File; /* file block */ + typech[T_Record] = E_Record; /* record block */ + typech[T_Tvsubs] = E_Tvsubs; /* substring trapped variable */ + typech[T_External]= E_External; /* external block */ + typech[T_List] = E_List; /* list header block */ + typech[T_Lelem] = E_Lelem; /* list element block */ + typech[T_Table] = E_Table; /* table header block */ + typech[T_Telem] = E_Telem; /* table element block */ + typech[T_Tvtbl] = E_Tvtbl; /* table elem trapped variable*/ + typech[T_Set] = E_Set; /* set header block */ + typech[T_Selem] = E_Selem; /* set element block */ + typech[T_Slots] = E_Slots; /* set/table hash slots */ + typech[T_Coexpr] = E_Coexpr; /* co-expression block (static) */ + typech[T_Refresh] = E_Refresh; /* co-expression refresh block */ + + + /* + * codes used elsewhere but not shown here: + * in the static region: E_Alien = alien (malloc block) + * in the static region: E_Free = free + * in the string region: E_String = string + */ + } + +/* + * mmrefresh() - redraw screen, initially or after garbage collection. + */ + +void mmrefresh() + { + char *p; + word n; + + /* + * If the monitor is asking for E_EndCollect events, then it + * can handle these memory allocation "redraw" events. + */ + if (!is:null(curpstate->eventmask) && + Testb((word)E_EndCollect, curpstate->eventmask)) { + for (p = blkbase; p < blkfree; p += n) { + n = BlkSize(p); + EVVal(n, typech[(int)BlkType(p)]); /* block region */ + } + EVVal(DiffPtrs(strfree, strbase), E_String); /* string region */ + } + } + +#endif /* EventMon */ diff --git a/src/runtime/fscan.r b/src/runtime/fscan.r new file mode 100644 index 0000000..8cba731 --- /dev/null +++ b/src/runtime/fscan.r @@ -0,0 +1,149 @@ +/* + * File: fscan.r + * Contents: move, pos, tab. + */ + +"move(i) - move &pos by i, return substring of &subject spanned." +" Reverses effects if resumed." + +function{0,1+} move(i) + + if !cnv:C_integer(i) then + runerr(101,i) + + abstract { + return string + } + + body { + register C_integer j; + C_integer oldpos; + + /* + * Save old &pos. Local variable j holds &pos before the move. + */ + oldpos = j = k_pos; + + /* + * If attempted move is past either end of the string, fail. + */ + if (i + j <= 0 || i + j > StrLen(k_subject) + 1) + fail; + + /* + * Set new &pos. + */ + k_pos += i; + EVVal(k_pos, E_Spos); + + /* + * Make sure i >= 0. + */ + if (i < 0) { + j += i; + i = -i; + } + + /* + * Suspend substring of &subject that was moved over. + */ + suspend string(i, StrLoc(k_subject) + j - 1); + + /* + * If move is resumed, restore the old position and fail. + */ + if (oldpos > StrLen(k_subject) + 1) + runerr(205, kywd_pos); + else { + k_pos = oldpos; + EVVal(k_pos, E_Spos); + } + + fail; + } +end + + +"pos(i) - test if &pos is at position i in &subject." + +function{0,1} pos(i) + + if !cnv:C_integer(i) then + runerr(101, i) + + abstract { + return integer + } + body { + /* + * Fail if &pos is not equivalent to i, return i otherwise. + */ + if ((i = cvpos(i, StrLen(k_subject))) != k_pos) + fail; + return C_integer i; + } +end + + +"tab(i) - set &pos to i, return substring of &subject spanned." +"Reverses effects if resumed." + +function{0,1+} tab(i) + + if !cnv:C_integer(i) then + runerr(101, i); + + abstract { + return string + } + + body { + C_integer j, t, oldpos; + + /* + * Convert i to an absolute position. + */ + i = cvpos(i, StrLen(k_subject)); + if (i == CvtFail) + fail; + + /* + * Save old &pos. Local variable j holds &pos before the tab. + */ + oldpos = j = k_pos; + + /* + * Set new &pos. + */ + k_pos = i; + EVVal(k_pos, E_Spos); + + /* + * Make i the length of the substring &subject[i:j] + */ + if (j > i) { + t = j; + j = i; + i = t - j; + } + else + i = i - j; + + /* + * Suspend the portion of &subject that was tabbed over. + */ + suspend string(i, StrLoc(k_subject) + j - 1); + + /* + * If tab is resumed, restore the old position and fail. + */ + if (oldpos > StrLen(k_subject) + 1) + runerr(205, kywd_pos); + else { + k_pos = oldpos; + EVVal(k_pos, E_Spos); + } + + fail; + } +end diff --git a/src/runtime/fstr.r b/src/runtime/fstr.r new file mode 100644 index 0000000..08d9f10 --- /dev/null +++ b/src/runtime/fstr.r @@ -0,0 +1,720 @@ +/* + * File: fstr.r + * Contents: center, detab, entab, left, map, repl, reverse, right, trim + */ + + +/* + * macro used by center, left, right + */ +#begdef FstrSetup + /* + * s1 must be a string. n must be a non-negative integer and defaults + * to 1. s2 must be a string and defaults to a blank. + */ + if !cnv:string(s1) then + runerr(103,s1) + if !def:C_integer(n,1) then + runerr(101, n) + if !def:tmp_string(s2,blank) then + runerr(103, s2) + + abstract { + return string + } + body { + register char *s, *st; + word slen; + char *sbuf, *s3; + + if (n < 0) { + irunerr(205,n); + errorfail; + } + /* + * The padding string is null; make it a blank. + */ + if (StrLen(s2) == 0) + s2 = blank; + /* } must be supplied */ +#enddef + + +"center(s1,i,s2) - pad s1 on left and right with s2 to length i." + +function{1} center(s1,n,s2) + FstrSetup /* includes body { */ + { + word hcnt; + + /* + * If we are extracting the center of a large string (not padding), + * just construct a descriptor. + */ + if (n <= StrLen(s1)) { + return string(n, StrLoc(s1) + ((StrLen(s1)-n+1)>>1)); + } + + /* + * Get space for the new string. Start at the right + * of the new string and copy s2 into it from right to left as + * many times as will fit in the right half of the new string. + */ + Protect(sbuf = alcstr(NULL, n), runerr(0)); + + slen = StrLen(s2); + s3 = StrLoc(s2); + hcnt = n / 2; + s = sbuf + n; + while (s > sbuf + hcnt) { + st = s3 + slen; + while (st > s3 && s > sbuf + hcnt) + *--s = *--st; + } + + /* + * Start at the left end of the new string and copy s1 into it from + * left to right as many time as will fit in the left half of the + * new string. + */ + s = sbuf; + while (s < sbuf + hcnt) { + st = s3; + while (st < s3 + slen && s < sbuf + hcnt) + *s++ = *st++; + } + + slen = StrLen(s1); + if (n < slen) { + /* + * s1 is larger than the field to center it in. The source for the + * copy starts at the appropriate point in s1 and the destination + * starts at the left end of of the new string. + */ + s = sbuf; + st = StrLoc(s1) + slen/2 - hcnt + (~n&slen&1); + } + else { + /* + * s1 is smaller than the field to center it in. The source for the + * copy starts at the left end of s1 and the destination starts at + * the appropriate point in the new string. + */ + s = sbuf + hcnt - slen/2 - (~n&slen&1); + st = StrLoc(s1); + } + /* + * Perform the copy, moving min(*s1,n) bytes from st to s. + */ + if (slen > n) + slen = n; + while (slen-- > 0) + *s++ = *st++; + + /* + * Return the new string. + */ + return string(n, sbuf); + } } +end + + +"detab(s,i,...) - replace tabs with spaces, with stops at columns indicated." + +function{1} detab(s,i[n]) + + if !cnv:string(s) then + runerr(103,s) + + abstract { + return string + } + + body { + tended char *in, *out, *iend; + C_integer last, interval, col, target, expand, j; + dptr tablst; + dptr endlst; + int is_expanded = 0; + char c; + + /* + * Make sure all allocations for result will go in one region + */ + reserve(Strings, StrLen(s) * 8); + + for (j=0; j<n; j++) { + if (!cnv:integer(i[j],i[j])) + runerr(101,i[j]); + if ((j>0) && IntVal(i[j])<=IntVal(i[j-1])) + runerr(210, i[j]); + + } + /* + * Start out assuming the result will be the same size as the argument. + */ + Protect(StrLoc(result) = alcstr(NULL, StrLen(s)), runerr(0)); + StrLen(result) = StrLen(s); + + /* + * Copy the string, expanding tabs. + */ + last = 1; + if (n == 0) + interval = 8; + else { + if (!cnv:integer(i[0], i[0])) + runerr(101, i[0]); + + if (IntVal(i[0]) <= last) + runerr(210, i[0]); + } + tablst = i; + endlst = &i[n]; + col = 1; + iend = StrLoc(s) + StrLen(s); + for (in = StrLoc(s), out = StrLoc(result); in < iend; ) + switch (c = *out++ = *in++) { + case '\b': + col--; + tablst = i; /* reset the list of remaining tab stops */ + last = 1; + break; + case '\n': + case '\r': + col = 1; + tablst = i; /* reset the list of remaining tab stops */ + last = 1; + break; + case '\t': + is_expanded = 1; + out--; + target = col; + nxttab(&target, &tablst, endlst, &last, &interval); + expand = target - col - 1; + if (expand > 0) { + Protect(alcstr(NULL, expand), runerr(0)); + StrLen(result) += expand; + } + while (col < target) { + *out++ = ' '; + col++; + } + break; + default: + if (isprint(c)) + col++; + } + + /* + * Return new string if indeed there were tabs; otherwise return original + * string to conserve memory. + */ + if (is_expanded) + return result; + else { + long n = DiffPtrs(StrLoc(result),strfree); /* note deallocation */ + if (n < 0) + EVVal(-n, E_StrDeAlc); + else + EVVal(n, E_String); + strtotal += DiffPtrs(StrLoc(result),strfree); + strfree = StrLoc(result); /* reset the free pointer */ + return s; /* return original string */ + } + } +end + + + +"entab(s,i,...) - replace spaces with tabs, with stops at columns indicated." + +function{1} entab(s,i[n]) + if !cnv:string(s) then + runerr(103,s) + + abstract { + return string + } + + body { + C_integer last, interval, col, target, nt, nt1, j; + dptr tablst; + dptr endlst; + char *in, *out, *iend; + char c; + int inserted = 0; + + for (j=0; j<n; j++) { + if (!cnv:integer(i[j],i[j])) + runerr(101,i[j]); + + if ((j>0) && IntVal(i[j])<=IntVal(i[j-1])) + runerr(210, i[j]); + } + + /* + * Get memory for result at end of string space. We may give some back + * if not all needed, or all of it if no tabs can be inserted. + */ + Protect(StrLoc(result) = alcstr(NULL, StrLen(s)), runerr(0)); + StrLen(result) = StrLen(s); + + /* + * Copy the string, looking for runs of spaces. + */ + last = 1; + if (n == 0) + interval = 8; + else { + if (!cnv:integer(i[0], i[0])) + runerr(101, i[0]); + if (IntVal(i[0]) <= last) + runerr(210, i[0]); + } + tablst = i; + endlst = &i[n]; + col = 1; + target = 0; + iend = StrLoc(s) + StrLen(s); + + for (in = StrLoc(s), out = StrLoc(result); in < iend; ) + switch (c = *out++ = *in++) { + case '\b': + col--; + tablst = i; /* reset the list of remaining tab stops */ + last = 1; + break; + case '\n': + case '\r': + col = 1; + tablst = i; /* reset the list of remaining tab stops */ + last = 1; + break; + case '\t': + nxttab(&col, &tablst, endlst, &last, &interval); + break; + case ' ': + target = col + 1; + while (in < iend && *in == ' ') + target++, in++; + if (target - col > 1) { /* never tab just 1; already copied space */ + nt = col; + nxttab(&nt, &tablst, endlst, &last, &interval); + if (nt == col+1) { + nt1 = nt; + nxttab(&nt1, &tablst, endlst, &last, &interval); + if (nt1 > target) { + col++; /* keep space to avoid 1-col tab then spaces */ + nt = nt1; + } + else + out--; /* back up to begin tabbing */ + } + else + out--; /* back up to begin tabbing */ + while (nt <= target) { + inserted = 1; + *out++ = '\t'; /* put tabs to tab positions */ + col = nt; + nxttab(&nt, &tablst, endlst, &last, &interval); + } + while (col++ < target) + *out++ = ' '; /* complete gap with spaces */ + } + col = target; + break; + default: + if (isprint(c)) + col++; + } + + /* + * Return new string if indeed tabs were inserted; otherwise return + * original string (and reset strfree) to conserve memory. + */ + if (inserted) { + long n; + StrLen(result) = DiffPtrs(out,StrLoc(result)); + n = DiffPtrs(out,strfree); /* note the deallocation */ + if (n < 0) + EVVal(-n, E_StrDeAlc); + else + EVVal(n, E_String); + strtotal += DiffPtrs(out,strfree); + strfree = out; /* give back unused space */ + return result; /* return new string */ + } + else { + long n = DiffPtrs(StrLoc(result),strfree); /* note the deallocation */ + if (n < 0) + EVVal(-n, E_StrDeAlc); + else + EVVal(n, E_String); + strtotal += DiffPtrs(StrLoc(result),strfree); + strfree = StrLoc(result); /* reset free pointer */ + return s; /* return original string */ + } + } +end + +/* + * nxttab -- helper routine for entab and detab, returns next tab + * beyond col + */ + +void nxttab(col, tablst, endlst, last, interval) +C_integer *col; +dptr *tablst; +dptr endlst; +C_integer *last; +C_integer *interval; + { + /* + * Look for the right tab stop. + */ + while (*tablst < endlst && *col >= IntVal((*tablst)[0])) { + ++*tablst; + if (*tablst == endlst) + *interval = IntVal((*tablst)[-1]) - *last; + else { + *last = IntVal((*tablst)[-1]); + } + } + if (*tablst >= endlst) + *col = *col + *interval - (*col - *last) % *interval; + else + *col = IntVal((*tablst)[0]); + } + + +"left(s1,i,s2) - pad s1 on right with s2 to length i." + +function{1} left(s1,n,s2) + FstrSetup /* includes body { */ + + /* + * If we are extracting the left part of a large string (not padding), + * just construct a descriptor. + */ + if (n <= StrLen(s1)) { + return string(n, StrLoc(s1)); + } + + /* + * Get n bytes of string space. Start at the right end of the new + * string and copy s2 into the new string as many times as it fits. + * Note that s2 is copied from right to left. + */ + Protect(sbuf = alcstr(NULL, n), runerr(0)); + + slen = StrLen(s2); + s3 = StrLoc(s2); + s = sbuf + n; + while (s > sbuf) { + st = s3 + slen; + while (st > s3 && s > sbuf) + *--s = *--st; + } + + /* + * Copy up to n bytes of s1 into the new string, starting at the left end + */ + s = sbuf; + slen = StrLen(s1); + st = StrLoc(s1); + if (slen > n) + slen = n; + while (slen-- > 0) + *s++ = *st++; + + /* + * Return the new string. + */ + return string(n, sbuf); + } +end + + +"map(s1,s2,s3) - map s1, using s2 and s3." + +function{1} map(s1,s2,s3) + /* + * s1 must be a string; s2 and s3 default to (string conversions of) + * &ucase and &lcase, respectively. + */ + if !cnv:string(s1) then + runerr(103,s1) +#if COMPILER + if !def:string(s2, ucase) then + runerr(103,s2) + if !def:string(s3, lcase) then + runerr(103,s3) +#endif /* COMPILER */ + + abstract { + return string + } + body { + register int i; + register word slen; + register char *str1, *str2, *str3; + static char maptab[256]; + +#if !COMPILER + if (is:null(s2)) + s2 = ucase; + if (is:null(s3)) + s3 = lcase; +#endif /* !COMPILER */ + /* + * If s2 and s3 are the same as for the last call of map, + * the current values in maptab can be used. Otherwise, the + * mapping information must be recomputed. + */ + if (!EqlDesc(maps2,s2) || !EqlDesc(maps3,s3)) { + maps2 = s2; + maps3 = s3; + +#if !COMPILER + if (!cnv:string(s2,s2)) + runerr(103,s2); + if (!cnv:string(s3,s3)) + runerr(103,s3); +#endif /* !COMPILER */ + /* + * s2 and s3 must be of the same length + */ + if (StrLen(s2) != StrLen(s3)) + runerr(208); + + /* + * The array maptab is used to perform the mapping. First, + * maptab[i] is initialized with i for i from 0 to 255. + * Then, for each character in s2, the position in maptab + * corresponding to the value of the character is assigned + * the value of the character in s3 that is in the same + * position as the character from s2. + */ + str2 = StrLoc(s2); + str3 = StrLoc(s3); + for (i = 0; i <= 255; i++) + maptab[i] = i; + for (slen = 0; slen < StrLen(s2); slen++) + maptab[str2[slen]&0377] = str3[slen]; + } + + if (StrLen(s1) == 0) { + return emptystr; + } + + /* + * The result is a string the size of s1; create the result + * string, but specify no value for it. + */ + StrLen(result) = slen = StrLen(s1); + Protect(StrLoc(result) = alcstr(NULL, slen), runerr(0)); + str1 = StrLoc(s1); + str2 = StrLoc(result); + + /* + * Run through the string, using values in maptab to do the + * mapping. + */ + while (slen-- > 0) + *str2++ = maptab[(*str1++)&0377]; + + return result; + } +end + + +"repl(s,i) - concatenate i copies of string s." + +function{1} repl(s,n) + + if !cnv:string(s) then + runerr(103,s) + + if !cnv:C_integer(n) then + runerr(101,n) + + abstract { + return string + } + + body { + register C_integer cnt; + register C_integer slen; + register C_integer size; + register char * resloc, * sloc, *floc; + + if (n < 0) { + irunerr(205,n); + errorfail; + } + + slen = StrLen(s); + /* + * Return an empty string if n is 0 or if s is the empty string. + */ + if ((n == 0) || (slen==0)) + return emptystr; + + /* + * Make sure the resulting string will not be too long. + */ + size = n * slen; + if (size > MaxStrLen) { + irunerr(205,n); + errorfail; + } + + /* + * Make result a descriptor for the replicated string. + */ + Protect(resloc = alcstr(NULL, size), runerr(0)); + + StrLoc(result) = resloc; + StrLen(result) = size; + + /* + * Fill the allocated area with copies of s. + */ + sloc = StrLoc(s); + if (slen == 1) + memset(resloc, *sloc, size); + else { + while (--n >= 0) { + floc = sloc; + cnt = slen; + while (--cnt >= 0) + *resloc++ = *floc++; + } + } + + return result; + } +end + + +"reverse(s) - reverse string s." + +function{1} reverse(s) + + if !cnv:string(s) then + runerr(103,s) + + abstract { + return string + } + body { + register char c, *floc, *lloc; + register word slen; + + /* + * Allocate a copy of s. + */ + slen = StrLen(s); + Protect(StrLoc(result) = alcstr(StrLoc(s), slen), runerr(0)); + StrLen(result) = slen; + + /* + * Point floc at the start of s and lloc at the end of s. Work floc + * and sloc along s in opposite directions, swapping the characters + * at floc and lloc. + */ + floc = StrLoc(result); + lloc = floc + --slen; + while (floc < lloc) { + c = *floc; + *floc++ = *lloc; + *lloc-- = c; + } + return result; + } +end + + +"right(s1,i,s2) - pad s1 on left with s2 to length i." + +function{1} right(s1,n,s2) + FstrSetup /* includes body { */ + /* + * If we are extracting the right part of a large string (not padding), + * just construct a descriptor. + */ + if (n <= StrLen(s1)) { + return string(n, StrLoc(s1) + StrLen(s1) - n); + } + + /* + * Get n bytes of string space. Start at the left end of the new + * string and copy s2 into the new string as many times as it fits. + */ + Protect(sbuf = alcstr(NULL, n), runerr(0)); + + slen = StrLen(s2); + s3 = StrLoc(s2); + s = sbuf; + while (s < sbuf + n) { + st = s3; + while (st < s3 + slen && s < sbuf + n) + *s++ = *st++; + } + + /* + * Copy s1 into the new string, starting at the right end and copying + * s2 from right to left. If *s1 > n, only copy n bytes. + */ + s = sbuf + n; + slen = StrLen(s1); + st = StrLoc(s1) + slen; + if (slen > n) + slen = n; + while (slen-- > 0) + *--s = *--st; + + /* + * Return the new string. + */ + return string(n, sbuf); + } +end + + +"trim(s,c) - trim trailing characters in c from s." + +function{1} trim(s,c) + + if !cnv:string(s) then + runerr(103, s) + /* + * c defaults to a cset containing a blank. + */ + if !def:tmp_cset(c,blankcs) then + runerr(104, c) + + abstract { + return string + } + + body { + char *sloc; + C_integer slen; + + /* + * Start at the end of s and then back up until a character that is + * not in c is found. The actual trimming is done by having a + * descriptor that points at a substring of s, but with the length + * reduced. + */ + slen = StrLen(s); + sloc = StrLoc(s) + slen - 1; + while (sloc >= StrLoc(s) && Testb(*sloc, c)) { + sloc--; + slen--; + } + return string(slen, StrLoc(s)); + } +end diff --git a/src/runtime/fstranl.r b/src/runtime/fstranl.r new file mode 100644 index 0000000..be13839 --- /dev/null +++ b/src/runtime/fstranl.r @@ -0,0 +1,260 @@ +/* + * File: fstranl.r + * String analysis functions: any,bal,find,many,match,upto + * + * str_anal is a macro for performing the standard conversions and + * defaulting for string analysis functions. It takes as arguments the + * parameters for subject, beginning position, and ending position. It + * produces declarations for these 3 names prepended with cnv_. These + * variables will contain the converted versions of the arguments. + */ +#begdef str_anal(s, i, j) + declare { + C_integer cnv_ ## i; + C_integer cnv_ ## j; + } + + abstract { + return integer + } + + if is:null(s) then { + inline { + s = k_subject; + } + if is:null(i) then inline { + cnv_ ## i = k_pos; + } + } + else { + if !cnv:string(s) then + runerr(103,s) + if is:null(i) then inline { + cnv_ ## i = 1; + } + } + + if !is:null(i) then + if cnv:C_integer(i,cnv_ ## i) then inline { + if ((cnv_ ## i = cvpos(cnv_ ## i, StrLen(s))) == CvtFail) + fail; + } + else + runerr(101,i) + + + if is:null(j) then inline { + cnv_ ## j = StrLen(s) + 1; + } + else if cnv:C_integer(j,cnv_ ## j) then inline { + if ((cnv_ ## j = cvpos(cnv_ ## j, StrLen(s))) == CvtFail) + fail; + if (cnv_ ## i > cnv_ ## j) { + register C_integer tmp; + tmp = cnv_ ## i; + cnv_ ## i = cnv_ ## j; + cnv_ ## j = tmp; + } + } + else + runerr(101,j) + +#enddef + + +"any(c,s,i1,i2) - produces i1+1 if i2 is greater than 1 and s[i] is contained " +"in c and poseq(i2,x) is greater than poseq(i1,x), but fails otherwise." + +function{0,1} any(c,s,i,j) + str_anal( s, i, j ) + if !cnv:tmp_cset(c) then + runerr(104,c) + body { + if (cnv_i == cnv_j) + fail; + if (!Testb(StrLoc(s)[cnv_i-1], c)) + fail; + return C_integer cnv_i+1; + } +end + + +"bal(c1,c2,c3,s,i1,i2) - generates the sequence of integer positions in s up to" +" a character of c1 in s[i1:i2] that is balanced with respect to characters in" +" c2 and c3, but fails if there is no such position." + +function{*} bal(c1,c2,c3,s,i,j) + str_anal( s, i, j ) + if !def:tmp_cset(c1,fullcs) then + runerr(104,c1) + if !def:tmp_cset(c2,lparcs) then + runerr(104,c2) + if !def:tmp_cset(c3,rparcs) then + runerr(104,c3) + + body { + C_integer cnt; + char c; + + /* + * Loop through characters in s[i:j]. When a character in c2 + * is found, increment cnt; when a character in c3 is found, decrement + * cnt. When cnt is 0 there have been an equal number of occurrences + * of characters in c2 and c3, i.e., the string to the left of + * i is balanced. If the string is balanced and the current character + * (s[i]) is in c, suspend with i. Note that if cnt drops below + * zero, bal fails. + */ + cnt = 0; + while (cnv_i < cnv_j) { + c = StrLoc(s)[cnv_i-1]; + if (cnt == 0 && Testb(c, c1)) { + suspend C_integer cnv_i; + } + if (Testb(c, c2)) + cnt++; + else if (Testb(c, c3)) + cnt--; + if (cnt < 0) + fail; + cnv_i++; + } + /* + * Eventually fail. + */ + fail; + } +end + + +"find(s1,s2,i1,i2) - generates the sequence of positions in s2 at which " +"s1 occurs as a substring in s2[i1:i2], but fails if there is no such position." + +function{*} find(s1,s2,i,j) + str_anal( s2, i, j ) + if !cnv:string(s1) then + runerr(103,s1) + + body { + register char *str1, *str2; + C_integer s1_len, l, term; + + /* + * Loop through s2[i:j] trying to find s1 at each point, stopping + * when the remaining portion s2[i:j] is too short to contain s1. + * Optimize me! + */ + s1_len = StrLen(s1); + term = cnv_j - s1_len; + while (cnv_i <= term) { + str1 = StrLoc(s1); + str2 = StrLoc(s2) + cnv_i - 1; + l = s1_len; + + /* + * Compare strings on a byte-wise basis; if the end is reached + * before inequality is found, suspend with the position of the + * string. + */ + do { + if (l-- <= 0) { + suspend C_integer cnv_i; + break; + } + } while (*str1++ == *str2++); + cnv_i++; + } + fail; + } +end + + +"many(c,s,i1,i2) - produces the position in s after the longest initial " +"sequence of characters in c in s[i1:i2] but fails if there is none." + +function{0,1} many(c,s,i,j) + str_anal( s, i, j ) + if !cnv:tmp_cset(c) then + runerr(104,c) + body { + C_integer start_i = cnv_i; + /* + * Move i along s[i:j] until a character that is not in c is found + * or the end of the string is reached. + */ + while (cnv_i < cnv_j) { + if (!Testb(StrLoc(s)[cnv_i-1], c)) + break; + cnv_i++; + } + /* + * Fail if no characters in c were found; otherwise + * return the position of the first character not in c. + */ + if (cnv_i == start_i) + fail; + return C_integer cnv_i; + } +end + + +"match(s1,s2,i1,i2) - produces i1+*s1 if s1==s2[i1+:*s1], but fails otherwise." + +function{0,1} match(s1,s2,i,j) + str_anal( s2, i, j ) + if !cnv:tmp_string(s1) then + runerr(103,s1) + body { + char *str1, *str2; + + /* + * Cannot match unless s2[i:j] is as long as s1. + */ + if (cnv_j - cnv_i < StrLen(s1)) + fail; + + /* + * Compare s1 with s2[i:j] for *s1 characters; fail if an + * inequality is found. + */ + str1 = StrLoc(s1); + str2 = StrLoc(s2) + cnv_i - 1; + for (cnv_j = StrLen(s1); cnv_j > 0; cnv_j--) + if (*str1++ != *str2++) + fail; + + /* + * Return position of end of matched string in s2. + */ + return C_integer cnv_i + StrLen(s1); + } +end + + +"upto(c,s,i1,i2) - generates the sequence of integer positions in s up to a " +"character in c in s[i2:i2], but fails if there is no such position." + +function{*} upto(c,s,i,j) + str_anal( s, i, j ) + if !cnv:tmp_cset(c) then + runerr(104,c) + body { + C_integer tmp; + + /* + * Look through s[i:j] and suspend position of each occurrence of + * of a character in c. + */ + while (cnv_i < cnv_j) { + tmp = (C_integer)StrLoc(s)[cnv_i-1]; + if (Testb(tmp, c)) { + suspend C_integer cnv_i; + } + cnv_i++; + } + /* + * Eventually fail. + */ + fail; + } +end diff --git a/src/runtime/fstruct.r b/src/runtime/fstruct.r new file mode 100644 index 0000000..469c3c5 --- /dev/null +++ b/src/runtime/fstruct.r @@ -0,0 +1,906 @@ +/* + * File: fstruct.r + * Contents: delete, get, key, insert, list, member, pop, pull, push, put, + * set, table + */ + +"delete(x1,x2) - delete element x2 from set or table x1 if it is there" +" (always succeeds and returns x1)." + +function{1} delete(s,x) + abstract { + return type(s) ** (set ++ table) + } + + /* + * The technique and philosophy here are the same + * as used in insert - see comment there. + */ + type_case s of { + set: + body { + register uword hn; + register union block **pd; + int res; + + hn = hash(&x); + + pd = memb(BlkLoc(s), &x, hn, &res); + if (res == 1) { + /* + * The element is there so delete it. + */ + *pd = (*pd)->selem.clink; + (BlkLoc(s)->set.size)--; + } + + EVValD(&s, E_Sdelete); + EVValD(&x, E_Sval); + return s; + } + table: + body { + register union block **pd; + register uword hn; + int res; + + hn = hash(&x); + pd = memb(BlkLoc(s), &x, hn, &res); + if (res == 1) { + /* + * The element is there so delete it. + */ + *pd = (*pd)->telem.clink; + (BlkLoc(s)->table.size)--; + } + + EVValD(&s, E_Tdelete); + EVValD(&x, E_Tsub); + return s; + } + default: + runerr(122, s) + } +end + + +/* + * c_get - convenient C-level access to the get function + * returns 0 on failure, otherwise fills in res + */ +int c_get(hp, res) +struct b_list *hp; +struct descrip *res; +{ + register word i; + register struct b_lelem *bp; + + /* + * Fail if the list is empty. + */ + if (hp->size <= 0) + return 0; + + /* + * Point bp at the first list block. If the first block has no + * elements in use, point bp at the next list block. + */ + bp = (struct b_lelem *) hp->listhead; + if (bp->nused <= 0) { + bp = (struct b_lelem *) bp->listnext; + hp->listhead = (union block *) bp; +#ifdef ListFix + bp->listprev = (union block *) hp; +#else /* ListFix */ + bp->listprev = NULL; +#endif /* ListFix */ + } + + /* + * Locate first element and assign it to result for return. + */ + i = bp->first; + *res = bp->lslots[i]; + + /* + * Set bp->first to new first element, or 0 if the block is now + * empty. Decrement the usage count for the block and the size + * of the list. + */ + if (++i >= bp->nslots) + i = 0; + bp->first = i; + bp->nused--; + hp->size--; + + return 1; +} + +#begdef GetOrPop(get_or_pop) +#get_or_pop "(x) - " #get_or_pop " an element from the left end of list x." +/* + * get(L) - get an element from end of list L. + * Identical to pop(L). + */ +function{0,1} get_or_pop(x) + if !is:list(x) then + runerr(108, x) + + abstract { + return store[type(x).lst_elem] + } + + body { + EVValD(&x, E_Lget); + if (!c_get((struct b_list *)BlkLoc(x), &result)) fail; + return result; + } +end +#enddef + +GetOrPop(get) /* get(x) - get an element from the left end of list x. */ +GetOrPop(pop) /* pop(x) - pop an element from the left end of list x. */ + + +"key(T) - generate successive keys (entry values) from table T." + +function{*} key(t) + if !is:table(t) then + runerr(124, t) + + abstract { + return store[type(t).tbl_key] + } + + inline { + tended union block *ep; + struct hgstate state; + + EVValD(&t, E_Tkey); + for (ep = hgfirst(BlkLoc(t), &state); ep != 0; + ep = hgnext(BlkLoc(t), &state, ep)) { + EVValD(&ep->telem.tref, E_Tsub); + suspend ep->telem.tref; + } + fail; + } +end + + +"insert(x1, x2, x3) - insert element x2 into set or table x1 if not already there" +" if x1 is a table, the assigned value for element x2 is x3." +" (always succeeds and returns x1)." + +function{1} insert(s, x, y) + type_case s of { + + set: { + abstract { + store[type(s).set_elem] = type(x) + return type(s) + } + + body { + tended union block *bp, *bp2; + register uword hn; + int res; + struct b_selem *se; + register union block **pd; + + bp = BlkLoc(s); + hn = hash(&x); + /* + * If x is a member of set s then res will have the value 1, + * and pd will have a pointer to the pointer + * that points to that member. + * If x is not a member of the set then res will have + * the value 0 and pd will point to the pointer + * which should point to the member - thus we know where + * to link in the new element without having to do any + * repetitive looking. + */ + + /* get this now because can't tend pd */ + Protect(se = alcselem(&x, hn), runerr(0)); + + pd = memb(bp, &x, hn, &res); + if (res == 0) { + /* + * The element is not in the set - insert it. + */ + addmem((struct b_set *)bp, se, pd); + if (TooCrowded(bp)) + hgrow(bp); + } + else + deallocate((union block *)se); + + EVValD(&s, E_Sinsert); + EVValD(&x, E_Sval); + return s; + } + } + + table: { + abstract { + store[type(s).tbl_key] = type(x) + store[type(s).tbl_val] = type(y) + return type(s) + } + + body { + tended union block *bp, *bp2; + union block **pd; + struct b_telem *te; + register uword hn; + int res; + + bp = BlkLoc(s); + hn = hash(&x); + + /* get this now because can't tend pd */ + Protect(te = alctelem(), runerr(0)); + + pd = memb(bp, &x, hn, &res); /* search table for key */ + if (res == 0) { + /* + * The element is not in the table - insert it. + */ + bp->table.size++; + te->clink = *pd; + *pd = (union block *)te; + te->hashnum = hn; + te->tref = x; + te->tval = y; + if (TooCrowded(bp)) + hgrow(bp); + } + else { + /* + * We found an existing entry; just change its value. + */ + deallocate((union block *)te); + te = (struct b_telem *) *pd; + te->tval = y; + } + + EVValD(&s, E_Tinsert); + EVValD(&x, E_Tsub); + return s; + } + } + + default: + runerr(122, s); + } +end + + +"list(i, x) - create a list of size i, with initial value x." + +function{1} list(n, x) + if !def:C_integer(n, 0L) then + runerr(101, n) + + abstract { + return new list(type(x)) + } + + body { + tended struct b_list *hp; + register word i, size; + word nslots; + register struct b_lelem *bp; /* does not need to be tended */ + + nslots = size = n; + + /* + * Ensure that the size is positive and that the list-element block + * has at least MinListSlots slots. + */ + if (size < 0) { + irunerr(205, n); + errorfail; + } + if (nslots == 0) + nslots = MinListSlots; + + /* + * Allocate the list-header block and a list-element block. + * Note that nslots is the number of slots in the list-element + * block while size is the number of elements in the list. + */ + Protect(hp = alclist(size), runerr(0)); + Protect(bp = alclstb(nslots, (word)0, size), runerr(0)); + hp->listhead = hp->listtail = (union block *) bp; +#ifdef ListFix + bp->listprev = bp->listnext = (union block *) hp; +#endif /* ListFix */ + + /* + * Initialize each slot. + */ + for (i = 0; i < size; i++) + bp->lslots[i] = x; + + Desc_EVValD(hp, E_Lcreate, D_List); + + /* + * Return the new list. + */ + return list(hp); + } +end + + +"member(x1, x2) - returns x1 if x2 is a member of set or table x2 but fails" +" otherwise." + +function{0,1} member(s, x) + type_case s of { + + set: { + abstract { + return type(x) ** store[type(s).set_elem] + } + inline { + int res; + register uword hn; + + EVValD(&s, E_Smember); + EVValD(&x, E_Sval); + + hn = hash(&x); + memb(BlkLoc(s), &x, hn, &res); + if (res==1) + return x; + else + fail; + } + } + table: { + abstract { + return type(x) ** store[type(s).tbl_key] + } + inline { + int res; + register uword hn; + + EVValD(&s, E_Tmember); + EVValD(&x, E_Tsub); + + hn = hash(&x); + memb(BlkLoc(s), &x, hn, &res); + if (res == 1) + return x; + else + fail; + } + } + default: + runerr(122, s) + } +end + + +"pull(L) - pull an element from end of list L." + +function{0,1} pull(x) + /* + * x must be a list. + */ + if !is:list(x) then + runerr(108, x) + abstract { + return store[type(x).lst_elem] + } + + body { + register word i; + register struct b_list *hp; + register struct b_lelem *bp; + + EVValD(&x, E_Lpull); + + /* + * Point at list header block and fail if the list is empty. + */ + hp = (struct b_list *) BlkLoc(x); + if (hp->size <= 0) + fail; + + /* + * Point bp at the last list element block. If the last block has no + * elements in use, point bp at the previous list element block. + */ + bp = (struct b_lelem *) hp->listtail; + if (bp->nused <= 0) { + bp = (struct b_lelem *) bp->listprev; + hp->listtail = (union block *) bp; +#ifdef ListFix + bp->listnext = (union block *) hp; +#else /* ListFix */ + bp->listnext = NULL; +#endif /* ListFix */ + } + + /* + * Set i to position of last element and assign the element to + * result for return. Decrement the usage count for the block + * and the size of the list. + */ + i = bp->first + bp->nused - 1; + if (i >= bp->nslots) + i -= bp->nslots; + result = bp->lslots[i]; + bp->nused--; + hp->size--; + return result; + } +end + +#ifdef Graphics +/* + * c_push - C-level, nontending push operation + */ +void c_push(l, val) +dptr l; +dptr val; +{ + register word i; + register struct b_lelem *bp; /* does not need to be tended */ + static int two = 2; /* some compilers generate bad code for + division by a constant that's a power of 2*/ + /* + * Point bp at the first list-element block. + */ + bp = (struct b_lelem *) BlkLoc(*l)->list.listhead; + +#ifdef EventMon /* initialize i so it's 0 if first list-element */ + i = 0; /* block isn't full */ +#endif /* EventMon */ + + /* + * If the first list-element block is full, allocate a new + * list-element block, make it the first list-element block, + * and make it the previous block of the former first list-element + * block. + */ + if (bp->nused >= bp->nslots) { + /* + * Set i to the size of block to allocate. + */ + i = BlkLoc(*l)->list.size / two; + if (i < MinListSlots) + i = MinListSlots; +#ifdef MaxListSlots + if (i > MaxListSlots) + i = MaxListSlots; +#endif /* MaxListSlots */ + + /* + * Allocate a new list element block. If the block can't + * be allocated, try smaller blocks. + */ + while ((bp = alclstb(i, (word)0, (word)0)) == NULL) { + i /= 4; + if (i < MinListSlots) + fatalerr(0, NULL); + } + + BlkLoc(*l)->list.listhead->lelem.listprev = (union block *) bp; +#ifdef ListFix + bp->listprev = BlkLoc(*l); +#endif /* ListFix */ + bp->listnext = BlkLoc(*l)->list.listhead; + BlkLoc(*l)->list.listhead = (union block *) bp; + } + + /* + * Set i to position of new first element and assign val to + * that element. + */ + i = bp->first - 1; + if (i < 0) + i = bp->nslots - 1; + bp->lslots[i] = *val; + /* + * Adjust value of location of first element, block usage count, + * and current list size. + */ + bp->first = i; + bp->nused++; + BlkLoc(*l)->list.size++; + } +#endif /* Graphics */ + + +"push(L, x1, ..., xN) - push x onto beginning of list L." + +function{1} push(x, vals[n]) + /* + * x must be a list. + */ + if !is:list(x) then + runerr(108, x) + abstract { + store[type(x).lst_elem] = type(vals) + return type(x) + } + + body { + tended struct b_list *hp; + dptr dp; + register word i, val, num; + register struct b_lelem *bp; /* does not need to be tended */ + static int two = 2; /* some compilers generate bad code for + division by a constant that's a power of 2*/ + + if (n == 0) { + dp = &nulldesc; + num = 1; + } + else { + dp = vals; + num = n; + } + + for (val = 0; val < num; val++) { + /* + * Point hp at the list-header block and bp at the first + * list-element block. + */ + hp = (struct b_list *) BlkLoc(x); + bp = (struct b_lelem *) hp->listhead; + +#ifdef EventMon /* initialize i so it's 0 if first list-element */ + i = 0; /* block isn't full */ +#endif /* EventMon */ + + /* + * If the first list-element block is full, allocate a new + * list-element block, make it the first list-element block, + * and make it the previous block of the former first list-element + * block. + */ + if (bp->nused >= bp->nslots) { + /* + * Set i to the size of block to allocate. + */ + i = hp->size / two; + if (i < MinListSlots) + i = MinListSlots; +#ifdef MaxListSlots + if (i > MaxListSlots) + i = MaxListSlots; +#endif /* MaxListSlots */ + + /* + * Allocate a new list element block. If the block can't + * be allocated, try smaller blocks. + */ + while ((bp = alclstb(i, (word)0, (word)0)) == NULL) { + i /= 4; + if (i < MinListSlots) + runerr(0); + } + + hp->listhead->lelem.listprev = (union block *) bp; +#ifdef ListFix + bp->listprev = (union block *) hp; +#endif /* ListFix */ + bp->listnext = hp->listhead; + hp->listhead = (union block *) bp; + } + + /* + * Set i to position of new first element and assign val to + * that element. + */ + i = bp->first - 1; + if (i < 0) + i = bp->nslots - 1; + bp->lslots[i] = dp[val]; + /* + * Adjust value of location of first element, block usage count, + * and current list size. + */ + bp->first = i; + bp->nused++; + hp->size++; + } + + EVValD(&x, E_Lpush); + + /* + * Return the list. + */ + return x; + } +end + +/* + * c_put - C-level, nontending list put function + */ +void c_put(l, val) +struct descrip *l; +struct descrip *val; +{ + register word i; + register struct b_lelem *bp; /* does not need to be tended */ + static int two = 2; /* some compilers generate bad code for + division by a constant that's a power of 2*/ + + /* + * Point hp at the list-header block and bp at the last + * list-element block. + */ + bp = (struct b_lelem *) BlkLoc(*l)->list.listtail; + +#ifdef EventMon /* initialize i so it's 0 if last list-element */ + i = 0; /* block isn't full */ +#endif /* EventMon */ + + /* + * If the last list-element block is full, allocate a new + * list-element block, make it the last list-element block, + * and make it the next block of the former last list-element + * block. + */ + if (bp->nused >= bp->nslots) { + /* + * Set i to the size of block to allocate. + */ + i = ((struct b_list *)BlkLoc(*l))->size / two; + if (i < MinListSlots) + i = MinListSlots; +#ifdef MaxListSlots + if (i > MaxListSlots) + i = MaxListSlots; +#endif /* MaxListSlots */ + + /* + * Allocate a new list element block. If the block can't + * be allocated, try smaller blocks. + */ + while ((bp = alclstb(i, (word)0, (word)0)) == NULL) { + i /= 4; + if (i < MinListSlots) + fatalerr(0, NULL); + } + + ((struct b_list *)BlkLoc(*l))->listtail->lelem.listnext = + (union block *) bp; + bp->listprev = ((struct b_list *)BlkLoc(*l))->listtail; +#ifdef ListFix + bp->listnext = BlkLoc(*l); +#endif /* ListFix */ + ((struct b_list *)BlkLoc(*l))->listtail = (union block *) bp; + } + + /* + * Set i to position of new last element and assign val to + * that element. + */ + i = bp->first + bp->nused; + if (i >= bp->nslots) + i -= bp->nslots; + bp->lslots[i] = *val; + + /* + * Adjust block usage count and current list size. + */ + bp->nused++; + ((struct b_list *)BlkLoc(*l))->size++; +} + + +"put(L, x1, ..., xN) - put elements onto end of list L." + +function{1} put(x, vals[n]) + /* + * x must be a list. + */ + if !is:list(x) then + runerr(108, x) + abstract { + store[type(x).lst_elem] = type(vals) + return type(x) + } + + body { + tended struct b_list *hp; + dptr dp; + register word i, val, num; + register struct b_lelem *bp; /* does not need to be tended */ + static int two = 2; /* some compilers generate bad code for + division by a constant that's a power of 2*/ + if (n == 0) { + dp = &nulldesc; + num = 1; + } + else { + dp = vals; + num = n; + } + + /* + * Point hp at the list-header block and bp at the last + * list-element block. + */ + for(val = 0; val < num; val++) { + + hp = (struct b_list *)BlkLoc(x); + bp = (struct b_lelem *) hp->listtail; + +#ifdef EventMon /* initialize i so it's 0 if last list-element */ + i = 0; /* block isn't full */ +#endif /* EventMon */ + + /* + * If the last list-element block is full, allocate a new + * list-element block, make it the last list-element block, + * and make it the next block of the former last list-element + * block. + */ + if (bp->nused >= bp->nslots) { + /* + * Set i to the size of block to allocate. + */ + i = hp->size / two; + if (i < MinListSlots) + i = MinListSlots; +#ifdef MaxListSlots + if (i > MaxListSlots) + i = MaxListSlots; +#endif /* MaxListSlots */ + /* + * Allocate a new list element block. If the block can't + * be allocated, try smaller blocks. + */ + while ((bp = alclstb(i, (word)0, (word)0)) == NULL) { + i /= 4; + if (i < MinListSlots) + runerr(0); + } + + hp->listtail->lelem.listnext = (union block *) bp; + bp->listprev = hp->listtail; +#ifdef ListFix + bp->listnext = (union block *)hp; +#endif /* ListFix */ + hp->listtail = (union block *) bp; + } + + /* + * Set i to position of new last element and assign val to + * that element. + */ + i = bp->first + bp->nused; + if (i >= bp->nslots) + i -= bp->nslots; + bp->lslots[i] = dp[val]; + + /* + * Adjust block usage count and current list size. + */ + bp->nused++; + hp->size++; + + } + + EVValD(&x, E_Lput); + + /* + * Return the list. + */ + return x; + } +end + + +"set(L) - create a set with members in list L." +" The members are linked into hash chains which are" +" arranged in increasing order by hash number." + +function{1} set(l) + + type_case l of { + null: { + abstract { + return new set(empty_type) + } + inline { + register union block * ps; + ps = hmake(T_Set, (word)0, (word)0); + if (ps == NULL) + runerr(0); + Desc_EVValD(ps, E_Screate, D_Set); + return set(ps); + } + } + + list: { + abstract { + return new set(store[type(l).lst_elem]) + } + + body { + tended union block *pb; + register uword hn; + dptr pd; + struct b_selem *ne; /* does not need to be tended */ + int res; + word i, j; + tended union block *ps; + union block **pe; + + /* + * Make a set of the appropriate size. + */ + pb = BlkLoc(l); + ps = hmake(T_Set, (word)0, pb->list.size); + if (ps == NULL) + runerr(0); + + /* + * Chain through each list block and for + * each element contained in the block + * insert the element into the set if not there. + * + * ne always has a new element ready for use. We must get one + * in advance, and stay one ahead, because pe can't be tended. + */ + Protect(ne = alcselem(&nulldesc, (uword)0), runerr(0)); + + for (pb = pb->list.listhead; +#ifdef ListFix + BlkType(pb) == T_Lelem; +#else /* ListFix */ + pb != NULL; +#endif /* ListFix */ + pb = pb->lelem.listnext) { + for (i = 0; i < pb->lelem.nused; i++) { + j = pb->lelem.first + i; + if (j >= pb->lelem.nslots) + j -= pb->lelem.nslots; + pd = &pb->lelem.lslots[j]; + pe = memb(ps, pd, hn = hash(pd), &res); + if (res == 0) { + ne->setmem = *pd; /* add new element */ + ne->hashnum = hn; + addmem((struct b_set *)ps, ne, pe); + /* get another blk */ + Protect(ne = alcselem(&nulldesc, (uword)0), runerr(0)); + } + } + } + deallocate((union block *)ne); + Desc_EVValD(ps, E_Screate, D_Set); + return set(ps); + } + } + + default : + runerr(108, l) + } +end + + +"table(x) - create a table with default value x." + +function{1} table(x) + abstract { + return new table(empty_type, empty_type, type(x)) + } + inline { + union block *bp; + + bp = hmake(T_Table, (word)0, (word)0); + if (bp == NULL) + runerr(0); + bp->table.defvalue = x; + Desc_EVValD(bp, E_Tcreate, D_Table); + return table(bp); + } +end diff --git a/src/runtime/fsys.r b/src/runtime/fsys.r new file mode 100644 index 0000000..6b70b65 --- /dev/null +++ b/src/runtime/fsys.r @@ -0,0 +1,1107 @@ +/* + * File: fsys.r + * Contents: close, chdir, exit, getenv, open, read, reads, remove, rename, + * seek, stop, system, where, write, writes, [getch, getche, kbhit] + */ + +"close(f) - close file f." + +function{1} close(f) + + if !is:file(f) then + runerr(105, f) + + abstract { + return file ++ integer + } + + body { + FILE *fp; + int status; + + fp = BlkLoc(f)->file.fd; + status = BlkLoc(f)->file.status; + if ((status & (Fs_Read | Fs_Write)) == 0) + return f; /* if already closed */ + + #ifdef Graphics + pollctr >>= 1; + pollctr++; + if (BlkLoc(f)->file.status & Fs_Window) { + /* + * Close a window. + */ + BlkLoc(f)->file.status = Fs_Window; /* clears read and write */ + SETCLOSED((wbp) fp); + wclose((wbp) fp); + return f; + } + #endif /* Graphics */ + + #ifdef ReadDirectory + if (BlkLoc(f)->file.status & Fs_Directory) { + /* + * Close a directory. + */ + closedir((DIR*) fp); + BlkLoc(f)->file.status = 0; + return f; + } + #endif /* ReadDirectory */ + + #ifdef Pipes + if (BlkLoc(f)->file.status & Fs_Pipe) { + /* + * Close a pipe. (Returns pclose status, contrary to doc.) + */ + BlkLoc(f)->file.status = 0; + return C_integer((pclose(fp) >> 8) & 0377); + } + #endif /* Pipes */ + + /* + * Close a simple file. + */ + fclose(fp); + BlkLoc(f)->file.status = 0; + return f; + } +end + +#undef exit +#passthru #undef exit + +"exit(i) - exit process with status i, which defaults to 0." + +function{} exit(status) + if !def:C_integer(status, EXIT_SUCCESS) then + runerr(101, status) + inline { + c_exit((int)status); + } +end + + +"getenv(s) - return contents of environment variable s." + +function{0,1} getenv(s) + + /* + * Make a C-style string out of s + */ + if !cnv:C_string(s) then + runerr(103,s) + abstract { + return string + } + + inline { + register char *p; + long l; + + if ((p = getenv(s)) != NULL) { /* get environment variable */ + l = strlen(p); + Protect(p = alcstr(p,l),runerr(0)); + return string(l,p); + } + else /* fail if not in environment */ + fail; + + } +end + + +#ifdef Graphics +"open(s1, s2, ...) - open file named s1 with options s2" +" and attributes given in trailing arguments." +function{0,1} open(fname, spec, attr[n]) +#else /* Graphics */ +"open(fname, spec) - open file fname with specification spec." +function{0,1} open(fname, spec) +#endif /* Graphics */ + declare { + tended struct descrip filename; + } + + /* + * fopen and popen require a C string, but it looks terrible in + * error messages, so convert it to a string here and use a local + * variable (fnamestr) to store the C string. + */ + if !cnv:string(fname) then + runerr(103, fname) + + /* + * spec defaults to "r". + */ + if !def:tmp_string(spec, letr) then + runerr(103, spec) + + abstract { + return file + } + + body { + tended char *fnamestr; + register word slen; + register int i; + register char *s; + int status; + char mode[4]; + extern FILE *fopen(); + FILE *f; + struct b_file *fl; + +#ifdef Graphics + int j, err_index = -1; + tended struct b_list *hp; + tended struct b_lelem *bp; +#endif /* Graphics */ + + /* + * get a C string for the file name + */ + if (!cnv:C_string(fname, fnamestr)) + runerr(103,fname); + + status = 0; + + /* + * Scan spec, setting appropriate bits in status. Produce a + * run-time error if an unknown character is encountered. + */ + s = StrLoc(spec); + slen = StrLen(spec); + for (i = 0; i < slen; i++) { + switch (*s++) { + case 'a': + case 'A': + status |= Fs_Write|Fs_Append; + continue; + case 'b': + case 'B': + status |= Fs_Read|Fs_Write; + continue; + case 'c': + case 'C': + status |= Fs_Create|Fs_Write; + continue; + case 'r': + case 'R': + status |= Fs_Read; + continue; + case 'w': + case 'W': + status |= Fs_Write; + continue; + case 't': + case 'T': + status &= ~Fs_Untrans; + continue; + case 'u': + case 'U': + status |= Fs_Untrans; + continue; + + #ifdef Pipes + case 'p': + case 'P': + status |= Fs_Pipe; + continue; + #endif /* Pipes */ + + case 'x': + case 'X': + case 'g': + case 'G': +#ifdef Graphics + status |= Fs_Window | Fs_Read | Fs_Write; + continue; +#else /* Graphics */ + fail; +#endif /* Graphics */ + + default: + runerr(209, spec); + } + } + + /* + * Construct a mode field for fopen/popen. + */ + mode[0] = '\0'; + mode[1] = '\0'; + mode[2] = '\0'; + mode[3] = '\0'; + + if ((status & (Fs_Read|Fs_Write)) == 0) /* default: read only */ + status |= Fs_Read; + if (status & Fs_Create) + mode[0] = 'w'; + else if (status & Fs_Append) + mode[0] = 'a'; + else if (status & Fs_Read) + mode[0] = 'r'; + else + mode[0] = 'w'; + + if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write)) + mode[1] = '+'; + if ((status & Fs_Untrans) != 0) + strcat(mode, "b"); + + /* + * Open the file with fopen or popen. + */ + +#ifdef Graphics + if (status & Fs_Window) { + /* + * allocate an empty event queue for the window + */ + Protect(hp = alclist(0), runerr(0)); + Protect(bp = alclstb(MinListSlots, (word)0, 0), runerr(0)); + hp->listhead = hp->listtail = (union block *) bp; +#ifdef ListFix + bp->listprev = bp->listnext = (union block *) hp; +#endif /* ListFix */ + + /* + * loop through attributes, checking validity + */ + for (j = 0; j < n; j++) { + if (is:null(attr[j])) + attr[j] = emptystr; + if (!is:string(attr[j])) + runerr(109, attr[j]); + } + + f = (FILE *)wopen(fnamestr, hp, attr, n, &err_index); + if (f == NULL) { + if (err_index >= 0) runerr(145, attr[err_index]); + else if (err_index == -1) fail; + else runerr(305); + } + } else +#endif /* Graphics */ + +#ifdef Pipes + if (status & Fs_Pipe) { + if (status != (Fs_Read|Fs_Pipe) && status != (Fs_Write|Fs_Pipe)) + runerr(209, spec); + f = popen(fnamestr, mode); + } + else +#endif /* Pipes */ + + { +#ifdef ReadDirectory + struct stat sbuf; + if ((status & Fs_Write) == 0 + && stat(fnamestr, &sbuf) == 0 + && S_ISDIR(sbuf.st_mode)) { + status |= Fs_Directory; + f = (FILE*) opendir(fnamestr); + } + else +#endif /* ReadDirectory */ + f = fopen(fnamestr, mode); + } + + /* + * Fail if the file cannot be opened. + */ + if (f == NULL) { + fail; + } + + /* + * Return the resulting file value. + */ + StrLen(filename) = strlen(fnamestr); + StrLoc(filename) = fnamestr; + + Protect(fl = alcfile(f, status, &filename), runerr(0)); +#ifdef Graphics + /* + * link in the Icon file value so this window can find it + */ + if (status & Fs_Window) { + ((wbp)f)->window->filep.dword = D_File; + BlkLoc(((wbp)f)->window->filep) = (union block *)fl; + if (is:null(lastEventWin)) { + lastEventWin = ((wbp)f)->window->filep; + lastEvFWidth = FWIDTH((wbp)f); + lastEvLeading = LEADING((wbp)f); + lastEvAscent = ASCENT((wbp)f); + } + } +#endif /* Graphics */ + return file(fl); + } +end + + +"read(f) - read line on file f." + +function{0,1} read(f) + /* + * Default f to &input. + */ + if is:null(f) then + inline { + f.dword = D_File; + BlkLoc(f) = (union block *)&k_input; + } + else if !is:file(f) then + runerr(105, f) + + abstract { + return string + } + + body { + register word slen, rlen; + register char *sp; + int status; + static char sbuf[MaxReadStr]; + tended struct descrip s; + FILE *fp; + + /* + * Get a pointer to the file and be sure that it is open for reading. + */ + fp = BlkLoc(f)->file.fd; + status = BlkLoc(f)->file.status; + if ((status & Fs_Read) == 0) + runerr(212, f); + + if (status & Fs_Writing) { + fseek(fp, 0L, SEEK_CUR); + BlkLoc(f)->file.status &= ~Fs_Writing; + } + BlkLoc(f)->file.status |= Fs_Reading; + +#ifdef ReadDirectory + if ((BlkLoc(f)->file.status & Fs_Directory) != 0) { + struct dirent *de = readdir((DIR*) fp); + if (de == NULL) + fail; + slen = strlen(de->d_name); + Protect(sp = alcstr(de->d_name, slen), runerr(0)); + return string(slen, sp); + } +#endif /* ReadDirectory */ + + /* + * Use getstrg to read a line from the file, failing if getstrg + * encounters end of file. [[ What about -2?]] + */ + StrLen(s) = 0; + do { +#ifdef Graphics + pollctr >>= 1; + pollctr++; + if (status & Fs_Window) { + slen = wgetstrg(sbuf,MaxReadStr,fp); + if (slen == -1) + runerr(141); + if (slen == -2) + runerr(143); + if (slen == -3) + fail; + } + else +#endif /* Graphics */ + + if ((slen = getstrg(sbuf, MaxReadStr, &BlkLoc(f)->file)) == -1) + fail; + + /* + * Allocate the string read and make s a descriptor for it. + */ + rlen = slen < 0 ? (word)MaxReadStr : slen; + + Protect(reserve(Strings, rlen), runerr(0)); + if (StrLen(s) > 0 && !InRange(strbase,StrLoc(s),strfree)) { + Protect(reserve(Strings, StrLen(s)+rlen), runerr(0)); + Protect((StrLoc(s) = alcstr(StrLoc(s),StrLen(s))), runerr(0)); + } + + Protect(sp = alcstr(sbuf,rlen), runerr(0)); + if (StrLen(s) == 0) + StrLoc(s) = sp; + StrLen(s) += rlen; + } while (slen < 0); + return s; + } +end + + +"reads(f,i) - read i characters on file f." + +function{0,1} reads(f,i) + /* + * Default f to &input. + */ + if is:null(f) then + inline { + f.dword = D_File; + BlkLoc(f) = (union block *)&k_input; + } + else if !is:file(f) then + runerr(105, f) + + /* + * i defaults to 1 (read a single character) + */ + if !def:C_integer(i,1L) then + runerr(101, i) + + abstract { + return string + } + + body { + long tally, nbytes; + int status; + FILE *fp; + tended struct descrip s; + + /* + * Get a pointer to the file and be sure that it is open for reading. + */ + fp = BlkLoc(f)->file.fd; + status = BlkLoc(f)->file.status; + if ((status & Fs_Read) == 0) + runerr(212, f); + + if (status & Fs_Writing) { + fseek(fp, 0L, SEEK_CUR); + BlkLoc(f)->file.status &= ~Fs_Writing; + } + BlkLoc(f)->file.status |= Fs_Reading; + + /* + * Be sure that a positive number of bytes is to be read. + */ + if (i <= 0) { + irunerr(205, i); + + errorfail; + } + +#ifdef ReadDirectory + /* + * If reading a directory, return up to i bytes of next entry. + */ + if ((BlkLoc(f)->file.status & Fs_Directory) != 0) { + char *sp; + struct dirent *de = readdir((DIR*) fp); + if (de == NULL) + fail; + nbytes = strlen(de->d_name); + if (nbytes > i) + nbytes = i; + Protect(sp = alcstr(de->d_name, nbytes), runerr(0)); + return string(nbytes, sp); + } +#endif /* ReadDirectory */ + + /* + * For now, assume we can read the full number of bytes. + */ + Protect(StrLoc(s) = alcstr(NULL, i), runerr(0)); + StrLen(s) = 0; + +#ifdef Graphics + pollctr >>= 1; + pollctr++; + if (status & Fs_Window) { + tally = wlongread(StrLoc(s),sizeof(char),i,fp); + if (tally == -1) + runerr(141); + else if (tally == -2) + runerr(143); + else if (tally == -3) + fail; + } + else +#endif /* Graphics */ + tally = longread(StrLoc(s),sizeof(char),i,fp); + + if (tally == 0) + fail; + StrLen(s) = tally; + /* + * We may not have used the entire amount of storage we reserved. + */ + nbytes = DiffPtrs(StrLoc(s) + tally, strfree); + if (nbytes < 0) + EVVal(-nbytes, E_StrDeAlc); + else + EVVal(nbytes, E_String); + strtotal += nbytes; + strfree = StrLoc(s) + tally; + return s; + } +end + + +"remove(s) - remove the file named s." + +function{0,1} remove(s) + + /* + * Make a C-style string out of s + */ + if !cnv:C_string(s) then + runerr(103,s) + abstract { + return null + } + + inline { + if (remove(s) != 0) + fail; + return nulldesc; + } +end + + +"rename(s1,s2) - rename the file named s1 to have the name s2." + +function{0,1} rename(s1,s2) + + /* + * Make C-style strings out of s1 and s2 + */ + if !cnv:C_string(s1) then + runerr(103,s1) + if !cnv:C_string(s2) then + runerr(103,s2) + + abstract { + return null + } + + body { + if (rename(s1,s2) != 0) + fail; + return nulldesc; + } +end + + +"seek(f,i) - seek to offset i in file f." +" [[ What about seek error ? ]] " + +function{0,1} seek(f,o) + + /* + * f must be a file + */ + if !is:file(f) then + runerr(105,f) + + /* + * o must be an integer and defaults to 1. + */ + if !def:C_integer(o,1L) then + runerr(0) + + abstract { + return file + } + + body { + FILE *fd; + + fd = BlkLoc(f)->file.fd; + if (BlkLoc(f)->file.status == 0) + fail; +#ifdef ReadDirectory + if ((BlkLoc(f)->file.status & Fs_Directory) != 0) + fail; +#endif /* ReadDirectory */ + +#ifdef Graphics + pollctr >>= 1; + pollctr++; + if (BlkLoc(f)->file.status & Fs_Window) + fail; +#endif /* Graphics */ + + if (o > 0) { + if (fseek(fd, o - 1, SEEK_SET) != 0) + fail; + } + else { + if (fseek(fd, o, SEEK_END) != 0) + fail; + } + BlkLoc(f)->file.status &= ~(Fs_Reading | Fs_Writing); + return f; + } +end + + +"system(s) - execute string s as a system command." + +function{1} system(s) + /* + * Make a C-style string out of s + */ + if !cnv:C_string(s) then + runerr(103,s) + + abstract { + return integer + } + + inline { + /* + * Pass the C string to the system() function and return + * the exit code of the command as the result of system(). + * Note, the expression on a "return" may not have side effects, + * so the exit code must be returned via a variable. + */ + C_integer i; + +#ifdef Graphics + pollctr >>= 1; + pollctr++; +#endif /* Graphics */ + + i = (C_integer)system(s); + return C_integer i; + } +end + + + +"where(f) - return current offset position in file f." + +function{0,1} where(f) + + if !is:file(f) then + runerr(105,f) + + abstract { + return integer + } + + body { + FILE *fd; + long ftell(); + long pos; + + fd = BlkLoc(f)->file.fd; + + if ((BlkLoc(f)->file.status == 0)) + fail; +#ifdef ReadDirectory + if ((BlkLoc(f)->file.status & Fs_Directory) != 0) + fail; +#endif /* ReadDirectory */ + +#ifdef Graphics + pollctr >>= 1; + pollctr++; + if (BlkLoc(f)->file.status & Fs_Window) + fail; +#endif /* Graphics */ + + pos = ftell(fd) + 1; + if (pos == 0) + fail; /* may only be effective on ANSI systems */ + + return C_integer pos; + } +end + +/* + * stop(), write(), and writes() differ in whether they stop the program + * and whether they output newlines. The macro GenWrite is used to + * produce all three functions. + */ +#define False 0 +#define True 1 + +#begdef DefaultFile(error_out) + inline { +#if error_out + if ((k_errout.status & Fs_Write) == 0) + runerr(213); + else { + f = k_errout.fd; + } +#else /* error_out */ + if ((k_output.status & Fs_Write) == 0) + runerr(213); + else { + f = k_output.fd; + } +#endif /* error_out */ + } +#enddef /* DefaultFile */ + +#begdef Finish(retvalue, nl, terminate) +#if nl + /* + * Append a newline to the file. + */ +#ifdef Graphics + pollctr >>= 1; + pollctr++; + if (status & Fs_Window) + wputc('\n',(wbp)f); + else +#endif /* Graphics */ + putc('\n', f); +#endif /* nl */ + + /* + * Flush the file. + */ +#ifdef Graphics + if (!(status & Fs_Window)) { +#endif /* Graphics */ + if (ferror(f)) + runerr(214); + fflush(f); + +#ifdef Graphics + } +#endif /* Graphics */ + + +#if terminate + c_exit(EXIT_FAILURE); +#else /* terminate */ + return retvalue; +#endif /* terminate */ +#enddef /* Finish */ + +#begdef GenWrite(name, nl, terminate) + +#name "(a,b,...) - write arguments" +#if !nl + " without newline terminator" +#endif /* nl */ +#if terminate + " (starting on error output) and stop" +#endif /* terminate */ +"." + +#if terminate +function {} name(x[nargs]) +#else /* terminate */ +function {1} name(x[nargs]) +#endif /* terminate */ + + declare { + FILE *f = NULL; + word status = k_errout.status; + } + +#if terminate + abstract { + return empty_type + } +#endif /* terminate */ + + len_case nargs of { + 0: { +#if !terminate + abstract { + return null + } +#endif /* terminate */ + DefaultFile(terminate) + body { + Finish(nulldesc, nl, terminate) + } + } + + default: { +#if !terminate + abstract { + return type(x) + } +#endif /* terminate */ + /* + * See if we need to start with the default file. + */ + if !is:file(x[0]) then + DefaultFile(terminate) + + body { + tended struct descrip t; + register word n; + + /* + * Loop through the arguments. + */ + for (n = 0; n < nargs; n++) { + if (is:file(x[n])) { /* Current argument is a file */ +#if nl + /* + * If this is not the first argument, output a newline to the + * current file and flush it. + */ + if (n > 0) { + + /* + * Append a newline to the file and flush it. + */ +#ifdef Graphics + pollctr >>= 1; + pollctr++; + if (status & Fs_Window) { + wputc('\n',(wbp)f); + wflush((wbp)f); + } + else { +#endif /* Graphics */ + putc('\n', f); + if (ferror(f)) + runerr(214); + fflush(f); +#ifdef Graphics + } +#endif /* Graphics */ + } +#endif /* nl */ + + /* + * Switch the current file to the file named by the current + * argument providing it is a file. + */ + status = BlkLoc(x[n])->file.status; + if ((status & Fs_Write) == 0) + runerr(213, x[n]); + f = BlkLoc(x[n])->file.fd; + } + else { + /* + * Convert the argument to a string, defaulting to a empty + * string. + */ + if (!def:tmp_string(x[n],emptystr,t)) + runerr(109, x[n]); + + /* + * Output the string. + */ +#ifdef Graphics + if (status & Fs_Window) + wputstr((wbp)f, StrLoc(t), StrLen(t)); + else +#endif /* Graphics */ + if (putstr(f, &t) == Failed) { + runerr(214, x[n]); + } + } + } + + Finish(x[n-1], nl, terminate) + } + } + } +end +#enddef /* GenWrite */ + +GenWrite(stop, True, True) /* stop(s, ...) - write message and stop */ +GenWrite(write, True, False) /* write(s, ...) - write with new-line */ +GenWrite(writes, False, False) /* writes(s, ...) - write with no new-line */ + +#ifdef KeyboardFncs + +"getch() - return a character from console." + +function{0,1} getch() + abstract { + return string; + } + body { + int i; + i = getch(); + if (i<0 || i>255) + fail; + return string(1, (char *)&allchars[i & 0xFF]); + } +end + +"getche() -- return a character from console with echo." + +function{0,1} getche() + abstract { + return string; + } + body { + int i; + i = getche(); + if (i<0 || i>255) + fail; + return string(1, (char *)&allchars[i & 0xFF]); + } +end + + +"kbhit() -- Check to see if there is a keyboard character waiting to be read." + +function{0,1} kbhit() + abstract { + return null + } + inline { + if (kbhit()) + return nulldesc; + else + fail; + } +end +#endif /* KeyboardFncs */ + +"chdir(s) - change working directory to s." +function{0,1} chdir(s) + + if !cnv:C_string(s) then + runerr(103,s) + abstract { + return null + } + inline { + if (chdir(s) != 0) + fail; + return nulldesc; + } +end + +"delay(i) - delay for i milliseconds." + +function{1} delay(n) + + if !cnv:C_integer(n) then + runerr(101,n) + abstract { + return null + } + + inline { + if (idelay(n) == Failed) + fail; +#ifdef Graphics + pollctr >>= 1; + pollctr++; +#endif /* Graphics */ + return nulldesc; + } +end + +"flush(f) - flush file f." + +function{1} flush(f) + if !is:file(f) then + runerr(105, f) + abstract { + return type(f) + } + + body { + FILE *fp; + int status; + + fp = BlkLoc(f)->file.fd; + status = BlkLoc(f)->file.status; + if ((status & (Fs_Read | Fs_Write)) == 0) + return f; /* if already closed */ + +#ifdef ReadDirectory + if ((BlkLoc(f)->file.status & Fs_Directory) != 0) + return f; +#endif /* ReadDirectory */ + +#ifdef Graphics + pollctr >>= 1; + pollctr++; + if (!(BlkLoc(f)->file.status & Fs_Window)) + fflush(fp); +#else /* Graphics */ + fflush(fp); +#endif /* Graphics */ + + /* + * Return the flushed file. + */ + return f; + } +end + +#ifdef FAttrib + +"fattrib(str, att) - get the attribute of a file " + +function{*} fattrib (fname, att[argc]) + + if !cnv:C_string(fname) then + runerr(103, fname) + + abstract { + return string ++ integer + } + + body { + tended char *s; + struct stat fs; + int fd, i; + char *retval; + char *temp; + long l; + + if ( stat(fname, &fs) == -1 ) + fail; + for(i=0; i<argc; i++) { + if (!cnv:C_string(att[i], s)) { + runerr(103, att[i]); + } + if ( !strcasecmp("size", s) ) { + suspend C_integer(fs.st_size); + } + else if ( !strcasecmp("status", s) ) { + temp = make_mode (fs.st_mode); + l = strlen(temp); + Protect(retval = alcstr(temp,l), runerr(0)); + free(temp); + suspend string(l, retval); + } + else if ( !strcasecmp("m_time", s) ) { + temp = ctime(&(fs.st_mtime)); + l = strlen(temp); + if (temp[l-1] == '\n') l--; + Protect(temp = alcstr(temp, l), runerr(0)); + suspend string(l, temp); + } + else if ( !strcasecmp("a_time", s) ) { + temp = ctime(&(fs.st_atime)); + l = strlen(temp); + if (temp[l-1] == '\n') l--; + Protect(temp = alcstr(temp, l), runerr(0)); + suspend string(l, temp); + } + else if ( !strcasecmp("c_time", s) ) { + temp = ctime(&(fs.st_ctime)); + l = strlen(temp); + if (temp[l-1] == '\n') l--; + Protect(temp = alcstr(temp, l), runerr(0)); + suspend string(l, temp); + } + else { + runerr(205, att[i]); + } + } + fail; + } +end +#endif /* FAttrib */ diff --git a/src/runtime/fwindow.r b/src/runtime/fwindow.r new file mode 100644 index 0000000..010286f --- /dev/null +++ b/src/runtime/fwindow.r @@ -0,0 +1,2720 @@ +/* + * File: fwindow.r - Icon graphics interface + * + * Contents: Active, Bg, Color, CopyArea, Couple, + * DrawArc, DrawCircle, DrawCurve, DrawImage, DrawLine, + * DrawSegment, DrawPoint, DrawPolygon, DrawString, + * DrawRectangle, EraseArea, Event, Fg, FillArc, FillCircle, + * FillRectangle, FillPolygon, Font, FreeColor, GotoRC, GotoXY, + * NewColor, Pattern, PaletteChars, PaletteColor, PaletteKey, + * Pending, QueryPointer, ReadImage, TextWidth, Uncouple, + * WAttrib, WDefault, WFlush, WSync, WriteImage + */ + +#ifdef Graphics + +/* + * Global variables. + * A poll counter for use in interp.c, + * the binding for the console window - FILE * for simplicity, + * &col, &row, &x, &y, &interval, timestamp, and modifier keys. + */ +int pollctr; +FILE *ConsoleBinding = NULL; +/* + * the global buffer used as work space for printing string, etc + */ +char ConsoleStringBuf[MaxReadStr * 48]; +char *ConsoleStringBufPtr = ConsoleStringBuf; +unsigned long ConsoleFlags = 0; /* Console flags */ + + + +"Active() - produce the next active window" + +function{0,1} Active() + abstract { + return file + } + body { + wsp ws; + if (!wstates || !(ws = getactivewindow())) fail; + return ws->filep; + } +end + + +"Alert(w,volume) - Alert the user" + +function{1} Alert(argv[argc]) + abstract { + return file + } + body { + wbp w; + int warg = 0; + C_integer volume; + OptWindow(w); + + if (argc == warg) volume = 0; + else if (!def:C_integer(argv[warg], 0, volume)) + runerr(101, argv[warg]); + walert(w, volume); + ReturnWindow; + } +end + +"Bg(w,s) - background color" + +function{0,1} Bg(argv[argc]) + abstract { + return string + } + body { + wbp w; + char sbuf1[MaxCvtLen]; + int len; + tended char *tmp; + int warg = 0; + OptWindow(w); + + /* + * If there is a (non-window) argument we are setting by + * either a mutable color (negative int) or a string name. + */ + if (argc - warg > 0) { + if (is:integer(argv[warg])) { /* mutable color or packed RGB */ + if (isetbg(w, IntVal(argv[warg])) == Failed) fail; + } + else { + if (!cnv:C_string(argv[warg], tmp)) + runerr(103,argv[warg]); + if(setbg(w, tmp) == Failed) fail; + } + } + + /* + * In any event, this function returns the current background color. + */ + getbg(w, sbuf1); + len = strlen(sbuf1); + Protect(tmp = alcstr(sbuf1, len), runerr(0)); + return string(len, tmp); + } +end + + +"Clip(w, x, y, w, h) - set context clip rectangle" + +function{1} Clip(argv[argc]) + abstract { + return file + } + body { + wbp w; + int warg = 0, r; + C_integer x, y, width, height; + wcp wc; + OptWindow(w); + + wc = w->context; + + if (argc <= warg) { + wc->clipx = wc->clipy = 0; + wc->clipw = wc->cliph = -1; + unsetclip(w); + } + else { + r = rectargs(w, argc, argv, warg, &x, &y, &width, &height); + if (r >= 0) + runerr(101, argv[r]); + wc->clipx = x; + wc->clipy = y; + wc->clipw = width; + wc->cliph = height; + setclip(w); + } + + ReturnWindow; + } +end + + +"Clone(w, attribs...) - create a new context bound to w's canvas" + +function{1} Clone(argv[argc]) + abstract { + return file + } + body { + wbp w, w2; + int warg = 0, n; + tended struct descrip sbuf, sbuf2; + char answer[128]; + OptWindow(w); + + Protect(w2 = alc_wbinding(), runerr(0)); + w2->window = w->window; + w2->window->refcount++; + + if (argc>warg && is:file(argv[warg])) { + if ((BlkLoc(argv[warg])->file.status & Fs_Window) == 0) + runerr(140,argv[warg]); + if ((BlkLoc(argv[warg])->file.status & (Fs_Read|Fs_Write)) == 0) + runerr(142,argv[warg]); + if (ISCLOSED((wbp)BlkLoc(argv[warg])->file.fd)) + runerr(142,argv[warg]); + Protect(w2->context = + clone_context((wbp)BlkLoc(argv[warg])->file.fd), runerr(0)); + warg++; + } + else { + Protect(w2->context = clone_context(w), runerr(0)); + } + + for (n = warg; n < argc; n++) { + if (!is:null(argv[n])) { + if (!cnv:tmp_string(argv[n], sbuf)) + runerr(109, argv[n]); + switch (wattrib(w2, StrLoc(argv[n]), StrLen(argv[n]), &sbuf2, answer)) { + case Failed: fail; + case Error: runerr(0, argv[n]); + } + } + } + + Protect(BlkLoc(result) = + (union block *)alcfile((FILE *)w2, Fs_Window|Fs_Read|Fs_Write, + &emptystr),runerr(0)); + result.dword = D_File; + return result; + } +end + + + +"Color(argv[]) - return or set color map entries" + +function{0,1} Color(argv[argc]) + abstract { + return file ++ string + } + body { + wbp w; + int warg = 0; + int i, len; + C_integer n; + char *colorname, *srcname; + tended char *tmp; + + OptWindow(w); + if (argc - warg == 0) runerr(101); + + if (argc - warg == 1) { /* if this is a query */ + CnvCInteger(argv[warg], n) + if ((colorname = get_mutable_name(w, n)) == NULL) + fail; + len = strlen(colorname); + Protect(tmp = alcstr(colorname, len), runerr(0)); + return string(len, tmp); + } + + CheckArgMultiple(2); + + for (i = warg; i < argc; i += 2) { + CnvCInteger(argv[i], n) + if ((colorname = get_mutable_name(w, n)) == NULL) + fail; + + if (is:integer(argv[i+1])) { /* copy another mutable */ + if (IntVal(argv[i+1]) >= 0) + runerr(205, argv[i+1]); /* must be negative */ + if ((srcname = get_mutable_name(w, IntVal(argv[i+1]))) == NULL) + fail; + if (set_mutable(w, n, srcname) == Failed) fail; + strcpy(colorname, srcname); + } + + else { /* specified by name */ + tended char *tmp; + if (!cnv:C_string(argv[i+1],tmp)) + runerr(103,argv[i+1]); + + if (set_mutable(w, n, tmp) == Failed) fail; + strcpy(colorname, tmp); + } + } + + ReturnWindow; + } +end + + +"ColorValue(w,s) - produce RGB components from string color name" + +function{0,1} ColorValue(argv[argc]) + abstract { + return string + } + body { + wbp w; + C_integer n; + int warg = 0, len; + long r, g, b; + tended char *s; + char tmp[24], *t; + + if (is:file(argv[0]) && (BlkLoc(argv[0])->file.status & Fs_Window)) { + w = (wbp)BlkLoc(argv[0])->file.fd; /* explicit window */ + warg = 1; + } + else if (is:file(kywd_xwin[XKey_Window]) && + (BlkLoc(kywd_xwin[XKey_Window])->file.status & Fs_Window)) + w = (wbp)BlkLoc(kywd_xwin[XKey_Window])->file.fd; /* &window */ + else + w = NULL; /* no window (but proceed anyway) */ + + if (!(warg < argc)) + runerr(103); + + if (cnv:C_integer(argv[warg], n)) { + if (w != NULL && (t = get_mutable_name(w, n))) + Protect(s = alcstr(t, (word)strlen(t)+1), runerr(306)); + else + fail; + } + else if (!cnv:C_string(argv[warg], s)) + runerr(103,argv[warg]); + + if (parsecolor(w, s, &r, &g, &b) == Succeeded) { + sprintf(tmp,"%ld,%ld,%ld", r, g, b); + len = strlen(tmp); + Protect(s = alcstr(tmp,len), runerr(306)); + return string(len, s); + } + fail; + } +end + + +"CopyArea(w,w2,x,y,width,height,x2,y2) - copy area" + +function{0,1} CopyArea(argv[argc]) /* w,w2,x,y,width,height,x2,y2 */ + abstract { + return file + } + body { + int warg = 0, n, r; + C_integer x, y, width, height, x2, y2, width2, height2; + wbp w, w2; + OptWindow(w); + + /* + * 2nd window defaults to value of first window + */ + if (argc>warg && is:file(argv[warg])) { + if ((BlkLoc(argv[warg])->file.status & Fs_Window) == 0) + runerr(140,argv[warg]); + if ((BlkLoc(argv[warg])->file.status & (Fs_Read|Fs_Write)) == 0) + runerr(142,argv[warg]); + w2 = (wbp)BlkLoc(argv[warg])->file.fd; + if (ISCLOSED(w2)) + runerr(142,argv[warg]); + warg++; + } + else { + w2 = w; + } + + /* + * x1, y1, width, and height follow standard conventions. + */ + r = rectargs(w, argc, argv, warg, &x, &y, &width, &height); + if (r >= 0) + runerr(101, argv[r]); + + /* + * get x2 and y2, ignoring width and height. + */ + n = argc; + if (n > warg + 6) + n = warg + 6; + r = rectargs(w2, n, argv, warg + 4, &x2, &y2, &width2, &height2); + if (r >= 0) + runerr(101, argv[r]); + + if (copyArea(w, w2, x, y, width, height, x2, y2) == Failed) + fail; + ReturnWindow; + } +end + +/* + * Bind the canvas associated with w to the context + * associated with w2. If w2 is omitted, create a new context. + * Produces a new window variable. + */ +"Couple(w,w2) - couple canvas to context" + +function{0,1} Couple(w,w2) + abstract { + return file + } + body { + tended struct descrip sbuf, sbuf2; + wbp wb, wb_new; + wsp ws; + + /* + * make the new binding + */ + Protect(wb_new = alc_wbinding(), runerr(0)); + + /* + * if w is a file, then we bind to an existing window + */ + if (is:file(w) && (BlkLoc(w)->file.status & Fs_Window)) { + wb = (wbp)(BlkLoc(w)->file.fd); + wb_new->window = ws = wb->window; + if (is:file(w2) && (BlkLoc(w2)->file.status & Fs_Window)) { + /* + * Bind an existing window to an existing context, + * and up the context's reference count. + */ + if (rebind(wb_new, (wbp)(BlkLoc(w2)->file.fd)) == Failed) fail; + wb_new->context->refcount++; + } + else + runerr(140, w2); + + /* bump up refcount to ws */ + ws->refcount++; + } + else + runerr(140, w); + + Protect(BlkLoc(result) = + (union block *)alcfile((FILE *)wb_new, Fs_Window|Fs_Read|Fs_Write, + &emptystr),runerr(0)); + result.dword = D_File; + return result; + } +end + +/* + * DrawArc(w, x1, y1, width1, height1, angle11, angle21,...) + */ +"DrawArc(argv[]){1} - draw arc" + +function{1} DrawArc(argv[argc]) + abstract { + return file + } + body { + wbp w; + int i, j, r, warg = 0; + XArc arcs[MAXXOBJS]; + C_integer x, y, width, height; + double a1, a2; + + OptWindow(w); + j = 0; + for (i = warg; i < argc || i == warg; i += 6) { + if (j == MAXXOBJS) { + drawarcs(w, arcs, MAXXOBJS); + j = 0; + } + r = rectargs(w, argc, argv, i, &x, &y, &width, &height); + if (r >= 0) + runerr(101, argv[r]); + + arcs[j].x = x; + arcs[j].y = y; + ARCWIDTH(arcs[j]) = width; + ARCHEIGHT(arcs[j]) = height; + + /* + * Angle 1 processing. Computes in radians and 64'ths of a degree, + * bounds checks, and handles wraparound. + */ + if (i + 4 >= argc || is:null(argv[i + 4])) + a1 = 0.0; + else { + if (!cnv:C_double(argv[i + 4], a1)) + runerr(102, argv[i + 4]); + if (a1 >= 0.0) + a1 = fmod(a1, 2 * Pi); + else + a1 = -fmod(-a1, 2 * Pi); + } + /* + * Angle 2 processing + */ + if (i + 5 >= argc || is:null(argv[i + 5])) + a2 = 2 * Pi; + else { + if (!cnv:C_double(argv[i + 5], a2)) + runerr(102, argv[i + 5]); + if (fabs(a2) > 3 * Pi) + runerr(101, argv[i + 5]); + } + if (fabs(a2) >= 2 * Pi) { + a2 = 2 * Pi; + } + else { + if (a2 < 0.0) { + a1 += a2; + a2 = fabs(a2); + } + } + if (a1 < 0.0) + a1 = 2 * Pi - fmod(fabs(a1), 2 * Pi); + else + a1 = fmod(a1, 2 * Pi); + arcs[j].angle1 = ANGLE(a1); + arcs[j].angle2 = EXTENT(a2); + + j++; + } + + drawarcs(w, arcs, j); + ReturnWindow; + } +end + +/* + * DrawCircle(w, x1, y1, r1, angle11, angle21, ...) + */ +"DrawCircle(argv[]){1} - draw circle" + +function{1} DrawCircle(argv[argc]) + abstract { + return file + } + body { + wbp w; + int warg = 0, r; + + OptWindow(w); + r = docircles(w, argc - warg, argv + warg, 0); + if (r < 0) + ReturnWindow; + else if (r >= argc - warg) + runerr(146); + else + runerr(102, argv[warg + r]); + } +end + +/* + * DrawCurve(w,x1,y1,...xN,yN) + * Draw a smooth curve through the given points. + */ +"DrawCurve(argv[]){1} - draw curve" + +function{1} DrawCurve(argv[argc]) + abstract { + return file + } + body { + wbp w; + int i, n, closed = 0, warg = 0; + C_integer dx, dy, x0, y0, xN, yN; + XPoint *points; + + OptWindow(w); + CheckArgMultiple(2); + + dx = w->context->dx; + dy = w->context->dy; + + Protect(points = (XPoint *)malloc(sizeof(XPoint) * (n+2)), runerr(305)); + + if (n > 1) { + CnvCInteger(argv[warg], x0) + CnvCInteger(argv[warg + 1], y0) + CnvCInteger(argv[argc - 2], xN) + CnvCInteger(argv[argc - 1], yN) + if ((x0 == xN) && (y0 == yN)) { + closed = 1; /* duplicate the next to last point */ + CnvCShort(argv[argc-4], points[0].x); + CnvCShort(argv[argc-3], points[0].y); + points[0].x += w->context->dx; + points[0].y += w->context->dy; + } + else { /* duplicate the first point */ + CnvCShort(argv[warg], points[0].x); + CnvCShort(argv[warg + 1], points[0].y); + points[0].x += w->context->dx; + points[0].y += w->context->dy; + } + for (i = 1; i <= n; i++) { + int base = warg + (i-1) * 2; + CnvCShort(argv[base], points[i].x); + CnvCShort(argv[base + 1], points[i].y); + points[i].x += dx; + points[i].y += dy; + } + if (closed) { /* duplicate the second point */ + points[i] = points[2]; + } + else { /* duplicate the last point */ + points[i] = points[i-1]; + } + if (n < 3) { + drawlines(w, points+1, n); + } + else { + drawCurve(w, points, n+2); + } + } + free(points); + ReturnWindow; + } +end + + +"DrawImage(w,x,y,s) - draw bitmapped figure" + +function{0,1} DrawImage(argv[argc]) + abstract { + return null++integer + } + body { + wbp w; + int warg = 0; + int c, i, width, height, row, p; + C_integer x, y; + word nchars; + unsigned char *s, *t, *z; + struct descrip d; + struct palentry *e; + OptWindow(w); + + /* + * X or y can be defaulted but s is required. + * Validate x/y first so that the error message makes more sense. + */ + if (argc - warg >= 1 && !def:C_integer(argv[warg], -w->context->dx, x)) + runerr(101, argv[warg]); + if (argc - warg >= 2 && !def:C_integer(argv[warg + 1], -w->context->dy, y)) + runerr(101, argv[warg + 1]); + if (argc - warg < 3) + runerr(103); /* missing s */ + if (!cnv:tmp_string(argv[warg+2], d)) + runerr(103, argv[warg + 2]); + + x += w->context->dx; + y += w->context->dy; + /* + * Extract the Width and skip the following comma. + */ + s = (unsigned char *)StrLoc(d); + z = s + StrLen(d); /* end+1 of string */ + width = 0; + while (s < z && *s == ' ') /* skip blanks */ + s++; + while (s < z && isdigit(*s)) /* scan number */ + width = 10 * width + *s++ - '0'; + while (s < z && *s == ' ') /* skip blanks */ + s++; + if (width == 0 || *s++ != ',') /* skip comma */ + fail; + while (s < z && *s == ' ') /* skip blanks */ + s++; + if (s >= z) /* if end of string */ + fail; + + /* + * Check for a bilevel format. + */ + if ((c = *s) == '#' || c == '~') { + s++; + nchars = 0; + for (t = s; t < z; t++) + if (isxdigit(*t)) + nchars++; /* count hex digits */ + else if (*t != PCH1 && *t != PCH2) + fail; /* illegal punctuation */ + if (nchars == 0) + fail; + row = (width + 3) / 4; /* digits per row */ + if (nchars % row != 0) + fail; + height = nchars / row; + if (blimage(w, x, y, width, height, c, s, (word)(z - s)) == Error) + runerr(305); + else + return nulldesc; + } + + /* + * Extract the palette name and skip its comma. + */ + c = *s++; /* save initial character */ + p = 0; + while (s < z && isdigit(*s)) /* scan digits */ + p = 10 * p + *s++ - '0'; + while (s < z && *s == ' ') /* skip blanks */ + s++; + if (s >= z || p == 0 || *s++ != ',') /* skip comma */ + fail; + if (c == 'g' && p >= 2 && p <= 256) /* validate grayscale number */ + p = -p; + else if (c != 'c' || p < 1 || p > 6) /* validate color number */ + fail; + + /* + * Scan the image to see which colors are needed. + */ + e = palsetup(p); + if (e == NULL) + runerr(305); + for (i = 0; i < 256; i++) + e[i].used = 0; + nchars = 0; + for (t = s; t < z; t++) { + c = *t; + e[c].used = 1; + if (e[c].valid || e[c].transpt) + nchars++; /* valid color, or transparent */ + else if (c != PCH1 && c != PCH2) + fail; + } + if (nchars == 0) + fail; /* empty image */ + if (nchars % width != 0) + fail; /* not rectangular */ + + /* + * Call platform-dependent code to draw the image. + */ + height = nchars / width; + i = strimage(w, x, y, width, height, e, s, (word)(z - s), 0); + if (i == 0) + return nulldesc; + else if (i < 0) + runerr(305); + else + return C_integer i; + } +end + +/* + * DrawLine(w,x1,y1,...xN,yN) + */ +"DrawLine(argv[]){1} - draw line" + +function{1} DrawLine(argv[argc]) + abstract { + return file + } + body { + wbp w; + int i, j, n, warg = 0; + XPoint points[MAXXOBJS]; + int dx, dy; + + OptWindow(w); + CheckArgMultiple(2); + + dx = w->context->dx; + dy = w->context->dy; + for(i=0, j=0;i<n;i++, j++) { + int base = warg + i * 2; + if (j==MAXXOBJS) { + drawlines(w, points, MAXXOBJS); + points[0] = points[MAXXOBJS-1]; + j = 1; + } + CnvCShort(argv[base], points[j].x); + CnvCShort(argv[base + 1], points[j].y); + points[j].x += dx; + points[j].y += dy; + } + drawlines(w, points, j); + ReturnWindow; + } +end + +/* + * DrawPoint(w, x1, y1, ...xN, yN) + */ +"DrawPoint(argv[]){1} - draw point" + +function{1} DrawPoint(argv[argc]) + abstract { + return file + } + body { + wbp w; + int i, j, n, warg = 0; + XPoint points[MAXXOBJS]; + int dx, dy; + + OptWindow(w); + CheckArgMultiple(2); + + dx = w->context->dx; + dy = w->context->dy; + for(i=0, j=0; i < n; i++, j++) { + int base = warg + i * 2; + if (j == MAXXOBJS) { + drawpoints(w, points, MAXXOBJS); + j = 0; + } + CnvCShort(argv[base], points[j].x); + CnvCShort(argv[base + 1], points[j].y); + points[j].x += dx; + points[j].y += dy; + } + drawpoints(w, points, j); + ReturnWindow; + } +end + +/* + * DrawPolygon(w,x1,y1,...xN,yN) + */ +"DrawPolygon(argv[]){1} - draw polygon" + +function{1} DrawPolygon(argv[argc]) + abstract { + return file + } + body { + wbp w; + int i, j, n, base, dx, dy, warg = 0; + XPoint points[MAXXOBJS]; + + OptWindow(w); + CheckArgMultiple(2); + + dx = w->context->dx; + dy = w->context->dy; + + /* + * To make a closed polygon, start with the *last* point. + */ + CnvCShort(argv[argc - 2], points[0].x); + CnvCShort(argv[argc - 1], points[0].y); + points[0].x += dx; + points[0].y += dy; + + /* + * Now add all points from beginning to end, including last point again. + */ + for(i = 0, j = 1; i < n; i++, j++) { + base = warg + i * 2; + if (j == MAXXOBJS) { + drawlines(w, points, MAXXOBJS); + points[0] = points[MAXXOBJS-1]; + j = 1; + } + CnvCShort(argv[base], points[j].x); + CnvCShort(argv[base + 1], points[j].y); + points[j].x += dx; + points[j].y += dy; + } + drawlines(w, points, j); + ReturnWindow; + } +end + +/* + * DrawRectangle(w, x1, y1, width1, height1, ..., xN, yN, widthN,heightN) + */ +"DrawRectangle(argv[]){1} - draw rectangle" + +function{1} DrawRectangle(argv[argc]) + abstract { + return file + } + body { + wbp w; + int i, j, r, warg = 0; + XRectangle recs[MAXXOBJS]; + C_integer x, y, width, height; + + OptWindow(w); + j = 0; + + for (i = warg; i < argc || i == warg; i += 4) { + r = rectargs(w, argc, argv, i, &x, &y, &width, &height); + if (r >= 0) + runerr(101, argv[r]); + if (j == MAXXOBJS) { + drawrectangles(w,recs,MAXXOBJS); + j = 0; + } + RECX(recs[j]) = x; + RECY(recs[j]) = y; + RECWIDTH(recs[j]) = width; + RECHEIGHT(recs[j]) = height; + j++; + } + + drawrectangles(w, recs, j); + ReturnWindow; + } +end + +/* + * DrawSegment(x11,y11,x12,y12,...,xN1,yN1,xN2,yN2) + */ +"DrawSegment(argv[]){1} - draw line segment" + +function{1} DrawSegment(argv[argc]) + abstract { + return file + } + body { + wbp w; + int i, j, n, warg = 0, dx, dy; + XSegment segs[MAXXOBJS]; + + OptWindow(w); + CheckArgMultiple(4); + + dx = w->context->dx; + dy = w->context->dy; + for(i=0, j=0; i < n; i++, j++) { + int base = warg + i * 4; + if (j == MAXXOBJS) { + drawsegments(w, segs, MAXXOBJS); + j = 0; + } + CnvCShort(argv[base], segs[j].x1); + CnvCShort(argv[base + 1], segs[j].y1); + CnvCShort(argv[base + 2], segs[j].x2); + CnvCShort(argv[base + 3], segs[j].y2); + segs[j].x1 += dx; + segs[j].x2 += dx; + segs[j].y1 += dy; + segs[j].y2 += dy; + } + drawsegments(w, segs, j); + ReturnWindow; + } +end + +/* + * DrawString(w, x1, y1, s1, ..., xN, yN, sN) + */ +"DrawString(argv[]){1} - draw text" + +function{1} DrawString(argv[argc]) + abstract { + return file + } + body { + wbp w; + int i, n, len, warg = 0; + char *s; + + OptWindow(w); + CheckArgMultiple(3); + + for(i=0; i < n; i++) { + C_integer x, y; + int base = warg + i * 3; + CnvCInteger(argv[base], x); + CnvCInteger(argv[base + 1], y); + x += w->context->dx; + y += w->context->dy; + CnvTmpString(argv[base + 2], argv[base + 2]); + s = StrLoc(argv[base + 2]); + len = StrLen(argv[base + 2]); + drawstrng(w, x, y, s, len); + } + ReturnWindow; + } +end + + +"EraseArea(w,x,y,width,height) - clear an area of the window" + +function{1} EraseArea(argv[argc]) + abstract { + return file + } + body { + wbp w; + int warg = 0, i, r; + C_integer x, y, width, height; + OptWindow(w); + + for (i = warg; i < argc || i == warg; i += 4) { + r = rectargs(w, argc, argv, i, &x, &y, &width, &height); + if (r >= 0) + runerr(101, argv[r]); + eraseArea(w, x, y, width, height); + } + + ReturnWindow; + } +end + + +"Event(w) - return an event from a window" + +function{1} Event(argv[argc]) + abstract { + return string ++ integer + } + body { + wbp w; + C_integer i; + tended struct descrip d; + int warg = 0; + OptWindow(w); + + d = nulldesc; + i = wgetevent(w, &d); + if (i == 0) { + if (is:file(kywd_xwin[XKey_Window]) && + w == (wbp)BlkLoc(kywd_xwin[XKey_Window])->file.fd) + lastEventWin = kywd_xwin[XKey_Window]; + else + lastEventWin = argv[warg-1]; + lastEvFWidth = FWIDTH((wbp)BlkLoc(lastEventWin)->file.fd); + lastEvLeading = LEADING((wbp)BlkLoc(lastEventWin)->file.fd); + lastEvAscent = ASCENT((wbp)BlkLoc(lastEventWin)->file.fd); + return d; + } + else if (i == -1) + runerr(141); + else + runerr(143); + } +end + + +"Fg(w,s) - foreground color" + +function{0,1} Fg(argv[argc]) + abstract { + return string + } + body { + wbp w; + char sbuf1[MaxCvtLen]; + int len; + tended char *tmp; + int warg = 0; + OptWindow(w); + + /* + * If there is a (non-window) argument we are setting by + * either a mutable color (negative int) or a string name. + */ + if (argc - warg > 0) { + if (is:integer(argv[warg])) { /* mutable color or packed RGB */ + if (isetfg(w, IntVal(argv[warg])) == Failed) fail; + } + else { + if (!cnv:C_string(argv[warg], tmp)) + runerr(103,argv[warg]); + if(setfg(w, tmp) == Failed) fail; + } + } + + /* + * In any case, this function returns the current foreground color. + */ + getfg(w, sbuf1); + len = strlen(sbuf1); + Protect(tmp = alcstr(sbuf1, len), runerr(0)); + return string(len, tmp); + } +end + +/* + * FillArc(w, x1, y1, width1, height1, angle11, angle21,...) + */ +"FillArc(argv[]){1} - fill arc" + +function{1} FillArc(argv[argc]) + abstract { + return file + } + body { + wbp w; + int i, j, r, warg = 0; + XArc arcs[MAXXOBJS]; + C_integer x, y, width, height; + double a1, a2; + + OptWindow(w); + j = 0; + for (i = warg; i < argc || i == warg; i += 6) { + if (j == MAXXOBJS) { + fillarcs(w, arcs, MAXXOBJS); + j = 0; + } + r = rectargs(w, argc, argv, i, &x, &y, &width, &height); + if (r >= 0) + runerr(101, argv[r]); + + arcs[j].x = x; + arcs[j].y = y; + ARCWIDTH(arcs[j]) = width; + ARCHEIGHT(arcs[j]) = height; + + if (i + 4 >= argc || is:null(argv[i + 4])) { + a1 = 0.0; + } + else { + if (!cnv:C_double(argv[i + 4], a1)) + runerr(102, argv[i + 4]); + if (a1 >= 0.0) + a1 = fmod(a1, 2 * Pi); + else + a1 = -fmod(-a1, 2 * Pi); + } + if (i + 5 >= argc || is:null(argv[i + 5])) + a2 = 2 * Pi; + else { + if (!cnv:C_double(argv[i + 5], a2)) + runerr(102, argv[i + 5]); + if (fabs(a2) > 3 * Pi) + runerr(101, argv[i + 5]); + } + if (fabs(a2) >= 2 * Pi) { + a2 = 2 * Pi; + } + else { + if (a2 < 0.0) { + a1 += a2; + a2 = fabs(a2); + } + } + arcs[j].angle2 = EXTENT(a2); + if (a1 < 0.0) + a1 = 2 * Pi - fmod(fabs(a1), 2 * Pi); + else + a1 = fmod(a1, 2 * Pi); + arcs[j].angle1 = ANGLE(a1); + + j++; + } + + fillarcs(w, arcs, j); + ReturnWindow; + } +end + +/* + * FillCircle(w, x1, y1, r1, angle11, angle21, ...) + */ +"FillCircle(argv[]){1} - draw filled circle" + +function{1} FillCircle(argv[argc]) + abstract { + return file + } + body { + wbp w; + int warg = 0, r; + + OptWindow(w); + r = docircles(w, argc - warg, argv + warg, 1); + if (r < 0) + ReturnWindow; + else if (r >= argc - warg) + runerr(146); + else + runerr(102, argv[warg + r]); + } +end + +/* + * FillPolygon(w, x1, y1, ...xN, yN) + */ +"FillPolygon(argv[]){1} - fill polygon" + +function{1} FillPolygon(argv[argc]) + abstract { + return file + } + body { + wbp w; + int i, n, warg = 0; + XPoint *points; + int dx, dy; + + OptWindow(w); + + CheckArgMultiple(2) + + /* + * Allocate space for all the points in a contiguous array, + * because a FillPolygon must be performed in a single call. + */ + n = argc>>1; + Protect(points = (XPoint *)malloc(sizeof(XPoint) * n), runerr(305)); + dx = w->context->dx; + dy = w->context->dy; + for(i=0; i < n; i++) { + int base = warg + i * 2; + CnvCShort(argv[base], points[i].x); + CnvCShort(argv[base + 1], points[i].y); + points[i].x += dx; + points[i].y += dy; + } + fillpolygon(w, points, n); + free(points); + ReturnWindow; + } +end + +/* + * FillRectangle(w, x1, y1, width1, height1,...,xN, yN, widthN, heightN) + */ +"FillRectangle(argv[]){1} - draw filled rectangle" + +function{1} FillRectangle(argv[argc]) + abstract { + return file + } + body { + wbp w; + int i, j, r, warg = 0; + XRectangle recs[MAXXOBJS]; + C_integer x, y, width, height; + + OptWindow(w); + j = 0; + + for (i = warg; i < argc || i == warg; i += 4) { + r = rectargs(w, argc, argv, i, &x, &y, &width, &height); + if (r >= 0) + runerr(101, argv[r]); + if (j == MAXXOBJS) { + fillrectangles(w,recs,MAXXOBJS); + j = 0; + } + RECX(recs[j]) = x; + RECY(recs[j]) = y; + RECWIDTH(recs[j]) = width; + RECHEIGHT(recs[j]) = height; + j++; + } + + fillrectangles(w, recs, j); + ReturnWindow; + } +end + + + +"Font(w,s) - get/set font" + +function{0,1} Font(argv[argc]) + abstract { + return string + } + body { + tended char *tmp; + int len; + wbp w; + int warg = 0; + char buf[MaxCvtLen]; + OptWindow(w); + + if (warg < argc) { + if (!cnv:C_string(argv[warg],tmp)) + runerr(103,argv[warg]); + if (setfont(w,&tmp) == Failed) fail; + } + getfntnam(w, buf); + len = strlen(buf); + Protect(tmp = alcstr(buf, len), runerr(0)); + return string(len,tmp); + } +end + + +"FreeColor(argv[]) - free colors" + +function{1} FreeColor(argv[argc]) + abstract { + return file + } + body { + wbp w; + int warg = 0; + int i; + C_integer n; + tended char *s; + + OptWindow(w); + if (argc - warg == 0) runerr(103); + + for (i = warg; i < argc; i++) { + if (is:integer(argv[i])) { + CnvCInteger(argv[i], n) + if (n < 0) + free_mutable(w, n); + } + else { + if (!cnv:C_string(argv[i], s)) + runerr(103,argv[i]); + freecolor(w, s); + } + } + + ReturnWindow; + } + +end + + +"GotoRC(w,r,c) - move cursor to a particular text row and column" + +function{1} GotoRC(argv[argc]) + abstract { + return file + } + body { + C_integer r, c; + wbp w; + int warg = 0; + OptWindow(w); + + if (argc - warg < 1) + r = 1; + else + CnvCInteger(argv[warg], r) + if (argc - warg < 2) + c = 1; + else + CnvCInteger(argv[warg + 1], c) + + /* + * turn the cursor off + */ + hidecrsr(w->window); + + w->window->y = ROWTOY(w, r); + w->window->x = COLTOX(w, c); + w->window->x += w->context->dx; + w->window->y += w->context->dy; + + /* + * turn it back on at new location + */ + UpdateCursorPos(w->window, w->context); + showcrsr(w->window); + + ReturnWindow; + } +end + + +"GotoXY(w,x,y) - move cursor to a particular pixel location" + +function{1} GotoXY(argv[argc]) + abstract { + return file + } + body { + wbp w; + C_integer x, y; + int warg = 0; + OptWindow(w); + + if (argc - warg < 1) + x = 0; + else + CnvCInteger(argv[warg], x) + if (argc - warg < 2) + y = 0; + else + CnvCInteger(argv[warg + 1], y) + + x += w->context->dx; + y += w->context->dy; + + hidecrsr(w->window); + + w->window->x = x; + w->window->y = y; + + UpdateCursorPos(w->window, w->context); + showcrsr(w->window); + + ReturnWindow; + } +end + + +"Lower(w) - lower w to the bottom of the window stack" + +function{1} Lower(argv[argc]) + abstract { + return file + } + body { + wbp w; + int warg = 0; + OptWindow(w); + lowerWindow(w); + ReturnWindow; + } +end + + +"NewColor(w,s) - allocate an entry in the color map" + +function{0,1} NewColor(argv[argc]) + abstract { + return integer + } + body { + wbp w; + int rv; + int warg = 0; + OptWindow(w); + + if (mutable_color(w, argv+warg, argc-warg, &rv) == Failed) fail; + return C_integer rv; + } +end + + + +"PaletteChars(w,p) - return the characters forming keys to palette p" + +function{0,1} PaletteChars(argv[argc]) + abstract { + return string + } + body { + int n, warg; + extern char c1list[], c2list[], c3list[], c4list[]; + + if (is:file(argv[0]) && (BlkLoc(argv[0])->file.status & Fs_Window)) + warg = 1; + else + warg = 0; /* window not required */ + if (argc - warg < 1) + n = 1; + else + n = palnum(&argv[warg]); + switch (n) { + case -1: runerr(103, argv[warg]); /* not a string */ + case 0: fail; /* unrecognized */ + case 1: return string(90, c1list); /* c1 */ + case 2: return string(9, c2list); /* c2 */ + case 3: return string(31, c3list); /* c3 */ + case 4: return string(73, c4list); /* c4 */ + case 5: return string(141, (char *)allchars); /* c5 */ + case 6: return string(241, (char *)allchars); /* c6 */ + default: /* gn */ + if (n >= -64) + return string(-n, c4list); + else + return string(-n, (char *)allchars); + } + } +end + + +"PaletteColor(w,p,s) - return color of key s in palette p" + +function{0,1} PaletteColor(argv[argc]) + abstract { + return string + } + body { + int p, warg, len; + char tmp[24], *s; + struct palentry *e; + tended struct descrip d; + + if (is:file(argv[0]) && (BlkLoc(argv[0])->file.status & Fs_Window)) + warg = 1; + else + warg = 0; /* window not required */ + if (argc - warg < 2) + runerr(103); + p = palnum(&argv[warg]); + if (p == -1) + runerr(103, argv[warg]); + if (p == 0) + fail; + if (!cnv:tmp_string(argv[warg + 1], d)) + runerr(103, argv[warg + 1]); + if (StrLen(d) != 1) + runerr(205, d); + e = palsetup(p); + if (e == NULL) + runerr(305); + e += *StrLoc(d) & 0xFF; + if (!e->valid) + fail; + sprintf(tmp, "%ld,%ld,%ld", e->clr.red, e->clr.green, e->clr.blue); + len = strlen(tmp); + Protect(s = alcstr(tmp, len), runerr(306)); + return string(len, s); + } +end + + +"PaletteKey(w,p,s) - return key of closest color to s in palette p" + +function{0,1} PaletteKey(argv[argc]) + abstract { + return string + } + body { + wbp w; + int warg = 0, p; + C_integer n; + tended char *s; + long r, g, b; + + if (is:file(argv[0]) && (BlkLoc(argv[0])->file.status & Fs_Window)) { + w = (wbp)BlkLoc(argv[0])->file.fd; /* explicit window */ + warg = 1; + } + else if (is:file(kywd_xwin[XKey_Window]) && + (BlkLoc(kywd_xwin[XKey_Window])->file.status & Fs_Window)) + w = (wbp)BlkLoc(kywd_xwin[XKey_Window])->file.fd; /* &window */ + else + w = NULL; /* no window (but proceed anyway) */ + + if (argc - warg < 2) + runerr(103); + p = palnum(&argv[warg]); + if (p == -1) + runerr(103, argv[warg]); + if (p == 0) + fail; + + if (cnv:C_integer(argv[warg + 1], n)) { + if (w == NULL || (s = get_mutable_name(w, n)) == NULL) + fail; + } + else if (!cnv:C_string(argv[warg + 1], s)) + runerr(103, argv[warg + 1]); + + if (parsecolor(w, s, &r, &g, &b) == Succeeded) + return string(1, rgbkey(p, r / 65535.0, g / 65535.0, b / 65535.0)); + else + fail; + } +end + + +"Pattern(w,s) - sets the context fill pattern by string name" + +function{1} Pattern(argv[argc]) + abstract { + return file + } + body { + int warg = 0; + wbp w; + OptWindow(w); + + if (argc - warg == 0) + runerr(103, nulldesc); + + if (! cnv:string(argv[warg], argv[warg])) + runerr(103, nulldesc); + + switch (SetPattern(w, StrLoc(argv[warg]), StrLen(argv[warg]))) { + case Error: + runerr(0, argv[warg]); + case Failed: + fail; + } + + ReturnWindow; + } +end + + +"Pending(w,x[]) - produce a list of events pending on window" + +function{0,1} Pending(argv[argc]) + abstract { + return list + } + body { + wbp w; + int warg = 0; + wsp ws; + int i; + OptWindow(w); + + ws = w->window; + wsync(w); + + /* + * put additional arguments to Pending on the pending list in + * guaranteed consecutive order. + */ + for (i = warg; i < argc; i++) { + c_put(&(ws->listp), &argv[i]); + } + + /* + * retrieve any events that might be relevant before returning the + * pending queue. + */ + switch (pollevent()) { + case -1: runerr(141); + case 0: fail; + } + return ws->listp; + } +end + + + +"Pixel(w,x,y,width,height) - produce the contents of some pixels" + +function{3} Pixel(argv[argc]) + abstract { + return integer ++ string + } + body { + struct imgmem imem; + C_integer x, y, width, height; + wbp w; + int warg = 0, slen, r; + tended struct descrip lastval; + char strout[50]; + OptWindow(w); + + r = rectargs(w, argc, argv, warg, &x, &y, &width, &height); + if (r >= 0) + runerr(101, argv[r]); + + { + int i, j; + long rv; + wsp ws = w->window; + +#ifndef max +#define max(x,y) (((x)<(y))?(y):(x)) +#define min(x,y) (((x)>(y))?(y):(x)) +#endif + + imem.x = max(x,0); + imem.y = max(y,0); + imem.width = min(width, (int)ws->width - imem.x); + imem.height = min(height, (int)ws->height - imem.y); + + if (getpixel_init(w, &imem) == Failed) fail; + + lastval = emptystr; + + for (j=y; j < y + height; j++) { + for (i=x; i < x + width; i++) { + getpixel(w, i, j, &rv, strout, &imem); + slen = strlen(strout); + if (rv >= 0) { + int signal; + if (slen != StrLen(lastval) || + strncmp(strout, StrLoc(lastval), slen)) { + Protect((StrLoc(lastval) = alcstr(strout, slen)), runerr(0)); + StrLen(lastval) = slen; + } +#if COMPILER + suspend lastval; /* memory leak on vanquish */ +#else /* COMPILER */ + /* + * suspend, but free up imem if vanquished; RTL workaround + * Needs implementing under the compiler. + */ + r_args[0] = lastval; +#ifdef EventMon + if ((signal = interp(G_Fsusp, r_args)) != A_Resume) { +#else /* EventMon */ + if ((signal = interp(G_Csusp, r_args)) != A_Resume) { +#endif /* EventMon */ + tend = r_tend.previous; + getpixel_term(w, &imem); + VanquishReturn(signal); + } +#endif /* COMPILER */ + } + else { +#if COMPILER + suspend C_integer rv; /* memory leak on vanquish */ +#else /* COMPILER */ + int signal; + /* + * suspend, but free up imem if vanquished; RTL workaround + * Needs implementing under the compiler. + */ + r_args[0].dword = D_Integer; + r_args[0].vword.integr = rv; +#ifdef EventMon + if ((signal = interp(G_Fsusp, r_args)) != A_Resume) { +#else /* EventMon */ + if ((signal = interp(G_Csusp, r_args)) != A_Resume) { +#endif /* EventMon */ + tend = r_tend.previous; + getpixel_term(w, &imem); + VanquishReturn(signal); + } +#endif /* COMPILER */ + } + } + } + getpixel_term(w, &imem); + fail; + } + } +end + + +"QueryPointer(w) - produce mouse position" + +function{0,2} QueryPointer(w) + + declare { + XPoint xp; + } + abstract { + return integer + } + body { + pollevent(); + if (is:null(w)) { + query_rootpointer(&xp); + } + else { + if (!is:file(w) || !(BlkLoc(w)->file.status & Fs_Window)) + runerr(140, w); + query_pointer((wbp)BlkLoc(w)->file.fd, &xp); + } + suspend C_integer xp.x; + suspend C_integer xp.y; + fail; + } +end + + +"Raise(w) - raise w to the top of the window stack" + +function{1} Raise(argv[argc]) + abstract { + return file + } + body { + wbp w; + int warg = 0; + OptWindow(w); + raiseWindow(w); + ReturnWindow; + } +end + + +"ReadImage(w, s, x, y, p) - load image file" + +function{0,1} ReadImage(argv[argc]) + abstract { + return integer + } + body { + wbp w; + char filename[MaxPath + 1]; + tended char *tmp; + int status, warg = 0; + C_integer x, y; + int p, r; + struct imgdata imd; + OptWindow(w); + + if (argc - warg == 0) + runerr(103,nulldesc); + if (!cnv:C_string(argv[warg], tmp)) + runerr(103,argv[warg]); + + /* + * x and y must be integers; they default to the upper left pixel. + */ + if (argc - warg < 2) x = -w->context->dx; + else if (!def:C_integer(argv[warg+1], -w->context->dx, x)) + runerr(101, argv[warg+1]); + if (argc - warg < 3) y = -w->context->dy; + else if (!def:C_integer(argv[warg+2], -w->context->dy, y)) + runerr(101, argv[warg+2]); + + /* + * p is an optional palette name. + */ + if (argc - warg < 4 || is:null(argv[warg+3])) p = 0; + else { + p = palnum(&argv[warg+3]); + if (p == -1) + runerr(103, argv[warg+3]); + if (p == 0) + fail; + } + + x += w->context->dx; + y += w->context->dy; + strncpy(filename, tmp, MaxPath); /* copy to loc that won't move */ + filename[MaxPath] = '\0'; + + /* + * First try to read as a GIF file. + * If that doesn't work, try platform-dependent image reading code. + */ + r = readGIF(filename, p, &imd); + if (r == Succeeded) { + status = strimage(w, x, y, imd.width, imd.height, imd.paltbl, + imd.data, (word)imd.width * (word)imd.height, 0); + if (status < 0) + r = Error; + free((pointer)imd.paltbl); + free((pointer)imd.data); + } + else if (r == Failed) + r = readimage(w, filename, x, y, &status); + if (r == Error) + runerr(305); + if (r == Failed) + fail; + if (status == 0) + return nulldesc; + else + return C_integer (word)status; + } +end + + + +"WSync(w) - synchronize with server" + +function{1} WSync(w) + abstract { + return file++null + } + body { + wbp _w_; + + if (is:null(w)) { + _w_ = NULL; + } + else if (!is:file(w)) runerr(140,w); + else { + if (!(BlkLoc(w)->file.status & Fs_Window)) + runerr(140,w); + _w_ = (wbp)BlkLoc(w)->file.fd; + } + + wsync(_w_); + pollevent(); + return w; + } +end + + +"TextWidth(w,s) - compute text pixel width" + +function{1} TextWidth(argv[argc]) + abstract { + return integer + } + body { + wbp w; + int warg=0; + C_integer i; + OptWindow(w); + + if (warg == argc) runerr(103,nulldesc); + else if (!cnv:tmp_string(argv[warg],argv[warg])) + runerr(103,argv[warg]); + + i = TEXTWIDTH(w, StrLoc(argv[warg]), StrLen(argv[warg])); + return C_integer i; + } +end + + +"Uncouple(w) - uncouple window" + +function{1} Uncouple(w) + abstract { + return file + } + body { + wbp _w_; + if (!is:file(w)) runerr(140,w); + if ((BlkLoc(w)->file.status & Fs_Window) == 0) runerr(140,w); + if ((BlkLoc(w)->file.status & (Fs_Read|Fs_Write)) == 0) runerr(142,w); + _w_ = (wbp)BlkLoc(w)->file.fd; + BlkLoc(w)->file.status = Fs_Window; /* no longer open for read/write */ + free_binding(_w_); + return w; + } +end + +"WAttrib(argv[]) - read/write window attributes" + +function{*} WAttrib(argv[argc]) + abstract { + return file++string++integer + } + body { + wbp w, wsave; + word n; + tended struct descrip sbuf, sbuf2; + char answer[128]; + int pass, config = 0; + int warg = 0; + OptWindow(w); + + wsave = w; + /* + * Loop through the arguments. + */ + for (pass = 1; pass <= 2; pass++) { + w = wsave; + if (config && pass == 2) { + if (do_config(w, config) == Failed) fail; + } + for (n = warg; n < argc; n++) { + if (is:file(argv[n])) {/* Current argument is a file */ + /* + * Switch the current file to the file named by the + * current argument providing it is a file. argv[n] + * is made to be a empty string to avoid a special case. + */ + if (!(BlkLoc(argv[n])->file.status & Fs_Window)) + runerr(140,argv[n]); + w = (wbp)BlkLoc(argv[n])->file.fd; + if (config && pass == 2) { + if (do_config(w, config) == Failed) fail; + } + } + else { /* Current argument should be a string */ + /* + * In pass 1, a null argument is an error; failed attribute + * assignments are turned into null descriptors for pass 2 + * and are ignored. + */ + if (is:null(argv[n])) { + if (pass == 2) + continue; + else runerr(109, argv[n]); + } + /* + * If its an integer or real, it can't be a valid attribute. + */ + if (is:integer(argv[n]) || is:real(argv[n])) { + runerr(145, argv[n]); + } + /* + * Convert the argument to a string + */ + if (!cnv:tmp_string(argv[n], sbuf)) + runerr(109, argv[n]); + /* + * Various parts of the code can't handle long attributes. + * (ugh.) + */ + if (StrLen(sbuf) > 127) + runerr(145, argv[n]); + /* + * Read/write the attribute + */ + if (pass == 1) { + char *tmp_s = StrLoc(sbuf); + char *tmp_s2 = StrLoc(sbuf) + StrLen(sbuf); + for ( ; tmp_s < tmp_s2; tmp_s++) + if (*tmp_s == '=') break; + if (tmp_s < tmp_s2) { + /* + * pass 1: perform attribute assignments + */ + switch (wattrib(w, StrLoc(sbuf), StrLen(sbuf), + &sbuf2, answer)) { + case Failed: + /* + * Mark the attribute so we don't produce a result + */ + argv[n] = nulldesc; + continue; + case Error: runerr(0, argv[n]); + } + if (StrLen(sbuf) > 4) { + if (!strncmp(StrLoc(sbuf), "pos=", 4)) config |= 1; + if (StrLen(sbuf) > 5) { + if (!strncmp(StrLoc(sbuf), "posx=", 5)) config |= 1; + if (!strncmp(StrLoc(sbuf), "posy=", 5)) config |= 1; + if (!strncmp(StrLoc(sbuf), "rows=", 5)) config |= 2; + if (!strncmp(StrLoc(sbuf), "size=", 5)) config |= 2; + if (StrLen(sbuf) > 6) { + if (!strncmp(StrLoc(sbuf), "width=", 6)) + config |= 2; + if (!strncmp(StrLoc(sbuf), "lines=", 6)) + config |= 2; + if (StrLen(sbuf) > 7) { + if (!strncmp(StrLoc(sbuf), "height=", 7)) + config |= 2; + if (!strncmp(StrLoc(sbuf), "resize=", 7)) + config |= 2; + if (StrLen(sbuf) > 8) { + if (!strncmp(StrLoc(sbuf), "columns=", 8)) + config |= 2; + if (StrLen(sbuf) > 9) { + if (!strncmp(StrLoc(sbuf), + "geometry=", 9)) + config |= 3; + } + } + } + } + } + } + } + } + /* + * pass 2: perform attribute queries, suspend result(s) + */ + else if (pass==2) { + char *stmp, *stmp2; + /* + * Turn assignments into queries. + */ + for( stmp = StrLoc(sbuf), + stmp2 = stmp + StrLen(sbuf); stmp < stmp2; stmp++) + if (*stmp == '=') break; + if (stmp < stmp2) + StrLen(sbuf) = stmp - StrLoc(sbuf); + + switch (wattrib(w, StrLoc(sbuf), StrLen(sbuf), + &sbuf2, answer)) { + case Failed: continue; + case Error: runerr(0, argv[n]); + } + if (is:string(sbuf2)) + Protect(StrLoc(sbuf2) = alcstr(StrLoc(sbuf2),StrLen(sbuf2)), runerr(0)); + suspend sbuf2; + } + } + } + } + fail; + } +end + + +"WDefault(w,program,option) - get a default value from the environment" + +function{0,1} WDefault(argv[argc]) + abstract { + return string + } + body { + wbp w; + int warg = 0; + long l; + tended char *prog, *opt; + char sbuf1[MaxCvtLen]; + OptWindow(w); + + if (argc-warg < 2) + runerr(103); + if (!cnv:C_string(argv[warg],prog)) + runerr(103,argv[warg]); + if (!cnv:C_string(argv[warg+1],opt)) + runerr(103,argv[warg+1]); + + if (getdefault(w, prog, opt, sbuf1) == Failed) fail; + l = strlen(sbuf1); + Protect(prog = alcstr(sbuf1,l),runerr(0)); + return string(l,prog); + } +end + + +"WFlush(w) - flush all output to window w" + +function{1} WFlush(argv[argc]) + abstract { + return file + } + body { + wbp w; + int warg = 0; + OptWindow(w); + wflush(w); + ReturnWindow; + } +end + + +"WriteImage(w,filename,x,y,width,height) - write an image to a file" + +function{0,1} WriteImage(argv[argc]) + abstract { + return file + } + body { + wbp w; + int r; + C_integer x, y, width, height, warg = 0; + tended char *s; + OptWindow(w); + + if (argc - warg == 0) + runerr(103, nulldesc); + else if (!cnv:C_string(argv[warg], s)) + runerr(103, argv[warg]); + + r = rectargs(w, argc, argv, warg + 1, &x, &y, &width, &height); + if (r >= 0) + runerr(101, argv[r]); + + /* + * clip image to window, and fail if zero-sized. + * (the casts to long are necessary to avoid unsigned comparison.) + */ + if (x < 0) { + width += x; + x = 0; + } + if (y < 0) { + height += y; + y = 0; + } + if (x + width > (long) w->window->width) + width = w->window->width - x; + if (y + height > (long) w->window->height) + height = w->window->height - y; + if (width <= 0 || height <= 0) + fail; + + /* + * try platform-dependent code first; it will reject the call + * if the file name s does not specify a platform-dependent format. + */ + r = dumpimage(w, s, x, y, width, height); + if (r == NoCvt) + r = writeGIF(w, s, x, y, width, height); + if (r != Succeeded) + fail; + ReturnWindow; + } +end + +#ifdef WinExtns + +"WinPlayMedia(w,x[]) - play a multimedia resource" + +function{0,1} WinPlayMedia(argv[argc]) + abstract { + return null + } + body { + wbp w; + tended char *tmp; + int warg = 0; + int i; + wsp ws; + word n; + OptWindow(w); + + ws = w->window; + for (n = warg; n < argc; n++) { + if (!cnv:C_string(argv[n], tmp)) + runerr(103,argv[warg]); + if (playmedia(w, tmp) == Failed) fail; + } + return nulldesc; + } +end + + + +/* + * Simple Windows-native pushbutton + */ +"WinButton(w, s, x, y, wd, ht) - install a pushbutton with label s on window w" + +function{0,1} WinButton(argv[argc]) + abstract { + return file + } + body { + wbp w; + wsp ws; + int i, ii, i2, r, total = 0; + C_integer x, y, width, height, warg = 0; + tended char *s, *s2; + tended struct descrip d; + tended struct b_list *hp; + OptWindow(w); + ws = w->window; + if (warg == argc) fail; + if (!cnv:C_string(argv[warg], s)) runerr(103, argv[warg]); + warg++; + /* + * look for an existing button with this id. + */ + for(i = 0; i < ws->nChildren; i++) { + if (!strcmp(s, ws->child[i].id) && ws->child[i].type==CHILD_BUTTON) + break; + } + /* + * create a new button if none is found + */ + if (i == ws->nChildren) { + ws->nChildren++; + ws->child = realloc(ws->child, + ws->nChildren * sizeof(childcontrol)); + makebutton(ws, ws->child + i, s); + } + + if (warg >= argc) x = 0; + else if (!def:C_integer(argv[warg], 0, x)) + runerr(101, argv[warg]); + warg++; + if (warg >= argc) y = 0; + else if (!def:C_integer(argv[warg], 0, y)) + runerr(101, argv[warg]); + warg++; + /* + * default width is width of text in system font + 2 chars + */ + ii = sysTextWidth(w, s, strlen(s)) + 10; + if (warg >= argc) width = i2; + else if (!def:C_integer(argv[warg], i2, width)) + runerr(101, argv[warg]); + warg++; + /* + * default height is height of text in system font * 7/4 + */ + i2 = sysFontHeight(w) * 7 / 4; + if (warg >= argc) height = i2; + else if (!def:C_integer(argv[warg], i2, height)) + runerr(101, argv[warg]); + + movechild(ws->child + i, x, y, width, height); + ReturnWindow; + } +end + +"WinScrollBar(w, s, i1, i2, i3, x, y, wd, ht) - install a scrollbar" + +function{0,1} WinScrollBar(argv[argc]) + abstract { + return file + } + body { + wbp w; + wsp ws; + C_integer x, y, width, height, warg = 0, i1, i2, i3, i, ii; + tended char *s, *s2; + tended struct descrip d; + tended struct b_list *hp; + + OptWindow(w); + ws = w->window; + if (warg == argc) fail; + if (!cnv:C_string(argv[warg], s)) runerr(103, argv[warg]); + warg++; + /* + * look for an existing scrollbar with this id. + */ + for(i = 0; i < ws->nChildren; i++) { + if (!strcmp(s, ws->child[i].id) && ws->child[i].type==CHILD_EDIT) + break; + } + /* + * i1, the min of the scrollbar range, defaults to 0 + */ + if (warg >= argc) i1 = 0; + else if (!def:C_integer(argv[warg], 0, i1)) runerr(101, argv[warg]); + warg++; + /* + * i2, the max of the scrollbar range, defaults to 100 + */ + if (warg >= argc) i2 = 100; + else if (!def:C_integer(argv[warg], 100, i2)) runerr(101, argv[warg]); + warg++; + /* + * create a new scrollbar at end of array if none was found + */ + if (i == ws->nChildren) { + ws->nChildren++; + ws->child = realloc(ws->child, ws->nChildren * sizeof(childcontrol)); + makescrollbar(ws, ws->child + i, s, i1, i2); + } + /* + * i3, the interval, defaults to 10 + */ + if (warg >= argc) i3 = 10; + else if (!def:C_integer(argv[warg], 10, i3)) + runerr(101, argv[warg]); + warg++; + /* + * x defaults to the right edge of the window - system scrollbar width + */ + ii = ws->width - sysScrollWidth(); + if (warg >= argc) x = ii; + else if (!def:C_integer(argv[warg], ii, x)) + runerr(101, argv[warg]); + warg++; + /* + * y defaults to 0 + */ + if (warg >= argc) y = 0; + else if (!def:C_integer(argv[warg], 0, y)) + runerr(101, argv[warg]); + warg++; + /* + * width defaults to system scrollbar width + */ + ii = sysScrollWidth(); + if (warg >= argc) width = ii; + else if (!def:C_integer(argv[warg], ii, width)) + runerr(101, argv[warg]); + warg++; + /* + * height defaults to height of the client window + */ + if (warg >= argc) height = ws->height; + else if (!def:C_integer(argv[warg], ws->height, height)) + runerr(101, argv[warg]); + + movechild(ws->child + i, x, y, width, height); + ReturnWindow; + } +end + +/* + * Simple Windows-native menu bar + */ +"WinMenuBar(w,L1,L2,...) - install a set of top-level menus" + +function{0,1} WinMenuBar(argv[argc]) + abstract { + return file + } + body { + wbp w; + wsp ws; + int i, total = 0; + C_integer x, y, warg = 0; + tended char *s; + tended struct descrip d; + OptWindow(w); + ws = w->window; + + if (warg == argc) fail; + for (i = warg; i < argc; i++) { + if (!is:list(argv[i])) runerr(108, argv[i]); + total += BlkLoc(argv[i])->list.size; + } + /* + * free up memory for the old menu map + */ + if (ws->nmMapElems) { + for (i=0; i<ws->nmMapElems; i++) free(ws->menuMap[i]); + free(ws->menuMap); + } + ws->menuMap = (char **)calloc(total, sizeof(char *)); + + if (nativemenubar(w, total, argc, argv, warg, &d) == Error) + runerr(103, d); + ReturnWindow; + } +end + +/* + * Windows-native editor + */ +"WinEditRegion(w, s, s2, x, y, wd, ht) = install an edit box with label s" + +function{0, 1} WinEditRegion(argv[argc]) + abstract { + return file ++ string + } + body { + wbp w; + wsp ws; + tended char *s, *s2; + C_integer i, x, y, width, height, warg = 0; + OptWindow(w); + ws = w->window; + if (warg == argc) fail; + if (!cnv:C_string(argv[warg], s)) + runerr(103, argv[warg]); + warg++; + /* + * look for an existing edit region with this id. + */ + for(i = 0; i < ws->nChildren; i++) { + if (!strcmp(s, ws->child[i].id) && ws->child[i].type==CHILD_EDIT) + break; + } + /* + * create a new edit region if none is found + */ + if (i == ws->nChildren) { + ws->nChildren++; + ws->child = realloc(ws->child, ws->nChildren * sizeof(childcontrol)); + makeeditregion(w, ws->child + i, s); + } + /* + * Invoked with no value, return the current value of an existing + * edit region (entire buffer is one gigantic string). + */ + else if (warg == argc) { + geteditregion(ws->child + i, &result); + return result; + } + /* + * Assign a value (s2 string contents) or perform editing command + */ + if (is:null(argv[warg])) s2 = NULL; + else if (!cnv:C_string(argv[warg], s2)) runerr(103, argv[warg]); + warg++; + + if (warg >= argc) x = 0; + else if (!def:C_integer(argv[warg], 0, x)) runerr(101, argv[warg]); + warg++; + if (warg >= argc) y = 0; + else if (!def:C_integer(argv[warg], 0, y)) runerr(101, argv[warg]); + warg++; + if (warg >= argc) width = ws->width - x; + else if (!def:C_integer(argv[warg], ws->width -x, width)) + runerr(101, argv[warg]); + warg++; + if (warg >= argc) height = ws->height - y; + else if (!def:C_integer(argv[warg], ws->height - y, height)) + runerr(101, argv[warg]); + + if (s2 && !strcmp("!clear", s2)) { + cleareditregion(ws->child + i); + s2 = NULL; + } + else if (s2 && !strcmp("!copy", s2)) { + copyeditregion(ws->child + i); + s2 = NULL; + } + else if (s2 && !strcmp("!cut", s2)) { + cuteditregion(ws->child + i); + s2 = NULL; + } + else if (s2 && !strcmp("!paste", s2)) { + pasteeditregion(ws->child + i); + s2 = NULL; + } + else if (s2 && !strcmp("!undo", s2)) { + if (undoeditregion(ws->child + i) == Failed) fail; + s2 = NULL; + } + else if (s2 && !strncmp("!modified=", s2, 10)) { + setmodifiededitregion(ws->child + i, atoi(s2+10)); + s2 = NULL; + } + else if (s2 && !strcmp("!modified", s2)) { + if (modifiededitregion(ws->child + i) == Failed) fail; + s2 = NULL; + } + else if (s2 && !strncmp("!font=", s2, 6)) { + if (setchildfont(ws->child + i, s2 + 6) == Succeeded) { + ReturnWindow; + } + else fail; + } + else if (s2 && !strcmp("!setsel", s2)) { + setchildselection(ws, ws->child + i, x, y); + ReturnWindow; + } + + if (s2) { + seteditregion(ws->child + i, s2); + } + movechild(ws->child + i, x, y, width, height); + setfocusonchild(ws, ws->child + i, width, height); + ReturnWindow; + } +end + + +/* + * common dialog functions + */ + +"WinColorDialog(w,s) - choose a color for a window's context" + +function{0,1} WinColorDialog(argv[argc]) + abstract { + return string + } + body { + wbp w; + C_integer x, y, width, height, warg = 0; + long r, g, b; + tended char *s; + char buf[64], *tmp = buf; + OptWindow(w); + + if (warg < argc) { + if (is:null(argv[warg])) s = "white"; + else if (!cnv:C_string(argv[warg], s)) runerr(103, argv[warg]); + } + else s = "white"; + if (parsecolor(w, s, &r, &g, &b) == Failed) fail; + + if (nativecolordialog(w, r, g, b, buf) == NULL) fail; + StrLoc(result) = alcstr(buf, strlen(buf)); + StrLen(result) = strlen(buf); + return result; + } +end + +"WinFontDialog(w,s) - choose a font for a window's context" + +function{0,1} WinFontDialog(argv[argc]) + abstract { + return string + } + body { + wbp w; + int r; + C_integer x, y, width, height, warg = 0, fheight; + int flags; + tended char *s; + char buf[64], *tmp = buf; + OptWindow(w); + + if (warg < argc) { + if (is:null(argv[warg])) s = "fixed"; + else if (!cnv:C_string(argv[warg], s)) runerr(103, argv[warg]); + } + else s = "fixed"; + + parsefont(s, buf, &flags, &fheight); + + if (nativefontdialog(w, buf, flags, fheight) == Failed) fail; + StrLoc(result) = alcstr(buf, strlen(buf)); + StrLen(result) = strlen(buf); + return result; + } +end + + +"WinOpenDialog(w,s1,s2,i,s3,j) - choose a file to open" + +function{0,1} WinOpenDialog(argv[argc]) + abstract { + return string + } + body { + wbp w; + int len, slen; + C_integer i, j, x, y, width, height, warg = 0; + char buf2[64], buf3[256], chReplace; + char *tmpstr; + tended char *s1, *s2, *s3; + OptWindow(w); + + if (warg >= argc || is:null(argv[warg])) { + s1 = "Open:"; + } + else if (!cnv:C_string(argv[warg], s1)) { + runerr(103, argv[warg]); + } + warg++; + + if (warg >= argc || is:null(argv[warg])) { + s2 = ""; + } + else if (!cnv:C_string(argv[warg], s2)) { + runerr(103, argv[warg]); + } + warg++; + + if (warg >= argc) { + i = 50; + } + else if (!def:C_integer(argv[warg], 50, i)) { + runerr(101, argv[warg]); + } + warg++; + + if (warg >= argc || is:null(argv[warg])) { + strcpy(buf3,"All Files(*.*)|*.*|"); + s3 = buf3; + } + else if (!cnv:C_string(argv[warg], s3)) { + runerr(103, argv[warg]); + } + else { + strncpy(buf3, s3, 255); + buf3[255] = '\0'; + s3 = buf3; + } + chReplace = s3[strlen(s3)-1]; + slen = strlen(s3); + for(j=0; j < slen; j++) + if(s3[j] == chReplace) s3[j] = '\0'; + warg++; + + if (warg >= argc) { + j = 1; + } + else if (!def:C_integer(argv[warg], 1, j)) { + runerr(101, argv[warg]); + } + warg++; + + if ((tmpstr = nativeopendialog(w,s1,s2,s3,i,j)) == NULL) fail; + len = strlen(tmpstr); + StrLoc(result) = alcstr(tmpstr, len); + StrLen(result) = len; + return result; + } +end + + +"WinSelectDialog(w, s1, buttons) - select from a set of choices" + +function{0,1} WinSelectDialog(argv[argc]) + abstract { + return string + } + body { + wbp w; + C_integer i, j, warg = 0, len; + tended char *s1; + char *s2 = NULL, *tmpstr; + tended struct descrip d; + tended struct b_list *hp; + int lsize; + OptWindow(w); + + /* + * look for list of text for the message. concatenate text strings. + */ + if (warg == argc) + fail; + if (!is:list(argv[warg])) runerr(108, argv[warg]); + hp = (struct b_list *)BlkLoc(argv[warg]); + lsize = hp->size; + for(i=0; i < lsize; i++) { + c_get(hp, &d); + if (!cnv:C_string(d, s1)) runerr(103, d); + len += strlen(s1)+2; + if (s2) { + s2 = realloc(s2, len); + if (!s2) fail; + strcat(s2, "\r\n"); + strcat(s2, s1); + } + else s2 = salloc(s1); + c_put(&(argv[warg]), &d); + } + warg++; + + if (warg >= argc) { + hp = NULL; + } + else { + if (!is:list(argv[warg])) runerr(108, argv[warg]); + hp = (struct b_list *)BlkLoc(argv[warg]); + lsize = hp->size; + for(i=0; i < lsize; i++) { + c_get(hp, &d); + if (!cnv:C_string(d, s1)) runerr(103, d); + c_put(&(argv[warg]), &d); + } + } + tmpstr = nativeselectdialog(w, hp, s2); + if (tmpstr == NULL) fail; + free(s2); + len = strlen(tmpstr); + StrLoc(result) = alcstr(tmpstr, len); + StrLen(result) = len; + return result; + } +end + +"WinSaveDialog(w,s1,s2,i,s3,j) - choose a file to save" + +function{0,1} WinSaveDialog(argv[argc]) + abstract { + return string + } + body { + wbp w; + int len; + C_integer i, j, warg = 0, slen; + char buf3[128], chReplace; + tended char *tmpstr; + tended char *s1, *s2, *s3; + OptWindow(w); + + if (warg >= argc || is:null(argv[warg])) { + s1 = "Save:"; + } + else if (!cnv:C_string(argv[warg], s1)) { + runerr(103, argv[warg]); + } + warg++; + + if (warg >= argc || is:null(argv[warg])) { + s2 = ""; + } + else if (!cnv:C_string(argv[warg], s2)) { + runerr(103, argv[warg]); + } + warg++; + + if (warg >= argc) { + i = 50; + } + else if (!def:C_integer(argv[warg], 50, i)) { + runerr(101, argv[warg]); + } + warg++; + + if (warg >= argc || is:null(argv[warg])) { + strcpy(buf3,"All Files(*.*)|*.*|"); + s3 = buf3; + } + else if (!cnv:C_string(argv[warg], s3)) { + runerr(103, argv[warg]); + } + else { + strcpy(buf3, s3); + s3 = buf3; + } + chReplace = s3[strlen(s3)-1]; + slen = strlen(s3); + for(j=0; j < slen; j++) + if(s3[j] == chReplace) s3[j] = '\0'; + warg++; + + if (warg >= argc) { + j = 1; + } + else if (!def:C_integer(argv[warg], 1, j)) { + runerr(101, argv[warg]); + } + warg++; + if ((tmpstr = nativesavedialog(w, s1, s2, s3, i, j)) == NULL) fail; + len = strlen(tmpstr); + StrLoc(result) = alcstr(tmpstr, len); + StrLen(result) = len; + return result; + } +end +#endif /* WinExtns */ + +#endif /* Graphics */ diff --git a/src/runtime/imain.r b/src/runtime/imain.r new file mode 100644 index 0000000..424a4f6 --- /dev/null +++ b/src/runtime/imain.r @@ -0,0 +1,384 @@ +#if !COMPILER +/* + * File: imain.r + * Interpreter main program, argument handling, and such. + * Contents: main, iconx, ixopts, resolve + */ + +#include "../h/version.h" +#include "../h/header.h" +#include "../h/opdefs.h" + +static int iconx(int argc, char *argv[]); +static void ixopts(int argc, char *argv[], int *ip); + +/* + * Initial interpreter entry point (for all remaining platforms). + */ +int main(int argc, char *argv[]) { + return iconx(argc, argv); +} + +/* + * Initial icode sequence. This is used to invoke the main procedure + * with one argument. If main returns, the Op_Quit is executed. + */ +int iconx(int argc, char *argv[]) { + int i, slen; + static word istart[4]; + static int mterm = Op_Quit; + + #ifdef MultiThread + /* + * Look for MultiThread programming environment in which to execute + * this program, specified by MTENV environment variable. + */ + { + char *p; + char **new_argv; + int i, j = 1, k = 1; + if ((p = getenv("MTENV")) != NULL) { + for(i=0;p[i];i++) + if (p[i] == ' ') + j++; + new_argv = malloc((argc + j) * sizeof(char *)); + new_argv[0] = argv[0]; + for (i=0; p[i]; ) { + new_argv[k++] = p+i; + while (p[i] && (p[i] != ' ')) + i++; + if (p[i] == ' ') + p[i++] = '\0'; + } + for(i=1;i<argc;i++) + new_argv[k++] = argv[i]; + argc += j; + argv = new_argv; + } + } + #endif /* MultiThread */ + + ipc.opnd = NULL; + + #ifdef LoadFunc + /* + * Append to FPATH the bin directory from which iconx was executed. + */ + { + char *p, *q, buf[1000]; + p = getenv("FPATH"); + q = relfile(argv[0], "/.."); + sprintf(buf, "FPATH=%s %s", (p ? p : "."), (q ? q : ".")); + putenv(buf); + } + #endif /* LoadFunc */ + + /* + * Setup Icon interface. It's done this way to avoid duplication + * of code, since the same thing has to be done if calling Icon + * is enabled. + */ + + ixopts(argc, argv, &i); + + if (i < 0) { + argc++; + argv--; + i++; + } + + while (i--) { /* skip option arguments */ + argc--; + argv++; + } + + if (argc <= 1) + error(NULL, "no icode file specified"); + + /* + * Call icon_init with the name of the icode file to execute. [[I?]] + */ + icon_init(argv[1], &argc, argv); + + /* + * Point sp at word after b_coexpr block for &main, point ipc at initial + * icode segment, and clear the gfp. + */ + + stackend = stack + mstksize/WordSize; + sp = stack + Wsizeof(struct b_coexpr); + + ipc.opnd = istart; + *ipc.op++ = Op_Noop; /* aligns Invoke's operand */ /* [[I?]] */ + *ipc.op++ = Op_Invoke; /* [[I?]] */ + *ipc.opnd++ = 1; + *ipc.op = Op_Quit; + ipc.opnd = istart; + + gfp = 0; + + /* + * Set up expression frame marker to contain execution of the + * main procedure. If failure occurs in this context, control + * is transferred to mterm, the address of an Op_Quit. + */ + efp = (struct ef_marker *)(sp); + efp->ef_failure.op = &mterm; + efp->ef_gfp = 0; + efp->ef_efp = 0; + efp->ef_ilevel = 1; + sp += Wsizeof(*efp) - 1; + + pfp = 0; + ilevel = 0; + + /* + * We have already loaded the + * icode and initialized things, so it's time to just push main(), + * build an Icon list for the rest of the arguments, and called + * interp on a "invoke 1" bytecode. + */ + + /* + * The first global variable holds the value of "main". If it + * is not of type procedure, this is noted as run-time error 117. + * Otherwise, this value is pushed on the stack. + */ + if (globals[0].dword != D_Proc) + fatalerr(117, NULL); + PushDesc(globals[0]); + PushNull; + glbl_argp = (dptr)(sp - 1); + + /* + * If main() has a parameter, it is to be invoked with one argument, a list + * of the command line arguments. The command line arguments are pushed + * on the stack as a series of descriptors and Ollist is called to create + * the list. The null descriptor first pushed serves as Arg0 for + * Ollist and receives the result of the computation. + */ + if (((struct b_proc *)BlkLoc(globals[0]))->nparam > 0) { + for (i = 2; i < argc; i++) { + char *tmp; + slen = strlen(argv[i]); + PushVal(slen); + Protect(tmp=alcstr(argv[i],(word)slen), fatalerr(0,NULL)); + PushAVal(tmp); + } + + Ollist(argc - 2, glbl_argp); + } + + sp = (word *)glbl_argp + 1; + glbl_argp = 0; + ixinited = 1; /* post fact that iconx is initialized */ + + /* + * Start things rolling by calling interp. This call to interp + * returns only if an Op_Quit is executed. If this happens, + * c_exit() is called to wrap things up. + */ + interp(0,(dptr)NULL); + c_exit(EXIT_SUCCESS); + return 0; +} + +/* + * ixopts - handle interpreter command line options. + */ +void ixopts(argc,argv,ip) +int argc; +char **argv; +int *ip; + { + + #ifdef TallyOpt + extern int tallyopt; + #endif /* TallyOpt */ + + *ip = 0; /* number of arguments processed */ + + #if MSWIN + /* + * if we didn't start with iconx.exe, backup one + * so that our icode filename is argv[1]. + */ + { + char tmp[256], *t2, *basename, *ext; + int len = 0; + strcpy(tmp, argv[0]); + for (t2 = tmp; *t2; t2++) { + switch (*t2) { + case ':': + case '/': + case '\\': + basename = t2 + 1; + ext = NULL; + break; + case '.': + ext = t2; + break; + default: + *t2 = tolower(*t2); + break; + } + } + /* If present, cut the ".exe" extension. */ + if (ext != NULL && !strcmp(ext, ".exe")) + *ext = 0; + + /* + * if argv[0] is not a reference to our interpreter, take it as the + * name of the icode file, and back up for it. + */ + if (strcmp(basename, "iconx")) { + argv--; + argc++; + (*ip)--; + } + } + #endif /* MSWIN */ + + /* + * Handle command line options. + */ + while ( argv[1] != 0 && *argv[1] == '-' ) { + + switch ( *(argv[1]+1) ) { + + #ifdef TallyOpt + /* + * Set tallying flag if -T option given + */ + case 'T': + tallyopt = 1; + break; + #endif /* TallyOpt */ + + /* + * Announce version on stderr if -V is given. + */ + case 'V': + fprintf(stderr, "%s (%s, %s)\n", Version, Config, __DATE__); + if (!argv[2]) + exit(0); + break; + + } + + argc--; + (*ip)++; + argv++; + } + } + +/* + * resolve - perform various fix-ups on the data read from the icode + * file. + */ +#ifdef MultiThread + void resolve(pstate) + struct progstate *pstate; +#else /* MultiThread */ + void resolve() +#endif /* MultiThread */ + + { + register word i, j; + register struct b_proc *pp; + register dptr dp; + extern int Omkrec(); + #ifdef MultiThread + register struct progstate *savedstate; + #endif /* MultiThread */ + + #ifdef MultiThread + savedstate = curpstate; + if (pstate) curpstate = pstate; + #endif /* MultiThread */ + + /* + * Relocate the names of the global variables. + */ + for (dp = gnames; dp < egnames; dp++) + StrLoc(*dp) = strcons + (uword)StrLoc(*dp); + + /* + * Scan the global variable array for procedures and fill in appropriate + * addresses. + */ + for (j = 0; j < n_globals; j++) { + + if (globals[j].dword != D_Proc) + continue; + + /* + * The second word of the descriptor for procedure variables tells + * where the procedure is. Negative values are used for built-in + * procedures and positive values are used for Icon procedures. + */ + i = IntVal(globals[j]); + + if (i < 0) { + /* + * globals[j] points to a built-in function; call (bi_)strprc + * to look it up by name in the interpreter's table of built-in + * functions. + */ + if((BlkLoc(globals[j])= (union block *)bi_strprc(gnames+j,0)) == NULL) + globals[j] = nulldesc; /* undefined, set to &null */ + } + else { + + /* + * globals[j] points to an Icon procedure or a record; i is an offset + * to location of the procedure block in the code section. Point + * pp at the block and replace BlkLoc(globals[j]). + */ + pp = (struct b_proc *)(code + i); + BlkLoc(globals[j]) = (union block *)pp; + + /* + * Relocate the address of the name of the procedure. + */ + StrLoc(pp->pname) = strcons + (uword)StrLoc(pp->pname); + + if (pp->ndynam == -2) { + /* + * This procedure is a record constructor. Make its entry point + * be the entry point of Omkrec(). + */ + pp->entryp.ccode = Omkrec; + + /* + * Initialize field names + */ + for (i = 0; i < pp->nfields; i++) + StrLoc(pp->lnames[i]) = strcons + (uword)StrLoc(pp->lnames[i]); + + } + else { + /* + * This is an Icon procedure. Relocate the entry point and + * the names of the parameters, locals, and static variables. + */ + pp->entryp.icode = code + pp->entryp.ioff; + for (i = 0; i < abs((int)pp->nparam)+pp->ndynam+pp->nstatic; i++) + StrLoc(pp->lnames[i]) = strcons + (uword)StrLoc(pp->lnames[i]); + } + } + } + + /* + * Relocate the names of the fields. + */ + + for (dp = fnames; dp < efnames; dp++) + StrLoc(*dp) = strcons + (uword)StrLoc(*dp); + + #ifdef MultiThread + curpstate = savedstate; + #endif /* MultiThread */ + } + +#endif /* !COMPILER */ diff --git a/src/runtime/imisc.r b/src/runtime/imisc.r new file mode 100644 index 0000000..cde8a90 --- /dev/null +++ b/src/runtime/imisc.r @@ -0,0 +1,357 @@ +#if !COMPILER +/* + * File: imisc.r + * Contents: field, mkrec, limit, llist, bscan, escan + */ + +/* + * x.y - access field y of record x. + */ + +LibDcl(field,2,".") + { + register word fnum; + register struct b_record *rp; + register dptr dp; + +#ifdef MultiThread + register union block *bptr; +#else /* MultiThread */ + extern int *ftabp; + #ifdef FieldTableCompression + extern int *fo; + extern unsigned char *focp; + extern short *fosp; + extern char *bm; + #endif /* FieldTableCompression */ + extern word *records; +#endif /* MultiThread */ + + Deref(Arg1); + + /* + * Arg1 must be a record and Arg2 must be a field number. + */ + if (!is:record(Arg1)) + RunErr(107, &Arg1); + if (IntVal(Arg2) == -1) /* if was known bad at ilink time */ + RunErr(207, &Arg1); /* was warning then, now it's fatal */ + + /* + * Map the field number into a field number for the record x. + */ + rp = (struct b_record *) BlkLoc(Arg1); + +#ifdef MultiThread + bptr = rp->recdesc; + if (!InRange(curpstate->Records, bptr, curpstate->Ftabp)) { + int i; + int nfields = bptr->proc.nfields; + /* + * Look up the field number by a brute force search through + * the record constructor's field names. + */ + Arg0 = fnames[IntVal(Arg2)]; + fprintf(stderr,"looking up interprogram field %.*s\n", StrLen(Arg0), + StrLoc(Arg0)); + for (i=0;i<nfields;i++){ + if ((StrLen(Arg0) == StrLen(bptr->proc.lnames[i])) && + !strncmp(StrLoc(Arg0), StrLoc(bptr->proc.lnames[i]),StrLen(Arg0))) + break; + } + if (i<nfields) fnum = i; + else fnum = -1; + } + else +#endif /* MultiThread */ + +#ifdef FieldTableCompression +#define FO(i) ((foffwidth==1)?focp[i]:((foffwidth==2)?fosp[i]:fo[i])) +#define FTAB(i) ((ftabwidth==1)?ftabcp[i]:((ftabwidth==2)?ftabsp[i]:ftabp[i])) +#else /* FieldTableCompression */ +#define FO(i) fo[i] +#define FTAB(i) ftabp[i] +#endif /* FieldTableCompression */ + +#ifdef FieldTableCompression + fnum = FTAB(FO(IntVal(Arg2)) + (rp->recdesc->proc.recnum - 1)); +#else /* FieldTableCompression */ + fnum = FTAB(IntVal(Arg2) * *records + rp->recdesc->proc.recnum - 1); +#endif /* FieldTableCompression */ + + /* + * If fnum < 0, x doesn't contain the specified field. + */ + +#ifdef FieldTableCompression +{ + int bytes, index; + unsigned char this_bit = 0200; + + bytes = *records >> 3; + if ((*records & 07) != 0) + bytes++; + index = IntVal(Arg2) * bytes + (rp->recdesc->proc.recnum - 1) / 8; + this_bit = this_bit >> (rp->recdesc->proc.recnum - 1) % 8; + if ((bm[index] | this_bit) != bm[index]) + RunErr(207, &Arg1); +} + + if (ftabwidth == 1) { + if (fnum == 255) + RunErr(207, &Arg1); + } + else +#endif /* FieldTableCompression */ + if (fnum < 0) + RunErr(207, &Arg1); + + EVValD(&Arg1, E_Rref); + EVVal(fnum + 1, E_Rsub); + + /* + * Return a pointer to the descriptor for the appropriate field. + */ + dp = &rp->fields[fnum]; + Arg0.dword = D_Var + ((word *)dp - (word *)rp); + VarLoc(Arg0) = (dptr)rp; + Return; + } + + +/* + * mkrec - create a record. + */ + +LibDcl(mkrec,-1,"mkrec") + { + register int i; + register struct b_proc *bp; + register struct b_record *rp; + + /* + * Be sure that call is from a procedure. + */ + + /* + * Get a pointer to the record constructor procedure and allocate + * a record with the appropriate number of fields. + */ + bp = (struct b_proc *) BlkLoc(Arg0); + Protect(rp = alcrecd((int)bp->nfields, (union block *)bp), RunErr(0,NULL)); + + /* + * Set all fields in the new record to null value. + */ + for (i = (int)bp->nfields; i > nargs; i--) + rp->fields[i-1] = nulldesc; + + /* + * Assign each argument value to a record element and dereference it. + */ + for ( ; i > 0; i--) { + rp->fields[i-1] = cargp[i]; /* Arg(i), expanded to avoid CLCC bug on Sun*/ + Deref(rp->fields[i-1]); + } + + ArgType(0) = D_Record; + Arg0.vword.bptr = (union block *)rp; + EVValD(&Arg0, E_Rcreate); + Return; + } + +/* + * limit - explicit limitation initialization. + */ + + +LibDcl(limit,2,"\\") + { + + C_integer tmp; + + /* + * The limit is both passed and returned in Arg0. The limit must + * be an integer. If the limit is 0, the expression being evaluated + * fails. If the limit is < 0, it is an error. Note that the + * result produced by limit is ultimately picked up by the lsusp + * function. + */ + Deref(Arg0); + + if (!cnv:C_integer(Arg0,tmp)) + RunErr(101, &Arg0); + MakeInt(tmp,&Arg0); + + if (IntVal(Arg0) < 0) + RunErr(205, &Arg0); + if (IntVal(Arg0) == 0) + Fail; + Return; + } + +/* + * bscan - set &subject and &pos upon entry to a scanning expression. + * + * Arguments are: + * Arg0 - new value for &subject + * Arg1 - saved value of &subject + * Arg2 - saved value of &pos + * + * A variable pointing to the saved &subject and &pos is returned to be + * used by escan. + */ + +LibDcl(bscan,2,"?") + { + int rc; + struct pf_marker *cur_pfp; + + /* + * Convert the new value for &subject to a string. + */ + Deref(Arg0); + + if (!cnv:string(Arg0,Arg0)) + RunErr(103, &Arg0); + + EVValD(&Arg0, E_Snew); + + /* + * Establish a new &subject value and set &pos to 1. + */ + k_subject = Arg0; + k_pos = 1; + + /* If the saved scanning environment belongs to the current procedure + * call, put a reference to it in the procedure frame. + */ + if (pfp->pf_scan == NULL) + pfp->pf_scan = &Arg1; + cur_pfp = pfp; + + /* + * Suspend with a variable pointing to the saved &subject and &pos. + */ + ArgType(0) = D_Var; + VarLoc(Arg0) = &Arg1; + + rc = interp(G_Csusp,cargp); + +#ifdef EventMon + if (rc != A_Resume) + EVValD(&Arg1, E_Srem); + else + EVValD(&Arg1, E_Sfail); +#endif /* EventMon */ + + if (pfp != cur_pfp) + return rc; + + /* + * Leaving scanning environment. Restore the old &subject and &pos values. + */ + k_subject = Arg1; + k_pos = IntVal(Arg2); + + if (pfp->pf_scan == &Arg1) + pfp->pf_scan = NULL; + + return rc; + + } + +/* + * escan - restore &subject and &pos at the end of a scanning expression. + * + * Arguments: + * Arg0 - variable pointing to old values of &subject and &pos + * Arg1 - result of the scanning expression + * + * The two arguments are reversed, so that the result of the scanning + * expression becomes the result of escan. This result is dereferenced + * if it refers to &subject or &pos. Then the saved values of &subject + * and &pos are exchanged with the current ones. + * + * Escan suspends once it has restored the old &subject; on failure + * the new &subject and &pos are "unrestored", and the failure is + * propagated into the using clause. + */ + +LibDcl(escan,1,"escan") + { + struct descrip tmp; + int rc; + struct pf_marker *cur_pfp; + + /* + * Copy the result of the scanning expression into Arg0, which will + * be the result of the scan. + */ + tmp = Arg0; + Arg0 = Arg1; + Arg1 = tmp; + + /* + * If the result of the scanning expression is &subject or &pos, + * it is dereferenced. #%#% following is incorrect #%#% + */ + /*if ((Arg0 == k_subject) || + (Arg0 == kywd_pos)) + Deref(Arg0); */ + + /* + * Swap new and old values of &subject + */ + tmp = k_subject; + k_subject = *VarLoc(Arg1); + *VarLoc(Arg1) = tmp; + + /* + * Swap new and old values of &pos + */ + tmp = *(VarLoc(Arg1) + 1); + IntVal(*(VarLoc(Arg1) + 1)) = k_pos; + k_pos = IntVal(tmp); + + /* + * If we are returning to the scanning environment of the current + * procedure call, indicate that it is no longed in a saved state. + */ + if (pfp->pf_scan == VarLoc(Arg1)) + pfp->pf_scan = NULL; + cur_pfp = pfp; + + /* + * Suspend with the value of the scanning expression. + */ + + EVValD(&k_subject, E_Ssusp); + + rc = interp(G_Csusp,cargp); + if (pfp != cur_pfp) + return rc; + + /* + * Re-entering scanning environment, exchange the values of &subject + * and &pos again + */ + tmp = k_subject; + k_subject = *VarLoc(Arg1); + *VarLoc(Arg1) = tmp; + +#ifdef EventMon + if (rc == A_Resume) + EVValD(&k_subject, E_Sresum); +#endif /* EventMon */ + + tmp = *(VarLoc(Arg1) + 1); + IntVal(*(VarLoc(Arg1) + 1)) = k_pos; + k_pos = IntVal(tmp); + + if (pfp->pf_scan == NULL) + pfp->pf_scan = VarLoc(Arg1); + + return rc; + } +#endif /* !COMPILER */ diff --git a/src/runtime/init.r b/src/runtime/init.r new file mode 100644 index 0000000..248bda8 --- /dev/null +++ b/src/runtime/init.r @@ -0,0 +1,1118 @@ +/* + * File: init.r + * Initialization, termination, and such. + * Contents: readhdr, init/icon_init, envset, env_err, env_int, + * fpe_trap, inttrag, segvtrap, error, syserr, c_exit, err, + * fatalerr, pstrnmcmp, datainit, [loadicode, savepstate, loadpstate] + */ + +static void env_err (char *msg, char *name, char *val); +FILE *pathOpen (char *fname, char *mode); + +#if !COMPILER + #include "../h/header.h" + static FILE *readhdr(char *name, struct header *hdr); + + #passthru #define OpDef(p,n,s,u) int Cat(O,p) (dptr cargp); + #passthru #include "../h/odefs.h" + #passthru #undef OpDef + + /* + * External declarations for operator blocks. + */ + + #passthru #define OpDef(f,nargs,sname,underef)\ + {\ + T_Proc,\ + Vsizeof(struct b_proc),\ + Cat(O,f),\ + nargs,\ + -1,\ + underef,\ + 0,\ + {{sizeof(sname)-1,sname}}}, + #passthru static B_IProc(2) init_op_tbl[] = { + #passthru #include "../h/odefs.h" + #passthru }; + #undef OpDef +#endif /* !COMPILER */ + +#ifdef WinGraphics + static void MSStartup(HINSTANCE hInstance, HINSTANCE hPrevInstance); +#endif /* WinGraphics */ + +/* + * A number of important variables follow. + */ + +char *prog_name; /* name of icode file */ + +int line_info; /* flag: line information is available */ +char *file_name = NULL; /* source file for current execution point */ +int line_num = 0; /* line number for current execution point */ +struct b_proc *op_tbl; /* operators available for string invocation */ + +extern struct errtab errtab[]; /* error numbers and messages */ + +word mstksize = MStackSize; /* initial size of main stack */ +word stksize = StackSize; /* co-expression stack size */ + +int k_level = 0; /* &level */ + +#ifndef MultiThread + struct descrip k_main; /* &main */ +#endif /* MultiThread */ + +int ixinited = 0; /* set-up switch */ + +char *currend = NULL; /* current end of memory region */ + + +word qualsize = QualLstSize; /* size of quallist for fixed regions */ + +word memcushion = RegionCushion; /* memory region cushion factor */ +word memgrowth = RegionGrowth; /* memory region growth factor */ + +uword stattotal = 0; /* cumulative total static allocation */ +#ifndef MultiThread + uword strtotal = 0; /* cumulative total string allocation */ + uword blktotal = 0; /* cumulative total block allocation */ +#endif /* MultiThread */ + +int dodump; /* if nonzero, core dump on error */ +int noerrbuf; /* if nonzero, do not buffer stderr */ + +struct descrip maps2; /* second cached argument of map */ +struct descrip maps3; /* third cached argument of map */ + +#ifndef MultiThread + struct descrip k_current; /* current expression stack pointer */ + int k_errornumber = 0; /* &errornumber */ + char *k_errortext = ""; /* &errortext */ + struct descrip k_errorvalue; /* &errorvalue */ + int have_errval = 0; /* &errorvalue has legal value */ + int t_errornumber = 0; /* tentative k_errornumber value */ + int t_have_val = 0; /* tentative have_errval flag */ + struct descrip t_errorvalue; /* tentative k_errorvalue value */ +#endif /* MultiThread */ + +struct b_coexpr *stklist; /* base of co-expression block list */ + +struct tend_desc *tend = NULL; /* chain of tended descriptors */ + +struct region rootstring, rootblock; + +#ifndef MultiThread + dptr glbl_argp = NULL; /* argument pointer */ + dptr globals, eglobals; /* pointer to global variables */ + dptr gnames, egnames; /* pointer to global variable names */ + dptr estatics; /* pointer to end of static variables */ + struct region *curstring, *curblock; + #if !COMPILER + int n_globals = 0; /* number of globals */ + int n_statics = 0; /* number of statics */ + #endif /* !COMPILER */ +#endif /* MultiThread */ + +#if COMPILER + struct p_frame *pfp = NULL; /* procedure frame pointer */ + + int debug_info; /* flag: is debugging information available */ + int err_conv; /* flag: is error conversion supported */ + int largeints; /* flag: large integers are supported */ + + struct b_coexpr *mainhead; /* &main */ + +#else /* COMPILER */ + + int debug_info=1; /* flag: debugging information IS available */ + int err_conv=1; /* flag: error conversion IS supported */ + + int op_tbl_sz = (sizeof(init_op_tbl) / sizeof(struct b_proc)); + struct pf_marker *pfp = NULL; /* Procedure frame pointer */ + + #ifdef MultiThread + struct progstate *curpstate; /* lastop accessed in program state */ + struct progstate rootpstate; + #else /* MultiThread */ + + struct b_coexpr *mainhead; /* &main */ + + char *code; /* interpreter code buffer */ + char *ecode; /* end of interpreter code buffer */ + word *records; /* pointer to record procedure blocks */ + + int *ftabp; /* pointer to record/field table */ + + #ifdef FieldTableCompression + word ftabwidth; /* field table entry width */ + word foffwidth; /* field offset entry width */ + unsigned char *ftabcp, *focp; /* pointers to record/field table */ + short *ftabsp, *fosp; /* pointers to record/field table */ + + int *fo; /* field offset (row in field table) */ + char *bm; /* bitmap array of valid field bits */ + #endif /* FieldTableCompression */ + + dptr fnames, efnames; /* pointer to field names */ + dptr statics; /* pointer to static variables */ + char *strcons; /* pointer to string constant table */ + struct ipc_fname *filenms, *efilenms; /* pointer to ipc/file name table */ + struct ipc_line *ilines, *elines; /* pointer to ipc/line number table */ + #endif /* MultiThread */ + + #ifdef TallyOpt + word tallybin[16]; /* counters for tallying */ + int tallyopt = 0; /* want tally results output? */ + #endif /* TallyOpt */ + + word *stack; /* Interpreter stack */ + word *stackend; /* End of interpreter stack */ + +#endif /* COMPILER */ + +#if !COMPILER + +/* + * Open the icode file and read the header. + * Used by icon_init() as well as MultiThread's loadicode() + */ +static FILE *readhdr(name,hdr) +char *name; +struct header *hdr; + { + FILE *fname = NULL; + int n; + struct fileparts fp; + + if (!name) + error(name, "No interpreter file supplied"); + + /* + * Try adding the suffix if the file name doesn't end in it. + */ + n = strlen(name); + fp = *fparse(name); + + if ( IcodeSuffix[0] != '\0' && strcmp(fp.ext,IcodeSuffix) != 0 + && ( IcodeASuffix[0] == '\0' || strcmp(fp.ext,IcodeASuffix) != 0 ) ) { + char tname[100], ext[50]; + if (n + strlen(IcodeSuffix) + 1 > 100) + error(name, "icode file name too long"); + strcpy(ext,fp.ext); + strcat(ext,IcodeSuffix); + makename(tname,NULL,name,ext); + + #if MSWIN + fname = pathOpen(tname,"rb"); /* try to find path */ + #else /* MSWIN */ + fname = fopen(tname, "rb"); + #endif /* MSWIN */ + + } + + if (fname == NULL) /* try the name as given */ + #if MSWIN + fname = pathOpen(name, "rb"); + #else /* MSWIN */ + fname = fopen(name, "rb"); + #endif /* MSWIN */ + + if (fname == NULL) + return NULL; + + { + static char errmsg[] = "can't read interpreter file header"; + +#ifdef BinaryHeader + if (fseek(fname, (long)MaxHdr, 0) == -1) + error(name, errmsg); +#else /* BinaryHeader */ + char buf[200]; + + for (;;) { + if (fgets(buf, sizeof buf-1, fname) == NULL) + error(name, errmsg); + if (strncmp(buf, "[executable Icon binary follows]", 32) == 0) + break; + } + + while ((n = getc(fname)) != EOF && n != '\f') /* read thru \f\n\0 */ + ; + getc(fname); + getc(fname); +#endif /* BinaryHeader */ + + if (fread((char *)hdr, sizeof(char), sizeof(*hdr), fname) != sizeof(*hdr)) + error(name, errmsg); + } + + return fname; + } + +#endif /* !COMPILER */ + +/* + * init/icon_init - initialize memory and prepare for Icon execution. + */ +#if !COMPILER + struct header hdr; +#endif /* !COMPILER */ + +#if COMPILER + void init(name, argcp, argv, trc_init) + char *name; + int *argcp; + char *argv[]; + int trc_init; +#else /* COMPILER */ + void icon_init(name, argcp, argv) + char *name; + int *argcp; + char *argv[]; +#endif /* COMPILER */ + + { + int delete_icode = 0; +#if !COMPILER + FILE *fname = NULL; + word cbread, longread(); +#endif /* COMPILER */ + + prog_name = name; /* Set icode file name */ + +#ifdef WinGraphics + { + STARTUPINFO si; + + /* + * Initialize windows stuff. + */ + GetStartupInfo(&si); + ncmdShow = si.wShowWindow; + if ( ncmdShow == SW_HIDE ) + /* Started from command line, show normal windows in this case. */ + ncmdShow = SW_SHOWNORMAL; + mswinInstance = GetModuleHandle( NULL ); + MSStartup( mswinInstance, NULL ); + } +#endif /* WinGraphics */ + + /* + * Look for environment variable ICODE_TEMP=xxxxx:yyyyy as a message + * from icont to delete icode file xxxxx and to use yyyyy for &progname. + * (This is used with Unix "#!" script files written in Icon.) + */ + { + char *itval = getenv("ICODE_TEMP"); + int nlen = strlen(name); + if (itval != NULL && itval[nlen] == ':' && strncmp(name,itval,nlen)==0) { + delete_icode = 1; + prog_name = itval + nlen + 1; + } + } + +#if COMPILER + curstring = &rootstring; + curblock = &rootblock; + rootstring.size = MaxStrSpace; + rootblock.size = MaxAbrSize; +#else /* COMPILER */ + +#ifdef MultiThread + /* + * initialize root pstate + */ + curpstate = &rootpstate; + rootpstate.parentdesc = nulldesc; + rootpstate.eventmask= nulldesc; + rootpstate.opcodemask = nulldesc; + rootpstate.eventcode= nulldesc; + rootpstate.eventval = nulldesc; + rootpstate.eventsource = nulldesc; + rootpstate.Glbl_argp = NULL; + MakeInt(0, &(rootpstate.Kywd_err)); + MakeInt(1, &(rootpstate.Kywd_pos)); + StrLen(rootpstate.ksub) = 0; + StrLoc(rootpstate.ksub) = ""; + MakeInt(hdr.trace, &(rootpstate.Kywd_trc)); + StrLen(rootpstate.Kywd_prog) = strlen(prog_name); + StrLoc(rootpstate.Kywd_prog) = prog_name; + MakeInt(0, &(rootpstate.Kywd_ran)); + rootpstate.K_errornumber = 0; + rootpstate.T_errornumber = 0; + rootpstate.Have_errval = 0; + rootpstate.T_have_val = 0; + rootpstate.K_errortext = ""; + rootpstate.K_errorvalue = nulldesc; + rootpstate.T_errorvalue = nulldesc; + +#ifdef Graphics + MakeInt(0,&(rootpstate.AmperX)); + MakeInt(0,&(rootpstate.AmperY)); + MakeInt(0,&(rootpstate.AmperRow)); + MakeInt(0,&(rootpstate.AmperCol)); + MakeInt(0,&(rootpstate.AmperInterval)); + rootpstate.LastEventWin = nulldesc; + rootpstate.Kywd_xwin[XKey_Window] = nulldesc; +#endif /* Graphics */ + + rootpstate.Coexp_ser = 2; + rootpstate.List_ser = 1; + rootpstate.Set_ser = 1; + rootpstate.Table_ser = 1; + rootpstate.stringregion = &rootstring; + rootpstate.blockregion = &rootblock; + +#else /* MultiThread */ + + curstring = &rootstring; + curblock = &rootblock; +#endif /* MultiThread */ + + rootstring.size = MaxStrSpace; + rootblock.size = MaxAbrSize; +#endif /* COMPILER */ + +#if !COMPILER + op_tbl = (struct b_proc*)init_op_tbl; +#endif /* !COMPILER */ + +#ifdef Double + if (sizeof(struct size_dbl) != sizeof(double)) + syserr("Icon configuration does not handle double alignment"); +#endif /* Double */ + + /* + * Catch floating-point traps and memory faults. + */ + signal(SIGFPE, fpetrap); + signal(SIGSEGV, segvtrap); + + /* + * Initialize data that can't be initialized statically. + */ + + datainit(); + + #if COMPILER + IntVal(kywd_trc) = trc_init; + #else /* COMPILER */ + fname = readhdr(name,&hdr); + if (fname == NULL) + error(name, "cannot open interpreter file"); + k_trace = hdr.trace; + #endif /* COMPILER */ + + /* + * Examine the environment and make appropriate settings. [[I?]] + */ + envset(); + + /* + * Convert stack sizes from words to bytes. + */ + stksize *= WordSize; + mstksize *= WordSize; + + /* + * Allocate memory for various regions. + */ +#if COMPILER + initalloc(); +#else /* COMPILER */ +#ifdef MultiThread + initalloc(hdr.hsize,&rootpstate); +#else /* MultiThread */ + initalloc(hdr.hsize); +#endif /* MultiThread */ +#endif /* COMPILER */ + +#if !COMPILER + /* + * Establish pointers to icode data regions. [[I?]] + */ + ecode = code + hdr.Records; + records = (word *)ecode; + ftabp = (int *)(code + hdr.Ftab); +#ifdef FieldTableCompression + fo = (int *)(code + hdr.Fo); + focp = (unsigned char *)(fo); + fosp = (short *)(fo); + if (hdr.FoffWidth == 1) { + bm = (char *)(focp + hdr.Nfields); + } + else if (hdr.FoffWidth == 2) { + bm = (char *)(fosp + hdr.Nfields); + } + else + bm = (char *)(fo + hdr.Nfields); + + ftabwidth = hdr.FtabWidth; + foffwidth = hdr.FoffWidth; + ftabcp = (unsigned char *)(code + hdr.Ftab); + ftabsp = (short *)(code + hdr.Ftab); +#endif /* FieldTableCompression */ + fnames = (dptr)(code + hdr.Fnames); + globals = efnames = (dptr)(code + hdr.Globals); + gnames = eglobals = (dptr)(code + hdr.Gnames); + statics = egnames = (dptr)(code + hdr.Statics); + estatics = (dptr)(code + hdr.Filenms); + filenms = (struct ipc_fname *)estatics; + efilenms = (struct ipc_fname *)(code + hdr.linenums); + ilines = (struct ipc_line *)efilenms; + elines = (struct ipc_line *)(code + hdr.Strcons); + strcons = (char *)elines; + n_globals = eglobals - globals; + n_statics = estatics - statics; +#endif /* COMPILER */ + + /* + * Allocate stack and initialize &main. + */ + +#if COMPILER + mainhead = (struct b_coexpr *)malloc(sizeof(struct b_coexpr)); +#else /* COMPILER */ + stack = (word *)malloc(mstksize); + mainhead = (struct b_coexpr *)stack; + +#endif /* COMPILER */ + + if (mainhead == NULL) +#if COMPILER + err_msg(305, NULL); +#else /* COMPILER */ + fatalerr(303, NULL); +#endif /* COMPILER */ + + mainhead->title = T_Coexpr; + mainhead->id = 1; + mainhead->size = 1; /* pretend main() does an activation */ + mainhead->nextstk = NULL; + mainhead->es_tend = NULL; + mainhead->freshblk = nulldesc; /* &main has no refresh block. */ + /* This really is a bug. */ +#ifdef MultiThread + mainhead->program = &rootpstate; +#endif /* MultiThread */ +#if COMPILER + mainhead->file_name = ""; + mainhead->line_num = 0; +#endif /* COMPILER */ + +#ifdef Coexpr + Protect(mainhead->es_actstk = alcactiv(), fatalerr(0,NULL)); + pushact(mainhead, mainhead); +#endif /* Coexpr */ + + /* + * Point &main at the co-expression block for the main procedure and set + * k_current, the pointer to the current co-expression, to &main. + */ + k_main.dword = D_Coexpr; + BlkLoc(k_main) = (union block *) mainhead; + k_current = k_main; + +#if !COMPILER + /* + * Read the interpretable code and data into memory. + */ + if ((cbread = longread(code, sizeof(char), (long)hdr.hsize, fname)) != + hdr.hsize) { + fprintf(stderr,"Tried to read %ld bytes of code, got %ld\n", + (long)hdr.hsize,(long)cbread); + error(name, "bad icode file"); + } + fclose(fname); + if (delete_icode) /* delete icode file if flag set earlier */ + remove(name); + +/* + * Make sure the version number of the icode matches the interpreter version. + */ + if (strcmp((char *)hdr.config,IVersion)) { + fprintf(stderr,"icode version mismatch in %s\n", name); + fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config); + fprintf(stderr,"\texpected version: %s\n",IVersion); + error(name, "cannot run"); + } +#endif /* !COMPILER */ + + /* + * Initialize the event monitoring system, if configured. + */ + +#ifdef EventMon + EVInit(); +#endif /* EventMon */ + +#if !COMPILER + /* + * Resolve references from icode to run-time system. + */ +#ifdef MultiThread + resolve(NULL); +#else /* MultiThread */ + resolve(); +#endif /* MultiThread */ +#endif /* COMPILER */ + + /* + * Allocate and assign a buffer to stderr if possible. + */ + if (noerrbuf) + setbuf(stderr, NULL); + else { + void *buf = malloc(BUFSIZ); + if (buf == NULL) + fatalerr(305, NULL); + setbuf(stderr, buf); + } + + /* + * Start timing execution. + */ + millisec(); + } + +/* + * Service routines related to getting things started. + */ + + +/* + * Check for environment variables that Icon uses and set system + * values as is appropriate. + */ +void envset() + { + register char *p; + + if ((p = getenv("NOERRBUF")) != NULL) + noerrbuf++; + env_int("TRACE", &k_trace, 0, (uword)0); + env_int("COEXPSIZE", &stksize, 1, (uword)MaxUnsigned); + env_int("STRSIZE", &ssize, 1, (uword)MaxBlock); + env_int("BLKSIZE", &abrsize, 1, (uword)MaxBlock); + env_int("MSTKSIZE", &mstksize, 1, (uword)MaxUnsigned); + env_int("QLSIZE", &qualsize, 1, (uword)MaxBlock); + env_int("IXCUSHION", &memcushion, 1, (uword)100); /* max 100 % */ + env_int("IXGROWTH", &memgrowth, 1, (uword)10000); /* max 100x growth */ + + if ((p = getenv("ICONCORE")) != NULL && *p != '\0') { + /* + * ICONCORE is set. Reset traps to allow dump after abnormal termination. + */ + dodump++; + signal(SIGFPE, SIG_DFL); + signal(SIGSEGV, SIG_DFL); + } + } + +/* + * env_err - print an error mesage about the value of an environment + * variable. + */ +static void env_err(msg, name, val) +char *msg; +char *name; +char *val; +{ + char msg_buf[100]; + + strncpy(msg_buf, msg, 99); + strncat(msg_buf, ": ", 99 - (int)strlen(msg_buf)); + strncat(msg_buf, name, 99 - (int)strlen(msg_buf)); + strncat(msg_buf, "=", 99 - (int)strlen(msg_buf)); + strncat(msg_buf, val, 99 - (int)strlen(msg_buf)); + error("", msg_buf); +} + +/* + * env_int - get the value of an integer-valued environment variable. + */ +void env_int(name, variable, non_neg, limit) +char *name; +word *variable; +int non_neg; +uword limit; +{ + char *value; + char *s; + register uword n = 0; + register uword d; + int sign = 1; + + if ((value = getenv(name)) == NULL || *value == '\0') + return; + + s = value; + if (*s == '-') { + if (non_neg) + env_err("environment variable out of range", name, value); + sign = -1; + ++s; + } + else if (*s == '+') + ++s; + while (isdigit(*s)) { + d = *s++ - '0'; + /* + * See if 10 * n + d > limit, but do it so there can be no overflow. + */ + if ((d > (uword)(limit / 10 - n) * 10 + limit % 10) && (limit > 0)) + env_err("environment variable out of range", name, value); + n = n * 10 + d; + } + if (*s != '\0') + env_err("environment variable not numeric", name, value); + *variable = sign * n; +} + +/* + * Termination routines. + */ + +/* + * Produce run-time error 204 on floating-point traps. + */ + +void fpetrap(int sig) + { + fatalerr(204, NULL); + } + +/* + * Produce run-time error 302 on segmentation faults. + */ +void segvtrap(int sig) + { + static int n = 0; + + if (n != 0) { /* only try traceback once */ + fprintf(stderr, "[Traceback failed]\n"); + exit(1); + } + n++; + fatalerr(302, NULL); + exit(1); + } + +/* + * error - print error message from s1 and s2; used only in startup code. + */ +void error(s1, s2) +char *s1, *s2; + { + if (!s1) + fprintf(stderr, "error in startup code\n%s\n", s2); + else + fprintf(stderr, "error in startup code\n%s: %s\n", s1, s2); + fflush(stderr); + if (dodump) + abort(); + c_exit(EXIT_FAILURE); + } + +/* + * syserr - print s as a system error. + */ +void syserr(s) +char *s; + { + fprintf(stderr, "System error"); + if (pfp == NULL) + fprintf(stderr, " in startup code"); + else { +#if COMPILER + if (line_info) + fprintf(stderr, " at line %d in %s", line_num, file_name); +#else /* COMPILER */ + fprintf(stderr, " at line %ld in %s", (long)findline(ipc.opnd), + findfile(ipc.opnd)); +#endif /* COMPILER */ + } + fprintf(stderr, "\n%s\n", s); + fflush(stderr); + if (dodump) + abort(); + c_exit(EXIT_FAILURE); + } + +/* + * c_exit(i) - flush all buffers and exit with status i. + */ +void c_exit(i) +int i; +{ + +#ifdef EventMon + if (curpstate != NULL) { + EVVal((word)i, E_Exit); + } +#endif /* EventMon */ + +#ifdef MultiThread + if (curpstate != NULL && curpstate->parent != NULL) { + /* might want to get to the lterm somehow, instead */ + while (1) { + struct descrip dummy; + co_chng(curpstate->parent->Mainhead, NULL, &dummy, A_Cofail, 1); + } + } +#endif /* MultiThread */ + +#ifdef TallyOpt + { + int j; + + if (tallyopt) { + fprintf(stderr,"tallies: "); + for (j=0; j<16; j++) + fprintf(stderr," %ld", (long)tallybin[j]); + fprintf(stderr,"\n"); + } + } +#endif /* TallyOpt */ + + if (k_dump && ixinited) { + fprintf(stderr,"\nTermination dump:\n\n"); + fflush(stderr); + fprintf(stderr,"co-expression #%ld(%ld)\n", + (long)BlkLoc(k_current)->coexpr.id, + (long)BlkLoc(k_current)->coexpr.size); + fflush(stderr); + xdisp(pfp,glbl_argp,k_level,stderr); + } + + exit(i); + +} + +/* + * err() is called if an erroneous situation occurs in the virtual + * machine code. It is typed as int to avoid declaration problems + * elsewhere. + */ +int err() +{ + syserr("call to 'err'\n"); + return 1; /* unreachable; make compilers happy */ +} + +/* + * fatalerr - disable error conversion and call run-time error routine. + */ +void fatalerr(n, v) +int n; +dptr v; + { + IntVal(kywd_err) = 0; + err_msg(n, v); + } + +/* + * pstrnmcmp - compare names in two pstrnm structs; used for qsort. + */ +int pstrnmcmp(a,b) +struct pstrnm *a, *b; +{ + return strcmp(a->pstrep, b->pstrep); +} + +/* + * datainit - initialize some global variables. + */ +void datainit() + { + + /* + * Initializations that cannot be performed statically (at least for + * some compilers). [[I?]] + */ + +#ifdef MultiThread + k_errout.title = T_File; + k_input.title = T_File; + k_output.title = T_File; +#endif /* MultiThread */ + + k_errout.fd = stderr; + StrLen(k_errout.fname) = 7; + StrLoc(k_errout.fname) = "&errout"; + k_errout.status = Fs_Write; + + if (k_input.fd == NULL) + k_input.fd = stdin; + StrLen(k_input.fname) = 6; + StrLoc(k_input.fname) = "&input"; + k_input.status = Fs_Read; + + if (k_output.fd == NULL) + k_output.fd = stdout; + StrLen(k_output.fname) = 7; + StrLoc(k_output.fname) = "&output"; + k_output.status = Fs_Write; + + IntVal(kywd_pos) = 1; + IntVal(kywd_ran) = 0; + StrLen(kywd_prog) = strlen(prog_name); + StrLoc(kywd_prog) = prog_name; + StrLen(k_subject) = 0; + StrLoc(k_subject) = ""; + +#ifdef MSwindows + if (i != EXIT_SUCCESS) + { + char exit_msg[40]; + + sprintf(exit_msg, "Terminated with exit code %d", i); + MessageBox(NULL, exit_msg, prog_name, MB_OK | MB_ICONSTOP); + } +#endif /* defined(MSwindows) */ + + StrLen(blank) = 1; + StrLoc(blank) = " "; + StrLen(emptystr) = 0; + StrLoc(emptystr) = ""; + BlkLoc(nullptr) = (union block *)NULL; + StrLen(lcase) = 26; + StrLoc(lcase) = "abcdefghijklmnopqrstuvwxyz"; + StrLen(letr) = 1; + StrLoc(letr) = "r"; + IntVal(nulldesc) = 0; + k_errorvalue = nulldesc; + IntVal(onedesc) = 1; + StrLen(ucase) = 26; + StrLoc(ucase) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; + IntVal(zerodesc) = 0; + +#ifdef EventMon +/* + * Initialization needed for event monitoring + */ + + BlkLoc(csetdesc) = (union block *)&fullcs; + BlkLoc(rzerodesc) = (union block *)&realzero; + +#endif /* EventMon */ + + maps2 = nulldesc; + maps3 = nulldesc; + + #if !COMPILER + qsort((char *)pntab,pnsize,sizeof(struct pstrnm), (int(*)())pstrnmcmp); + #endif /* COMPILER */ + + } + +#ifdef MultiThread +/* + * loadicode - initialize memory particular to a given icode file + */ +struct b_coexpr * loadicode(name, theInput, theOutput, theError, bs, ss, stk) +char *name; +struct b_file *theInput, *theOutput, *theError; +C_integer bs, ss, stk; + { + struct b_coexpr *coexp; + struct progstate *pstate; + struct header hdr; + FILE *fname = NULL; + word cbread, longread(); + + /* + * open the icode file and read the header + */ + fname = readhdr(name,&hdr); + if (fname == NULL) + return NULL; + + /* + * Allocate memory for icode and the struct that describes it + */ + Protect(coexp = alccoexp(hdr.hsize, stk), + { fprintf(stderr,"can't malloc new icode region\n");c_exit(EXIT_FAILURE);}); + + pstate = coexp->program; + /* + * Initialize values. + */ + pstate->hsize = hdr.hsize; + pstate->parent= NULL; + pstate->parentdesc= nulldesc; + pstate->opcodemask= nulldesc; + pstate->eventmask= nulldesc; + pstate->eventcode= nulldesc; + pstate->eventval = nulldesc; + pstate->eventsource = nulldesc; + pstate->K_current.dword = D_Coexpr; + + MakeInt(0, &(pstate->Kywd_err)); + MakeInt(1, &(pstate->Kywd_pos)); + MakeInt(0, &(pstate->Kywd_ran)); + + StrLen(pstate->Kywd_prog) = strlen(prog_name); + StrLoc(pstate->Kywd_prog) = prog_name; + StrLen(pstate->ksub) = 0; + StrLoc(pstate->ksub) = ""; + MakeInt(hdr.trace, &(pstate->Kywd_trc)); + +#ifdef EventMon + pstate->Linenum = pstate->Column = pstate->Lastline = pstate->Lastcol = 0; +#endif /* EventMon */ + pstate->Lastop = 0; + /* + * might want to override from TRACE environment variable here. + */ + + /* + * Establish pointers to icode data regions. [[I?]] + */ + pstate->Mainhead= ((struct b_coexpr *)pstate)-1; + pstate->K_main.dword = D_Coexpr; + BlkLoc(pstate->K_main) = (union block *) pstate->Mainhead; + pstate->Code = (char *)(pstate + 1); + pstate->Ecode = (char *)(pstate->Code + hdr.Records); + pstate->Records = (word *)(pstate->Code + hdr.Records); + pstate->Ftabp = (int *)(pstate->Code + hdr.Ftab); +#ifdef FieldTableCompression + pstate->Fo = (int *)(pstate->Code + hdr.Fo); + pstate->Focp = (unsigned char *)(pstate->Fo); + pstate->Fosp = (short *)(pstate->Fo); + pstate->Foffwidth = hdr.FoffWidth; + if (hdr.FoffWidth == 1) { + pstate->Bm = (char *)(pstate->Focp + hdr.Nfields); + } + else if (hdr.FoffWidth == 2) { + pstate->Bm = (char *)(pstate->Fosp + hdr.Nfields); + } + else + pstate->Bm = (char *)(pstate->Fo + hdr.Nfields); + pstate->Ftabwidth= hdr.FtabWidth; + pstate->Foffwidth = hdr.FoffWidth; + pstate->Ftabcp = (unsigned char *)(pstate->Code + hdr.Ftab); + pstate->Ftabsp = (short *)(pstate->Code + hdr.Ftab); +#endif /* FieldTableCompression */ + pstate->Fnames = (dptr)(pstate->Code + hdr.Fnames); + pstate->Globals = pstate->Efnames = (dptr)(pstate->Code + hdr.Globals); + pstate->Gnames = pstate->Eglobals = (dptr)(pstate->Code + hdr.Gnames); + pstate->NGlobals = pstate->Eglobals - pstate->Globals; + pstate->Statics = pstate->Egnames = (dptr)(pstate->Code + hdr.Statics); + pstate->Estatics = (dptr)(pstate->Code + hdr.Filenms); + pstate->NStatics = pstate->Estatics - pstate->Statics; + pstate->Filenms = (struct ipc_fname *)(pstate->Estatics); + pstate->Efilenms = (struct ipc_fname *)(pstate->Code + hdr.linenums); + pstate->Ilines = (struct ipc_line *)(pstate->Efilenms); + pstate->Elines = (struct ipc_line *)(pstate->Code + hdr.Strcons); + pstate->Strcons = (char *)(pstate->Elines); + pstate->K_errornumber = 0; + pstate->T_errornumber = 0; + pstate->Have_errval = 0; + pstate->T_have_val = 0; + pstate->K_errortext = ""; + pstate->K_errorvalue = nulldesc; + pstate->T_errorvalue = nulldesc; + +#ifdef Graphics + MakeInt(0, &(pstate->AmperX)); + MakeInt(0, &(pstate->AmperY)); + MakeInt(0, &(pstate->AmperRow)); + MakeInt(0, &(pstate->AmperCol)); + MakeInt(0, &(pstate->AmperInterval)); + pstate->LastEventWin = nulldesc; + pstate->Kywd_xwin[XKey_Window] = nulldesc; +#endif /* Graphics */ + + pstate->Coexp_ser = 2; + pstate->List_ser = 1; + pstate->Set_ser = 1; + pstate->Table_ser = 1; + + pstate->stringtotal = pstate->blocktotal = + pstate->colltot = pstate->collstat = + pstate->collstr = pstate->collblk = 0; + + pstate->stringregion = (struct region *)malloc(sizeof(struct region)); + pstate->blockregion = (struct region *)malloc(sizeof(struct region)); + pstate->stringregion->size = ss; + pstate->blockregion->size = bs; + + /* + * the local program region list starts out with this region only + */ + pstate->stringregion->prev = NULL; + pstate->blockregion->prev = NULL; + pstate->stringregion->next = NULL; + pstate->blockregion->next = NULL; + /* + * the global region list links this region with curpstate's + */ + pstate->stringregion->Gprev = curpstate->stringregion; + pstate->blockregion->Gprev = curpstate->blockregion; + pstate->stringregion->Gnext = curpstate->stringregion->Gnext; + pstate->blockregion->Gnext = curpstate->blockregion->Gnext; + if (curpstate->stringregion->Gnext) + curpstate->stringregion->Gnext->Gprev = pstate->stringregion; + curpstate->stringregion->Gnext = pstate->stringregion; + if (curpstate->blockregion->Gnext) + curpstate->blockregion->Gnext->Gprev = pstate->blockregion; + curpstate->blockregion->Gnext = pstate->blockregion; + initalloc(0, pstate); + + pstate->K_errout = *theError; + pstate->K_input = *theInput; + pstate->K_output = *theOutput; + + /* + * Read the interpretable code and data into memory. + */ + if ((cbread = longread(pstate->Code, sizeof(char), (long)hdr.hsize, fname)) + != hdr.hsize) { + fprintf(stderr,"Tried to read %ld bytes of code, got %ld\n", + (long)hdr.hsize,(long)cbread); + error(name, "can't read interpreter code"); + } + fclose(fname); + + /* + * Make sure the version number of the icode matches the interpreter version + */ + if (strcmp((char *)hdr.config,IVersion)) { + fprintf(stderr,"icode version mismatch in %s\n", name); + fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config); + fprintf(stderr,"\texpected version: %s\n",IVersion); + error(name, "cannot run"); + } + + /* + * Resolve references from icode to run-time system. + * The first program has this done in icon_init after + * initializing the event monitoring system. + */ + resolve(pstate); + + return coexp; + } +#endif /* MultiThread */ + +#ifdef WinGraphics +static void MSStartup(HINSTANCE hInstance, HINSTANCE hPrevInstance) + { + WNDCLASS wc; + if (!hPrevInstance) { + wc.style = CS_HREDRAW | CS_VREDRAW; + wc.lpfnWndProc = WndProc; + wc.cbClsExtra = 0; + wc.cbWndExtra = 0; + wc.hInstance = hInstance; + wc.hIcon = NULL; + wc.hCursor = NULL; + wc.hbrBackground = GetStockObject(WHITE_BRUSH); + wc.lpszMenuName = NULL; + wc.lpszClassName = "iconx"; + RegisterClass(&wc); + } + } +#endif /* WinGraphics */ diff --git a/src/runtime/interp.r b/src/runtime/interp.r new file mode 100644 index 0000000..c5fd713 --- /dev/null +++ b/src/runtime/interp.r @@ -0,0 +1,1818 @@ +#if !COMPILER +/* + * File: interp.r + * The interpreter proper. + */ + +#include "../h/opdefs.h" + +extern fptr fncentry[]; + + +/* + * Prototypes for static functions. + */ +#ifdef EventMon +static struct ef_marker *vanq_bound (struct ef_marker *efp_v, + struct gf_marker *gfp_v); +static void vanq_proc (struct ef_marker *efp_v, + struct gf_marker *gfp_v); +#endif /* EventMon */ + +#ifndef MultiThread +word lastop; /* Last operator evaluated */ +#endif /* MultiThread */ + +/* + * Istate variables. + */ +struct ef_marker *efp; /* Expression frame pointer */ +struct gf_marker *gfp; /* Generator frame pointer */ +inst ipc; /* Interpreter program counter */ +word *sp = NULL; /* Stack pointer */ + +int ilevel; /* Depth of recursion in interp() */ +struct descrip value_tmp; /* list argument to Op_Apply */ +struct descrip eret_tmp; /* eret value during unwinding */ + +int coexp_act; /* last co-expression action */ + +#ifndef MultiThread +dptr xargp; +word xnargs; +#endif /* MultiThread */ + +/* + * Macros for use inside the main loop of the interpreter. + */ + +#ifdef EventMon +#define E_Misc -1 +#define E_Operator 0 +#define E_Function 1 +#endif /* EventMon */ + +/* + * Setup_Op sets things up for a call to the C function for an operator. + * InterpEVValD expands to nothing if EventMon is not defined. + */ +#begdef Setup_Op(nargs) +#ifdef EventMon + lastev = E_Operator; + value_tmp.dword = D_Proc; + value_tmp.vword.bptr = (union block *)&op_tbl[lastop - 1]; + InterpEVValD(&value_tmp, E_Ocall); +#endif /* EventMon */ + rargp = (dptr)(rsp - 1) - nargs; + xargp = rargp; + ExInterp; +#enddef /* Setup_Op */ + +/* + * Setup_Arg sets things up for a call to the C function. + * It is the same as Setup_Op, except the latter is used only + * operators. + */ +#begdef Setup_Arg(nargs) +#ifdef EventMon + lastev = E_Misc; +#endif /* EventMon */ + rargp = (dptr)(rsp - 1) - nargs; + xargp = rargp; + ExInterp; +#enddef /* Setup_Arg */ + +#begdef Call_Cond + if ((*(optab[lastop]))(rargp) == A_Resume) { +#ifdef EventMon + InterpEVVal((word)-1, E_Ofail); +#endif /* EventMon */ + goto efail_noev; + } + rsp = (word *) rargp + 1; +#ifdef EventMon + goto return_term; +#else /* EventMon */ + break; +#endif /* EventMon */ +#enddef /* Call_Cond */ + +/* + * Call_Gen - Call a generator. A C routine associated with the + * current opcode is called. When it when it terminates, control is + * passed to C_rtn_term to deal with the termination condition appropriately. + */ +#begdef Call_Gen + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; +#enddef /* Call_Gen */ + +/* + * GetWord fetches the next icode word. PutWord(x) stores x at the current + * icode word. + */ +#define GetWord (*ipc.opnd++) +#define PutWord(x) ipc.opnd[-1] = (x) +#define GetOp (word)(*ipc.op++) +#define PutOp(x) ipc.op[-1] = (x) + +/* + * DerefArg(n) dereferences the nth argument. + */ +#define DerefArg(n) Deref(rargp[n]) + +/* + * For the sake of efficiency, the stack pointer is kept in a register + * variable, rsp, in the interpreter loop. Since this variable is + * only accessible inside the loop, and the global variable sp is used + * for the stack pointer elsewhere, rsp must be stored into sp when + * the context of the loop is left and conversely, rsp must be loaded + * from sp when the loop is reentered. The macros ExInterp and EntInterp, + * respectively, handle these operations. Currently, this register/global + * scheme is only used for the stack pointer, but it can be easily extended + * to other variables. + */ + +#define ExInterp sp = rsp; +#define EntInterp rsp = sp; + +/* + * Inside the interpreter loop, PushDesc, PushNull, PushAVal, and + * PushVal use rsp instead of sp for efficiency. + */ +#undef PushDesc +#undef PushNull +#undef PushVal +#undef PushAVal +#define PushDesc(d) PushDescSP(rsp,d) +#define PushNull PushNullSP(rsp) +#define PushVal(v) PushValSP(rsp,v) +#define PushAVal(a) PushValSP(rsp,a) + + +/* + * The main loop of the interpreter. + */ +int interp(fsig,cargp) +int fsig; +dptr cargp; + { + register word opnd; + register word *rsp; + register dptr rargp; + register struct ef_marker *newefp; + register struct gf_marker *newgfp; + register word *wd; + register word *firstwd, *lastwd; + word *oldsp; + int type, signal, args; + extern int (*optab[])(); + extern int (*keytab[])(); + struct b_proc *bproc; +#ifdef EventMon + int lastev = E_Misc; +#endif /* EventMon */ + +#ifdef TallyOpt + extern word tallybin[]; +#endif /* TallyOpt */ + +#ifdef EventMon + EVVal(fsig, E_Intcall); + EVVal(DiffPtrs(sp, stack), E_Stack); +#endif /* EventMon */ + +#ifndef MultiThread + /* + * Make a stab at catching interpreter stack overflow. This does + * nothing for invocation in a co-expression other than &main. + */ + if (BlkLoc(k_current) == BlkLoc(k_main) && + ((char *)sp + PerilDelta) > (char *)stackend) + fatalerr(301, NULL); +#endif /* MultiThread */ + +#ifdef Polling + if (!pollctr--) { + pollctr = pollevent(); + if (pollctr == -1) fatalerr(141, NULL); + } +#endif /* Polling */ + + ilevel++; + + EntInterp; + +#ifdef EventMon + switch (fsig) { + case G_Csusp: + case G_Fsusp: + case G_Osusp: + value_tmp = *(dptr)(rsp - 1); /* argument */ + Deref(value_tmp); + InterpEVValD(&value_tmp, + (fsig == G_Fsusp)?E_Fsusp:(fsig == G_Osusp?E_Osusp:E_Bsusp)); +#else /* EventMon */ + if (fsig == G_Csusp) { +#endif /* EventMon */ + + oldsp = rsp; + + /* + * Create the generator frame. + */ + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = fsig; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + rsp += Wsizeof(struct gf_smallmarker); + + /* + * Region extends from first word after the marker for the generator + * or expression frame enclosing the call to the now-suspending + * routine to the first argument of the routine. + */ + if (gfp != 0) { + if (gfp->gf_gentype == G_Psusp) + firstwd = (word *)gfp + Wsizeof(*gfp); + else + firstwd = (word *)gfp + Wsizeof(struct gf_smallmarker); + } + else + firstwd = (word *)efp + Wsizeof(*efp); + lastwd = (word *)cargp + 1; + + /* + * Copy the portion of the stack with endpoints firstwd and lastwd + * (inclusive) to the top of the stack. + */ + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + gfp = newgfp; + } +/* + * Top of the interpreter loop. + */ + + for (;;) { + +#ifdef EventMon + + /* + * Location change events are generated by checking to see if the opcode + * has changed indices in the "line number" (now line + column) table; + * "straight line" forward code does not require a binary search to find + * the new location; instead, a pointer is simply incremented. + * Further optimization here is planned. + */ + if (!is:null(curpstate->eventmask) && ( + Testb((word)E_Loc, curpstate->eventmask) || + Testb((word)E_Line, curpstate->eventmask) + )) { + + if (InRange(code, ipc.opnd, ecode)) { + uword ipc_offset = DiffPtrs((char *)ipc.opnd, (char *)code); + uword size; + word temp_no; + if (!current_line_ptr || + current_line_ptr->ipc > ipc_offset || + current_line_ptr[1].ipc <= ipc_offset) { +#ifdef LineCodes +#ifdef Polling + if (!pollctr--) { + ExInterp; + pollctr = pollevent(); + EntInterp; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif /* Polling */ +#endif /* LineCodes */ + + + if(current_line_ptr && + current_line_ptr + 2 < elines && + current_line_ptr[1].ipc < ipc_offset && + ipc_offset < current_line_ptr[2].ipc) { + current_line_ptr ++; + } + else { + current_line_ptr = ilines; + size = DiffPtrs((char *)elines, (char *)ilines) / + sizeof(struct ipc_line *); + while (size > 1) { + if (ipc_offset >= current_line_ptr[size>>1].ipc) { + current_line_ptr = ¤t_line_ptr[size>>1]; + size -= (size >> 1); + } + else { + size >>= 1; + } + } + } + linenum = current_line_ptr->line; + temp_no = linenum & 65535; + if ((lastline & 65535) != temp_no) { + if (Testb((word)E_Line, curpstate->eventmask)) + if (temp_no) + InterpEVVal(temp_no, E_Line); + } + if (lastline != linenum) { + lastline = linenum; + if (Testb((word)E_Loc, curpstate->eventmask) && + current_line_ptr->line >> 16) + InterpEVVal(current_line_ptr->line, E_Loc); + } + } + } + } +#endif /* EventMon */ + + lastop = GetOp; /* Instruction fetch */ + +#ifdef EventMon + /* + * If we've asked for ALL opcode events, or specifically for this one + * generate an MT-style event. + */ + if ((!is:null(curpstate->eventmask) && + Testb((word)E_Opcode, curpstate->eventmask)) && + (is:null(curpstate->opcodemask) || + Testb((word)lastop, curpstate->opcodemask))) { + ExInterp; + MakeInt(lastop, &(curpstate->parent->eventval)); + actparent(E_Opcode); + EntInterp + } +#endif /* EventMon */ + + switch ((int)lastop) { /* + * Switch on opcode. The cases are + * organized roughly by functionality + * to make it easier to find things. + * For some C compilers, there may be + * an advantage to arranging them by + * likelihood of selection. + */ + + /* ---Constant construction--- */ + + case Op_Cset: /* cset */ + PutOp(Op_Acset); + PushVal(D_Cset); + opnd = GetWord; + opnd += (word)ipc.opnd; + PutWord(opnd); + PushAVal(opnd); + break; + + case Op_Acset: /* cset, absolute address */ + PushVal(D_Cset); + PushAVal(GetWord); + break; + + case Op_Int: /* integer */ + PushVal(D_Integer); + PushVal(GetWord); + break; + + case Op_Real: /* real */ + PutOp(Op_Areal); + PushVal(D_Real); + opnd = GetWord; + opnd += (word)ipc.opnd; + PushAVal(opnd); + PutWord(opnd); + break; + + case Op_Areal: /* real, absolute address */ + PushVal(D_Real); + PushAVal(GetWord); + break; + + case Op_Str: /* string */ + PutOp(Op_Astr); + PushVal(GetWord); + opnd = (word)strcons + GetWord; + PutWord(opnd); + PushAVal(opnd); + break; + + case Op_Astr: /* string, absolute address */ + PushVal(GetWord); + PushAVal(GetWord); + break; + + /* ---Variable construction--- */ + + case Op_Arg: /* argument */ + PushVal(D_Var); + PushAVal(&glbl_argp[GetWord + 1]); + break; + + case Op_Global: /* global */ + PutOp(Op_Aglobal); + PushVal(D_Var); + opnd = GetWord; + PushAVal(&globals[opnd]); + PutWord((word)&globals[opnd]); + break; + + case Op_Aglobal: /* global, absolute address */ + PushVal(D_Var); + PushAVal(GetWord); + break; + + case Op_Local: /* local */ + PushVal(D_Var); + PushAVal(&pfp->pf_locals[GetWord]); + break; + + case Op_Static: /* static */ + PutOp(Op_Astatic); + PushVal(D_Var); + opnd = GetWord; + PushAVal(&statics[opnd]); + PutWord((word)&statics[opnd]); + break; + + case Op_Astatic: /* static, absolute address */ + PushVal(D_Var); + PushAVal(GetWord); + break; + + + /* ---Operators--- */ + + /* Unary operators */ + + case Op_Compl: /* ~e */ + case Op_Neg: /* -e */ + case Op_Number: /* +e */ + case Op_Refresh: /* ^e */ + case Op_Size: /* *e */ + Setup_Op(1); + DerefArg(1); + Call_Cond; + + case Op_Value: /* .e */ + Setup_Op(1); + DerefArg(1); + Call_Cond; + + case Op_Nonnull: /* \e */ + case Op_Null: /* /e */ + Setup_Op(1); + Call_Cond; + + case Op_Random: /* ?e */ + PushNull; + Setup_Op(2) + Call_Cond + + /* Generative unary operators */ + + case Op_Tabmat: /* =e */ + Setup_Op(1); + DerefArg(1); + Call_Gen; + + case Op_Bang: /* !e */ + PushNull; + Setup_Op(2); + Call_Gen; + + /* Binary operators */ + + case Op_Cat: /* e1 || e2 */ + case Op_Diff: /* e1 -- e2 */ + case Op_Div: /* e1 / e2 */ + case Op_Inter: /* e1 ** e2 */ + case Op_Lconcat: /* e1 ||| e2 */ + case Op_Minus: /* e1 - e2 */ + case Op_Mod: /* e1 % e2 */ + case Op_Mult: /* e1 * e2 */ + case Op_Power: /* e1 ^ e2 */ + case Op_Unions: /* e1 ++ e2 */ + case Op_Plus: /* e1 + e2 */ + case Op_Eqv: /* e1 === e2 */ + case Op_Lexeq: /* e1 == e2 */ + case Op_Lexge: /* e1 >>= e2 */ + case Op_Lexgt: /* e1 >> e2 */ + case Op_Lexle: /* e1 <<= e2 */ + case Op_Lexlt: /* e1 << e2 */ + case Op_Lexne: /* e1 ~== e2 */ + case Op_Neqv: /* e1 ~=== e2 */ + case Op_Numeq: /* e1 = e2 */ + case Op_Numge: /* e1 >= e2 */ + case Op_Numgt: /* e1 > e2 */ + case Op_Numle: /* e1 <= e2 */ + case Op_Numne: /* e1 ~= e2 */ + case Op_Numlt: /* e1 < e2 */ + Setup_Op(2); + DerefArg(1); + DerefArg(2); + Call_Cond; + + case Op_Asgn: /* e1 := e2 */ + Setup_Op(2); + Call_Cond; + + case Op_Swap: /* e1 :=: e2 */ + PushNull; + Setup_Op(3); + Call_Cond; + + case Op_Subsc: /* e1[e2] */ + PushNull; + Setup_Op(3); + Call_Cond; + /* Generative binary operators */ + + case Op_Rasgn: /* e1 <- e2 */ + Setup_Op(2); + Call_Gen; + + case Op_Rswap: /* e1 <-> e2 */ + PushNull; + Setup_Op(3); + Call_Gen; + + /* Conditional ternary operators */ + + case Op_Sect: /* e1[e2:e3] */ + PushNull; + Setup_Op(4); + Call_Cond; + /* Generative ternary operators */ + + case Op_Toby: /* e1 to e2 by e3 */ + Setup_Op(3); + DerefArg(1); + DerefArg(2); + DerefArg(3); + Call_Gen; + + case Op_Noop: /* no-op */ + +#ifdef LineCodes +#ifdef Polling + if (!pollctr--) { + ExInterp; + pollctr = pollevent(); + EntInterp; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif /* Polling */ + + +#endif /* LineCodes */ + + break; + + + case Op_Colm: /* source column number */ + { +#ifdef EventMon + word loc; + column = GetWord; + loc = column; + loc <<= (WordBits >> 1); /* column in high-order part */ + loc += linenum; + InterpEVVal(loc, E_Loc); +#endif /* EventMon */ + break; + } + + case Op_Line: /* source line number */ + +#ifdef LineCodes +#ifdef Polling + if (!pollctr--) { + ExInterp; + pollctr = pollevent(); + EntInterp; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif /* Polling */ + + +#endif /* LineCodes */ + +#ifdef EventMon + linenum = GetWord; + lastline = linenum; +#endif /* EventMon */ + + break; + + /* ---String Scanning--- */ + + case Op_Bscan: /* prepare for scanning */ + PushDesc(k_subject); + PushVal(D_Integer); + PushVal(k_pos); + Setup_Arg(2); + + signal = Obscan(2,rargp); + + goto C_rtn_term; + + case Op_Escan: /* exit from scanning */ + Setup_Arg(1); + + signal = Oescan(1,rargp); + + goto C_rtn_term; + + /* ---Other Language Operations--- */ + + case Op_Apply: { /* apply */ + union block *bp; + int i, j; + + value_tmp = *(dptr)(rsp - 1); /* argument */ + Deref(value_tmp); + switch (Type(value_tmp)) { + case T_List: { + rsp -= 2; /* pop it off */ + bp = BlkLoc(value_tmp); + args = (int)bp->list.size; + +#ifndef MultiThread + /* + * Make a stab at catching interpreter stack overflow. + * This does nothing for invocation in a co-expression other + * than &main. + */ + if (BlkLoc(k_current) == BlkLoc(k_main) && + ((char *)sp + args * sizeof(struct descrip) > + (char *)stackend)) + fatalerr(301, NULL); +#endif /* MultiThread */ + + for (bp = bp->list.listhead; +#ifdef ListFix + BlkType(bp) == T_Lelem; +#else /* ListFix */ + bp != NULL; +#endif /* ListFix */ + bp = bp->lelem.listnext) { + for (i = 0; i < bp->lelem.nused; i++) { + j = bp->lelem.first + i; + if (j >= bp->lelem.nslots) + j -= bp->lelem.nslots; + PushDesc(bp->lelem.lslots[j]); + } + } + goto invokej; + } + + case T_Record: { + rsp -= 2; /* pop it off */ + bp = BlkLoc(value_tmp); + args = bp->record.recdesc->proc.nfields; + for (i = 0; i < args; i++) { + PushDesc(bp->record.fields[i]); + } + goto invokej; + } + + default: { /* illegal type for invocation */ + + xargp = (dptr)(rsp - 3); + err_msg(126, &value_tmp); + goto efail; + } + } + } + + case Op_Invoke: { /* invoke */ + args = (int)GetWord; +invokej: + { + int nargs; + dptr carg; + + ExInterp; + type = invoke(args, &carg, &nargs); + EntInterp; + + if (type == I_Fail) + goto efail_noev; + if (type == I_Continue) + break; + else { + + rargp = carg; /* valid only for Vararg or Builtin */ + +#ifdef Polling + /* + * Do polling here + */ + pollctr >>= 1; + if (!pollctr) { + ExInterp; + pollctr = pollevent(); + EntInterp; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif /* Polling */ + +#ifdef EventMon + lastev = E_Function; + InterpEVValD(rargp, E_Fcall); +#endif /* EventMon */ + + bproc = (struct b_proc *)BlkLoc(*rargp); + +#ifdef FncTrace + typedef int (*bfunc2)(dptr, struct descrip *); +#endif /* FncTrace */ + + + /* ExInterp not needed since no change since last EntInterp */ + if (type == I_Vararg) { + int (*bfunc)(); + bfunc = bproc->entryp.ccode; + +#ifdef FncTrace + signal = (*bfunc)(nargs, rargp, &(procs->pname)); +#else /* FncTrace */ + signal = (*bfunc)(nargs,rargp); +#endif /* FncTrace */ + + } + else + { + int (*bfunc)(); + bfunc = bproc->entryp.ccode; + +#ifdef FncTrace + signal = (*(bfunc2)bfunc)(rargp, &(bproc->pname)); +#else /* FncTrace */ + signal = (*bfunc)(rargp); +#endif /* FncTrace */ + } + +#ifdef FncTrace + if (k_ftrace) { + k_ftrace--; + if (signal == A_Failure) + failtrace(&(bproc->pname)); + else + rtrace(&(bproc->pname),rargp); + } +#endif /* FncTrace */ + + goto C_rtn_term; + } + } + } + + case Op_Keywd: /* keyword */ + + PushNull; + opnd = GetWord; + Setup_Arg(0); + + signal = (*(keytab[(int)opnd]))(rargp); + goto C_rtn_term; + + case Op_Llist: /* construct list */ + opnd = GetWord; + +#ifdef EventMon + lastev = E_Operator; + value_tmp.dword = D_Proc; + value_tmp.vword.bptr = (union block *)&mt_llist; + InterpEVValD(&value_tmp, E_Ocall); + rargp = (dptr)(rsp - 1) - opnd; + xargp = rargp; + ExInterp; +#else /* EventMon */ + Setup_Arg(opnd); +#endif /* EventMon */ + + { + int i; + for (i=1;i<=opnd;i++) + DerefArg(i); + } + + signal = Ollist((int)opnd,rargp); + + goto C_rtn_term; + + /* ---Marking and Unmarking--- */ + + case Op_Mark: /* create expression frame marker */ + PutOp(Op_Amark); + opnd = GetWord; + opnd += (word)ipc.opnd; + PutWord(opnd); + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = (word *)opnd; + goto mark; + + case Op_Amark: /* mark with absolute fipc */ + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = (word *)GetWord; +mark: + newefp->ef_gfp = gfp; + newefp->ef_efp = efp; + newefp->ef_ilevel = ilevel; + rsp += Wsizeof(*efp); + efp = newefp; + gfp = 0; + break; + + case Op_Mark0: /* create expression frame with 0 ipl */ +mark0: + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = 0; + newefp->ef_gfp = gfp; + newefp->ef_efp = efp; + newefp->ef_ilevel = ilevel; + rsp += Wsizeof(*efp); + efp = newefp; + gfp = 0; + break; + + case Op_Unmark: /* remove expression frame */ + +#ifdef EventMon + ExInterp; + vanq_bound(efp, gfp); + EntInterp; +#endif /* EventMon */ + + gfp = efp->ef_gfp; + rsp = (word *)efp - 1; + + /* + * Remove any suspended C generators. + */ +Unmark_uw: + if (efp->ef_ilevel < ilevel) { + --ilevel; + + ExInterp; + +#ifdef EventMon + EVVal(A_Unmark_uw, E_Intret); + EVVal(DiffPtrs(sp, stack), E_Stack); +#endif /* EventMon */ + + return A_Unmark_uw; + } + + efp = efp->ef_efp; + break; + + /* ---Suspensions--- */ + + case Op_Esusp: { /* suspend from expression */ + + /* + * Create the generator frame. + */ + oldsp = rsp; + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = G_Esusp; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + gfp = newgfp; + rsp += Wsizeof(struct gf_smallmarker); + + /* + * Region extends from first word after enclosing generator or + * expression frame marker to marker for current expression frame. + */ + if (efp->ef_gfp != 0) { + newgfp = (struct gf_marker *)(efp->ef_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp); + else + firstwd = (word *)efp->ef_gfp + + Wsizeof(struct gf_smallmarker); + } + else + firstwd = (word *)efp->ef_efp + Wsizeof(*efp); + lastwd = (word *)efp - 1; + efp = efp->ef_efp; + + /* + * Copy the portion of the stack with endpoints firstwd and lastwd + * (inclusive) to the top of the stack. + */ + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushVal(oldsp[-1]); + PushVal(oldsp[0]); + break; + } + + case Op_Lsusp: { /* suspend from limitation */ + struct descrip sval; + + /* + * The limit counter is contained in the descriptor immediately + * prior to the current expression frame. lval is established + * as a pointer to this descriptor. + */ + dptr lval = (dptr)((word *)efp - 2); + + /* + * Decrement the limit counter and check it. + */ + if (--IntVal(*lval) > 0) { + /* + * The limit has not been reached, set up stack. + */ + + sval = *(dptr)(rsp - 1); /* save result */ + + /* + * Region extends from first word after enclosing generator or + * expression frame marker to the limit counter just prior to + * to the current expression frame marker. + */ + if (efp->ef_gfp != 0) { + newgfp = (struct gf_marker *)(efp->ef_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp); + else + firstwd = (word *)efp->ef_gfp + + Wsizeof(struct gf_smallmarker); + } + else + firstwd = (word *)efp->ef_efp + Wsizeof(*efp); + lastwd = (word *)efp - 3; + if (gfp == 0) + gfp = efp->ef_gfp; + efp = efp->ef_efp; + + /* + * Copy the portion of the stack with endpoints firstwd and lastwd + * (inclusive) to the top of the stack. + */ + rsp -= 2; /* overwrite result */ + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushDesc(sval); /* push saved result */ + } + else { + /* + * Otherwise, the limit has been reached. Instead of + * suspending, remove the current expression frame and + * replace the limit counter with the value on top of + * the stack (which would have been suspended had the + * limit not been reached). + */ + *lval = *(dptr)(rsp - 1); + +#ifdef EventMon + ExInterp; + vanq_bound(efp, gfp); + EntInterp; +#endif /* EventMon */ + + gfp = efp->ef_gfp; + + /* + * Since an expression frame is being removed, inactive + * C generators contained therein are deactivated. + */ +Lsusp_uw: + if (efp->ef_ilevel < ilevel) { + --ilevel; + ExInterp; + +#ifdef EventMon + EVVal(A_Lsusp_uw, E_Intret); + EVVal(DiffPtrs(sp, stack), E_Stack); +#endif /* EventMon */ + + return A_Lsusp_uw; + } + rsp = (word *)efp - 1; + efp = efp->ef_efp; + } + break; + } + + case Op_Psusp: { /* suspend from procedure */ + + /* + * An Icon procedure is suspending a value. Determine if the + * value being suspended should be dereferenced and if so, + * dereference it. If tracing is on, strace is called + * to generate a message. Appropriate values are + * restored from the procedure frame of the suspending procedure. + */ + + struct descrip tmp; + dptr svalp; + struct b_proc *sproc; + +#ifdef EventMon + value_tmp = *(dptr)(rsp - 1); /* argument */ + Deref(value_tmp); + InterpEVValD(&value_tmp, E_Psusp); +#endif /* EventMon */ + + svalp = (dptr)(rsp - 1); + if (Var(*svalp)) { + ExInterp; + retderef(svalp, (word *)glbl_argp, sp); + EntInterp; + } + + /* + * Create the generator frame. + */ + oldsp = rsp; + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = G_Psusp; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + newgfp->gf_argp = glbl_argp; + newgfp->gf_pfp = pfp; + gfp = newgfp; + rsp += Wsizeof(*gfp); + + /* + * Region extends from first word after the marker for the + * generator or expression frame enclosing the call to the + * now-suspending procedure to Arg0 of the procedure. + */ + if (pfp->pf_gfp != 0) { + newgfp = (struct gf_marker *)(pfp->pf_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)pfp->pf_gfp + Wsizeof(*gfp); + else + firstwd = (word *)pfp->pf_gfp + + Wsizeof(struct gf_smallmarker); + } + else + firstwd = (word *)pfp->pf_efp + Wsizeof(*efp); + lastwd = (word *)glbl_argp - 1; + efp = efp->ef_efp; + + /* + * Copy the portion of the stack with endpoints firstwd and lastwd + * (inclusive) to the top of the stack. + */ + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushVal(oldsp[-1]); + PushVal(oldsp[0]); + --k_level; + if (k_trace) { + k_trace--; + sproc = (struct b_proc *)BlkLoc(*glbl_argp); + strace(&(sproc->pname), svalp); + } + + /* + * If the scanning environment for this procedure call is in + * a saved state, switch environments. + */ + if (pfp->pf_scan != NULL) { + +#ifdef EventMon + InterpEVValD(&k_subject, E_Ssusp); +#endif /* EventMon */ + + tmp = k_subject; + k_subject = *pfp->pf_scan; + *pfp->pf_scan = tmp; + + tmp = *(pfp->pf_scan + 1); + IntVal(*(pfp->pf_scan + 1)) = k_pos; + k_pos = IntVal(tmp); + } + +#ifdef MultiThread + /* + * If the program state changed for this procedure call, + * change back. + */ + ENTERPSTATE(pfp->pf_prog); +#endif /* MultiThread */ + + efp = pfp->pf_efp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + break; + } + + /* ---Returns--- */ + + case Op_Eret: { /* return from expression */ + /* + * Op_Eret removes the current expression frame, leaving the + * original top of stack value on top. + */ + /* + * Save current top of stack value in global temporary (no + * danger of reentry). + */ + eret_tmp = *(dptr)&rsp[-1]; + gfp = efp->ef_gfp; +Eret_uw: + /* + * Since an expression frame is being removed, inactive + * C generators contained therein are deactivated. + */ + if (efp->ef_ilevel < ilevel) { + --ilevel; + ExInterp; + +#ifdef EventMon + EVVal(A_Eret_uw, E_Intret); + EVVal(DiffPtrs(sp, stack), E_Stack); +#endif /* EventMon */ + + return A_Eret_uw; + } + rsp = (word *)efp - 1; + efp = efp->ef_efp; + PushDesc(eret_tmp); + break; + } + + + case Op_Pret: { /* return from procedure */ +#ifdef EventMon + struct descrip oldargp; + static struct descrip unwinder; +#endif /* EventMon */ + + /* + * An Icon procedure is returning a value. Determine if the + * value being returned should be dereferenced and if so, + * dereference it. If tracing is on, rtrace is called to + * generate a message. Inactive generators created after + * the activation of the procedure are deactivated. Appropriate + * values are restored from the procedure frame. + */ + struct b_proc *rproc; + rproc = (struct b_proc *)BlkLoc(*glbl_argp); +#ifdef EventMon + oldargp = *glbl_argp; + ExInterp; + vanq_proc(efp, gfp); + EntInterp; + /* used to InterpEVValD(argp,E_Pret); here */ +#endif /* EventMon */ + + *glbl_argp = *(dptr)(rsp - 1); + if (Var(*glbl_argp)) { + ExInterp; + retderef(glbl_argp, (word *)glbl_argp, sp); + EntInterp; + } + + --k_level; + if (k_trace) { + k_trace--; + rtrace(&(rproc->pname), glbl_argp); + } +Pret_uw: + if (pfp->pf_ilevel < ilevel) { + --ilevel; + ExInterp; + +#ifdef EventMon + EVVal(A_Pret_uw, E_Intret); + EVVal(DiffPtrs(sp, stack), E_Stack); + unwinder = oldargp; +#endif /* EventMon */ + + return A_Pret_uw; + } + +#ifdef EventMon + if (!is:proc(oldargp) && is:proc(unwinder)) + oldargp = unwinder; +#endif /* EventMon */ + rsp = (word *)glbl_argp + 1; + efp = pfp->pf_efp; + gfp = pfp->pf_gfp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + +#ifdef MultiThread + if (pfp) + ENTERPSTATE(pfp->pf_prog); +#ifdef EventMon + value_tmp = *(dptr)(rsp - 1); /* argument */ + Deref(value_tmp); + InterpEVValD(&value_tmp, E_Pret); +#endif /* EventMon */ +#endif /* MultiThread */ + break; + } + + /* ---Failures--- */ + + case Op_Efail: +efail: +#ifdef EventMon + InterpEVVal((word)-1, E_Efail); +#endif /* EventMon */ +efail_noev: + /* + * Failure has occurred in the current expression frame. + */ + if (gfp == 0) { + /* + * There are no suspended generators to resume. + * Remove the current expression frame, restoring + * values. + * + * If the failure ipc is 0, propagate failure to the + * enclosing frame by branching back to efail. + * This happens, for example, in looping control + * structures that fail when complete. + */ + +#ifdef MultiThread + if (efp == 0) { + break; + } +#endif /* MultiThread */ + + ipc = efp->ef_failure; + gfp = efp->ef_gfp; + rsp = (word *)efp - 1; + efp = efp->ef_efp; + + if (ipc.op == 0) + goto efail; + break; + } + + else { + /* + * There is a generator that can be resumed. Make + * the stack adjustments and then switch on the + * type of the generator frame marker. + */ + struct descrip tmp; + register struct gf_marker *resgfp = gfp; + + type = (int)resgfp->gf_gentype; + + if (type == G_Psusp) { + glbl_argp = resgfp->gf_argp; + if (k_trace) { /* procedure tracing */ + k_trace--; + ExInterp; + atrace(&(((struct b_proc *)BlkLoc(*glbl_argp))->pname)); + EntInterp; + } + } + ipc = resgfp->gf_ipc; + efp = resgfp->gf_efp; + gfp = resgfp->gf_gfp; + rsp = (word *)resgfp - 1; + if (type == G_Psusp) { + pfp = resgfp->gf_pfp; + + /* + * If the scanning environment for this procedure call is + * supposed to be in a saved state, switch environments. + */ + if (pfp->pf_scan != NULL) { + tmp = k_subject; + k_subject = *pfp->pf_scan; + *pfp->pf_scan = tmp; + + tmp = *(pfp->pf_scan + 1); + IntVal(*(pfp->pf_scan + 1)) = k_pos; + k_pos = IntVal(tmp); + +#ifdef EventMon + InterpEVValD(&k_subject, E_Sresum); +#endif /* EventMon */ + } + +#ifdef MultiThread + /* + * Enter the program state of the resumed frame + */ + ENTERPSTATE(pfp->pf_prog); +#endif /* MultiThread */ + + ++k_level; /* adjust procedure level */ + } + + switch (type) { + +#ifdef EventMon + case G_Fsusp: + InterpEVVal((word)0, E_Fresum); + --ilevel; + ExInterp; + EVVal(A_Resume, E_Intret); + EVVal(DiffPtrs(sp, stack), E_Stack); + return A_Resume; + + case G_Osusp: + InterpEVVal((word)0, E_Oresum); + --ilevel; + ExInterp; + EVVal(A_Resume, E_Intret); + EVVal(DiffPtrs(sp, stack), E_Stack); + return A_Resume; +#endif /* EventMon */ + + case G_Csusp: + InterpEVVal((word)0, E_Eresum); + --ilevel; + ExInterp; +#ifdef EventMon + EVVal(A_Resume, E_Intret); + EVVal(DiffPtrs(sp, stack), E_Stack); +#endif /* EventMon */ + return A_Resume; + + case G_Esusp: + InterpEVVal((word)0, E_Eresum); + goto efail_noev; + + case G_Psusp: /* resuming a procedure */ + InterpEVValD(glbl_argp, E_Presum); + break; + } + + break; + } + + case Op_Pfail: { /* fail from procedure */ + +#ifdef EventMon + ExInterp; + vanq_proc(efp, gfp); + EVValD(glbl_argp, E_Pfail); + EntInterp; +#endif /* EventMon */ + + /* + * An Icon procedure is failing. Generate tracing message if + * tracing is on. Deactivate inactive C generators created + * after activation of the procedure. Appropriate values + * are restored from the procedure frame. + */ + + --k_level; + if (k_trace) { + k_trace--; + failtrace(&(((struct b_proc *)BlkLoc(*glbl_argp))->pname)); + } +Pfail_uw: + + if (pfp->pf_ilevel < ilevel) { + --ilevel; + ExInterp; +#ifdef EventMon + EVVal(A_Pfail_uw, E_Intret); + EVVal(DiffPtrs(sp, stack), E_Stack); +#endif /* EventMon */ + return A_Pfail_uw; + } + efp = pfp->pf_efp; + gfp = pfp->pf_gfp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + +#ifdef MultiThread + /* + * Enter the program state of the procedure being reentered. + * A NULL pfp indicates the program is complete. + */ + if (pfp) { + ENTERPSTATE(pfp->pf_prog); + } +#endif /* MultiThread */ + + goto efail_noev; + } + /* ---Odds and Ends--- */ + + case Op_Ccase: /* case clause */ + PushNull; + PushVal(((word *)efp)[-2]); + PushVal(((word *)efp)[-1]); + break; + + case Op_Chfail: /* change failure ipc */ + opnd = GetWord; + opnd += (word)ipc.opnd; + efp->ef_failure.opnd = (word *)opnd; + break; + + case Op_Dup: /* duplicate descriptor */ + PushNull; + rsp[1] = rsp[-3]; + rsp[2] = rsp[-2]; + rsp += 2; + break; + + case Op_Field: /* e1.e2 */ + PushVal(D_Integer); + PushVal(GetWord); + Setup_Arg(2); + + signal = Ofield(2,rargp); + + goto C_rtn_term; + + case Op_Goto: /* goto */ + PutOp(Op_Agoto); + opnd = GetWord; + opnd += (word)ipc.opnd; + PutWord(opnd); + ipc.opnd = (word *)opnd; + break; + + case Op_Agoto: /* goto absolute address */ + opnd = GetWord; + ipc.opnd = (word *)opnd; + break; + + case Op_Init: /* initial */ + *--ipc.op = Op_Goto; + opnd = sizeof(*ipc.op) + sizeof(*rsp); + opnd += (word)ipc.opnd; + ipc.opnd = (word *)opnd; + break; + + case Op_Limit: /* limit */ + Setup_Arg(0); + + if (Olimit(0,rargp) == A_Resume) { + + /* + * limit has failed here; could generate an event for it, + * but not an Ofail since limit is not an operator and + * no Ocall was ever generated for it. + */ + goto efail_noev; + } + else { + /* + * limit has returned here; could generate an event for it, + * but not an Oret since limit is not an operator and + * no Ocall was ever generated for it. + */ + rsp = (word *) rargp + 1; + } + goto mark0; + +#ifdef TallyOpt + case Op_Tally: /* tally */ + tallybin[GetWord]++; + break; +#endif /* TallyOpt */ + + case Op_Pnull: /* push null descriptor */ + PushNull; + break; + + case Op_Pop: /* pop descriptor */ + rsp -= 2; + break; + + case Op_Push1: /* push integer 1 */ + PushVal(D_Integer); + PushVal(1); + break; + + case Op_Pushn1: /* push integer -1 */ + PushVal(D_Integer); + PushVal(-1); + break; + + case Op_Sdup: /* duplicate descriptor */ + rsp += 2; + rsp[-1] = rsp[-3]; + rsp[0] = rsp[-2]; + break; + + /* ---Co-expressions--- */ + + case Op_Create: /* create */ + +#ifdef Coexpr + PushNull; + Setup_Arg(0); + opnd = GetWord; + opnd += (word)ipc.opnd; + + signal = Ocreate((word *)opnd, rargp); + + goto C_rtn_term; +#else /* Coexpr */ + err_msg(401, NULL); + goto efail; +#endif /* Coexpr */ + + case Op_Coact: { /* @e */ + +#ifndef Coexpr + err_msg(401, NULL); + goto efail; +#else /* Coexpr */ + struct b_coexpr *ncp; + dptr dp; + + ExInterp; + dp = (dptr)(sp - 1); + xargp = dp - 2; + + Deref(*dp); + if (dp->dword != D_Coexpr) { + err_msg(118, dp); + goto efail; + } + + ncp = (struct b_coexpr *)BlkLoc(*dp); + + signal = activate((dptr)(sp - 3), ncp, (dptr)(sp - 3)); + EntInterp; + if (signal == A_Resume) + goto efail_noev; + else + rsp -= 2; +#endif /* Coexpr */ + break; + } + + case Op_Coret: { /* return from co-expression */ + +#ifndef Coexpr + syserr("co-expression return, but co-expressions not implemented"); +#else /* Coexpr */ + struct b_coexpr *ncp; + + ExInterp; + ncp = popact((struct b_coexpr *)BlkLoc(k_current)); + + ++BlkLoc(k_current)->coexpr.size; + co_chng(ncp, (dptr)&sp[-1], NULL, A_Coret, 1); + EntInterp; +#endif /* Coexpr */ + break; + + } + + case Op_Cofail: { /* fail from co-expression */ + +#ifndef Coexpr + syserr("co-expression failure, but co-expressions not implemented"); +#else /* Coexpr */ + struct b_coexpr *ncp; + + ExInterp; + ncp = popact((struct b_coexpr *)BlkLoc(k_current)); + + co_chng(ncp, NULL, NULL, A_Cofail, 1); + EntInterp; +#endif /* Coexpr */ + break; + + } + case Op_Quit: /* quit */ + + + goto interp_quit; + + + default: { + char buf[50]; + + sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n", + (long)lastop, lastop); + syserr(buf); + } + } + continue; + +C_rtn_term: + EntInterp; + + switch (signal) { + + case A_Resume: +#ifdef EventMon + if ((lastev == E_Function) || (lastev == E_Operator)) { + InterpEVVal((word)-1, + ((lastev == E_Function)? E_Ffail : E_Ofail)); + lastev = E_Misc; + } +#endif /* EventMon */ + goto efail_noev; + + case A_Unmark_uw: /* unwind for unmark */ +#ifdef EventMon + if ((lastev == E_Function) || (lastev == E_Operator)) { + InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); + lastev = E_Misc; + } +#endif /* EventMon */ + goto Unmark_uw; + + case A_Lsusp_uw: /* unwind for lsusp */ +#ifdef EventMon + if ((lastev == E_Function) || (lastev == E_Operator)) { + InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); + lastev = E_Misc; + } +#endif /* EventMon */ + goto Lsusp_uw; + + case A_Eret_uw: /* unwind for eret */ +#ifdef EventMon + if ((lastev == E_Function) || (lastev == E_Operator)) { + InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); + lastev = E_Misc; + } +#endif /* EventMon */ + goto Eret_uw; + + case A_Pret_uw: /* unwind for pret */ +#ifdef EventMon + if ((lastev == E_Function) || (lastev == E_Operator)) { + InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); + lastev = E_Misc; + } +#endif /* EventMon */ + goto Pret_uw; + + case A_Pfail_uw: /* unwind for pfail */ +#ifdef EventMon + if ((lastev == E_Function) || (lastev == E_Operator)) { + InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); + lastev = E_Misc; + } +#endif /* EventMon */ + goto Pfail_uw; + } + + rsp = (word *)rargp + 1; /* set rsp to result */ + +#ifdef EventMon +return_term: + value_tmp = *(dptr)(rsp - 1); /* argument */ + Deref(value_tmp); + if ((lastev == E_Function) || (lastev == E_Operator)) { + InterpEVValD(&value_tmp, ((lastev == E_Function) ? E_Fret:E_Oret)); + lastev = E_Misc; + } +#endif /* EventMon */ + + continue; + } + +interp_quit: + --ilevel; + if (ilevel != 0) + syserr("interp: termination with inactive generators."); + /*NOTREACHED*/ + return 0; /* avoid gcc warning */ + } + +#ifdef EventMon +/* + * vanq_proc - monitor the removal of suspended operations from within + * a procedure. + */ +static void vanq_proc(efp_v, gfp_v) +struct ef_marker *efp_v; +struct gf_marker *gfp_v; + { + + if (is:null(curpstate->eventmask)) + return; + + /* + * Go through all the bounded expression of the procedure. + */ + while ((efp_v = vanq_bound(efp_v, gfp_v)) != NULL) { + gfp_v = efp_v->ef_gfp; + efp_v = efp_v->ef_efp; + } + } + +/* + * vanq_bound - monitor the removal of suspended operations from + * the current bounded expression and return the expression frame + * pointer for the bounded expression. + */ +static struct ef_marker *vanq_bound(efp_v, gfp_v) +struct ef_marker *efp_v; +struct gf_marker *gfp_v; + { + + if (is:null(curpstate->eventmask)) + return efp_v; + + while (gfp_v != 0) { /* note removal of suspended operations */ + switch ((int)gfp_v->gf_gentype) { + case G_Psusp: + EVValD(gfp_v->gf_argp, E_Prem); + break; + /* G_Fsusp and G_Osusp handled in-line during unwinding */ + case G_Esusp: + EVVal((word)0, E_Erem); + break; + } + + if (((int)gfp_v->gf_gentype) == G_Psusp) { + vanq_proc(gfp_v->gf_efp, gfp_v->gf_gfp); + efp_v = gfp_v->gf_pfp->pf_efp; /* efp before the call */ + gfp_v = gfp_v->gf_pfp->pf_gfp; /* gfp before the call */ + } + else { + efp_v = gfp_v->gf_efp; + gfp_v = gfp_v->gf_gfp; + } + } + + return efp_v; + } +#endif /* EventMon */ + +#ifdef MultiThread +/* + * activate some other co-expression from an arbitrary point in + * the interpreter. + */ +int mt_activate(tvalp,rslt,ncp) +dptr tvalp, rslt; +register struct b_coexpr *ncp; +{ + register struct b_coexpr *ccp = (struct b_coexpr *)BlkLoc(k_current); + int first, rv; + + dptr savedtvalloc = NULL; + /* + * Set activator in new co-expression. + */ + if (ncp->es_actstk == NULL) { + Protect(ncp->es_actstk = alcactiv(), { err_msg(0, NULL); exit(1); }); + /* + * If no one ever explicitly activates this co-expression, fail to + * the implicit activator. + */ + ncp->es_actstk->arec[0].activator = ccp; + first = 0; + } + else + first = 1; + + if(ccp->tvalloc) { + if (InRange(blkbase,ccp->tvalloc,blkfree)) { + fprintf(stderr, + "Multiprogram garbage collection disaster in mt_activate()!\n"); + fflush(stderr); + exit(1); + } + savedtvalloc = ccp->tvalloc; + } + + rv = co_chng(ncp, tvalp, rslt, A_MTEvent, first); + + if ((savedtvalloc != NULL) && (savedtvalloc != ccp->tvalloc)) { + fprintf(stderr,"averted co-expression disaster in activate\n"); + ccp->tvalloc = savedtvalloc; + } + + return rv; +} + + +/* + * activate the "&parent" co-expression from anywhere, if there is one + */ +void actparent(event) +int event; + { + struct progstate *parent = curpstate->parent; + + StrLen(parent->eventcode) = 1; + StrLoc(parent->eventcode) = (char *)&allchars[event & 0xFF]; + mt_activate(&(parent->eventcode), NULL, + (struct b_coexpr *)curpstate->parent->Mainhead); + } +#endif /* MultiThread */ +#endif /* !COMPILER */ diff --git a/src/runtime/invoke.r b/src/runtime/invoke.r new file mode 100644 index 0000000..87b9fd1 --- /dev/null +++ b/src/runtime/invoke.r @@ -0,0 +1,377 @@ +/* + * invoke.r - contains invoke, apply + */ + +#if COMPILER + +/* + * invoke - perform general invocation on a value. + */ +int invoke(nargs, args, rslt, succ_cont) +int nargs; +dptr args; +dptr rslt; +continuation succ_cont; + { + tended struct descrip callee; + struct b_proc *proc; + C_integer n; + + /* + * remove the operation being called from the argument list. + */ + deref(&args[0], &callee); + ++args; + nargs -= 1; + + if (is:proc(callee)) + return (*((struct b_proc *)BlkLoc(callee))->ccode)(nargs, args, rslt, + succ_cont); + else if (cnv:C_integer(callee, n)) { + if (n <= 0) + n += nargs + 1; + if (n <= 0 || n > nargs) + return A_Resume; + *rslt = args[n - 1]; + return A_Continue; + } + else if (cnv:string(callee, callee)) { + proc = strprc(&callee, (C_integer)nargs); + if (proc == NULL) + RunErr(106, &callee); + return (*(proc)->ccode)(nargs, args, rslt, succ_cont); + } + else + RunErr(106, &callee); + } + + +/* + * apply - implement binary bang. Construct an argument list for + * invoke() from the callee and the list it is applied to. + */ +int apply(callee, strct, rslt, succ_cont) +dptr callee; +dptr strct; +dptr rslt; +continuation succ_cont; + { + tended struct descrip dstrct; + struct tend_desc *tnd_args; /* place to tend arguments to invoke() */ + union block *ep; + int nargs; + word i, j; + word indx; + int signal; + + deref(strct, &dstrct); + + switch (Type(dstrct)) { + + case T_List: { + /* + * Copy the arguments from the list into an tended array of descriptors. + */ + nargs = BlkLoc(dstrct)->list.size + 1; + tnd_args = malloc(sizeof(struct tend_desc) + + (nargs - 1) * sizeof(struct descrip)); + if (tnd_args == NULL) + RunErr(305, NULL); + + tnd_args->d[0] = *callee; + indx = 1; + for (ep = BlkLoc(dstrct)->list.listhead; +#ifdef ListFix + BlkType(ep) == T_Lelem; +#else /* ListFix */ + ep != NULL; +#endif /* ListFix */ + ep = ep->lelem.listnext) { + for (i = 0; i < ep->lelem.nused; i++) { + j = ep->lelem.first + i; + if (j >= ep->lelem.nslots) + j -= ep->lelem.nslots; + tnd_args->d[indx++] = ep->lelem.lslots[j]; + } + } + tnd_args->num = nargs; + tnd_args->previous = tend; + tend = tnd_args; + + signal = invoke(indx, tnd_args->d, rslt, succ_cont); + + tend = tnd_args->previous; + free(tnd_args); + return signal; + } + case T_Record: { + /* + * Copy the arguments from the record into an tended array + * of descriptors. + */ + nargs = BlkLoc(dstrct)->record.recdesc->proc.nfields; + tnd_args = malloc(sizeof(struct tend_desc) + + (nargs - 1) * sizeof(struct descrip)); + if (tnd_args == NULL) + RunErr(305, NULL); + + tnd_args->d[0] = *callee; + indx = 1; + ep = BlkLoc(dstrct); + for (i = 0; i < nargs; i++) + tnd_args->d[indx++] = ep->record.fields[i]; + tnd_args->num = nargs; + tnd_args->previous = tend; + tend = tnd_args; + + signal = invoke(indx, tnd_args->d, rslt, succ_cont); + + tend = tnd_args->previous; + free(tnd_args); + return signal; + } + default: { + RunErr(126, &dstrct); + } + } + } + +#else /* COMPILER */ + +#ifdef EventMon +#include "../h/opdefs.h" +#endif /* EventMon */ + + +/* + * invoke -- Perform setup for invocation. + */ +int invoke(nargs,cargp,n) +dptr *cargp; +int nargs, *n; +{ + register struct pf_marker *newpfp; + register dptr newargp; + register word *newsp = sp; + tended struct descrip arg_sv; + register word i; + struct b_proc *proc; + int nparam; + + /* + * Point newargp at Arg0 and dereference it. + */ + newargp = (dptr )(sp - 1) - nargs; + + xnargs = nargs; + xargp = newargp; + + Deref(newargp[0]); + + /* + * See what course the invocation is to take. + */ + if (newargp->dword != D_Proc) { + C_integer tmp; + /* + * Arg0 is not a procedure. + */ + + if (cnv:C_integer(newargp[0], tmp)) { + MakeInt(tmp,&newargp[0]); + + /* + * Arg0 is an integer, select result. + */ + i = cvpos(IntVal(newargp[0]), (word)nargs); + if (i == CvtFail || i > nargs) + return I_Fail; + newargp[0] = newargp[i]; + sp = (word *)newargp + 1; + return I_Continue; + } + else { + struct b_proc *tmp; + /* + * See if Arg0 can be converted to a string that names a procedure + * or operator. If not, generate run-time error 106. + */ + if (!cnv:tmp_string(newargp[0],newargp[0]) || + ((tmp = strprc(newargp, (C_integer)nargs)) == NULL)) { + err_msg(106, newargp); + return I_Fail; + } + BlkLoc(newargp[0]) = (union block *)tmp; + newargp[0].dword = D_Proc; + } + } + + /* + * newargp[0] is now a descriptor suitable for invocation. Dereference + * the supplied arguments. + */ + + proc = (struct b_proc *)BlkLoc(newargp[0]); + if (proc->nstatic >= 0) /* if negative, don't reference arguments */ + for (i = 1; i <= nargs; i++) + Deref(newargp[i]); + + /* + * Adjust the argument list to conform to what the routine being invoked + * expects (proc->nparam). If nparam is less than 0, the number of + * arguments is variable. For functions (ndynam = -1) with a + * variable number of arguments, nothing need be done. For Icon procedures + * with a variable number of arguments, arguments beyond abs(nparam) are + * put in a list which becomes the last argument. For fix argument + * routines, if too many arguments were supplied, adjusting the stack + * pointer is all that is necessary. If too few arguments were supplied, + * null descriptors are pushed for each missing argument. + */ + + proc = (struct b_proc *)BlkLoc(newargp[0]); + nparam = (int)proc->nparam; + if (nparam >= 0) { + if (nargs > nparam) + newsp -= (nargs - nparam) * 2; + else if (nargs < nparam) { + i = nparam - nargs; + while (i--) { + *++newsp = D_Null; + *++newsp = 0; + } + } + nargs = nparam; + + xnargs = nargs; + + } + else { + if (proc->ndynam >= 0) { /* this is a procedure */ + int lelems; + dptr llargp; + + if (nargs < abs(nparam) - 1) { + i = abs(nparam) - 1 - nargs; + while (i--) { + *++newsp = D_Null; + *++newsp = 0; + } + nargs = abs(nparam) - 1; + } + + lelems = nargs - (abs(nparam) - 1); + llargp = &newargp[abs(nparam)]; + arg_sv = llargp[-1]; + + Ollist(lelems, &llargp[-1]); + + llargp[0] = llargp[-1]; + llargp[-1] = arg_sv; + /* + * Reload proc pointer in case Ollist triggered a garbage collection. + */ + proc = (struct b_proc *)BlkLoc(newargp[0]); + newsp = (word *)llargp + 1; + nargs = abs(nparam); + } + } + + if (proc->ndynam < 0) { + /* + * A function is being invoked, so nothing else here needs to be done. + */ + + if (nargs < abs(nparam) - 1) { + i = abs(nparam) - 1 - nargs; + while (i--) { + *++newsp = D_Null; + *++newsp = 0; + } + nargs = abs(nparam) - 1; + } + + *n = nargs; + *cargp = newargp; + sp = newsp; + + EVVal((word)Op_Invoke,E_Ecall); + + if ((nparam < 0) || (proc->ndynam == -2)) + return I_Vararg; + else + return I_Builtin; + } + +#ifndef MultiThread + /* + * Make a stab at catching interpreter stack overflow. This does + * nothing for invocation in a co-expression other than &main. + */ + if (BlkLoc(k_current) == BlkLoc(k_main) && + ((char *)sp + PerilDelta) > (char *)stackend) + fatalerr(301, NULL); +#endif /* MultiThread */ + + /* + * Build the procedure frame. + */ + newpfp = (struct pf_marker *)(newsp + 1); + newpfp->pf_nargs = nargs; + newpfp->pf_argp = glbl_argp; + newpfp->pf_pfp = pfp; + newpfp->pf_ilevel = ilevel; + newpfp->pf_scan = NULL; + + newpfp->pf_ipc = ipc; + newpfp->pf_gfp = gfp; + newpfp->pf_efp = efp; + +#ifdef MultiThread + newpfp->pf_prog = curpstate; +#endif /* MultiThread */ + + glbl_argp = newargp; + pfp = newpfp; + newsp += Vwsizeof(*pfp); + + /* + * If tracing is on, use ctrace to generate a message. + */ + if (k_trace) { + k_trace--; + ctrace(&(proc->pname), nargs, &newargp[1]); + } + + /* + * Point ipc at the icode entry point of the procedure being invoked. + */ + ipc.opnd = (word *)proc->entryp.icode; + +#ifdef MultiThread + /* + * Enter the program state of the procedure being invoked. + */ + if (!InRange(code, ipc.opnd, ecode)) { + syserr("interprogram procedure calls temporarily prohibited\n"); + } +#endif /* MultiThread */ + + efp = 0; + gfp = 0; + + /* + * Push a null descriptor on the stack for each dynamic local. + */ + for (i = proc->ndynam; i > 0; i--) { + *++newsp = D_Null; + *++newsp = 0; + } + sp = newsp; + k_level++; + + EVValD(newargp, E_Pcall); + + return I_Continue; +} + +#endif /* COMPILER */ diff --git a/src/runtime/keyword.r b/src/runtime/keyword.r new file mode 100644 index 0000000..e6eb462 --- /dev/null +++ b/src/runtime/keyword.r @@ -0,0 +1,752 @@ +/* + * File: keyword.r + * Contents: all keywords + * + * After adding keywords, be sure to rerun ../icont/mkkwd. + */ + +#define KDef(p,n) int Cat(K,p) (dptr cargp); +#include "../h/kdefs.h" +#undef KDef + +"&allocated - the space used in the storage regions:" +" total, static, string, and block" +keyword{4} allocated + abstract { + return integer + } + inline { + suspend C_integer stattotal + strtotal + blktotal; + suspend C_integer stattotal; + suspend C_integer strtotal; + return C_integer blktotal; + } +end + +"&clock - a string consisting of the current time of day" +keyword{1} clock + abstract { + return string + } + inline { + time_t t; + struct tm *ct; + char sbuf[9], *tmp; + + time(&t); + ct = localtime(&t); + sprintf(sbuf,"%02d:%02d:%02d", ct->tm_hour, ct->tm_min, ct->tm_sec); + Protect(tmp = alcstr(sbuf,(word)8), runerr(0)); + return string(8, tmp); + } +end + +"&collections - the number of collections: total, triggered by static requests" +" triggered by string requests, and triggered by block requests" +keyword{4} collections + abstract { + return integer + } + inline { + suspend C_integer coll_tot; + suspend C_integer coll_stat; + suspend C_integer coll_str; + return C_integer coll_blk; + } +end + +#if !COMPILER +"&column - source column number of current execution point" +keyword{1} column + abstract { + return integer; + } + inline { +#ifdef MultiThread +#ifdef EventMon + return C_integer findcol(ipc.opnd); +#else /* EventMon */ + fail; +#endif /* EventMon */ +#else + fail; +#endif /* MultiThread */ + } +end +#endif /* !COMPILER */ + +"¤t - the currently active co-expression" +keyword{1} current + abstract { + return coexpr + } + inline { + return k_current; + } +end + +"&date - the current date" +keyword{1} date + abstract { + return string + } + inline { + time_t t; + struct tm *ct; + char sbuf[11], *tmp; + + time(&t); + ct = localtime(&t); + sprintf(sbuf, "%04d/%02d/%02d", + 1900 + ct->tm_year, ct->tm_mon + 1, ct->tm_mday); + Protect(tmp = alcstr(sbuf,(word)10), runerr(0)); + return string(10, tmp); + } +end + +"&dateline - current date and time" +keyword{1} dateline + abstract { + return string + } + body { + static char *day[] = { + "Sunday", "Monday", "Tuesday", "Wednesday", + "Thursday", "Friday", "Saturday" + }; + static char *month[] = { + "January", "February", "March", "April", "May", "June", + "July", "August", "September", "October", "November", "December" + }; + time_t t; + struct tm *ct; + char sbuf[MaxCvtLen]; + int hour; + char *merid, *tmp; + int i; + + time(&t); + ct = localtime(&t); + if ((hour = ct->tm_hour) >= 12) { + merid = "pm"; + if (hour > 12) + hour -= 12; + } + else { + merid = "am"; + if (hour < 1) + hour += 12; + } + sprintf(sbuf, "%s, %s %d, %d %d:%02d %s", day[ct->tm_wday], + month[ct->tm_mon], ct->tm_mday, 1900 + ct->tm_year, hour, + ct->tm_min, merid); + i = strlen(sbuf); + Protect(tmp = alcstr(sbuf, i), runerr(0)); + return string(i, tmp); + } +end + +"&digits - a cset consisting of the 10 decimal digits" +keyword{1} digits + constant '0123456789' +end + +"&e - the base of the natural logarithms" +keyword{1} e + constant 2.71828182845904523536028747135266249775724709369996 +end + +"&error - enable/disable error conversion" +keyword{1} error + abstract { + return kywdint + } + inline { + return kywdint(&kywd_err); + } +end + +"&errornumber - error number of last error converted to failure" +keyword{0,1} errornumber + abstract { + return integer + } + inline { + if (k_errornumber == 0) + fail; + return C_integer k_errornumber; + } +end + +"&errortext - error message of last error converted to failure" +keyword{0,1} errortext + abstract { + return string + } + inline { + if (k_errornumber == 0) + fail; + return C_string k_errortext; + } +end + +"&errorvalue - erroneous value of last error converted to failure" +keyword{0,1} errorvalue + abstract { + return any_value + } + inline { + if (have_errval) + return k_errorvalue; + else + fail; + } +end + +"&errout - standard error output." +keyword{1} errout + abstract { + return file + } + inline { + return file(&k_errout); + } +end + +"&fail - just fail" +keyword{0} fail + abstract { + return empty_type + } + inline { + fail; + } +end + +"&eventcode - event in monitored program" +keyword{0,1} eventcode + abstract { + return kywdevent + } + inline { + return kywdevent(&k_eventcode); + } +end + +"&eventsource - source of events in monitoring program" +keyword{0,1} eventsource + abstract { + return kywdevent + } + inline { + return kywdevent(&k_eventsource); + } +end + +"&eventvalue - value from event in monitored program" +keyword{0,1} eventvalue + abstract { + return kywdevent + } + inline { + return kywdevent(&k_eventvalue); + } +end + +"&features - generate strings identifying features in this version of Icon" +keyword{1,*} features + abstract { + return string + } + body { +#if COMPILER +#define Feature(guard,sym,kwval) if ((guard) && (kwval)) suspend C_string kwval; +#else /* COMPILER */ +#define Feature(guard,sym,kwval) if (kwval) suspend C_string kwval; +#endif /* COMPILER */ +#include "../h/features.h" + fail; + } +end + +"&file - name of the source file for the current execution point" +keyword{1} file + abstract { + return string + } + inline { +#if COMPILER + if (line_info) + return C_string file_name; + else + runerr(402); +#else /* COMPILER */ + char *s; + s = findfile(ipc.opnd); + if (!strcmp(s,"?")) fail; + return C_string s; +#endif /* COMPILER */ + } +end + +"&host - a string that identifies the host computer Icon is running on." +keyword{1} host + abstract { + return string + } + inline { + char sbuf[MaxCvtLen], *tmp; + int i; + + iconhost(sbuf); + i = strlen(sbuf); + Protect(tmp = alcstr(sbuf, i), runerr(0)); + return string(i, tmp); + } +end + +"&input - the standard input file" +keyword{1} input + abstract { + return file + } + inline { + return file(&k_input); + } +end + +"&lcase - a cset consisting of the 26 lower case letters" +keyword{1} lcase + constant 'abcdefghijklmnopqrstuvwxyz' +end + +"&letters - a cset consisting of the 52 letters" +keyword{1} letters + constant 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' +end + +"&level - level of procedure call." +keyword{1} level + abstract { + return integer + } + + inline { +#if COMPILER + if (!debug_info) + runerr(402); +#endif /* COMPILER */ + return C_integer k_level; + } +end + +"&line - source line number of current execution point" +keyword{1} line + abstract { + return integer; + } + inline { +#if COMPILER + if (line_info) + return C_integer line_num; + else + runerr(402); +#else /* COMPILER */ + return C_integer findline(ipc.opnd); +#endif /* COMPILER */ + } +end + +"&main - the main co-expression." +keyword{1} main + abstract { + return coexpr + } + inline { + return k_main; + } +end + +"&null - the null value." +keyword{1} null + abstract { + return null + } + inline { + return nulldesc; + } +end + +"&output - the standard output file." +keyword{1} output + abstract { + return file + } + inline { + return file(&k_output); + } +end + +"&phi - the golden ratio" +keyword{1} phi + constant 1.618033988749894848204586834365638117720309180 +end + +"&pi - the ratio of circumference to diameter" +keyword{1} pi + constant 3.14159265358979323846264338327950288419716939937511 +end + +"&pos - a variable containing the current focus in string scanning." +keyword{1} pos + abstract { + return kywdpos + } + inline { + return kywdpos(&kywd_pos); + } +end + +"&progname - a variable containing the program name." +keyword{1} progname + abstract { + return kywdstr + } + inline { + return kywdstr(&kywd_prog); + } +end + +"&random - a variable containing the current seed for random operations." +keyword{1} random + abstract { + return kywdint + } + inline { + return kywdint(&kywd_ran); + } +end + +"®ions - generates regions sizes" +keyword{3} regions + abstract { + return integer + } + inline { + word allRegions = 0; + struct region *rp; + + suspend C_integer 0; /* static region */ + + allRegions = DiffPtrs(strend,strbase); + for (rp = curstring->next; rp; rp = rp->next) + allRegions += DiffPtrs(rp->end,rp->base); + for (rp = curstring->prev; rp; rp = rp->prev) + allRegions += DiffPtrs(rp->end,rp->base); + suspend C_integer allRegions; /* string region */ + + allRegions = DiffPtrs(blkend,blkbase); + for (rp = curblock->next; rp; rp = rp->next) + allRegions += DiffPtrs(rp->end,rp->base); + for (rp = curblock->prev; rp; rp = rp->prev) + allRegions += DiffPtrs(rp->end,rp->base); + return C_integer allRegions; /* block region */ + } +end + +"&source - the co-expression that invoked the current co-expression." +keyword{1} source + abstract { + return coexpr + } + inline { +#ifndef Coexpr + return k_main; +#else /* Coexpr */ + return coexpr(topact((struct b_coexpr *)BlkLoc(k_current))); +#endif /* Coexpr */ + } +end + +"&storage - generate the amount of storage used for each region." +keyword{3} storage + abstract { + return integer + } + inline { + word allRegions = 0; + struct region *rp; + + suspend C_integer 0; /* static region */ + + allRegions = DiffPtrs(strfree,strbase); + for (rp = curstring->next; rp; rp = rp->next) + allRegions += DiffPtrs(rp->free,rp->base); + for (rp = curstring->prev; rp; rp = rp->prev) + allRegions += DiffPtrs(rp->free,rp->base); + suspend C_integer allRegions; /* string region */ + + allRegions = DiffPtrs(blkfree,blkbase); + for (rp = curblock->next; rp; rp = rp->next) + allRegions += DiffPtrs(rp->free,rp->base); + for (rp = curblock->prev; rp; rp = rp->prev) + allRegions += DiffPtrs(rp->free,rp->base); + return C_integer allRegions; /* block region */ + } +end + +"&subject - variable containing the current subject of string scanning." +keyword{1} subject + abstract { + return kywdsubj + } + inline { + return kywdsubj(&k_subject); + } +end + +"&time - the elapsed execution time in milliseconds." +keyword{1} time + abstract { + return integer + } + inline { + return C_integer millisec(); + } +end + +"&trace - variable that controls procedure tracing." +keyword{1} trace + abstract { + return kywdint + } + inline { + return kywdint(&kywd_trc); + } +end + +"&dump - variable that controls termination dump." +keyword{1} dump + abstract { + return kywdint + } + inline { + return kywdint(&kywd_dmp); + } +end + +"&ucase - a cset consisting of the 26 uppercase characters." +keyword{1} ucase + constant 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +end + +"&version - a string indentifying this version of Icon." +keyword{1} version + constant Version +end + +#ifndef MultiThread +struct descrip kywd_xwin[2] = {{D_Null}}; +#endif /* MultiThread */ + +"&window - variable containing the current graphics rendering context." +#ifdef Graphics +keyword{1} window + abstract { + return kywdwin + } + inline { + return kywdwin(kywd_xwin + XKey_Window); + } +end +#else /* Graphics */ +keyword{0} window + abstract { + return empty_type + } + inline { + fail; + } +end +#endif /* Graphics */ + +#ifdef Graphics +"&col - mouse horizontal position in text columns." +keyword{1} col + abstract { return kywdint } + inline { if (is:null(lastEventWin)) runerr(140, lastEventWin); + else return kywdint(&erCol); } +end + +"&row - mouse vertical position in text rows." +keyword{1} row + abstract { return kywdint } + inline { if (is:null(lastEventWin)) runerr(140, lastEventWin); + else return kywdint(&erRow); } +end + +"&x - mouse horizontal position." +keyword{1} x + abstract { return kywdint } + inline { if (is:null(lastEventWin)) runerr(140, lastEventWin); + else return kywdint(&erX); } +end + +"&y - mouse vertical position." +keyword{1} y + abstract { return kywdint } + inline { if (is:null(lastEventWin)) runerr(140, lastEventWin); + else return kywdint(&erY); } +end + +"&interval - milliseconds since previous event." +keyword{1} interval + abstract { return kywdint } + inline { if (is:null(lastEventWin)) runerr(140, lastEventWin); + else return kywdint(&erInterval); } +end + +"&control - null if control key was down on last X event, else failure" +keyword{0,1} control + abstract { return null } + inline { if (is:null(lastEventWin)) runerr(140, lastEventWin); + else if (xmod_control) return nulldesc; else fail; } +end + +"&shift - null if shift key was down on last X event, else failure" +keyword{0,1} shift + abstract { return null } + inline { if (is:null(lastEventWin)) runerr(140, lastEventWin); + else if (xmod_shift) return nulldesc; else fail; } +end + +"&meta - null if meta key was down on last X event, else failure" +keyword{0,1} meta + abstract { return null } + inline { if (is:null(lastEventWin)) runerr(140, lastEventWin); + else if (xmod_meta) return nulldesc; else fail; } +end +#else /* Graphics */ +"&col - mouse horizontal position in text columns." +keyword{0} col + abstract { return empty_type } + inline { fail; } +end + +"&row - mouse vertical position in text rows." +keyword{0} row + abstract { return empty_type } + inline { fail; } +end + +"&x - mouse horizontal position." +keyword{0} x + abstract { return empty_type } + inline { fail; } +end + +"&y - mouse vertical position." +keyword{0} y + abstract { return empty_type } + inline { fail; } +end + +"&interval - milliseconds since previous event." +keyword{0} interval + abstract { return empty_type } + inline { fail; } +end + +"&control - null if control key was down on last X event, else failure" +keyword{0} control + abstract { return empty_type} + inline { fail; } +end + +"&shift - null if shift key was down on last X event, else failure" +keyword{0} shift + abstract { return empty_type } + inline { fail; } +end + +"&meta - null if meta key was down on last X event, else failure" +keyword{0} meta + abstract { return empty_type } + inline { fail; } +end +#endif /* Graphics */ + +"&lpress - left button press." +keyword{1} lpress + abstract { return integer} inline { return C_integer MOUSELEFT; } +end +"&mpress - middle button press." +keyword{1} mpress + abstract { return integer} inline { return C_integer MOUSEMID; } +end +"&rpress - right button press." +keyword{1} rpress + abstract { return integer} inline { return C_integer MOUSERIGHT; } +end +"&lrelease - left button release." +keyword{1} lrelease + abstract { return integer} inline { return C_integer MOUSELEFTUP; } +end +"&mrelease - middle button release." +keyword{1} mrelease + abstract { return integer} inline { return C_integer MOUSEMIDUP; } +end +"&rrelease - right button release." +keyword{1} rrelease + abstract { return integer} inline { return C_integer MOUSERIGHTUP; } +end +"&ldrag - left button drag." +keyword{1} ldrag + abstract { return integer} inline { return C_integer MOUSELEFTDRAG; } +end +"&mdrag - middle button drag." +keyword{1} mdrag + abstract { return integer} inline { return C_integer MOUSEMIDDRAG; } +end +"&rdrag - right button drag." +keyword{1} rdrag + abstract { return integer} inline { return C_integer MOUSERIGHTDRAG; } +end +"&resize - window resize." +keyword{1} resize + abstract { return integer} inline { return C_integer RESIZED; } +end + +"&ascii - a cset consisting of the 128 ascii characters" +keyword{1} ascii +constant '\ +\000\001\002\003\004\005\006\007\010\011\012\013\014\015\016\017\ +\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037\ +\040\041\042\043\044\045\046\047\050\051\052\053\054\055\056\057\ +\060\061\062\063\064\065\066\067\070\071\072\073\074\075\076\077\ +\100\101\102\103\104\105\106\107\110\111\112\113\114\115\116\117\ +\120\121\122\123\124\125\126\127\130\131\132\133\134\135\136\137\ +\140\141\142\143\144\145\146\147\150\151\152\153\154\155\156\157\ +\160\161\162\163\164\165\166\167\170\171\172\173\174\175\176\177' +end + +"&cset - a cset consisting of all the 256 characters." +keyword{1} cset +constant '\ +\0\1\2\3\4\5\6\7\10\11\12\13\14\15\16\17\ +\20\21\22\23\24\25\26\27\30\31\32\33\34\35\36\37\ +\40\41\42\43\44\45\46\47\50\51\52\53\54\55\56\57\ +\60\61\62\63\64\65\66\67\70\71\72\73\74\75\76\77\ +\100\101\102\103\104\105\106\107\110\111\112\113\114\115\116\117\ +\120\121\122\123\124\125\126\127\130\131\132\133\134\135\136\137\ +\140\141\142\143\144\145\146\147\150\151\152\153\154\155\156\157\ +\160\161\162\163\164\165\166\167\170\171\172\173\174\175\176\177\ +\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217\ +\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237\ +\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257\ +\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277\ +\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317\ +\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337\ +\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357\ +\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377' +end diff --git a/src/runtime/lmisc.r b/src/runtime/lmisc.r new file mode 100644 index 0000000..11f29de --- /dev/null +++ b/src/runtime/lmisc.r @@ -0,0 +1,176 @@ +/* + * file: lmisc.r + * Contents: [O]create, activate + */ + +/* + * create - return an entry block for a co-expression. + */ +#if COMPILER +struct b_coexpr *create(fnc, cproc, ntemps, wrk_size) +continuation fnc; +struct b_proc *cproc; +int ntemps; +int wrk_size; +#else /* COMPILER */ + +int Ocreate(entryp, cargp) +word *entryp; +register dptr cargp; +#endif /* COMPILER */ + { + +#ifdef Coexpr + tended struct b_coexpr *sblkp; + register struct b_refresh *rblkp; + register dptr dp, ndp; + int na, nl, i; + +#if !COMPILER + struct b_proc *cproc; + + /* cproc is the Icon procedure that create occurs in */ + cproc = (struct b_proc *)BlkLoc(glbl_argp[0]); +#endif /* COMPILER */ + + /* + * Calculate number of arguments and number of local variables. + */ +#if COMPILER + na = abs((int)cproc->nparam); +#else /* COMPILER */ + na = pfp->pf_nargs + 1; /* includes Arg0 */ +#endif /* COMPILER */ + nl = (int)cproc->ndynam; + + /* + * Get a new co-expression stack and initialize. + */ + +#ifdef MultiThread + Protect(sblkp = alccoexp(0, 0), err_msg(0, NULL)); +#else /* MultiThread */ + Protect(sblkp = alccoexp(), err_msg(0, NULL)); +#endif /* MultiThread */ + + + if (!sblkp) +#if COMPILER + return NULL; +#else /* COMPILER */ + Fail; +#endif /* COMPILER */ + + /* + * Get a refresh block for the new co-expression. + */ +#if COMPILER + Protect(rblkp = alcrefresh(na, nl, ntemps, wrk_size), err_msg(0,NULL)); +#else /* COMPILER */ + Protect(rblkp = alcrefresh(entryp, na, nl),err_msg(0,NULL)); +#endif /* COMPILER */ + if (!rblkp) +#if COMPILER + return NULL; +#else /* COMPILER */ + Fail; +#endif /* COMPILER */ + + sblkp->freshblk.dword = D_Refresh; + BlkLoc(sblkp->freshblk) = (union block *) rblkp; + +#if !COMPILER + /* + * Copy current procedure frame marker into refresh block. + */ + rblkp->pfmkr = *pfp; + rblkp->pfmkr.pf_pfp = 0; +#endif /* COMPILER */ + + /* + * Copy arguments into refresh block. + */ + ndp = rblkp->elems; + dp = glbl_argp; + for (i = 1; i <= na; i++) + *ndp++ = *dp++; + + /* + * Copy locals into the refresh block. + */ +#if COMPILER + dp = pfp->tend.d; +#else /* COMPILER */ + dp = &(pfp->pf_locals)[0]; +#endif /* COMPILER */ + for (i = 1; i <= nl; i++) + *ndp++ = *dp++; + + /* + * Use the refresh block to finish initializing the co-expression stack. + */ + co_init(sblkp); + +#if COMPILER + sblkp->fnc = fnc; + if (line_info) { + if (debug_info) + PFDebug(sblkp->pf)->proc = cproc; + PFDebug(sblkp->pf)->old_fname = ""; + PFDebug(sblkp->pf)->old_line = 0; + } + + return sblkp; +#else /* COMPILER */ + /* + * Return the new co-expression. + */ + Arg0.dword = D_Coexpr; + BlkLoc(Arg0) = (union block *) sblkp; + Return; +#endif /* COMPILER */ +#else /* Coexpr */ + err_msg(401, NULL); +#if COMPILER + return NULL; +#else /* COMPILER */ + Fail; +#endif /* COMPILER */ +#endif /* Coexpr */ + + } + +/* + * activate - activate a co-expression. + */ +int activate(val, ncp, result) +dptr val; +struct b_coexpr *ncp; +dptr result; + { +#ifdef Coexpr + + int first; + + /* + * Set activator in new co-expression. + */ + if (ncp->es_actstk == NULL) { + Protect(ncp->es_actstk = alcactiv(),RunErr(0,NULL)); + first = 0; + } + else + first = 1; + + if (pushact(ncp, (struct b_coexpr *)BlkLoc(k_current)) == Error) + RunErr(0,NULL); + + if (co_chng(ncp, val, result, A_Coact, first) == A_Cofail) + return A_Resume; + else + return A_Continue; + +#else /* Coexpr */ + RunErr(401,NULL); +#endif /* Coexpr */ + } diff --git a/src/runtime/oarith.r b/src/runtime/oarith.r new file mode 100644 index 0000000..b3ca88c --- /dev/null +++ b/src/runtime/oarith.r @@ -0,0 +1,502 @@ +/* + * File: oarith.r + * Contents: arithmetic operators + - * / % ^. Auxiliary routines + * iipow, ripow. + * + * The arithmetic operators all follow a canonical conversion + * protocol encapsulated in the macro ArithOp. + */ + +int over_flow = 0; + +#begdef ArithOp(icon_op, func_name, c_int_op, c_real_op) + + operator{1} icon_op func_name(x, y) + declare { +#ifdef LargeInts + tended struct descrip lx, ly; +#endif /* LargeInts */ + C_integer irslt; + } + arith_case (x, y) of { + C_integer: { + abstract { + return integer + } + inline { + extern int over_flow; + c_int_op(x,y); + } + } + integer: { /* large integers only */ + abstract { + return integer + } + inline { + big_ ## c_int_op(x,y); + } + } + C_double: { + abstract { + return real + } + inline { + c_real_op(x, y); + } + } + } +end + +#enddef + +/* + * x / y + */ + +#begdef big_Divide(x,y) +{ + if ( ( Type ( y ) == T_Integer ) && ( IntVal ( y ) == 0 ) ) + runerr(201); /* Divide fix */ + + if (bigdiv(&x,&y,&result) == Error) /* alcbignum failed */ + runerr(0); + return result; +} +#enddef +#begdef Divide(x,y) +{ + if ( y == 0 ) + runerr(201); /* divide fix */ + + irslt = div3(x,y); + if (over_flow) { +#ifdef LargeInts + MakeInt(x,&lx); + MakeInt(y,&ly); + if (bigdiv(&lx,&ly,&result) == Error) /* alcbignum failed */ + runerr(0); + return result; +#else /* LargeInts */ + runerr(203); +#endif /* LargeInts */ + } + else return C_integer irslt; +} +#enddef +#begdef RealDivide(x,y) +{ + double z; + + if (y == 0.0) + runerr(204); + z = x / y; + return C_double z; +} +#enddef + + +ArithOp( / , divide , Divide , RealDivide) + +/* + * x - y + */ + +#begdef big_Sub(x,y) +{ + if (bigsub(&x,&y,&result) == Error) /* alcbignum failed */ + runerr(0); + return result; +} +#enddef + +#begdef Sub(x,y) + irslt = sub(x,y); + if (over_flow) { +#ifdef LargeInts + MakeInt(x,&lx); + MakeInt(y,&ly); + if (bigsub(&lx,&ly,&result) == Error) /* alcbignum failed */ + runerr(0); + return result; +#else /* LargeInts */ + runerr(203); +#endif /* LargeInts */ + } + else return C_integer irslt; +#enddef + +#define RealSub(x,y) return C_double (x - y); + +ArithOp( - , minus , Sub , RealSub) + + +/* + * x % y + */ +#define Abs(x) ((x) > 0 ? (x) : -(x)) + +#begdef big_IntMod(x,y) +{ + if ( ( Type ( y ) == T_Integer ) && ( IntVal ( y ) == 0 ) ) { + irunerr(202,0); + errorfail; + } + if (bigmod(&x,&y,&result) == Error) + runerr(0); + return result; +} +#enddef + +#begdef IntMod(x,y) +{ + irslt = mod3(x,y); + if (over_flow) { + irunerr(202,y); + errorfail; + } + return C_integer irslt; +} +#enddef + +#begdef RealMod(x,y) +{ + double d; + + if (y == 0.0) + runerr(204); + + d = fmod(x, y); + /* d must have the same sign as x */ + if (x < 0.0) { + if (d > 0.0) { + d -= Abs(y); + } + } + else if (d < 0.0) { + d += Abs(y); + } + return C_double d; +} +#enddef + +ArithOp( % , mod , IntMod , RealMod) + +/* + * x * y + */ + +#begdef big_Mpy(x,y) +{ + if (bigmul(&x,&y,&result) == Error) + runerr(0); + return result; +} +#enddef + +#begdef Mpy(x,y) + irslt = mul(x,y); + if (over_flow) { +#ifdef LargeInts + MakeInt(x,&lx); + MakeInt(y,&ly); + if (bigmul(&lx,&ly,&result) == Error) /* alcbignum failed */ + runerr(0); + return result; +#else /* LargeInts */ + runerr(203); +#endif /* LargeInts */ + } + else return C_integer irslt; +#enddef + + +#define RealMpy(x,y) return C_double (x * y); + +ArithOp( * , mult , Mpy , RealMpy) + + +"-x - negate x." + +operator{1} - neg(x) + if cnv:(exact)C_integer(x) then { + abstract { + return integer + } + inline { + C_integer i; + extern int over_flow; + + i = neg(x); + if (over_flow) { +#ifdef LargeInts + struct descrip tmp; + MakeInt(x,&tmp); + if (bigneg(&tmp, &result) == Error) /* alcbignum failed */ + runerr(0); + return result; +#else /* LargeInts */ + irunerr(203,x); + errorfail; +#endif /* LargeInts */ + } + return C_integer i; + } + } +#ifdef LargeInts + else if cnv:(exact) integer(x) then { + abstract { + return integer + } + inline { + if (bigneg(&x, &result) == Error) /* alcbignum failed */ + runerr(0); + return result; + } + } +#endif /* LargeInts */ + else { + if !cnv:C_double(x) then + runerr(102, x) + abstract { + return real + } + inline { + double drslt; + drslt = -x; + return C_double drslt; + } + } +end + + +"+x - convert x to a number." +/* + * Operational definition: generate runerr if x is not numeric. + */ +operator{1} + number(x) + if cnv:(exact)C_integer(x) then { + abstract { + return integer + } + inline { + return C_integer x; + } + } +#ifdef LargeInts + else if cnv:(exact) integer(x) then { + abstract { + return integer + } + inline { + return x; + } + } +#endif /* LargeInts */ + else if cnv:C_double(x) then { + abstract { + return real + } + inline { + return C_double x; + } + } + else + runerr(102, x) +end + +/* + * x + y + */ + +#begdef big_Add(x,y) +{ + if (bigadd(&x,&y,&result) == Error) + runerr(0); + return result; +} +#enddef + +#begdef Add(x,y) + irslt = add(x,y); + if (over_flow) { +#ifdef LargeInts + MakeInt(x,&lx); + MakeInt(y,&ly); + if (bigadd(&lx, &ly, &result) == Error) /* alcbignum failed */ + runerr(0); + return result; +#else /* LargeInts */ + runerr(203); +#endif /* LargeInts */ + } + else return C_integer irslt; +#enddef + +#define RealAdd(x,y) return C_double (x + y); + +ArithOp( + , plus , Add , RealAdd) + + +"x ^ y - raise x to the y power." + +operator{1} ^ powr(x, y) + if cnv:(exact)C_integer(y) then { + if cnv:(exact)integer(x) then { + abstract { + return integer + } + inline { +#ifdef LargeInts + tended struct descrip ly; + MakeInt ( y, &ly ); + if (bigpow(&x, &ly, &result) == Error) /* alcbignum failed */ + runerr(0); + return result; +#else + extern int over_flow; + C_integer r = iipow(IntVal(x), y); + if (over_flow) + runerr(203); + return C_integer r; +#endif + } + } + else { + if !cnv:C_double(x) then + runerr(102, x) + abstract { + return real + } + inline { + if (ripow( x, y, &result) == Error) + runerr(0); + return result; + } + } + } +#ifdef LargeInts + else if cnv:(exact)integer(y) then { + if cnv:(exact)integer(x) then { + abstract { + return integer + } + inline { + if (bigpow(&x, &y, &result) == Error) /* alcbignum failed */ + runerr(0); + return result; + } + } + else { + if !cnv:C_double(x) then + runerr(102, x) + abstract { + return real + } + inline { + if ( bigpowri ( x, &y, &result ) == Error ) + runerr(0); + return result; + } + } + } +#endif /* LargeInts */ + else { + if !cnv:C_double(x) then + runerr(102, x) + if !cnv:C_double(y) then + runerr(102, y) + abstract { + return real + } + inline { + if (x == 0.0 && y < 0.0) + runerr(204); + if (x < 0.0) + runerr(206); + return C_double pow(x,y); + } + } +end + +#if COMPILER || !(defined LargeInts) +/* + * iipow - raise an integer to an integral power. + */ +C_integer iipow(n1, n2) +C_integer n1, n2; + { + C_integer result; + + /* Handle some special cases first */ + over_flow = 0; + switch ( n1 ) { + case 1: + return 1; + case -1: + /* Result depends on whether n2 is even or odd */ + return ( n2 & 01 ) ? -1 : 1; + case 0: + if ( n2 <= 0 ) + over_flow = 1; + return 0; + default: + if (n2 < 0) + return 0; + } + + result = 1L; + for ( ; ; ) { + if (n2 & 01L) + { + result = mul(result, n1); + if (over_flow) + return 0; + } + + if ( ( n2 >>= 1 ) == 0 ) break; + n1 = mul(n1, n1); + if (over_flow) + return 0; + } + over_flow = 0; + return result; + } +#endif /* COMPILER || !(defined LargeInts) */ + + +/* + * ripow - raise a real number to an integral power. + */ +int ripow(r, n, drslt) +double r; +C_integer n; +dptr drslt; + { + double retval; + + if (r == 0.0 && n <= 0) + ReturnErrNum(204, Error); + if (n < 0) { + /* + * r ^ n = ( 1/r ) * ( ( 1/r ) ^ ( -1 - n ) ) + * + * (-1) - n never overflows, even when n == MinLong. + */ + n = (-1) - n; + r = 1.0 / r; + retval = r; + } + else + retval = 1.0; + + /* multiply retval by r ^ n */ + while (n > 0) { + if (n & 01L) + retval *= r; + r *= r; + n >>= 1; + } + Protect(BlkLoc(*drslt) = (union block *)alcreal(retval), return Error); + drslt->dword = D_Real; + return Succeeded; + } diff --git a/src/runtime/oasgn.r b/src/runtime/oasgn.r new file mode 100644 index 0000000..b93d646 --- /dev/null +++ b/src/runtime/oasgn.r @@ -0,0 +1,522 @@ +/* + * File: oasgn.r + */ + +/* + * Asgn - perform an assignment when the destination descriptor might + * be within a block. + */ +#define Asgn(dest, src) *(dptr)((word *)VarLoc(dest) + Offset(dest)) = src; + +/* + * GeneralAsgn - perform the assignment x := y, where x is known to be + * a variable and y is has been dereferenced. + */ +#begdef GeneralAsgn(x, y) + +#ifdef EventMon + body { + if (!is:null(curpstate->eventmask) && + Testb((word)E_Assign, curpstate->eventmask)) { + EVAsgn(&x); + } + } +#endif /* EventMon */ + + type_case x of { + tvsubs: { + abstract { + store[store[type(x).str_var]] = string + } + inline { + if (subs_asgn(&x, (const dptr)&y) == Error) + runerr(0); + } + } + tvtbl: { + abstract { + store[store[type(x).trpd_tbl].tbl_val] = type(y) + } + inline { + if (tvtbl_asgn(&x, (const dptr)&y) == Error) + runerr(0); + } + } + kywdevent: + body { + *VarLoc(x) = y; + } + kywdwin: + body { +#ifdef Graphics + if (is:null(y)) + *VarLoc(x) = y; + else { + if ((!is:file(y)) || !(BlkLoc(y)->file.status & Fs_Window)) + runerr(140,y); + *VarLoc(x) = y; + } +#endif /* Graphics */ + } + kywdint: + { + /* + * No side effect in the type realm - keyword x is still an int. + */ + body { + C_integer i; + + if (!cnv:C_integer(y, i)) + runerr(101, y); + IntVal(*VarLoc(x)) = i; + +#ifdef Graphics + if (xyrowcol(&x) == -1) + runerr(140,kywd_xwin[XKey_Window]); +#endif /* Graphics */ + } + } + kywdpos: { + /* + * No side effect in the type realm - &pos is still an int. + */ + body { + C_integer i; + + if (!cnv:C_integer(y, i)) + runerr(101, y); + +#ifdef MultiThread + i = cvpos((long)i, StrLen(*(VarLoc(x)+1))); +#else /* MultiThread */ + i = cvpos((long)i, StrLen(k_subject)); +#endif /* MultiThread */ + + if (i == CvtFail) + fail; + IntVal(*VarLoc(x)) = i; + + EVVal(k_pos, E_Spos); + } + } + kywdsubj: { + /* + * No side effect in the type realm - &subject is still a string + * and &pos is still an int. + */ + if !cnv:string(y, *VarLoc(x)) then + runerr(103, y); + inline { +#ifdef MultiThread + IntVal(*(VarLoc(x)-1)) = 1; +#else /* MultiThread */ + k_pos = 1; +#endif /* MultiThread */ + EVVal(k_pos, E_Spos); + } + } + kywdstr: { + /* + * No side effect in the type realm. + */ + if !cnv:string(y, *VarLoc(x)) then + runerr(103, y); + } + default: { + abstract { + store[type(x)] = type(y) + } + inline { + Asgn(x, y) + } + } + } + +#ifdef EventMon + body { + EVValD(&y, E_Value); + } +#endif /* EventMon */ + +#enddef + + +"x := y - assign y to x." + +operator{0,1} := asgn(underef x, y) + + if !is:variable(x) then + runerr(111, x) + + abstract { + return type(x) + } + + GeneralAsgn(x, y) + + inline { + /* + * The returned result is the variable to which assignment is being + * made. + */ + return x; + } +end + + +"x <- y - assign y to x." +" Reverses assignment if resumed." + +operator{0,1+} <- rasgn(underef x -> saved_x, y) + + if !is:variable(x) then + runerr(111, x) + + abstract { + return type(x) + } + + GeneralAsgn(x, y) + + inline { + suspend x; + } + + GeneralAsgn(x, saved_x) + + inline { + fail; + } +end + + +"x <-> y - swap values of x and y." +" Reverses swap if resumed." + +operator{0,1+} <-> rswap(underef x -> dx, underef y -> dy) + + declare { + tended union block *bp_x, *bp_y; + word adj1 = 0; + word adj2 = 0; + } + + if !is:variable(x) then + runerr(111, x) + if !is:variable(y) then + runerr(111, y) + + abstract { + return type(x) + } + + if is:tvsubs(x) && is:tvsubs(y) then + body { + bp_x = BlkLoc(x); + bp_y = BlkLoc(y); + if (VarLoc(bp_x->tvsubs.ssvar) == VarLoc(bp_y->tvsubs.ssvar) && + Offset(bp_x->tvsubs.ssvar) == Offset(bp_y->tvsubs.ssvar)) { + /* + * x and y are both substrings of the same string, set + * adj1 and adj2 for use in locating the substrings after + * an assignment has been made. If x is to the right of y, + * set adj1 := *x - *y, otherwise if y is to the right of + * x, set adj2 := *y - *x. Note that the adjustment + * values may be negative. + */ + if (bp_x->tvsubs.sspos > bp_y->tvsubs.sspos) + adj1 = bp_x->tvsubs.sslen - bp_y->tvsubs.sslen; + else if (bp_y->tvsubs.sspos > bp_x->tvsubs.sspos) + adj2 = bp_y->tvsubs.sslen - bp_x->tvsubs.sslen; + } + } + + /* + * Do x := y + */ + GeneralAsgn(x, dy) + + if is:tvsubs(x) && is:tvsubs(y) then + inline { + if (adj2 != 0) + /* + * Arg2 is to the right of Arg1 and the assignment Arg1 := Arg2 has + * shifted the position of Arg2. Add adj2 to the position of Arg2 + * to account for the replacement of Arg1 by Arg2. + */ + bp_y->tvsubs.sspos += adj2; + } + + /* + * Do y := x + */ + GeneralAsgn(y, dx) + + if is:tvsubs(x) && is:tvsubs(y) then + inline { + if (adj1 != 0) + /* + * Arg1 is to the right of Arg2 and the assignment Arg2 := Arg1 + * has shifted the position of Arg1. Add adj2 to the position + * of Arg1 to account for the replacement of Arg2 by Arg1. + */ + bp_x->tvsubs.sspos += adj1; + } + + inline { + suspend x; + } + /* + * If resumed, the assignments are undone. Note that the string position + * adjustments are opposite those done earlier. + */ + GeneralAsgn(x, dx) + if is:tvsubs(x) && is:tvsubs(y) then + inline { + if (adj2 != 0) + bp_y->tvsubs.sspos -= adj2; + } + + GeneralAsgn(y, dy) + if is:tvsubs(x) && is:tvsubs(y) then + inline { + if (adj1 != 0) + bp_x->tvsubs.sspos -= adj1; + } + + inline { + fail; + } +end + + +"x :=: y - swap values of x and y." + +operator{0,1} :=: swap(underef x -> dx, underef y -> dy) + declare { + tended union block *bp_x, *bp_y; + word adj1 = 0; + word adj2 = 0; + } + + /* + * x and y must be variables. + */ + if !is:variable(x) then + runerr(111, x) + if !is:variable(y) then + runerr(111, y) + + abstract { + return type(x) + } + + if is:tvsubs(x) && is:tvsubs(y) then + body { + bp_x = BlkLoc(x); + bp_y = BlkLoc(y); + if (VarLoc(bp_x->tvsubs.ssvar) == VarLoc(bp_y->tvsubs.ssvar) && + Offset(bp_x->tvsubs.ssvar) == Offset(bp_y->tvsubs.ssvar)) { + /* + * x and y are both substrings of the same string, set + * adj1 and adj2 for use in locating the substrings after + * an assignment has been made. If x is to the right of y, + * set adj1 := *x - *y, otherwise if y is to the right of + * x, set adj2 := *y - *x. Note that the adjustment + * values may be negative. + */ + if (bp_x->tvsubs.sspos > bp_y->tvsubs.sspos) + adj1 = bp_x->tvsubs.sslen - bp_y->tvsubs.sslen; + else if (bp_y->tvsubs.sspos > bp_x->tvsubs.sspos) + adj2 = bp_y->tvsubs.sslen - bp_x->tvsubs.sslen; + } + } + + /* + * Do x := y + */ + GeneralAsgn(x, dy) + + if is:tvsubs(x) && is:tvsubs(y) then + inline { + if (adj2 != 0) + /* + * Arg2 is to the right of Arg1 and the assignment Arg1 := Arg2 has + * shifted the position of Arg2. Add adj2 to the position of Arg2 + * to account for the replacement of Arg1 by Arg2. + */ + bp_y->tvsubs.sspos += adj2; + } + + /* + * Do y := x + */ + GeneralAsgn(y, dx) + + if is:tvsubs(x) && is:tvsubs(y) then + inline { + if (adj1 != 0) + /* + * Arg1 is to the right of Arg2 and the assignment Arg2 := Arg1 + * has shifted the position of Arg1. Add adj2 to the position + * of Arg1 to account for the replacement of Arg2 by Arg1. + */ + bp_x->tvsubs.sspos += adj1; + } + + inline { + return x; + } +end + +/* + * subs_asgn - perform assignment to a substring. Leave the updated substring + * in dest in case it is needed as the result of the assignment. + */ +int subs_asgn(dest, src) +dptr dest; +const dptr src; + { + tended struct descrip deststr; + tended struct descrip srcstr; + tended struct descrip rsltstr; + tended struct b_tvsubs *tvsub; + + char *s, *s2; + word i, len; + word prelen; /* length of portion of string before substring */ + word poststrt; /* start of portion of string following substring */ + word postlen; /* length of portion of string following substring */ + + if (!cnv:tmp_string(*src, srcstr)) + ReturnErrVal(103, *src, Error); + + /* + * Be sure that the variable in the trapped variable points + * to a string and that the string is big enough to contain + * the substring. + */ + tvsub = (struct b_tvsubs *)BlkLoc(*dest); + deref(&tvsub->ssvar, &deststr); + if (!is:string(deststr)) + ReturnErrVal(103, deststr, Error); + prelen = tvsub->sspos - 1; + poststrt = prelen + tvsub->sslen; + if (poststrt > StrLen(deststr)) + ReturnErrNum(205, Error); + + /* + * Form the result string. + * Start by allocating space for the entire result. + */ + len = prelen + StrLen(srcstr) + StrLen(deststr) - poststrt; + Protect(s = alcstr(NULL, len), return Error); + StrLoc(rsltstr) = s; + StrLen(rsltstr) = len; + /* + * First, copy the portion of the substring string to the left of + * the substring into the string space. + */ + s2 = StrLoc(deststr); + for (i = 0; i < prelen; i++) + *s++ = *s2++; + /* + * Copy the string to be assigned into the string space, + * effectively concatenating it. + */ + s2 = StrLoc(srcstr); + for (i = 0; i < StrLen(srcstr); i++) + *s++ = *s2++; + /* + * Copy the portion of the substring to the right of + * the substring into the string space, completing the + * result. + */ + s2 = StrLoc(deststr) + poststrt; + postlen = StrLen(deststr) - poststrt; + for (i = 0; i < postlen; i++) + *s++ = *s2++; + + /* + * Perform the assignment and update the trapped variable. + */ + type_case tvsub->ssvar of { + kywdevent: { + *VarLoc(tvsub->ssvar) = rsltstr; + } + kywdstr: { + *VarLoc(tvsub->ssvar) = rsltstr; + } + kywdsubj: { + *VarLoc(tvsub->ssvar) = rsltstr; + k_pos = 1; + } + tvtbl: { + if (tvtbl_asgn(&tvsub->ssvar, (const dptr)&rsltstr) == Error) + return Error; + } + default: { + Asgn(tvsub->ssvar, rsltstr); + } + } + tvsub->sslen = StrLen(srcstr); + + EVVal(tvsub->sslen, E_Ssasgn); + return Succeeded; + } + +/* + * tvtbl_asgn - perform an assignment to a table element trapped variable, + * inserting the element in the table if needed. + */ +int tvtbl_asgn(dest, src) +dptr dest; +const dptr src; + { + tended struct b_tvtbl *bp; + tended struct descrip tval; + struct b_telem *te; + union block **slot; + struct b_table *tp; + int res; + + /* + * Allocate te now (even if we may not need it) + * because slot cannot be tended. + */ + bp = (struct b_tvtbl *) BlkLoc(*dest); /* Save params to tended vars */ + tval = *src; + Protect(te = alctelem(), return Error); + + /* + * First see if reference is in the table; if it is, just update + * the value. Otherwise, allocate a new table entry. + */ + slot = memb(bp->clink, &bp->tref, bp->hashnum, &res); + + if (res == 1) { + /* + * Do not need new te, just update existing entry. + */ + deallocate((union block *) te); + (*slot)->telem.tval = tval; + } + else { + /* + * Link te into table, fill in entry. + */ + tp = (struct b_table *) bp->clink; + tp->size++; + + te->clink = *slot; + *slot = (union block *) te; + + te->hashnum = bp->hashnum; + te->tref = bp->tref; + te->tval = tval; + + if (TooCrowded(tp)) /* grow hash table if now too full */ + hgrow((union block *)tp); + } + return Succeeded; + } diff --git a/src/runtime/ocat.r b/src/runtime/ocat.r new file mode 100644 index 0000000..c778d6d --- /dev/null +++ b/src/runtime/ocat.r @@ -0,0 +1,120 @@ +/* + * File: ocat.r -- caterr, lconcat + */ +"x || y - concatenate strings x and y." + +operator{1} || cater(x, y) + + if !cnv:string(x) then + runerr(103, x) + if !cnv:string(y) then + runerr(103, y) + + abstract { + return string + } + + body { + char *s, *s2; + word len, i; + + /* + * Optimization 1: The strings to be concatenated are already + * adjacent in memory; no allocation is required. + */ + if (StrLoc(x) + StrLen(x) == StrLoc(y)) { + StrLoc(result) = StrLoc(x); + StrLen(result) = StrLen(x) + StrLen(y); + return result; + } + else if ((StrLoc(x) + StrLen(x) == strfree) + && (DiffPtrs(strend,strfree) > StrLen(y))) { + /* + * Optimization 2: The end of x is at the end of the string space. + * Hence, x was the last string allocated and need not be + * re-allocated. y is appended to the string space and the + * result is pointed to the start of x. + */ + result = x; + /* + * Append y to the end of the string space. + */ + Protect(alcstr(StrLoc(y),StrLen(y)), runerr(0)); + /* + * Set the length of the result and return. + */ + StrLen(result) = StrLen(x) + StrLen(y); + return result; + } + + /* + * Otherwise, allocate space for x and y, and copy them + * to the end of the string space. + */ + Protect(StrLoc(result) = alcstr(NULL, StrLen(x) + StrLen(y)), runerr(0)); + s = StrLoc(result); + s2 = StrLoc(x); + len = StrLen(x); + for(i = 0; i < len; i++) + *s++ = *s2++; + s2 = StrLoc(y); + len = StrLen(y); + for(i = 0; i < len; i++) + *s++ = *s2++; + + /* + * Set the length of the result and return. + */ + StrLen(result) = StrLen(x) + StrLen(y); + return result; + } +end + + +"x ||| y - concatenate lists x and y." + +operator{1} ||| lconcat(x, y) + /* + * x and y must be lists. + */ + if !is:list(x) then + runerr(108, x) + if !is:list(y) then + runerr(108, y) + + abstract { + return new list(store[(type(x) ++ type(y)).lst_elem]) + } + + body { + register struct b_list *bp1; + register struct b_lelem *lp1; + word size1, size2, size3; + + /* + * Get the size of both lists. + */ + size1 = BlkLoc(x)->list.size; + size2 = BlkLoc(y)->list.size; + size3 = size1 + size2; + + Protect(bp1 = (struct b_list *)alclist(size3), runerr(0)); + Protect(lp1 = (struct b_lelem *)alclstb(size3,(word)0,size3), runerr(0)); + bp1->listhead = bp1->listtail = (union block *)lp1; +#ifdef ListFix + lp1->listprev = lp1->listnext = (union block *)bp1; +#endif /* ListFix */ + + /* + * Make a copy of both lists in adjacent slots. + */ + cpslots(&x, lp1->lslots, (word)1, size1 + 1); + cpslots(&y, lp1->lslots + size1, (word)1, size2 + 1); + + BlkLoc(x) = (union block *)bp1; + + EVValD(&x, E_Lcreate); + + return x; + } +end diff --git a/src/runtime/ocomp.r b/src/runtime/ocomp.r new file mode 100644 index 0000000..af1b1e0 --- /dev/null +++ b/src/runtime/ocomp.r @@ -0,0 +1,177 @@ +/* + * File: ocomp.r + * Contents: lexeq, lexge, lexgt, lexle, lexlt, lexne, numeq, numge, + * numgt, numle, numlt, numne, eqv, neqv + */ + +/* + * NumComp is a macro that defines the form of a numeric comparisons. + */ +#begdef NumComp(icon_op, func_name, c_op, descript) +"x " #icon_op " y - test if x is numerically " #descript " y." + operator{0,1} icon_op func_name(x,y) + + arith_case (x, y) of { + C_integer: { + abstract { + return integer + } + inline { + if c_op(x, y) + return C_integer y; + fail; + } + } + integer: { /* large integers only */ + abstract { + return integer + } + inline { + if (big_ ## c_op (x,y)) + return y; + fail; + } + } + C_double: { + abstract { + return real + } + inline { + if c_op (x, y) + return C_double y; + fail; + } + } + } +end + +#enddef + +/* + * x = y + */ +#define NumEq(x,y) (x == y) +#define big_NumEq(x,y) (bigcmp(&x,&y) == 0) +NumComp( = , numeq, NumEq, equal to) + +/* + * x >= y + */ +#define NumGe(x,y) (x >= y) +#define big_NumGe(x,y) (bigcmp(&x,&y) >= 0) +NumComp( >=, numge, NumGe, greater than or equal to) + +/* + * x > y + */ +#define NumGt(x,y) (x > y) +#define big_NumGt(x,y) (bigcmp(&x,&y) > 0) +NumComp( > , numgt, NumGt, greater than) + +/* + * x <= y + */ +#define NumLe(x,y) (x <= y) +#define big_NumLe(x,y) (bigcmp(&x,&y) <= 0) +NumComp( <=, numle, NumLe, less than or equal to) + +/* + * x < y + */ +#define NumLt(x,y) (x < y) +#define big_NumLt(x,y) (bigcmp(&x,&y) < 0) +NumComp( < , numlt, NumLt, less than) + +/* + * x ~= y + */ +#define NumNe(x,y) (x != y) +#define big_NumNe(x,y) (bigcmp(&x,&y) != 0) +NumComp( ~=, numne, NumNe, not equal to) + +/* + * StrComp is a macro that defines the form of a string comparisons. + */ +#begdef StrComp(icon_op, func_name, special_test, c_comp, comp_value, descript) +"x " #icon_op " y - test if x is lexically " #descript " y." +operator{0,1} icon_op func_name(x,y) + declare { + int temp_str = 0; + } + abstract { + return string + } + if !cnv:tmp_string(x) then + runerr(103,x) + if !is:string(y) then + if cnv:tmp_string(y) then + inline { + temp_str = 1; + } + else + runerr(103,y) + + body { + + /* + * lexcmp does the work. + */ + if (special_test (lexcmp(&x, &y) c_comp comp_value)) { + /* + * Return y as the result of the comparison. If y was converted to + * a string, a copy of it is allocated. + */ + result = y; + if (temp_str) + Protect(StrLoc(result) = alcstr(StrLoc(result), StrLen(result)), runerr(0)); + return result; + } + else + fail; + } +end +#enddef + +StrComp(==, lexeq, (StrLen(x) == StrLen(y)) &&, ==, Equal, equal to) +StrComp(~==, lexne, (StrLen(x) != StrLen(y)) ||, !=, Equal, not equal to) + +StrComp(>>=, lexge, , !=, Less, greater than or equal to) +StrComp(>>, lexgt, , ==, Greater, greater than) +StrComp(<<=, lexle, , !=, Greater, less than or equal to) +StrComp(<<, lexlt, , ==, Less, less than) + + +"x === y - test equivalence of x and y." + +operator{0,1} === eqv(x,y) + abstract { + return type(y) + } + inline { + /* + * Let equiv do all the work, failing if equiv indicates non-equivalence. + */ + if (equiv(&x, &y)) + return y; + else + fail; + } +end + + +"x ~=== y - test inequivalence of x and y." + +operator{0,1} ~=== neqv(x,y) + abstract { + return type(y) + } + inline { + /* + * equiv does all the work. + */ + if (!equiv(&x, &y)) + return y; + else + fail; + } +end diff --git a/src/runtime/omisc.r b/src/runtime/omisc.r new file mode 100644 index 0000000..96a3e1b --- /dev/null +++ b/src/runtime/omisc.r @@ -0,0 +1,284 @@ +/* + * File: omisc.r + * Contents: refresh, size, tabmat, toby, to, llist + */ + +"^x - create a refreshed copy of a co-expression." +#ifdef Coexpr +/* + * ^x - return an entry block for co-expression x from the refresh block. + */ +operator{1} ^ refresh(x) + if !is:coexpr(x) then + runerr(118, x) + abstract { + return coexpr + } + + body { + register struct b_coexpr *sblkp; + + /* + * Get a new co-expression stack and initialize. + */ +#ifdef MultiThread + Protect(sblkp = alccoexp(0, 0), runerr(0)); +#else /* MultiThread */ + Protect(sblkp = alccoexp(), runerr(0)); +#endif /* MultiThread */ + + sblkp->freshblk = BlkLoc(x)->coexpr.freshblk; + if (ChkNull(sblkp->freshblk)) /* &main cannot be refreshed */ + runerr(215, x); + + /* + * Use refresh block to finish initializing the new co-expression. + */ + co_init(sblkp); + +#if COMPILER + sblkp->fnc = BlkLoc(x)->coexpr.fnc; + if (line_info) { + if (debug_info) + PFDebug(sblkp->pf)->proc = PFDebug(BlkLoc(x)->coexpr.pf)->proc; + PFDebug(sblkp->pf)->old_fname = + PFDebug(BlkLoc(x)->coexpr.pf)->old_fname; + PFDebug(sblkp->pf)->old_line = + PFDebug(BlkLoc(x)->coexpr.pf)->old_line; + } +#endif /* COMPILER */ + + return coexpr(sblkp); + } +#else /* Coexpr */ +operator{} ^ refresh(x) + runerr(401) +#endif /* Coexpr */ + +end + + +"*x - return size of string or object x." + +operator{1} * size(x) + abstract { + return integer + } + type_case x of { + string: inline { + return C_integer StrLen(x); + } + list: inline { + return C_integer BlkLoc(x)->list.size; + } + table: inline { + return C_integer BlkLoc(x)->table.size; + } + set: inline { + return C_integer BlkLoc(x)->set.size; + } + cset: inline { + register word i; + + i = BlkLoc(x)->cset.size; + if (i < 0) + i = cssize(&x); + return C_integer i; + } + record: inline { + return C_integer BlkLoc(x)->record.recdesc->proc.nfields; + } + coexpr: inline { + return C_integer BlkLoc(x)->coexpr.size; + } + default: { + /* + * Try to convert it to a string. + */ + if !cnv:tmp_string(x) then + runerr(112, x); /* no notion of size */ + inline { + return C_integer StrLen(x); + } + } + } +end + + +"=x - tab(match(x)). Reverses effects if resumed." + +operator{*} = tabmat(x) + /* + * x must be a string. + */ + if !cnv:string(x) then + runerr(103, x) + abstract { + return string + } + + body { + register word l; + register char *s1, *s2; + C_integer i, j; + /* + * Make a copy of &pos. + */ + i = k_pos; + + /* + * Fail if &subject[&pos:0] is not of sufficient length to contain x. + */ + j = StrLen(k_subject) - i + 1; + if (j < StrLen(x)) + fail; + + /* + * Get pointers to x (s1) and &subject (s2). Compare them on a byte-wise + * basis and fail if s1 doesn't match s2 for *s1 characters. + */ + s1 = StrLoc(x); + s2 = StrLoc(k_subject) + i - 1; + l = StrLen(x); + while (l-- > 0) { + if (*s1++ != *s2++) + fail; + } + + /* + * Increment &pos to tab over the matched string and suspend the + * matched string. + */ + l = StrLen(x); + k_pos += l; + + EVVal(k_pos, E_Spos); + + suspend x; + + /* + * tabmat has been resumed, restore &pos and fail. + */ + if (i > StrLen(k_subject) + 1) + runerr(205, kywd_pos); + else { + k_pos = i; + EVVal(k_pos, E_Spos); + } + fail; + } +end + + +"i to j by k - generate successive values." + +operator{*} ... toby(from, to, by) + /* + * arguments must be integers. + */ + if !cnv:C_integer(from) then + runerr(101, from) + if !cnv:C_integer(to) then + runerr(101, to) + if !cnv:C_integer(by) then + runerr(101, by) + + abstract { + return integer + } + + inline { + /* + * by must not be zero. + */ + if (by == 0) { + irunerr(211, by); + errorfail; + } + + /* + * Count up or down (depending on relationship of from and to) and + * suspend each value in sequence, failing when the limit has been + * exceeded. + */ + if (by > 0) + for ( ; from <= to; from += by) { + suspend C_integer from; + } + else + for ( ; from >= to; from += by) { + suspend C_integer from; + } + fail; + } +end + + +"i to j - generate successive values." + +operator{*} ... to(from, to) + /* + * arguments must be integers. + */ + if !cnv:C_integer(from) then + runerr(101, from) + if !cnv:C_integer(to) then + runerr(101, to) + + abstract { + return integer + } + + inline { + for ( ; from <= to; ++from) { + suspend C_integer from; + } + fail; + } +end + + +" [x1, x2, ... ] - create an explicitly specified list." + +operator{1} [...] llist(elems[n]) + abstract { + return new list(type(elems)) + } + body { + tended struct b_list *hp; + register word i; + register struct b_lelem *bp; /* need not be tended */ + word nslots; + + nslots = n; + if (nslots == 0) + nslots = MinListSlots; + + /* + * Allocate the list and a list block. + */ + Protect(hp = alclist(n), runerr(0)); + Protect(bp = alclstb(nslots, (word)0, n), runerr(0)); + + /* + * Make the list block just allocated into the first and last blocks + * for the list. + */ + hp->listhead = hp->listtail = (union block *)bp; +#ifdef ListFix + bp->listprev = bp->listnext = (union block *)hp; +#endif /* ListFix */ + + /* + * Assign each argument to a list element. + */ + for (i = 0; i < n; i++) + bp->lslots[i] = elems[i]; + +/* Not quite right -- should be after list() returns in case it fails */ + Desc_EVValD(hp, E_Lcreate, D_List); + + return list(hp); + } +end + diff --git a/src/runtime/oref.r b/src/runtime/oref.r new file mode 100644 index 0000000..3ac86bc --- /dev/null +++ b/src/runtime/oref.r @@ -0,0 +1,881 @@ +/* + * File: oref.r + * Contents: bang, random, sect, subsc + */ + +"!x - generate successive values from object x." + +operator{*} ! bang(underef x -> dx) + declare { + register C_integer i, j; + tended union block *ep; + struct hgstate state; + char ch; + } + + if is:variable(x) && is:string(dx) then { + abstract { + return new tvsubs(type(x)) + } + inline { + /* + * A nonconverted string from a variable is being banged. + * Loop through the string suspending one-character substring + * trapped variables. + */ + for (i = 1; i <= StrLen(dx); i++) { + suspend tvsubs(&x, i, (word)1); + deref(&x, &dx); + if (!is:string(dx)) + runerr(103, dx); + } + } + } + else type_case dx of { + + list: { + abstract { + return type(dx).lst_elem + } + inline { + +#ifdef EventMon + word xi = 0; + + EVValD(&dx, E_Lbang); +#endif /* EventMon */ + + /* + * x is a list. Chain through each list element block and for + * each one, suspend with a variable pointing to each + * element contained in the block. + */ + for (ep = BlkLoc(dx)->list.listhead; +#ifdef ListFix + BlkType(ep) == T_Lelem; +#else /* ListFix */ + ep != NULL; +#endif /* ListFix */ + ep = ep->lelem.listnext){ + for (i = 0; i < ep->lelem.nused; i++) { + j = ep->lelem.first + i; + if (j >= ep->lelem.nslots) + j -= ep->lelem.nslots; + +#ifdef EventMon + MakeInt(++xi, &eventdesc); + EVValD(&eventdesc, E_Lsub); +#endif /* EventMon */ + + suspend struct_var(&ep->lelem.lslots[j], ep); + } + } + } + } + + file: { + abstract { + return string + } + body { + FILE *fd; + char sbuf[MaxCvtLen]; + register char *sp; + register C_integer slen, rlen; + word status; + + /* + * x is a file. Read the next line into the string space + * and suspend the newly allocated string. + */ + fd = BlkLoc(dx)->file.fd; + + status = BlkLoc(dx)->file.status; + if ((status & Fs_Read) == 0) + runerr(212, dx); + +#ifdef ReadDirectory + if ((status & Fs_Directory) != 0) { + for (;;) { + struct dirent *de = readdir((DIR*) fd); + if (de == NULL) + fail; + slen = strlen(de->d_name); + Protect(sp = alcstr(de->d_name, slen), runerr(0)); + suspend string(slen, sp); + } + } +#endif /* ReadDirectory */ + + if (status & Fs_Writing) { + fseek(fd, 0L, SEEK_CUR); + BlkLoc(dx)->file.status &= ~Fs_Writing; + } + BlkLoc(dx)->file.status |= Fs_Reading; + status = BlkLoc(dx)->file.status; + + for (;;) { + StrLen(result) = 0; + do { + +#ifdef Graphics + pollctr >>= 1; pollctr++; + if (status & Fs_Window) { + slen = wgetstrg(sbuf,MaxCvtLen,fd); + if (slen == -1) + runerr(141); + else if (slen < -1) + runerr(143); + } + else +#endif /* Graphics */ + + if ((slen = getstrg(sbuf,MaxCvtLen,&BlkLoc(dx)->file)) == -1) + fail; + rlen = slen < 0 ? (word)MaxCvtLen : slen; + + Protect(reserve(Strings, rlen), runerr(0)); + if (!InRange(strbase,StrLoc(result),strfree)) { + Protect(reserve(Strings, StrLen(result)+rlen), runerr(0)); + Protect((StrLoc(result) = alcstr(StrLoc(result), + StrLen(result))), runerr(0)); + } + + Protect(sp = alcstr(sbuf,rlen), runerr(0)); + if (StrLen(result) == 0) + StrLoc(result) = sp; + StrLen(result) += rlen; + } while (slen < 0); + suspend result; + } + } + } + + table: { + abstract { + return type(dx).tbl_val + } + inline { + struct b_tvtbl *tp; + + EVValD(&dx, E_Tbang); + + /* + * x is a table. Chain down the element list in each bucket + * and suspend a variable pointing to each element in turn. + */ + for (ep = hgfirst(BlkLoc(dx), &state); ep != 0; + ep = hgnext(BlkLoc(dx), &state, ep)) { + + EVValD(&ep->telem.tval, E_Tval); + + Protect(tp = alctvtbl(&dx, &ep->telem.tref, ep->telem.hashnum), runerr(0)); + suspend tvtbl(tp); + } + } + } + + set: { + abstract { + return store[type(dx).set_elem] + } + inline { + EVValD(&dx, E_Sbang); + /* + * This is similar to the method for tables except that a + * value is returned instead of a variable. + */ + for (ep = hgfirst(BlkLoc(dx), &state); ep != 0; + ep = hgnext(BlkLoc(dx), &state, ep)) { + EVValD(&ep->selem.setmem, E_Sval); + suspend ep->selem.setmem; + } + } + } + + record: { + abstract { + return type(dx).all_fields + } + inline { + /* + * x is a record. Loop through the fields and suspend + * a variable pointing to each one. + */ + +#ifdef EventMon + word xi = 0; + + EVValD(&dx, E_Rbang); +#endif /* EventMon */ + + j = BlkLoc(dx)->record.recdesc->proc.nfields; + for (i = 0; i < j; i++) { + +#ifdef EventMon + MakeInt(++xi, &eventdesc); + EVValD(&eventdesc, E_Rsub); +#endif /* EventMon */ + + suspend struct_var(&BlkLoc(dx)->record.fields[i], + (struct b_record *)BlkLoc(dx)); + } + } + } + + default: + if cnv:tmp_string(dx) then { + abstract { + return string + } + inline { + /* + * A (converted or non-variable) string is being banged. + * Loop through the string suspending simple one character + * substrings. + */ + for (i = 1; i <= StrLen(dx); i++) { + ch = *(StrLoc(dx) + i - 1); + suspend string(1, (char *)&allchars[ch & 0xFF]); + } + } + } + else + runerr(116, dx); + } + + inline { + fail; + } +end + + +#define RandVal (RanScale*(k_random=(RandA*k_random+RandC)&0x7FFFFFFFL)) + +"?x - produce a randomly selected element of x." + +operator{0,1} ? random(underef x -> dx) + +#ifndef LargeInts + declare { + C_integer v = 0; + } +#endif /* LargeInts */ + + if is:variable(x) && is:string(dx) then { + abstract { + return new tvsubs(type(x)) + } + body { + C_integer val; + double rval; + + /* + * A string from a variable is being banged. Produce a one + * character substring trapped variable. + */ + if ((val = StrLen(dx)) <= 0) + fail; + rval = RandVal; /* This form is used to get around */ + rval *= val; /* a bug in a certain C compiler */ + return tvsubs(&x, (word)rval + 1, (word)1); + } + } + else type_case dx of { + string: { + /* + * x is a string, but it is not a variable. Produce a + * random character in it as the result; a substring + * trapped variable is not needed. + */ + abstract { + return string + } + body { + C_integer val; + double rval; + + if ((val = StrLen(dx)) <= 0) + fail; + rval = RandVal; + rval *= val; + return string(1, StrLoc(dx)+(word)rval); + } + } + + cset: { + /* + * x is a cset. Convert it to a string, select a random character + * of that string and return it. A substring trapped variable is + * not needed. + */ + if !cnv:tmp_string(dx) then + { /* cannot fail */ } + abstract { + return string + } + body { + C_integer val; + double rval; + char ch; + + if ((val = StrLen(dx)) <= 0) + fail; + rval = RandVal; + rval *= val; + ch = *(StrLoc(dx) + (word)rval); + return string(1, (char *)&allchars[ch & 0xFF]); + } + } + + list: { + abstract { + return type(dx).lst_elem + } + /* + * x is a list. Set i to a random number in the range [1,*x], + * failing if the list is empty. + */ + body { + C_integer val; + double rval; + register C_integer i, j; + union block *bp; /* doesn't need to be tended */ + val = BlkLoc(dx)->list.size; + if (val <= 0) + fail; + rval = RandVal; + rval *= val; + i = (word)rval + 1; + +#ifdef EventMon + EVValD(&dx, E_Lrand); + MakeInt(i, &eventdesc); + EVValD(&eventdesc, E_Lsub); +#endif /* EventMon */ + + j = 1; + /* + * Work down chain list of list blocks and find the block that + * contains the selected element. + */ + bp = BlkLoc(dx)->list.listhead; + while (i >= j + bp->lelem.nused) { + j += bp->lelem.nused; + bp = bp->lelem.listnext; +#ifdef ListFix + if (BlkType(bp) == T_List) +#else /* ListFix */ + if (bp == NULL) +#endif /* ListFix */ + syserr("list reference out of bounds in random"); + } + /* + * Locate the appropriate element and return a variable + * that points to it. + */ + i += bp->lelem.first - j; + if (i >= bp->lelem.nslots) + i -= bp->lelem.nslots; + return struct_var(&bp->lelem.lslots[i], bp); + } + } + + table: { + abstract { + return type(dx).tbl_val + } + /* + * x is a table. Set n to a random number in the range [1,*x], + * failing if the table is empty. + */ + body { + C_integer val; + double rval; + register C_integer i, j, n; + union block *ep, *bp; /* doesn't need to be tended */ + struct b_slots *seg; + struct b_tvtbl *tp; + + bp = BlkLoc(dx); + val = bp->table.size; + if (val <= 0) + fail; + rval = RandVal; + rval *= val; + n = (word)rval + 1; + +#ifdef EventMon + EVValD(&dx, E_Trand); + MakeInt(n, &eventdesc); + EVValD(&eventdesc, E_Tsub); +#endif /* EventMon */ + + + /* + * Walk down the hash chains to find and return the nth element + * as a variable. + */ + for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) + for (j = segsize[i] - 1; j >= 0; j--) + for (ep = seg->hslots[j]; +#ifdef TableFix + BlkType(ep) == T_Telem; +#else /* TableFix */ + ep != NULL; +#endif /* TableFix */ + ep = ep->telem.clink) + if (--n <= 0) { + Protect(tp = alctvtbl(&dx, &ep->telem.tref, ep->telem.hashnum), runerr(0)); + return tvtbl(tp); + } + syserr("table reference out of bounds in random"); + } + } + + set: { + abstract { + return store[type(dx).set_elem] + } + /* + * x is a set. Set n to a random number in the range [1,*x], + * failing if the set is empty. + */ + body { + C_integer val; + double rval; + register C_integer i, j, n; + union block *bp, *ep; /* doesn't need to be tended */ + struct b_slots *seg; + + bp = BlkLoc(dx); + val = bp->set.size; + if (val <= 0) + fail; + rval = RandVal; + rval *= val; + n = (word)rval + 1; + +#ifdef EventMon + EVValD(&dx, E_Srand); + MakeInt(n, &eventdesc); +#endif /* EventMon */ + + /* + * Walk down the hash chains to find and return the nth element. + */ + for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) + for (j = segsize[i] - 1; j >= 0; j--) + for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink) + if (--n <= 0) + return ep->selem.setmem; + syserr("set reference out of bounds in random"); + } + } + + record: { + abstract { + return type(dx).all_fields + } + /* + * x is a record. Set val to a random number in the range + * [1,*x] (*x is the number of fields), failing if the + * record has no fields. + */ + body { + C_integer val; + double rval; + struct b_record *rec; /* doesn't need to be tended */ + + rec = (struct b_record *)BlkLoc(dx); + val = rec->recdesc->proc.nfields; + if (val <= 0) + fail; + /* + * Locate the selected element and return a variable + * that points to it + */ + rval = RandVal; + rval *= val; + +#ifdef EventMon + EVValD(&dx, E_Rrand); + MakeInt(rval + 1, &eventdesc); + EVValD(&eventdesc, E_Rsub); +#endif /* EventMon */ + + return struct_var(&rec->fields[(word)rval], rec); + } + } + + default: { + +#ifdef LargeInts + if !cnv:integer(dx) then + runerr(113, dx) +#else /* LargeInts */ + if !cnv:C_integer(dx,v) then + runerr(113, dx) +#endif /* LargeInts */ + + abstract { + return integer ++ real + } + body { + double rval; + +#ifdef LargeInts + C_integer v; + if (Type(dx) == T_Lrgint) { + if (bigrand(&dx, &result) == Error) /* alcbignum failed */ + runerr(0); + return result; + } + + v = IntVal(dx); +#endif /* LargeInts */ + /* + * x is an integer, be sure that it's non-negative. + */ + if (v < 0) + runerr(205, dx); + + /* + * val contains the integer value of x. If val is 0, return + * a real in the range [0,1), else return an integer in the + * range [1,val]. + */ + if (v == 0) { + rval = RandVal; + return C_double rval; + } + else { + rval = RandVal; + rval *= v; + return C_integer (long)rval + 1; + } + } + } + } +end + +"x[i:j] - form a substring or list section of x." + +operator{0,1} [:] sect(underef x -> dx, i, j) + declare { + int use_trap = 0; + } + + if is:list(dx) then { + abstract { + return type(dx) + } + /* + * If it isn't a C integer, but is a large integer, fail on + * the out-of-range index. + */ + if !cnv:C_integer(i) then { + if cnv : integer(i) then inline { fail; } + runerr(101, i) + } + if !cnv:C_integer(j) then { + if cnv : integer(j) then inline { fail; } + runerr(101, j) + } + + body { + C_integer t; + + i = cvpos((long)i, (long)BlkLoc(dx)->list.size); + if (i == CvtFail) + fail; + j = cvpos((long)j, (long)BlkLoc(dx)->list.size); + if (j == CvtFail) + fail; + if (i > j) { + t = i; + i = j; + j = t; + } + if (cplist(&dx, &result, i, j) == Error) + runerr(0); + return result; + } + } + else { + + /* + * x should be a string. If x is a variable, we must create a + * substring trapped variable. + */ + if is:variable(x) && is:string(dx) then { + abstract { + return new tvsubs(type(x)) + } + inline { + use_trap = 1; + } + } + else if cnv:string(dx) then + abstract { + return string + } + else + runerr(110, dx) + + /* + * If it isn't a C integer, but is a large integer, fail on + * the out-of-range index. + */ + if !cnv:C_integer(i) then { + if cnv : integer(i) then inline { fail; } + runerr(101, i) + } + if !cnv:C_integer(j) then { + if cnv : integer(j) then inline { fail; } + runerr(101, j) + } + + body { + C_integer t; + + i = cvpos((long)i, (long)StrLen(dx)); + if (i == CvtFail) + fail; + j = cvpos((long)j, (long)StrLen(dx)); + if (j == CvtFail) + fail; + if (i > j) { /* convert section to substring */ + t = i; + i = j; + j = t - j; + } + else + j = j - i; + + if (use_trap) { + return tvsubs(&x, i, j); + } + else + return string(j, StrLoc(dx)+i-1); + } + } +end + +"x[y] - access yth character or element of x." + +operator{0,1} [] subsc(underef x -> dx,y) + declare { + int use_trap = 0; + } + + type_case dx of { + list: { + abstract { + return type(dx).lst_elem + } + /* + * Make sure that y is a C integer. + */ + if !cnv:C_integer(y) then { + /* + * If it isn't a C integer, but is a large integer, fail on + * the out-of-range index. + */ + if cnv : integer(y) then inline { fail; } + runerr(101, y) + } + body { + word i, j; + register union block *bp; /* doesn't need to be tended */ + struct b_list *lp; /* doesn't need to be tended */ + +#ifdef EventMon + EVValD(&dx, E_Lref); + MakeInt(y, &eventdesc); + EVValD(&eventdesc, E_Lsub); +#endif /* EventMon */ + + /* + * Make sure that subscript y is in range. + */ + lp = (struct b_list *)BlkLoc(dx); + i = cvpos((long)y, (long)lp->size); + if (i == CvtFail || i > lp->size) + fail; + /* + * Locate the list-element block containing the desired + * element. + */ + bp = lp->listhead; + j = 1; + /* + * y is in range, so bp can never be null here. if it was, a memory + * violation would occur in the code that follows, anyhow, so + * exiting the loop on a NULL bp makes no sense. + */ + while (i >= j + bp->lelem.nused) { + j += bp->lelem.nused; + bp = bp->lelem.listnext; + } + + /* + * Locate the desired element and return a pointer to it. + */ + i += bp->lelem.first - j; + if (i >= bp->lelem.nslots) + i -= bp->lelem.nslots; + return struct_var(&bp->lelem.lslots[i], bp); + } + } + + table: { + abstract { + store[type(dx).tbl_key] = type(y) /* the key might be added */ + return type(dx).tbl_val ++ new tvtbl(type(dx)) + } + /* + * x is a table. Return a table element trapped variable + * representing the result; defer actual lookup until later. + */ + body { + uword hn; + struct b_tvtbl *tp; + + EVValD(&dx, E_Tref); + EVValD(&y, E_Tsub); + + hn = hash(&y); + Protect(tp = alctvtbl(&dx, &y, hn), runerr(0)); + return tvtbl(tp); + } + } + + record: { + abstract { + return type(dx).all_fields + } + /* + * x is a record. Convert y to an integer and be sure that it + * it is in range as a field number. + */ + if !cnv:C_integer(y) then body { + if (!cnv:tmp_string(y,y)) + runerr(101,y); + else { + register union block *bp; /* doesn't need to be tended */ + register union block *bp2; /* doesn't need to be tended */ + register word i; + register int len; + char *loc; + int nf; + bp = BlkLoc(dx); + bp2 = BlkLoc(dx)->record.recdesc; + nf = bp2->proc.nfields; + loc = StrLoc(y); + len = StrLen(y); + for(i=0; i<nf; i++) { + if (len == StrLen(bp2->proc.lnames[i]) && + !strncmp(loc, StrLoc(bp2->proc.lnames[i]), len)) { + +#ifdef EventMon + EVValD(&dx, E_Rref); + MakeInt(i+1, &eventdesc); + EVValD(&eventdesc, E_Rsub); +#endif /* EventMon */ + + /* + * Found the field, return a pointer to it. + */ + return struct_var(&bp->record.fields[i], bp); + } + } + fail; + } + } + else + body { + word i; + register union block *bp; /* doesn't need to be tended */ + + bp = BlkLoc(dx); + i = cvpos(y, (word)(bp->record.recdesc->proc.nfields)); + if (i == CvtFail || i > bp->record.recdesc->proc.nfields) + fail; + +#ifdef EventMon + EVValD(&dx, E_Rref); + MakeInt(i, &eventdesc); + EVValD(&eventdesc, E_Rsub); +#endif /* EventMon */ + + /* + * Locate the appropriate field and return a pointer to it. + */ + return struct_var(&bp->record.fields[i-1], bp); + } + } + + default: { + /* + * dx must either be a string or be convertible to one. Decide + * whether a substring trapped variable can be created. + */ + if is:variable(x) && is:string(dx) then { + abstract { + return new tvsubs(type(x)) + } + inline { + use_trap = 1; + } + } + else if cnv:tmp_string(dx) then + abstract { + return string + } + else + runerr(114, dx) + + /* + * Make sure that y is a C integer. + */ + if !cnv:C_integer(y) then { + /* + * If it isn't a C integer, but is a large integer, fail on + * the out-of-range index. + */ + if cnv : integer(y) then inline { fail; } + runerr(101, y) + } + + body { + char ch; + word i; + + /* + * Convert y to a position in x and fail if the position + * is out of bounds. + */ + i = cvpos(y, StrLen(dx)); + if (i == CvtFail || i > StrLen(dx)) + fail; + if (use_trap) { + /* + * x is a string, make a substring trapped variable for the + * one character substring selected and return it. + */ + return tvsubs(&x, i, (word)1); + } + else { + /* + * x was converted to a string, so it cannot be assigned + * back into. Just return a string containing the selected + * character. + */ + ch = *(StrLoc(dx)+i-1); + return string(1, (char *)&allchars[ch & 0xFF]); + } + } + } + } +end diff --git a/src/runtime/oset.r b/src/runtime/oset.r new file mode 100644 index 0000000..7808e80 --- /dev/null +++ b/src/runtime/oset.r @@ -0,0 +1,299 @@ +/* + * File: oset.r + * Contents: compl, diff, inter, union + */ + +"~x - complement cset x." + +operator{1} ~ compl(x) + /* + * x must be a cset. + */ + if !cnv:tmp_cset(x) then + runerr(104, x) + + abstract { + return cset + } + body { + register int i; + struct b_cset *cp, *cpx; + + /* + * Allocate a new cset and then copy each cset word from x + * into the new cset words, complementing each bit. + */ + Protect(cp = alccset(), runerr(0)); + cpx = (struct b_cset *)BlkLoc(x); /* must come after alccset() */ + for (i = 0; i < CsetSize; i++) + cp->bits[i] = ~cpx->bits[i]; + return cset(cp); + } +end + + +"x -- y - difference of csets x and y or of sets x and y." + +operator{1} -- diff(x,y) + if is:set(x) && is:set(y) then { + abstract { + return type(x) + } + body { + int res; + register int i; + register word slotnum; + tended union block *srcp, *tstp, *dstp; + tended struct b_slots *seg; + tended struct b_selem *ep; + struct b_selem *np; + union block **hook; + + /* + * Make a new set based on the size of x. + */ + dstp = hmake(T_Set, (word)0, BlkLoc(x)->set.size); + if (dstp == NULL) + runerr(0); + /* + * For each element in set x if it is not in set y + * copy it directly into the result set. + * + * np always has a new element ready for use. We get one in advance, + * and stay one ahead, because hook can't be tended. + */ + srcp = BlkLoc(x); + tstp = BlkLoc(y); + Protect(np = alcselem(&nulldesc, (uword)0), runerr(0)); + + for (i = 0; i < HSegs && (seg = srcp->set.hdir[i]) != NULL; i++) + for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--) { + ep = (struct b_selem *)seg->hslots[slotnum]; + while (ep != NULL) { + memb(tstp, &ep->setmem, ep->hashnum, &res); + if (res == 0) { + hook = memb(dstp, &ep->setmem, ep->hashnum, &res); + np->setmem = ep->setmem; + np->hashnum = ep->hashnum; + addmem(&dstp->set, np, hook); + Protect(np = alcselem(&nulldesc, (uword)0), runerr(0)); + } + ep = (struct b_selem *)ep->clink; + } + } + deallocate((union block *)np); + if (TooSparse(dstp)) + hshrink(dstp); + Desc_EVValD(dstp, E_Screate, D_Set); + return set(dstp); + } + } + else { + if !cnv:tmp_cset(x) then + runerr(120, x) + if !cnv:tmp_cset(y) then + runerr(120, y) + abstract { + return cset + } + /* + * Allocate a new cset and in each word of it, compute the value + * of the bitwise difference of the corresponding words in the + * Arg1 and Arg2 csets. + */ + body { + struct b_cset *cp, *cpx, *cpy; + register int i; + + Protect(cp = alccset(), runerr(0)); + cpx = (struct b_cset *)BlkLoc(x); /* must come after alccset() */ + cpy = (struct b_cset *)BlkLoc(y); /* must come after alccset() */ + for (i = 0; i < CsetSize; i++) + cp->bits[i] = cpx->bits[i] & ~cpy->bits[i]; + return cset(cp); + } + } +end + + +"x ** y - intersection of csets x and y or of sets x and y." + +operator{1} ** inter(x,y) + if is:set(x) && is:set(y) then { + abstract { + return new set(store[type(x).set_elem] ** store[type(y).set_elem]) + } + body { + int res; + register int i; + register word slotnum; + tended union block *srcp, *tstp, *dstp; + tended struct b_slots *seg; + tended struct b_selem *ep; + struct b_selem *np; + union block **hook; + + /* + * Make a new set the size of the smaller argument set. + */ + dstp = hmake(T_Set, (word)0, + Min(BlkLoc(x)->set.size, BlkLoc(y)->set.size)); + if (dstp == NULL) + runerr(0); + /* + * Using the smaller of the two sets as the source + * copy directly into the result each of its elements + * that are also members of the other set. + * + * np always has a new element ready for use. We get one in advance, + * and stay one ahead, because hook can't be tended. + */ + if (BlkLoc(x)->set.size <= BlkLoc(y)->set.size) { + srcp = BlkLoc(x); + tstp = BlkLoc(y); + } + else { + srcp = BlkLoc(y); + tstp = BlkLoc(x); + } + Protect(np = alcselem(&nulldesc, (uword)0), runerr(0)); + for (i = 0; i < HSegs && (seg = srcp->set.hdir[i]) != NULL; i++) + for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--) { + ep = (struct b_selem *)seg->hslots[slotnum]; + while (ep != NULL) { + memb(tstp, &ep->setmem, ep->hashnum, &res); + if (res != 0) { + hook = memb(dstp, &ep->setmem, ep->hashnum, &res); + np->setmem = ep->setmem; + np->hashnum = ep->hashnum; + addmem(&dstp->set, np, hook); + Protect(np = alcselem(&nulldesc, (uword)0), runerr(0)); + } + ep = (struct b_selem *)ep->clink; + } + } + deallocate((union block *)np); + if (TooSparse(dstp)) + hshrink(dstp); + Desc_EVValD(dstp, E_Screate, D_Set); + return set(dstp); + } + } + else { + + if !cnv:tmp_cset(x) then + runerr(120, x) + if !cnv:tmp_cset(y) then + runerr(120, y) + abstract { + return cset + } + + /* + * Allocate a new cset and in each word of it, compute the value + * of the bitwise intersection of the corresponding words in the + * x and y csets. + */ + body { + struct b_cset *cp, *cpx, *cpy; + register int i; + + Protect(cp = alccset(), runerr(0)); + cpx = (struct b_cset *)BlkLoc(x); /* must come after alccset() */ + cpy = (struct b_cset *)BlkLoc(y); /* must come after alccset() */ + for (i = 0; i < CsetSize; i++) { + cp->bits[i] = cpx->bits[i] & cpy->bits[i]; + } + return cset(cp); + } + } +end + + +"x ++ y - union of csets x and y or of sets x and y." + +operator{1} ++ union(x,y) + if is:set(x) && is:set(y) then { + abstract { + return new set(store[type(x).set_elem] ++ store[type(y).set_elem]) + } + body { + int res; + register int i; + register word slotnum; + struct descrip d; + tended union block *dstp; + tended struct b_slots *seg; + tended struct b_selem *ep; + struct b_selem *np; + union block **hook; + + /* + * Ensure that x is the larger set; if not, swap. + */ + if (BlkLoc(y)->set.size > BlkLoc(x)->set.size) { + d = x; + x = y; + y = d; + } + /* + * Copy x and ensure there's room for *x + *y elements. + */ + if (cpset(&x, &result, BlkLoc(x)->set.size + BlkLoc(y)->set.size) + == Error) + runerr(0); + /* + * Copy each element from y into the result, if not already there. + * + * np always has a new element ready for use. We get one in advance, + * and stay one ahead, because hook can't be tended. + */ + dstp = BlkLoc(result); + Protect(np = alcselem(&nulldesc, (uword)0), runerr(0)); + for (i = 0; i < HSegs && (seg = BlkLoc(y)->set.hdir[i]) != NULL; i++) + for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--) { + ep = (struct b_selem *)seg->hslots[slotnum]; + while (ep != NULL) { + hook = memb(dstp, &ep->setmem, ep->hashnum, &res); + if (res == 0) { + np->setmem = ep->setmem; + np->hashnum = ep->hashnum; + addmem(&dstp->set, np, hook); + Protect(np = alcselem(&nulldesc, (uword)0), runerr(0)); + } + ep = (struct b_selem *)ep->clink; + } + } + deallocate((union block *)np); + if (TooCrowded(dstp)) /* if the union got too big, enlarge */ + hgrow(dstp); + return result; + } + } + else { + if !cnv:tmp_cset(x) then + runerr(120, x) + if !cnv:tmp_cset(y) then + runerr(120, y) + abstract { + return cset + } + + /* + * Allocate a new cset and in each word of it, compute the value + * of the bitwise union of the corresponding words in the + * x and y csets. + */ + body { + struct b_cset *cp, *cpx, *cpy; + register int i; + + Protect(cp = alccset(), runerr(0)); + cpx = (struct b_cset *)BlkLoc(x); /* must come after alccset() */ + cpy = (struct b_cset *)BlkLoc(y); /* must come after alccset() */ + for (i = 0; i < CsetSize; i++) + cp->bits[i] = cpx->bits[i] | cpy->bits[i]; + return cset(cp); + } + } +end diff --git a/src/runtime/ovalue.r b/src/runtime/ovalue.r new file mode 100644 index 0000000..e428868 --- /dev/null +++ b/src/runtime/ovalue.r @@ -0,0 +1,72 @@ +/* + * File: ovalue.r + * Contents: nonnull, null, value, conj + */ + +"\\x - test x for nonnull value." + +operator{0,1} \ nonnull(underef x -> dx) + abstract { + return type(x) + } + /* + * If the dereferenced value dx is not null, the pre-dereferenced + * x is returned, otherwise, the function fails. + */ + if is:null(dx) then + inline { + fail; + } + else { + inline { + return x; + } + } +end + + + +"/x - test x for null value." + +operator{0,1} / null(underef x -> dx) + abstract { + return type(x) + } + /* + * If the dereferenced value dx is null, the pre-derefereneced value + * x is returned, otherwise, the function fails. + */ + if is:null(dx) then { + inline { + return x; + } + } + else + inline { + fail; + } +end + + +".x - produce value of x." + +operator{1} . value(x) + abstract { + return type(x) + } + inline { + return x; + } +end + + +"x & y - produce value of y." + +operator{1} & conj(underef x, underef y) + abstract { + return type(y) + } + inline { + return y; + } +end diff --git a/src/runtime/ralc.r b/src/runtime/ralc.r new file mode 100644 index 0000000..9f55671 --- /dev/null +++ b/src/runtime/ralc.r @@ -0,0 +1,784 @@ +/* + * File: ralc.r + * Contents: allocation routines + */ + +/* + * Prototypes. + */ +static struct region *findgap (struct region *curr, word nbytes); +static struct region *newregion (word nbytes, word stdsize); + +extern word alcnum; + +#ifndef MultiThread +word coexp_ser = 2; /* serial numbers for co-expressions; &main is 1 */ +word list_ser = 1; /* serial numbers for lists */ +word set_ser = 1; /* serial numbers for sets */ +word table_ser = 1; /* serial numbers for tables */ +#endif /* MultiThread */ + + +/* + * AlcBlk - allocate a block. + */ +#begdef AlcBlk(var, struct_nm, t_code, nbytes) +{ +#ifdef MultiThread + EVVal((word)nbytes, typech[t_code]); +#endif /* MultiThread */ + + /* + * Ensure that there is enough room in the block region. + */ + if (DiffPtrs(blkend,blkfree) < nbytes && !reserve(Blocks, nbytes)) + return NULL; + + /* + * If monitoring, show the allocation. + */ +#ifndef MultiThread + EVVal((word)nbytes, typech[t_code]); +#endif + + /* + * Decrement the free space in the block region by the number of bytes + * allocated and return the address of the first byte of the allocated + * block. + */ + blktotal += nbytes; + var = (struct struct_nm *)blkfree; + blkfree += nbytes; + var->title = t_code; +} +#enddef + +/* + * AlcFixBlk - allocate a fixed length block. + */ +#define AlcFixBlk(var, struct_nm, t_code)\ + AlcBlk(var, struct_nm, t_code, sizeof(struct struct_nm)) + +/* + * AlcVarBlk - allocate a variable-length block. + */ +#begdef AlcVarBlk(var, struct_nm, t_code, n_desc) + { +#ifdef EventMon + uword size; +#else /* EventMon */ + register uword size; +#endif /* EventMon */ + + /* + * Variable size blocks are declared with one descriptor, thus + * we need add in only n_desc - 1 descriptors. + */ + size = sizeof(struct struct_nm) + (n_desc - 1) * sizeof(struct descrip); + AlcBlk(var, struct_nm, t_code, size) + var->blksize = size; + } +#enddef + +/* + * alcactiv - allocate a co-expression activation block. + */ + +struct astkblk *alcactiv() + { + struct astkblk *abp; + + abp = (struct astkblk *)malloc(sizeof(struct astkblk)); + + /* + * If malloc failed, attempt to free some co-expression blocks and retry. + */ + if (abp == NULL) { + collect(Static); + abp = (struct astkblk *)malloc(sizeof(struct astkblk)); + } + + if (abp == NULL) + ReturnErrNum(305, NULL); + abp->nactivators = 0; + abp->astk_nxt = NULL; + return abp; + } + +#ifdef LargeInts +/* + * alcbignum - allocate an n-digit bignum in the block region + */ + +struct b_bignum *alcbignum(n) +word n; + { + register struct b_bignum *blk; + register uword size; + + size = sizeof(struct b_bignum) + ((n - 1) * sizeof(DIGIT)); + /* ensure whole number of words allocated */ + size = (size + WordSize - 1) & -WordSize; + AlcBlk(blk, b_bignum, T_Lrgint, size); + blk->blksize = size; + blk->msd = blk->sign = 0; + blk->lsd = n - 1; + return blk; + } +#endif /* LargeInts */ + +/* + * alccoexp - allocate a co-expression stack block. + */ + +#if COMPILER +struct b_coexpr *alccoexp() + { + struct b_coexpr *ep; + static int serial = 2; /* main co-expression is allocated elsewhere */ + ep = (struct b_coexpr *)malloc(stksize); + + /* + * If malloc failed or if there have been too many co-expression allocations + * since a collection, attempt to free some co-expression blocks and retry. + */ + + if (ep == NULL || alcnum > AlcMax) { + collect(Static); + ep = (struct b_coexpr *)malloc(stksize); + } + + if (ep == NULL) + ReturnErrNum(305, NULL); + + alcnum++; /* increment allocation count since last g.c. */ + + ep->title = T_Coexpr; + ep->size = 0; + ep->id = serial++; + ep->nextstk = stklist; + ep->es_tend = NULL; + ep->file_name = ""; + ep->line_num = 0; + ep->freshblk = nulldesc; + ep->es_actstk = NULL; + ep->cstate[0] = 0; /* zero the first two cstate words as a flag */ + ep->cstate[1] = 0; + stklist = ep; + return ep; + } +#else /* COMPILER */ +#ifdef MultiThread +/* + * If this is a new program being loaded, an icodesize>0 gives the + * hdr.hsize and a stacksize to use; allocate + * sizeof(progstate) + icodesize + mstksize + * Otherwise (icodesize==0), allocate a normal stksize... + */ +struct b_coexpr *alccoexp(icodesize, stacksize) +long icodesize, stacksize; +#else /* MultiThread */ +struct b_coexpr *alccoexp() +#endif /* MultiThread */ + + { + struct b_coexpr *ep; + +#ifdef MultiThread + if (icodesize > 0) { + ep = (struct b_coexpr *) + calloc(1, stacksize+ + icodesize+ + sizeof(struct progstate)+ + sizeof(struct b_coexpr)); + } + else +#endif /* MultiThread */ + + ep = (struct b_coexpr *)malloc(stksize); + + /* + * If malloc failed or if there have been too many co-expression allocations + * since a collection, attempt to free some co-expression blocks and retry. + */ + + if (ep == NULL || alcnum > AlcMax) { + + collect(Static); + +#ifdef MultiThread + if (icodesize>0) { + ep = (struct b_coexpr *) + malloc(mstksize+icodesize+sizeof(struct progstate)); + } + else +#endif /* MultiThread */ + + ep = (struct b_coexpr *)malloc(stksize); + } + if (ep == NULL) + ReturnErrNum(305, NULL); + + alcnum++; /* increment allocation count since last g.c. */ + + ep->title = T_Coexpr; + ep->es_actstk = NULL; + ep->size = 0; +#ifdef MultiThread + ep->es_pfp = NULL; + ep->es_gfp = NULL; + ep->es_argp = NULL; + ep->tvalloc = NULL; + + if (icodesize > 0) + ep->id = 1; + else +#endif /* MultiThread */ + ep->id = coexp_ser++; + ep->nextstk = stklist; + ep->es_tend = NULL; + ep->cstate[0] = 0; /* zero the first two cstate words as a flag */ + ep->cstate[1] = 0; + +#ifdef MultiThread + /* + * Initialize program state to self for &main; curpstate for others. + */ + if(icodesize>0) ep->program = (struct progstate *)(ep+1); + else ep->program = curpstate; +#endif /* MultiThread */ + + stklist = ep; + return ep; + } +#endif /* COMPILER */ + +/* + * alccset - allocate a cset in the block region. + */ + +struct b_cset *alccset() + { + register struct b_cset *blk; + register int i; + + AlcFixBlk(blk, b_cset, T_Cset) + blk->size = -1; /* flag size as not yet computed */ + + /* + * Zero the bit array. + */ + for (i = 0; i < CsetSize; i++) + blk->bits[i] = 0; + return blk; + } + +/* + * alcfile - allocate a file block in the block region. + */ + +struct b_file *alcfile(fd, status, name) +FILE *fd; +int status; +dptr name; + { + tended struct descrip tname = *name; + register struct b_file *blk; + + AlcFixBlk(blk, b_file, T_File) + blk->fd = fd; + blk->status = status; + blk->fname = tname; + return blk; + } + +/* + * alchash - allocate a hashed structure (set or table header) in the block + * region. + */ +union block *alchash(tcode) +int tcode; + { + register int i; + register struct b_set *ps; + register struct b_table *pt; + + if (tcode == T_Table) { + AlcFixBlk(pt, b_table, T_Table); + ps = (struct b_set *)pt; + ps->id = table_ser++; + } + else { /* tcode == T_Set */ + AlcFixBlk(ps, b_set, T_Set); + ps->id = set_ser++; + } + ps->size = 0; + ps->mask = 0; + for (i = 0; i < HSegs; i++) + ps->hdir[i] = NULL; + return (union block *)ps; + } + +/* + * alcsegment - allocate a slot block in the block region. + */ + +struct b_slots *alcsegment(nslots) +word nslots; + { + uword size; + register struct b_slots *blk; + + size = sizeof(struct b_slots) + WordSize * (nslots - HSlots); + AlcBlk(blk, b_slots, T_Slots, size); + blk->blksize = size; + while (--nslots >= 0) + blk->hslots[nslots] = NULL; + return blk; + } + +/* + * alclist - allocate a list header block in the block region. + * + * Forces a g.c. if there's not enough room for the whole list. + */ + +struct b_list *alclist(size) +uword size; + { + register struct b_list *blk; + + if (!reserve(Blocks, (word)(sizeof(struct b_list) + sizeof (struct b_lelem) + + (size - 1) * sizeof(struct descrip)))) return NULL; + AlcFixBlk(blk, b_list, T_List) + blk->size = size; + blk->id = list_ser++; + blk->listhead = NULL; + blk->listtail = NULL; + return blk; + } + +/* + * alclstb - allocate a list element block in the block region. + */ + +struct b_lelem *alclstb(nslots, first, nused) +uword nslots, first, nused; + { + register struct b_lelem *blk; + register word i; + + AlcVarBlk(blk, b_lelem, T_Lelem, nslots) + blk->nslots = nslots; + blk->first = first; + blk->nused = nused; + blk->listprev = NULL; + blk->listnext = NULL; + /* + * Set all elements to &null. + */ + for (i = 0; i < nslots; i++) + blk->lslots[i] = nulldesc; + return blk; + } + +/* + * alcreal - allocate a real value in the block region. + */ + +struct b_real *alcreal(val) +double val; + { + register struct b_real *blk; + + AlcFixBlk(blk, b_real, T_Real) + +#ifdef Double +/* access real values one word at a time */ + { int *rp, *rq; + rp = (int *) &(blk->realval); + rq = (int *) &val; + *rp++ = *rq++; + *rp = *rq; + } +#else /* Double */ + blk->realval = val; +#endif /* Double */ + + return blk; + } + +/* + * alcrecd - allocate record with nflds fields in the block region. + */ + +struct b_record *alcrecd(nflds, recptr) +int nflds; +union block *recptr; + { + tended union block *trecptr = recptr; + register struct b_record *blk; + + AlcVarBlk(blk, b_record, T_Record, nflds) + blk->recdesc = trecptr; + blk->id = (((struct b_proc *)recptr)->recid)++; + return blk; + } + +/* + * alcrefresh - allocate a co-expression refresh block. + */ + +#if COMPILER +struct b_refresh *alcrefresh(na, nl, nt, wrk_sz) +int na; +int nl; +int nt; +int wrk_sz; + { + struct b_refresh *blk; + + AlcVarBlk(blk, b_refresh, T_Refresh, na + nl) + blk->nlocals = nl; + blk->nargs = na; + blk->ntemps = nt; + blk->wrk_size = wrk_sz; + return blk; + } +#else /* COMPILER */ +struct b_refresh *alcrefresh(entryx, na, nl) +word *entryx; +int na, nl; + { + struct b_refresh *blk; + + AlcVarBlk(blk, b_refresh, T_Refresh, na + nl); + blk->ep = entryx; + blk->numlocals = nl; + return blk; + } +#endif /* COMPILER */ + +/* + * alcselem - allocate a set element block. + */ + +struct b_selem *alcselem(mbr,hn) +uword hn; +dptr mbr; + + { + tended struct descrip tmbr = *mbr; + register struct b_selem *blk; + + AlcFixBlk(blk, b_selem, T_Selem) + blk->clink = NULL; + blk->setmem = tmbr; + blk->hashnum = hn; + return blk; + } + +/* + * alcstr - allocate a string in the string space. + */ + +char *alcstr(s, slen) +register char *s; +register word slen; + { + tended struct descrip ts; + register char *d; + char *ofree; + +#ifdef MultiThread + StrLen(ts) = slen; + StrLoc(ts) = s; +#ifdef EventMon + if (!noMTevents) +#endif /* EventMon */ + EVVal(slen, E_String); + s = StrLoc(ts); +#endif /* MultiThread */ + + /* + * Make sure there is enough room in the string space. + */ + if (DiffPtrs(strend,strfree) < slen) { + StrLen(ts) = slen; + StrLoc(ts) = s; + if (!reserve(Strings, slen)) + return NULL; + s = StrLoc(ts); + } + + strtotal += slen; + + /* + * Copy the string into the string space, saving a pointer to its + * beginning. Note that s may be null, in which case the space + * is still to be allocated but nothing is to be copied into it. + */ + ofree = d = strfree; + if (s) { + while (slen-- > 0) + *d++ = *s++; + } + else + d += slen; + + strfree = d; + return ofree; + } + +/* + * alcsubs - allocate a substring trapped variable in the block region. + */ + +struct b_tvsubs *alcsubs(len, pos, var) +word len, pos; +dptr var; + { + tended struct descrip tvar = *var; + register struct b_tvsubs *blk; + + AlcFixBlk(blk, b_tvsubs, T_Tvsubs) + blk->sslen = len; + blk->sspos = pos; + blk->ssvar = tvar; + return blk; + } + +/* + * alctelem - allocate a table element block in the block region. + */ + +struct b_telem *alctelem() + { + register struct b_telem *blk; + + AlcFixBlk(blk, b_telem, T_Telem) + blk->hashnum = 0; + blk->clink = NULL; + blk->tref = nulldesc; + return blk; + } + +/* + * alctvtbl - allocate a table element trapped variable block in the block + * region. + */ + +struct b_tvtbl *alctvtbl(tbl, ref, hashnum) +register dptr tbl, ref; +uword hashnum; + { + tended struct descrip ttbl = *tbl; + tended struct descrip tref = *ref; + register struct b_tvtbl *blk; + + AlcFixBlk(blk, b_tvtbl, T_Tvtbl) + blk->hashnum = hashnum; + blk->clink = BlkLoc(ttbl); + blk->tref = tref; + return blk; + } + +/* + * deallocate - return a block to the heap. + * + * The block must be the one that is at the very end of a block region. + */ +void deallocate (bp) +union block *bp; +{ + word nbytes; + struct region *rp; + + nbytes = BlkSize(bp); + for (rp = curblock; rp; rp = rp->next) + if ((char *)bp + nbytes == rp->free) + break; + if (!rp) + for (rp = curblock->prev; rp; rp = rp->prev) + if ((char *)bp + nbytes == rp->free) + break; + if (!rp) + syserr ("deallocation botch"); + rp->free = (char *)bp; + blktotal -= nbytes; + EVVal(nbytes, E_BlkDeAlc); +} + +/* + * reserve -- ensure space in either string or block region. + * + * 1. check for space in current region. + * 2. check for space in older regions. + * 3. check for space in newer regions. + * 4. set goal of 10% of size of newest region. + * 5. collect regions, newest to oldest, until goal met. + * 6. allocate new region at 200% the size of newest existing. + * 7. reset goal back to original request. + * 8. collect regions that were too small to bother with before. + * 9. search regions, newest to oldest. + * 10. give up and signal error. + */ + +char *reserve(region, nbytes) +int region; +word nbytes; +{ + struct region **pcurr, *curr, *rp; + word want, newsize; + extern int qualfail; + + if (region == Strings) + pcurr = &curstring; + else + pcurr = &curblock; + curr = *pcurr; + + /* + * Check for space available now. + */ + if (DiffPtrs(curr->end, curr->free) >= nbytes) + return curr->free; /* quick return: current region is OK */ + + if ((rp = findgap(curr, nbytes)) != 0) { /* check all regions on chain */ + *pcurr = rp; /* switch regions */ + return rp->free; + } + + /* + * Set "curr" to point to newest region. + */ + while (curr->next) + curr = curr->next; + + /* + * Need to collect garbage. To reduce thrashing, set a minimum requirement + * of 10% of the size of the newest region, and collect regions until that + * amount of free space appears in one of them. + */ + want = (curr->size / 100) * memcushion; + if (want < nbytes) + want = nbytes; + + for (rp = curr; rp; rp = rp->prev) + if (rp->size >= want) { /* if large enough to possibly succeed */ + *pcurr = rp; + collect(region); + if (DiffPtrs(rp->end,rp->free) >= want) + return rp->free; + } + + /* + * That didn't work. Allocate a new region with a size based on the + * newest previous region. + */ + newsize = (curr->size / 100) * memgrowth; + if (newsize < nbytes) + newsize = nbytes; + if (newsize < MinAbrSize) + newsize = MinAbrSize; + + if ((rp = newregion(nbytes, newsize)) != 0) { + rp->prev = curr; + rp->next = NULL; + curr->next = rp; + rp->Gnext = curr; + rp->Gprev = curr->Gprev; + if (curr->Gprev) curr->Gprev->Gnext = rp; + curr->Gprev = rp; + *pcurr = rp; +#ifdef EventMon + if (!noMTevents) { + if (region == Strings) { + EVVal(rp->size, E_TenureString); + } + else { + EVVal(rp->size, E_TenureBlock); + } + } +#endif /* EventMon */ + return rp->free; + } + + /* + * Allocation failed. Try to continue, probably thrashing all the way. + * Collect the regions that weren't collected before and see if any + * region has enough to satisfy the original request. + */ + for (rp = curr; rp; rp = rp->prev) + if (rp->size < want) { /* if not collected earlier */ + *pcurr = rp; + collect(region); + if (DiffPtrs(rp->end,rp->free) >= want) + return rp->free; + } + if ((rp = findgap(curr, nbytes)) != 0) { + *pcurr = rp; + return rp->free; + } + + /* + * All attempts failed. + */ + if (region == Blocks) + ReturnErrNum(307, 0); + else if (qualfail) + ReturnErrNum(304, 0); + else + ReturnErrNum(306, 0); +} + +/* + * findgap - search region chain for a region having at least nbytes available + */ +static struct region *findgap(curr, nbytes) +struct region *curr; +word nbytes; + { + struct region *rp; + + for (rp = curr; rp; rp = rp->prev) + if (DiffPtrs(rp->end, rp->free) >= nbytes) + return rp; + for (rp = curr->next; rp; rp = rp->next) + if (DiffPtrs(rp->end, rp->free) >= nbytes) + return rp; + return NULL; + } + +/* + * newregion - try to malloc a new region and tenure the old one, + * backing off if the requested size fails. + */ +static struct region *newregion(nbytes,stdsize) +word nbytes,stdsize; +{ + uword minSize = MinAbrSize; + struct region *rp; + + if ((uword)nbytes > minSize) + minSize = (uword)nbytes; + rp = (struct region *)malloc(sizeof(struct region)); + if (rp) { + rp->size = stdsize; + if (rp->size < nbytes) + rp->size = Max(nbytes+stdsize, nbytes); + do { + rp->free = rp->base = (char *)AllocReg(rp->size); + if (rp->free != NULL) { + rp->end = rp->base + rp->size; + return rp; + } + else { + } + rp->size = (rp->size + nbytes)/2 - 1; + } + while (rp->size >= minSize); + free((char *)rp); + } + return NULL; +} diff --git a/src/runtime/rcoexpr.r b/src/runtime/rcoexpr.r new file mode 100644 index 0000000..4036ef6 --- /dev/null +++ b/src/runtime/rcoexpr.r @@ -0,0 +1,315 @@ +/* + * File: rcoexpr.r -- co_init, co_chng + */ + +#if COMPILER +static continuation coexpr_fnc; /* function to call after switching stacks */ +#endif /* COMPILER */ + +/* + * co_init - use the contents of the refresh block to initialize the + * co-expression. + */ +void co_init(sblkp) +struct b_coexpr *sblkp; +{ +#ifndef Coexpr + syserr("co_init() called, but co-expressions not implemented"); +#else /* Coexpr */ + register word *newsp; + register struct b_refresh *rblkp; + register dptr dp, dsp; + int frame_size; + word stack_strt; + int na, nl, nt, i; + + /* + * Get pointer to refresh block. + */ + rblkp = (struct b_refresh *)BlkLoc(sblkp->freshblk); + +#if COMPILER + na = rblkp->nargs; /* number of arguments */ + nl = rblkp->nlocals; /* number of locals */ + nt = rblkp->ntemps; /* number of temporaries */ + + /* + * The C stack must be aligned on the correct boundary. For up-growing + * stacks, the C stack starts after the initial procedure frame of + * the co-expression block. For down-growing stacks, the C stack starts + * at the last word of the co-expression block. + */ +#ifdef UpStack + frame_size = sizeof(struct p_frame) + sizeof(struct descrip) * (nl + na + + nt - 1) + rblkp->wrk_size; + stack_strt = (word)((char *)&sblkp->pf + frame_size + StackAlign*WordSize); +#else /* UpStack */ + stack_strt = (word)((char *)sblkp + stksize - WordSize); +#endif /* UpStack */ + sblkp->cstate[0] = stack_strt & ~(WordSize * StackAlign - 1); + + sblkp->es_argp = &sblkp->pf.tend.d[nl + nt]; /* args follow temporaries */ + +#else /* COMPILER */ + + na = (rblkp->pfmkr).pf_nargs + 1; /* number of arguments */ + nl = (int)rblkp->numlocals; /* number of locals */ + + /* + * The interpreter stack starts at word after co-expression stack block. + * C stack starts at end of stack region on machines with down-growing C + * stacks and somewhere in the middle of the region. + * + * The C stack is aligned on a doubleword boundary. For up-growing + * stacks, the C stack starts in the middle of the stack portion + * of the static block. For down-growing stacks, the C stack starts + * at the last word of the static block. + */ + + newsp = (word *)((char *)sblkp + sizeof(struct b_coexpr)); + +#ifdef UpStack + sblkp->cstate[0] = + ((word)((char *)sblkp + (stksize - sizeof(*sblkp))/2) + &~((word)WordSize*StackAlign-1)); +#else /* UpStack */ + sblkp->cstate[0] = + ((word)((char *)sblkp + stksize - WordSize) + &~((word)WordSize*StackAlign-1)); +#endif /* UpStack */ + + sblkp->es_argp = (dptr)newsp; /* args are first thing on stack */ + +#endif /* COMPILER */ + + /* + * Copy arguments onto new stack. + */ + dsp = sblkp->es_argp; + dp = rblkp->elems; + for (i = 1; i <= na; i++) + *dsp++ = *dp++; + + /* + * Set up state variables and initialize procedure frame. + */ +#if COMPILER + sblkp->es_pfp = &sblkp->pf; + sblkp->es_tend = &sblkp->pf.tend; + sblkp->pf.old_pfp = NULL; + sblkp->pf.rslt = NULL; + sblkp->pf.succ_cont = NULL; + sblkp->pf.tend.previous = NULL; + sblkp->pf.tend.num = nl + na + nt; + sblkp->es_actstk = NULL; +#else /* COMPILER */ + *((struct pf_marker *)dsp) = rblkp->pfmkr; + sblkp->es_pfp = (struct pf_marker *)dsp; + sblkp->es_tend = NULL; + dsp = (dptr)((word *)dsp + Vwsizeof(*pfp)); + sblkp->es_ipc.opnd = rblkp->ep; + sblkp->es_gfp = 0; + sblkp->es_efp = 0; + sblkp->es_ilevel = 0; +#endif /* COMPILER */ + sblkp->tvalloc = NULL; + + /* + * Copy locals into the co-expression. + */ +#if COMPILER + dsp = sblkp->pf.tend.d; +#endif /* COMPILER */ + for (i = 1; i <= nl; i++) + *dsp++ = *dp++; + +#if COMPILER + /* + * Initialize temporary variables. + */ + for (i = 1; i <= nt; i++) + *dsp++ = nulldesc; +#else /* COMPILER */ + /* + * Push two null descriptors on the stack. + */ + *dsp++ = nulldesc; + *dsp++ = nulldesc; + + sblkp->es_sp = (word *)dsp - 1; +#endif /* COMPILER */ + +#endif /* Coexpr */ + } + +/* + * co_chng - high-level co-expression context switch. + */ +int co_chng(ncp, valloc, rsltloc, swtch_typ, first) +struct b_coexpr *ncp; +struct descrip *valloc; /* location of value being transmitted */ +struct descrip *rsltloc;/* location to put result */ +int swtch_typ; /* A_Coact, A_Coret, A_Cofail, or A_MTEvent */ +int first; +{ +#ifndef Coexpr + syserr("co_chng() called, but co-expressions not implemented"); +#else /* Coexpr */ + register struct b_coexpr *ccp; + static int coexp_act; /* used to pass signal across activations */ + /* back to whomever activates, if they care */ + + ccp = (struct b_coexpr *)BlkLoc(k_current); + +#if !COMPILER +#ifdef EventMon + switch(swtch_typ) { + /* + * A_MTEvent does not generate an event. + */ + case A_MTEvent: + break; + case A_Coact: + EVValX(ncp,E_Coact); + if (!is:null(curpstate->eventmask)) { + curpstate->parent->eventsource.dword = D_Coexpr; + BlkLoc(curpstate->parent->eventsource) = (union block *)ncp; + } + break; + case A_Coret: + EVValX(ncp,E_Coret); + if (!is:null(curpstate->eventmask)) { + curpstate->parent->eventsource.dword = D_Coexpr; + BlkLoc(curpstate->parent->eventsource) = (union block *)ncp; + } + break; + case A_Cofail: + EVValX(ncp,E_Cofail); + if (!is:null(curpstate->eventmask) && ncp->program == curpstate) { + curpstate->parent->eventsource.dword = D_Coexpr; + BlkLoc(curpstate->parent->eventsource) = (union block *)ncp; + } + break; + } +#endif /* EventMon */ +#endif /* COMPILER */ + + /* + * Determine if we need to transmit a value. + */ + if (valloc != NULL) { + +#if !COMPILER + /* + * Determine if we need to dereference the transmitted value. + */ + if (Var(*valloc)) + retderef(valloc, (word *)glbl_argp, sp); +#endif /* COMPILER */ + + if (ncp->tvalloc != NULL) + *ncp->tvalloc = *valloc; + } + ncp->tvalloc = NULL; + ccp->tvalloc = rsltloc; + + /* + * Save state of current co-expression. + */ + ccp->es_pfp = pfp; + ccp->es_argp = glbl_argp; + ccp->es_tend = tend; + +#if !COMPILER + ccp->es_efp = efp; + ccp->es_gfp = gfp; + ccp->es_ipc = ipc; + ccp->es_sp = sp; + ccp->es_ilevel = ilevel; +#endif /* COMPILER */ + +#if COMPILER + if (line_info) { + ccp->file_name = file_name; + ccp->line_num = line_num; + file_name = ncp->file_name; + line_num = ncp->line_num; + } +#endif /* COMPILER */ + +#if COMPILER + if (debug_info) +#endif /* COMPILER */ + if (k_trace) +#ifdef EventMon + if (swtch_typ != A_MTEvent) +#endif /* EventMon */ + cotrace(ccp, ncp, swtch_typ, valloc); + + /* + * Establish state for new co-expression. + */ + pfp = ncp->es_pfp; + tend = ncp->es_tend; + +#if !COMPILER + efp = ncp->es_efp; + gfp = ncp->es_gfp; + ipc = ncp->es_ipc; + sp = ncp->es_sp; + ilevel = (int)ncp->es_ilevel; +#endif /* COMPILER */ + +#if !COMPILER +#ifdef MultiThread + /* + * Enter the program state of the co-expression being activated + */ + ENTERPSTATE(ncp->program); +#endif /* MultiThread */ +#endif /* COMPILER */ + + glbl_argp = ncp->es_argp; + BlkLoc(k_current) = (union block *)ncp; + +#if COMPILER + coexpr_fnc = ncp->fnc; +#endif /* COMPILER */ + +#ifdef EventMon + /* + * From here on out, A_MTEvent looks like a A_Coact. + */ + if (swtch_typ == A_MTEvent) + swtch_typ = A_Coact; +#endif /* EventMon */ + + coexp_act = swtch_typ; + coswitch(ccp->cstate, ncp->cstate,first); + return coexp_act; +#endif /* Coexpr */ + } + +#ifdef Coexpr +/* + * new_context - determine what function to call to execute the new + * co-expression; this completes the context switch. + */ +void new_context(fsig,cargp) +int fsig; +dptr cargp; + { +#if COMPILER + (*coexpr_fnc)(); +#else /* COMPILER */ + interp(fsig, cargp); +#endif /* COMPILER */ + } +#else /* Coexpr */ +/* dummy new_context if co-expressions aren't supported */ +void new_context(fsig,cargp) +int fsig; +dptr cargp; + { + } +#endif /* Coexpr */ diff --git a/src/runtime/rcolor.r b/src/runtime/rcolor.r new file mode 100644 index 0000000..a3ac813 --- /dev/null +++ b/src/runtime/rcolor.r @@ -0,0 +1,722 @@ +/* + * File: rcolor.r + * graphics tables and functions related to color + */ + +#ifdef Graphics + +static int colorphrase (char *buf, long *r, long *g, long *b); +static double rgbval (double n1, double n2, double hue); + +/* + * Structures and tables used for color parsing. + * Tables must be kept lexically sorted. + */ + +typedef struct { /* color name entry */ + char name[8]; /* basic color name */ + char ish[12]; /* -ish form */ + short hue; /* hue, in degrees */ + char lgt; /* lightness, as percentage */ + char sat; /* saturation, as percentage */ +} colrname; + +typedef struct { /* arbitrary lookup entry */ + char word[10]; /* word */ + char val; /* value, as percentage */ +} colrmod; + +static colrname colortable[] = { /* known colors */ + /* color ish-form hue lgt sat */ + { "black", "blackish", 0, 0, 0 }, + { "blue", "bluish", 240, 50, 100 }, + { "brown", "brownish", 30, 25, 100 }, + { "cyan", "cyanish", 180, 50, 100 }, + { "gray", "grayish", 0, 50, 0 }, + { "green", "greenish", 120, 50, 100 }, + { "grey", "greyish", 0, 50, 0 }, + { "magenta", "magentaish", 300, 50, 100 }, + { "orange", "orangish", 15, 50, 100 }, + { "pink", "pinkish", 345, 75, 100 }, + { "purple", "purplish", 270, 50, 100 }, + { "red", "reddish", 0, 50, 100 }, + { "violet", "violetish", 270, 75, 100 }, + { "white", "whitish", 0, 100, 0 }, + { "yellow", "yellowish", 60, 50, 100 }, + }; + +static colrmod lighttable[] = { /* lightness modifiers */ + { "dark", 0 }, + { "deep", 0 }, /* = very dark (see code) */ + { "light", 100 }, + { "medium", 50 }, + { "pale", 100 }, /* = very light (see code) */ + }; + +static colrmod sattable[] = { /* saturation levels */ + { "moderate", 50 }, + { "strong", 75 }, + { "vivid", 100 }, + { "weak", 25 }, + }; + +/* + * parsecolor(w, s, &r, &g, &b) - parse a color specification + * + * parsecolor interprets a color specification and produces r/g/b values + * scaled linearly from 0 to 65535. parsecolor returns Succeeded or Failed. + * + * An Icon color specification can be any of the forms + * + * #rgb (hexadecimal digits) + * #rrggbb + * #rrrgggbbb + * #rrrrggggbbbb + * nnnnn,nnnnn,nnnnn (integers 0 - 65535) + * <Icon color phrase> + * <native color spec> + */ + +int parsecolor(w, buf, r, g, b) +wbp w; +char *buf; +long *r, *g, *b; + { + int len, mul; + char *fmt, c; + double dr, dg, db; + + *r = *g = *b = 0L; + + /* trim leading spaces */ + while (isspace(*buf)) + buf++; + + /* try interpreting as three comma-separated integers */ + if (sscanf(buf, "%lf,%lf,%lf%c", &dr, &dg, &db, &c) == 3) { + *r = dr; + *g = dg; + *b = db; + if (*r>=0 && *r<=65535 && *g>=0 && *g<=65535 && *b>=0 && *b<=65535) + return Succeeded; + else + return Failed; + } + + /* try interpreting as a hexadecimal value */ + if (*buf == '#') { + buf++; + for (len = 0; isalnum(buf[len]); len++); + switch (len) { + case 3: fmt = "%1x%1x%1x%c"; mul = 0x1111; break; + case 6: fmt = "%2x%2x%2x%c"; mul = 0x0101; break; + case 9: fmt = "%3x%3x%3x%c"; mul = 0x0010; break; + case 12: fmt = "%4x%4x%4x%c"; mul = 0x0001; break; + default: return Failed; + } + if (sscanf(buf, fmt, r, g, b, &c) != 3) + return Failed; + *r *= mul; + *g *= mul; + *b *= mul; + return Succeeded; + } + + /* try interpreting as a color phrase or as a native color spec */ + if (colorphrase(buf, r, g, b) || nativecolor(w, buf, r, g, b)) + return Succeeded; + else + return Failed; + } + +/* + * colorphrase(s, &r, &g, &b) -- parse Icon color phrase. + * + * An Icon color phrase matches the pattern + * + * weak + * pale moderate + * light strong + * [[very] medium ] [ vivid ] [color[ish]] color + * dark + * deep + * + * where "color" is any of: + * + * black gray grey white pink violet brown + * red orange yellow green cyan blue purple magenta + * + * A single space or hyphen separates each word from its neighbor. The + * default lightness is "medium", and the default saturation is "vivid". + * + * "pale" means "very light"; "deep" means "very dark". + * + * This naming scheme is based loosely on + * A New Color-Naming System for Graphics Languages + * Toby Berk, Lee Brownston, and Arie Kaufman + * IEEE Computer Graphics & Applications, May 1982 + */ + +static int colorphrase(buf, r, g, b) +char *buf; +long *r, *g, *b; + { + int len, very; + char c, *p, *ebuf, cbuffer[MAXCOLORNAME]; + float lgt, sat, blend, bl2, m1, m2; + float h1, l1, s1, h2, l2, s2, r2, g2, b2; + + lgt = -1.0; /* default no lightness mod */ + sat = 1.0; /* default vivid saturation */ + len = strlen(buf); + while (isspace(buf[len-1])) + len--; /* trim trailing spaces */ + + if (len >= sizeof(cbuffer)) + return 0; /* if too long for valid Icon spec */ + + /* + * copy spec, lowering case and replacing spaces and hyphens with NULs + */ + for(p = cbuffer; (c = *buf) != 0; p++, buf++) { + if (isupper(c)) *p = tolower(c); + else if (c == ' ' || c == '-') *p = '\0'; + else *p = c; + } + *p = '\0'; + + buf = cbuffer; + ebuf = buf + len; + /* check for "very" */ + if (strcmp(buf, "very") == 0) { + very = 1; + buf += strlen(buf) + 1; + if (buf >= ebuf) + return 0; + } + else + very = 0; + + /* check for lightness adjective */ + p = qsearch(buf, (char *)lighttable, + ElemCount(lighttable), ElemSize(lighttable), strcmp); + if (p) { + /* set the "very" flag for "pale" or "deep" */ + if (strcmp(buf, "pale") == 0) + very = 1; /* pale = very light */ + else if (strcmp(buf, "deep") == 0) + very = 1; /* deep = very dark */ + /* skip past word */ + buf += strlen(buf) + 1; + if (buf >= ebuf) + return 0; + /* save lightness value, but ignore "medium" */ + if ((((colrmod *)p) -> val) != 50) + lgt = ((colrmod *)p) -> val / 100.0; + } + else if (very) + return 0; + + /* check for saturation adjective */ + p = qsearch(buf, (char *)sattable, + ElemCount(sattable), ElemSize(sattable), strcmp); + if (p) { + sat = ((colrmod *)p) -> val / 100.0; + buf += strlen(buf) + 1; + if (buf >= ebuf) + return 0; + } + + if (buf + strlen(buf) >= ebuf) + blend = h1 = l1 = s1 = 0.0; /* only one word left */ + else { + /* we have two (or more) name words; get the first */ + if ((p = qsearch(buf, colortable[0].name, + ElemCount(colortable), ElemSize(colortable), strcmp)) != NULL) { + blend = 0.5; + } + else if ((p = qsearch(buf, colortable[0].ish, + ElemCount(colortable), ElemSize(colortable), strcmp)) != NULL) { + p -= sizeof(colortable[0].name); + blend = 0.25; + } + else + return 0; + + h1 = ((colrname *)p) -> hue; + l1 = ((colrname *)p) -> lgt / 100.0; + s1 = ((colrname *)p) -> sat / 100.0; + buf += strlen(buf) + 1; + } + + /* process second (or only) name word */ + p = qsearch(buf, colortable[0].name, + ElemCount(colortable), ElemSize(colortable), strcmp); + if (!p || buf + strlen(buf) < ebuf) + return 0; + h2 = ((colrname *)p) -> hue; + l2 = ((colrname *)p) -> lgt / 100.0; + s2 = ((colrname *)p) -> sat / 100.0; + + /* at this point we know we have a valid spec */ + + /* interpolate hls specs */ + if (blend > 0) { + bl2 = 1.0 - blend; + + if (s1 == 0.0) + ; /* use h2 unchanged */ + else if (s2 == 0.0) + h2 = h1; + else if (h2 - h1 > 180) + h2 = blend * h1 + bl2 * (h2 - 360); + else if (h1 - h2 > 180) + h2 = blend * (h1 - 360) + bl2 * h2; + else + h2 = blend * h1 + bl2 * h2; + if (h2 < 0) + h2 += 360; + + l2 = blend * l1 + bl2 * l2; + s2 = blend * s1 + bl2 * s2; + } + + /* apply saturation and lightness modifiers */ + if (lgt >= 0.0) { + if (very) + l2 = (2 * lgt + l2) / 3.0; + else + l2 = (lgt + 2 * l2) / 3.0; + } + s2 *= sat; + + /* convert h2,l2,s2 to r2,g2,b2 */ + /* from Foley & Van Dam, 1st edition, p. 619 */ + /* beware of dangerous typos in 2nd edition */ + if (s2 == 0) + r2 = g2 = b2 = l2; + else { + if (l2 < 0.5) + m2 = l2 * (1 + s2); + else + m2 = l2 + s2 - l2 * s2; + m1 = 2 * l2 - m2; + r2 = rgbval(m1, m2, h2 + 120); + g2 = rgbval(m1, m2, h2); + b2 = rgbval(m1, m2, h2 - 120); + } + + /* scale and convert the calculated result */ + *r = 65535 * r2; + *g = 65535 * g2; + *b = 65535 * b2; + + return 1; + } + +/* + * rgbval(n1, n2, hue) - helper function for HLS to RGB conversion + */ +static double rgbval(n1, n2, hue) +double n1, n2, hue; + { + if (hue > 360) + hue -= 360; + else if (hue < 0) + hue += 360; + + if (hue < 60) + return n1 + (n2 - n1) * hue / 60.0; + else if (hue < 180) + return n2; + else if (hue < 240) + return n1 + (n2 - n1) * (240 - hue) / 60.0; + else + return n1; + } + +/* + * Static data for XDrawImage and XPalette functions + */ + +/* + * c<n>list - the characters of the palettes that are not contiguous ASCII + */ +char c1list[] = "0123456789?!nNAa#@oOBb$%pPCc&|\ +qQDd,.rREe;:sSFf+-tTGg*/uUHh`'vVIi<>wWJj()xXKk[]yYLl{}zZMm^="; +char c2list[] = "kbgcrmywx"; +char c3list[] = "@ABCDEFGHIJKLMNOPQRSTUVWXYZabcd"; +char c4list[] = + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz{}$%&*+-/?@"; + +/* + * cgrays -- lists of grayscales contained within color palettes + */ +static char *cgrays[] = { "0123456", "kxw", "@abMcdZ", "0$%&L*+-g/?@}", +"\0}~\177\200\37\201\202\203\204>\205\206\207\210]\211\212\213\214|", +"\0\330\331\332\333\334+\335\336\337\340\341V\342\343\344\345\346\201\ +\347\350\351\352\353\254\354\355\356\357\360\327" }; + +/* + * c1cube - a precomputed mapping from a color cube to chars in c1 palette + * + * This is 10x10x10 cube (A Thousand Points of Light). + */ +#define C1Side 10 /* length of one side of C1 cube */ +static char c1cube[] = { + '0', '0', 'w', 'w', 'w', 'W', 'W', 'W', 'J', 'J', '0', '0', 'v', 'v', 'v', + 'W', 'W', 'W', 'J', 'J', 's', 't', 't', 'v', 'v', 'V', 'V', 'V', 'V', 'J', + 's', 't', 't', 'u', 'u', 'V', 'V', 'V', 'V', 'I', 's', 't', 't', 'u', 'u', + 'V', 'V', 'V', 'I', 'I', 'S', 'S', 'T', 'T', 'T', 'U', 'U', 'U', 'I', 'I', + 'S', 'S', 'T', 'T', 'T', 'U', 'U', 'U', 'U', 'I', 'S', 'S', 'T', 'T', 'T', + 'U', 'U', 'U', 'U', 'H', 'F', 'F', 'T', 'T', 'G', 'G', 'U', 'U', 'H', 'H', + 'F', 'F', 'F', 'G', 'G', 'G', 'G', 'H', 'H', 'H', '0', '0', 'x', 'x', 'x', + 'W', 'W', 'W', 'J', 'J', '!', '1', '1', 'v', 'v', 'W', 'W', 'W', 'J', 'J', + 'r', '1', '1', 'v', 'v', 'V', 'V', 'V', 'j', 'j', 'r', 'r', 't', 'u', 'u', + 'V', 'V', 'V', 'j', 'j', 'r', 'r', 't', 'u', 'u', 'V', 'V', 'V', 'I', 'I', + 'S', 'S', 'T', 'T', 'T', 'U', 'U', 'U', 'I', 'I', 'S', 'S', 'T', 'T', 'T', + 'U', 'U', 'U', 'i', 'i', 'S', 'S', 'T', 'T', 'T', 'U', 'U', 'U', 'i', 'i', + 'F', 'F', 'f', 'f', 'G', 'G', 'g', 'g', 'H', 'H', 'F', 'F', 'f', 'f', 'G', + 'G', 'g', 'g', 'H', 'H', 'n', 'z', 'x', 'x', 'x', 'X', 'X', 'X', 'X', 'J', + '!', '1', '1', 'x', 'x', 'X', 'X', 'X', 'j', 'j', 'p', '1', '1', '2', '2', + ')', 'V', 'j', 'j', 'j', 'r', 'r', '2', '2', '2', ')', 'V', 'j', 'j', 'j', + 'r', 'r', '2', '2', '2', '>', '>', '>', 'j', 'j', 'R', 'R', '-', '-', '/', + '/', '>', '>', 'i', 'i', 'R', 'R', 'R', 'T', '/', '/', '\'','i', 'i', 'i', + 'R', 'R', 'f', 'f', '/', '/', 'g', 'g', 'i', 'i', 'R', 'f', 'f', 'f', 'f', + 'g', 'g', 'g', 'h', 'h', 'F', 'f', 'f', 'f', 'f', 'g', 'g', 'g', 'h', 'h', + 'n', 'z', 'z', 'y', 'y', 'X', 'X', 'X', 'X', 'K', 'o', 'o', 'z', 'y', 'y', + 'X', 'X', 'X', 'j', 'j', 'p', 'p', '2', '2', '2', ')', 'X', 'j', 'j', 'j', + 'q', 'q', '2', '2', '2', ')', ')', 'j', 'j', 'j', 'q', 'q', '2', '2', '2', + '>', '>', '>', 'j', 'j', 'R', 'R', '-', '-', '/', '/', '>', '>', 'i', 'i', + 'R', 'R', 'R', '-', '/', '/', '\'','\'','i', 'i', 'R', 'R', 'f', 'f', '/', + '/', '\'','g', 'i', 'i', 'R', 'f', 'f', 'f', 'f', 'g', 'g', 'g', 'h', 'h', + 'E', 'f', 'f', 'f', 'f', 'g', 'g', 'g', 'h', 'h', 'n', 'z', 'z', 'y', 'y', + 'X', 'X', 'X', 'K', 'K', 'o', 'o', 'z', 'y', 'y', 'X', 'X', 'X', 'K', 'K', + '?', '?', '?', '2', '2', ']', ']', ']', 'j', 'j', 'q', 'q', '2', '2', '2', + ']', ']', ']', 'j', 'j', 'q', 'q', '2', '2', '3', '3', '>', '>', 'j', 'j', + 'R', 'R', ':', ':', '3', '3', '>', '>', 'i', 'i', 'R', 'R', ':', ':', ':', + '/', '\'','\'','i', 'i', 'R', 'R', ':', ':', ':', '/', '\'','\'','i', 'i', + 'E', 'E', 'f', 'f', 'f', 'g', 'g', 'g', 'h', 'h', 'E', 'E', 'f', 'f', 'f', + 'g', 'g', 'g', 'h', 'h', 'N', 'N', 'Z', 'Z', 'Z', 'Y', 'Y', 'Y', 'K', 'K', + 'O', 'O', 'Z', 'Z', 'Z', 'Y', 'Y', 'Y', 'K', 'K', '?', '?', '?', '@', '=', + ']', ']', ']', 'k', 'k', 'P', 'P', '@', '@', '=', ']', ']', ']', 'k', 'k', + 'P', 'P', '%', '%', '%', '3', ']', ']', 'k', 'k', 'Q', 'Q', '|', '|', '3', + '3', '4', '4', '(', '(', 'Q', 'Q', ':', ':', ':', '4', '4', '4', '(', '(', + 'Q', 'Q', ':', ':', ':', '4', '4', '4', '<', '<', 'E', 'E', 'e', 'e', 'e', + '+', '+', '*', '*', '<', 'E', 'E', 'e', 'e', 'e', '+', '+', '*', '*', '`', + 'N', 'N', 'Z', 'Z', 'Z', 'Y', 'Y', 'Y', 'Y', 'K', 'O', 'O', 'Z', 'Z', 'Z', + 'Y', 'Y', 'Y', 'k', 'k', 'O', 'O', 'O', 'Z', '=', '=', '}', 'k', 'k', 'k', + 'P', 'P', 'P', '@', '=', '=', '}', '}', 'k', 'k', 'P', 'P', '%', '%', '%', + '=', '}', '}', 'k', 'k', 'Q', 'Q', '|', '|', '|', '4', '4', '4', '(', '(', + 'Q', 'Q', '.', '.', '.', '4', '4', '4', '(', '(', 'Q', 'Q', 'e', '.', '.', + '4', '4', '4', '<', '<', 'Q', 'e', 'e', 'e', 'e', '+', '+', '*', '*', '<', + 'E', 'e', 'e', 'e', 'e', '+', '+', '*', '*', '`', 'N', 'N', 'Z', 'Z', 'Z', + 'Y', 'Y', 'Y', 'Y', 'L', 'O', 'O', 'Z', 'Z', 'Z', 'Y', 'Y', 'Y', 'k', 'k', + 'O', 'O', 'O', 'a', '=', '=', 'm', 'k', 'k', 'k', 'P', 'P', 'a', 'a', '=', + '=', '}', 'k', 'k', 'k', 'P', 'P', '%', '%', '%', '=', '}', '8', '8', '8', + 'Q', 'Q', '|', '|', '|', '4', '4', '8', '8', '8', 'Q', 'Q', 'c', '.', '.', + '4', '4', '4', '[', '[', 'Q', 'Q', 'c', 'c', '9', '9', '4', '5', '5', '<', + 'Q', 'e', 'e', 'e', 'e', ';', ';', '5', '5', '<', 'D', 'e', 'e', 'e', 'e', + ';', ';', ';', '*', '`', 'A', 'A', 'Z', 'Z', 'M', 'M', 'Y', 'Y', 'L', 'L', + 'A', 'A', 'a', 'a', 'M', 'M', 'm', 'm', 'L', 'L', 'B', 'B', 'a', 'a', 'a', + 'm', 'm', 'm', 'l', 'l', 'B', 'B', 'a', 'a', 'a', 'm', 'm', 'm', 'l', 'l', + 'C', 'C', 'b', 'b', 'b', '7', '7', '7', '8', '8', 'C', 'C', 'b', 'b', 'b', + '7', '7', '^', '[', '[', 'Q', 'c', 'c', 'c', 'c', '#', '#', '^', '[', '[', + 'Q', 'c', 'c', 'c', '9', '9', '$', '5', '5', '[', 'D', 'D', 'd', 'd', '9', + '&', '&', '5', '5', '6', 'D', 'D', 'd', 'd', 'd', ';', ';', ';', '6', '6', + 'A', 'A', 'A', 'M', 'M', 'M', 'M', 'L', 'L', 'L', 'A', 'A', 'a', 'a', 'M', + 'M', 'm', 'm', 'L', 'L', 'B', 'B', 'a', 'a', 'a', 'm', 'm', 'm', 'l', 'l', + 'B', 'B', 'a', 'a', 'a', 'm', 'm', 'm', 'l', 'l', 'C', 'C', 'b', 'b', 'b', + '7', '7', '7', 'l', 'l', 'C', 'C', 'b', 'b', 'b', '7', '7', '^', '^', '{', + 'C', 'c', 'c', 'c', 'c', '#', '#', '^', '^', '{', 'D', 'c', 'c', 'c', '9', + '9', '$', '$', '^', '{', 'D', 'D', 'd', 'd', '9', '&', '&', '&', '6', '6', + 'D', 'D', 'd', 'd', 'd', ',', ',', ',', '6', '6' +}; + +/* + * c1rgb - RGB values for c1 palette entries + * + * Entry order corresponds to c1list (above). + * Each entry gives r,g,b in linear range 0 to 48. + */ +static unsigned char c1rgb[] = { + 0, 0, 0, /* 0 black */ + 8, 8, 8, /* 1 very dark gray */ + 16, 16, 16, /* 2 dark gray */ + 24, 24, 24, /* 3 gray */ + 32, 32, 32, /* 4 light gray */ + 40, 40, 40, /* 5 very light gray */ + 48, 48, 48, /* 6 white */ + 48, 24, 30, /* 7 pink */ + 36, 24, 48, /* 8 violet */ + 48, 36, 24, /* 9 very light brown */ + 24, 12, 0, /* ? brown */ + 8, 4, 0, /* ! very dark brown */ + 16, 0, 0, /* n very dark red */ + 32, 0, 0, /* N dark red */ + 48, 0, 0, /* A red */ + 48, 16, 16, /* a light red */ + 48, 32, 32, /* # very light red */ + 30, 18, 18, /* @ weak red */ + 16, 4, 0, /* o very dark orange */ + 32, 8, 0, /* O dark orange */ + 48, 12, 0, /* B orange */ + 48, 24, 16, /* b light orange */ + 48, 36, 32, /* $ very light orange */ + 30, 21, 18, /* % weak orange */ + 16, 8, 0, /* p very dark red-yellow */ + 32, 16, 0, /* P dark red-yellow */ + 48, 24, 0, /* C red-yellow */ + 48, 32, 16, /* c light red-yellow */ + 48, 40, 32, /* & very light red-yellow */ + 30, 24, 18, /* | weak red-yellow */ + 16, 16, 0, /* q very dark yellow */ + 32, 32, 0, /* Q dark yellow */ + 48, 48, 0, /* D yellow */ + 48, 48, 16, /* d light yellow */ + 48, 48, 32, /* , very light yellow */ + 30, 30, 18, /* . weak yellow */ + 8, 16, 0, /* r very dark yellow-green */ + 16, 32, 0, /* R dark yellow-green */ + 24, 48, 0, /* E yellow-green */ + 32, 48, 16, /* e light yellow-green */ + 40, 48, 32, /* ; very light yellow-green */ + 24, 30, 18, /* : weak yellow-green */ + 0, 16, 0, /* s very dark green */ + 0, 32, 0, /* S dark green */ + 0, 48, 0, /* F green */ + 16, 48, 16, /* f light green */ + 32, 48, 32, /* + very light green */ + 18, 30, 18, /* - weak green */ + 0, 16, 8, /* t very dark cyan-green */ + 0, 32, 16, /* T dark cyan-green */ + 0, 48, 24, /* G cyan-green */ + 16, 48, 32, /* g light cyan-green */ + 32, 48, 40, /* * very light cyan-green */ + 18, 30, 24, /* / weak cyan-green */ + 0, 16, 16, /* u very dark cyan */ + 0, 32, 32, /* U dark cyan */ + 0, 48, 48, /* H cyan */ + 16, 48, 48, /* h light cyan */ + 32, 48, 48, /* ` very light cyan */ + 18, 30, 30, /* ' weak cyan */ + 0, 8, 16, /* v very dark blue-cyan */ + 0, 16, 32, /* V dark blue-cyan */ + 0, 24, 48, /* I blue-cyan */ + 16, 32, 48, /* i light blue-cyan */ + 32, 40, 48, /* < very light blue-cyan */ + 18, 24, 30, /* > weak blue-cyan */ + 0, 0, 16, /* w very dark blue */ + 0, 0, 32, /* W dark blue */ + 0, 0, 48, /* J blue */ + 16, 16, 48, /* j light blue */ + 32, 32, 48, /* ( very light blue */ + 18, 18, 30, /* ) weak blue */ + 8, 0, 16, /* x very dark purple */ + 16, 0, 32, /* X dark purple */ + 24, 0, 48, /* K purple */ + 32, 16, 48, /* k light purple */ + 40, 32, 48, /* [ very light purple */ + 24, 18, 30, /* ] weak purple */ + 16, 0, 16, /* y very dark magenta */ + 32, 0, 32, /* Y dark magenta */ + 48, 0, 48, /* L magenta */ + 48, 16, 48, /* l light magenta */ + 48, 32, 48, /* { very light magenta */ + 30, 18, 30, /* } weak magenta */ + 16, 0, 8, /* z very dark magenta-red */ + 32, 0, 16, /* Z dark magenta-red */ + 48, 0, 24, /* M magenta-red */ + 48, 16, 32, /* m light magenta-red */ + 48, 32, 40, /* ^ very light magenta-red */ + 30, 18, 24, /* = weak magenta-red */ + }; + +/* + * palnum(d) - return palette number, or 0 if unrecognized. + * + * returns +1 ... +6 for "c1" through "c6" + * returns +1 for &null + * returns -2 ... -256 for "g2" through "g256" + * returns 0 for unrecognized palette name + * returns -1 for non-string argument + */ +int palnum(d) +dptr d; + { + tended char *s; + char c, x; + int n; + + if (is:null(*d)) + return 1; + if (!cnv:C_string(*d, s)) + return -1; + if (sscanf(s, "%c%d%c", &c, &n, &x) != 2) + return 0; + if (c == 'c' && n >= 1 && n <= 6) + return n; + if (c == 'g' && n >= 2 && n <= 256) + return -n; + return 0; + } + + +struct palentry *palsetup_palette; /* current palette */ + +/* + * palsetup(p) - set up palette for specified palette. + */ +struct palentry *palsetup(p) +int p; + { + int r, g, b, i, n, c; + unsigned int rr, gg, bb; + unsigned char *s = NULL, *t; + double m; + struct palentry *e; + static int palnumber; /* current palette number */ + + if (palnumber == p) + return palsetup_palette; + if (palsetup_palette == NULL) { + palsetup_palette = + (struct palentry *)malloc(256 * sizeof(struct palentry)); + if (palsetup_palette == NULL) + return NULL; + } + palnumber = p; + + for (i = 0; i < 256; i++) + palsetup_palette[i].valid = palsetup_palette[i].transpt = 0; + palsetup_palette[TCH1].transpt = 1; + palsetup_palette[TCH2].transpt = 1; + + if (p < 0) { /* grayscale palette */ + n = -p; + if (n <= 64) + s = (unsigned char *)c4list; + else + s = allchars; + m = 1.0 / (n - 1); + + for (i = 0; i < n; i++) { + e = &palsetup_palette[*s++]; + gg = 65535 * m * i; + e->clr.red = e->clr.green = e->clr.blue = gg; + e->valid = 1; + e->transpt = 0; + } + return palsetup_palette; + } + + if (p == 1) { /* special c1 palette */ + s = (unsigned char *)c1list; + t = c1rgb; + while ((c = *s++) != 0) { + e = &palsetup_palette[c]; + e->clr.red = 65535 * (((int)*t++) / 48.0); + e->clr.green = 65535 * (((int)*t++) / 48.0); + e->clr.blue = 65535 * (((int)*t++) / 48.0); + e->valid = 1; + e->transpt = 0; + } + return palsetup_palette; + } + + switch (p) { /* color cube plus extra grays */ + case 2: s = (unsigned char *)c2list; break; /* c2 */ + case 3: s = (unsigned char *)c3list; break; /* c3 */ + case 4: s = (unsigned char *)c4list; break; /* c4 */ + case 5: s = allchars; break; /* c5 */ + case 6: s = allchars; break; /* c6 */ + } + m = 1.0 / (p - 1); + for (r = 0; r < p; r++) { + rr = 65535 * m * r; + for (g = 0; g < p; g++) { + gg = 65535 * m * g; + for (b = 0; b < p; b++) { + bb = 65535 * m * b; + e = &palsetup_palette[*s++]; + e->clr.red = rr; + e->clr.green = gg; + e->clr.blue = bb; + e->valid = 1; + e->transpt = 0; + } + } + } + m = 1.0 / (p * (p - 1)); + for (g = 0; g < p * (p - 1); g++) + if (g % p != 0) { + gg = 65535 * m * g; + e = &palsetup_palette[*s++]; + e->clr.red = e->clr.green = e->clr.blue = gg; + e->valid = 1; + e->transpt = 0; + } + return palsetup_palette; + } + +/* + * rgbkey(p,r,g,b) - return pointer to key of closest color in palette number p. + * + * In color cubes, finds "extra" grays only if r == g == b. + */ +char *rgbkey(p, r, g, b) +int p; +double r, g, b; + { + int n, i; + double m; + char *s; + + if (p > 0) { /* color */ + if (r == g && g == b) { + if (p == 1) + m = 6; + else + m = p * (p - 1); + return cgrays[p - 1] + (int)(0.501 + m * g); + } + else { + if (p == 1) + n = C1Side; + else + n = p; + m = n - 1; + i = (int)(0.501 + m * r); + i = n * i + (int)(0.501 + m * g); + i = n * i + (int)(0.501 + m * b); + switch(p) { + case 1: return c1cube + i; /* c1 */ + case 2: return c2list + i; /* c2 */ + case 3: return c3list + i; /* c3 */ + case 4: return c4list + i; /* c4 */ + case 5: return (char *)allchars + i; /* c5 */ + case 6: return (char *)allchars + i; /* c6 */ + } + } + } + else { /* grayscale */ + if (p < -64) + s = (char *)allchars; + else + s = c4list; + return s + (int)(0.5 + (0.299 * r + 0.587 * g + 0.114 * b) * (-p - 1)); + } + + /*NOTREACHED*/ + return 0; /* avoid gcc warning */ + } + +#else /* Graphics */ + +/* + * Stubs to prevent dynamic loader from rejecting cfunc library of IPL. + */ +int palnum(dptr *d) { return 0; } +char *rgbkey(int p, double r, double g, double b) { return 0; } + +#endif /* Graphics */ diff --git a/src/runtime/rcomp.r b/src/runtime/rcomp.r new file mode 100644 index 0000000..6cd0610 --- /dev/null +++ b/src/runtime/rcomp.r @@ -0,0 +1,444 @@ +/* + * File: rcomp.r + * Contents: anycmp, equiv, lexcmp + */ + +/* + * anycmp - compare any two objects. + */ + +int anycmp(dp1,dp2) +dptr dp1, dp2; + { + register int o1, o2; + register long v1, v2, lresult; + int iresult; + double rres1, rres2, rresult; + + /* + * Get a collating number for dp1 and dp2. + */ + o1 = order(dp1); + o2 = order(dp2); + + /* + * If dp1 and dp2 aren't of the same type, compare their collating numbers. + */ + if (o1 != o2) + return (o1 > o2 ? Greater : Less); + + if (o1 == 3) + /* + * dp1 and dp2 are strings, use lexcmp to compare them. + */ + return lexcmp(dp1,dp2); + + switch (Type(*dp1)) { + +#ifdef LargeInts + + case T_Integer: + if (Type(*dp2) != T_Lrgint) { + v1 = IntVal(*dp1); + v2 = IntVal(*dp2); + if (v1 < v2) + return Less; + else if (v1 == v2) + return Equal; + else + return Greater; + } + /* if dp2 is a Lrgint, flow into next case */ + + case T_Lrgint: + lresult = bigcmp(dp1, dp2); + if (lresult == 0) + return Equal; + return ((lresult > 0) ? Greater : Less); + +#else /* LargeInts */ + + case T_Integer: + v1 = IntVal(*dp1); + v2 = IntVal(*dp2); + if (v1 < v2) + return Less; + else if (v1 == v2) + return Equal; + else + return Greater; + +#endif /* LargeInts */ + + case T_Coexpr: + /* + * Collate on co-expression id. + */ + lresult = (BlkLoc(*dp1)->coexpr.id - BlkLoc(*dp2)->coexpr.id); + if (lresult == 0) + return Equal; + return ((lresult > 0) ? Greater : Less); + + case T_Cset: + return csetcmp((unsigned int *)((struct b_cset *)BlkLoc(*dp1))->bits, + (unsigned int *)((struct b_cset *)BlkLoc(*dp2))->bits); + + case T_File: + /* + * Collate on file name or window label. + */ + { + struct descrip s1, s2; /* live only long enough to lexcmp them */ + dptr ps1 = &(BlkLoc(*dp1)->file.fname); + dptr ps2 = &(BlkLoc(*dp2)->file.fname); +#ifdef Graphics + if (BlkLoc(*dp1)->file.status & Fs_Window) { + wbp w = (wbp) BlkLoc(*dp1)->file.fd; + StrLoc(s1) = w->window->windowlabel; + StrLen(s1) = strlen(w->window->windowlabel); + ps1 = &s1; + } + if (BlkLoc(*dp2)->file.status & Fs_Window) { + wbp w = (wbp) BlkLoc(*dp2)->file.fd; + StrLoc(s2) = w->window->windowlabel; + StrLen(s2) = strlen(w->window->windowlabel); + ps2 = &s2; + } +#endif /* Graphics */ + return lexcmp(ps1, ps2); + } + + case T_List: + /* + * Collate on list id. + */ + lresult = (BlkLoc(*dp1)->list.id - BlkLoc(*dp2)->list.id); + if (lresult == 0) + return Equal; + return ((lresult > 0) ? Greater : Less); + + case T_Null: + return Equal; + + case T_Proc: + /* + * Collate on procedure name. + */ + return lexcmp(&(BlkLoc(*dp1)->proc.pname), + &(BlkLoc(*dp2)->proc.pname)); + + case T_Real: + GetReal(dp1,rres1); + GetReal(dp2,rres2); + rresult = rres1 - rres2; + if (rresult == 0.0) + return Equal; + return ((rresult > 0.0) ? Greater : Less); + + case T_Record: + /* + * Collate on record id within record name. + */ + iresult = lexcmp(&(BlkLoc(*dp1)->record.recdesc->proc.pname), + &(BlkLoc(*dp2)->record.recdesc->proc.pname)); + if (iresult == Equal) { + lresult = (BlkLoc(*dp1)->record.id - BlkLoc(*dp2)->record.id); + if (lresult > 0) /* coded this way because of code-generation */ + return Greater; /* bug in MSC++ 7.0A; do not change. */ + else if (lresult < 0) + return Less; + else + return Equal; + } + return iresult; + + case T_Set: + /* + * Collate on set id. + */ + lresult = (BlkLoc(*dp1)->set.id - BlkLoc(*dp2)->set.id); + if (lresult == 0) + return Equal; + return ((lresult > 0) ? Greater : Less); + + case T_Table: + /* + * Collate on table id. + */ + lresult = (BlkLoc(*dp1)->table.id - BlkLoc(*dp2)->table.id); + if (lresult == 0) + return Equal; + return ((lresult > 0) ? Greater : Less); + + case T_External: + /* + * Collate these values according to the relative positions of + * their blocks in the heap. + */ + lresult = ((long)BlkLoc(*dp1) - (long)BlkLoc(*dp2)); + if (lresult == 0) + return Equal; + return ((lresult > 0) ? Greater : Less); + + default: + syserr("anycmp: unknown datatype."); + /*NOTREACHED*/ + return 0; /* avoid gcc warning */ + } + } + +/* + * order(x) - return collating number for object x. + */ + +int order(dp) +dptr dp; + { + if (Qual(*dp)) + return 3; /* string */ + switch (Type(*dp)) { + case T_Null: + return 0; + case T_Integer: + return 1; + +#ifdef LargeInts + case T_Lrgint: + return 1; +#endif /* LargeInts */ + + case T_Real: + return 2; + + /* string: return 3 (see above) */ + + case T_Cset: + return 4; + case T_File: + return 5; + case T_Coexpr: + return 6; + case T_Proc: + return 7; + case T_List: + return 8; + case T_Set: + return 9; + case T_Table: + return 10; + case T_Record: + return 11; + case T_External: + return 12; + default: + syserr("order: unknown datatype."); + /*NOTREACHED*/ + return 0; /* avoid gcc warning */ + } + } + +/* + * equiv - test equivalence of two objects. + */ + +int equiv(dp1, dp2) +dptr dp1, dp2; + { + register int result; + register word i; + register char *s1, *s2; + double rres1, rres2; + + result = 0; + + /* + * If the descriptors are identical, the objects are equivalent. + */ + if (EqlDesc(*dp1,*dp2)) + result = 1; + else if (Qual(*dp1) && Qual(*dp2)) { + + /* + * If both are strings of equal length, compare their characters. + */ + + if ((i = StrLen(*dp1)) == StrLen(*dp2)) { + + + s1 = StrLoc(*dp1); + s2 = StrLoc(*dp2); + result = 1; + while (i--) + if (*s1++ != *s2++) { + result = 0; + break; + } + + } + } + else if (dp1->dword == dp2->dword) + switch (Type(*dp1)) { + /* + * For integers and reals, just compare the values. + */ + case T_Integer: + result = (IntVal(*dp1) == IntVal(*dp2)); + break; + +#ifdef LargeInts + case T_Lrgint: + result = (bigcmp(dp1, dp2) == 0); + break; +#endif /* LargeInts */ + + + case T_Real: + GetReal(dp1, rres1); + GetReal(dp2, rres2); + result = (rres1 == rres2); + break; + + case T_Cset: + /* + * Compare the bit arrays of the csets. + */ + result = 1; + for (i = 0; i < CsetSize; i++) + if (BlkLoc(*dp1)->cset.bits[i] != BlkLoc(*dp2)->cset.bits[i]) { + result = 0; + break; + } + } + else + /* + * dp1 and dp2 are of different types, so they can't be + * equivalent. + */ + result = 0; + + return result; + } + +/* + * lexcmp - lexically compare two strings. + */ + +int lexcmp(dp1, dp2) +dptr dp1, dp2; + { + + + register char *s1, *s2; + register word minlen; + word l1, l2; + + /* + * Get length and starting address of both strings. + */ + l1 = StrLen(*dp1); + s1 = StrLoc(*dp1); + l2 = StrLen(*dp2); + s2 = StrLoc(*dp2); + + /* + * Set minlen to length of the shorter string. + */ + minlen = Min(l1, l2); + + /* + * Compare as many bytes as are in the smaller string. If an + * inequality is found, compare the differing bytes. + */ + while (minlen--) + if (*s1++ != *s2++) + return (*--s1 & 0377) > (*--s2 & 0377) ? Greater : Less; + + /* + * The strings compared equal for the length of the shorter. + */ + if (l1 == l2) + return Equal; + else if (l1 > l2) + return Greater; + else + return Less; + + } + +/* + * csetcmp - compare two cset bit arrays. + * The order defined by this function is identical to the lexical order of + * the two strings that the csets would be converted into. + */ + +int csetcmp(cs1, cs2) +unsigned int *cs1, *cs2; + { + unsigned int nbit, mask, *cs_end; + + if (cs1 == cs2) return Equal; + + /* + * The longest common prefix of the two bit arrays converts to some + * common prefix string. The first bit on which the csets disagree is + * the first character of the conversion strings that disagree, and so this + * is the character on which the order is determined. The cset that has + * this first non-common bit = one, has in that position the lowest + * character, so this cset is lexically least iff the other cset has some + * following bit set. If the other cset has no bits set after the first + * point of disagreement, then it is a prefix of the other, and is therefor + * lexically less. + * + * Find the first word where cs1 and cs2 are different. + */ + for (cs_end = cs1 + CsetSize; cs1 < cs_end; cs1++, cs2++) + if (*cs1 != *cs2) { + /* + * Let n be the position at which the bits first differ within + * the word. Set nbit to some integer for which the nth bit + * is the first bit in the word that is one. Note here and in the + * following, that bits go from right to left within a word, so + * the _first_ bit is the _rightmost_ bit. + */ + nbit = *cs1 ^ *cs2; + + /* Set mask to an integer that has all zeros in bit positions + * upto and including position n, and all ones in bit positions + * _after_ bit position n. + */ + for (mask = (unsigned)MaxLong << 1; !(~mask & nbit); mask <<= 1); + + /* + * nbit & ~mask contains zeros everywhere except position n, which + * is a one, so *cs2 & (nbit & ~mask) is non-zero iff the nth bit + * of *cs2 is one. + */ + if (*cs2 & (nbit & ~mask)) { + /* + * If there are bits set in cs1 after bit position n in the + * current word, then cs1 is lexically greater than cs2. + */ + if (*cs1 & mask) return Greater; + while (++cs1 < cs_end) + if (*cs1) return Greater; + + /* + * Otherwise cs1 is a proper prefix of cs2 and is therefore + * lexically less. + */ + return Less; + } + + /* + * If the nth bit of *cs2 isn't one, then the nth bit of cs1 + * must be one. Just reverse the logic for the previous + * case. + */ + if (*cs2 & mask) return Less; + cs_end = cs2 + (cs_end - cs1); + while (++cs2 < cs_end) + if (*cs2) return Less; + return Greater; + } + return Equal; + } diff --git a/src/runtime/rdebug.r b/src/runtime/rdebug.r new file mode 100644 index 0000000..26d1167 --- /dev/null +++ b/src/runtime/rdebug.r @@ -0,0 +1,1019 @@ +/* + * rdebug.r - tracebk, get_name, xdisp, ctrace, rtrace, failtrace, strace, + * atrace, cotrace + */ + +/* + * Prototypes. + */ +static int glbcmp (char *pi, char *pj); +static int keyref (union block *bp, dptr dp); +static void showline (char *f, int l); +static void showlevel (register int n); +static void ttrace (void); +static void xtrace + (struct b_proc *bp, word nargs, dptr arg, int pline, char *pfile); + +/* + * tracebk - print a trace of procedure calls. + */ + +#if COMPILER + +void tracebk(lcl_pfp, argp) +struct p_frame *lcl_pfp; +dptr argp; + { + struct b_proc *cproc; + + struct debug *debug; + word nparam; + + if (lcl_pfp == NULL) + return; + debug = PFDebug(*lcl_pfp); + tracebk(lcl_pfp->old_pfp, lcl_pfp->old_argp); + cproc = debug->proc; + xtrace(cproc, (word)abs((int)cproc->nparam), argp, debug->old_line, + debug->old_fname); + } + +#else /* COMPILER */ + +void tracebk(lcl_pfp, argp) +struct pf_marker *lcl_pfp; +dptr argp; + { + struct b_proc *cproc; + + struct pf_marker *origpfp = pfp; + dptr arg; + inst cipc; + + /* + * Chain back through the procedure frame markers, looking for the + * first one, while building a foward chain of pointers through + * the expression frame pointers. + */ + + for (pfp->pf_efp = NULL; pfp->pf_pfp != NULL; pfp = pfp->pf_pfp) { + (pfp->pf_pfp)->pf_efp = (struct ef_marker *)pfp; + } + + /* Now start from the base procedure frame marker, producing a listing + * of the procedure calls up through the last one. + */ + + while (pfp) { + arg = &((dptr)pfp)[-(pfp->pf_nargs) - 1]; + cproc = (struct b_proc *)BlkLoc(arg[0]); + /* + * The ipc in the procedure frame points after the "invoke n". + */ + cipc = pfp->pf_ipc; + --cipc.opnd; + --cipc.op; + + xtrace(cproc, pfp->pf_nargs, &arg[0], findline(cipc.opnd), + findfile(cipc.opnd)); + /* + * On the last call, show both the call and the offending expression. + */ + if (pfp == origpfp) { + ttrace(); + break; + } + + pfp = (struct pf_marker *)(pfp->pf_efp); + } + } + +#endif /* COMPILER */ + +/* + * xtrace - procedure *bp is being called with nargs arguments, the first + * of which is at arg; produce a trace message. + */ +static void xtrace(bp, nargs, arg, pline, pfile) +struct b_proc *bp; +word nargs; +dptr arg; +int pline; +char *pfile; + { + + if (bp == NULL) + fprintf(stderr, "????"); + else { + +#if COMPILER + putstr(stderr, &(bp->pname)); +#else /* COMPILER */ + if (arg[0].dword == D_Proc) + putstr(stderr, &(bp->pname)); + else + outimage(stderr, arg, 0); + arg++; +#endif /* COMPILER */ + + putc('(', stderr); + while (nargs--) { + outimage(stderr, arg++, 0); + if (nargs) + putc(',', stderr); + } + putc(')', stderr); + } + + if (pline != 0) + fprintf(stderr, " from line %d in %s", pline, pfile); + putc('\n', stderr); + fflush(stderr); + } + +/* + * get_name -- function to get print name of variable. + */ +int get_name(dp1,dp0) + dptr dp1, dp0; + { + dptr dp, varptr; + tended union block *blkptr; + dptr arg1; /* 1st parameter */ + dptr loc1; /* 1st local */ + struct b_proc *proc; /* address of procedure block */ + char sbuf[100]; /* buffer; might be too small */ + char *s, *s2; + word i, j, k; + int t; + +#if COMPILER + arg1 = glbl_argp; + loc1 = pfp->tend.d; + proc = PFDebug(*pfp)->proc; +#else /* COMPILER */ + arg1 = &glbl_argp[1]; + loc1 = pfp->pf_locals; + proc = &BlkLoc(*glbl_argp)->proc; +#endif /* COMPILER */ + + type_case *dp1 of { + tvsubs: { + blkptr = BlkLoc(*dp1); + get_name(&(blkptr->tvsubs.ssvar),dp0); + sprintf(sbuf,"[%ld:%ld]",(long)blkptr->tvsubs.sspos, + (long)blkptr->tvsubs.sspos+blkptr->tvsubs.sslen); + k = StrLen(*dp0); + j = strlen(sbuf); + + /* + * allocate space for both the name and the subscript image, + * and then copy both parts into the allocated space + */ + Protect(s = alcstr(NULL, k + j), return Error); + s2 = StrLoc(*dp0); + StrLoc(*dp0) = s; + StrLen(*dp0) = j + k; + for (i = 0; i < k; i++) + *s++ = *s2++; + s2 = sbuf; + for (i = 0; i < j; i++) + *s++ = *s2++; + } + + tvtbl: { + t = keyref(BlkLoc(*dp1) ,dp0); + if (t == Error) + return Error; + } + + kywdint: + if (VarLoc(*dp1) == &kywd_ran) { + StrLen(*dp0) = 7; + StrLoc(*dp0) = "&random"; + } + else if (VarLoc(*dp1) == &kywd_trc) { + StrLen(*dp0) = 6; + StrLoc(*dp0) = "&trace"; + } + +#ifdef FncTrace + else if (VarLoc(*dp1) == &kywd_ftrc) { + StrLen(*dp0) = 7; + StrLoc(*dp0) = "&ftrace"; + } +#endif /* FncTrace */ + + else if (VarLoc(*dp1) == &kywd_dmp) { + StrLen(*dp0) = 5; + StrLoc(*dp0) = "&dump"; + } + else if (VarLoc(*dp1) == &kywd_err) { + StrLen(*dp0) = 6; + StrLoc(*dp0) = "&error"; + } + else + syserr("name: unknown integer keyword variable"); + + kywdevent: +#ifdef MultiThread + if (VarLoc(*dp1) == &curpstate->eventsource) { + StrLen(*dp0) = 12; + StrLoc(*dp0) = "&eventsource"; + } + else if (VarLoc(*dp1) == &curpstate->eventval) { + StrLen(*dp0) = 11; + StrLoc(*dp0) = "&eventvalue"; + } + else if (VarLoc(*dp1) == &curpstate->eventcode) { + StrLen(*dp0) = 10; + StrLoc(*dp0) = "&eventcode"; + } + else +#endif /* MultiThread */ + syserr("name: unknown event keyword variable"); + + kywdwin: { + StrLen(*dp0) = 7; + StrLoc(*dp0) = "&window"; + } + + kywdstr: { + StrLen(*dp0) = 9; + StrLoc(*dp0) = "&progname"; + } + + kywdpos: { + StrLen(*dp0) = 4; + StrLoc(*dp0) = "&pos"; + } + + kywdsubj: { + StrLen(*dp0) = 8; + StrLoc(*dp0) = "&subject"; + } + + default: + if (Offset(*dp1) == 0) { + /* + * Must be a named variable. + */ + dp = VarLoc(*dp1); /* get address of variable */ + if (InRange(globals,dp,eglobals)) { + *dp0 = gnames[dp - globals]; /* global */ + return GlobalName; + } + else if (InRange(statics,dp,estatics)) { + i = dp - statics - proc->fstatic; /* static */ + if (i < 0 || i >= proc->nstatic) + syserr("name: unreferencable static variable"); + i += abs((int)proc->nparam) + abs((int)proc->ndynam); + *dp0 = proc->lnames[i]; + return StaticName; + } + else if (InRange(arg1, dp, &arg1[abs((int)proc->nparam)])) { + *dp0 = proc->lnames[dp - arg1]; /* argument */ + return ParamName; + } + else if (InRange(loc1, dp, &loc1[proc->ndynam])) { + *dp0 = proc->lnames[dp - loc1 + abs((int)proc->nparam)]; + return LocalName; + } + else + syserr("name: cannot determine variable name"); + } + else { + /* + * Must be an element of a structure. + */ + blkptr = (union block *)VarLoc(*dp1); + varptr = (dptr)((word *)VarLoc(*dp1) + Offset(*dp1)); + switch ((int)BlkType(blkptr)) { + case T_Lelem: /* list */ + i = varptr - &blkptr->lelem.lslots[blkptr->lelem.first] + 1; + if (i < 1) + i += blkptr->lelem.nslots; +#ifdef ListFix + while (BlkType(blkptr->lelem.listprev) == T_Lelem) { +#else /* ListFix */ + while (blkptr->lelem.listprev != NULL) { +#endif /* ListFix */ + blkptr = blkptr->lelem.listprev; + i += blkptr->lelem.nused; + } +#ifdef ListFix + sprintf(sbuf,"list_%d[%ld]", + (long)blkptr->lelem.listprev->list.id, (long)i); +#else /* ListFix */ + sprintf(sbuf,"L[%ld]", (long)i); +#endif /* ListFix */ + i = strlen(sbuf); + Protect(StrLoc(*dp0) = alcstr(sbuf,i), return Error); + StrLen(*dp0) = i; + break; + case T_Record: /* record */ + i = varptr - blkptr->record.fields; + proc = &blkptr->record.recdesc->proc; + +#ifdef TableFix + sprintf(sbuf,"record %s_%d.%s", StrLoc(proc->recname), + blkptr->record.id, + StrLoc(proc->lnames[i])); +#else + sprintf(sbuf,"%s.%s", StrLoc(proc->recname), + StrLoc(proc->lnames[i])); +#endif + + i = strlen(sbuf); + Protect(StrLoc(*dp0) = alcstr(sbuf,i), return Error); + StrLen(*dp0) = i; + break; + case T_Telem: /* table */ + t = keyref(blkptr,dp0); + if (t == Error) + return Error; + break; + default: /* none of the above */ +#ifdef EventMon + *dp0 = emptystr; +#else /* EventMon */ + syserr("name: invalid structure reference"); +#endif /* EventMon */ + + } + } + } + return Succeeded; + } + +#if COMPILER +#begdef PTraceSetup() + struct b_proc *proc; + + --k_trace; + showline(file_name, line_num); + showlevel(k_level); + proc = PFDebug(*pfp)->proc; /* get address of procedure block */ + putstr(stderr, &proc->pname); +#enddef + +/* + * ctrace - a procedure is being called; produce a trace message. + */ +void ctrace() + { + dptr arg; + int n; + + PTraceSetup(); + + putc('(', stderr); + arg = glbl_argp; + n = abs((int)proc->nparam); + while (n--) { + outimage(stderr, arg++, 0); + if (n) + putc(',', stderr); + } + putc(')', stderr); + putc('\n', stderr); + fflush(stderr); + } + +/* + * rtrace - a procedure is returning; produce a trace message. + */ + +void rtrace() + { + PTraceSetup(); + + fprintf(stderr, " returned "); + outimage(stderr, pfp->rslt, 0); + putc('\n', stderr); + fflush(stderr); + } + +/* + * failtrace - procedure named s is failing; produce a trace message. + */ + +void failtrace() + { + PTraceSetup(); + + fprintf(stderr, " failed\n"); + fflush(stderr); + } + +/* + * strace - a procedure is suspending; produce a trace message. + */ + +void strace() + { + PTraceSetup(); + + fprintf(stderr, " suspended "); + outimage(stderr, pfp->rslt, 0); + putc('\n', stderr); + fflush(stderr); + } + +/* + * atrace - a procedure is being resumed; produce a trace message. + */ +void atrace() + { + PTraceSetup(); + + fprintf(stderr, " resumed\n"); + fflush(stderr); + } +#endif /* COMPILER */ + +/* + * keyref(bp,dp) -- print name of subscripted table + */ +static int keyref(bp, dp) + union block *bp; + dptr dp; + { + char *s, *s2; + char sbuf[100]; /* buffer; might be too small */ + int len; + + if (getimage(&(bp->telem.tref),dp) == Error) + return Error; + + /* + * Allocate space, and copy the image surrounded by "table_n[" and "]" + */ + s2 = StrLoc(*dp); + len = StrLen(*dp); +#ifdef TableFix + if (BlkType(bp) == T_Tvtbl) + bp = bp->tvtbl.clink; + else + while(BlkType(bp) == T_Telem) + bp = bp->telem.clink; + sprintf(sbuf, "table_%d[", bp->table.id); +#else /* TableFix */ + strcpy(sbuf, "T["); +#endif /* TableFix */ + { char * dest = sbuf + strlen(sbuf); + strncpy(dest, s2, len); + dest[len] = '\0'; + } + strcat(sbuf, "]"); + len = strlen(sbuf); + Protect(s = alcstr(sbuf, len), return Error); + StrLoc(*dp) = s; + StrLen(*dp) = len; + return Succeeded; + } + +#ifdef Coexpr +/* + * cotrace -- a co-expression context switch; produce a trace message. + */ +void cotrace(ccp, ncp, swtch_typ, valloc) +struct b_coexpr *ccp; +struct b_coexpr *ncp; +int swtch_typ; +dptr valloc; + { + struct b_proc *proc; + +#if !COMPILER + inst t_ipc; +#endif /* !COMPILER */ + + --k_trace; + +#if COMPILER + showline(ccp->file_name, ccp->line_num); + proc = PFDebug(*ccp->es_pfp)->proc; /* get address of procedure block */ +#else /* COMPILER */ + + /* + * Compute the ipc of the instruction causing the context switch. + */ + t_ipc.op = ipc.op - 1; + showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); + proc = (struct b_proc *)BlkLoc(*glbl_argp); +#endif /* COMPILER */ + + showlevel(k_level); + putstr(stderr, &proc->pname); + fprintf(stderr,"; co-expression_%ld ", (long)ccp->id); + switch (swtch_typ) { + case A_Coact: + fprintf(stderr,": "); + outimage(stderr, valloc, 0); + fprintf(stderr," @ "); + break; + case A_Coret: + fprintf(stderr,"returned "); + outimage(stderr, valloc, 0); + fprintf(stderr," to "); + break; + case A_Cofail: + fprintf(stderr,"failed to "); + break; + } + fprintf(stderr,"co-expression_%ld\n", (long)ncp->id); + fflush(stderr); + } +#endif /* Coexpr */ + +/* + * showline - print file and line number information. + */ +static void showline(f, l) +char *f; +int l; + { + int i; + + i = (int)strlen(f); + while (i > 13) { + f++; + i--; + } + if (l > 0) + fprintf(stderr, "%-13s: %4d ",f, l); + else + fprintf(stderr, " : "); + } + +/* + * showlevel - print "| " n times. + */ +static void showlevel(n) +register int n; + { + while (n-- > 0) { + putc('|', stderr); + putc(' ', stderr); + } + } + +#if !COMPILER + +#include "../h/opdefs.h" + + +extern struct descrip value_tmp; /* argument of Op_Apply */ +extern struct b_proc *opblks[]; + + +/* + * ttrace - show offending expression. + */ +static void ttrace() + { + struct b_proc *bp; + word nargs; + switch ((int)lastop) { + + case Op_Keywd: + fprintf(stderr,"bad keyword reference"); + break; + + case Op_Invoke: + bp = (struct b_proc *)BlkLoc(*xargp); + nargs = xnargs; + if (xargp[0].dword == D_Proc) + putstr(stderr, &(bp->pname)); + else + outimage(stderr, xargp, 0); + putc('(', stderr); + while (nargs--) { + outimage(stderr, ++xargp, 0); + if (nargs) + putc(',', stderr); + } + putc(')', stderr); + break; + + case Op_Toby: + putc('{', stderr); + outimage(stderr, ++xargp, 0); + fprintf(stderr, " to "); + outimage(stderr, ++xargp, 0); + fprintf(stderr, " by "); + outimage(stderr, ++xargp, 0); + putc('}', stderr); + break; + + case Op_Subsc: + putc('{', stderr); + outimage(stderr, ++xargp, 0); + putc('[', stderr); + outimage(stderr, ++xargp, 0); + putc(']', stderr); + putc('}', stderr); + break; + + case Op_Sect: + putc('{', stderr); + outimage(stderr, ++xargp, 0); + putc('[', stderr); + outimage(stderr, ++xargp, 0); + putc(':', stderr); + outimage(stderr, ++xargp, 0); + putc(']', stderr); + putc('}', stderr); + break; + + case Op_Bscan: + putc('{', stderr); + outimage(stderr, xargp, 0); + fputs(" ? ..}", stderr); + break; + + case Op_Coact: + putc('{', stderr); + outimage(stderr, ++xargp, 0); + fprintf(stderr, " @ "); + outimage(stderr, ++xargp, 0); + putc('}', stderr); + break; + + case Op_Apply: + outimage(stderr, xargp++, 0); + fprintf(stderr," ! "); + outimage(stderr, &value_tmp, 0); + break; + + case Op_Create: + fprintf(stderr,"{create ..}"); + break; + + case Op_Field: + putc('{', stderr); + outimage(stderr, ++xargp, 0); + fprintf(stderr, " . "); + ++xargp; + if (IntVal(*xargp) == -1) + fprintf(stderr, "field"); + else + fprintf(stderr, "%s", StrLoc(fnames[IntVal(*xargp)])); + putc('}', stderr); + break; + + case Op_Limit: + fprintf(stderr, "limit counter: "); + outimage(stderr, xargp, 0); + break; + + case Op_Llist: + fprintf(stderr,"[ ... ]"); + break; + + default: + + bp = opblks[lastop]; + nargs = abs((int)bp->nparam); + putc('{', stderr); + if (lastop == Op_Bang || lastop == Op_Random) + goto oneop; + if (abs((int)bp->nparam) >= 2) { + outimage(stderr, ++xargp, 0); + putc(' ', stderr); + putstr(stderr, &(bp->pname)); + putc(' ', stderr); + } + else +oneop: + putstr(stderr, &(bp->pname)); + outimage(stderr, ++xargp, 0); + putc('}', stderr); + } + + if (ipc.opnd != NULL) + fprintf(stderr, " from line %d in %s", findline(ipc.opnd), + findfile(ipc.opnd)); + putc('\n', stderr); + fflush(stderr); + } + + +/* + * ctrace - procedure named s is being called with nargs arguments, the first + * of which is at arg; produce a trace message. + */ +void ctrace(dp, nargs, arg) +dptr dp; +int nargs; +dptr arg; + { + + showline(findfile(ipc.opnd), findline(ipc.opnd)); + showlevel(k_level); + putstr(stderr, dp); + putc('(', stderr); + while (nargs--) { + outimage(stderr, arg++, 0); + if (nargs) + putc(',', stderr); + } + putc(')', stderr); + putc('\n', stderr); + fflush(stderr); + } + +/* + * rtrace - procedure named s is returning *rval; produce a trace message. + */ + +void rtrace(dp, rval) +dptr dp; +dptr rval; + { + inst t_ipc; + + /* + * Compute the ipc of the return instruction. + */ + t_ipc.op = ipc.op - 1; + showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); + showlevel(k_level); + putstr(stderr, dp); + fprintf(stderr, " returned "); + outimage(stderr, rval, 0); + putc('\n', stderr); + fflush(stderr); + } + +/* + * failtrace - procedure named s is failing; produce a trace message. + */ + +void failtrace(dp) +dptr dp; + { + inst t_ipc; + + /* + * Compute the ipc of the fail instruction. + */ + t_ipc.op = ipc.op - 1; + showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); + showlevel(k_level); + putstr(stderr, dp); + fprintf(stderr, " failed"); + putc('\n', stderr); + fflush(stderr); + } + +/* + * strace - procedure named s is suspending *rval; produce a trace message. + */ + +void strace(dp, rval) +dptr dp; +dptr rval; + { + inst t_ipc; + + /* + * Compute the ipc of the suspend instruction. + */ + t_ipc.op = ipc.op - 1; + showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); + showlevel(k_level); + putstr(stderr, dp); + fprintf(stderr, " suspended "); + outimage(stderr, rval, 0); + putc('\n', stderr); + fflush(stderr); + } + +/* + * atrace - procedure named s is being resumed; produce a trace message. + */ + +void atrace(dp) +dptr dp; + { + inst t_ipc; + + /* + * Compute the ipc of the instruction causing resumption. + */ + t_ipc.op = ipc.op - 1; + showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); + showlevel(k_level); + putstr(stderr, dp); + fprintf(stderr, " resumed"); + putc('\n', stderr); + fflush(stderr); + } + +#ifdef Coexpr +/* + * coacttrace -- co-expression is being activated; produce a trace message. + */ +void coacttrace(ccp, ncp) +struct b_coexpr *ccp; +struct b_coexpr *ncp; + { + struct b_proc *bp; + inst t_ipc; + + bp = (struct b_proc *)BlkLoc(*glbl_argp); + /* + * Compute the ipc of the activation instruction. + */ + t_ipc.op = ipc.op - 1; + showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); + showlevel(k_level); + putstr(stderr, &(bp->pname)); + fprintf(stderr,"; co-expression_%ld : ", (long)ccp->id); + outimage(stderr, (dptr)(sp - 3), 0); + fprintf(stderr," @ co-expression_%ld\n", (long)ncp->id); + fflush(stderr); + } + +/* + * corettrace -- return from co-expression; produce a trace message. + */ +void corettrace(ccp, ncp) +struct b_coexpr *ccp; +struct b_coexpr *ncp; + { + struct b_proc *bp; + inst t_ipc; + + bp = (struct b_proc *)BlkLoc(*glbl_argp); + /* + * Compute the ipc of the coret instruction. + */ + t_ipc.op = ipc.op - 1; + showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); + showlevel(k_level); + putstr(stderr, &(bp->pname)); + fprintf(stderr,"; co-expression_%ld returned ", (long)ccp->id); + outimage(stderr, (dptr)(&ncp->es_sp[-3]), 0); + fprintf(stderr," to co-expression_%ld\n", (long)ncp->id); + fflush(stderr); + } + +/* + * cofailtrace -- failure return from co-expression; produce a trace message. + */ +void cofailtrace(ccp, ncp) +struct b_coexpr *ccp; +struct b_coexpr *ncp; + { + struct b_proc *bp; + inst t_ipc; + + bp = (struct b_proc *)BlkLoc(*glbl_argp); + /* + * Compute the ipc of the cofail instruction. + */ + t_ipc.op = ipc.op - 1; + showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); + showlevel(k_level); + putstr(stderr, &(bp->pname)); + fprintf(stderr,"; co-expression_%ld failed to co-expression_%ld\n", + (long)ccp->id, (long)ncp->id); + fflush(stderr); + } +#endif /* Coexpr */ +#endif /* !COMPILER */ + +/* + * Service routine to display variables in given number of + * procedure calls to file f. + */ + +int xdisp(fp,dp,count,f) +#if COMPILER + struct p_frame *fp; +#else /* COMPILER */ + struct pf_marker *fp; +#endif /* COMPILER */ + register dptr dp; + int count; + FILE *f; + { + register dptr np; + register int n; + struct b_proc *bp; + word nglobals, *indices; + + while (count--) { /* go back through 'count' frames */ + if (fp == NULL) + break; /* needed because &level is wrong in co-expressions */ + +#if COMPILER + bp = PFDebug(*fp)->proc; /* get address of procedure block */ +#else /* COMPILER */ + bp = (struct b_proc *)BlkLoc(*dp++); /* get addr of procedure block */ + /* #%#% was: no post-increment there, but *pre*increment dp below */ +#endif /* COMPILER */ + + /* + * Print procedure name. + */ + putstr(f, &(bp->pname)); + fprintf(f, " local identifiers:\n"); + + /* + * Print arguments. + */ + np = bp->lnames; + for (n = abs((int)bp->nparam); n > 0; n--) { + fprintf(f, " "); + putstr(f, np); + fprintf(f, " = "); + outimage(f, dp++, 0); + putc('\n', f); + np++; + } + + /* + * Print locals. + */ +#if COMPILER + dp = fp->tend.d; +#else /* COMPILER */ + dp = &fp->pf_locals[0]; +#endif /* COMPILER */ + for (n = bp->ndynam; n > 0; n--) { + fprintf(f, " "); + putstr(f, np); + fprintf(f, " = "); + outimage(f, dp++, 0); + putc('\n', f); + np++; + } + + /* + * Print statics. + */ + dp = &statics[bp->fstatic]; + for (n = bp->nstatic; n > 0; n--) { + fprintf(f, " "); + putstr(f, np); + fprintf(f, " = "); + outimage(f, dp++, 0); + putc('\n', f); + np++; + } + +#if COMPILER + dp = fp->old_argp; + fp = fp->old_pfp; +#else /* COMPILER */ + dp = fp->pf_argp; + fp = fp->pf_pfp; +#endif /* COMPILER */ + } + + /* + * Print globals. Sort names in lexical order using temporary index array. + */ + +#if COMPILER + nglobals = n_globals; +#else /* COMPILER */ + nglobals = eglobals - globals; +#endif /* COMPILER */ + + indices = (word *)malloc(nglobals * sizeof(word)); + if (indices == NULL) + return Failed; + else { + for (n = 0; n < nglobals; n++) + indices[n] = n; + qsort ((char*)indices, (int)nglobals, sizeof(word), (int (*)())glbcmp); + fprintf(f, "\nglobal identifiers:\n"); + for (n = 0; n < nglobals; n++) { + fprintf(f, " "); + putstr(f, &gnames[indices[n]]); + fprintf(f, " = "); + outimage(f, &globals[indices[n]], 0); + putc('\n', f); + } + fflush(f); + free((pointer)indices); + } + return Succeeded; + } + +/* + * glbcmp - compare the names of two globals using their temporary indices. + */ +static int glbcmp (pi, pj) +char *pi, *pj; + { + register word i = *(word *)pi; + register word j = *(word *)pj; + return lexcmp(&gnames[i], &gnames[j]); + } + diff --git a/src/runtime/rimage.r b/src/runtime/rimage.r new file mode 100644 index 0000000..775b836 --- /dev/null +++ b/src/runtime/rimage.r @@ -0,0 +1,930 @@ +/* + * File: rimage.c + * Functions and data for reading and writing GIF images + */ + +#ifdef Graphics + +#define GifSeparator 0x2C /* (',') beginning of image */ +#define GifTerminator 0x3B /* (';') end of image */ +#define GifExtension 0x21 /* ('!') extension block */ +#define GifControlExt 0xF9 /* graphic control extension label */ +#define GifEmpty -1 /* internal flag indicating no prefix */ + +#define GifTableSize 4096 /* maximum number of entries in table */ +#define GifBlockSize 255 /* size of output block */ + +typedef struct lzwnode { /* structure of LZW encoding tree node */ + unsigned short tcode; /* token code */ + unsigned short child; /* first child node */ + unsigned short sibling; /* next sibling */ + } lzwnode; + +static int gfread (char *fn, int p); +static int gfheader (FILE *f); +static int gfskip (FILE *f); +static void gfcontrol (FILE *f); +static int gfimhdr (FILE *f); +static int gfmap (FILE *f, int p); +static int gfsetup (void); +static int gfrdata (FILE *f); +static int gfrcode (FILE *f); +static void gfinsert (int prev, int c); +static int gffirst (int c); +static void gfgen (int c); +static void gfput (int b); + +static int gfwrite (wbp w, char *filename, + int x, int y, int width, int height); +static void gfmktree (lzwnode *tree); +static void gfout (int tcode); +static void gfdump (void); + +static int medcut (long hlist[], struct palentry plist[], int ncolors); + +static FILE *gf_f; /* input file */ + +static int gf_gcmap, gf_lcmap; /* global color map? local color map? */ +static int gf_nbits; /* number of bits per pixel */ +static int gf_ilace; /* interlace flag */ +static int gf_width, gf_height; /* image size */ + +static short *gf_prefix, *gf_suffix; /* prefix and suffix tables */ +static int gf_free; /* next free position */ + +static struct palentry *gf_paltbl; /* palette table */ +static unsigned char *gf_string; /* incoming image data */ +static short *gf_pixels; /* outgoing image data */ +static unsigned char *gf_nxt, *gf_lim; /* store pointer and its limit */ +static int gf_row, gf_step; /* current row and step size */ + +static int gf_cdsize; /* code size */ +static int gf_clear, gf_eoi; /* values of CLEAR and EOI codes */ +static int gf_lzwbits, gf_lzwmask; /* current bits per code */ + +static unsigned char *gf_obuf; /* output buffer */ +static unsigned long gf_curr; /* current partial byte(s) */ +static int gf_valid; /* number of valid bits */ +static int gf_rem; /* remaining bytes in this block */ + +/* + * readGIF(filename, p, imd) - read GIF file into image data structure + * + * p is a palette number to which the GIF colors are to be coerced; + * p=0 uses the colors exactly as given in the GIF file. + */ +int readGIF(filename, p, imd) +char *filename; +int p; +struct imgdata *imd; + { + int r; + + r = gfread(filename, p); /* read image */ + + if (gf_prefix) free((pointer)gf_prefix); /* deallocate temp memory */ + if (gf_suffix) free((pointer)gf_suffix); + if (gf_f) fclose(gf_f); + + if (r != Succeeded) { /* if no success, free mem */ + if (gf_paltbl) free((pointer) gf_paltbl); + if (gf_string) free((pointer) gf_string); + return r; /* return Failed or Error */ + } + + imd->width = gf_width; /* set return variables */ + imd->height = gf_height; + imd->paltbl = gf_paltbl; + imd->data = gf_string; + + return Succeeded; /* return success */ + } + +/* + * gfread(filename, p) - read GIF file, setting gf_ globals + */ +static int gfread(filename, p) +char *filename; +int p; + { + int i; + + gf_f = NULL; + gf_prefix = NULL; + gf_suffix = NULL; + gf_string = NULL; + + if (!(gf_paltbl = (struct palentry *)malloc(256 * sizeof(struct palentry)))) + return Failed; + + if ((gf_f = fopen(filename, "rb")) == NULL) + return Failed; + + for (i = 0; i < 256; i++) /* init palette table */ + gf_paltbl[i].used = gf_paltbl[i].valid = gf_paltbl[i].transpt = 0; + + if (!gfheader(gf_f)) /* read file header */ + return Failed; + if (gf_gcmap) /* read global color map, if any */ + if (!gfmap(gf_f, p)) + return Failed; + if (!gfskip(gf_f)) /* skip to start of image */ + return Failed; + if (!gfimhdr(gf_f)) /* read image header */ + return Failed; + if (gf_lcmap) /* read local color map, if any */ + if (!gfmap(gf_f, p)) + return Failed; + if (!gfsetup()) /* prepare to read image */ + return Error; + if (!gfrdata(gf_f)) /* read image data */ + return Failed; + while (gf_row < gf_height) /* pad if too short */ + gfput(0); + + return Succeeded; + } + +/* + * gfheader(f) - read GIF file header; return nonzero if successful + */ +static int gfheader(f) +FILE *f; + { + unsigned char hdr[13]; /* size of a GIF header */ + int b; + + if (fread((char *)hdr, sizeof(char), sizeof(hdr), f) != sizeof(hdr)) + return 0; /* header short or missing */ + if (strncmp((char *)hdr, "GIF", 3) != 0 || + !isdigit(hdr[3]) || !isdigit(hdr[4])) + return 0; /* not GIFnn */ + + b = hdr[10]; /* flag byte */ + gf_gcmap = b & 0x80; /* global color map flag */ + gf_nbits = (b & 7) + 1; /* number of bits per pixel */ + return 1; + } + +/* + * gfskip(f) - skip intermediate blocks and locate image + */ +static int gfskip(f) +FILE *f; + { + int c, n; + + while ((c = getc(f)) != GifSeparator) { /* look for start-of-image flag */ + if (c == EOF) + return 0; + if (c == GifExtension) { /* if extension block is present */ + c = getc(f); /* get label */ + if ((c & 0xFF) == GifControlExt) + gfcontrol(f); /* process control subblock */ + while ((n = getc(f)) != 0) { /* read blks until empty one */ + if (n == EOF) + return 0; + n &= 0xFF; /* ensure positive count */ + while (n--) /* skip block contents */ + getc(f); + } + } + } + return 1; + } + +/* + * gfcontrol(f) - process control extension subblock + */ +static void gfcontrol(f) +FILE *f; + { + int i, n, c, t; + + n = getc(f) & 0xFF; /* subblock length (s/b 4) */ + for (i = t = 0; i < n; i++) { + c = getc(f) & 0xFF; + if (i == 0) + t = c & 1; /* transparency flag */ + else if (i == 3 && t != 0) { + gf_paltbl[c].transpt = 1; /* set flag for transpt color */ + gf_paltbl[c].valid = 0; /* color is no longer "valid" */ + } + } + } + +/* + * gfimhdr(f) - read image header + */ +static int gfimhdr(f) +FILE *f; + { + unsigned char hdr[9]; /* size of image hdr excl separator */ + int b; + + if (fread((char *)hdr, sizeof(char), sizeof(hdr), f) != sizeof(hdr)) + return 0; /* header short or missing */ + gf_width = hdr[4] + 256 * hdr[5]; + gf_height = hdr[6] + 256 * hdr[7]; + b = hdr[8]; /* flag byte */ + gf_lcmap = b & 0x80; /* local color map flag */ + gf_ilace = b & 0x40; /* interlace flag */ + if (gf_lcmap) + gf_nbits = (b & 7) + 1; /* if local map, reset nbits also */ + return 1; + } + +/* + * gfmap(f, p) - read GIF color map into paltbl under control of palette p + */ +static int gfmap(f, p) +FILE *f; +int p; + { + int ncolors, i, r, g, b, c; + struct palentry *stdpal = 0; + + if (p) + stdpal = palsetup(p); + + ncolors = 1 << gf_nbits; + + for (i = 0; i < ncolors; i++) { + r = getc(f); + g = getc(f); + b = getc(f); + if (r == EOF || g == EOF || b == EOF) + return 0; + if (p) { + c = *(unsigned char *)(rgbkey(p, r / 255.0, g / 255.0, b / 255.0)); + gf_paltbl[i].clr = stdpal[c].clr; + } + else { + gf_paltbl[i].clr.red = 257 * r; /* 257 * 255 -> 65535 */ + gf_paltbl[i].clr.green = 257 * g; + gf_paltbl[i].clr.blue = 257 * b; + } + if (!gf_paltbl[i].transpt) /* if not transparent color */ + gf_paltbl[i].valid = 1; /* mark as valid/opaque */ + } + + return 1; + } + +/* + * gfsetup() - prepare to read GIF data + */ +static int gfsetup() + { + int i; + word len; + + len = (word)gf_width * (word)gf_height; + gf_string = (unsigned char *)malloc(len); + gf_prefix = (short *)malloc(GifTableSize * sizeof(short)); + gf_suffix = (short *)malloc(GifTableSize * sizeof(short)); + if (!gf_string || !gf_prefix || !gf_suffix) + return 0; + for (i = 0; i < GifTableSize; i++) { + gf_prefix[i] = GifEmpty; + gf_suffix[i] = i; + } + + gf_row = 0; /* current row is 0 */ + gf_nxt = gf_string; /* set store pointer */ + + if (gf_ilace) { /* if interlaced */ + gf_step = 8; /* step rows by 8 */ + gf_lim = gf_string + gf_width; /* stop at end of one row */ + } + else { + gf_lim = gf_string + len; /* do whole image at once */ + gf_step = gf_height; /* step to end when full */ + } + + return 1; + } + +/* + * gfrdata(f) - read GIF data + */ +static int gfrdata(f) +FILE *f; + { + int curr, prev, c; + + if ((gf_cdsize = getc(f)) == EOF) + return 0; + gf_clear = 1 << gf_cdsize; + gf_eoi = gf_clear + 1; + gf_free = gf_eoi + 1; + + gf_lzwbits = gf_cdsize + 1; + gf_lzwmask = (1 << gf_lzwbits) - 1; + + gf_curr = 0; + gf_valid = 0; + gf_rem = 0; + + prev = curr = gfrcode(f); + while (curr != gf_eoi) { + if (curr == gf_clear) { /* if reset code */ + gf_lzwbits = gf_cdsize + 1; + gf_lzwmask = (1 << gf_lzwbits) - 1; + gf_free = gf_eoi + 1; + prev = curr = gfrcode(f); + gfgen(curr); + } + else if (curr < gf_free) { /* if code is in table */ + gfgen(curr); + gfinsert(prev, gffirst(curr)); + prev = curr; + } + else if (curr == gf_free) { /* not yet in table */ + c = gffirst(prev); + gfgen(prev); + gfput(c); + gfinsert(prev, c); + prev = curr; + } + else { /* illegal code */ + if (gf_nxt == gf_lim) + return 1; /* assume just extra stuff after end */ + else + return 0; /* more badly confused */ + } + curr = gfrcode(f); + } + + return 1; + } + +/* + * gfrcode(f) - read next LZW code + */ +static int gfrcode(f) +FILE *f; + { + int c, r; + + while (gf_valid < gf_lzwbits) { + if (--gf_rem <= 0) { + if ((gf_rem = getc(f)) == EOF) + return gf_eoi; + } + if ((c = getc(f)) == EOF) + return gf_eoi; + gf_curr |= ((c & 0xFF) << gf_valid); + gf_valid += 8; + } + r = gf_curr & gf_lzwmask; + gf_curr >>= gf_lzwbits; + gf_valid -= gf_lzwbits; + return r; + } + +/* + * gfinsert(prev, c) - insert into table + */ +static void gfinsert(prev, c) +int prev, c; + { + + if (gf_free >= GifTableSize) /* sanity check */ + return; + + gf_prefix[gf_free] = prev; + gf_suffix[gf_free] = c; + + /* increase code size if code bits are exhausted, up to max of 12 bits */ + if (++gf_free > gf_lzwmask && gf_lzwbits < 12) { + gf_lzwmask = gf_lzwmask * 2 + 1; + gf_lzwbits++; + } + + } + +/* + * gffirst(c) - return the first pixel in a map structure + */ +static int gffirst(c) +int c; + { + int d; + + if (c >= gf_free) + return 0; /* not in table (error) */ + while ((d = gf_prefix[c]) != GifEmpty) + c = d; + return gf_suffix[c]; + } + +/* + * gfgen(c) - generate and output prefix + */ +static void gfgen(c) +int c; + { + int d; + + if ((d = gf_prefix[c]) != GifEmpty) + gfgen(d); + gfput(gf_suffix[c]); + } + +/* + * gfput(b) - add a byte to the output string + */ +static void gfput(b) +int b; + { + if (gf_nxt >= gf_lim) { /* if current row is full */ + gf_row += gf_step; + while (gf_row >= gf_height && gf_ilace && gf_step > 2) { + if (gf_step == 4) { + gf_row = 1; + gf_step = 2; + } + else if ((gf_row % 8) != 0) { + gf_row = 2; + gf_step = 4; + } + else { + gf_row = 4; + /* gf_step remains 8 */ + } + } + + if (gf_row >= gf_height) { + gf_step = 0; + return; /* too much data; ignore it */ + } + gf_nxt = gf_string + ((word)gf_row * (word)gf_width); + gf_lim = gf_nxt + gf_width; + } + + *gf_nxt++ = b; /* store byte */ + gf_paltbl[b].used = 1; /* mark color entry as used */ + } + +/* + * writeGIF(w, filename, x, y, width, height) - write GIF image + * + * Returns Succeeded, Failed, or Error. + * We assume that the area specified is within the window. + */ +int writeGIF(w, filename, x, y, width, height) +wbp w; +char *filename; +int x, y, width, height; + { + int r; + + r = gfwrite(w, filename, x, y, width, height); + if (gf_f) fclose(gf_f); + if (gf_pixels) free((pointer)gf_pixels); + return r; + } + +/* + * gfwrite(w, filename, x, y, width, height) - write GIF file + * + * We write GIF87a format (not 89a) for maximum acceptability and because + * we don't need any of the extensions of GIF89. + */ + +static int gfwrite(w, filename, x, y, width, height) +wbp w; +char *filename; +int x, y, width, height; + { + unsigned char obuf[GifBlockSize]; + short *p, *q; + int i, c, cur, nc; + long h, npixels, hlist[1<<15]; + LinearColor *cp; + struct palentry paltbl[GIFMAX]; + lzwnode tree[GifTableSize + 1]; + + npixels = (long)width * (long)height; /* total length of data */ + + if (!(gf_f = fopen(filename, "wb"))) + return Failed; + if (!(gf_pixels = malloc(npixels * sizeof(short)))) + return Error; + + if (!capture(w, x, y, width, height, gf_pixels)) /* get data (rgb15) */ + return Error; + + memset(hlist, 0, sizeof(hlist)); + for (h = 0; h < npixels; h++) /* make histogram */ + hlist[gf_pixels[h]]++; + + nc = medcut(hlist, paltbl, GIFMAX); /* make palette using median cut alg */ + if (nc == 0) + return Error; + + gf_nbits = 1; /* figure out gif bits for nc colors */ + while ((1 << gf_nbits) < nc) + gf_nbits++; + if (gf_nbits < 2) + gf_cdsize = 2; + else + gf_cdsize = gf_nbits; + + gf_clear = 1 << gf_cdsize; /* set encoding variables */ + gf_eoi = gf_clear + 1; + gf_free = gf_eoi + 1; + gf_lzwbits = gf_cdsize + 1; + + /* + * Write the header, global color table, and image descriptor. + */ + + fprintf(gf_f, "GIF87a%c%c%c%c%c%c%c", width, width >> 8, height, height >> 8, + 0x80 | ((gf_nbits - 1) << 4) | (gf_nbits - 1), 0, 0); + + for (i = 0; i < (1 << gf_nbits); i++) { /* output color table */ + if (i < GIFMAX && i < nc) { + cp = &paltbl[i].clr; + putc(cp->red >> 8, gf_f); + putc(cp->green >> 8, gf_f); + putc(cp->blue >> 8, gf_f); + } + else { + putc(0, gf_f); + putc(0, gf_f); + putc(0, gf_f); + } + } + + fprintf(gf_f, "%c%c%c%c%c%c%c%c%c%c%c", GifSeparator, 0, 0, 0, 0, + width, width >> 8, height, height >> 8, gf_nbits - 1, gf_cdsize); + + /* + * Encode and write the image. + */ + gf_obuf = obuf; /* initialize output state */ + gf_curr = 0; + gf_valid = 0; + gf_rem = GifBlockSize; + + gfmktree(tree); /* initialize encoding tree */ + + gfout(gf_clear); /* start with CLEAR code */ + + p = gf_pixels; + q = p + npixels; + cur = hlist[*p++]; /* first pixel is special */ + while (p < q) { + c = hlist[*p++]; /* get code */ + for (i = tree[cur].child; i != 0; i = tree[i].sibling) + if (tree[i].tcode == c) /* find as suffix of previous string */ + break; + if (i != 0) { /* if found in encoding tree */ + cur = i; /* note where */ + continue; /* and accumulate more */ + } + gfout(cur); /* new combination -- output prefix */ + tree[gf_free].tcode = c; /* make node for new combination */ + tree[gf_free].child = 0; + tree[gf_free].sibling = tree[cur].child; + tree[cur].child = gf_free; + cur = c; /* restart string from single pixel */ + ++gf_free; /* grow tree to account for new node */ + if (gf_free > (1 << gf_lzwbits)) { + if (gf_free > GifTableSize) { + gfout(gf_clear); /* table is full; reset to empty */ + gf_lzwbits = gf_cdsize + 1; + gfmktree(tree); + } + else + gf_lzwbits++; /* time to make output one bit wider */ + } + } + + /* + * Finish up. + */ + gfout(cur); /* flush accumulated prefix */ + gfout(gf_eoi); /* send EOI code */ + gf_lzwbits = 7; + gfout(0); /* force out last partial byte */ + gfdump(); /* dump final block */ + putc(0, gf_f); /* terminate image (block of size 0) */ + putc(GifTerminator, gf_f); /* terminate file */ + + fflush(gf_f); + if (ferror(gf_f)) + return Failed; + else + return Succeeded; /* caller will close file */ + } + +/* + * gfmktree() - initialize or reinitialize encoding tree + */ + +static void gfmktree(tree) +lzwnode *tree; + { + int i; + + for (i = 0; i < gf_clear; i++) { /* for each basic entry */ + tree[i].tcode = i; /* code is pixel value */ + tree[i].child = 0; /* no suffixes yet */ + tree[i].sibling = i + 1; /* next code is sibling */ + } + tree[gf_clear - 1].sibling = 0; /* last entry has no sibling */ + gf_free = gf_eoi + 1; /* reset next free entry */ + } + +/* + * gfout(code) - output one LZW token + */ +static void gfout(tcode) +int tcode; + { + gf_curr |= tcode << gf_valid; /* add to current word */ + gf_valid += gf_lzwbits; /* count the bits */ + while (gf_valid >= 8) { /* while we have a byte to output */ + gf_obuf[GifBlockSize - gf_rem] = gf_curr; /* put in buffer */ + gf_curr >>= 8; /* remove from word */ + gf_valid -= 8; + if (--gf_rem == 0) /* flush buffer when full */ + gfdump(); + } + } + +/* + * gfdump() - dump output buffer + */ +static void gfdump() + { + int n; + + n = GifBlockSize - gf_rem; + putc(n, gf_f); /* write block size */ + fwrite((pointer)gf_obuf, 1, n, gf_f); /*write block */ + gf_rem = GifBlockSize; /* reset buffer to empty */ + } + +/* + * Median cut quantization code, based on the classic algorithm from + * Color Image Quantization for Frame Buffer Display + * Paul Heckbert + * SIGGRAPH '82, July 1982 (vol 16 no 3), pp297-307 + */ + +typedef struct box { /* 3-D RGB region for median cut algorithm */ + struct box *next; /* next box in chain */ + long count; /* number of occurrences in this region */ + char maxaxis; /* indication of longest axis */ + char maxdim; /* length along longest axis */ + char cutpt; /* cut point along that axis */ + char rmin, gmin, bmin; /* minimum r, g, b values (5-bit color) */ + char rmax, gmax, bmax; /* maximum r, g, b values (5-bit color) */ + } box; + +#define MC_QUANT 5 /* quantize colors to 5 bits for median cut */ +#define MC_MAXC ((1 << MC_QUANT) - 1) /* so the maximum color value is 31 */ + +#define MC_RED (2 * MC_QUANT) /* red shift */ +#define MC_GRN (1 * MC_QUANT) /* green shift */ +#define MC_BLU (0 * MC_QUANT) /* blue shift */ + +static void mc_shrink(box *bx); +static void mc_cut(box *bx); +static void mc_setcolor(box *bx, struct palentry *pe, int i); +static void mc_median(box *bx, int axis, long counts[], int min, int max); +static void mc_remove(box *bx); +static void mc_insert(box *bx); + +static long *mc_hlist; /* current histogram list */ +static box *mc_blist; /* current box list */ +static int mc_nboxes = 0; /* number of boxes allocated so far */ + +static box *mc_bfirst; /* first box on linked list */ + +/* + * medcut(hlist, plist, n) -- perform median-cut color quantization. + * + * On entry, hlist is a histogram of 32768 entries (5-bit color), + * plist is an array of n palentry structs to be filled in, + * and n is the number of colors desired in the result. + * + * On exit, up to n entries in plist have been filled in, and each + * hlist entry is an index into plist for the corresponding color. + * + * medcut returns the number of entries actually used. + * This is usually n if the histogram has that many nonzero entries. + * A return code of 0 indicates an allocation failure. + */ +int medcut(long hlist[], struct palentry plist[], int ncolors) { + box *bx; + int i; + + if ((mc_blist = malloc(ncolors * sizeof(box))) == NULL) + return 0; + mc_nboxes = 0; + mc_hlist = hlist; + + bx = &mc_blist[mc_nboxes++]; /* create initial box */ + bx->next = NULL; + bx->rmin = bx->gmin = bx->bmin = 0; + bx->rmax = bx->gmax = bx->bmax = 31; + mc_shrink(bx); /* set box statistics */ + mc_bfirst = bx; /* put as first and only box on chain */ + + while (mc_nboxes < ncolors && mc_bfirst->maxdim > 1) + mc_cut(mc_bfirst); /* split box with longest dimension */ + + for (i = 0; i < mc_nboxes; i++) /* for every box created */ + mc_setcolor(&mc_blist[i], &plist[i], i); /* set palette entry */ + + free(mc_blist); + return mc_nboxes; + } + +/* + * mc_shrink(bx) -- shrink a box to tightly enclose its contents. + * + * Adjusts rmin, gmin, bmin, rmax, gmax, bmax. + * Calculates count, maxaxis, maxdim, and cutpt + * (while the necessary statistics are handy). + */ +static void mc_shrink(box *bx) { + int i, n, r, g, b, t, dr, dg, db; + long rcounts[MC_MAXC+1], gcounts[MC_MAXC+1], bcounts[MC_MAXC+1]; + + memset(rcounts, 0, (MC_MAXC + 1) * sizeof(long)); + memset(gcounts, 0, (MC_MAXC + 1) * sizeof(long)); + memset(bcounts, 0, (MC_MAXC + 1) * sizeof(long)); + + /* + * Simultaneously count cross-sections along r, g, and b axes. + */ + t = n = 0; + for (r = bx->rmin; r <= bx->rmax; r++) { + for (g = bx->gmin; g <= bx->gmax; g++) { + for (b = bx->bmin; b <= bx->bmax; b++) { + i = (r << MC_RED) + (g << MC_GRN) + (b << MC_BLU); + n = mc_hlist[i]; + t += n; + rcounts[r] += n; + gcounts[g] += n; + bcounts[b] += n; + } + } + } + bx->count = t; + + /* + * Adjust min/mas bounds to tightly enclose the data we found. + */ + while (rcounts[bx->rmin] == 0) bx->rmin++; + while (rcounts[bx->rmax] == 0) bx->rmax--; + while (gcounts[bx->gmin] == 0) bx->gmin++; + while (gcounts[bx->gmax] == 0) bx->gmax--; + while (bcounts[bx->bmin] == 0) bx->bmin++; + while (bcounts[bx->bmax] == 0) bx->bmax--; + + /* + * Find and record the axis of longest dimension. + */ + dr = bx->rmax - bx->rmin; + dg = bx->gmax - bx->gmin; + db = bx->bmax - bx->bmin; + if (db > dg && db > dr) + mc_median(bx, MC_BLU, bcounts, bx->bmin, bx->bmax); + else if (dr > dg) + mc_median(bx, MC_RED, rcounts, bx->rmin, bx->rmax); + else + mc_median(bx, MC_GRN, gcounts, bx->gmin, bx->gmax); + } + +/* + * mc_median(bx, axis, counts, cmin, cmax) -- find median and set box values. + */ +static void mc_median(box *bx, int axis, long counts[], int cmin, int cmax) { + int lower, upper; + + bx->maxaxis = axis; + bx->maxdim = cmax - cmin + 1; + lower = counts[cmin]; + upper = counts[cmax]; + + /* + * Approach from both ends to find the median bin. + */ + while (cmin < cmax) { + if (lower < upper) + lower += counts[++cmin]; + else + upper += counts[--cmax]; + } + + /* + * Have counted the median bin in both upper and lower halves. + * Remove it from the larger of those two. + */ + if (lower < upper) + upper -= counts[cmax++]; + else + lower -= counts[cmin--]; + + bx->cutpt = cmax; + bx->count = lower + upper; + } + +/* + * mc_cut(bx) -- split box at previously recorded cutpoint. + */ +static void mc_cut(box *b1) { + box *b2; + + mc_remove(b1); /* unlink box */ + b2 = &mc_blist[mc_nboxes++]; /* allocate new box */ + *b2 = *b1; /* duplicate the contents */ + + switch (b1->maxaxis) { + case MC_RED: b1->rmax = b1->cutpt - 1; b2->rmin = b2->cutpt; break; + case MC_GRN: b1->gmax = b1->cutpt - 1; b2->gmin = b2->cutpt; break; + case MC_BLU: b1->bmax = b1->cutpt - 1; b2->bmin = b2->cutpt; break; + } + mc_shrink(b1); /* recomputes box statistics */ + mc_shrink(b2); + + mc_insert(b1); /* put both boxes back on list */ + mc_insert(b2); + } + +/* + * mc_remove(bx) -- remove box from global linked list. + * + * This is fast in practice because we always remove the first entry. + */ +static void mc_remove(box *bx) { + box **bp; + + for (bp = &mc_bfirst; *bp != NULL; bp = &(*bp)->next) { + if (*bp == bx) { + *bp = bx->next; + return; + } + } + } + +/* + * mc_insert(bx) -- insert box in list, preserving decreasing maxdim ordering. + */ +static void mc_insert(box *bx) { + box **bp; + + for (bp = &mc_bfirst; *bp != NULL; bp = &(*bp)->next) { + if (bx->maxdim > (*bp)->maxdim + || (bx->maxdim == (*bp)->maxdim && bx->count >= (*bp)->count)) + break; + } + bx->next = *bp; + *bp = bx; + } + +/* + * mc_setcolor(bx, pe, i) -- set palette entry to box color. + * + * Also sets the associated hlist entries to i, the palette index. + */ +static void mc_setcolor(box *bx, struct palentry *pe, int i) { + int j, r, g, b; + long n, t = 0, rtotal = 0, gtotal = 0, btotal = 0; + + /* + * Calculate a weighted sum of the colors in the box. + */ + for (r = bx->rmin; r <= bx->rmax; r++) { + for (g = bx->gmin; g <= bx->gmax; g++) { + for (b = bx->bmin; b <= bx->bmax; b++) { + j = (r << MC_RED) + (g << MC_GRN) + (b << MC_BLU); + n = mc_hlist[j]; + t += n; + rtotal += n * r; + gtotal += n * g; + btotal += n * b; + mc_hlist[j] = i; + } + } + } + + /* + * Scale colors using floating arithmetic to avoid overflow. + */ + pe->clr.red = (65535. / MC_MAXC) * rtotal / t + 0.5; + pe->clr.green = (65535. / MC_MAXC) * gtotal / t + 0.5; + pe->clr.blue = (65535. / MC_MAXC) * btotal / t + 0.5; + pe->used = 1; + pe->valid = 1; + pe->transpt = 0; + } + +#endif /* Graphics */ diff --git a/src/runtime/rlrgint.r b/src/runtime/rlrgint.r new file mode 100644 index 0000000..f624cc7 --- /dev/null +++ b/src/runtime/rlrgint.r @@ -0,0 +1,2302 @@ +/* + * File: rlrgint.r + * Large integer arithmetic + */ + +#ifdef LargeInts + +extern int over_flow; + +/* + * Conventions: + * + * Lrgints entering this module and leaving it are too large to + * be represented with T_Integer. So, externally, a given value + * is always T_Integer or always T_Lrgint. + * + * Routines outside this module operate on bignums by calling + * a routine like + * + * bigadd(da, db, dx) + * + * where da, db, and dx are pointers to tended descriptors. + * For the common case where one argument is a T_Integer, these + * call routines like + * + * bigaddi(da, IntVal(*db), dx). + * + * The bigxxxi routines can convert an integer to bignum form; + * they use itobig. + * + * The routines that actually do the work take (length, address) + * pairs specifying unsigned base-B digit strings. The sign handling + * is done in the bigxxx routines. + */ + +/* + * Type for doing arithmetic on (2 * NB)-bit nonnegative numbers. + * Normally unsigned but may be signed (with NB reduced appropriately) + * if unsigned arithmetic is slow. + */ + +/* The bignum radix, B */ + +#define B ((word)1 << NB) + +/* Lrgint digits in a word */ + +#define WORDLEN (WordBits / NB + (WordBits % NB != 0)) + +/* size of a bignum block that will hold an integer */ + +#define INTBIGBLK sizeof(struct b_bignum) + sizeof(DIGIT) * WORDLEN + +/* lo(uword d) : the low digit of a uword + hi(uword d) : the rest, d is unsigned + signed_hi(uword d) : the rest, d is signed + dbl(DIGIT a, DIGIT b) : the two-digit uword [a,b] */ + +#define lo(d) ((d) & (B - 1)) +#define hi(d) ((uword)(d) >> NB) +#define dbl(a,b) (((uword)(a) << NB) + (b)) + +#if ((-1) >> 1) < 0 +#define signed_hi(d) ((word)(d) >> NB) +#else +#define signbit ((uword)1 << (WordBits - NB - 1)) +#define signed_hi(d) ((word)((((uword)(d) >> NB) ^ signbit) - signbit)) +#endif + +/* LrgInt(dptr dp) : the struct b_bignum pointed to by dp */ + +#define LrgInt(dp) ((struct b_bignum *)&BlkLoc(*dp)->bignumblk) + +/* LEN(struct b_bignum *b) : number of significant digits */ + +#define LEN(b) ((b)->lsd - (b)->msd + 1) + +/* DIG(struct b_bignum *b, word i): pointer to ith most significant digit */ +/* (NOTE: This macro expansion often results in a very long string, + * so when DIG is used, keep it to one use per line.) + */ + +#define DIG(b,i) (&(b)->digits[(b)->msd+(i)]) + +/* ceil, ln: ceil may be 1 too high in case ln is inaccurate */ + +#undef ceil +#define ceil(x) ((word)((x) + 1.01)) +#define ln(n) (log((double)n)) + +/* determine the number of words needed for a bignum block with n digits */ + +#define LrgNeed(n) ( ((sizeof(struct b_bignum) + ((n) - 1) * sizeof(DIGIT)) \ + + WordSize - 1) & -WordSize ) + +/* copied from rconv.c */ + +#define tonum(c) (isdigit(c) ? (c)-'0' : 10+(((c)|(040))-'a')) + +/* copied from oref.c */ + +#define RandVal (RanScale*(k_random=(RandA*(long)k_random+RandC)&0x7fffffffL)) + +/* + * Prototypes. + */ + +static int mkdesc (struct b_bignum *x, dptr dx); +static void itobig (word i, struct b_bignum *x, dptr dx); + +static void decout (FILE *f, DIGIT *n, word l); + +static int bigaddi (dptr da, word i, dptr dx); +static int bigsubi (dptr da, word i, dptr dx); +static int bigmuli (dptr da, word i, dptr dx); +static int bigdivi (dptr da, word i, dptr dx); +static int bigmodi (dptr da, word i, dptr dx); +static int bigpowi (dptr da, word i, dptr dx); +static int bigpowii (word a, word i, dptr dx); +static word bigcmpi (dptr da, word i); + +static DIGIT add1 (DIGIT *u, DIGIT *v, DIGIT *w, word n); +static word sub1 (DIGIT *u, DIGIT *v, DIGIT *w, word n); +static void mul1 (DIGIT *u, DIGIT *v, DIGIT *w, word n, word m); +static int div1 + (DIGIT *a, DIGIT *b, DIGIT *q, DIGIT *r, word m, word n, struct b_bignum *b1, struct b_bignum *b2); +static void compl1 (DIGIT *u, DIGIT *w, word n); +static word cmp1 (DIGIT *u, DIGIT *v, word n); +static DIGIT addi1 (DIGIT *u, word k, DIGIT *w, word n); +static void subi1 (DIGIT *u, word k, DIGIT *w, word n); +static DIGIT muli1 (DIGIT *u, word k, int c, DIGIT *w, word n); +static DIGIT divi1 (DIGIT *u, word k, DIGIT *w, word n); +static DIGIT shifti1 (DIGIT *u, word k, DIGIT c, DIGIT *w, word n); +static word cmpi1 (DIGIT *u, word k, word n); + +#define bdzero(dest,l) memset(dest, '\0', (l) * sizeof(DIGIT)) +#define bdcopy(src, dest, l) memcpy(dest, src, (l) * sizeof(DIGIT)) + +/* + * mkdesc -- put value into a descriptor + */ + +static int mkdesc(x, dx) +struct b_bignum *x; +dptr dx; +{ + word xlen, cmp; + static DIGIT maxword[WORDLEN] = { 1 << ((WordBits - 1) % NB) }; + + /* suppress leading zero digits */ + + while (x->msd != x->lsd && + *DIG(x,0) == 0) + x->msd++; + + /* put it into a word if it fits, otherwise return the bignum */ + + xlen = LEN(x); + + if (xlen < WORDLEN || + (xlen == WORDLEN && + ((cmp = cmp1(DIG(x,0), maxword, (word)WORDLEN)) < 0 || + (cmp == (word)0 && x->sign)))) { + word val = -(word)*DIG(x,0); + word i; + + for (i = x->msd; ++i <= x->lsd; ) + val = (val << NB) - x->digits[i]; + if (!x->sign) + val = -val; + dx->dword = D_Integer; + IntVal(*dx) = val; + } + else { + dx->dword = D_Lrgint; + BlkLoc(*dx) = (union block *)x; + } + return Succeeded; +} + +/* + * i -> big + */ + +static void itobig(i, x, dx) +word i; +struct b_bignum *x; +dptr dx; +{ + x->lsd = WORDLEN - 1; + x->msd = WORDLEN; + x->sign = 0; + + if (i == 0) { + x->msd--; + *DIG(x,0) = 0; + } + else if (i < 0) { + word d = lo(i); + + if (d != 0) { + d = B - d; + i += B; + } + i = - signed_hi(i); + x->msd--; + *DIG(x,0) = d; + x->sign = 1; + } + + while (i != 0) { + x->msd--; + *DIG(x,0) = lo(i); + i = hi(i); + } + + dx->dword = D_Lrgint; + BlkLoc(*dx) = (union block *)x; +} + +/* + * string -> bignum + */ + +word bigradix(sign, r, s, end_s, result) +int sign; /* '-' or not */ +int r; /* radix 2 .. 36 */ +char *s, *end_s; /* input string */ +union numeric *result; /* output T_Integer or T_Lrgint */ +{ + struct b_bignum *b; + DIGIT *bd; + word len; + int c; + + if (r == 0) + return CvtFail; + len = ceil((end_s - s) * ln(r) / ln(B)); + Protect(b = alcbignum(len), return Error); + bd = DIG(b,0); + + bdzero(bd, len); + + if (r < 2 || r > 36) + return CvtFail; + + for (c = ((s < end_s) ? *s++ : ' '); isalnum(c); + c = ((s < end_s) ? *s++ : ' ')) { + c = tonum(c); + if (c >= r) + return CvtFail; + muli1(bd, (word)r, c, bd, len); + } + + /* + * Skip trailing white space and make sure there is nothing else left + * in the string. Note, if we have already reached end-of-string, + * c has been set to a space. + */ + while (isspace(c) && s < end_s) + c = *s++; + if (!isspace(c)) + return CvtFail; + + if (sign == '-') + b->sign = 1; + + /* put value into dx and return the type */ + + { struct descrip dx; + (void)mkdesc(b, &dx); + if (Type(dx) == T_Lrgint) + result->big = (struct b_bignum *)BlkLoc(dx); + else + result->integer = IntVal(dx); + return Type(dx); + } +} + +/* + * bignum -> real + */ + +double bigtoreal(da) +dptr da; +{ + word i; + double r = 0; + struct b_bignum *b = &BlkLoc(*da)->bignumblk; + + for (i = b->msd; i <= b->lsd; i++) + r = r * B + b->digits[i]; + + return (b->sign ? -r : r); +} + +/* + * real -> bignum + */ + +int realtobig(da, dx) +dptr da, dx; +{ + +#ifdef Double + double x; +#else /* Double */ + double x = BlkLoc(*da)->realblk.realval; +#endif /* Double */ + + struct b_bignum *b; + word i, blen; + word d; + int sgn; + +#ifdef Double + { + int *rp, *rq; + rp = (int *) &(BlkLoc(*da)->realblk.realval); + rq = (int *) &x; + *rq++ = *rp++; + *rq = *rp; + } +#endif /* Double */ + + if (x > 0.9999 * MinLong && x < 0.9999 * MaxLong) { + MakeInt((word)x, dx); + return Succeeded; /* got lucky; a simple integer suffices */ + } + + if (sgn = x < 0) + x = -x; + blen = ln(x) / ln(B) + 0.99; + for (i = 0; i < blen; i++) + x /= B; + if (x >= 1.0) { + x /= B; + blen += 1; + } + + Protect(b = alcbignum(blen), return Error); + for (i = 0; i < blen; i++) { + d = (x *= B); + *DIG(b,i) = d; + x -= d; + } + + b->sign = sgn; + return mkdesc(b, dx); +} + +/* + * bignum -> string + */ + +int bigtos(da, dx) +dptr da, dx; +{ + tended struct b_bignum *a, *temp; + word alen = LEN(LrgInt(da)); + word slen = ceil(alen * ln(B) / ln(10)); + char *p, *q; + + a = LrgInt(da); + Protect(temp = alcbignum(alen), fatalerr(0,NULL)); + if (a->sign) + slen++; + Protect(q = alcstr(NULL,slen), fatalerr(0,NULL)); + bdcopy(DIG(a,0), + DIG(temp,0), + alen); + p = q += slen; + while (cmpi1(DIG(temp,0), + (word)0, alen)) + *--p = '0' + divi1(DIG(temp,0), + (word)10, + DIG(temp,0), + alen); + if (a->sign) + *--p = '-'; + StrLen(*dx) = q - p; + StrLoc(*dx) = p; + return NoCvt; /* The mnemonic is wrong, but the signal means */ + /* that the string is allocated and not null- */ + /* terminated. */ +} + +/* + * bignum -> file + */ + +void bigprint(f, da) +FILE *f; +dptr da; +{ + struct b_bignum *a, *temp; + word alen = LEN(LrgInt(da)); + word slen, dlen; + struct b_bignum *blk = &BlkLoc(*da)->bignumblk; + + slen = blk->lsd - blk->msd; + dlen = slen * NB * 0.3010299956639812 /* 1 / log2(10) */ + + log((double)blk->digits[blk->msd]) * 0.4342944819032518 + 0.5; + /* 1 / ln(10) */ + if (dlen >= MaxDigits) { + fprintf(f, "integer(~10^%ld)",(long)dlen); + return; + } + + /* not worth passing this one back */ + Protect(temp = alcbignum(alen), fatalerr(0, NULL)); + + a = LrgInt(da); + bdcopy(DIG(a,0), + DIG(temp,0), + alen); + if (a->sign) + putc('-', f); + decout(f, + DIG(temp,0), + alen); +} + +/* + * decout - given a base B digit string, print the number in base 10. + */ +static void decout(f, n, l) +FILE *f; +DIGIT *n; +word l; +{ + DIGIT i = divi1(n, (word)10, n, l); + + if (cmpi1(n, (word)0, l)) + decout(f, n, l); + putc('0' + i, f); +} + +/* + * da -> dx + */ + +int cpbignum(da, dx) +dptr da, dx; +{ + struct b_bignum *a, *x; + word alen = LEN(LrgInt(da)); + + Protect(x = alcbignum(alen), return Error); + a = LrgInt(da); + bdcopy(DIG(a,0), + DIG(x,0), + alen); + x->sign = a->sign; + return mkdesc(x, dx); +} + +/* + * da + db -> dx + */ + +int bigadd(da, db, dx) +dptr da, db; +dptr dx; +{ + tended struct b_bignum *a, *b; + struct b_bignum *x; + word alen, blen; + word c; + + if (Type(*da) == T_Lrgint && Type(*db) == T_Lrgint) { + alen = LEN(LrgInt(da)); + blen = LEN(LrgInt(db)); + a = LrgInt(da); + b = LrgInt(db); + if (a->sign == b->sign) { + if (alen > blen) { + Protect(x = alcbignum(alen + 1), return Error); + c = add1(DIG(a,alen-blen), + DIG(b,0), + DIG(x,alen-blen+1), + blen); + *DIG(x,0) = + addi1(DIG(a,0), + c, + DIG(x,1), + alen-blen); + } + else if (alen == blen) { + Protect(x = alcbignum(alen + 1), return Error); + *DIG(x,0) = + add1(DIG(a,0), + DIG(b,0), + DIG(x,1), + alen); + } + else { + Protect(x = alcbignum(blen + 1), return Error); + c = add1(DIG(b,blen-alen), + DIG(a,0), + DIG(x,blen-alen+1), + alen); + *DIG(x,0) = + addi1(DIG(b,0), + c, + DIG(x,1), + blen-alen); + } + x->sign = a->sign; + } + else { + if (alen > blen) { + Protect(x = alcbignum(alen), return Error); + c = sub1(DIG(a,alen-blen), + DIG(b,0), + DIG(x,alen-blen), + blen); + subi1(DIG(a,0), + -c, + DIG(x,0), + alen-blen); + x->sign = a->sign; + } + else if (alen == blen) { + Protect(x = alcbignum(alen), return Error); + if (cmp1(DIG(a,0), + DIG(b,0), + alen) > 0) { + (void)sub1(DIG(a,0), + DIG(b,0), + DIG(x,0), + alen); + x->sign = a->sign; + } + else { + (void)sub1(DIG(b,0), + DIG(a,0), + DIG(x,0), + alen); + x->sign = b->sign; + } + } + else { + Protect(x = alcbignum(blen), return Error); + c = sub1(DIG(b,blen-alen), + DIG(a,0), + DIG(x,blen-alen), + alen); + subi1(DIG(b,0), + -c, + DIG(x,0), + blen-alen); + x->sign = b->sign; + } + } + return mkdesc(x, dx); + } + else if (Type(*da) == T_Lrgint) /* bignum + integer */ + return bigaddi(da, IntVal(*db), dx); + else if (Type(*db) == T_Lrgint) /* integer + bignum */ + return bigaddi(db, IntVal(*da), dx); + else { /* integer + integer */ + struct descrip td; + char tdigits[INTBIGBLK]; + + itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); + return bigaddi(&td, IntVal(*db), dx); + } +} + +/* + * da - db -> dx + */ + +int bigsub(da, db, dx) +dptr da, db, dx; +{ + struct descrip td; + char tdigits[INTBIGBLK]; + tended struct b_bignum *a, *b; + struct b_bignum *x; + word alen, blen; + word c; + + if (Type(*da) == T_Lrgint && Type(*db) == T_Lrgint) { + alen = LEN(LrgInt(da)); + blen = LEN(LrgInt(db)); + a = LrgInt(da); + b = LrgInt(db); + if (a->sign != b->sign) { + if (alen > blen) { + Protect(x = alcbignum(alen + 1), return Error); + c = add1(DIG(a,alen-blen), + DIG(b,0), + DIG(x,alen-blen+1), + blen); + *DIG(x,0) = + addi1(DIG(a,0), + c, + DIG(x,1), + alen-blen); + } + else if (alen == blen) { + Protect(x = alcbignum(alen + 1), return Error); + *DIG(x,0) = + add1(DIG(a,0), + DIG(b,0), + DIG(x,1), + alen); + } + else { + Protect(x = alcbignum(blen + 1), return Error); + c = add1(DIG(b,blen-alen), + DIG(a,0), + DIG(x,blen-alen+1), + alen); + *DIG(x,0) = + addi1(DIG(b,0), + c, + DIG(x,1), + blen-alen); + } + x->sign = a->sign; + } + else { + if (alen > blen) { + Protect(x = alcbignum(alen), return Error); + c = sub1(DIG(a,alen-blen), + DIG(b,0), + DIG(x,alen-blen), + blen); + subi1(DIG(a,0), + -c, + DIG(x,0), + alen-blen); + x->sign = a->sign; + } + else if (alen == blen) { + Protect(x = alcbignum(alen), return Error); + if (cmp1(DIG(a,0), + DIG(b,0), + alen) > 0) { + (void)sub1(DIG(a,0), + DIG(b,0), + DIG(x,0), + alen); + x->sign = a->sign; + } + else { + (void)sub1(DIG(b,0), + DIG(a,0), + DIG(x,0), + alen); + x->sign = 1 ^ b->sign; + } + } + else { + Protect(x = alcbignum(blen), return Error); + c = sub1(DIG(b,blen-alen), + DIG(a,0), + DIG(x,blen-alen), + alen); + subi1(DIG(b,0), + -c, + DIG(x,0), + blen-alen); + x->sign = 1 ^ b->sign; + } + } + return mkdesc(x, dx); + } + else if (Type(*da) == T_Lrgint) /* bignum - integer */ + return bigsubi(da, IntVal(*db), dx); + else if (Type(*db) == T_Lrgint) { /* integer - bignum */ + itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); + alen = LEN(LrgInt(&td)); + blen = LEN(LrgInt(db)); + a = LrgInt(&td); + b = LrgInt(db); + if (a->sign != b->sign) { + if (alen == blen) { + Protect(x = alcbignum(alen + 1), return Error); + *DIG(x,0) = + add1(DIG(a,0), + DIG(b,0), + DIG(x,1), + alen); + } + else { + Protect(x = alcbignum(blen + 1), return Error); + c = add1(DIG(b,blen-alen), + DIG(a,0), + DIG(x,blen-alen+1), + alen); + *DIG(x,0) = + addi1(DIG(b,0), + c, + DIG(x,1), + blen-alen); + } + x->sign = a->sign; + } + else { + if (alen == blen) { + Protect(x = alcbignum(alen), return Error); + if (cmp1(DIG(a,0), + DIG(b,0), + alen) > 0) { + (void)sub1(DIG(a,0), + DIG(b,0), + DIG(x,0), + alen); + x->sign = a->sign; + } + else { + (void)sub1(DIG(b,0), + DIG(a,0), + DIG(x,0), + alen); + x->sign = 1 ^ b->sign; + } + } + else { + Protect(x = alcbignum(blen), return Error); + c = sub1(DIG(b,blen-alen), + DIG(a,0), + DIG(x,blen-alen), + alen); + subi1(DIG(b,0), + -c, + DIG(x,0), + blen-alen); + x->sign = 1 ^ b->sign; + } + } + return mkdesc(x, dx); + } + else { /* integer - integer */ + itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); + return bigsubi(&td, IntVal(*db), dx); + } + +} + +/* + * da * db -> dx + */ + +int bigmul(da, db, dx) +dptr da, db, dx; +{ + tended struct b_bignum *a, *b; + struct b_bignum *x; + word alen, blen; + + if (Type(*da) == T_Lrgint && Type(*db) == T_Lrgint) { + alen = LEN(LrgInt(da)); + blen = LEN(LrgInt(db)); + a = LrgInt(da); + b = LrgInt(db); + Protect(x = alcbignum(alen + blen), return Error); + mul1(DIG(a,0), + DIG(b,0), + DIG(x,0), + alen, blen); + x->sign = a->sign ^ b->sign; + return mkdesc(x, dx); + } + else if (Type(*da) == T_Lrgint) /* bignum * integer */ + return bigmuli(da, IntVal(*db), dx); + else if (Type(*db) == T_Lrgint) /* integer * bignum */ + return bigmuli(db, IntVal(*da), dx); + else { /* integer * integer */ + struct descrip td; + char tdigits[INTBIGBLK]; + + itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); + return bigmuli(&td, IntVal(*db), dx); + } +} + +/* + * da / db -> dx + */ + +int bigdiv(da, db, dx) +dptr da, db, dx; +{ + tended struct b_bignum *a, *b, *x, *tu, *tv; + word alen, blen; + struct descrip td; + char tdigits[INTBIGBLK]; + + /* Put *da into large integer format. */ + if (Type(*da) != T_Lrgint) { + itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); + da = &td; + } + + if (Type(*db) == T_Lrgint) { /* bignum / bignum */ + alen = LEN(LrgInt(da)); + blen = LEN(LrgInt(db)); + if (alen < blen) { + MakeInt(0, dx); + return Succeeded; + } + a = LrgInt(da); + b = LrgInt(db); + Protect(x = alcbignum(alen - blen + 1), return Error); + if (blen == 1) + divi1(DIG(a,0), + (word)*DIG(b,0), + DIG(x,0), + alen); + else { + Protect(tu = alcbignum(alen + 1), return Error); + Protect(tv = alcbignum(blen), return Error); + if (div1(DIG(a,0), + DIG(b,0), + DIG(x,0), + NULL, alen-blen, blen, tu, tv) == Error) + return Error; + } + x->sign = a->sign ^ b->sign; + return mkdesc(x, dx); + } + else /* bignum / integer */ + return bigdivi(da, IntVal(*db), dx); +} + +/* + * da % db -> dx + */ + +int bigmod(da, db, dx) +dptr da, db, dx; +{ + tended struct b_bignum *a, *b, *x, *temp, *tu, *tv; + word alen, blen; + struct descrip td; + char tdigits[INTBIGBLK]; + + /* Put *da into large integer format. */ + if (Type(*da) != T_Lrgint) { + itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); + da = &td; + } + + if (Type(*db) == T_Lrgint) { /* bignum % bignum */ + alen = LEN(LrgInt(da)); + blen = LEN(LrgInt(db)); + if (alen < blen) { + cpbignum(da, dx); + return Succeeded; + } + a = LrgInt(da); + b = LrgInt(db); + Protect(x = alcbignum(blen), return Error); + if (blen == 1) { + Protect(temp = alcbignum(alen), return Error); + *DIG(x,0) = + divi1(DIG(a,0), + (word)*DIG(b,0), + DIG(temp,0), + alen); + } + else { + Protect(tu = alcbignum(alen + 1), return Error); + Protect(tv = alcbignum(blen), return Error); + if (div1(DIG(a,0), + DIG(b,0), + NULL, + DIG(x,0), + alen-blen, blen, tu, tv) == Error) + return Error; + } + x->sign = a->sign; + return mkdesc(x, dx); + } + else /* bignum % integer */ + return bigmodi(da, IntVal(*db), dx); +} + +/* + * -i -> dx + */ + +int bigneg(da, dx) +dptr da, dx; +{ + struct descrip td; + char tdigits[INTBIGBLK]; + int cpstat; + + /* Put *da into large integer format. */ + if (Type(*da) != T_Lrgint) { + itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); + da = &td; + } + LrgInt(da)->sign ^= 1; /* Temporarily change the sign */ + cpstat = cpbignum(da, dx); + LrgInt(da)->sign ^= 1; /* Change it back */ + + return cpstat; +} + +/* + * da ^ db -> dx + */ + +int bigpow(da, db, dx) +dptr da, db, dx; +{ + + if (Type(*db) == T_Lrgint) { + struct b_bignum *b; + + b = LrgInt ( db ); + + + if (Type(*da) == T_Lrgint) { + if ( b->sign ) { + /* bignum ^ -bignum = 0 */ + MakeInt ( 0, dx ); + return Succeeded; + } + else + /* bignum ^ +bignum = guaranteed overflow */ + ReturnErrNum(307, Error); + } + else if ( b->sign ) + /* integer ^ -bignum */ + switch ( IntVal ( *da ) ) { + case 1: + MakeInt ( 1, dx ); + return Succeeded; + case -1: + /* Result is +1 / -1, depending on whether *b is even or odd. */ + if ( ( b->digits[ b->lsd ] ) & 01 ) + MakeInt ( -1, dx ); + else + MakeInt ( 1, dx ); + return Succeeded; + case 0: + ReturnErrNum(204,Error); + default: + /* da ^ (negative int) = 0 for all non-special cases */ + MakeInt(0, dx); + return Succeeded; + } + else { + /* integer ^ +bignum */ + word n, blen; + register DIGIT nth_dig, mask; + + b = LrgInt ( db ); + blen = LEN ( b ); + + /* We scan the bits of b from the most to least significant. + * The bit position in b is represented by the pair ( n, mask ) + * where n is the DIGIT number (0 = most sig.) and mask is the + * the bit mask for the current bit. + * + * For each bit (most sig to least) in b, + * for each zero, square the partial result; + * for each one, square it and multiply it by a */ + MakeInt ( 1, dx ); + for ( n = 0; n < blen; ++n ) { + nth_dig = *DIG ( b, n ); + for ( mask = 1 << ( NB - 1 ); mask; mask >>= 1 ) { + if ( bigmul ( dx, dx, dx ) == Error ) + return Error; + if ( nth_dig & mask ) + if ( bigmul ( dx, da, dx ) == Error ) + return Error; + } + } + } + return Succeeded; + } + else if (Type(*da) == T_Lrgint) /* bignum ^ integer */ + return bigpowi(da, IntVal(*db), dx); + else /* integer ^ integer */ + return bigpowii(IntVal(*da), IntVal(*db), dx); +} + +int bigpowri( a, db, drslt ) +double a; +dptr db, drslt; +{ + register double retval; + register word n; + register DIGIT nth_dig, mask; + struct b_bignum *b; + word blen; + + b = LrgInt ( db ); + blen = LEN ( b ); + if ( b->sign ) { + if ( a == 0.0 ) + ReturnErrNum(204, Error); + else + a = 1.0 / a; + } + + /* We scan the bits of b from the most to least significant. + * The bit position in b is represented by the pair ( n, mask ) + * where n is the DIGIT number (0 = most sig.) and mask is the + * the bit mask for the current bit. + * + * For each bit (most sig to least) in b, + * for each zero, square the partial result; + * for each one, square it and multiply it by a */ + retval = 1.0; + for ( n = 0; n < blen; ++n ) { + nth_dig = *DIG ( b, n ); + for ( mask = 1 << ( NB - 1 ); mask; mask >>= 1 ) { + retval *= retval; + if ( nth_dig & mask ) + retval *= a; + } + } + + Protect(BlkLoc(*drslt) = (union block *)alcreal(retval), return Error); + drslt->dword = D_Real; + return Succeeded; +} + +/* + * iand(da, db) -> dx + */ + +int bigand(da, db, dx) +dptr da, db, dx; +{ + tended struct b_bignum *a, *b, *x, *tad, *tbd; + word alen, blen, xlen; + word i; + DIGIT *ad, *bd; + struct descrip td; + char tdigits[INTBIGBLK]; + + if (Type(*da) == T_Lrgint && Type(*db) == T_Lrgint) { + alen = LEN(LrgInt(da)); + blen = LEN(LrgInt(db)); + xlen = alen > blen ? alen : blen; + a = LrgInt(da); + b = LrgInt(db); + Protect(x = alcbignum(xlen), return Error); + + if (alen == xlen && !a->sign) + ad = DIG(a,0); + else { + Protect(tad = alcbignum(xlen), return Error); + ad = DIG(tad,0); + bdzero(ad, xlen - alen); + bdcopy(DIG(a,0), + &ad[xlen-alen], alen); + if (a->sign) + compl1(ad, ad, xlen); + } + + if (blen == xlen && !b->sign) + bd = DIG(b,0); + else { + Protect(tbd = alcbignum(xlen), return Error); + bd = DIG(tbd,0); + bdzero(bd, xlen - blen); + bdcopy(DIG(b,0), + &bd[xlen-blen], blen); + if (b->sign) + compl1(bd, bd, xlen); + } + + for (i = 0; i < xlen; i++) + *DIG(x,i) = + ad[i] & bd[i]; + + if (a->sign & b->sign) { + x->sign = 1; + compl1(DIG(x,0), + DIG(x,0), + xlen); + } + } + else if (Type(*da) == T_Lrgint) { /* iand(bignum,integer) */ + itobig(IntVal(*db), (struct b_bignum *)tdigits, &td); + alen = LEN(LrgInt(da)); + blen = LEN(LrgInt(&td)); + xlen = alen > blen ? alen : blen; + a = LrgInt(da); + b = LrgInt(&td); + Protect(x = alcbignum(alen), return Error); + + if (alen == xlen && !a->sign) + ad = DIG(a,0); + else { + Protect(tad = alcbignum(xlen), return Error); + ad = DIG(tad,0); + bdzero(ad, xlen - alen); + bdcopy(DIG(a,0), + &ad[xlen-alen], alen); + if (a->sign) + compl1(ad, ad, xlen); + } + + if (blen == xlen && !b->sign) + bd = DIG(b,0); + else { + Protect(tbd = alcbignum(xlen), return Error); + bd = DIG(tbd,0); + bdzero(bd, xlen - blen); + bdcopy(DIG(b,0), + &bd[xlen-blen], blen); + if (b->sign) + compl1(bd, bd, xlen); + } + + for (i = 0; i < xlen; i++) + *DIG(x,i) = + ad[i] & bd[i]; + + if (a->sign & b->sign) { + x->sign = 1; + compl1(DIG(x,0), + DIG(x,0), + xlen); + } + } + else if (Type(*db) == T_Lrgint) { /* iand(integer,bignum) */ + itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); + alen = LEN(LrgInt(&td)); + blen = LEN(LrgInt(db)); + xlen = alen > blen ? alen : blen; + a = LrgInt(&td); + b = LrgInt(db); + Protect(x = alcbignum(blen), return Error); + + if (alen == xlen && !a->sign) + ad = DIG(a,0); + else { + Protect(tad = alcbignum(xlen), return Error); + ad = DIG(tad,0); + bdzero(ad, xlen - alen); + bdcopy(DIG(a,0), + &ad[xlen-alen], alen); + if (a->sign) + compl1(ad, ad, xlen); + } + + if (blen == xlen && !b->sign) + bd = DIG(b,0); + else { + Protect(tbd = alcbignum(xlen), return Error); + bd = DIG(tbd,0); + bdzero(bd, xlen - blen); + bdcopy(DIG(b,0), + &bd[xlen-blen], blen); + if (b->sign) + compl1(bd, bd, xlen); + } + + for (i = 0; i < xlen; i++) + *DIG(x,i) = + ad[i] & bd[i]; + + if (a->sign & b->sign) { + x->sign = 1; + compl1(DIG(x,0), + DIG(x,0), + xlen); + } + } + /* not called for iand(integer,integer) */ + + return mkdesc(x, dx); +} + +/* + * ior(da, db) -> dx + */ + +int bigor(da, db, dx) +dptr da, db, dx; +{ + tended struct b_bignum *a, *b, *x, *tad, *tbd; + word alen, blen, xlen; + word i; + DIGIT *ad, *bd; + struct descrip td; + char tdigits[INTBIGBLK]; + + if (Type(*da) == T_Lrgint && Type(*db) == T_Lrgint) { + alen = LEN(LrgInt(da)); + blen = LEN(LrgInt(db)); + xlen = alen > blen ? alen : blen; + a = LrgInt(da); + b = LrgInt(db); + Protect(x = alcbignum(xlen), return Error); + + if (alen == xlen && !a->sign) + ad = DIG(a,0); + else { + Protect(tad = alcbignum(xlen), return Error); + ad = DIG(tad,0); + bdzero(ad, xlen - alen); + bdcopy(DIG(a,0), + &ad[xlen-alen], alen); + if (a->sign) + compl1(ad, ad, xlen); + } + + if (blen == xlen && !b->sign) + bd = DIG(b,0); + else { + Protect(tbd = alcbignum(xlen), return Error); + bd = DIG(tbd,0); + bdzero(bd, xlen - blen); + bdcopy(DIG(b,0), + &bd[xlen-blen], blen); + if (b->sign) + compl1(bd, bd, xlen); + } + + for (i = 0; i < xlen; i++) + *DIG(x,i) = + ad[i] | bd[i]; + + if (a->sign | b->sign) { + x->sign = 1; + compl1(DIG(x,0), + DIG(x,0), + xlen); + } + } + else if (Type(*da) == T_Lrgint) { /* ior(bignum,integer) */ + itobig(IntVal(*db), (struct b_bignum *)tdigits, &td); + alen = LEN(LrgInt(da)); + blen = LEN(LrgInt(&td)); + xlen = alen > blen ? alen : blen; + a = LrgInt(da); + b = LrgInt(&td); + Protect(x = alcbignum(alen), return Error); + + if (alen == xlen && !a->sign) + ad = DIG(a,0); + else { + Protect(tad = alcbignum(xlen), return Error); + ad = DIG(tad,0); + bdzero(ad, xlen - alen); + bdcopy(DIG(a,0), + &ad[xlen-alen], alen); + if (a->sign) + compl1(ad, ad, xlen); + } + + if (blen == xlen && !b->sign) + bd = DIG(b,0); + else { + Protect(tbd = alcbignum(xlen), return Error); + bd = DIG(tbd,0); + bdzero(bd, xlen - blen); + bdcopy(DIG(b,0), + &bd[xlen-blen], blen); + if (b->sign) + compl1(bd, bd, xlen); + } + + for (i = 0; i < xlen; i++) + *DIG(x,i) = + ad[i] | bd[i]; + + if (a->sign | b->sign) { + x->sign = 1; + compl1(DIG(x,0), + DIG(x,0), + xlen); + } + } + else if (Type(*db) == T_Lrgint) { /* ior(integer,bignym) */ + itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); + alen = LEN(LrgInt(&td)); + blen = LEN(LrgInt(db)); + xlen = alen > blen ? alen : blen; + a = LrgInt(&td); + b = LrgInt(db); + Protect(x = alcbignum(blen), return Error); + + if (alen == xlen && !a->sign) + ad = DIG(a,0); + else { + Protect(tad = alcbignum(xlen), return Error); + ad = DIG(tad,0); + bdzero(ad, xlen - alen); + bdcopy(DIG(a,0), + &ad[xlen-alen], alen); + if (a->sign) + compl1(ad, ad, xlen); + } + + if (blen == xlen && !b->sign) + bd = DIG(b,0); + else { + Protect(tbd = alcbignum(xlen), return Error); + bd = DIG(tbd,0); + bdzero(bd, xlen - blen); + bdcopy(DIG(b,0), + &bd[xlen-blen], blen); + if (b->sign) + compl1(bd, bd, xlen); + } + + for (i = 0; i < xlen; i++) + *DIG(x,i) = + ad[i] | bd[i]; + + if (a->sign | b->sign) { + x->sign = 1; + compl1(DIG(x,0), + DIG(x,0), + xlen); + } + } + /* not called for ior(integer,integer) */ + + return mkdesc(x, dx); +} + +/* + * xor(da, db) -> dx + */ + +int bigxor(da, db, dx) +dptr da, db, dx; +{ + tended struct b_bignum *a, *b, *x, *tad, *tbd; + word alen, blen, xlen; + word i; + DIGIT *ad, *bd; + struct descrip td; + char tdigits[INTBIGBLK]; + + if (Type(*da) == T_Lrgint && Type(*db) == T_Lrgint) { + alen = LEN(LrgInt(da)); + blen = LEN(LrgInt(db)); + xlen = alen > blen ? alen : blen; + a = LrgInt(da); + b = LrgInt(db); + Protect(x = alcbignum(xlen), return Error); + + if (alen == xlen && !a->sign) + ad = DIG(a,0); + else { + Protect(tad = alcbignum(xlen), return Error); + ad = DIG(tad,0); + bdzero(ad, xlen - alen); + bdcopy(DIG(a,0), + &ad[xlen-alen], alen); + if (a->sign) + compl1(ad, ad, xlen); + } + + if (blen == xlen && !b->sign) + bd = DIG(b,0); + else { + Protect(tbd = alcbignum(xlen), return Error); + bd = DIG(tbd,0); + bdzero(bd, xlen - blen); + bdcopy(DIG(b,0), + &bd[xlen-blen], blen); + if (b->sign) + compl1(bd, bd, xlen); + } + + for (i = 0; i < xlen; i++) + *DIG(x,i) = + ad[i] ^ bd[i]; + + if (a->sign ^ b->sign) { + x->sign = 1; + compl1(DIG(x,0), + DIG(x,0), + xlen); + } + } + else if (Type(*da) == T_Lrgint) { /* ixor(bignum,integer) */ + itobig(IntVal(*db), (struct b_bignum *)tdigits, &td); + alen = LEN(LrgInt(da)); + blen = LEN(LrgInt(&td)); + xlen = alen > blen ? alen : blen; + a = LrgInt(da); + b = LrgInt(&td); + Protect(x = alcbignum(alen), return Error); + + if (alen == xlen && !a->sign) + ad = DIG(a,0); + else { + Protect(tad = alcbignum(xlen), return Error); + ad = DIG(tad,0); + bdzero(ad, xlen - alen); + bdcopy(DIG(a,0), + &ad[xlen-alen], alen); + if (a->sign) + compl1(ad, ad, xlen); + } + + if (blen == xlen && !b->sign) + bd = DIG(b,0); + else { + Protect(tbd = alcbignum(xlen), return Error); + bd = DIG(tbd,0); + bdzero(bd, xlen - blen); + bdcopy(DIG(b,0), + &bd[xlen-blen], blen); + if (b->sign) + compl1(bd, bd, xlen); + } + + for (i = 0; i < xlen; i++) + *DIG(x,i) = + ad[i] ^ bd[i]; + + if (a->sign ^ b->sign) { + x->sign = 1; + compl1(DIG(x,0), + DIG(x,0), + xlen); + } + } + else if (Type(*db) == T_Lrgint) { /* ixor(integer,bignum) */ + itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); + alen = LEN(LrgInt(&td)); + blen = LEN(LrgInt(db)); + xlen = alen > blen ? alen : blen; + a = LrgInt(&td); + b = LrgInt(db); + Protect(x = alcbignum(blen), return Error); + + if (alen == xlen && !a->sign) + ad = DIG(a,0); + else { + Protect(tad = alcbignum(xlen), return Error); + ad = DIG(tad,0); + bdzero(ad, xlen - alen); + bdcopy(DIG(a,0), + &ad[xlen-alen], alen); + if (a->sign) + compl1(ad, ad, xlen); + } + + if (blen == xlen && !b->sign) + bd = DIG(b,0); + else { + Protect(tbd = alcbignum(xlen), return Error); + bd = DIG(tbd,0); + bdzero(bd, xlen - blen); + bdcopy(DIG(b,0), + &bd[xlen-blen], blen); + if (b->sign) + compl1(bd, bd, xlen); + } + + for (i = 0; i < xlen; i++) + *DIG(x,i) = + ad[i] ^ bd[i]; + + if (a->sign ^ b->sign) { + x->sign = 1; + compl1(DIG(x,0), + DIG(x,0), + xlen); + } + } + /* not called for ixor(integer,integer) */ + + return mkdesc(x, dx); +} + +/* + * bigshift(da, db) -> dx + */ + +int bigshift(da, db, dx) +dptr da, db, dx; +{ + tended struct b_bignum *a, *x, *tad; + word alen; + word r = IntVal(*db) % NB; + word q = (r >= 0 ? IntVal(*db) : (IntVal(*db) - (r += NB))) / NB; + word xlen; + DIGIT *ad; + struct descrip td; + char tdigits[INTBIGBLK]; + + if (Type(*da) == T_Integer) { + itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); + da = &td; + } + + alen = LEN(LrgInt(da)); + xlen = alen + q + 1; + if (xlen <= 0) { + MakeInt(-LrgInt(da)->sign, dx); + return Succeeded; + } + else { + a = LrgInt(da); + Protect(x = alcbignum(xlen), return Error); + + if (a->sign) { + Protect(tad = alcbignum(alen), return Error); + ad = DIG(tad,0); + bdcopy(DIG(a,0), + ad, alen); + compl1(ad, ad, alen); + } + else + ad = DIG(a,0); + + if (q >= 0) { + *DIG(x,0) = + shifti1(ad, r, (DIGIT)0, + DIG(x,1), + alen); + bdzero(DIG(x,alen+1), + q); + } + else + *DIG(x,0) = + shifti1(ad, r, ad[alen+q] >> (NB-r), + DIG(x,1), alen+q); + + if (a->sign) { + x->sign = 1; + *DIG(x,0) |= + B - (1 << r); + compl1(DIG(x,0), + DIG(x,0), + xlen); + } + return mkdesc(x, dx); + } + } + +/* + * negative if da < db + * zero if da == db + * positive if da > db + */ + +word bigcmp(da, db) +dptr da, db; +{ + struct b_bignum *a = LrgInt(da); + struct b_bignum *b = LrgInt(db); + word alen, blen; + + if (Type(*da) == T_Lrgint && Type(*db) == T_Lrgint) { + if (a->sign != b->sign) + return (b->sign - a->sign); + alen = LEN(a); + blen = LEN(b); + if (alen != blen) + return (a->sign ? blen - alen : alen - blen); + + if (a->sign) + return cmp1(DIG(b,0), + DIG(a,0), + alen); + else + return cmp1(DIG(a,0), + DIG(b,0), + alen); + } + else if (Type(*da) == T_Lrgint) /* cmp(bignum, integer) */ + return bigcmpi(da, IntVal(*db)); + else /* cmp(integer, bignum) */ + return -bigcmpi(db, IntVal(*da)); +} + +/* + * ?da -> dx + */ + +int bigrand(da, dx) +dptr da, dx; +{ + tended struct b_bignum *x, *a, *td, *tu, *tv; + word alen = LEN(LrgInt(da)); + DIGIT *d; + word i; + double rval; + + Protect(x = alcbignum(alen), return Error); + Protect(td = alcbignum(alen + 1), return Error); + d = DIG(td,0); + a = LrgInt(da); + + for (i = alen; i >= 0; i--) { + rval = RandVal; + d[i] = rval * B; + } + + Protect(tu = alcbignum(alen + 2), return Error); + Protect(tv = alcbignum(alen), return Error); + if (div1(d, DIG(a,0), + NULL, + DIG(x,0), + (word)1, alen, tu, tv) == Error) + return Error; + addi1(DIG(x,0), + (word)1, + DIG(x,0), + alen); + return mkdesc(x, dx); +} + +/* + * da + i -> dx + */ + +static int bigaddi(da, i, dx) +dptr da, dx; +word i; +{ + tended struct b_bignum *a; + struct b_bignum *x; + word alen; + + if (i < 0 && i > MinLong) + return bigsubi(da, -i, dx); + else if (i < 0 || i >= B ) { + struct descrip td; + char tdigits[INTBIGBLK]; + + itobig(i, (struct b_bignum *)tdigits, &td); + return bigadd(da, &td, dx); + } + else { + alen = LEN(LrgInt(da)); + a = LrgInt(da); + if (a->sign) { + Protect(x = alcbignum(alen), return Error); + subi1(DIG(a,0), + i, + DIG(x,0), + alen); + } + else { + Protect(x = alcbignum(alen + 1), return Error); + *DIG(x,0) = + addi1(DIG(a,0), + i, + DIG(x,1), + alen); + } + x->sign = a->sign; + return mkdesc(x, dx); + } +} + +/* + * da - i -> dx + */ + +static int bigsubi(da, i, dx) +dptr da, dx; +word i; +{ + tended struct b_bignum *a; + struct b_bignum *x; + word alen; + + if (i < 0 && i > MinLong) + return bigaddi(da, -i, dx); + else if (i < 0 || i >= B) { + struct descrip td; + char tdigits[INTBIGBLK]; + + itobig(i, (struct b_bignum *)tdigits, &td); + return bigsub(da, &td, dx); + } + else { + alen = LEN(LrgInt(da)); + a = LrgInt(da); + if (a->sign) { + Protect(x = alcbignum(alen + 1), return Error); + *DIG(x,0) = + addi1(DIG(a,0), + i, + DIG(x,1), + alen); + } + else { + Protect(x = alcbignum(alen), return Error); + subi1(DIG(a,0), + i, + DIG(x,0), + alen); + } + x->sign = a->sign; + return mkdesc(x, dx); + } +} + +/* + * da * i -> dx + */ + +static int bigmuli(da, i, dx) +dptr da, dx; +word i; +{ + tended struct b_bignum *a; + struct b_bignum *x; + word alen; + + if (i <= -B || i >= B) { + struct descrip td; + char tdigits[INTBIGBLK]; + + itobig(i, (struct b_bignum *)tdigits, &td); + return bigmul(da, &td, dx); + } + else { + alen = LEN(LrgInt(da)); + a = LrgInt(da); + Protect(x = alcbignum(alen + 1), return Error); + if (i >= 0) + x->sign = a->sign; + else { + x->sign = 1 ^ a->sign; + i = -i; + } + *DIG(x,0) = + muli1(DIG(a,0), + i, 0, + DIG(x,1), + alen); + return mkdesc(x, dx); + } +} + +/* + * da / i -> dx + */ + +static int bigdivi(da, i, dx) +dptr da, dx; +word i; +{ + tended struct b_bignum *a; + struct b_bignum *x; + word alen; + + if (i <= -B || i >= B) { + struct descrip td; + char tdigits[INTBIGBLK]; + + itobig(i, (struct b_bignum *)tdigits, &td); + return bigdiv(da, &td, dx); + } + else { + alen = LEN(LrgInt(da)); + a = LrgInt(da); + Protect(x = alcbignum(alen), return Error); + if (i >= 0) + x->sign = a->sign; + else { + x->sign = 1 ^ a->sign; + i = -i; + } + divi1(DIG(a,0), + i, + DIG(x,0), + alen); + return mkdesc(x, dx); + } +} + +/* + * da % i -> dx + */ + +static int bigmodi(da, i, dx) +dptr da, dx; +word i; +{ + tended struct b_bignum *a, *temp; + word alen; + word x; + + if (i <= -B || i >= B) { + struct descrip td; + char tdigits[INTBIGBLK]; + + itobig(i, (struct b_bignum *)tdigits, &td); + return bigmod(da, &td, dx); + } + else { + alen = LEN(LrgInt(da)); + a = LrgInt(da); + temp = a; /* avoid trash pointer */ + Protect(temp = alcbignum(alen), return Error); + x = divi1(DIG(a,0), + Abs(i), + DIG(temp,0), + alen); + if (a->sign) + x = -x; + MakeInt(x, dx); + return Succeeded; + } +} + +/* + * da ^ i -> dx + */ + +static int bigpowi(da, i, dx) +dptr da, dx; +word i; +{ + int n = WordBits; + + if (i > 0) { + /* scan bits left to right. skip leading 1. */ + while (--n >= 0) + if (i & ((word)1 << n)) + break; + /* then, for each zero, square the partial result; + for each one, square it and multiply it by a */ + *dx = *da; + while (--n >= 0) { + if (bigmul(dx, dx, dx) == Error) + return Error; + if (i & ((word)1 << n)) + if (bigmul(dx, da, dx) == Error) + return Error; + } + } + else if (i == 0) { + MakeInt(1, dx); + } + else { + MakeInt(0, dx); + } + return Succeeded; +} + +/* + * a ^ i -> dx + */ + +static int bigpowii(a, i, dx) +word a, i; +dptr dx; +{ + word x, y; + int n = WordBits; + int isbig = 0; + + if (a == 0 || i <= 0) { /* special cases */ + if (a == 0 && i <= 0) /* 0 ^ negative -> error */ + ReturnErrNum(204,Error); + if (i == 0) { + MakeInt(1, dx); + return Succeeded; + } + if (a == -1) { /* -1 ^ [odd,even] -> [-1,+1] */ + if (!(i & 1)) + a = 1; + } + else if (a != 1) { /* 1 ^ any -> 1 */ + a = 0; + } /* others ^ negative -> 0 */ + MakeInt(a, dx); + } + else { + struct descrip td; + char tdigits[INTBIGBLK]; + + /* scan bits left to right. skip leading 1. */ + while (--n >= 0) + if (i & ((word)1 << n)) + break; + /* then, for each zero, square the partial result; + for each one, square it and multiply it by a */ + x = a; + while (--n >= 0) { + if (isbig) { + if (bigmul(dx, dx, dx) == Error) + return Error; + } + else { + y = mul(x, x); + if (!over_flow) + x = y; + else { + itobig(x, (struct b_bignum *)tdigits, &td); + if (bigmul(&td, &td, dx) == Error) + return Error; + isbig = (Type(*dx) == T_Lrgint); + } + } + if (i & ((word)1 << n)) { + if (isbig) { + if (bigmuli(dx, a, dx) == Error) + return Error; + } + else { + y = mul(x, a); + if (!over_flow) + x = y; + else { + itobig(x, (struct b_bignum *)tdigits, &td); + if (bigmuli(&td, a, dx) == Error) + return Error; + isbig = (Type(*dx) == T_Lrgint); + } + } + } + } + if (!isbig) { + MakeInt(x, dx); + } + } + return Succeeded; +} + +/* + * negative if da < i + * zero if da == i + * positive if da > i + */ + +static word bigcmpi(da, i) +dptr da; +word i; +{ + struct b_bignum *a = LrgInt(da); + word alen = LEN(a); + + if (i > -B && i < B) { + if (i >= 0) + if (a->sign) + return -1; + else + return cmpi1(DIG(a,0), + i, alen); + else + if (a->sign) + return -cmpi1(DIG(a,0), + -i, alen); + else + return 1; + } + else { + struct descrip td; + char tdigits[INTBIGBLK]; + + itobig(i, (struct b_bignum *)tdigits, &td); + return bigcmp(da, &td); + } +} + + +/* These are all straight out of Knuth vol. 2, Sec. 4.3.1. */ + +/* + * (u,n) + (v,n) -> (w,n) + * + * returns carry, 0 or 1 + */ + +static DIGIT add1(u, v, w, n) +DIGIT *u, *v, *w; +word n; +{ + uword dig, carry; + word i; + + carry = 0; + for (i = n; --i >= 0; ) { + dig = (uword)u[i] + v[i] + carry; + w[i] = lo(dig); + carry = hi(dig); + } + return carry; +} + +/* + * (u,n) - (v,n) -> (w,n) + * + * returns carry, 0 or -1 + */ + +static word sub1(u, v, w, n) +DIGIT *u, *v, *w; +word n; +{ + uword dig, carry; + word i; + + carry = 0; + for (i = n; --i >= 0; ) { + dig = (uword)u[i] - v[i] + carry; + w[i] = lo(dig); + carry = signed_hi(dig); + } + return carry; +} + +/* + * (u,n) * (v,m) -> (w,m+n) + */ + +static void mul1(u, v, w, n, m) +DIGIT *u, *v, *w; +word n, m; +{ + word i, j; + uword dig, carry; + + bdzero(&w[m], n); + + for (j = m; --j >= 0; ) { + carry = 0; + for (i = n; --i >= 0; ) { + dig = (uword)u[i] * v[j] + w[i+j+1] + carry; + w[i+j+1] = lo(dig); + carry = hi(dig); + } + w[j] = carry; + } +} + +/* + * (a,m+n) / (b,n) -> (q,m+1) (r,n) + * + * if q or r is NULL, the quotient or remainder is discarded + */ + +static int div1(a, b, q, r, m, n, tu, tv) +DIGIT *a, *b, *q, *r; +word m, n; +struct b_bignum *tu, *tv; +{ + uword qhat, rhat; + uword dig, carry; + DIGIT *u, *v; + word d; + word i, j; + + u = DIG(tu,0); + v = DIG(tv,0); + + /* D1 */ + for (d = 0; d < NB; d++) + if (b[0] & (1 << (NB - 1 - d))) + break; + + u[0] = shifti1(a, d, (DIGIT)0, &u[1], m+n); + shifti1(b, d, (DIGIT)0, v, n); + + /* D2, D7 */ + for (j = 0; j <= m; j++) { + /* D3 */ + if (u[j] == v[0]) { + qhat = B - 1; + rhat = (uword)v[0] + u[j+1]; + } + else { + uword numerator = dbl(u[j], u[j+1]); + qhat = numerator / (uword)v[0]; + rhat = numerator % (uword)v[0]; + } + + while (rhat < (uword)B && qhat * (uword)v[1] > (uword)dbl(rhat, u[j+2])) { + qhat -= 1; + rhat += v[0]; + } + + /* D4 */ + carry = 0; + for (i = n; i > 0; i--) { + dig = u[i+j] - v[i-1] * qhat + carry; /* -BSQ+B .. B-1 */ + u[i+j] = lo(dig); + if ((uword)dig < (uword)B) + carry = hi(dig); + else carry = hi(dig) | -B; + } + carry = (word)(carry + u[j]) < 0; + + /* D5 */ + if (q) + q[j] = qhat; + + /* D6 */ + if (carry) { + if (q) + q[j] -= 1; + carry = 0; + for (i = n; i > 0; i--) { + dig = (uword)u[i+j] + v[i-1] + carry; + u[i+j] = lo(dig); + carry = hi(dig); + } + } + } + + if (r) { + if (d == 0) + shifti1(&u[m+1], (word)d, (DIGIT)0, r, n); + else + r[0] = shifti1(&u[m+1], (word)(NB - d), u[m+n]>>d, &r[1], n - 1); + } + return Succeeded; +} + +/* + * - (u,n) -> (w,n) + * + */ + +static void compl1(u, w, n) +DIGIT *u, *w; +word n; +{ + uword dig, carry = 0; + word i; + + for (i = n; --i >= 0; ) { + dig = carry - u[i]; + w[i] = lo(dig); + carry = signed_hi(dig); + } +} + +/* + * (u,n) : (v,n) + */ + +static word cmp1(u, v, n) +DIGIT *u, *v; +word n; +{ + word i; + + for (i = 0; i < n; i++) + if (u[i] != v[i]) + return u[i] > v[i] ? 1 : -1; + return 0; +} + +/* + * (u,n) + k -> (w,n) + * + * k in 0 .. B-1 + * returns carry, 0 or 1 + */ + +static DIGIT addi1(u, k, w, n) +DIGIT *u, *w; +word k; +word n; +{ + uword dig, carry; + word i; + + carry = k; + for (i = n; --i >= 0; ) { + dig = (uword)u[i] + carry; + w[i] = lo(dig); + carry = hi(dig); + } + return carry; +} + +/* + * (u,n) - k -> (w,n) + * + * k in 0 .. B-1 + * u must be greater than k + */ + +static void subi1(u, k, w, n) +DIGIT *u, *w; +word k; +word n; +{ + uword dig, carry; + word i; + + carry = -k; + for (i = n; --i >= 0; ) { + dig = (uword)u[i] + carry; + w[i] = lo(dig); + carry = signed_hi(dig); + } +} + +/* + * (u,n) * k + c -> (w,n) + * + * k in 0 .. B-1 + * returns carry, 0 .. B-1 + */ + +static DIGIT muli1(u, k, c, w, n) +DIGIT *u, *w; +word k; +int c; +word n; +{ + uword dig, carry; + word i; + + carry = c; + for (i = n; --i >= 0; ) { + dig = (uword)k * u[i] + carry; + w[i] = lo(dig); + carry = hi(dig); + } + return carry; +} + +/* + * (u,n) / k -> (w,n) + * + * k in 0 .. B-1 + * returns remainder, 0 .. B-1 + */ + +static DIGIT divi1(u, k, w, n) +DIGIT *u, *w; +word k; +word n; +{ + uword dig, remain; + word i; + + remain = 0; + for (i = 0; i < n; i++) { + dig = dbl(remain, u[i]); + w[i] = dig / k; + remain = dig % k; + } + return remain; +} + +/* + * ((u,n) << k) + c -> (w,n) + * + * k in 0 .. NB-1 + * c in 0 .. B-1 + * returns carry, 0 .. B-1 + */ + +static DIGIT shifti1(u, k, c, w, n) +DIGIT *u, c, *w; +word k; +word n; +{ + uword dig; + word i; + + if (k == 0) { + bdcopy(u, w, n); + return 0; + } + + for (i = n; --i >= 0; ) { + dig = ((uword)u[i] << k) + c; + w[i] = lo(dig); + c = hi(dig); + } + return c; +} + +/* + * (u,n) : k + * + * k in 0 .. B-1 + */ + +static word cmpi1(u, k, n) +DIGIT *u; +word k; +word n; +{ + word i; + + for (i = 0; i < n-1; i++) + if (u[i]) + return 1; + if (u[n - 1] == (DIGIT)k) + return 0; + return u[n - 1] > (DIGIT)k ? 1 : -1; +} + +#endif /* LargeInts */ diff --git a/src/runtime/rmemmgt.r b/src/runtime/rmemmgt.r new file mode 100644 index 0000000..4a9daa2 --- /dev/null +++ b/src/runtime/rmemmgt.r @@ -0,0 +1,1459 @@ +/* + * File: rmemmgt.r + * Contents: block description arrays, memory initialization, + * garbage collection, dump routines + */ + +/* + * Prototypes + */ +static void postqual (dptr dp); +static void markblock (dptr dp); +static void markptr (union block **ptr); +static void sweep (struct b_coexpr *ce); +static void sweep_stk (struct b_coexpr *ce); +static void reclaim (void); +static void cofree (void); +static void scollect (word extra); +static int qlcmp (dptr *q1,dptr *q2); +static void adjust (char *source, char *dest); +static void compact (char *source); +static void mvc (uword n, char *src, char *dest); + +#ifdef MultiThread +static void markprogram (struct progstate *pstate); +#endif /*MultiThread*/ + +/* + * Variables + */ + +#ifndef MultiThread +word coll_stat = 0; /* collections in static region */ +word coll_str = 0; /* collections in string region */ +word coll_blk = 0; /* collections in block region */ +word coll_tot = 0; /* total collections */ +#endif /* MultiThread */ +word alcnum = 0; /* co-expressions allocated since g.c. */ + +dptr *quallist; /* string qualifier list */ +dptr *qualfree; /* qualifier list free pointer */ +dptr *equallist; /* end of qualifier list */ + +int qualfail; /* flag: qualifier list overflow */ + +/* + * Allocated block size table (sizes given in bytes). A size of -1 is used + * for types that have no blocks; a size of 0 indicates that the + * second word of the block contains the size; a value greater than + * 0 is used for types with constant sized blocks. + */ + +int bsizes[] = { + -1, /* T_Null (0), not block */ + -1, /* T_Integer (1), not block */ + 0, /* T_Lrgint (2), large integer */ + sizeof(struct b_real), /* T_Real (3), real number */ + sizeof(struct b_cset), /* T_Cset (4), cset */ + sizeof(struct b_file), /* T_File (5), file block */ + 0, /* T_Proc (6), procedure block */ + 0, /* T_Record (7), record block */ + sizeof(struct b_list), /* T_List (8), list header block */ + 0, /* T_Lelem (9), list element block */ + sizeof(struct b_set), /* T_Set (10), set header block */ + sizeof(struct b_selem), /* T_Selem (11), set element block */ + sizeof(struct b_table), /* T_Table (12), table header block */ + sizeof(struct b_telem), /* T_Telem (13), table element block */ + sizeof(struct b_tvtbl), /* T_Tvtbl (14), table element trapped variable */ + 0, /* T_Slots (15), set/table hash block */ + sizeof(struct b_tvsubs), /* T_Tvsubs (16), substring trapped variable */ + 0, /* T_Refresh (17), refresh block */ + -1, /* T_Coexpr (18), co-expression block */ + 0, /* T_External (19) external block */ + -1, /* T_Kywdint (20), integer keyword variable */ + -1, /* T_Kywdpos (21), keyword &pos */ + -1, /* T_Kywdsubj (22), keyword &subject */ + -1, /* T_Kywdwin (23), keyword &window */ + -1, /* T_Kywdstr (24), string keyword variable */ + -1, /* T_Kywdevent (25), event keyword variable */ + }; + +/* + * Table of offsets (in bytes) to first descriptor in blocks. -1 is for + * types not allocated, 0 for blocks with no descriptors. + */ +int firstd[] = { + -1, /* T_Null (0), not block */ + -1, /* T_Integer (1), not block */ + 0, /* T_Lrgint (2), large integer */ + 0, /* T_Real (3), real number */ + 0, /* T_Cset (4), cset */ + 3*WordSize, /* T_File (5), file block */ + +#ifdef MultiThread + 8*WordSize, /* T_Proc (6), procedure block */ +#else /* MultiThread */ + 7*WordSize, /* T_Proc (6), procedure block */ +#endif /* MultiThread */ + + 4*WordSize, /* T_Record (7), record block */ + 0, /* T_List (8), list header block */ + 7*WordSize, /* T_Lelem (9), list element block */ + 0, /* T_Set (10), set header block */ + 3*WordSize, /* T_Selem (11), set element block */ + (4+HSegs)*WordSize, /* T_Table (12), table header block */ + 3*WordSize, /* T_Telem (13), table element block */ + 3*WordSize, /* T_Tvtbl (14), table element trapped variable */ + 0, /* T_Slots (15), set/table hash block */ + 3*WordSize, /* T_Tvsubs (16), substring trapped variable */ + +#if COMPILER + 2*WordSize, /* T_Refresh (17), refresh block */ +#else /* COMPILER */ + (4+Wsizeof(struct pf_marker))*WordSize, /* T_Refresh (17), refresh block */ +#endif /* COMPILER */ + + -1, /* T_Coexpr (18), co-expression block */ + 0, /* T_External (19), external block */ + -1, /* T_Kywdint (20), integer keyword variable */ + -1, /* T_Kywdpos (21), keyword &pos */ + -1, /* T_Kywdsubj (22), keyword &subject */ + -1, /* T_Kywdwin (23), keyword &window */ + -1, /* T_Kywdstr (24), string keyword variable */ + -1, /* T_Kywdevent (25), event keyword variable */ + }; + +/* + * Table of offsets (in bytes) to first pointer in blocks. -1 is for + * types not allocated, 0 for blocks with no pointers. + */ +int firstp[] = { + -1, /* T_Null (0), not block */ + -1, /* T_Integer (1), not block */ + 0, /* T_Lrgint (2), large integer */ + 0, /* T_Real (3), real number */ + 0, /* T_Cset (4), cset */ + 0, /* T_File (5), file block */ + 0, /* T_Proc (6), procedure block */ + 3*WordSize, /* T_Record (7), record block */ + 3*WordSize, /* T_List (8), list header block */ + 2*WordSize, /* T_Lelem (9), list element block */ + 4*WordSize, /* T_Set (10), set header block */ + 1*WordSize, /* T_Selem (11), set element block */ + 4*WordSize, /* T_Table (12), table header block */ + 1*WordSize, /* T_Telem (13), table element block */ + 1*WordSize, /* T_Tvtbl (14), table element trapped variable */ + 2*WordSize, /* T_Slots (15), set/table hash block */ + 0, /* T_Tvsubs (16), substring trapped variable */ + 0, /* T_Refresh (17), refresh block */ + -1, /* T_Coexpr (18), co-expression block */ + 0, /* T_External (19), external block */ + -1, /* T_Kywdint (20), integer keyword variable */ + -1, /* T_Kywdpos (21), keyword &pos */ + -1, /* T_Kywdsubj (22), keyword &subject */ + -1, /* T_Kywdwin (23), keyword &window */ + -1, /* T_Kywdstr (24), string keyword variable */ + -1, /* T_Kywdevent (25), event keyword variable */ + }; + +/* + * Table of number of pointers in blocks. -1 is for types not allocated and + * types without pointers, 0 for pointers through the end of the block. + */ +int ptrno[] = { + -1, /* T_Null (0), not block */ + -1, /* T_Integer (1), not block */ + -1, /* T_Lrgint (2), large integer */ + -1, /* T_Real (3), real number */ + -1, /* T_Cset (4), cset */ + -1, /* T_File (5), file block */ + -1, /* T_Proc (6), procedure block */ + 1, /* T_Record (7), record block */ + 2, /* T_List (8), list header block */ + 2, /* T_Lelem (9), list element block */ + HSegs, /* T_Set (10), set header block */ + 1, /* T_Selem (11), set element block */ + HSegs, /* T_Table (12), table header block */ + 1, /* T_Telem (13), table element block */ + 1, /* T_Tvtbl (14), table element trapped variable */ + 0, /* T_Slots (15), set/table hash block */ + -1, /* T_Tvsubs (16), substring trapped variable */ + -1, /* T_Refresh (17), refresh block */ + -1, /* T_Coexpr (18), co-expression block */ + -1, /* T_External (19), external block */ + -1, /* T_Kywdint (20), integer keyword variable */ + -1, /* T_Kywdpos (21), keyword &pos */ + -1, /* T_Kywdsubj (22), keyword &subject */ + -1, /* T_Kywdwin (23), keyword &window */ + -1, /* T_Kywdstr (24), string keyword variable */ + -1, /* T_Kywdevent (25), event keyword variable */ + }; + +/* + * Table of block names used by debugging functions. + */ +char *blkname[] = { + "illegal object", /* T_Null (0), not block */ + "illegal object", /* T_Integer (1), not block */ + "large integer", /* T_Largint (2) */ + "real number", /* T_Real (3) */ + "cset", /* T_Cset (4) */ + "file", /* T_File (5) */ + "procedure", /* T_Proc (6) */ + "record", /* T_Record (7) */ + "list", /* T_List (8) */ + "list element", /* T_Lelem (9) */ + "set", /* T_Set (10) */ + "set element", /* T_Selem (11) */ + "table", /* T_Table (12) */ + "table element", /* T_Telem (13) */ + "table element trapped variable", /* T_Tvtbl (14) */ + "hash block", /* T_Slots (15) */ + "substring trapped variable", /* T_Tvsubs (16) */ + "refresh block", /* T_Refresh (17) */ + "co-expression", /* T_Coexpr (18) */ + "external block", /* T_External (19) */ + "integer keyword variable", /* T_Kywdint (20) */ + "&pos", /* T_Kywdpos (21) */ + "&subject", /* T_Kywdsubj (22) */ + "illegal object", /* T_Kywdwin (23) */ + "illegal object", /* T_Kywdstr (24) */ + "illegal object", /* T_Kywdevent (25) */ + }; + +/* + * Sizes of hash chain segments. + * Table size must equal or exceed HSegs. + */ +uword segsize[] = { + ((uword)HSlots), /* segment 0 */ + ((uword)HSlots), /* segment 1 */ + ((uword)HSlots) << 1, /* segment 2 */ + ((uword)HSlots) << 2, /* segment 3 */ + ((uword)HSlots) << 3, /* segment 4 */ + ((uword)HSlots) << 4, /* segment 5 */ + ((uword)HSlots) << 5, /* segment 6 */ + ((uword)HSlots) << 6, /* segment 7 */ + ((uword)HSlots) << 7, /* segment 8 */ + ((uword)HSlots) << 8, /* segment 9 */ + ((uword)HSlots) << 9, /* segment 10 */ + ((uword)HSlots) << 10, /* segment 11 */ + ((uword)HSlots) << 11, /* segment 12 */ + ((uword)HSlots) << 12, /* segment 13 */ + ((uword)HSlots) << 13, /* segment 14 */ + ((uword)HSlots) << 14, /* segment 15 */ + ((uword)HSlots) << 15, /* segment 16 */ + ((uword)HSlots) << 16, /* segment 17 */ + ((uword)HSlots) << 17, /* segment 18 */ + ((uword)HSlots) << 18, /* segment 19 */ + }; + +/* + * initalloc - initialization routine to allocate memory regions + */ + +#if COMPILER +void initalloc() + { + +#else /* COMPILER */ +#ifdef MultiThread +void initalloc(codesize,p) +struct progstate *p; +#else /* MultiThread */ +void initalloc(codesize) +#endif /* MultiThread */ +word codesize; + { +#ifdef MultiThread + struct region *ps, *pb; +#endif + + if ((uword)codesize > (unsigned)MaxBlock) + error(NULL, "icode file too large"); + /* + * Allocate icode region + */ +#ifdef MultiThread + if (codesize) +#endif /* MultiThread */ + if ((code = (char *)AllocReg(codesize)) == NULL) + error(NULL, + "insufficient memory, corrupted icode file, or wrong platform"); +#endif /* COMPILER */ + + /* + * Set up allocated memory. The regions are: + * Static memory region (not used) + * Allocated string region + * Allocate block region + * Qualifier list + */ + +#ifdef MultiThread + ps = p->stringregion; + ps->free = ps->base = (char *)AllocReg(ps->size); + if (ps->free == NULL) + error(NULL, "insufficient memory for string region"); + ps->end = ps->base + ps->size; + + pb = p->blockregion; + pb->free = pb->base = (char *)AllocReg(pb->size); + if (pb->free == NULL) + error(NULL, "insufficient memory for block region"); + pb->end = pb->base + pb->size; + + if (p == &rootpstate) { + if ((quallist = (dptr *)malloc(qualsize)) == NULL) + error(NULL, "insufficient memory for qualifier list"); + equallist = (dptr *)((char *)quallist + qualsize); + } +#else /* MultiThread */ + { + uword t1, t2; + t1 = ssize; + t2 = abrsize; + curstring = (struct region *)malloc(sizeof(struct region)); + curblock = (struct region *)malloc(sizeof(struct region)); + curstring->size = t1; + curblock->size = t2; + } + curstring->next = curstring->prev = NULL; + curstring->Gnext = curstring->Gprev = NULL; + curblock->next = curblock->prev = NULL; + curblock->Gnext = curblock->Gprev = NULL; + if ((strfree = strbase = (char *)AllocReg(ssize)) == NULL) + error(NULL, "insufficient memory for string region"); + strend = strbase + ssize; + if ((blkfree = blkbase = (char *)AllocReg(abrsize)) == NULL) + error(NULL, "insufficient memory for block region"); + blkend = blkbase + abrsize; + if ((quallist = (dptr *)malloc(qualsize)) == NULL) + error(NULL, "insufficient memory for qualifier list"); + equallist = (dptr *)((char *)quallist + qualsize); +#endif /* MultiThread */ + } + +/* + * collect - do a garbage collection of currently active regions. + */ + +int collect(region) +int region; + { + struct b_coexpr *cp; + +#ifdef EventMon + if (!noMTevents) + EVVal((word)region,E_Collect); +#endif /* EventMon */ + + switch (region) { + case Static: + coll_stat++; + break; + case Strings: + coll_str++; + break; + case Blocks: + coll_blk++; + break; + } + coll_tot++; + + alcnum = 0; + + /* + * Garbage collection cannot be done until initialization is complete. + */ + +#if !COMPILER + if (sp == NULL) + return 0; +#endif /* !COMPILER */ + + /* + * Sync the values (used by sweep) in the coexpr block for ¤t + * with the current values. + */ + cp = (struct b_coexpr *)BlkLoc(k_current); + cp->es_tend = tend; + +#if !COMPILER + cp->es_pfp = pfp; + cp->es_gfp = gfp; + cp->es_efp = efp; + cp->es_sp = sp; +#endif /* !COMPILER */ + + /* + * Reset qualifier list. + */ + qualfree = quallist; + qualfail = 0; + + /* + * Mark the stacks for &main and the current co-expression. + */ +#ifdef MultiThread + markprogram(&rootpstate); +#endif /* MultiThread */ + markblock(&k_main); + markblock(&k_current); + /* + * Mark &subject and the cached s2 and s3 strings for map. + */ +#ifndef MultiThread + postqual(&k_subject); + postqual(&kywd_prog); +#endif /* MultiThread */ + if (Qual(maps2)) /* caution: the cached arguments of */ + postqual(&maps2); /* map may not be strings. */ + else if (Pointer(maps2)) + markblock(&maps2); + if (Qual(maps3)) + postqual(&maps3); + else if (Pointer(maps3)) + markblock(&maps3); + +#ifdef Graphics + /* + * Mark file and list values for windows + */ + { + wsp ws; + + for (ws = wstates; ws ; ws = ws->next) { + if (is:file(ws->filep)) + markblock(&(ws->filep)); + if (is:list(ws->listp)) + markblock(&(ws->listp)); + } + } +#endif /* Graphics */ + + /* + * Mark the globals and the statics. + */ + +#ifndef MultiThread + { register struct descrip *dp; + for (dp = globals; dp < eglobals; dp++) + if (Qual(*dp)) + postqual(dp); + else if (Pointer(*dp)) + markblock(dp); + + for (dp = statics; dp < estatics; dp++) + if (Qual(*dp)) + postqual(dp); + else if (Pointer(*dp)) + markblock(dp); + } + +#ifdef Graphics + if (is:file(kywd_xwin[XKey_Window])) + markblock(&(kywd_xwin[XKey_Window])); + if (is:file(lastEventWin)) + markblock(&(lastEventWin)); +#endif /* Graphics */ +#endif /* MultiThread */ + + reclaim(); + + /* + * Turn off all the marks in all the block regions everywhere + */ + { struct region *br; + for (br = curblock->Gnext; br; br = br->Gnext) { + char *source = br->base, *free = br->free; + uword NoMark = (uword) ~F_Mark; + while (source < free) { + BlkType(source) &= NoMark; + source += BlkSize(source); + } + } + for (br = curblock->Gprev; br; br = br->Gprev) { + char *source = br->base, *free = br->free; + uword NoMark = (uword) ~F_Mark; + while (source < free) { + BlkType(source) &= NoMark; + source += BlkSize(source); + } + } + } + +#ifdef EventMon + if (!noMTevents) { + mmrefresh(); + EVValD(&nulldesc, E_EndCollect); + } +#endif /* EventMon */ + + return 1; + } + +/* + * markprogram - traverse pointers out of a program state structure + */ + +#ifdef MultiThread +#define PostDescrip(d) \ + if (Qual(d)) \ + postqual(&(d)); \ + else if (Pointer(d))\ + markblock(&(d)); + +static void markprogram(pstate) +struct progstate *pstate; + { + struct descrip *dp; + + PostDescrip(pstate->parentdesc); + PostDescrip(pstate->eventmask); + PostDescrip(pstate->opcodemask); + PostDescrip(pstate->eventcode); + PostDescrip(pstate->eventval); + PostDescrip(pstate->eventsource); + + /* Kywd_err, &error, always an integer */ + /* Kywd_pos, &pos, always an integer */ + postqual(&(pstate->ksub)); + postqual(&(pstate->Kywd_prog)); + /* Kywd_ran, &random, always an integer */ + /* Kywd_trc, &trace, always an integer */ + + /* + * Mark the globals and the statics. + */ + for (dp = pstate->Globals; dp < pstate->Eglobals; dp++) + if (Qual(*dp)) + postqual(dp); + else if (Pointer(*dp)) + markblock(dp); + + for (dp = pstate->Statics; dp < pstate->Estatics; dp++) + if (Qual(*dp)) + postqual(dp); + else if (Pointer(*dp)) + markblock(dp); + + /* + * no marking for &x, &y, &row, &col, &interval, all integers + */ +#ifdef Graphics + PostDescrip(pstate->LastEventWin); /* last Event() win */ + PostDescrip(pstate->Kywd_xwin[XKey_Window]); /* &window */ +#endif /* Graphics */ + + PostDescrip(pstate->K_errorvalue); + PostDescrip(pstate->T_errorvalue); + } +#endif /* MultiThread */ + +/* + * postqual - mark a string qualifier. Strings outside the string space + * are ignored. + */ + +static void postqual(dp) +dptr dp; + { + char *newqual; + + if (InRange(strbase,StrLoc(*dp),strfree + 1)) { + /* + * The string is in the string space. Add it to the string qualifier + * list, but before adding it, expand the string qualifier list if + * necessary. + */ + if (qualfree >= equallist) { + + /* reallocate a new qualifier list that's twice as large */ + newqual = realloc(quallist, 2 * qualsize); + if (newqual) { + quallist = (dptr *)newqual; + qualfree = (dptr *)(newqual + qualsize); + qualsize *= 2; + equallist = (dptr *)(newqual + qualsize); + } + else { + qualfail = 1; + return; + } + + } + *qualfree++ = dp; + } + } + +/* + * markblock - mark each accessible block in the block region and build + * back-list of descriptors pointing to that block. (Phase I of garbage + * collection.) + */ +static void markblock(dp) +dptr dp; + { + register dptr dp1; + register char *block, *endblock; + word type, fdesc; + int numptr; + register union block **ptr, **lastptr; + + if (Var(*dp)) { + if (dp->dword & F_Typecode) { + switch (Type(*dp)) { + case T_Kywdint: + case T_Kywdpos: + case T_Kywdsubj: + /* + * The descriptor points to a keyword, not a block. + */ + return; + } + } + else if (Offset(*dp) == 0) { + /* + * The descriptor is a simple variable not residing in a block. + */ + return; + } + } + + /* + * Get the block to which dp points. + */ + block = (char *)BlkLoc(*dp); + + if (InRange(blkbase,block,blkfree)) { + type = BlkType(block); + if ((uword)type <= MaxType) { + + /* + * The type is valid, which indicates that this block has not + * been marked. Point endblock to the byte past the end + * of the block. + */ + endblock = block + BlkSize(block); + } + + /* + * Add dp to the back chain for the block and point the + * block (via the type field) to dp.vword. + */ + BlkLoc(*dp) = (union block *)type; + BlkType(block) = (uword)&BlkLoc(*dp); + + if ((uword)type <= MaxType) { + /* + * The block was not marked; process pointers and descriptors + * within the block. + */ + if ((fdesc = firstp[type]) > 0) { + /* + * The block contains pointers; mark each pointer. + */ + ptr = (union block **)(block + fdesc); + numptr = ptrno[type]; + if (numptr > 0) + lastptr = ptr + numptr; + else + lastptr = (union block **)endblock; + for (; ptr < lastptr; ptr++) + if (*ptr != NULL) + markptr(ptr); + } + if ((fdesc = firstd[type]) > 0) + /* + * The block contains descriptors; mark each descriptor. + */ + for (dp1 = (dptr)(block + fdesc); + (char *)dp1 < endblock; dp1++) { + if (Qual(*dp1)) + postqual(dp1); + else if (Pointer(*dp1)) + markblock(dp1); + } + } + } + + else if ((unsigned int)BlkType(block) == T_Coexpr) { + struct b_coexpr *cp; + struct astkblk *abp; + int i; + struct descrip adesc; + + /* + * dp points to a co-expression block that has not been + * marked. Point the block to dp. Sweep the interpreter + * stack in the block. Then mark the block for the + * activating co-expression and the refresh block. + */ + BlkType(block) = (uword)dp; + sweep((struct b_coexpr *)block); + +#ifdef MultiThread + if (((struct b_coexpr *)block)+1 == + (struct b_coexpr *)((struct b_coexpr *)block)->program){ + /* + * This coexpr is an &main; traverse its roots + */ + markprogram(((struct b_coexpr *)block)->program); + } +#endif /* MultiThread */ + +#ifdef Coexpr + /* + * Mark the activators of this co-expression. The activators are + * stored as a list of addresses, but markblock requires the address + * of a descriptor. To accommodate markblock, the dummy descriptor + * adesc is filled in with each activator address in turn and then + * marked. Since co-expressions and the descriptors that reference + * them don't participate in the back-chaining scheme, it's ok to + * reuse the descriptor in this manner. + */ + cp = (struct b_coexpr *)block; + adesc.dword = D_Coexpr; + for (abp = cp->es_actstk; abp != NULL; abp = abp->astk_nxt) { + for (i = 1; i <= abp->nactivators; i++) { + BlkLoc(adesc) = (union block *)abp->arec[i-1].activator; + markblock(&adesc); + } + } + if(BlkLoc(cp->freshblk) != NULL) + markblock(&((struct b_coexpr *)block)->freshblk); +#endif /* Coexpr */ + } + + else { + struct region *rp; + + /* + * Look for this block in other allocated block regions. + */ + for (rp = curblock->Gnext; rp; rp = rp->Gnext) + if (InRange(rp->base,block,rp->free)) break; + + if (rp == NULL) + for (rp = curblock->Gprev; rp; rp = rp->Gprev) + if (InRange(rp->base,block,rp->free)) break; + + /* + * If this block is not in a block region, its something else + * like a procedure block. + */ + if (rp == NULL) + return; + + /* + * Get this block's type field; return if it is marked + */ + type = BlkType(block); + if ((uword)type > MaxType) + return; + + /* + * this is an unmarked block outside the (collecting) block region; + * process pointers and descriptors within the block. + * + * The type is valid, which indicates that this block has not + * been marked. Point endblock to the byte past the end + * of the block. + */ + endblock = block + BlkSize(block); + + BlkType(block) |= F_Mark; /* mark the block */ + + if ((fdesc = firstp[type]) > 0) { + /* + * The block contains pointers; mark each pointer. + */ + ptr = (union block **)(block + fdesc); + numptr = ptrno[type]; + if (numptr > 0) + lastptr = ptr + numptr; + else + lastptr = (union block **)endblock; + for (; ptr < lastptr; ptr++) + if (*ptr != NULL) + markptr(ptr); + } + if ((fdesc = firstd[type]) > 0) + /* + * The block contains descriptors; mark each descriptor. + */ + for (dp1 = (dptr)(block + fdesc); + (char *)dp1 < endblock; dp1++) { + if (Qual(*dp1)) + postqual(dp1); + else if (Pointer(*dp1)) + markblock(dp1); + } + } + } + +/* + * markptr - just like mark block except the object pointing at the block + * is just a block pointer, not a descriptor. + */ + +static void markptr(ptr) +union block **ptr; + { + register dptr dp; + register char *block, *endblock; + word type, fdesc; + int numptr; + register union block **ptr1, **lastptr; + + /* + * Get the block to which ptr points. + */ + block = (char *)*ptr; + if (InRange(blkbase,block,blkfree)) { + type = BlkType(block); + if ((uword)type <= MaxType) { + /* + * The type is valid, which indicates that this block has not + * been marked. Point endblock to the byte past the end + * of the block. + */ + endblock = block + BlkSize(block); + } + + /* + * Add ptr to the back chain for the block and point the + * block (via the type field) to ptr. + */ + *ptr = (union block *)type; + BlkType(block) = (uword)ptr; + + if ((uword)type <= MaxType) { + /* + * The block was not marked; process pointers and descriptors + * within the block. + */ + if ((fdesc = firstp[type]) > 0) { + /* + * The block contains pointers; mark each pointer. + */ + ptr1 = (union block **)(block + fdesc); + numptr = ptrno[type]; + if (numptr > 0) + lastptr = ptr1 + numptr; + else + lastptr = (union block **)endblock; + for (; ptr1 < lastptr; ptr1++) + if (*ptr1 != NULL) + markptr(ptr1); + } + if ((fdesc = firstd[type]) > 0) + /* + * The block contains descriptors; mark each descriptor. + */ + for (dp = (dptr)(block + fdesc); + (char *)dp < endblock; dp++) { + if (Qual(*dp)) + postqual(dp); + else if (Pointer(*dp)) + markblock(dp); + } + } + } + + else { + struct region *rp; + + /* + * Look for this block in other allocated block regions. + */ + for (rp = curblock->Gnext;rp;rp = rp->Gnext) + if (InRange(rp->base,block,rp->free)) break; + + if (rp == NULL) + for (rp = curblock->Gprev;rp;rp = rp->Gprev) + if (InRange(rp->base,block,rp->free)) break; + + /* + * If this block is not in a block region, its something else + * like a procedure block. + */ + if (rp == NULL) + return; + + /* + * Get this block's type field; return if it is marked + */ + type = BlkType(block); + if ((uword)type > MaxType) + return; + + /* + * this is an unmarked block outside the (collecting) block region; + * process pointers and descriptors within the block. + * + * The type is valid, which indicates that this block has not + * been marked. Point endblock to the byte past the end + * of the block. + */ + endblock = block + BlkSize(block); + + BlkType(block) |= F_Mark; /* mark the block */ + + if ((fdesc = firstp[type]) > 0) { + /* + * The block contains pointers; mark each pointer. + */ + ptr1 = (union block **)(block + fdesc); + numptr = ptrno[type]; + if (numptr > 0) + lastptr = ptr1 + numptr; + else + lastptr = (union block **)endblock; + for (; ptr1 < lastptr; ptr1++) + if (*ptr1 != NULL) + markptr(ptr1); + } + if ((fdesc = firstd[type]) > 0) + /* + * The block contains descriptors; mark each descriptor. + */ + for (dp = (dptr)(block + fdesc); + (char *)dp < endblock; dp++) { + if (Qual(*dp)) + postqual(dp); + else if (Pointer(*dp)) + markblock(dp); + } + } + } + +/* + * sweep - sweep the chain of tended descriptors for a co-expression + * marking the descriptors. + */ + +static void sweep(ce) +struct b_coexpr *ce; + { + register struct tend_desc *tp; + register int i; + + for (tp = ce->es_tend; tp != NULL; tp = tp->previous) { + for (i = 0; i < tp->num; ++i) { + if (Qual(tp->d[i])) + postqual(&tp->d[i]); + else if (Pointer(tp->d[i])) { + if(BlkLoc(tp->d[i]) != NULL) + markblock(&tp->d[i]); + } + } + } +#if !COMPILER + sweep_stk(ce); +#endif /* !COMPILER */ + } + +#if !COMPILER +/* + * sweep_stk - sweep the stack, marking all descriptors there. Method + * is to start at a known point, specifically, the frame that the + * fp points to, and then trace back along the stack looking for + * descriptors and local variables, marking them when they are found. + * The sp starts at the first frame, and then is moved down through + * the stack. Procedure, generator, and expression frames are + * recognized when the sp is a certain distance from the fp, gfp, + * and efp respectively. + * + * Sweeping problems can be manifested in a variety of ways due to + * the "if it can't be identified it's a descriptor" methodology. + */ + +static void sweep_stk(ce) +struct b_coexpr *ce; + { + register word *s_sp; + register struct pf_marker *fp; + register struct gf_marker *s_gfp; + register struct ef_marker *s_efp; + word nargs, type = 0, gsize = 0; + + fp = ce->es_pfp; + s_gfp = ce->es_gfp; + if (s_gfp != 0) { + type = s_gfp->gf_gentype; + if (type == G_Psusp) + gsize = Wsizeof(*s_gfp); + else + gsize = Wsizeof(struct gf_smallmarker); + } + s_efp = ce->es_efp; + s_sp = ce->es_sp; + nargs = 0; /* Nargs counter is 0 initially. */ + +#ifdef MultiThread + if (fp == 0) { + if (is:list(* (dptr) (s_sp - 1))) { + /* + * this is the argument list of an un-started task + */ + if (Pointer(*((dptr)(&s_sp[-1])))) { + markblock((dptr)&s_sp[-1]); + } + } + } +#endif /* MultiThread */ + + while ((fp != 0 || nargs)) { /* Keep going until current fp is + 0 and no arguments are left. */ + if (s_sp == (word *)fp + Vwsizeof(*pfp) - 1) { + /* sp has reached the upper + boundary of a procedure frame, + process the frame. */ + s_efp = fp->pf_efp; /* Get saved efp out of frame */ + s_gfp = fp->pf_gfp; /* Get save gfp */ + if (s_gfp != 0) { + type = s_gfp->gf_gentype; + if (type == G_Psusp) + gsize = Wsizeof(*s_gfp); + else + gsize = Wsizeof(struct gf_smallmarker); + } + s_sp = (word *)fp - 1; /* First argument descriptor is + first word above proc frame */ + nargs = fp->pf_nargs; + fp = fp->pf_pfp; + } + else if (s_gfp != NULL && s_sp == (word *)s_gfp + gsize - 1) { + /* The sp has reached the lower end + of a generator frame, process + the frame.*/ + if (type == G_Psusp) + fp = s_gfp->gf_pfp; + s_sp = (word *)s_gfp - 1; + s_efp = s_gfp->gf_efp; + s_gfp = s_gfp->gf_gfp; + if (s_gfp != 0) { + type = s_gfp->gf_gentype; + if (type == G_Psusp) + gsize = Wsizeof(*s_gfp); + else + gsize = Wsizeof(struct gf_smallmarker); + } + nargs = 1; + } + else if (s_sp == (word *)s_efp + Wsizeof(*s_efp) - 1) { + /* The sp has reached the upper + end of an expression frame, + process the frame. */ + s_gfp = s_efp->ef_gfp; /* Restore gfp, */ + if (s_gfp != 0) { + type = s_gfp->gf_gentype; + if (type == G_Psusp) + gsize = Wsizeof(*s_gfp); + else + gsize = Wsizeof(struct gf_smallmarker); + } + s_efp = s_efp->ef_efp; /* and efp from frame. */ + s_sp -= Wsizeof(*s_efp); /* Move past expression frame marker. */ + } + else { /* Assume the sp is pointing at a + descriptor. */ + if (Qual(*((dptr)(&s_sp[-1])))) + postqual((dptr)&s_sp[-1]); + else if (Pointer(*((dptr)(&s_sp[-1])))) { + markblock((dptr)&s_sp[-1]); + } + s_sp -= 2; /* Move past descriptor. */ + if (nargs) /* Decrement argument count if in an*/ + nargs--; /* argument list. */ + } + } + } +#endif /* !COMPILER */ + +/* + * reclaim - reclaim space in the allocated memory regions. The marking + * phase has already been completed. + */ + +static void reclaim() + { + /* + * Collect available co-expression blocks. + */ + cofree(); + + /* + * Collect the string space leaving it where it is. + */ + if (!qualfail) + scollect((word)0); + + /* + * Adjust the blocks in the block region in place. + */ + adjust(blkbase,blkbase); + + /* + * Compact the block region. + */ + compact(blkbase); + } + +/* + * cofree - collect co-expression blocks. This is done after + * the marking phase of garbage collection and the stacks that are + * reachable have pointers to data blocks, rather than T_Coexpr, + * in their type field. + */ + +static void cofree() + { + register struct b_coexpr **ep, *xep; + register struct astkblk *abp, *xabp; + + /* + * Reset the type for &main. + */ + +#ifdef MultiThread + rootpstate.Mainhead->title = T_Coexpr; +#else /* MultiThread */ + BlkLoc(k_main)->coexpr.title = T_Coexpr; +#endif /* MultiThread */ + + /* + * The co-expression blocks are linked together through their + * nextstk fields, with stklist pointing to the head of the list. + * The list is traversed and each stack that was not marked + * is freed. + */ + ep = &stklist; + while (*ep != NULL) { + if (BlkType(*ep) == T_Coexpr) { + xep = *ep; + *ep = (*ep)->nextstk; + /* + * Free the astkblks. There should always be one and it seems that + * it's not possible to have more than one, but nonetheless, the + * code provides for more than one. + */ + for (abp = xep->es_actstk; abp; ) { + xabp = abp; + abp = abp->astk_nxt; + free((pointer)xabp); + } + #ifdef CoClean + coclean(xep->cstate); + #endif /* CoClean */ + free((pointer)xep); + } + else { + BlkType(*ep) = T_Coexpr; + ep = &(*ep)->nextstk; + } + } + } + +/* + * scollect - collect the string space. quallist is a list of pointers to + * descriptors for all the reachable strings in the string space. For + * ease of description, it is referred to as if it were composed of + * descriptors rather than pointers to them. + */ + +static void scollect(extra) +word extra; + { + register char *source, *dest; + register dptr *qptr; + char *cend; + + if (qualfree <= quallist) { + /* + * There are no accessible strings. Thus, there are none to + * collect and the whole string space is free. + */ + strfree = strbase; + return; + } + /* + * Sort the pointers on quallist in ascending order of string + * locations. + */ + qsort((char *)quallist, (int)(DiffPtrs((char *)qualfree,(char *)quallist)) / + sizeof(dptr *), sizeof(dptr), (int (*)())qlcmp); + /* + * The string qualifiers are now ordered by starting location. + */ + dest = strbase; + source = cend = StrLoc(**quallist); + + /* + * Loop through qualifiers for accessible strings. + */ + for (qptr = quallist; qptr < qualfree; qptr++) { + if (StrLoc(**qptr) > cend) { + + /* + * qptr points to a qualifier for a string in the next clump. + * The last clump is moved, and source and cend are set for + * the next clump. + */ + while (source < cend) + *dest++ = *source++; + source = cend = StrLoc(**qptr); + } + if ((StrLoc(**qptr) + StrLen(**qptr)) > cend) + /* + * qptr is a qualifier for a string in this clump; extend + * the clump. + */ + cend = StrLoc(**qptr) + StrLen(**qptr); + /* + * Relocate the string qualifier. + */ + StrLoc(**qptr) = StrLoc(**qptr) + DiffPtrs(dest,source) + (uword)extra; + } + + /* + * Move the last clump. + */ + while (source < cend) + *dest++ = *source++; + strfree = dest; + } + +/* + * qlcmp - compare the location fields of two string qualifiers for qsort. + */ + +static int qlcmp(q1,q2) +dptr *q1, *q2; + { + return (int)(DiffPtrs(StrLoc(**q1),StrLoc(**q2))); + } + +/* + * adjust - adjust pointers into the block region, beginning with block oblk + * and basing the "new" block region at nblk. (Phase II of garbage + * collection.) + */ + +static void adjust(source,dest) +char *source, *dest; + { + register union block **nxtptr, **tptr; + + /* + * Loop through to the end of allocated block region, moving source + * to each block in turn and using the size of a block to find the + * next block. + */ + while (source < blkfree) { + if ((uword)(nxtptr = (union block **)BlkType(source)) > MaxType) { + + /* + * The type field of source is a back pointer. Traverse the + * chain of back pointers, changing each block location from + * source to dest. + */ + while ((uword)nxtptr > MaxType) { + tptr = nxtptr; + nxtptr = (union block **) *nxtptr; + *tptr = (union block *)dest; + } + BlkType(source) = (uword)nxtptr | F_Mark; + dest += BlkSize(source); + } + source += BlkSize(source); + } + } + +/* + * compact - compact good blocks in the block region. (Phase III of garbage + * collection.) + */ + +static void compact(source) +char *source; + { + register char *dest; + register word size; + + /* + * Start dest at source. + */ + dest = source; + + /* + * Loop through to end of allocated block space, moving source + * to each block in turn, using the size of a block to find the next + * block. If a block has been marked, it is copied to the + * location pointed to by dest and dest is pointed past the end + * of the block, which is the location to place the next saved + * block. Marks are removed from the saved blocks. + */ + while (source < blkfree) { + size = BlkSize(source); + if (BlkType(source) & F_Mark) { + BlkType(source) &= ~F_Mark; + if (source != dest) + mvc((uword)size,source,dest); + dest += size; + } + source += size; + } + + /* + * dest is the location of the next free block. Now that compaction + * is complete, point blkfree to that location. + */ + blkfree = dest; + } + +/* + * mvc - move n bytes from src to dest + * + * The algorithm is to copy the data (using memcpy) in the largest + * chunks possible, which is the size of area of the source data not in + * the destination area (ie non-overlapped area). (Chunks are expected to + * be fairly large.) + */ + +static void mvc(n, src, dest) +uword n; +register char *src, *dest; + { + register char *srcend, *destend; /* end of data areas */ + word copy_size; /* of size copy_size */ + word left_over; /* size of last chunk < copy_size */ + + if (n == 0) + return; + + srcend = src + n; /* point at byte after src data */ + destend = dest + n; /* point at byte after dest area */ + + if ((destend <= src) || (srcend <= dest)) /* not overlapping */ + memcpy(dest,src,n); + + else { /* overlapping data areas */ + if (dest < src) { + /* + * The move is from higher memory to lower memory. + */ + copy_size = DiffPtrs(src,dest); + + /* now loop round copying copy_size chunks of data */ + + do { + memcpy(dest,src,copy_size); + dest = src; + src = src + copy_size; + } + while (DiffPtrs(srcend,src) > copy_size); + + left_over = DiffPtrs(srcend,src); + + /* copy final fragment of data - if there is one */ + + if (left_over > 0) + memcpy(dest,src,left_over); + } + + else if (dest > src) { + /* + * The move is from lower memory to higher memory. + */ + copy_size = DiffPtrs(destend,srcend); + + /* now loop round copying copy_size chunks of data */ + + do { + destend = srcend; + srcend = srcend - copy_size; + memcpy(destend,srcend,copy_size); + } + while (DiffPtrs(srcend,src) > copy_size); + + left_over = DiffPtrs(srcend,src); + + /* copy intial fragment of data - if there is one */ + + if (left_over > 0) memcpy(dest,src,left_over); + } + + } /* end of overlapping data area code */ + + /* + * Note that src == dest implies no action + */ + } + +#ifdef DeBugIconx +/* + * descr - dump a descriptor. Used only for debugging. + */ + +void descr(dp) +dptr dp; + { + int i; + + fprintf(stderr,"%08lx: ",(long)dp); + if (Qual(*dp)) + fprintf(stderr,"%15s","qualifier"); + + else if (Var(*dp)) + fprintf(stderr,"%15s","variable"); + else { + i = Type(*dp); + switch (i) { + case T_Null: + fprintf(stderr,"%15s","null"); + break; + case T_Integer: + fprintf(stderr,"%15s","integer"); + break; + default: + fprintf(stderr,"%15s",blkname[i]); + } + } + fprintf(stderr," %08lx %08lx\n",(long)dp->dword,(long)IntVal(*dp)); + } + +/* + * blkdump - dump the allocated block region. Used only for debugging. + * NOTE: Not adapted for multiple regions. + */ + +void blkdump() + { + register char *blk; + register word type, size, fdesc; + register dptr ndesc; + + fprintf(stderr, + "\nDump of allocated block region. base:%08lx free:%08lx max:%08lx\n", + (long)blkbase,(long)blkfree,(long)blkend); + fprintf(stderr," loc type size contents\n"); + + for (blk = blkbase; blk < blkfree; blk += BlkSize(blk)) { + type = BlkType(blk); + size = BlkSize(blk); + fprintf(stderr," %08lx %15s %4ld\n",(long)blk,blkname[type], + (long)size); + if ((fdesc = firstd[type]) > 0) + for (ndesc = (dptr)(blk + fdesc); + ndesc < (dptr)(blk + size); ndesc++) { + fprintf(stderr," "); + descr(ndesc); + } + fprintf(stderr,"\n"); + } + fprintf(stderr,"end of block region.\n"); + } +#endif /* DeBugIconx */ diff --git a/src/runtime/rmisc.r b/src/runtime/rmisc.r new file mode 100644 index 0000000..a302da2 --- /dev/null +++ b/src/runtime/rmisc.r @@ -0,0 +1,1803 @@ +/* + * File: rmisc.r + * Contents: deref, eq, getvar, hash, outimage, + * qtos, pushact, popact, topact, [dumpact], + * findline, findipc, findfile, doimage, getimage + * printable, sig_rsm, cmd_line, varargs. + * + * Integer overflow checking. + */ + +/* + * Prototypes. + */ + +static void listimage + (FILE *f,struct b_list *lp, int noimage); +static void printimage (FILE *f,int c,int q); +static char * csname (dptr dp); + + +/* + * eq - compare two Icon strings for equality + */ +int eq(d1, d2) +dptr d1, d2; +{ + char *s1, *s2; + int i; + + if (StrLen(*d1) != StrLen(*d2)) + return 0; + s1 = StrLoc(*d1); + s2 = StrLoc(*d2); + for (i = 0; i < StrLen(*d1); i++) + if (*s1++ != *s2++) + return 0; + return 1; +} + +/* + * Get variable descriptor from name. Returns the (integer-encoded) scope + * of the variable (Succeeded for keywords), or Failed if the variable + * does not exist. + */ +int getvar(s,vp) + char *s; + dptr vp; + { + register dptr dp; + register dptr np; + register int i; + struct b_proc *bp; +#if COMPILER + struct descrip sdp; + + if (!debug_info) + fatalerr(402,NULL); + + StrLoc(sdp) = s; + StrLen(sdp) = strlen(s); +#else /* COMPILER */ + struct pf_marker *fp = pfp; +#endif /* COMPILER */ + + /* + * Is it a keyword that's a variable? + */ + if (*s == '&') { + + if (strcmp(s,"&error") == 0) { /* must put basic one first */ + vp->dword = D_Kywdint; + VarLoc(*vp) = &kywd_err; + return Succeeded; + } + else if (strcmp(s,"&pos") == 0) { + vp->dword = D_Kywdpos; + VarLoc(*vp) = &kywd_pos; + return Succeeded; + } + else if (strcmp(s,"&progname") == 0) { + vp->dword = D_Kywdstr; + VarLoc(*vp) = &kywd_prog; + return Succeeded; + } + else if (strcmp(s,"&random") == 0) { + vp->dword = D_Kywdint; + VarLoc(*vp) = &kywd_ran; + return Succeeded; + } + else if (strcmp(s,"&subject") == 0) { + vp->dword = D_Kywdsubj; + VarLoc(*vp) = &k_subject; + return Succeeded; + } + else if (strcmp(s,"&trace") == 0) { + vp->dword = D_Kywdint; + VarLoc(*vp) = &kywd_trc; + return Succeeded; + } + +#ifdef FncTrace + else if (strcmp(s,"&ftrace") == 0) { + vp->dword = D_Kywdint; + VarLoc(*vp) = &kywd_ftrc; + return Succeeded; + } +#endif /* FncTrace */ + + else if (strcmp(s,"&dump") == 0) { + vp->dword = D_Kywdint; + VarLoc(*vp) = &kywd_dmp; + return Succeeded; + } +#ifdef Graphics + else if (strcmp(s,"&window") == 0) { + vp->dword = D_Kywdwin; + VarLoc(*vp) = &(kywd_xwin[XKey_Window]); + return Succeeded; + } +#endif /* Graphics */ + +#ifdef MultiThread + else if (strcmp(s,"&eventvalue") == 0) { + vp->dword = D_Var; + VarLoc(*vp) = (dptr)&(curpstate->eventval); + return Succeeded; + } + else if (strcmp(s,"&eventsource") == 0) { + vp->dword = D_Var; + VarLoc(*vp) = (dptr)&(curpstate->eventsource); + return Succeeded; + } + else if (strcmp(s,"&eventcode") == 0) { + vp->dword = D_Var; + VarLoc(*vp) = (dptr)&(curpstate->eventcode); + return Succeeded; + } +#endif /* MultiThread */ + + else return Failed; + } + + /* + * Look for the variable the name with the local identifiers, + * parameters, and static names in each Icon procedure frame on the + * stack. If not found among the locals, check the global variables. + * If a variable with name is found, variable() returns a variable + * descriptor that points to the corresponding value descriptor. + * If no such variable exits, it fails. + */ + +#if !COMPILER + /* + * If no procedure has been called (as can happen with icon_call(), + * dont' try to find local identifier. + */ + if (pfp == NULL) + goto glbvars; +#endif /* !COMPILER */ + + dp = glbl_argp; +#if COMPILER + bp = PFDebug(*pfp)->proc; /* get address of procedure block */ +#else /* COMPILER */ + bp = (struct b_proc *)BlkLoc(*dp); /* get address of procedure block */ +#endif /* COMPILER */ + + np = bp->lnames; /* Check the formal parameter names. */ + + for (i = abs((int)bp->nparam); i > 0; i--) { +#if COMPILER + if (eq(&sdp, np) == 1) { +#else /* COMPILER */ + dp++; + if (strcmp(s,StrLoc(*np)) == 0) { +#endif /* COMPILER */ + vp->dword = D_Var; + VarLoc(*vp) = (dptr)dp; + return ParamName; + } + np++; +#if COMPILER + dp++; +#endif /* COMPILER */ + } + +#if COMPILER + dp = &pfp->tend.d[0]; +#else /* COMPILER */ + dp = &fp->pf_locals[0]; +#endif /* COMPILER */ + + for (i = (int)bp->ndynam; i > 0; i--) { /* Check the local dynamic names. */ +#if COMPILER + if (eq(&sdp, np)) { +#else /* COMPILER */ + if (strcmp(s,StrLoc(*np)) == 0) { +#endif /* COMPILER */ + vp->dword = D_Var; + VarLoc(*vp) = (dptr)dp; + return LocalName; + } + np++; + dp++; + } + + dp = &statics[bp->fstatic]; /* Check the local static names. */ + for (i = (int)bp->nstatic; i > 0; i--) { +#if COMPILER + if (eq(&sdp, np)) { +#else /* COMPILER */ + if (strcmp(s,StrLoc(*np)) == 0) { +#endif /* COMPILER */ + vp->dword = D_Var; + VarLoc(*vp) = (dptr)dp; + return StaticName; + } + np++; + dp++; + } + +#if COMPILER + for (i = 0; i < n_globals; ++i) { + if (eq(&sdp, &gnames[i])) { + vp->dword = D_Var; + VarLoc(*vp) = (dptr)&globals[i]; + return GlobalName; + } + } +#else /* COMPILER */ +glbvars: + dp = globals; /* Check the global variable names. */ + np = gnames; + while (dp < eglobals) { + if (strcmp(s,StrLoc(*np)) == 0) { + vp->dword = D_Var; + VarLoc(*vp) = (dptr)(dp); + return GlobalName; + } + np++; + dp++; + } +#endif /* COMPILER */ + return Failed; + } + +/* + * hash - compute hash value of arbitrary object for table and set accessing. + */ + +uword hash(dp) +dptr dp; + { + register char *s; + register uword i; + register word j, n; + register unsigned int *bitarr; + double r; + + if (Qual(*dp)) { + hashstring: + /* + * Compute the hash value for the string based on a scaled sum + * of its first ten characters, plus its length. + */ + i = 0; + s = StrLoc(*dp); + j = n = StrLen(*dp); + if (j > 10) /* limit scan to first ten characters */ + j = 10; + while (j-- > 0) { + i += *s++ & 0xFF; /* add unsigned version of next char */ + i *= 37; /* scale total by a nice prime number */ + } + i += n; /* add the (untruncated) string length */ + } + + else { + + switch (Type(*dp)) { + /* + * The hash value of an integer is itself times eight times the golden + * ratio. We do this calculation in fixed point. We don't just use + * the integer itself, for that would give bad results with sets + * having entries that are multiples of a power of two. + */ + case T_Integer: + i = (13255 * (uword)IntVal(*dp)) >> 10; + break; + +#ifdef LargeInts + /* + * The hash value of a bignum is based on its length and its + * most and least significant digits. + */ + case T_Lrgint: + { + struct b_bignum *b = &BlkLoc(*dp)->bignumblk; + + i = ((b->lsd - b->msd) << 16) ^ + (b->digits[b->msd] << 8) ^ b->digits[b->lsd]; + } + break; +#endif /* LargeInts */ + + /* + * The hash value of a real number is itself times a constant, + * converted to an unsigned integer. The intent is to scramble + * the bits well, in the case of integral values, and to scale up + * fractional values so they don't all land in the same bin. + * The constant below is 32749 / 29, the quotient of two primes, + * and was observed to work well in empirical testing. + */ + case T_Real: + GetReal(dp,r); + i = r * 1129.27586206896558; + break; + + /* + * The hash value of a cset is based on a convoluted combination + * of all its bits. + */ + case T_Cset: + i = 0; + bitarr = BlkLoc(*dp)->cset.bits + CsetSize - 1; + for (j = 0; j < CsetSize; j++) { + i += *bitarr--; + i *= 37; /* better distribution */ + } + i %= 1048583; /* scramble the bits */ + break; + + /* + * The hash value of a list, set, table, or record is its id, + * hashed like an integer. + */ + case T_List: + i = (13255 * BlkLoc(*dp)->list.id) >> 10; + break; + + case T_Set: + i = (13255 * BlkLoc(*dp)->set.id) >> 10; + break; + + case T_Table: + i = (13255 * BlkLoc(*dp)->table.id) >> 10; + break; + + case T_Record: + i = (13255 * BlkLoc(*dp)->record.id) >> 10; + break; + + case T_Proc: + dp = &(BlkLoc(*dp)->proc.pname); + goto hashstring; + + default: + /* + * For other types, use the type code as the hash + * value. + */ + i = Type(*dp); + break; + } + } + + return i; + } + + +#define StringLimit 16 /* limit on length of imaged string */ +#define ListLimit 6 /* limit on list items in image */ + +/* + * outimage - print image of *dp on file f. If noimage is nonzero, + * fields of records will not be imaged. + */ + +void outimage(f, dp, noimage) +FILE *f; +dptr dp; +int noimage; + { + register word i, j; + register char *s; + register union block *bp; + char *type, *csn; + FILE *fd; + struct descrip q; + double rresult; + tended struct descrip tdp; + + type_case *dp of { + string: { + /* + * *dp is a string qualifier. Print StringLimit characters of it + * using printimage and denote the presence of additional characters + * by terminating the string with "...". + */ + i = StrLen(*dp); + s = StrLoc(*dp); + j = Min(i, StringLimit); + putc('"', f); + while (j-- > 0) + printimage(f, *s++, '"'); + if (i > StringLimit) + fprintf(f, "..."); + putc('"', f); + } + + null: + fprintf(f, "&null"); + + integer: + +#ifdef LargeInts + if (Type(*dp) == T_Lrgint) + bigprint(f, dp); + else + fprintf(f, "%ld", (long)IntVal(*dp)); +#else /* LargeInts */ + fprintf(f, "%ld", (long)IntVal(*dp)); +#endif /* LargeInts */ + + real: { + char s[30]; + struct descrip rd; + + GetReal(dp,rresult); + rtos(rresult, &rd, s); + fprintf(f, "%s", StrLoc(rd)); + } + + cset: { + /* + * Check for a predefined cset; use keyword name if found. + */ + if ((csn = csname(dp)) != NULL) { + fprintf(f, csn); + return; + } + /* + * Use printimage to print each character in the cset. Follow + * with "..." if the cset contains more than StringLimit + * characters. + */ + putc('\'', f); + j = StringLimit; + for (i = 0; i < 256; i++) { + if (Testb(i, *dp)) { + if (j-- <= 0) { + fprintf(f, "..."); + break; + } + printimage(f, (int)i, '\''); + } + } + putc('\'', f); + } + + file: { + /* + * Check for distinguished files by looking at the address of + * of the object to image. If one is found, print its name. + */ + if ((fd = BlkLoc(*dp)->file.fd) == stdin) + fprintf(f, "&input"); + else if (fd == stdout) + fprintf(f, "&output"); + else if (fd == stderr) + fprintf(f, "&errout"); + else { + /* + * The file isn't a special one, just print "file(name)". + */ + i = StrLen(BlkLoc(*dp)->file.fname); + s = StrLoc(BlkLoc(*dp)->file.fname); +#ifdef Graphics + if (BlkLoc(*dp)->file.status & Fs_Window) { + s = ((wbp)(BlkLoc(*dp)->file.fd))->window->windowlabel; + i = strlen(s); + fprintf(f, "window_%d:%d(", + ((wbp)BlkLoc(*dp)->file.fd)->window->serial, + ((wbp)BlkLoc(*dp)->file.fd)->context->serial + ); + } + else +#endif /* Graphics */ + fprintf(f, "file("); + while (i-- > 0) + printimage(f, *s++, '\0'); + putc(')', f); + } + } + + proc: { + /* + * Produce one of: + * "procedure name" + * "function name" + * "record constructor name" + * + * Note that the number of dynamic locals is used to determine + * what type of "procedure" is at hand. + */ + i = StrLen(BlkLoc(*dp)->proc.pname); + s = StrLoc(BlkLoc(*dp)->proc.pname); + switch ((int)BlkLoc(*dp)->proc.ndynam) { + default: type = "procedure"; break; + case -1: type = "function"; break; + case -2: type = "record constructor"; break; + } + fprintf(f, "%s ", type); + while (i-- > 0) + printimage(f, *s++, '\0'); + } + + list: { + /* + * listimage does the work for lists. + */ + listimage(f, (struct b_list *)BlkLoc(*dp), noimage); + } + + table: { + /* + * Print "table_m(n)" where n is the size of the table. + */ + fprintf(f, "table_%ld(%ld)", (long)BlkLoc(*dp)->table.id, + (long)BlkLoc(*dp)->table.size); + } + + set: { + /* + * print "set_m(n)" where n is the cardinality of the set + */ + fprintf(f,"set_%ld(%ld)",(long)BlkLoc(*dp)->set.id, + (long)BlkLoc(*dp)->set.size); + } + + record: { + /* + * If noimage is nonzero, print "record(n)" where n is the + * number of fields in the record. If noimage is zero, print + * the image of each field instead of the number of fields. + */ + bp = BlkLoc(*dp); + i = StrLen(bp->record.recdesc->proc.recname); + s = StrLoc(bp->record.recdesc->proc.recname); + fprintf(f, "record "); + while (i-- > 0) + printimage(f, *s++, '\0'); + fprintf(f, "_%ld", (long)bp->record.id); + j = bp->record.recdesc->proc.nfields; + if (j <= 0) + fprintf(f, "()"); + else if (noimage > 0) + fprintf(f, "(%ld)", (long)j); + else { + putc('(', f); + i = 0; + for (;;) { + outimage(f, &bp->record.fields[i], noimage+1); + if (++i >= j) + break; + putc(',', f); + } + putc(')', f); + } + } + + coexpr: { + fprintf(f, "co-expression_%ld(%ld)", + (long)((struct b_coexpr *)BlkLoc(*dp))->id, + (long)((struct b_coexpr *)BlkLoc(*dp))->size); + } + + tvsubs: { + /* + * Produce "v[i+:j] = value" where v is the image of the variable + * containing the substring, i is starting position of the substring + * j is the length, and value is the string v[i+:j]. If the length + * (j) is one, just produce "v[i] = value". + */ + bp = BlkLoc(*dp); + dp = VarLoc(bp->tvsubs.ssvar); + if (is:kywdsubj(bp->tvsubs.ssvar)) { + fprintf(f, "&subject"); + fflush(f); + } + else { + dp = (dptr)((word *)dp + Offset(bp->tvsubs.ssvar)); + outimage(f, dp, noimage); + } + + if (bp->tvsubs.sslen == 1) + fprintf(f, "[%ld]", (long)bp->tvsubs.sspos); + else + fprintf(f, "[%ld+:%ld]", (long)bp->tvsubs.sspos, + (long)bp->tvsubs.sslen); + + if (Qual(*dp)) { + if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(*dp)) + return; + StrLen(q) = bp->tvsubs.sslen; + StrLoc(q) = StrLoc(*dp) + bp->tvsubs.sspos - 1; + fprintf(f, " = "); + outimage(f, &q, noimage); + } + } + + tvtbl: { + /* + * produce "t[s]" where t is the image of the table containing + * the element and s is the image of the subscript. + */ + bp = BlkLoc(*dp); + tdp.dword = D_Table; + BlkLoc(tdp) = bp->tvtbl.clink; + outimage(f, &tdp, noimage); + putc('[', f); + outimage(f, &bp->tvtbl.tref, noimage); + putc(']', f); + } + + kywdint: { + if (VarLoc(*dp) == &kywd_ran) + fprintf(f, "&random = "); + else if (VarLoc(*dp) == &kywd_trc) + fprintf(f, "&trace = "); + +#ifdef FncTrace + else if (VarLoc(*dp) == &kywd_ftrc) + fprintf(f, "&ftrace = "); +#endif /* FncTrace */ + + else if (VarLoc(*dp) == &kywd_dmp) + fprintf(f, "&dump = "); + else if (VarLoc(*dp) == &kywd_err) + fprintf(f, "&error = "); + outimage(f, VarLoc(*dp), noimage); + } + + kywdevent: { +#ifdef MultiThread + if (VarLoc(*dp) == &curpstate->eventsource) + fprintf(f, "&eventsource = "); + else if (VarLoc(*dp) == &curpstate->eventcode) + fprintf(f, "&eventcode = "); + else if (VarLoc(*dp) == &curpstate->eventval) + fprintf(f, "&eventval = "); +#endif /* MultiThread */ + outimage(f, VarLoc(*dp), noimage); + } + + kywdstr: { + outimage(f, VarLoc(*dp), noimage); + } + + kywdpos: { + fprintf(f, "&pos = "); + outimage(f, VarLoc(*dp), noimage); + } + + kywdsubj: { + fprintf(f, "&subject = "); + outimage(f, VarLoc(*dp), noimage); + } + kywdwin: { + fprintf(f, "&window = "); + outimage(f, VarLoc(*dp), noimage); + } + + default: { + if (is:variable(*dp)) { + /* + * *d is a variable. Print "variable =", dereference it, and + * call outimage to handle the value. + */ + fprintf(f, "(variable = "); + dp = (dptr)((word *)VarLoc(*dp) + Offset(*dp)); + outimage(f, dp, noimage); + putc(')', f); + } + else if (Type(*dp) == T_External) + fprintf(f, "external(%d)",((struct b_external *)BlkLoc(*dp))->blksize); + else if (Type(*dp) <= MaxType) + fprintf(f, "%s", blkname[Type(*dp)]); + else + syserr("outimage: unknown type"); + } + } + } + +/* + * printimage - print character c on file f using escape conventions + * if c is unprintable, '\', or equal to q. + */ + +static void printimage(f, c, q) +FILE *f; +int c, q; + { + if (printable(c)) { + /* + * c is printable, but special case ", ', and \. + */ + switch (c) { + case '"': + if (c != q) goto deflt; + fprintf(f, "\\\""); + return; + case '\'': + if (c != q) goto deflt; + fprintf(f, "\\'"); + return; + case '\\': + fprintf(f, "\\\\"); + return; + default: + deflt: + putc(c, f); + return; + } + } + + /* + * c is some sort of unprintable character. If it one of the common + * ones, produce a special representation for it, otherwise, produce + * its hex value. + */ + switch (c) { + case '\b': /* backspace */ + fprintf(f, "\\b"); + return; + case '\177': /* delete */ + fprintf(f, "\\d"); + return; + case '\33': /* escape */ + fprintf(f, "\\e"); + return; + case '\f': /* form feed */ + fprintf(f, "\\f"); + return; + case '\n': /* newline (line feed) */ + fprintf(f, "\\n"); + return; + case '\r': /* carriage return */ + fprintf(f, "\\r"); + return; + case '\t': /* horizontal tab */ + fprintf(f, "\\t"); + return; + case '\13': /* vertical tab */ + fprintf(f, "\\v"); + return; + default: /* hex escape sequence */ + fprintf(f, "\\x%02x", c & 0xff); + return; + } + } + +/* + * listimage - print an image of a list. + */ + +static void listimage(f, lp, noimage) +FILE *f; +struct b_list *lp; +int noimage; + { + register word i, j; + register struct b_lelem *bp; + word size, count; + + bp = (struct b_lelem *) lp->listhead; + size = lp->size; + + if (noimage > 0 && size > 0) { + /* + * Just give indication of size if the list isn't empty. + */ + fprintf(f, "list_%ld(%ld)", (long)lp->id, (long)size); + return; + } + + /* + * Print [e1,...,en] on f. If more than ListLimit elements are in the + * list, produce the first ListLimit/2 elements, an ellipsis, and the + * last ListLimit elements. + */ + fprintf(f, "list_%ld = [", (long)lp->id); + count = 1; + i = 0; + if (size > 0) { + for (;;) { + if (++i > bp->nused) { + i = 1; + bp = (struct b_lelem *) bp->listnext; + } + if (count <= ListLimit/2 || count > size - ListLimit/2) { + j = bp->first + i - 1; + if (j >= bp->nslots) + j -= bp->nslots; + outimage(f, &bp->lslots[j], noimage+1); + if (count >= size) + break; + putc(',', f); + } + else if (count == ListLimit/2 + 1) + fprintf(f, "...,"); + count++; + } + } + putc(']', f); + } + +/* + * qsearch(key,base,nel,width,compar) - binary search + * + * A binary search routine with arguments similar to qsort(3). + * Returns a pointer to the item matching "key", or NULL if none. + * Based on Bentley, CACM 28,7 (July, 1985), p. 676. + */ + +char * qsearch (key, base, nel, width, compar) +char * key; +char * base; +int nel, width; +int (*compar)(); +{ + int l, u, m, r; + char * a; + + l = 0; + u = nel - 1; + while (l <= u) { + m = (l + u) / 2; + a = (char *) ((char *) base + width * m); + r = compar (a, key); + if (r < 0) + l = m + 1; + else if (r > 0) + u = m - 1; + else + return a; + } + return 0; +} + +#if !COMPILER +/* + * qtos - convert a qualified string named by *dp to a C-style string. + * Put the C-style string in sbuf if it will fit, otherwise put it + * in the string region. + */ + +int qtos(dp, sbuf) +dptr dp; +char *sbuf; + { + register word slen; + register char *c, *s; + + c = StrLoc(*dp); + slen = StrLen(*dp)++; + if (slen >= MaxCvtLen) { + Protect(reserve(Strings, slen+1), return Error); + c = StrLoc(*dp); + if (c + slen != strfree) { + Protect(s = alcstr(c, slen), return Error); + } + else + s = c; + StrLoc(*dp) = s; + Protect(alcstr("",(word)1), return Error); + } + else { + StrLoc(*dp) = sbuf; + for ( ; slen > 0; slen--) + *sbuf++ = *c++; + *sbuf = '\0'; + } + return Succeeded; + } +#endif /* !COMPILER */ + +#ifdef Coexpr +/* + * pushact - push actvtr on the activator stack of ce + */ +int pushact(ce, actvtr) +struct b_coexpr *ce, *actvtr; +{ + struct astkblk *abp = ce->es_actstk, *nabp; + struct actrec *arp; + +#ifdef MultiThread + abp->arec[0].activator = actvtr; +#else /* MultiThread */ + + /* + * If the last activator is the same as this one, just increment + * its count. + */ + if (abp->nactivators > 0) { + arp = &abp->arec[abp->nactivators - 1]; + if (arp->activator == actvtr) { + arp->acount++; + return Succeeded; + } + } + /* + * This activator is different from the last one. Push this activator + * on the stack, possibly adding another block. + */ + if (abp->nactivators + 1 > ActStkBlkEnts) { + Protect(nabp = alcactiv(), fatalerr(0,NULL)); + nabp->astk_nxt = abp; + abp = nabp; + } + abp->nactivators++; + arp = &abp->arec[abp->nactivators - 1]; + arp->acount = 1; + arp->activator = actvtr; + ce->es_actstk = abp; +#endif /* MultiThread */ + return Succeeded; +} +#endif /* Coexpr */ + +/* + * popact - pop the most recent activator from the activator stack of ce + * and return it. + */ +struct b_coexpr *popact(ce) +struct b_coexpr *ce; +{ + +#ifdef Coexpr + + struct astkblk *abp = ce->es_actstk, *oabp; + struct actrec *arp; + struct b_coexpr *actvtr; + +#ifdef MultiThread + return abp->arec[0].activator; +#else /* MultiThread */ + + /* + * If the current stack block is empty, pop it. + */ + if (abp->nactivators == 0) { + oabp = abp; + abp = abp->astk_nxt; + free((pointer)oabp); + } + + if (abp == NULL || abp->nactivators == 0) + syserr("empty activator stack\n"); + + /* + * Find the activation record for the most recent co-expression. + * Decrement the activation count and if it is zero, pop that + * activation record and decrement the count of activators. + */ + arp = &abp->arec[abp->nactivators - 1]; + actvtr = arp->activator; + if (--arp->acount == 0) + abp->nactivators--; + + ce->es_actstk = abp; + return actvtr; +#endif /* MultiThread */ + +#else /* Coexpr */ + syserr("popact() called, but co-expressions not implemented"); +#endif /* Coexpr */ + +} + +#ifdef Coexpr +/* + * topact - return the most recent activator of ce. + */ +struct b_coexpr *topact(ce) +struct b_coexpr *ce; +{ + struct astkblk *abp = ce->es_actstk; + +#ifdef MultiThread + return abp->arec[0].activator; +#else /* MultiThread */ + if (abp->nactivators == 0) + abp = abp->astk_nxt; + return abp->arec[abp->nactivators-1].activator; +#endif /* MultiThread */ +} + +#ifdef DeBugIconx +/* + * dumpact - dump an activator stack + */ +void dumpact(ce) +struct b_coexpr *ce; +{ + struct astkblk *abp = ce->es_actstk; + struct actrec *arp; + int i; + + if (abp) + fprintf(stderr, "Ce %ld ", (long)ce->id); + while (abp) { + fprintf(stderr, "--- Activation stack block (%x) --- nact = %d\n", + abp, abp->nactivators); + for (i = abp->nactivators; i >= 1; i--) { + arp = &abp->arec[i-1]; + /*for (j = 1; j <= arp->acount; j++)*/ + fprintf(stderr, "co-expression_%ld(%d)\n", (long)(arp->activator->id), + arp->acount); + } + abp = abp->astk_nxt; + } +} +#endif /* DeBugIconx */ +#endif /* Coexpr */ + +#if !COMPILER +/* + * findline - find the source line number associated with the ipc + */ +#ifdef SrcColumnInfo +int findline(ipc) +word *ipc; +{ + return findloc(ipc) & 65535; +} +int findcol(ipc) +word *ipc; +{ + return findloc(ipc) >> 16; +} + +int findloc(ipc) +#else /* SrcColumnInfo */ +int findline(ipc) +#endif /* SrcColumnInfo */ +word *ipc; +{ + uword ipc_offset; + uword size; + struct ipc_line *base; + +#ifndef MultiThread + extern struct ipc_line *ilines, *elines; +#endif /* MultiThread */ + + static int two = 2; /* some compilers generate bad code for division + by a constant that is a power of two ... */ + + if (!InRange(code,ipc,ecode)) + return 0; + ipc_offset = DiffPtrs((char *)ipc,(char *)code); + base = ilines; + size = DiffPtrs((char *)elines,(char *)ilines) / sizeof(struct ipc_line *); + while (size > 1) { + if (ipc_offset >= base[size / two].ipc) { + base = &base[size / two]; + size -= size / two; + } + else + size = size / two; + } + /* + * return the line component of the location (column is top 16 bits) + */ + return (int)(base->line); +} +/* + * findipc - find the first ipc associated with a source-code line number. + */ +int findipc(line) +int line; +{ + uword size; + struct ipc_line *base; + +#ifndef MultiThread + extern struct ipc_line *ilines, *elines; +#endif /* MultiThread */ + + static int two = 2; /* some compilers generate bad code for division + by a constant that is a power of two ... */ + + base = ilines; + size = DiffPtrs((char *)elines,(char *)ilines) / sizeof(struct ipc_line *); + while (size > 1) { + if (line >= base[size / two].line) { + base = &base[size / two]; + size -= size / two; + } + else + size = size / two; + } + return base->ipc; +} + +/* + * findfile - find source file name associated with the ipc + */ +char *findfile(ipc) +word *ipc; +{ + uword ipc_offset; + struct ipc_fname *p; + +#ifndef MultiThread + extern struct ipc_fname *filenms, *efilenms; +#endif /* MultiThread */ + + if (!InRange(code,ipc,ecode)) + return "?"; + ipc_offset = DiffPtrs((char *)ipc,(char *)code); + for (p = efilenms - 1; p >= filenms; p--) + if (ipc_offset >= p->ipc) + return strcons + p->fname; + fprintf(stderr,"bad ipc/file name table\n"); + fflush(stderr); + c_exit(EXIT_FAILURE); + /*NOTREACHED*/ + return 0; /* avoid gcc warning */ +} +#endif /* !COMPILER */ + +/* + * doimage(c,q) - allocate character c in string space, with escape + * conventions if c is unprintable, '\', or equal to q. + * Returns number of characters allocated. + */ + +int doimage(c, q) +int c, q; + { + static char cbuf[5]; + + if (printable(c)) { + + /* + * c is printable, but special case ", ', and \. + */ + switch (c) { + case '"': + if (c != q) goto deflt; + Protect(alcstr("\\\"", (word)(2)), return Error); + return 2; + case '\'': + if (c != q) goto deflt; + Protect(alcstr("\\'", (word)(2)), return Error); + return 2; + case '\\': + Protect(alcstr("\\\\", (word)(2)), return Error); + return 2; + default: + deflt: + cbuf[0] = c; + Protect(alcstr(cbuf, (word)(1)), return Error); + return 1; + } + } + + /* + * c is some sort of unprintable character. If it is one of the common + * ones, produce a special representation for it, otherwise, produce + * its hex value. + */ + switch (c) { + case '\b': /* backspace */ + Protect(alcstr("\\b", (word)(2)), return Error); + return 2; + case '\177': /* delete */ + Protect(alcstr("\\d", (word)(2)), return Error); + return 2; + case '\33': /* escape */ + Protect(alcstr("\\e", (word)(2)), return Error); + return 2; + case '\f': /* form feed */ + Protect(alcstr("\\f", (word)(2)), return Error); + return 2; + case '\n': /* new line */ + Protect(alcstr("\\n", (word)(2)), return Error); + return 2; + case '\r': /* return */ + Protect(alcstr("\\r", (word)(2)), return Error); + return 2; + case '\t': /* horizontal tab */ + Protect(alcstr("\\t", (word)(2)), return Error); + return 2; + case '\13': /* vertical tab */ + Protect(alcstr("\\v", (word)(2)), return Error); + return 2; + default: /* hex escape sequence */ + sprintf(cbuf, "\\x%02x", c & 0xff); + Protect(alcstr(cbuf, (word)(4)), return Error); + return 4; + } + } + +/* + * getimage(dp1,dp2) - return string image of object dp1 in dp2. + */ + +int getimage(dp1,dp2) +dptr dp1, dp2; + { + register word len, outlen, rnlen; + int i; + tended char *s; + tended struct descrip source = *dp1; /* the source may move during gc */ + register union block *bp; + char *type, *t, *csn; + char sbuf[MaxCvtLen]; + FILE *fd; + + type_case source of { + string: { + /* + * Form the image by putting a quote in the string space, calling + * doimage with each character in the string, and then putting + * a quote at then end. Note that doimage directly writes into the + * string space. (Hence the indentation.) This technique is used + * several times in this routine. + */ + s = StrLoc(source); + len = StrLen(source); + Protect (reserve(Strings, (len << 2) + 2), return Error); + Protect(t = alcstr("\"", (word)(1)), return Error); + StrLoc(*dp2) = t; + StrLen(*dp2) = 1; + + while (len-- > 0) + StrLen(*dp2) += doimage(*s++, '"'); + Protect(alcstr("\"", (word)(1)), return Error); + ++StrLen(*dp2); + } + + null: { + StrLoc(*dp2) = "&null"; + StrLen(*dp2) = 5; + } + + integer: { +#ifdef LargeInts + if (Type(source) == T_Lrgint) { + word slen; + word dlen; + struct b_bignum *blk = &BlkLoc(source)->bignumblk; + + slen = blk->lsd - blk->msd; + dlen = slen * NB * 0.3010299956639812 /* 1 / log2(10) */ + + log((double)blk->digits[blk->msd]) * 0.4342944819032518 + 0.5; + /* 1 / ln(10) */ + if (dlen >= MaxDigits) { + sprintf(sbuf, "integer(~10^%ld)", (long)dlen); + len = strlen(sbuf); + Protect(StrLoc(*dp2) = alcstr(sbuf,len), return Error); + + + StrLen(*dp2) = len; + } + else bigtos(&source,dp2); + } + else + cnv: string(source, *dp2); +#else /* LargeInts */ + cnv:string(source, *dp2); +#endif /* LargeInts */ + } + + real: { + cnv:string(source, *dp2); + } + + cset: { + /* + * Check for the value of a predefined cset; use keyword name if found. + */ + if ((csn = csname(dp1)) != NULL) { + StrLoc(*dp2) = csn; + StrLen(*dp2) = strlen(csn); + return Succeeded; + } + /* + * Otherwise, describe it in terms of the character membership. + */ + + i = BlkLoc(source)->cset.size; + if (i < 0) + i = cssize(&source); + i = (i << 2) + 2; + if (i > 730) i = 730; + Protect (reserve(Strings, i), return Error); + + Protect(t = alcstr("'", (word)(1)), return Error); + StrLoc(*dp2) = t; + StrLen(*dp2) = 1; + for (i = 0; i < 256; ++i) + if (Testb(i, source)) + StrLen(*dp2) += doimage((char)i, '\''); + Protect(alcstr("'", (word)(1)), return Error); + ++StrLen(*dp2); + } + + file: { + /* + * Check for distinguished files by looking at the address of + * of the object to image. If one is found, make a string + * naming it and return. + */ + if ((fd = BlkLoc(source)->file.fd) == stdin) { + StrLen(*dp2) = 6; + StrLoc(*dp2) = "&input"; + } + else if (fd == stdout) { + StrLen(*dp2) = 7; + StrLoc(*dp2) = "&output"; + } + else if (fd == stderr) { + StrLen(*dp2) = 7; + StrLoc(*dp2) = "&errout"; + } + else { + /* + * The file is not a standard one; form a string of the form + * file(nm) where nm is the argument originally given to + * open. + */ +#ifdef Graphics + if (BlkLoc(source)->file.status & Fs_Window) { + s = ((wbp)(BlkLoc(source)->file.fd))->window->windowlabel; + len = strlen(s); + Protect (reserve(Strings, (len << 2) + 16), return Error); + sprintf(sbuf, "window_%d:%d(", + ((wbp)BlkLoc(source)->file.fd)->window->serial, + ((wbp)BlkLoc(source)->file.fd)->context->serial + ); + Protect(t = alcstr(sbuf, (word)(strlen(sbuf))), return Error); + StrLoc(*dp2) = t; + StrLen(*dp2) = strlen(sbuf); + } + else { +#endif /* Graphics */ + s = StrLoc(BlkLoc(source)->file.fname); + len = StrLen(BlkLoc(source)->file.fname); + Protect (reserve(Strings, (len << 2) + 12), return Error); + Protect(t = alcstr("file(", (word)(5)), return Error); + StrLoc(*dp2) = t; + StrLen(*dp2) = 5; +#ifdef Graphics + } +#endif /* Graphics */ + while (len-- > 0) + StrLen(*dp2) += doimage(*s++, '\0'); + Protect(alcstr(")", (word)(1)), return Error); + ++StrLen(*dp2); + } + } + + proc: { + /* + * Produce one of: + * "procedure name" + * "function name" + * "record constructor name" + * + * Note that the number of dynamic locals is used to determine + * what type of "procedure" is at hand. + */ + len = StrLen(BlkLoc(source)->proc.pname); + s = StrLoc(BlkLoc(source)->proc.pname); + Protect (reserve(Strings, len + 22), return Error); + switch ((int)BlkLoc(source)->proc.ndynam) { + default: type = "procedure "; outlen = 10; break; + case -1: type = "function "; outlen = 9; break; + case -2: type = "record constructor "; outlen = 19; break; + } + Protect(t = alcstr(type, outlen), return Error); + StrLoc(*dp2) = t; + Protect(alcstr(s, len), return Error); + StrLen(*dp2) = len + outlen; + } + + list: { + /* + * Produce: + * "list_m(n)" + * where n is the current size of the list. + */ + bp = BlkLoc(*dp1); + sprintf(sbuf, "list_%ld(%ld)", (long)bp->list.id, (long)bp->list.size); + len = strlen(sbuf); + Protect(t = alcstr(sbuf, len), return Error); + StrLoc(*dp2) = t; + StrLen(*dp2) = len; + } + + table: { + /* + * Produce: + * "table_m(n)" + * where n is the size of the table. + */ + bp = BlkLoc(*dp1); + sprintf(sbuf, "table_%ld(%ld)", (long)bp->table.id, + (long)bp->table.size); + len = strlen(sbuf); + Protect(t = alcstr(sbuf, len), return Error); + StrLoc(*dp2) = t; + StrLen(*dp2) = len; + } + + set: { + /* + * Produce "set_m(n)" where n is size of the set. + */ + bp = BlkLoc(*dp1); + sprintf(sbuf, "set_%ld(%ld)", (long)bp->set.id, (long)bp->set.size); + len = strlen(sbuf); + Protect(t = alcstr(sbuf,len), return Error); + StrLoc(*dp2) = t; + StrLen(*dp2) = len; + } + + record: { + /* + * Produce: + * "record name_m(n)" -- under construction + * where n is the number of fields. + */ + bp = BlkLoc(*dp1); + rnlen = StrLen(bp->record.recdesc->proc.recname); + sprintf(sbuf, "_%ld(%ld)", (long)bp->record.id, + (long)bp->record.recdesc->proc.nfields); + len = strlen(sbuf); + Protect (reserve(Strings, 7 + len + rnlen), return Error); + Protect(t = alcstr("record ", (word)(7)), return Error); + bp = BlkLoc(*dp1); /* refresh pointer */ + StrLoc(*dp2) = t; + StrLen(*dp2) = 7; + Protect(alcstr(StrLoc(bp->record.recdesc->proc.recname),rnlen), + return Error); + StrLen(*dp2) += rnlen; + Protect(alcstr(sbuf, len), return Error); + StrLen(*dp2) += len; + } + + coexpr: { + /* + * Produce: + * "co-expression_m (n)" + * where m is the number of the co-expressions and n is the + * number of results that have been produced. + */ + + sprintf(sbuf, "_%ld(%ld)", (long)BlkLoc(source)->coexpr.id, + (long)BlkLoc(source)->coexpr.size); + len = strlen(sbuf); + Protect (reserve(Strings, len + 13), return Error); + Protect(t = alcstr("co-expression", (word)(13)), return Error); + StrLoc(*dp2) = t; + Protect(alcstr(sbuf, len), return Error); + StrLen(*dp2) = 13 + len; + } + + default: + if (Type(*dp1) == T_External) { + /* + * For now, just produce "external(n)". + */ + sprintf(sbuf, "external(%ld)", (long)BlkLoc(*dp1)->externl.blksize); + len = strlen(sbuf); + Protect(t = alcstr(sbuf, len), return Error); + StrLoc(*dp2) = t; + StrLen(*dp2) = len; + } + else { + ReturnErrVal(123, source, Error); + } + } + return Succeeded; + } + +/* + * csname(dp) -- return the name of a predefined cset matching dp. + */ +static char *csname(dp) +dptr dp; + { + register int n; + + n = BlkLoc(*dp)->cset.size; + if (n < 0) + n = cssize(dp); + + /* + * Check for a cset we recognize using a hardwired decision tree. + * In ASCII, each of &lcase/&ucase/&digits are complete within 32 bits. + */ + if (n == 52) { + if ((Cset32('a',*dp) & Cset32('A',*dp)) == (0377777777l << CsetOff('a'))) + return ("&letters"); + } + else if (n < 52) { + if (n == 26) { + if (Cset32('a',*dp) == (0377777777l << CsetOff('a'))) + return ("&lcase"); + else if (Cset32('A',*dp) == (0377777777l << CsetOff('A'))) + return ("&ucase"); + } + else if (n == 10 && *CsetPtr('0',*dp) == (01777 << CsetOff('0'))) + return ("&digits"); + } + else /* n > 52 */ { + if (n == 256) + return "&cset"; + else if (n == 128 && ~0 == + (Cset32(0,*dp) & Cset32(32,*dp) & Cset32(64,*dp) & Cset32(96,*dp))) + return "&ascii"; + } + return NULL; + } + +/* + * cssize(dp) - calculate cset size, store it, and return it + */ +int cssize(dp) +dptr dp; +{ + register int i, n; + register unsigned int w, *wp; + register struct b_cset *cs; + + cs = &BlkLoc(*dp)->cset; + wp = (unsigned int *)cs->bits; + n = 0; + for (i = CsetSize; --i >= 0; ) + for (w = *wp++; w != 0; w >>= 1) + n += (w & 1); + cs->size = n; + return n; +} + +/* + * printable(c) -- is c a "printable" character? + */ + +int printable(c) +int c; + { + return (isascii(c) && isprint(c)); + } + +/* + * add, sub, mul, neg with overflow check + * all return 1 if ok, 0 if would overflow + */ + +extern int over_flow; + +/* + * add - integer addition with overflow checking + */ +word add(a, b) +word a, b; +{ + if ((a ^ b) >= 0 && (a >= 0 ? b > MaxLong - a : b < MinLong - a)) { + over_flow = 1; + return 0; + } + else { + over_flow = 0; + return a + b; + } +} + +/* + * sub - integer subtraction with overflow checking + */ +word sub(a, b) +word a, b; +{ + if ((a ^ b) < 0 && (a >= 0 ? b < a - MaxLong : b > a - MinLong)) { + over_flow = 1; + return 0; + } + else { + over_flow = 0; + return a - b; + } +} + +/* + * mul - integer multiplication with overflow checking + */ +word mul(a, b) +word a, b; +{ + if (b != 0) { + if ((a ^ b) >= 0) { + if (a >= 0 ? a > MaxLong / b : a < MaxLong / b) { + over_flow = 1; + return 0; + } + } + else if (b != -1 && (a >= 0 ? a > MinLong / b : a < MinLong / b)) { + over_flow = 1; + return 0; + } + } + + over_flow = 0; + return a * b; +} + +/* + * mod3 - integer modulo with overflow checking (always rounds to 0) + */ +word mod3(a, b) +word a, b; +{ + word retval; + + switch ( b ) + { + case 0: + over_flow = 1; /* Not really an overflow, but definitely an error */ + return 0; + + case MinLong: + /* Handle this separately, since -MinLong can overflow */ + retval = ( a > MinLong ) ? a : 0; + break; + + default: + /* First, we make b positive */ + if ( b < 0 ) b = -b; + + /* Make sure retval has the same sign as 'a' */ + retval = a % b; + if ( ( a < 0 ) && ( retval > 0 ) ) + retval -= b; + break; + } + + over_flow = 0; + return retval; +} + +/* + * div3 - integer divide with overflow checking (always rounds to 0) + */ +word div3(a, b) +word a, b; +{ + if ( ( b == 0 ) || /* Not really an overflow, but definitely an error */ + ( b == -1 && a == MinLong ) ) { + over_flow = 1; + return 0; + } + + over_flow = 0; + return ( a - mod3 ( a, b ) ) / b; +} + +/* + * neg - integer negation with overflow checking + */ +word neg(a) +word a; +{ + if (a == MinLong) { + over_flow = 1; + return 0; + } + over_flow = 0; + return -a; +} + +#if COMPILER +/* + * sig_rsm - standard success continuation that just signals resumption. + */ + +int sig_rsm() + { + return A_Resume; + } + +/* + * cmd_line - convert command line arguments into a list of strings. + */ +void cmd_line(argc, argv, rslt) +int argc; +char **argv; +dptr rslt; + { + tended struct b_list *hp; + register word i; + register struct b_lelem *bp; /* need not be tended */ + + /* + * Skip the program name. + */ + --argc; + ++argv; + + /* + * Allocate the list and a list block. + */ + Protect(hp = alclist(argc), fatalerr(0,NULL)); + Protect(bp = alclstb(argc, (word)0, argc), fatalerr(0,NULL)); + + /* + * Make the list block just allocated into the first and last blocks + * for the list. + */ + hp->listhead = hp->listtail = (union block *)bp; +#ifdef ListFix + bp->listprev = bp->listnext = (union block *)hp; +#endif /* ListFix */ + + /* + * Copy the arguments into the list + */ + for (i = 0; i < argc; ++i) { + StrLen(bp->lslots[i]) = strlen(argv[i]); + StrLoc(bp->lslots[i]) = argv[i]; + } + + rslt->dword = D_List; + rslt->vword.bptr = (union block *) hp; + } + +/* + * varargs - construct list for use in procedures with variable length + * argument list. + */ +void varargs(argp, nargs, rslt) +dptr argp; +int nargs; +dptr rslt; + { + tended struct b_list *hp; + register word i; + register struct b_lelem *bp; /* need not be tended */ + + /* + * Allocate the list and a list block. + */ + Protect(hp = alclist(nargs), fatalerr(0,NULL)); + Protect(bp = alclstb(nargs, (word)0, nargs), fatalerr(0,NULL)); + + /* + * Make the list block just allocated into the first and last blocks + * for the list. + */ + hp->listhead = hp->listtail = (union block *)bp; +#ifdef ListFix + bp->listprev = bp->listnext = (union block *)hp; +#endif /* ListFix */ + + /* + * Copy the arguments into the list + */ + for (i = 0; i < nargs; i++) + deref(&argp[i], &bp->lslots[i]); + + rslt->dword = D_List; + rslt->vword.bptr = (union block *) hp; + } +#endif /* COMPILER */ + +/* + * retderef - Dereference local variables and substrings of local + * string-valued variables. This is used for return, suspend, and + * transmitting values across co-expression context switches. + */ +void retderef(valp, low, high) +dptr valp; +word *low; +word *high; + { + struct b_tvsubs *tvb; + word *loc; + + if (Type(*valp) == T_Tvsubs) { + tvb = (struct b_tvsubs *)BlkLoc(*valp); + loc = (word *)VarLoc(tvb->ssvar); + } + else + loc = (word *)VarLoc(*valp) + Offset(*valp); + if (InRange(low, loc, high)) + deref(valp, valp); + } diff --git a/src/runtime/rmswin.ri b/src/runtime/rmswin.ri new file mode 100644 index 0000000..3471fd3 --- /dev/null +++ b/src/runtime/rmswin.ri @@ -0,0 +1,4204 @@ +/* + * rmswin.ri - Microsoft Windows-specific graphics interface code. + * + * Todo: + * geticonpos + * seticonimage + * free_mutable + * freecolor + * + * Untested: + * toggle_fgbg + * rebind + * geticonic + * getimstr + * getfntnam + * dumpimage + * getpointername + * + * Blown off: + * getvisual + * getdefault + */ +#ifdef Graphics + +void wfreersc(); +int alc_rgb(wbp w, SysColor rgb); +/* + * check_and_get_msg retreives the next message in *pMsg; + * returns 1 if regular message was retreived, 0 if quit message, + * -1 if there was an error. + */ +static int check_and_get_msg( MSG *pMsg ); +int numRealized; + +#ifndef min + #define min(x,y) (((x) < (y))?(x):(y)) + #define max(x,y) (((x) > (y))?(x):(y)) +#endif /* min */ +#define PALCLR(c) (c | 0x2000000L) + +int winInitialized = 0; +int BORDHEIGHT; +int BORDWIDTH; +/* + * check for double-byte character set versions of Windows + */ +CPINFO cpinfo; +int MAXBYTESPERCHAR; + +wclrp scp; +HPALETTE palette; +int numColors = 0; + +char szAppName[] = "Icon"; + +/* + * pattern symbols + */ +stringint siPatternSyms[] = { + {0, 16}, + { "black", 0}, + { "checkers", 12}, + { "darkgray", 2}, + { "diagonal", 8}, + { "grains", 13}, + { "gray", 3}, + { "grid", 10}, + { "horizontal",9}, + { "lightgray", 4}, + { "scales", 14}, + { "trellis", 11}, + { "vertical", 7}, + { "verydark", 1}, + { "verylight", 5}, + { "waves", 15}, + { "white", 6}, +}; + +/* + * draw ops + */ +stringint drawops[] = { + { 0, 16}, + {"and", R2_MASKPEN}, + {"andInverted", R2_MASKPENNOT}, + {"andReverse", R2_MASKNOTPEN}, + {"clear", R2_BLACK}, + {"copy", R2_COPYPEN}, + {"copyInverted", R2_NOTCOPYPEN}, + {"equiv", R2_NOTXORPEN}, + {"invert", R2_NOT}, + {"nand", R2_NOTMASKPEN}, + {"noop", R2_NOP}, + {"nor", R2_NOTMERGEPEN}, + {"or", R2_MERGEPEN}, + {"orInverted", R2_MERGEPENNOT}, + {"orReverse", R2_MERGENOTPEN}, + {"set", R2_WHITE}, + {"xor", R2_XORPEN}, +}; + +/* + * line types + */ +stringint siLineTypes[] = { + {0, 6}, + {"dashdotted", PS_DASHDOT}, + {"dashdotdotted", PS_DASHDOTDOT}, + {"dashed", PS_DOT}, + {"longdashed", PS_DASH}, + {"solid", PS_SOLID}, + {"striped", PS_DOT} +}; + +HINSTANCE mswinInstance; +int ncmdShow; + +int FoundIt, FoundNew; +HWND NewWin; +char *lookingfor; +struct WNDlist { + HWND w; + struct WNDlist *next; + } * wlhead; + +struct WNDlist *wlinsert(HWND w) +{ + struct WNDlist *x = malloc(sizeof (struct WNDlist)); + x->w = w; + x->next = wlhead; + wlhead = x; +} + +int wlsearch(HWND w) +{ + struct WNDlist *x; + for(x=wlhead;x;x=x->next) if (x->w == w) return 1; + return 0; +} + +void wlfree() +{ + struct WNDlist *x = wlhead; + while (wlhead) { + x = wlhead->next; + free(wlhead); + wlhead = x; + } +} + +BOOL_CALLBACK myenumproc(HWND w, LPARAM l) +{ + wlinsert(w); + return 1; +} + +BOOL_CALLBACK myenumproc2(HWND w, LPARAM l) +{ + if (!wlsearch(w)) { + FoundNew++; + NewWin = w; + } + return 1; +} + +char * strcasestr(char *haystack, char *needle) +{ + int len = strlen(needle); + while (*haystack) { + if (strncasecmp(haystack, needle, len) == 0) return haystack; + haystack++; + } + return 0; +} + +BOOL_CALLBACK myenumproc3(HWND w, LPARAM l) +{ + char s[64], s2[64]; + GetWindowText(w, s2, 63); + /* + * Conditions to find a window: + * 1) wasn't in the list of windows already present when we launched. + * 2) either contains the argv[0] program name, or + * was first window to appear after we called WinExec(). + */ + if (!wlsearch(w)) { + FoundNew++; + if ((strcasestr(s2, lookingfor) != NULL) || (NewWin && (NewWin == w))) { + FoundIt++; + } + } + return 1; +} + +char *lookcmdname(char *buf, char *s) +{ + char *t = buf; + while (*s) { + *t++ = *s; + if (*s == '\\') t = buf; + s++; + } + *t++ = '\0'; + s = buf; + while (*s) { + if (*s == '.') *s = '\0'; + s++; + } + return buf; +} + + +/* + * wopen + */ +FILE *wopen(char *name, struct b_list *lp, dptr attr, int n, int *err_idx) + { + wbp w; + wsp ws; + wcp wc; + struct imgdata *imd; + char answer[256]; + int i, r; + tended struct b_list *tlp; + tended struct descrip attrrslt; + HDC hdc, hdc2, hdc3; + TEXTMETRIC metrics; + LOGPALETTE logpal[4]; /* really 1 + space for an extra palette entry */ + HBRUSH brush; + HBITMAP oldpix, oldpix2; + HFONT oldfont; + + if (! winInitialized++) { + BORDWIDTH = FRAMEWIDTH * 2; + BORDHEIGHT = TITLEHEIGHT + FRAMEHEIGHT * 2 - 1; + GetCPInfo(CP_ACP, &cpinfo); + MAXBYTESPERCHAR = cpinfo.MaxCharSize; + } + + tlp = lp; + + /* + * allocate a binding, a window state, and a context + */ + Protect(w = alc_wbinding(), return NULL); + Protect(w->window = alc_winstate(), { free_binding(w); return NULL; }); + Protect(w->context = alc_context(w), { free_binding(w); return NULL; }); + ws = w->window; + ws->listp.dword = D_List; + BlkLoc(ws->listp) = (union block *)lp; + ws->width = ws->height = 0; + wc = w->context; + + /* + * process the passed in attributes - by calling wattrib + */ + for(i = 0; i < n; i++) + switch (wattrib(w, StrLoc(attr[i]), StrLen(attr[i]), &attrrslt, + answer)) { + case Failed: + wclose(w); + return NULL; + case Error: + /* think of something to do here */ + break; + } + + /* + * set the title, defaulting to the "filename" supplied to open() + */ + if (ws->windowlabel == NULL) ws->windowlabel = salloc(name); + if (ws->iconlabel == NULL) ws->iconlabel = salloc(name); + + if (ws->posx < 0) ws->posx = 0; + if (ws->posy < 0) ws->posy = 0; + + /* + * create the window + */ + ws->iconwin = CreateWindow( "iconx", ws->windowlabel, WS_OVERLAPPEDWINDOW, + ws->posx, ws->posy, + ws->width == 0 ? 400 : ws->width + BORDWIDTH, + ws->height == 0 ? 400: ws->height + BORDHEIGHT, + NULL, NULL, mswinInstance, NULL); + hdc = GetDC(ws->iconwin); + if ((GetDeviceCaps(hdc, RASTERCAPS) & RC_PALETTE) && (numColors == 0)){ + /* This window is on a device that supports palettes */ + numColors = 2; + logpal[0].palNumEntries = 2; + logpal[0].palVersion = 0x300; + logpal[0].palPalEntry[0].peFlags = 0; + logpal[0].palPalEntry[0].peRed = 0; + logpal[0].palPalEntry[0].peGreen = 0; + logpal[0].palPalEntry[0].peBlue = 0; + logpal[0].palPalEntry[1].peFlags = 0; + logpal[0].palPalEntry[1].peRed = 255; + logpal[0].palPalEntry[1].peGreen = 255; + logpal[0].palPalEntry[1].peBlue = 255; + palette = CreatePalette(logpal); + if ((scp = malloc(2 * sizeof (struct wcolor))) == NULL) return NULL; + scp[0].c = RGB(0,0,0); + scp[0].type = SHARED; + strcpy(scp[0].name, "black"); + scp[1].c = RGB(255,255,255); + scp[1].type = SHARED; + strcpy(scp[1].name, "white"); + } + oldfont = SelectObject(hdc, wc->font->font); + GetTextMetrics(hdc, &metrics); + wc->font->charwidth = dc_maxcharwidth(hdc); + SelectObject(hdc, oldfont); + ReleaseDC(ws->iconwin, hdc); + wc->font->ascent = metrics.tmAscent; + wc->font->descent = metrics.tmDescent; + /* wc->font->charwidth = metrics.tmMaxCharWidth; buggy */ + wc->font->height = metrics.tmHeight; + wc->leading = metrics.tmHeight; + ws->x = 0; + ws->y = ASCENT(w); + ws->y += w->context->dy; + ws->x += w->context->dx; + /* + * set the generic window's true default sizes + */ + if (!ws->width || !ws->height) { + if (!ws->width) ws->width = FWIDTH(w) * 80; + if (!ws->height) ws->height = FHEIGHT(w) * 12; + SetWindowPos(ws->iconwin, ws->iconwin, + ws->posx, + ws->posy, + ws->width + BORDWIDTH, ws->height + BORDHEIGHT, + SWP_NOZORDER); + } + if (!ws->pix) { + hdc = GetDC(ws->iconwin); + ws->pix = CreateCompatibleBitmap(hdc, ws->width, ws->height); + ReleaseDC(ws->iconwin, hdc); + } + + if (alc_rgb(w, wc->fg) == Failed) { + return 0; + } + if (alc_rgb(w, wc->bg) == Failed) { + return 0; + } + ws->pixwidth = ws->width; + ws->pixheight = ws->height; + if (!ISTOBEHIDDEN(ws)) { + ws->win = ws->iconwin; + ShowWindow(ws->win, ncmdShow); + } + else ws->win = 0; + + if (ws->initialPix) { + hdc = GetDC(ws->iconwin); + hdc2 = CreateCompatibleDC(hdc); + oldpix = SelectObject(hdc2, ws->pix); + hdc3 = CreateCompatibleDC(hdc); + oldpix2 = SelectObject(hdc3, ws->initialPix); + BitBlt(hdc2, 0, 0, ws->width, ws->height, hdc3, 0, 0, SRCCOPY); + if (ws->win) + BitBlt(hdc, 0, 0, ws->width, ws->height, hdc3, 0, 0, SRCCOPY); + SelectObject(hdc2, oldpix); + SelectObject(hdc3, oldpix2); + DeleteDC(hdc2); + DeleteDC(hdc3); + DeleteObject(ws->initialPix); + ws->initialPix = (HBITMAP) NULL; + } + else { + /* + * initialize the image with the background color + */ + RECT rec; + hdc = GetDC(ws->iconwin); + hdc2 = CreateCompatibleDC(hdc); + oldpix = SelectObject(hdc2, ws->pix); + rec.left = rec.top = 0; + rec.right = ws->width; + rec.bottom = ws->height; + if (palette) { + SelectPalette(hdc, palette, FALSE); + SelectPalette(hdc2, palette, FALSE); + RealizePalette(hdc); + RealizePalette(hdc2); + } + brush = CreateBrushIndirect(&(wc->bgbrush)); + if (ws->win) + FillRect(hdc, &rec, brush); + FillRect(hdc2, &rec, brush); + DeleteObject(brush); + SelectObject(hdc2, oldpix); + ReleaseDC(ws->iconwin, hdc); + DeleteDC(hdc2); + + imd = &ws->initimage; + if (imd->width) { + r = strimage(w, 0, 0, imd->width, imd->height, imd->paltbl, + imd->data, (word)imd->width * (word)imd->height, 0); + free((pointer)imd->paltbl); + free((pointer)imd->data); + imd->width = 0; + if (r < 0) { + return 0; + } + } + } + if (ws->win) + UpdateWindow(ws->win); + + return (FILE *)w; + } + +int handle_config(wbp w, UINT msg, WPARAM wp, LPARAM lp) + { + int neww, newh; + struct descrip d; + wsp ws = w->window; + + if (wp == SIZE_MINIMIZED) { + if (ws->win) { + SetWindowText(ws->win, ws->iconlabel); + ws->win = NULL; + } + return 1; + } + + if (ws->win) + SetWindowText(ws->win, ws->windowlabel); + ws->win = ws->iconwin; + + /* + * make sure text cursor stays on-screen + */ + ws->x = min(ws->x, LOWORD(lp) - FWIDTH(w)); + ws->y = min(ws->y, HIWORD(lp)); + + neww = LOWORD(lp); + newh = HIWORD(lp); + + /* + * if it was not a resize, drop it + */ + if ((ws->width == neww) && (ws->height == newh)) { + return 1; + } + + ws->width = neww; + ws->height = newh; + if (! resizePixmap(w, ws->width, ws->height)) return 0; + if (!ISEXPOSED(w)) { + SETEXPOSED(w); + return 1; + } + MakeInt(RESIZED, &d); + qevent(w->window, &d, ws->width, ws->height, ~(uword)0, 0); + return 1; + } + +/* + * handle window controls (child windows), at the moment these are + * buttons and scrollbars. wp is which child (base 1). + * Buttons come in as undiluted messages. + * Scrollbars come in with msg = new value of scrollbar + */ +void handle_child(wbp wb, UINT msg, WPARAM wp, LPARAM lp) + { + DWORD dw; + LONG t; + WORD x, y; + wsp ws = wb->window; + char *s; + int len; + struct descrip d; + int flags = 0; + if (LOWORD(wp) > ws->nChildren) return; + s = ws->child[LOWORD(wp) - 1].id; + len = strlen(s); + d = nulldesc; + StrLoc(d) = alcstr(s, len); + StrLen(d) = len; + switch (HIWORD(wp)) { + case BN_CLICKED: { + dw = GetMessagePos(); + x = LOWORD(dw); + y = HIWORD(dw); + break; + } + case EN_SETFOCUS: case EN_KILLFOCUS: case EN_CHANGE: case EN_UPDATE: + case EN_ERRSPACE: case EN_MAXTEXT: case EN_HSCROLL: case EN_VSCROLL: { + return; + } + default: { /* scrollbar */ + x = y = msg; + } + } + t = GetMessageTime(); + qevent(ws, &d, x, y, t, flags); + if (ws->focusChild) + SetFocus(ws->focusChild); + else if (ws->win) + SetFocus(ws->win); + else + SetFocus(ws->iconwin); + } + +void handle_menu(wbp wb, UINT msg, WPARAM wp, LPARAM lp) + { + wsp ws = wb->window; + DWORD dw; + LONG t; + WORD x, y; + struct descrip d; + char *s = ws->menuMap[wp]; + int len = strlen(s); + int flags = 0; + + d = nulldesc; + StrLoc(d) = alcstr(s, len); + StrLen(d) = len; + dw = GetMessagePos(); + x = LOWORD(dw); + y = HIWORD(dw); + t = GetMessageTime(); + qevent(ws, &d, x, y, t, flags); + } + +void handle_keypress(wbp wb, UINT msg, WPARAM wp, LPARAM lp, int meta) + { + wsp ws = wb->window; + DWORD dw; + LONG t; + WORD x, y; + struct descrip d; + int flags = 0; + if (msg == WM_CHAR || msg == WM_SYSCHAR) { + StrLen(d) = 1; + StrLoc(d) = (char *)&allchars[wp & 0xFF]; + } + else { /* WM_KEYDOWN or WM_SYSKEYDOWN */ + MakeInt(wp, &d); + } + dw = GetMessagePos(); + x = LOWORD(dw); + y = HIWORD(dw); + t = GetMessageTime(); + if (GetKeyState(VK_CONTROL) < 0) flags |= ControlMask; + if (GetKeyState(VK_SHIFT) < 0) flags |= ShiftMask; + + if (meta) flags |= Mod1Mask; + qevent(ws, &d, x, y, t, flags); + } + +void handle_mouse(wbp wb, UINT msg, WPARAM wp, LPARAM lp) + { + wsp ws = wb->window; + LONG t; + WORD x, y; + struct descrip d; + long flags = 0, eventcode; + + switch(msg) { + case WM_MOUSEMOVE: /* only called if one of these three cases is true */ + if (MK_LBUTTON & wp) + eventcode = MOUSELEFTDRAG; + else if (MK_RBUTTON & wp) + eventcode = MOUSERIGHTDRAG; + else if (MK_MBUTTON & wp) + eventcode = MOUSEMIDDRAG; + else eventcode = 0; + break; + case WM_LBUTTONDOWN: + eventcode = MOUSELEFT; + break; + case WM_MBUTTONDOWN: + eventcode = MOUSEMID; + break; + case WM_RBUTTONDOWN: + eventcode = MOUSERIGHT; + break; + case WM_LBUTTONUP: + eventcode = MOUSELEFTUP; + break; + case WM_MBUTTONUP: + eventcode = MOUSEMIDUP; + break; + case WM_RBUTTONUP: + eventcode = MOUSERIGHTUP; + break; + default: + eventcode = 0; + break; + } + + MakeInt(eventcode, &d); + x = LOWORD(lp); + y = HIWORD(lp); + t = GetMessageTime(); /* why might someone comment this out? */ + + if (MK_CONTROL & wp) flags |= ControlMask; + if (MK_SHIFT & wp) flags |= ShiftMask; + + qevent(ws, &d, x, y, t, flags); + } + +LRESULT_CALLBACK WndProc(HWND hwnd, UINT msg, WPARAM wp, LPARAM lp) +{ + HDC hdc, hdc2; + PAINTSTRUCT ps; + RECT rect; + wbp wb = NULL; + wsp ws = NULL; + int n, i, imin, imax; + + /* + * find a binding associated with the given window. + */ + for (wb = wbndngs; wb; wb=wb->next) { + ws = wb->window; + + if ((ws->win == hwnd) || (ws->iconwin == hwnd)) break; + } + if (msg == WM_QUIT) { + wfreersc(); + } + else if (!wb) { + /* + * doesn't look like its for one of our windows, pass it to + * DefWindowProc and hope for the best. + */ + } + else + switch(msg) { + case WM_PAINT: + hdc = BeginPaint(hwnd, &ps); + GetClientRect(hwnd, &rect); + if (IsIconic(hwnd)) { + HBRUSH hb = CreateBrushIndirect(&(wb->context->brush)); + FrameRect(hdc, &rect, hb); + DeleteObject(hb); + DrawText(hdc, "Iconx", 5, &rect, DT_WORDBREAK); + } + else { + HBITMAP oldpix; + hdc2 = CreateCompatibleDC(hdc); + oldpix = SelectObject(hdc2, ws->pix); + BitBlt(hdc, rect.left, rect.top, + rect.right - rect.left + 1, rect.bottom - rect.top + 1, + hdc2, rect.left, rect.top, SRCCOPY); + SelectObject(hdc2, oldpix); + DeleteDC(hdc2); + } + EndPaint(hwnd, &ps); + return 0; + case WM_MOUSEMOVE: + if (ws->curcursor) + SetCursor(ws->curcursor); + if ((MK_LBUTTON | MK_RBUTTON | MK_MBUTTON) & wp) + handle_mouse(wb,msg,wp,lp); + return 0; + case WM_LBUTTONDOWN: case WM_RBUTTONDOWN: case WM_MBUTTONDOWN: + case WM_LBUTTONUP: case WM_RBUTTONUP: case WM_MBUTTONUP: + handle_mouse(wb,msg,wp,lp); + return 0; + case WM_KEYDOWN: + switch (wp) { /* VK defn's from <winuser.h> */ + case VK_F1: case VK_F2: case VK_F3: case VK_F4: + case VK_F5: case VK_F6: case VK_F7: case VK_F8: + case VK_F9: case VK_F10: case VK_F11: case VK_F12: + case VK_HOME: case VK_END: case VK_PRIOR: case VK_NEXT: + case VK_LEFT: case VK_RIGHT: case VK_UP: case VK_DOWN: + case VK_INSERT: case VK_SELECT: case VK_PRINT: + case VK_EXECUTE: case VK_SNAPSHOT: case VK_HELP: case VK_SEPARATOR: + case VK_CLEAR: case VK_PAUSE: case VK_SCROLL: + handle_keypress(wb, msg, wp, lp, 0); + return 0; + case VK_DELETE: + handle_keypress(wb, WM_CHAR, '\177', lp, 0); + return 0; + } + break; + case WM_SYSKEYDOWN: + switch (wp) { + case VK_F1: case VK_F2: case VK_F3: /* alt-F4 terminates */ + case VK_F5: case VK_F6: case VK_F7: case VK_F8: + case VK_F9: case VK_F10: case VK_F11: case VK_F12: + case VK_HOME: case VK_END: case VK_PRIOR: case VK_NEXT: + case VK_LEFT: case VK_RIGHT: case VK_UP: case VK_DOWN: + case VK_INSERT: case VK_DELETE: case VK_SELECT: case VK_PRINT: + case VK_EXECUTE: case VK_SNAPSHOT: case VK_HELP: case VK_SEPARATOR: + case VK_CLEAR: case VK_PAUSE: + handle_keypress(wb, msg, wp, lp, 1); + return 0; + } + break; + case WM_CHAR: + handle_keypress(wb, msg, wp, lp, 0); + return 0; + case WM_SYSCHAR: + handle_keypress(wb, msg, wp, lp, 1); + /* + * Unless there is a menu bar installed, + * Alt-A .. Alt-Z, and Alt-0 .. Alt-9 are eaten by Icon; + * others are passed on to Windows for things like Alt-Esc. + */ + if (isalnum(wp) && !(ws->menuMap)) return 0; + break; + case WM_HSCROLL: + case WM_VSCROLL: + for(n=0; n < ws->nChildren && ws->child[n].win != (HWND)lp; n++){ + } + if (n == ws->nChildren) break; + i = GetScrollPos(ws->child[n].win, SB_CTL); + GetScrollRange(ws->child[n].win, SB_CTL, &imin, &imax); + switch (LOWORD(wp)) { + case SB_PAGEDOWN : + break; + case SB_LINEDOWN : + if (i < imax) { + SetScrollPos(ws->child[n].win, SB_CTL, + GetScrollPos(ws->child[n].win, SB_CTL) + 1, TRUE); + } + break; + case SB_PAGEUP : + break; + case SB_LINEUP : + if (i > imin) { + SetScrollPos(ws->child[n].win, SB_CTL, + GetScrollPos(ws->child[n].win, SB_CTL) - 1, TRUE); + } + break; + case SB_TOP : + SetScrollPos(ws->child[n].win, SB_CTL, imin, TRUE); + break; + case SB_BOTTOM : + SetScrollPos(ws->child[n].win, SB_CTL, imax, TRUE); + break; + case SB_THUMBPOSITION : + SetScrollPos(ws->child[n].win, SB_CTL, HIWORD(wp), TRUE); + break; + case SB_THUMBTRACK : + SetScrollPos(ws->child[n].win, SB_CTL, HIWORD(wp), TRUE); + break; + case SB_ENDSCROLL: /* noop */ + break; + default : /* potentially a problem here */ + break; + } + i = GetScrollPos(ws->child[n].win, SB_CTL); + handle_child(wb, i, n+1, -1); + break; + case WM_COMMAND: + if (LOWORD(lp) == 0) + handle_menu(wb, msg, wp, lp); + else + handle_child(wb, msg, wp, lp); + break; + case WM_SIZE: + handle_config(wb, msg, wp, lp); + break; + case WM_MOVE: + ws->posx = LOWORD(lp) - (BORDWIDTH>>1); + ws->posy = HIWORD(lp) - (BORDHEIGHT - 4); + break; + case WM_ACTIVATE: + if (wp == WA_INACTIVE) { + if (ws->savedcursor) SetCursor(ws->savedcursor); + if (ws->hasCaret) { + HideCaret(ws->iconwin); + DestroyCaret(); + ws->hasCaret = 0; + } + } + else { /* ... */ + if (ws->savedcursor == NULL) + ws->savedcursor = SetCursor(ws->curcursor); + else (void) SetCursor(ws->curcursor); + if (ISCURSORON(wb)) { + CreateCaret(ws->iconwin, NULL, FWIDTH(wb), FHEIGHT(wb)); + SetCaretPos(ws->x, ws->y - ASCENT(wb)); + SetCaretBlinkTime(500); + ShowCaret(ws->iconwin); + ws->hasCaret = 1; + } + } + break; + case WM_GETMINMAXINFO: { + MINMAXINFO *mmi = (MINMAXINFO *)lp; + if (! ISRESIZABLE(wb)) { + mmi->ptMinTrackSize.x = mmi->ptMaxTrackSize.x = + ws->width + BORDWIDTH; + mmi->ptMinTrackSize.y = mmi->ptMaxTrackSize.y = + ws->height + BORDHEIGHT; + } + return 0; + } + case WM_KILLFOCUS: + if (ws->hasCaret) { + HideCaret(ws->iconwin); + DestroyCaret(); + ws->hasCaret = 0; + } + break; + case WM_SETFOCUS: + if (ws->focusChild) + SetFocus(ws->focusChild); + else if (ISCURSORON(wb)) { + CreateCaret(ws->iconwin, NULL, FWIDTH(wb), FHEIGHT(wb)); + SetCaretPos(ws->x, ws->y - ASCENT(wb)); + SetCaretBlinkTime(500); + ShowCaret(ws->iconwin); + ws->hasCaret = 1; + } + break; + /* case WM_QUIT is handled prior to the switch*/ + case WM_DESTROY: + if (ws->win == hwnd) + ws->win = NULL; + if (ws->iconwin == hwnd) + ws->iconwin = NULL; + if (ws->refcount > 0) { + PostQuitMessage(0); + return 0; + } + else if (ws->refcount < 0) { + ws->refcount = -ws->refcount; + } + break; + case MM_MCINOTIFY: + mciSendCommand(LOWORD(lp), MCI_CLOSE, 0, (DWORD)NULL); + break; + } + return DefWindowProc(hwnd, msg, wp, lp); +} + +/* + * wclose - make sure the window goes away - no questions asked + */ +int wclose(wbp w) + { + wsp ws = w->window; + if (pollevent() == -1) return -1; + if (ws->win && ws->refcount > 1) { + /* + * Decrement refcount and negate it to tell the window procedure + * that we closed the window, not the user, so don't terminate. + */ + ws->refcount--; + ws->refcount = -ws->refcount; + DestroyWindow(ws->win); + while (ws->win) + if (pollevent() == -1) return -1; + } + else { + free_binding(w); + } + return 1; + } + +int pollevent() + { + wbp w; + MSG m; + int result; + + /* some while PeekMessage loops here, maybe one per window ? */ + while (PeekMessage(&m, NULL, 0, 0, PM_NOREMOVE)) { + if ((result = check_and_get_msg(&m)) <= 0) return result; + TranslateMessage(&m); + DispatchMessage(&m); + } + return 400; + } + +/* + * write some text to both the window and the pixmap + */ +void xdis(w,s,n) +register wbp w; +char *s; +int n; + { + XPoint pt; + HBRUSH hb; + XRectangle rect; + STDLOCALS(w); + + STDFONT; + rect.left = ws->x; rect.right = ws->x + dc_textwidth(pixdc, s, n); + rect.top = ws->y - ASCENT(w); rect.bottom = ws->y + DESCENT(w); + + /* skip resource allocation if we are offscreen */ + if (!(rect.left > ws->width || rect.right < 0 || + rect.top < 0 || rect.bottom > ws->height)) { + + hb = CreateBrushIndirect(&(wc->bgbrush)); + if (stdwin) { + /* + * SetBkColor() does not dither consistently with bgbrush; + * erase the background beforehand and use transparent drawing + */ + FillRect(stddc, &rect, hb); + SetBkMode(stddc, TRANSPARENT); + SetTextColor(stddc, PALCLR(wc->fg)); + TextOut(stddc, ws->x, ws->y - ASCENT(w), s, n); + } + FillRect(pixdc, &rect, hb); + DeleteObject(hb); + SetBkMode(pixdc, TRANSPARENT); + SetTextColor(pixdc, PALCLR(wc->fg)); + TextOut(pixdc, ws->x, ws->y - ASCENT(w), s, n); + } + ws->x += dc_textwidth(pixdc, s, n); + + FREE_STDLOCALS(w); + } +/* + * wputc + */ +int wputc(int ci, wbp w) + { + char c = (char)ci; + wsp ws = w->window; + wcp wc = w->context; + int y_plus_descent; + HBRUSH hb; + + switch (c) { + case '\n': + ws->y += LEADING(w); + if (ws->y + DESCENT(w) > ws->height) { + RECT r; + STDLOCALS(w); + ws->y -= LEADING(w); + y_plus_descent = ws->y + DESCENT(w); + BitBlt(pixdc, 0, 0, + ws->width, y_plus_descent, + pixdc, 0, LEADING(w), SRCCOPY); + r.left = 0; + r.top = y_plus_descent - FHEIGHT(w); + r.right = ws->width; + r.bottom = ws->height; + hb = CreateBrushIndirect(&(wc->bgbrush)); + FillRect(pixdc, &r, hb); + DeleteObject(hb); + if (stdwin) + BitBlt(stddc, 0, 0, ws->width, ws->height, + pixdc, 0, 0, SRCCOPY); + FREE_STDLOCALS(w); + } + /* intended fall-through */ + case '\r': + /* + * set the new x position + */ + ws->x = wc->dx; + break; + case '\t': + xdis(w, " ", 8 - (XTOCOL(w,ws->x) & 7)); + break; + /* + * Handle backspaces. This implements cooked mode echo handling. + */ + case '\177': + case '\010': { + int i = 0, pre_x; + + /* + * Start with the last character queued up. + */ + i--; + /* + * Trot back to the control-H itself. + */ + while ((i>-EQUEUELEN) && (EVQUESUB(w,i) != c)) { + i--; + } + if (i == -EQUEUELEN) break; + /* + * Go past the control-H. + */ + i--; + /* + * Go back through any number of control-H's from prior lifetimes. + */ + while((i > -EQUEUELEN) && !isprint(EVQUESUB(w,i))) { + i--; + } + if (i == -EQUEUELEN) break; + + /* + * OK, here's the character we're actually rubbing out. Back up. + */ + c = EVQUESUB(w,i); + pre_x = ws->x; + ws->x -= TEXTWIDTH(w, &c, 1); + /* + * Physically erase the character from the queue. This results in + * two control-H's present in the queue. + */ + *evquesub(w,i) = '\010'; + /* + * Save the backed-up position, and draw spaces through the erased. + */ + i = ws->x; + while(ws->x < pre_x) { + xdis(w, " ",1); + } + ws->x = i; + break; + } + /* + * bell (control-G) + */ + case '\007': + break; + default: + xdis(w, &c, 1); + } + /* + * turn the cursor back on + */ + UpdateCursorPos(ws,wc); + return 0; + } + +/* + * wgetq - get event from pending queue + */ +int wgetq(wbp w, dptr res) + { + MSG m; + wsp ws; + int first = 0, i = 0, j; + int hascaret = 0; + FILE *f; + + if (!w || !(ws = w->window) || !(ws->iconwin)) { + return -1; + } + while (1) { + /* + * grab the built up queue + */ + if (!EVQUEEMPTY(ws)) { + EVQUEGET(ws, *res); + if (ws->hasCaret) { + HideCaret(ws->iconwin); + DestroyCaret(); + ws->hasCaret = 0; + } + return 1; + } + if (ISCURSORON(w) && ws->hasCaret == 0) { + CreateCaret(ws->iconwin, NULL, FWIDTH(w), FHEIGHT(w)); + SetCaretPos(ws->x, ws->y - ASCENT(w)); + SetCaretBlinkTime(500); + ShowCaret(ws->iconwin); + ws->hasCaret = 1; + } + i++; + if (check_and_get_msg(&m) <= 0) return -1; + TranslateMessage(&m); + DispatchMessage(&m); + } + } + +/* + * determine the new size of the client + */ +int setheight(w, height) +wbp w; +int height; + { + wsp ws = w->window; + ws->height = height; + return Succeeded; + } + +/* + * determine new size of client + */ +int setwidth(w, width) +wbp w; +SHORT width; + { + wsp ws = w->window; + ws->width = width; + return Succeeded; + } + +int setgeometry(w, geo) +wbp w; +char *geo; + { + wsp ws = w->window; + int width = 0, height = 0; + int x = 0, y = 0, status; + if ((status = parsegeometry(geo, &x, &y, &width, &height)) == 0) + return Error; + if (status & 1) { + ws->width = width; + ws->height = height; + } + if (status & 2) { + ws->posx = x; + ws->posy = y; + } + return Succeeded; + } + +int setcanvas(w,s) +wbp w; +char *s; + { + int cmd; + wsp ws = w->window; + HWND stdwin = ws->win; + + if (!strcmp(s, "iconic")) { + cmd = SW_MINIMIZE; + CLRTOBEHIDDEN(ws); + } + else if (!strcmp(s, "normal")) { + cmd = SW_RESTORE; + stdwin = ws->win = ws->iconwin; + CLRTOBEHIDDEN(ws); + } + else if (!strcmp(s, "maximal")) { + cmd = SW_SHOWMAXIMIZED; + stdwin = ws->win = ws->iconwin; + CLRTOBEHIDDEN(ws); + } + else if (!strcmp(s, "hidden")) { + cmd = SW_HIDE; + SETTOBEHIDDEN(ws); + } + else { + return Error; + } + if (stdwin) + ShowWindow(stdwin, cmd); + + return Succeeded; + } + +int seticonicstate(w, val) +wbp w; +char *val; + { + int height; + return Failed; + } + +int seticonlabel(w, val) +wbp w; +char *val; + { + wsp ws = w->window; + if (ws->iconlabel != NULL) free(ws->iconlabel); + ws->iconlabel = salloc(val); + if (ws->win && IsIconic(ws->win)) + SetWindowText(ws->win, ws->iconlabel); + return Succeeded; + } + +int seticonpos(w, val) +wbp w; +char *val; + { + return Failed; + } + + +int setwindowlabel(w, val) +wbp w; +char *val; + { + wsp ws = w->window; + /* + * plug in the new string + */ + if (ws->windowlabel != NULL) + free(ws->windowlabel); + ws->windowlabel = salloc(val); + + /* + * if we have to update, do it + */ + if (ws->win && !IsIconic(ws->win)) + SetWindowText(ws->win, ws->windowlabel); + return Succeeded; + } + +int setcursor(w, on) +wbp w; +int on; + { + wsp ws = w->window; + if (on) { + SETCURSORON(w); + } + else { + CLRCURSORON(w); + } + return Succeeded; + } + +HFONT findfont(char *family, int size, int flags, int ansi) +{ + int weight; + char slant, spacing; + + if (size < 0) size = DEFAULTFONTSIZE; + + if (flags & FONTFLAG_MEDIUM) + weight = FW_MEDIUM; + else if ((flags & FONTFLAG_DEMI) && (flags & FONTFLAG_BOLD)) + weight = FW_DEMIBOLD; + else if (flags & FONTFLAG_BOLD) + weight = FW_BOLD; + else if (flags & FONTFLAG_DEMI) + weight = FW_SEMIBOLD; + else if (flags & FONTFLAG_LIGHT) + weight = FW_LIGHT; + else + weight = FW_DONTCARE; + + if (flags & FONTFLAG_ITALIC) + slant = 1; + else + slant = 0; + + if (flags & FONTFLAG_PROPORTIONAL) + spacing = VARIABLE_PITCH; + else if (flags & FONTFLAG_MONO) + spacing = FIXED_PITCH; + else spacing = DEFAULT_PITCH; + + return CreateFont(size, 0, 0, 0, weight, slant, 0, 0, + (ansi && (MAXBYTESPERCHAR==1)) ? ANSI_CHARSET:DEFAULT_CHARSET, + OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, + spacing, family); +} + +HFONT mkfont(char *s) +{ + int flags, size; + char family[MAXFONTWORD+1]; + char *stdfam = NULL; + HFONT hf = 0; + + if (parsefont(s, family, &flags, &size)) { + /* + * This is a legal Icon font spec. + * Check first for special "standard" family names. + */ + if (!strcmp(family, "mono") || !strcmp(family, "fixed")) { + stdfam = "Lucida Sans"; + flags |= FONTFLAG_MONO + FONTFLAG_SANS; + } + else if (!strcmp(family, "typewriter")) { + stdfam = "Courier New"; /* was "courier" */ + flags |= FONTFLAG_MONO + FONTFLAG_SERIF; + } + else if (!strcmp(family, "sans")) { + stdfam = "Arial"; /* was "swiss" */ + flags |= FONTFLAG_PROPORTIONAL + FONTFLAG_SANS; + } + else if (!strcmp(family, "serif")) { + stdfam = "Times New Roman"; + flags |= FONTFLAG_PROPORTIONAL + FONTFLAG_SERIF; + } + else stdfam = NULL; + + if (stdfam) { + /* + * Standard name: first try preferred family, then generalize. + * ICONFONT can be NULL, in which case Windows chooses. + */ + hf = findfont(stdfam, size, flags, 1); + if (hf == NULL) + hf = findfont(getenv("ICONFONT"), size, flags, 1); + } + else { + /* + * Any other name: must match as specified. + */ + hf = findfont(family, size, flags, 0); + } + } + return hf; +} + +/* + * Set the window's font by name. + */ +int setfont(w, s) +wbp w; +char **s; + { + wsp ws = w->window; + wcp wc = w->context; + HFONT hf, oldfont; + TEXTMETRIC metrics; + HDC tmpdc; + + hf = mkfont(*s); + if (hf != NULL) { + if (wc->font->font) + DeleteObject(wc->font->font); + wc->font->font = hf; + if (wc->font->name) + free(wc->font->name); + wc->font->name = salloc(*s); + + tmpdc = GetDC(ws->iconwin); + oldfont = SelectObject(tmpdc, hf); + wc->font->charwidth = dc_maxcharwidth(tmpdc); + if (GetTextMetrics(tmpdc, &metrics) == 0) { + /* gettextmetrics can fail; what should we do about it? */ + ; + } + SelectObject(tmpdc, oldfont); + ReleaseDC(ws->iconwin, tmpdc); + wc->font->ascent = metrics.tmAscent; + wc->font->descent = metrics.tmDescent; +/* wc->font->charwidth = metrics.tmMaxCharWidth; unreliable due to MS bug */ + wc->leading = wc->font->height = metrics.tmHeight; + return Succeeded; + } + return Failed; + } + +/* + * rebind() - bind w's context to that of w2. + */ +int rebind(w, w2) +wbp w, w2; + { + wsp ws = w->window; + /* decrement w->context->refcount? increment w2->context->refcount? */ + w->context = w2->context; + return Succeeded; + } + +void setclip(w) +wbp w; + { + wcp wc = w->context; + if (wc->cliprgn) + DeleteObject(wc->cliprgn); + if (wc->clipw >= 0) + wc->cliprgn = CreateRectRgn(wc->clipx, wc->clipy, + wc->clipx + wc->clipw, + wc->clipy + wc->cliph); + else + wc->cliprgn = NULL; + } + +void unsetclip(w) +wbp w; + { + wcp wc = w->context; + if (wc->cliprgn) + DeleteObject(wc->cliprgn); + wc->cliprgn = NULL; + } + + int lowerWindow(wbp w) + { + wsp ws = w->window; + if (ws->win) + SetWindowPos(ws->win, HWND_BOTTOM, 0, 0, 0, 0, SWP_NOMOVE | SWP_NOSIZE); + return Succeeded; + } + +int raiseWindow(wbp w) + { + wsp ws = w->window; + if (ws->win) + SetWindowPos(ws->win, HWND_TOP, 0, 0, 0, 0, SWP_NOMOVE | SWP_NOSIZE); + return Succeeded; + } + +int nativecolor(w, s, r, g, b) +wbp w; +char *s; +long *r, *g, *b; + { + return 0; /* no new colors beyond those of Icon */ + } +/* + * convert an Icon linear color into an MS Windows color value + */ +SysColor mscolor(wbp w, long r, long g, long b) +{ + SysColor x; + double invgamma = 1.0 / w->context->gamma; + long int red, green, blue; + + red = 65535L * pow(r / 65535.0, invgamma); + green = 65535L * pow(g / 65535.0, invgamma); + blue = 65535L * pow(b / 65535.0, invgamma); + return RGB(red >> 8, green >> 8, blue >> 8); +} + +/* + * Set the context's fill style by name. + */ +int setfillstyle(w, s) +wbp w; +char *s; + { + wcp wc = w->context; + + if (!strcmp(s, "solid")) { + wc->brush.lbStyle = wc->fillstyle = BS_SOLID; + wc->brush.lbColor = PALCLR(wc->fg); + } + else { + if (!strcmp(s, "masked") + || !strcmp(s, "stippled") || !strcmp(s, "patterned")) { + wc->brush.lbStyle = wc->fillstyle = BS_PATTERN; + wc->brush.lbColor = PALCLR(wc->fg); + wc->brush.lbHatch = (LONG)wc->pattern; + wc->bkmode = TRANSPARENT; + } + else if (!strcmp(s, "textured") + || !strcmp(s, "opaquestippled") || !strcmp(s, "opaquepatterned")) { + wc->brush.lbStyle = wc->fillstyle = BS_PATTERN; + wc->brush.lbColor = PALCLR(wc->fg); + wc->brush.lbHatch = (LONG)wc->pattern; + wc->bkmode = OPAQUE; + } + else { + return Error; + } + } + return Succeeded; + } + +/* + * Set the context's line style by name. + */ +int setlinestyle(w, s) +wbp w; +char *s; + { + wcp wc = w->context; + SHORT ltype; + + if ((ltype = si_s2i(siLineTypes, s)) < 0) + return Error; + wc->pen.lopnStyle = ltype; + resetfg(w); + if(!strcmp(s, "striped")) wc->bkmode = OPAQUE; + else wc->bkmode = TRANSPARENT; + return Succeeded; + } + +/* + * Set the context's line width + */ +int setlinewidth(wbp w, LONG linewid) + { + wcp wc = w->context; + wc->pen.lopnWidth.x = wc->pen.lopnWidth.y = + wc->bgpen.lopnWidth.x = wc->bgpen.lopnWidth.y = linewid; + return Succeeded; + } + + +/* + * Set the foreground to draw in a mutable color + */ +int isetfg(wbp w, int i) + { + char tmp[20]; + wcp wc = w->context; + if (-i > numColors) return Failed; + wc->fg = (0x01000000L | -i); + sprintf(tmp, "%ld", -i); + if (wc->fgname != NULL) free(wc->fgname); + wc->fgname = salloc(tmp); + wc->pen.lopnColor = wc->fg; + wc->brush.lbStyle = BS_SOLID; + wc->brush.lbColor = wc->fg; + return Succeeded; + } + +/* + * Set the context's background color by color cell. + */ +int isetbg(w, i) +wbp w; +int i; + { + char tmp[20]; + wcp wc = w->context; + if (-i > numColors) return Failed; + wc->bg = (0x01000000L | -i); + sprintf(tmp, "%ld", -i); + if (wc->bgname != NULL) free(wc->bgname); + wc->bgname = salloc(tmp); + wc->bgpen.lopnColor = wc->bg; + wc->bgbrush.lbStyle = BS_SOLID; + wc->bgbrush.lbColor = wc->bg; + return ISXORREVERSE(w) ? resetfg(w) : Succeeded; + } + + +int getdepthDC(HDC dc) +{ + return GetDeviceCaps(dc, BITSPIXEL) * GetDeviceCaps(dc, PLANES); +} + +int getdepth(wbp w) +{ + int i, j; + STDLOCALS(w); + i = GetDeviceCaps(pixdc, BITSPIXEL); + j = GetDeviceCaps(pixdc, PLANES); + FREE_STDLOCALS(w); + return i * j; +} + +int devicecaps(wbp w, int i) +{ + int rv; + STDLOCALS(w); + rv = GetDeviceCaps(pixdc, i); + FREE_STDLOCALS(w); + return rv; +} + +/* + * Reset the context's foreground color to whatever it is supposed to be. + */ +int resetfg(w) +wbp w; + { + return setfg(w, w->context->fgname); + } + +int alc_rgb(wbp w, SysColor rgb) +{ + int i; + wsp ws = w->window; + HDC hdc; + PALETTEENTRY pe; + LOGPALETTE lp; + if (palette) { + for (i=0; i < numColors; i++) { + if (rgb == scp[i].c && scp[i].type == SHARED) break; + } + if (i == numColors) { + numColors++; + if (ResizePalette(palette, numColors) == 0) { + numColors--; + return Failed; + } + scp = realloc(scp, numColors * sizeof(struct wcolor)); + if (scp == NULL) { numColors--; return Failed; } + scp[numColors - 1].c = rgb; + scp[numColors - 1].type = SHARED; + sprintf(scp[numColors - 1].name, "%d,%d,%d", + RED(rgb), GREEN(rgb), BLUE(rgb)); + lp.palNumEntries = 1; + lp.palVersion = 0x300; + lp.palPalEntry[0].peFlags = 0; + lp.palPalEntry[0].peRed = RED(rgb); + lp.palPalEntry[0].peGreen = GREEN(rgb); + lp.palPalEntry[0].peBlue = BLUE(rgb); + SetPaletteEntries(palette, numColors - 1, 1, lp.palPalEntry); + hdc = GetDC(ws->iconwin); + SelectPalette(hdc, palette, FALSE); + RealizePalette(hdc); + ReleaseDC(ws->iconwin, hdc); + } + } + return Succeeded; +} + +/* + * Retrieve next message, returning 0 if WM_QUIT, -1 if there is an error. + */ +int check_and_get_msg( MSG *pMsg ) +{ + BOOL result; + if ((result = GetMessage(pMsg, NULL, 0, 0)) <= 0) + { + return (result < 0) ? -1 : 0; + } + return 1; +} + +/* + * Set the context's foreground color + */ +int setfg(wbp w, char *val) + { + long r, g, b; + wcp wc = w->context; + if (parsecolor(w, val, &r, &g, &b) == Succeeded) { + wc->fg = mscolor(w, r, g, b); + if (alc_rgb(w, wc->fg) == Failed) return Failed; + if (!wc->fgname) wc->fgname = salloc(val); + else if (strcmp(wc->fgname, val)) { + free(wc->fgname); + wc->fgname = salloc(val); + } + wc->brush.lbColor = + PALCLR(ISXORREVERSE(w) ? ((wc->fg ^ wc->bg) & 0x00FFFFFF) : wc->fg); + wc->pen.lopnColor = wc->brush.lbColor; + wc->brush.lbStyle = wc->fillstyle; + if (wc->fillstyle == BS_PATTERN) + wc->brush.lbHatch = (LONG)wc->pattern; + return Succeeded; + } + return Failed; + } + +/* + * Set the window context's background color + */ +int setbg(wbp w, char *val) + { + long r, g, b; + wcp wc = w->context; + if (parsecolor(w, val, &r, &g, &b) == Succeeded) { + wc->bg = mscolor(w, r, g, b); + if (alc_rgb(w, wc->bg) == Failed) return Failed; + if (!wc->bgname) wc->bgname = salloc(val); + else if (strcmp(wc->bgname, val)) { + free(wc->bgname); + wc->bgname = salloc(val); + } + wc->bgpen.lopnColor = PALCLR(wc->bg); + wc->bgbrush.lbStyle = BS_SOLID; + wc->bgbrush.lbColor = PALCLR(wc->bg); + return ISXORREVERSE(w) ? resetfg(w) : Succeeded; + } + return Failed; + } + +/* + * Set the gamma correction factor. + */ +int setgamma(w, gamma) +wbp w; +double gamma; + { + wcp wc = w->context; + wc->gamma = gamma; + setfg(w, wc->fgname); + setbg(w, wc->bgname); + return Succeeded; + } + +/* + * setpointer() - define a mouse pointer shape + */ +int setpointer(w, val) +wbp w; +char *val; + { + HCURSOR c; + char *cval; + if (!strcmp(val,"arrow")) cval = IDC_ARROW; + else if (!strcmp(val,"cross")) cval = IDC_CROSS; + else if (!strcmp(val,"ibeam")) cval = IDC_IBEAM; + else if (!strcmp(val,"uparrow")) cval = IDC_UPARROW; + else if (!strcmp(val,"wait")) cval = IDC_WAIT; + else if (!strcmp(val,"starting")) cval = IDC_APPSTARTING; + else if (!strcmp(val,"icon")) cval = IDC_ICON; + else if (!strcmp(val,"size")) cval = IDC_SIZE; + else if (!strcmp(val,"sizenesw")) cval = IDC_SIZENESW; + else if (!strcmp(val,"sizens")) cval = IDC_SIZENS; + else if (!strcmp(val,"sizenwse")) cval = IDC_SIZENWSE; + else if (!strcmp(val,"sizewe")) cval = IDC_SIZEWE; + else if (!strcmp(val,"no")) cval = IDC_NO; + else { + return Failed; + } + c = LoadCursor(NULL, cval); + if (c == NULL) { + return Failed; + } + w->window->curcursor = c; + if (w->window->cursorname) free(w->window->cursorname); + w->window->cursorname = salloc(val); + if (! w->window->savedcursor) + w->window->savedcursor = SetCursor(c); + else (void) SetCursor(c); + /* should restore savedcursor when pointer moves outside our window */ + return Succeeded; + } + +/* + * setdrawop() - set the drawing operation + */ +int setdrawop(w, val) +wbp w; +char *val; + { + wcp wc = w->context; + if (!strcmp(val,"reverse")) { + if (!ISXORREVERSE(w)) { + SETXORREVERSE(w); + wc->drawop = R2_XORPEN; + resetfg(w); + } + } + else { + if (ISXORREVERSE(w)) { + CLRXORREVERSE(w); + resetfg(w); + } + wc->drawop = si_s2i(drawops,val); + if (wc->drawop == -1) { wc->drawop = R2_COPYPEN; return Error; } + } + return Succeeded; + } + +setdisplay(wbp w, char *val) + { + if (strcmp(val, "MS Windows")) + return Failed; + return Succeeded; + } + +setimage(wbp w, char *val) + { + wsp ws = w->window; + int status; + ws->initialPix = loadimage(w, val, &(ws->width), &(ws->height), + 0, &status); + if (ws->initialPix == (HBITMAP) NULL) return Failed; + return Succeeded; + } + +setleading(w, i) +wbp w; +int i; + { + wcp wc = w->context; + wc->leading = i; + } + +void toggle_fgbg(w) +wbp w; + { + SysColor tmp; + LOGPEN tpen; + LOGBRUSH tbrush; + wcp wc = w->context; + tmp = wc->fg; + wc->fg = wc->bg; + wc->bg = tmp; + tpen = wc->pen; + wc->pen = wc->bgpen; + wc->bgpen = tpen; + tbrush = wc->brush; + wc->brush = wc->bgbrush; + wc->bgbrush = tbrush; + } + +int getvisual(w, answer) +wbp w; +char *answer; + { + return Failed; + } + +/* + * getpos() - update the window state's notion of its current position + */ +int getpos(w) +wbp w; + { + return Succeeded; + } + +void getfg(w, answer) +wbp w; +char *answer; + { + strcpy(answer, w->context->fgname); + } + +void getbg(w, answer) +wbp w; +char *answer; + { + strcpy(answer, w->context->bgname); + } + +void getlinestyle(w, answer) +wbp w; +char *answer; + { + wcp wc = w->context; + char *ptr = si_i2s(siLineTypes, wc->pen.lopnStyle); + if (ptr != NULL) { + strcpy(answer, ptr); + } + else strcpy(answer, "unknown"); + } + +void getfntnam(w, answer) +wbp w; +char *answer; + { + strcpy(answer, w->context->font->name); + } + +void getpointername(w, answer) +wbp w; +char *answer; + { + char *s; + wsp ws = w->window; + strcpy(answer, w->window->cursorname); + } + +void getdisplay(wbp w, char *answer) + { + strcpy(answer, "MS Windows"); + } + +void getdrawop(w, answer) +wbp w; +char *answer; + { + char *s; + if (ISXORREVERSE(w)) s = "reverse"; + else s = si_i2s(drawops, w->context->drawop); + if (s) sprintf(answer, "%s", s); + else strcpy(answer, "unknown"); + } + +void geticonic(w, answer) +wbp w; +char *answer; + { + getcanvas(w, answer); + } + +void getcanvas(w, answer) +wbp w; +char *answer; + { + wsp ws = w->window; + if (ws->iconwin) { + if (!IsWindowVisible(ws->iconwin)) sprintf(answer, "hidden"); + else if (IsIconic(ws->iconwin)) sprintf(answer, "iconic"); + else if (IsZoomed(ws->iconwin)) sprintf(answer, "maximal"); + else sprintf(answer,"normal"); + } + else sprintf(answer,"hidden"); + } + +int geticonpos(w, val) +wbp w; +char *val; + { + return Failed; + } + +/* + * erase an area + */ +void eraseArea(w,x,y,width,height) +wbp w; +int x, y, width, height; + { + HBRUSH hb, oldbrush, oldbrush2; + XRectangle rect; + STDLOCALS(w); + hb = CreateBrushIndirect(&(wc->bgbrush)); + if (stdwin) oldbrush = SelectObject(stddc, hb); + oldbrush2 = SelectObject(pixdc, hb); + rect.left = x; rect.right = x + width; + rect.top = y; rect.bottom = y + height; + + if (stdwin) FillRect(stddc, &rect, hb); + FillRect(pixdc, &rect, hb); + if (stdwin) SelectObject(stddc, oldbrush); + SelectObject(pixdc, oldbrush2); + DeleteObject(hb); + FREE_STDLOCALS(w); + } + +/* + * copy an area + */ +int copyArea(w,w2,x,y,width,height,x2,y2) +wbp w, w2; +int x, y, width, height, x2, y2; + { + int lpad, rpad, tpad, bpad; + RECT r; + HDC srcdc, srcpixdc; + HBRUSH hb; + wsp ws1 = w->window; + HBITMAP oldpix; + STDLOCALS(w2); + /* + * setup device contexts for area copy + */ + SetROP2(pixdc, R2_COPYPEN); + hb = CreateBrushIndirect(&(wc->bgbrush)); + if (stdwin) + SetROP2(stddc, R2_COPYPEN); + if (w2->window == w->window) { + srcdc = pixdc; + srcpixdc = pixdc; + } + else { + srcdc = GetDC(w->window->iconwin); + srcpixdc = CreateCompatibleDC(srcdc); + SetROP2(srcpixdc, R2_COPYPEN); + } + oldpix = SelectObject(srcpixdc, w->window->pix); + + /* + * copy area, write unavailable areas with bg color + */ + if (x + width < 0 || y + height < 0 || x >= ws1->pixwidth || y >= ws1->pixheight) { + /* source is entirely offscreen, just fill with background */ + r.left = x2; r.top = y2; + r.right = x2 + width; r.bottom = y2 + height; + if (stdwin) + FillRect(stddc, &r, hb); + FillRect(pixdc, &r, hb); + } + else { + /* + * Check for source partially offscreen, but copy first and + * fill later in case the source and destination overlap. + */ + lpad = rpad = tpad = bpad = 0; + if (x < 0) { /* source extends past left edge */ + lpad = -x; + width -= lpad; + x2 += lpad; + x = 0; + } + if (x + width > ws1->pixwidth) { /* source extends past right edge */ + rpad = x + width - ws1->pixwidth; + width -= rpad; + } + if (y < 0) { /* source extends above top edge */ + tpad = -y; + height -= tpad; + y2 += tpad; + y = 0; + } + if (y + height > ws1->pixheight) { /* source extends below bottom */ + bpad = y + height - ws1->pixheight; + height -= bpad; + } + if (stdwin) + BitBlt(stddc, x2, y2, width, height, srcpixdc, x, y, SRCCOPY); + BitBlt(pixdc, x2, y2, width, height, srcpixdc, x, y, SRCCOPY); + + if (lpad > 0) { + r.left = x2-lpad; + r.top = y2-tpad; + r.right = r.left + lpad; + r.bottom = r.top + tpad+height+bpad; + if (stdwin) + FillRect(stddc, &r, hb); + FillRect(pixdc, &r, hb); + } + if (rpad > 0) { + r.left = x2+width; + r.top = y2-tpad; + r.right = r.left + rpad; + r.bottom = r.top + tpad+height+bpad; + if (stdwin) + FillRect(stddc, &r, hb); + FillRect(pixdc, &r, hb); + } + if (tpad > 0) { + r.left = x2; + r.top = y2-tpad; + r.right = r.left + width; + r.bottom = r.top + tpad; + if (stdwin) + FillRect(stddc, &r, hb); + FillRect(pixdc, &r, hb); + } + if (bpad > 0) { + r.left = x2; + r.top = y2+height; + r.right = r.left + width; + r.bottom = r.top + bpad; + if (stdwin) + FillRect(stddc, &r, hb); + FillRect(pixdc, &r, hb); + } + } + + /* + * free resources + */ + SelectObject(srcpixdc, oldpix); + if (w2->window != w->window) { + ReleaseDC(w->window->iconwin, srcdc); + DeleteDC(srcpixdc); + } + DeleteObject(hb); + FREE_STDLOCALS(w2); + return Succeeded; + } + +int getdefault(w, prog, opt, answer) +wbp w; +char *prog, *opt, *answer; + { + return Failed; + } + +/* + * Draw a bilevel image. + */ +int blimage(w, x, y, width, height, ch, s, len) +wbp w; +int x, y, width, height, ch; +unsigned char *s; +word len; + { + unsigned int m, msk1, c, ix, iy; + long fg, bg; + SysColor palfg, palbg; + STDLOCALS(w); + palfg = PALCLR(wc->fg); + palbg = PALCLR(wc->bg); + /* + * Read the image string and set the pixel values. Note that + * the hex digits in sequence fill the rows *right to left*. + */ + m = width % 4; + if (m == 0) + msk1 = 8; + else + msk1 = 1 << (m - 1); /* mask for first byte of row */ + + fg = wc->fg; + bg = wc->bg; + ix = width; + iy = 0; + m = msk1; + while (len--) { + if (isxdigit(c = *s++)) { /* if hexadecimal character */ + if (!isdigit(c)) /* fix bottom 4 bits if necessary */ + c += 9; + while (m > 0) { /* set (usually) 4 pixel values */ + --ix; + if (c & m) { + SetPixel(pixdc, ix, iy, palfg); + } + else if (ch != TCH1) { /* if zeroes aren't transparent */ + SetPixel(pixdc, ix, iy, palbg); + } + m >>= 1; + } + if (ix == 0) { /* if end of row */ + ix = width; + iy++; + m = msk1; + } + else + m = 8; + } + } + if (ix > 0) /* pad final row if incomplete */ + while (ix < width) + SetPixel(pixdc, ix++, iy, palbg); + + /* + * Put it on the screen. + */ + if (ws->win) + BitBlt(stddc, x, y, width, height, pixdc, x, y, SRCCOPY); + FREE_STDLOCALS(w); + return Succeeded; + } + +/* + * Draw a character-per-pixel image. + */ +int strimage(w, x, y, width, height, e, s, len, on_icon) +wbp w; +int x, y, width, height; +struct palentry *e; +unsigned char *s; +word len; +int on_icon; + { + HDC tempdc; + HBITMAP temppix; + register int c; + register unsigned int ix; + int v, anytransparent=0; + unsigned int iy, tmpw; + SysColor clrlist[256], xc, palbg; + char tmp[24]; + BITMAPINFO *bmi; + BITMAPINFOHEADER *bmih = &(bmi->bmiHeader); + HBITMAP oldpix = 0; + STDLOCALS(w); + + bmi = malloc(sizeof(BITMAPINFO) + 256 * sizeof(SysColor)); + if (bmi == NULL) { + FREE_STDLOCALS(w); + return -1; + } + + bmih = &(bmi->bmiHeader); + palbg = PALCLR(wc->bg); + if (on_icon) { + free(bmi); + FREE_STDLOCALS(w); + return -1; + } + + bmih->biClrImportant = 0; + /* + * Build arrays of colors in SysColor and RGBQUAD format for use by + * either SetPixel or DIB. Decide which to use based on whether + * there are any transparent pixels + */ + for (c = 0; c < 256; c++) { + if (e[c].transpt) anytransparent++; + if (e[c].used && e[c].valid) { + bmih->biClrImportant++; + clrlist[c] = mscolor(w, e[c].clr.red, e[c].clr.green, e[c].clr.blue); + bmi->bmiColors[c].rgbBlue = BLUE(clrlist[c]); + bmi->bmiColors[c].rgbRed = RED(clrlist[c]); + bmi->bmiColors[c].rgbGreen = GREEN(clrlist[c]); + if (alc_rgb(w, clrlist[c]) == Failed) { + free(bmi); + FREE_STDLOCALS(w); + return -1; + } + clrlist[c] = PALCLR(clrlist[c]); + } + else { + bmi->bmiColors[c].rgbBlue = BLUE(wc->bg); + bmi->bmiColors[c].rgbRed = RED(wc->bg); + bmi->bmiColors[c].rgbGreen = GREEN(wc->bg); + } + } + + /* + * if transparent characters are not present, blast out a DIB. + */ + if (anytransparent == 0) { + char *buf = malloc(height * (width+4)), *buf2; + buf2 = buf; + bmih->biSize = sizeof(BITMAPINFOHEADER); + bmih->biWidth = width; + bmih->biHeight = -height; + bmih->biPlanes = 1; + bmih->biBitCount = 8; + bmih->biCompression = BI_RGB; + bmih->biSizeImage = 0; + bmih->biXPelsPerMeter = 0; + bmih->biYPelsPerMeter = 0; + bmih->biClrUsed = 256; + + ix = 0; + while (len--) { + *buf++ = *s++; + if (++ix >= width) { + while(ix % 4) { + buf++; + ix++; + } + ix = 0; + } + } + temppix=CreateDIBitmap(pixdc, bmih, CBM_INIT, buf2, bmi, DIB_RGB_COLORS); + free(buf2); + tempdc = CreateCompatibleDC(stddc); + oldpix = SelectObject(tempdc, temppix); + BitBlt(pixdc, x, y, width, height, tempdc, 0, 0, SRCCOPY); + SelectObject(tempdc, oldpix); + DeleteDC(tempdc); + DeleteObject(temppix); + } + else { + /* + * The image contains some transparent pixels. + * Read the image string and set the pixel values. + * Note that SetPixelV() fails under Win32s; so we don't use it. + */ + ix = x; + iy = y; + tmpw = x + width; + while (len--) { + c = *s++; + v = e[c].valid; + if (v) { /* put char if valid */ + xc = SetPixel(pixdc, ix, iy, clrlist[c]); + } + if (v || e[c].transpt) { /* advance if valid or transparent */ + if (++ix >= tmpw) { + ix = x; /* reset for new row */ + iy++; + } + } + } + if (ix > 0) /* pad final row if incomplete */ + while (ix < width) + SetPixel(pixdc, x+ix++, y+iy, palbg); + } + + free(bmi); + /* + * Copy it from the pixmap onto the screen. + */ + if (on_icon) { + FREE_STDLOCALS(w); + return -1; + } + else { + if (ws->win) + BitBlt(stddc, x, y, width, height, pixdc, x, y, SRCCOPY); + } + FREE_STDLOCALS(w); + return 0; + } + +/* + * imqsearch(key,base,nel) - binary search hardwired for images + * + * A binary search routine with arguments similar to qsort(3). + * Returns a pointer to the item matching "key", or NULL if none. + * This is called a LOT, so it is hardwired for speed. + * Based on Bentley, CACM 28,7 (July, 1985), p. 676. + */ + +SysColor * imqsearch (SysColor key, SysColor *base, int nel) +{ + int l, u, m; + SysColor * a; + + l = 0; + u = nel - 1; + while (l <= u) { + m = (l + u) / 2; + a = base + m; + if (*a < key) + l = m + 1; + else if (*a > key) + u = m - 1; + else + return a; + } + while (a>base && key < *a) a--; + while (a<base+nel && key > *a) a++; + return a; +} + +/* + * capture -- get an image region. + * + * Stores the specified subimage in data as 15-bit color. + */ +int capture(w, xx, yy, width, height, data) +wbp w; +int xx, yy, width, height; +short *data; + { + SysColor px; + int r, g, b, x, y; + int wd = xx + width; + int ht = yy + height; + STDLOCALS(w); + + for (y = yy; y < ht; y++) { + for (x = xx; x < wd; x++) { + px = GetPixel(pixdc, x, y); + r = RED(px) >> 3; + g = GREEN(px) >> 3; + b = BLUE(px) >> 3; + *data++ = (r << 10) | (g << 5) | b; + } + } + FREE_STDLOCALS(w); + return 1; + } + +int readimage(w, filename, x, y, status) +wbp w; +char *filename; +int x, y, *status; + { + HBITMAP p, oldpix; + unsigned int width, height; + HDC srcdc, srcpixdc; + + if (!x && !y) + p = loadimage(w, filename, &width, &height, 1, status); + else + p = loadimage(w, filename, &width, &height, 0, status); + + if (p == (HBITMAP) NULL) { + return Failed; + } + + { + STDLOCALS(w); + + srcdc = GetDC(ws->iconwin); + srcpixdc = CreateCompatibleDC(srcdc); + oldpix = SelectObject(srcpixdc, p); + BitBlt(pixdc, x, y, width, height, srcpixdc, 0, 0, SRCCOPY); + if (stdwin) + BitBlt(stddc, x, y, width, height, srcpixdc, 0, 0, SRCCOPY); + SelectObject(srcpixdc, oldpix); + ReleaseDC(ws->iconwin, srcdc); + DeleteDC(srcpixdc); + + /* + * Make sure previous ops on p are complete, then free it. + */ + DeleteObject(p); + FREE_STDLOCALS(w); + return Succeeded; + } + } + + + +/* + * Initialize client for producing pixels from a window, or in this case, + * only create a device context once, not once per getpixel. + */ +int getpixel_init(w, imem) +wbp w; +struct imgmem *imem; + { + COLORREF *p; + wsp ws = w->window; + int i, j, x2, y2; + HDC stddc = GetDC(ws->iconwin), pixdc = CreateCompatibleDC(stddc); + HBITMAP oldpix; + + if (palette) SelectPalette(pixdc, palette, FALSE); + oldpix = SelectObject(pixdc, ws->pix); + + /* this looks like a bug for Win16 for images > 100x100 or so... */ + imem->crp = malloc( imem->width * imem->height * sizeof(COLORREF)); + if (imem->crp == NULL) return Failed; + p = imem->crp; + x2 = imem->x + imem->width; + y2 = imem->y + imem->height; + for(i = imem->y; i < y2; i++) + for(j = imem->x; j < x2; j++) { + if ((*p++ = GetPixel(pixdc, j, i)) == (COLORREF)-1L) { + free(imem->crp); + SelectObject(pixdc, oldpix); + FREE_STDLOCALS(w); + return Failed; + } + } + SelectObject(pixdc, oldpix); + FREE_STDLOCALS(w); + return Succeeded; + } + +int getpixel_term(w, imem) +wbp w; +struct imgmem *imem; +{ + free(imem->crp); + return Succeeded; +} + +/* + * Return pixel (x,y) from a window + */ +int getpixel(wbp w, int x, int y, long *rv, char *s, struct imgmem *imem) + { + COLORREF cr = imem->crp[(y-imem->y) * imem->width + (x-imem->x)]; + *rv = 1; + sprintf(s, "%ld,%ld,%ld", + (long)RED(cr)*257L, (long)GREEN(cr)*257L, (long)BLUE(cr)*257L); + return Succeeded; + } + +int query_pointer(w, pp) +wbp w; +XPoint *pp; + { + wsp ws = w->window; + RECT r; + if (ws->win) { + GetCursorPos(pp); + GetWindowRect(ws->win, &r); + pp->x -= r.left; + pp->y -= r.top; + return Succeeded; + } + return Failed; + } + +int query_rootpointer(pp) +XPoint *pp; + { + GetCursorPos(pp); + return Succeeded; + } + +int seticonimage(w, dp) +wbp w; +dptr dp; + { + wsp ws = w->window; + return Succeeded; + } + +/* + * dumpimage -- write an image to a disk file. Return 0 on failure. + */ +int dumpimage(wbp w, char *filename, unsigned int x, unsigned int y, + unsigned int width, unsigned int height) + { + int result = 0; + HDIB dib; + HDC destdc; + HBITMAP dumppix, oldpix; + STDLOCALS(w); + + if (strcmp(".bmp", filename + strlen(filename) - 4) && + strcmp(".BMP", filename + strlen(filename) - 4)) { + FREE_STDLOCALS(w); + return NoCvt; + } + + /* + * extract the desired rectangle from the source bitmap + */ + if (x || y || width != ws->pixwidth || height != ws->pixheight) { + dumppix = CreateCompatibleBitmap(stddc, width, height); + destdc = CreateCompatibleDC(stddc); + oldpix = SelectObject(destdc, dumppix); + BitBlt(destdc, 0, 0, width, height, pixdc, x, y, SRCCOPY); + } + else dumppix = ws->pix; + dib = BitmapToDIB(dumppix, palette); + if (dumppix != ws->pix) { + SelectObject(destdc, oldpix); + DeleteDC(destdc); + DeleteObject(dumppix); + } + + if (dib == NULL) { + result = Failed; + } + else { + if (result = SaveDIB(dib, filename)) { /* != 0 implies error */ + result = Failed; + } + else { + result = Succeeded; + } + DestroyDIB(dib); + } + + FREE_STDLOCALS(w); + return result; + } + + +/* + * loadimage + */ +HBITMAP loadimage(wbp w, char *filename, unsigned int *width, + unsigned int *height, int atorigin, int *status) + { + HDC hdc; + HDIB dib; + HBITMAP bmap; + HPALETTE p2; + PALETTEENTRY pe; + LPBITMAPINFO lpbmi; + int j; + int ii,jj, kk; + int xx[256]; + unsigned char * pd; + char *j2; + + dib = LoadDIB(filename); + if (dib != NULL) { + LPSTR pdib; + p2 = CreateDIBPalette(dib); + j2 = GlobalLock(dib); + j = DIBNumColors(j2); + jj = DIBWidth(j2); + kk = DIBHeight(j2); + GlobalUnlock(dib); + + if (!palette) { + LOGPALETTE logpal[4]; /* (1, + space for an extra palette entry) */ + hdc = GetDC(w->window->iconwin); + if ((GetDeviceCaps(hdc, RASTERCAPS) & RC_PALETTE) && (numColors ==0)){ + /* This window is on a device that supports palettes */ + numColors = 2; + logpal[0].palNumEntries = 2; + logpal[0].palVersion = 0x300; + logpal[0].palPalEntry[0].peFlags = 0; + logpal[0].palPalEntry[0].peRed = 0; + logpal[0].palPalEntry[0].peGreen = 0; + logpal[0].palPalEntry[0].peBlue = 0; + logpal[0].palPalEntry[1].peFlags = 0; + logpal[0].palPalEntry[1].peRed = 255; + logpal[0].palPalEntry[1].peGreen = 255; + logpal[0].palPalEntry[1].peBlue = 255; + palette = CreatePalette(logpal); + if (!palette) { + return NULL; + } + if ((scp = malloc(2 * sizeof (struct wcolor))) == NULL) + return NULL; + scp[0].c = RGB(0,0,0); + scp[0].type = SHARED; + strcpy(scp[0].name, "black"); + scp[1].c = RGB(255,255,255); + scp[1].type = SHARED; + strcpy(scp[1].name, "white"); + } + else { + /* this window is not on a device that supports palettes */ + } + ReleaseDC(w->window->iconwin, hdc); + } + if (palette) { + if (ResizePalette(palette, numColors + j) == 0) { + return NULL; + } + for (ii = 0; ii < j; ii++) { + if (GetPaletteEntries(p2, ii, 1, &pe) == 0) { + return NULL; + } + SetPaletteEntries(palette, numColors++, 1, &pe); + } + } + bmap = DIBToBitmap(dib, palette); + pdib = GlobalLock(dib); + *width = DIBWidth(pdib); + *height = DIBHeight(pdib); + GlobalUnlock(dib); + DestroyDIB(dib); + DeleteObject(p2); + *status = 0; + return bmap; + } + return NULL; + } + + +char *get_mutable_name(wbp w, int mute_index) + { + char *tmp; + PALETTEENTRY pe; + + if (-mute_index > numColors || scp[-mute_index].type != MUTABLE) { + return NULL; + } + + if (GetPaletteEntries(palette, -mute_index, 1, &pe) == 0) { + return NULL; + } + tmp = scp[-mute_index].name; + sprintf(tmp, "%d", mute_index); + sprintf(tmp + strlen(tmp) + 1, "%d,%d,%d", + (pe.peRed << 8) | 0xff, (pe.peGreen << 8) | 0xff, (pe.peBlue << 8) | 0xff); + return tmp + strlen(tmp) + 1; + } + +int set_mutable(wbp w, int i, char *s) + { + long r, g, b; + UINT rv; + PALETTEENTRY pe; + if (palette == 0) return Failed; + + { + STDLOCALS(w); + if (parsecolor(w, s, &r, &g, &b) != Succeeded) { + FREE_STDLOCALS(w); + return Failed; /* invalid color specification */ + } + pe.peRed = r >> 8; + pe.peGreen = g >> 8; + pe.peBlue = b >> 8; + pe.peFlags = PC_RESERVED; + raiseWindow(w); /* mutable won't mutate if window isn't active */ +#if 1 + AnimatePalette(palette, -i, 1, &pe); + rv = SetPaletteEntries(palette, -i, 1, &pe); +#endif + UnrealizeObject(palette); + RealizePalette(stddc); + AnimatePalette(palette, -i, 1, &pe); + FREE_STDLOCALS(w); +} + return Succeeded; + } + +void free_mutable(wbp w, int mute_index) + { + } + +/* + * Allocate a mutable color + */ +int mutable_color(wbp w, dptr argv, int argc, int *retval) + { + long r, g, b; + tended char *str; + LOGPALETTE lp; + { + STDLOCALS(w); + + if (!stddc || ((GetDeviceCaps(stddc, RASTERCAPS) & RC_PALETTE) == 0)) { + FREE_STDLOCALS(w); + return Failed; + } + + numColors++; + scp = realloc(scp, numColors * sizeof(struct wcolor)); + if (scp == NULL) { + FREE_STDLOCALS(w); + return Failed; + } + scp[numColors-1].c = -(numColors-1); + sprintf(scp[numColors-1].name, "%d:", -(numColors-1)); + scp[numColors-1].type = MUTABLE; + if (ResizePalette(palette, numColors) == 0) { + FREE_STDLOCALS(w); + return Failed; + } + + if (argc > 0) { /* set the color */ + if (argc != 1) { + FREE_STDLOCALS(w); + return Error; + } + /* + * old-style check for C integer + */ + else if (argv[0].dword == D_Integer) {/* check for color cell */ + if (IntVal(argv[0]) >= 0) { + FREE_STDLOCALS(w); + return Failed; /* must be negative */ + } + if (GetPaletteEntries(palette, -IntVal(argv[0]), + 1, lp.palPalEntry) == 0) { + FREE_STDLOCALS(w); + return Error; + } + /* convert to linear color? */ + } + else { + if (!cnv:C_string(argv[0],str)) { + FREE_STDLOCALS(w); + ReturnErrVal(103,argv[0], Error); + } + if (parsecolor(w, str, &r, &g, &b) != Succeeded) { + /* reduce logical palette size and count */ + FREE_STDLOCALS(w); + numColors--; + ResizePalette(palette, numColors); + return Failed; /* invalid color specification */ + } + lp.palPalEntry[0].peRed = r >> 8; + lp.palPalEntry[0].peGreen = g >> 8; + lp.palPalEntry[0].peBlue = b >> 8; + } + lp.palNumEntries = 1; + lp.palVersion = 0x300; + lp.palPalEntry[0].peFlags = PC_RESERVED; + SetPaletteEntries(palette, numColors - 1, 1, lp.palPalEntry); + UnrealizeObject(palette); + RealizePalette(stddc); + } + + *retval = -(numColors - 1); + FREE_STDLOCALS(w); + return Succeeded; + } + } + +void freecolor(wbp w, char *s) + { + } + +/* + * drawarcs() - assumes x and y are already fixed up for the bitmap + */ +void drawarcs(wbp wb, XArc *arcs, int narcs) + { + register XArc *arc = arcs; + int i, halfwidth, halfheight, x1, y1, x2, y2, right, bottom; + double a1_a2; + HPEN hp, oldpen, oldpen2; + STDLOCALS(wb); + hp = CreatePenIndirect(&(wc->pen)); + if (stdwin) oldpen = SelectObject(stddc, hp); + oldpen2 = SelectObject(pixdc, hp); + for (i = 0; i < narcs; i++, arc++) { + halfwidth = arc->width >> 1; + halfheight = arc->height >> 1; + arc->angle1 = -arc->angle1 - arc->angle2; + a1_a2 = arc->angle1 + arc->angle2; + x1 = arc->x + halfwidth + (int)(halfwidth * cos(arc->angle1)); + y1 = arc->y + halfheight - (int)(halfheight * sin(arc->angle1)); + x2 = arc->x + halfwidth + (int)(halfwidth * cos(a1_a2)); + y2 = arc->y + halfheight - (int)(halfheight * sin(a1_a2)); + right = arc->x + arc->width + 1; + bottom = arc->y + arc->height + 1; + if (ws->win) + Arc(stddc, arc->x, arc->y, right, bottom, x1, y1, x2, y2); + Arc(pixdc, arc->x, arc->y, right, bottom, x1, y1, x2, y2); + } + if (stdwin) SelectObject(stddc, oldpen); + SelectObject(pixdc, oldpen2); + DeleteObject(hp); + FREE_STDLOCALS(wb); + return; + } + + +/* + * drawlines - Support routine for DrawLine + */ +void drawlines(wbinding *wb, XPoint *points, int npoints) + { + int i, diff, bheight; + HPEN hp, oldpen, oldpen2; + XPoint tmp[2]; + STDLOCALS(wb); + hp = CreatePenIndirect(&(wc->pen)); + if (stdwin) oldpen = SelectObject(stddc, hp); + oldpen2 = SelectObject(pixdc, hp); + tmp[0] = points[npoints-1]; + tmp[1] = points[npoints-2]; + if (ws->win) { + SetBkMode(stddc, wc->bkmode); + Polyline(stddc, points, npoints); + Polyline(stddc, tmp, 2); + } + SetBkMode(pixdc, wc->bkmode); + Polyline(pixdc, points, npoints); + Polyline(pixdc, tmp, 2); + if (stdwin) SelectObject(stddc, oldpen); + SelectObject(pixdc, oldpen2); + DeleteObject(hp); + FREE_STDLOCALS(wb); + return; + } + + +/* + * drawpoints() - + * Parameters - the window binding for output, an array of points (assumed + * to be fixed up for bitmap) and the number of points + */ +void drawpoints(wbinding *wb, XPoint *points, int npoints) + { + register XPoint *p, *endp; + SysColor palfg; + STDLOCALS(wb); + endp = points + npoints; + palfg = PALCLR(wc->fg); + if (stdwin) { + for(p = points; p < endp; p++) { + SetPixel(stddc, p->x, p->y, palfg); + SetPixel(pixdc, p->x, p->y, palfg); + } + } + else { + for(p = points; p < endp; p++) { + SetPixel(pixdc, p->x, p->y, palfg); + } + } + FREE_STDLOCALS(wb); + return; + } + + +/* + * drawsegments() - + */ +void drawsegments(wbinding *wb, XSegment *segs, int nsegs) + { + int i, bheight; + XPoint ps[2]; + HPEN hp, oldpen, oldpen2; + STDLOCALS(wb); + hp = CreatePenIndirect(&(wc->pen)); + if (stdwin) oldpen = SelectObject(stddc, hp); + oldpen2 = SelectObject(pixdc, hp); + if (stdwin) { + SetBkMode(stddc, wc->bkmode); + for (i = 0; i < nsegs; i++) { + Polyline(stddc, (POINT *)(segs+i), 2); + } + } + SetBkMode(pixdc, wc->bkmode); + for (i = 0; i < nsegs; i++) { + Polyline(pixdc, (POINT *)(segs+i), 2); + } + if (stdwin) SelectObject(stddc, oldpen); + SelectObject(pixdc, oldpen2); + DeleteObject(hp); + FREE_STDLOCALS(wb); + return; + } + + +int allowresize(w, on) +wbp w; +int on; + { + if (on) + SETRESIZABLE(w); + else + CLRRESIZABLE(w); + return Succeeded; + } +int getselection(wbp w, char *buf) +{ + return Failed; + } +int setselection(wbp w, char *val) +{ + return Failed; + } + +/* + * drawstrng() + */ +void drawstrng(wbinding *wb, int x, int y, char *s, int slen) + { + STDLOCALS(wb); + + STDFONT; + if (stdwin) { + SetBkMode(stddc, TRANSPARENT); + if (wc->fg != RGB(0, 0, 0)) SetTextColor(stddc, PALCLR(wc->fg)); + if (wc->bg != RGB(255, 255, 255)) SetBkColor(stddc, PALCLR(wc->bg)); + TextOut(stddc, x, y - ASCENT(wb), s, slen); + } + SetBkMode(pixdc, TRANSPARENT); + if (wc->fg != RGB(0, 0, 0)) SetTextColor(pixdc, PALCLR(wc->fg)); + if (wc->bg != RGB(255, 255, 255)) SetBkColor(pixdc, PALCLR(wc->bg)); + TextOut(pixdc, x, y - ASCENT(wb), s, slen); + + FREE_STDLOCALS(wb); + return; + } + + +/* + * fillarcs + */ +void fillarcs(wbp wb, XArc *arcs, int narcs) + { + register XArc *arc = arcs; + int i, diff, bheight; + HBRUSH hb, oldbrush, oldbrush2; + POINT pts[3]; + HPEN hp, oldpen, oldpen2; + STDLOCALS(wb); + hp = CreatePenIndirect(&(wc->pen)); + if (stdwin) oldpen = SelectObject(stddc, hp); + oldpen2 = SelectObject(pixdc, hp); + hb = CreateBrushIndirect(&(wc->brush)); + if (stdwin) oldbrush = SelectObject(stddc, hb); + oldbrush2 = SelectObject(pixdc, hb); + SetTextColor(pixdc, PALCLR(wc->fg)); + if (stdwin) SetTextColor(stddc, PALCLR(wc->fg)); + SetBkColor(pixdc, PALCLR(wc->bg)); + if (stdwin) SetBkColor(stddc, PALCLR(wc->bg)); + if (stdwin) SetBkMode(stddc, wc->bkmode); + SetBkMode(pixdc, wc->bkmode); + for (i = 0; i < narcs; i++, arc++) { + if (arc->angle2 >= 2 * Pi) { + /* + * from SDK reference: Ellipse() draws up to but not including + * the right and bottom coordinates. Add +1 to compensate. + */ + if (stdwin) + Ellipse(stddc, arc->x, arc->y, + arc->x + arc->width + 1, arc->y + arc->height + 1); + Ellipse(pixdc, arc->x, arc->y, + arc->x + arc->width + 1, arc->y + arc->height + 1); + } + else { + arc->angle1 = -arc->angle1 - arc->angle2; + pts[0].x = arc->x + (arc->width>>1); + pts[0].y = arc->y + (arc->height>>1); + pts[1].x = arc->x + (arc->width>>1) + + (int)(((arc->width + 1)>>1) * cos(arc->angle1)); + pts[1].y = arc->y + (arc->height>>1) - + (int)(((arc->height )>>1) * sin(arc->angle1)); + pts[2].x = arc->x + (arc->width>> 1) + + (int)(((arc->width + 1)>>1) * cos(arc->angle1+arc->angle2)); + pts[2].y = arc->y + (arc->height>>1) - + (int)(((arc->height )>>1) * sin(arc->angle1+arc->angle2)); + if (stdwin) { + Pie(stddc, arc->x, arc->y, + arc->x + arc->width + 1, arc->y + arc->height + 1, + pts[1].x, pts[1].y, pts[2].x, pts[2].y); + } + Pie(pixdc, arc->x, arc->y, + arc->x + arc->width + 1, arc->y + arc->height + 1, + pts[1].x, pts[1].y, pts[2].x, pts[2].y); + } + } + if (stdwin) SelectObject(stddc, oldpen); + SelectObject(pixdc, oldpen2); + DeleteObject(hp); + if (stdwin) SelectObject(stddc, oldbrush); + SelectObject(pixdc, oldbrush2); + DeleteObject(hb); + FREE_STDLOCALS(wb); + return; + } + +/* + * fillrectangles + */ +void fillrectangles(wbp wb, XRectangle *recs, int nrecs) + { + int i, diff, bheight; + HBRUSH hb, oldbrush, oldbrush2; + HPEN hp, oldpen, oldpen2; + STDLOCALS(wb); + hp = CreatePenIndirect(&(wc->pen)); + if (stdwin) oldpen = SelectObject(stddc, hp); + oldpen2 = SelectObject(pixdc, hp); + hb = CreateBrushIndirect(&(wc->brush)); + if (stdwin) oldbrush = SelectObject(stddc, hb); + oldbrush2 = SelectObject(pixdc, hb); + SetTextColor(pixdc, PALCLR(wc->fg)); + if (stdwin) SetTextColor(stddc, PALCLR(wc->fg)); + SetBkColor(pixdc, PALCLR(wc->bg)); + if (stdwin) SetBkColor(stddc, PALCLR(wc->bg)); + if (stdwin) SetBkMode(stddc, wc->bkmode); + SetBkMode(pixdc, wc->bkmode); + for (i = 0; i < nrecs; i++) { + recs[i].right += recs[i].left; + recs[i].bottom += recs[i].top; + if (stdwin) FillRect(stddc, (recs+i), hb); + FillRect(pixdc, (recs+i), hb); + } + if (stdwin) SelectObject(stddc, oldpen); + SelectObject(pixdc, oldpen2); + DeleteObject(hp); + if (stdwin) SelectObject(stddc, oldbrush); + SelectObject(pixdc, oldbrush2); + DeleteObject(hb); + FREE_STDLOCALS(wb); + return; + } + + +/* + * drawrectangles - draw nrecs # of rectangles in array recs to binding w + */ +void drawrectangles(wbp w, XRectangle *recs, int nrecs) + { + register XRectangle *r; + LOGBRUSH lb; + HBRUSH hb, oldbrush, oldbrush2; + HPEN hp, oldpen, oldpen2; + STDLOCALS(w); + hp = CreatePenIndirect(&(wc->pen)); + if (stdwin) oldpen = SelectObject(stddc, hp); + oldpen2 = SelectObject(pixdc, hp); + lb.lbStyle = BS_NULL; + hb = CreateBrushIndirect(&lb); + if (stdwin) oldbrush = SelectObject(stddc, hb); + oldbrush2 = SelectObject(pixdc, hb); + for (r = recs; r < recs + nrecs; r++) { + /* + * from SDK reference: Rectangle() draws up to but not including + * the right and bottom coordinates. Add +1 to compensate. + */ + r->right += r->left + 1; + r->bottom += r->top + 1; + if (stdwin) Rectangle(stddc, r->left, r->top, r->right, r->bottom); + Rectangle(pixdc, r->left, r->top, r->right, r->bottom); + } + if (stdwin) SelectObject(stddc, oldpen); + SelectObject(pixdc, oldpen2); + DeleteObject(hp); + if (stdwin) SelectObject(stddc, oldbrush); + SelectObject(pixdc, oldbrush2); + DeleteObject(hb); + FREE_STDLOCALS(w); + return; + } + +/* + * fillpolygon + */ +void fillpolygon(wbp w, XPoint *pts, int npts) + { + HBRUSH hb, oldbrush; + HPEN hp, oldpen, oldpen2; + STDLOCALS(w); + if (stdwin) SetBkMode(stddc, wc->bkmode); + SetBkMode(pixdc, wc->bkmode); + hp = CreatePenIndirect(&(wc->pen)); + if (stdwin) oldpen = SelectObject(stddc, hp); + oldpen2 = SelectObject(pixdc, hp); + hb = CreateBrushIndirect(&(wc->brush)); + if (stdwin) { + oldbrush = SelectObject(stddc, hb); + Polygon(stddc, pts, npts); + SelectObject(stddc, oldbrush); + } + oldbrush = SelectObject(pixdc, hb); + Polygon(pixdc, pts, npts); + SelectObject(pixdc, oldbrush); + DeleteObject(hb); + if (stdwin) SelectObject(stddc, oldpen); + SelectObject(pixdc, oldpen2); + DeleteObject(hp); + FREE_STDLOCALS(w); + } + +LONG NumWindows = 0; + + +/* + * allocate a context. Can't be called until w has a display and window. + */ +wcp alc_context(w) +wbp w; + { + int i; + wcp wc; + + GRFX_ALLOC(wc, _wcontext); + + wc->bkmode = OPAQUE; /* at present, only used in line drawing */ + wc->fg = RGB(0,0,0); + wc->bg = RGB(255,255,255); + wc->fgname = salloc("black"); + wc->bgname = salloc("white"); + wc->pen.lopnStyle = PS_SOLID; + wc->pen.lopnWidth.x = wc->pen.lopnWidth.y = 1; + wc->pen.lopnColor = PALCLR(wc->fg); + wc->bgpen.lopnStyle = PS_SOLID; + wc->bgpen.lopnWidth.x = wc->bgpen.lopnWidth.y = 1; + wc->bgpen.lopnColor = PALCLR(wc->bg); + wc->fillstyle = BS_SOLID; + wc->brush.lbStyle = BS_SOLID; + wc->brush.lbColor = PALCLR(wc->fg); + wc->bgbrush.lbStyle = BS_SOLID; + wc->bgbrush.lbColor = PALCLR(wc->bg); + wc->gamma = GammaCorrection; + wc->drawop = R2_COPYPEN; + wc->font = (wfp)alloc(sizeof (struct _wfont)); + wc->font->name = salloc("fixed"); + wc->font->font = CreateFont(16,0,0,0,FW_NORMAL,0,0,0, + ((MAXBYTESPERCHAR==1)?ANSI_CHARSET:DEFAULT_CHARSET), + OUT_DEFAULT_PRECIS,CLIP_DEFAULT_PRECIS, + DEFAULT_QUALITY, FIXED_PITCH | FF_MODERN, + getenv("ICONFONT")); + + wc->font->charwidth = 8; /* looks like a bug */ + wc->leading = 16; + + GRFX_LINK(wc, wcntxts); + return wc; + } + +/* + * allocate a context, cloning attributes from an existing context + */ +wcp clone_context(w) +wbp w; + { + wcp wc, wc2 = w->context; + wsp ws = w->window; + wbinding tmp; + int i; + + GRFX_ALLOC(wc, _wcontext); + + tmp.window = ws; + tmp.context = wc; + /* + * copy over some stuff + */ + wc->clipx = wc2->clipx; + wc->clipy = wc2->clipy; + wc->clipw = wc2->clipw; + wc->cliph = wc2->cliph; + if (wc2->cliprgn) + wc->cliprgn = CreateRectRgn(wc->clipx,wc->clipy, + wc->clipx+wc->clipw, + wc->clipy+wc->cliph); + wc->dx = wc2->dx; + wc->dy = wc2->dy; + wc->bits = wc2->bits; + /* + * clone needs to make a copy of the pattern + * if (wc2->pattern) { + * wc->pattern = copy+somehow(wc2->pattern); + * if (wc2->patternname) + * wc->patternname = salloc(wc2->patternname); + * } + */ + + wc->bkmode = wc2->bkmode; + wc->fg = wc2->fg; + wc->bg = wc2->bg; + wc->fgname = salloc(wc2->fgname); + wc->bgname = salloc(wc2->bgname); + wc->pen = wc2->pen; + if (ISXORREVERSEW(wc)) { + wc->brush.lbColor = PALCLR((wc->fg ^ wc->bg) & 0x00FFFFFF); + } + else { + wc->brush.lbColor = PALCLR(wc->fg); + } + wc->bgpen = wc2->bgpen; + wc->fillstyle = wc2->fillstyle; + wc->brush.lbStyle = wc->fillstyle; + wc->bgbrush.lbStyle = wc->fillstyle; + wc->bgbrush.lbColor = PALCLR(wc->bg); + wc->gamma = wc2->gamma; + wc->drawop = wc2->drawop; + wc->font = (wfp)alloc(sizeof (struct _wfont)); + wc->font->name = salloc("fixed"); + wc->font->font = CreateFont(13,0,0,0,FW_NORMAL,0,0,0, + ((MAXBYTESPERCHAR==1)?ANSI_CHARSET:DEFAULT_CHARSET), + OUT_DEFAULT_PRECIS,CLIP_DEFAULT_PRECIS, + DEFAULT_QUALITY, FIXED_PITCH | FF_MODERN, + getenv("ICONFONT")); + wc->leading = wc2->leading; + setfont(&tmp, &(wc2->font->name)); + + GRFX_LINK(wc, wcntxts); + return wc; + } + +/* + * allocate a window state structure + */ +wsp alc_winstate() + { + int i; + wsp ws; + + GRFX_ALLOC(ws, _wstate); + ws->bits = 1024; /* echo ON; others OFF */ + ws->filep = nulldesc; + ws->listp = nulldesc; + ws->cursorname = salloc("arrow"); + ws->curcursor = LoadCursor(NULL, IDC_ARROW); + GRFX_LINK(ws, wstates); + return ws; + } + +/* + * free a window state + */ +int free_window(ws) +wsp ws; + { + int i; + ws->refcount--; + if(ws->refcount == 0) { + if (ws->win) /* && IsWindowVisible(ws->win))*/ + DestroyWindow(ws->win); +/* ws->win = 0;*/ + if (ws->iconwin && ws->iconwin != ws->win) { + if (IsWindowVisible(ws->iconwin)) + DestroyWindow(ws->iconwin); + else DestroyWindow(ws->iconwin); + } +/* ws->iconwin = 0;*/ +/* while (ws->win) + if (pollevent() == -1) return -1; +*/ + if (ws->windowlabel) free(ws->windowlabel); + if (ws->iconlabel) free(ws->iconlabel); + if (ws->pix) + DeleteObject(ws->pix); + ws->pix = 0; + if (ws->iconpix) + DeleteObject(ws->iconpix); + ws->iconpix = 0; + if (ws->initialPix) + DeleteObject(ws->initialPix); + ws->initialPix = 0; + /* need to enumerate and specifically free each string */ + if (ws->menuMap) { + for(i=0;i<ws->nmMapElems;i++) free(ws->menuMap[i]); + free(ws->menuMap); + ws->menuMap = 0; + } + free(ws->cursorname); + if (ws->child) { + for(i=0;i<ws->nChildren;i++) { + free(ws->child[i].id); + if (ws->child[i].font) DeleteObject(ws->child[i].font); + } + free(ws->child); + } + ws->child = 0; + GRFX_UNLINK(ws, wstates); + } + return 0; + } + +/* + * free a window context + */ +void free_context(wc) +wcp wc; + { + wc->refcount--; + if(wc->refcount == 0) { + if (wc->cliprgn) + DeleteObject(wc->cliprgn); + wc->cliprgn = 0; + if (wc->pattern) + DeleteObject(wc->pattern); + wc->pattern = 0; + if (wc->patternname) + free(wc->patternname); + wc->patternname = 0; + if (wc->fgname) free(wc->fgname); + wc->fgname = 0; + if (wc->bgname) free(wc->bgname); + wc->bgname = 0; + if (wc->font) { + if (wc->font->font) + DeleteObject(wc->font->font); + wc->font->font = 0; + if (wc->font->name) + free(wc->font->name); + wc->font->name = 0; + free(wc->font); + } + wc->font = 0; + GRFX_UNLINK(wc, wcntxts); + } + } + +int walert(wbp w, int volume) + { + MessageBeep(0); + } + +int patbits[] = { + 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF, + 0xFE,0xFF,0xEF,0xFF,0xFE,0xFF,0xEF,0xFF, + 0x77,0xDD,0x77,0xDD,0x77,0xDD,0x77,0xDD, + 0x55,0xAA,0x55,0xAA,0x55,0xAA,0x55,0xAA, + 0x11,0x44,0x11,0x44,0x11,0x44,0x11,0x44, + 0x01,0x00,0x10,0x00,0x01,0x00,0x10,0x00, + 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, + + 0x10,0x10,0x10,0x10,0x10,0x10,0x10,0x10, + 0x80,0x40,0x20,0x10,0x08,0x04,0x02,0x01, + 0x00,0x00,0x00,0xFF,0x00,0x00,0x00,0x00, + 0x10,0x10,0x10,0xFF,0x10,0x10,0x10,0x10, + 0x82,0x44,0x28,0x10,0x28,0x44,0x82,0x01, + + 0x0F,0x0F,0x0F,0x0F,0xF0,0xF0,0xF0,0xF0, + 0x1B,0x18,0x81,0xB1,0x36,0x06,0x60,0x63, + 0x02,0x02,0x05,0xF8,0x20,0x20,0x50,0x8F, + 0x03,0x84,0x48,0x30,0x03,0x84,0x48,0x30, +}; + +/* + * SetPattern + */ +int SetPattern(w, name, len) +wbp w; +char *name; +int len; + { + int width, nbits; + int i, j; + int symbol; + C_integer v, bits[MAXXOBJS]; + HBITMAP p; + char data[MAXXOBJS]; + char *buf = data; + wcp wc = w->context; + + if (wc->patternname != NULL) + free(wc->patternname); + wc->patternname = malloc(len+1); + strncpy(wc->patternname, name, len); + wc->patternname[len] = '\0'; + + /* + * If the pattern starts with a number it is a width , bits encoding + */ + if ((len > 0) && isdigit(name[0])) { + nbits = MAXXOBJS; + switch (parsepattern(name, len, &width, &nbits, bits)) { + case Failed: + return Failed; + case Error: + ReturnErrNum(145, Error); + } + if (w->window->iconwin == NULL) return Succeeded; + return SetPatternBits(w, width, bits, nbits); + } + + /* + * Otherwise, it is a named pattern. Find the symbol id. + */ + if ((symbol = si_s2i(siPatternSyms, wc->patternname)) >= 0) { + if (w->window->iconwin == NULL) return Succeeded; + for(i = 0; i < 8; i++) { + v = reversebits(~(patbits[symbol * 8 + i])); + *buf++ = v; + } + p = CreateBitmapFromData(data); + if (wc->pattern) + DeleteObject(wc->pattern); + wc->pattern = p; + if (wc->fillstyle == BS_PATTERN) { + wc->brush.lbStyle = BS_PATTERN; + wc->brush.lbColor = PALCLR(wc->fg); + wc->brush.lbHatch = (LONG)p; + } + return Succeeded; + } + ReturnErrNum(145, Error); + } + +/* + * Create an 8x8 bitmap from some data + */ +HBITMAP CreateBitmapFromData(char *data) +{ + WORD *wBits = alloc(8 * sizeof(WORD)); + HBITMAP rv; + int i; + static BITMAP bitmap = { 0, 8, 8, 2, 1, 1}; + for (i = 0; i < 8; i++) + wBits[i] = data[i]; + bitmap.bmBits = (LPSTR) wBits; + rv = CreateBitmapIndirect(&bitmap); + free(wBits); + return rv; +} + + +int SetPatternBits(w, width, bits, nbits) +wbp w; +int width; +C_integer *bits; +int nbits; + { + C_integer v; + int i, j, k; + HBITMAP p; + char data[MAXXOBJS]; + char *buf = data; + wcp wc = w->context; + + if (width != nbits) + return Failed; + + if (width == 8) { + for(i = 0; i < nbits; i++) { + v = bits[i]; + *buf++ = reversebits(~v); + } + } + else if (width == 4) { + for(k=0; k < 2; k++) /* do twice to get 8 rows */ + for(i = 0; i < nbits; i++) { + v = widenbits(bits[i]); + *buf++ = reversebits(~v); + } + } + else return Failed; + + p = CreateBitmapFromData(data); + if (wc->pattern) + DeleteObject(wc->pattern); + wc->pattern = p; + if (wc->fillstyle == BS_PATTERN) { + wc->brush.lbStyle = BS_PATTERN; + wc->brush.lbColor = PALCLR(wc->fg); + wc->brush.lbHatch = (LONG)p; + } + return Succeeded; + } + +int widenbits(int c) +{ + int rv = c; + if (c & 1) rv |= 16; + if (c & 2) rv |= 32; + if (c & 4) rv |= 64; + if (c & 8) rv |= 128; + return rv; +} + +int reversebits(int c) +{ + int rv = 0; + if (c & 1) rv |= 128; + if (c & 2) rv |= 64; + if (c & 4) rv |= 32; + if (c & 8) rv |= 16; + if (c & 16) rv |= 8; + if (c & 32) rv |= 4; + if (c & 64) rv |= 2; + if (c & 128) rv |= 1; + return rv; +} + +int pixmap_init(w) +wbp w; + { + wsp ws = w->window; + resizePixmap(w, ws->width, ws->height); + return Succeeded; + } + + +int do_config(w, status) +wbp w; +int status; + { + wsp ws = w->window; + int wid = ws->width, ht = ws->height; + int posx = ws->posx, posy = ws->posy; + if (! resizePixmap(w, wid, ht)) + return Failed; + if (ws->win) { + pollevent(); + if (status == 3) { + SetWindowPos(ws->win, ws->win, + posx, + posy, + wid, ht, SWP_NOZORDER); + } + else if (status == 2) { + SetWindowPos(ws->win, ws->win, 0, 0, + wid, ht, SWP_NOMOVE|SWP_NOZORDER); + } + else if (status == 1) + SetWindowPos(ws->win, ws->win, + posx, + posy, + 0, 0, SWP_NOSIZE|SWP_NOZORDER); + } + else if (ws->iconwin) { + if (status == 3) { + SetWindowPos(ws->iconwin, ws->iconwin, + posx, + posy, + wid, ht, SWP_NOZORDER); + } + else if (status == 2) { + SetWindowPos(ws->iconwin, ws->iconwin, 0, 0, + wid, ht, SWP_NOMOVE|SWP_NOZORDER); + } + else if (status == 1) + SetWindowPos(ws->iconwin, ws->iconwin, + posx, + posy, + 0, 0, SWP_NOSIZE|SWP_NOZORDER); + } + return Succeeded; + } + +DWORD playMIDIfile(HWND hWndNotify, LPSTR s) +{ + UINT wDeviceID; + DWORD dwReturn; + MCI_OPEN_PARMS mciOpenParms; + MCI_PLAY_PARMS mciPlayParms; + MCI_STATUS_PARMS mciStatusParms; + MCI_SEQ_SET_PARMS mciSeqSetParms; + + mciOpenParms.lpstrDeviceType = "sequencer"; + mciOpenParms.lpstrElementName = s; + if (dwReturn = mciSendCommand((UINT)NULL, MCI_OPEN, + MCI_OPEN_TYPE | MCI_OPEN_ELEMENT, + (DWORD)(LPVOID) &mciOpenParms)) { + return dwReturn; + } + wDeviceID = mciOpenParms.wDeviceID; + + /* attempt to select the MIDI mapper */ + mciSeqSetParms.dwPort = MIDI_MAPPER; + if (dwReturn = mciSendCommand(wDeviceID, MCI_SET, MCI_SEQ_SET_PORT, + (DWORD)(LPVOID) &mciSeqSetParms)) { + /* could not select the MIDI mapper; play anyway */ + } + + mciPlayParms.dwCallback = (DWORD) hWndNotify; + if (dwReturn = mciSendCommand(wDeviceID, MCI_PLAY, MCI_NOTIFY, + (DWORD)(LPVOID) &mciPlayParms)) { + mciSendCommand(wDeviceID, MCI_CLOSE, 0, (DWORD)NULL); + return dwReturn; + } + + return 0L; +} + + +int playmedia(wbp w, char *s) +{ + if (strstr(s, ".wav") || strstr(s, ".WAV")) { + sndPlaySound((LPSTR) s, SND_ASYNC); + return Succeeded; + } + else if (strstr(s, ".mid") || strstr(s, ".MID") || + strstr(s, ".rmi") || strstr(s, ".RMI")) { + if (playMIDIfile(w->window->win, (LPSTR) s) == 0) + return Succeeded; + } + /* + * Interpret as an MCI command string + */ + else { + if (mciSendString(s, NULL, 0, 0L)) return Failed; + return Succeeded; + } +} + +/* + * UpdateCursorPos + */ +void UpdateCursorPos(wsp ws, wcp wc) +{ + if (ISCURSORONW(ws)) { + if (ws->hasCaret) { + } + CreateCaret(ws->iconwin, NULL, FWIDTHC(wc), FHEIGHTC(wc)); + SetCaretBlinkTime(500); + SetCaretPos(ws->x, ws->y - ASCENTC(wc)); + ShowCaret(ws->iconwin); + ws->hasCaret = 1; + } +} + +int resizePixmap(wbp w, int width, int height) + { + HDC hdc, hdc2, hdc3; + HBITMAP newpix, oldpix, oldpix2; + HBRUSH hb; + LOGBRUSH lb; + XRectangle rect; + wsp ws = w->window; + int x = ws->pixwidth, y = ws->pixheight; + if (ISEXPOSED(w)) { + if (ws->pixwidth >= width && ws->pixheight >= height) { + return 1; + } + ws->pixheight = max(ws->pixheight, height); + ws->pixwidth = max(ws->pixwidth, width); + } + else { + ws->pixwidth = width; + ws->pixheight = height; + } + hdc = GetDC(ws->iconwin); + newpix = CreateCompatibleBitmap (hdc, ws->pixwidth, ws->pixheight); + if (ws->pix) { + hdc2 = CreateCompatibleDC(hdc); + oldpix = SelectObject(hdc2, ws->pix); + } + hdc3 = CreateCompatibleDC(hdc); + oldpix2 = SelectObject(hdc3, newpix); + if (palette) { + SelectPalette(hdc, palette, FALSE); + if (ws->pix) SelectPalette(hdc2, palette, FALSE); + SelectPalette(hdc3, palette, FALSE); + RealizePalette(hdc); + if (ws->pix) RealizePalette(hdc2); + RealizePalette(hdc3); + } + lb.lbStyle = BS_SOLID; + lb.lbColor = PALCLR(w->context->bg); + hb = CreateBrushIndirect(&lb); + /* + * initialize the new pixmap, including areas not in the old pixmap. + */ + rect.left = 0; rect.right = ws->pixwidth; + rect.top = 0; rect.bottom = ws->pixheight; + FillRect(hdc3, &rect, hb); + if (ws->win) + FillRect(hdc, &rect, hb); + + if (ws->pix) BitBlt(hdc3, 0, 0, x - 2, y - 1, hdc2, 0, 0, SRCCOPY); + if (ws->win) + BitBlt(hdc, 0, 0, ws->pixwidth, ws->pixheight, hdc3, 0, 0, SRCCOPY); + SelectObject(hdc3, oldpix2); + DeleteDC(hdc3); + if (ws->pix) { + SelectObject(hdc2, oldpix); + DeleteDC(hdc2); + } + ReleaseDC(ws->iconwin, hdc); + if (ws->pix) DeleteObject(ws->pix); + DeleteObject(hb); + ws->pix = newpix; + return 1; + } + +/* + * CreateWinDC - create a device context for drawing on the window + * In addition, select objects specified by flags. + */ +HDC CreateWinDC(wbp w) + { + wsp ws = w->window; + wcp wc = w->context; + HDC hdc = GetDC(ws->iconwin); + if (numColors > 0) { + SelectPalette(hdc, palette, FALSE); +/* UnrealizeObject(palette); */ + RealizePalette(hdc); + if (numRealized < numColors) { + numRealized = numColors; + if (RealizePalette(hdc) == 0) /* noop */; + } + } + SetROP2(hdc, wc->drawop); + if (wc->clipw >= 0){ + SelectClipRgn(hdc, wc->cliprgn); + } + return hdc; + } + +HDC CreatePixDC(wbp w, HDC hdc) + { + wsp ws = w->window; + wcp wc = w->context; + HBITMAP oldpix; + HDC hdc2 = CreateCompatibleDC(hdc); + if (numColors > 0) { + SelectPalette(hdc2, palette, FALSE); + RealizePalette(hdc2); + } +/* ws->initialPix = */ ws->theOldPix = SelectObject(hdc2, ws->pix); + SetROP2(hdc2, wc->drawop); + if (wc->clipw >= 0){ + SelectClipRgn(hdc2, wc->cliprgn); + } + return hdc2; + } + +int dc_maxcharwidth(HDC dc) +{ + int i, m = -1, x; + char s[2]; + s[1] = '\0'; + for (i=0; i<256; i++) { + s[0] = i; + x = dc_textwidth(dc, s, 1); + if (x > m) m = x; + } + return m; +} + +/* + * compute a text width for a current device context (typically pixdc) + */ +int dc_textwidth(HDC dc, char *s, int n) +{ + SIZE sz; + /* + * GetTextExtentPoint32(dc, s, n, &sz) gives incorrect behavior + * under Win32s + */ + GetTextExtentPoint(dc, s, n, &sz); + return (int)sz.cx; +} + +int sysScrollWidth() +{ + return GetSystemMetrics(SM_CXVSCROLL); +} + +int sysFontHeight(wbp w) +{ + TEXTMETRIC tm; + int rv; + wsp ws = w->window; + HDC dc = GetDC(ws->iconwin); + HFONT oldfont = SelectObject(dc, GetStockObject(SYSTEM_FIXED_FONT)); + GetTextMetrics(dc, &tm); + SelectObject(dc, oldfont); + ReleaseDC(ws->iconwin, dc); + return tm.tmHeight + tm.tmExternalLeading; +} + +int sysTextWidth(wbp w, char *s, int n) +{ + int rv; + wsp ws = w->window; + HDC dc = GetDC(ws->iconwin); + HFONT oldfont; + oldfont = SelectObject(dc, GetStockObject(SYSTEM_FIXED_FONT)); + rv = dc_textwidth(dc, s, n); + SelectObject(dc, oldfont); + ReleaseDC(ws->iconwin, dc); + return rv; +} + +int textWidth(wbp w, char *s, int n) + { + int rv; + wsp ws = w->window; + HDC stddc = GetDC(ws->iconwin); + HFONT oldfont = SelectObject(stddc, w->context->font->font); + rv = dc_textwidth(stddc, s, n); + SelectObject(stddc, oldfont); + ReleaseDC(ws->iconwin, stddc); + return rv; + } + +void warpPointer(w, x, y) +wbp w; +int x, y; + { + wsp ws = w->window; + SetCursorPos(ws->posx + x, ws->posy + y); + } + +/* + * free all Windows resources allocated by this instantiation of iconx + */ +void wfreersc() +{ + wbp w; + extern struct palentry *palsetup_palette; + while (wbndngs != NULL) { + w = wbndngs; + wbndngs = wbndngs->next; + free(w); + } + while (wstates != NULL) { + wstates->refcount = 1; + free_window(wstates); + } + while (wcntxts != NULL) { + wcntxts->refcount = 1; + free_context(wcntxts); + } + if (palette) { + DeleteObject(palette); + palette = 0; + } + if (palsetup_palette) { + free(palsetup_palette); + palsetup_palette = 0; + } + if (scp) { + free(scp); + scp = 0; + } + if (wlhead) + wlfree(); + mciSendCommand(MCI_ALL_DEVICE_ID, MCI_CLOSE, 0, (DWORD)NULL); +} + + +/* + * Native Windows UI facilities + */ +void makebutton(wsp ws, childcontrol *cc, char *s) +{ + cc->type = CHILD_BUTTON; + cc->font = 0; + cc->id = salloc(s); + cc->win = CreateWindow("button", cc->id, + WS_CHILD | WS_VISIBLE | BS_PUSHBUTTON, + 0, 0, 0, 0, ws->iconwin, (HMENU)ws->nChildren, mswinInstance, + NULL); +} + +void makescrollbar(wsp ws, childcontrol *cc, char *s, int i1, int i2) +{ + cc->type = CHILD_SCROLLBAR; + cc->id = salloc(s); + cc->font = 0; + cc->win = CreateWindow("scrollbar", cc->id, + WS_CHILD | WS_VISIBLE | SBS_VERT, 0, 0, 0, 0, + ws->iconwin, (HMENU)ws->nChildren, mswinInstance, NULL); + SetScrollRange(cc->win, SB_CTL, i1, i2, FALSE); +} + +int nativemenubar(wbp w, int total, int argc, dptr argv, int warg, dptr d) +{ + wsp ws; + tended struct b_list *hp; + HMENU tempMenu, tempMenu2 = NULL; + tended char *s, *s2; + int r, i; + ws = w->window; + + if (ws->nmMapElems) + tempMenu2 = ws->menuBar; + + ws->menuBar = CreateMenu(); + ws->nmMapElems = total; + total = 0; + while (warg < argc){ + /* + * each argument must be a list of strings + */ + hp = (struct b_list *)BlkLoc(argv[warg]); + r = hp->size; + /* + * Construct a Windows menu corresponding to the Icon list + */ + tempMenu = CreateMenu(); + for(i=0; i < r; i++) { + c_get(hp, d); + if (!is:string(*d)) return Error; + if (!cnv:C_string(*d, s)) return Error; + s = strdup(s); + if (i == 0) s2=s; + else + AppendMenu(tempMenu, MF_STRING, total, s); + ws->menuMap[total++] = s; + c_put(&(argv[warg]), d); + } + AppendMenu(ws->menuBar, MF_POPUP, (unsigned int)tempMenu, s2); + warg++; + } + /* + * Insert the menu into the window + */ + if (ws->win) SetMenu(ws->win, ws->menuBar); + if (tempMenu2) { + int i, n = GetMenuItemCount(tempMenu2); + for (i=0; i < n; i++) { + DestroyMenu(GetSubMenu(tempMenu2, i)); + } + DestroyMenu(tempMenu2); + } + return Succeeded; +} + +void makeeditregion(wbp w, childcontrol *cc, char *s) +{ + wsp ws = w->window; + cc->type = CHILD_EDIT; + cc->id = salloc(s); + cc->win = CreateWindow("edit", NULL, + WS_CHILD | WS_VISIBLE | WS_HSCROLL | WS_VSCROLL | + WS_BORDER | ES_LEFT | ES_MULTILINE | + ES_AUTOHSCROLL | ES_AUTOVSCROLL, + 0, 0, 0, 0, ws->iconwin, + (HMENU) ws->nChildren, mswinInstance, NULL); + setchildfont(cc, w->context->font->name); +} + +void cleareditregion(childcontrol *cc) +{ + SendMessage(cc->win, WM_CLEAR, 0, 0); +} + +void copyeditregion(childcontrol *cc) +{ + SendMessage(cc->win, WM_COPY, 0, 0); +} + +void cuteditregion(childcontrol *cc) +{ + SendMessage(cc->win, WM_CUT, 0, 0); +} + +void pasteeditregion(childcontrol *cc) +{ + SendMessage(cc->win, WM_PASTE, 0, 0); +} + +int undoeditregion(childcontrol *cc) +{ + if (!SendMessage(cc->win, WM_UNDO, 0, 0)) return Failed; + return Succeeded; +} + +int modifiededitregion(childcontrol *cc) +{ + if (!SendMessage(cc->win, EM_GETMODIFY, 0, 0)) return Failed; + return Succeeded; +} + +int setmodifiededitregion(childcontrol *cc, int i) +{ + SendMessage(cc->win, EM_SETMODIFY, i, 0); + return Succeeded; +} + +void geteditregion(childcontrol *cc, dptr d) +{ + int y = GetWindowTextLength(cc->win); + char *s2 = alcstr(NULL, y + 1); + GetWindowText(cc->win, s2, y+1); + StrLoc(*d) = s2; + StrLen(*d) = y; +} + +void seteditregion(childcontrol *cc, char *s2) +{ + SetWindowText(cc->win, s2); +} + + +void movechild(childcontrol *cc, + C_integer x, C_integer y, C_integer width, C_integer height) +{ + MoveWindow(cc->win, x, y, width, height, TRUE); +} + +int setchildfont(childcontrol *cc, char *fontname) +{ + HFONT hf; + RECT rect; + if (hf = mkfont(fontname)) { + SendMessage(cc->win, WM_SETFONT, (WPARAM)hf, 0); + if (cc->font) DeleteObject(cc->font); + cc->font = hf; + GetClientRect(cc->win, &rect); + InvalidateRect(cc->win, &rect, TRUE); + return Succeeded; + } + return Failed; +} + +void setfocusonchild(wsp ws, childcontrol *cc, int width, int height) +{ + if (width || height) { + SetFocus(cc->win); + ws->focusChild = cc->win; + } + else ws->focusChild = 0; +} + +void setchildselection(wsp ws, childcontrol *cc, int x, int y) +{ + int iLine = SendMessage(cc->win, EM_LINEFROMCHAR, x-1,0); + int topLine = SendMessage(cc->win, EM_GETFIRSTVISIBLELINE, 0, 0); + if (topLine != iLine) { + SendMessage(cc->win, EM_LINESCROLL, 0, iLine-topLine); + } + SendMessage(cc->win, EM_SETSEL, x - 1, y - 1); + SetFocus(cc->win); + ws->focusChild = cc->win; +} + +CHOOSEFONT cf; +LOGFONT lf; + +int nativefontdialog(wbp w, char *buf, int flags, int fheight) +{ + strcpy(lf.lfFaceName, buf); + lf.lfHeight = fheight; + lf.lfWidth = 0; + lf.lfEscapement = 0; + if (!strcmp(lf.lfFaceName, "mono") || !strcmp(lf.lfFaceName, "fixed")){ + strcpy(lf.lfFaceName, "Lucida Sans Typewriter"); + flags |= FONTFLAG_MONO + FONTFLAG_SANS; + } + else if (!strcmp(lf.lfFaceName, "typewriter")) { + strcpy(lf.lfFaceName, "courier"); + flags |= FONTFLAG_MONO + FONTFLAG_SERIF; + } + else if (!strcmp(lf.lfFaceName, "sans")) { + strcpy(lf.lfFaceName, "swiss"); + flags |= FONTFLAG_PROPORTIONAL + FONTFLAG_SANS; + } + else if (!strcmp(lf.lfFaceName, "serif")) { + strcpy(lf.lfFaceName, "roman"); + flags |= FONTFLAG_PROPORTIONAL + FONTFLAG_SERIF; + } + + if (flags & FONTFLAG_BOLD) lf.lfWeight = FW_BOLD; + else + lf.lfWeight = FW_DONTCARE; + if (flags & FONTFLAG_ITALIC) lf.lfItalic = 1; + lf.lfUnderline = lf.lfStrikeOut = 0; + lf.lfCharSet = + ((MAXBYTESPERCHAR==1)?ANSI_CHARSET:DEFAULT_CHARSET); + lf.lfOutPrecision = OUT_DEFAULT_PRECIS; + lf.lfClipPrecision = CLIP_DEFAULT_PRECIS; + lf.lfQuality = DEFAULT_QUALITY; + if (FONTFLAG_PROPORTIONAL) + lf.lfPitchAndFamily = VARIABLE_PITCH; + else if (FONTFLAG_MONO) + lf.lfPitchAndFamily = FIXED_PITCH; + else + lf.lfPitchAndFamily = DEFAULT_PITCH; + if (!strcmp(lf.lfFaceName, "swiss")) lf.lfPitchAndFamily |= FF_SWISS; + else if (!strcmp(lf.lfFaceName, "roman")) + lf.lfPitchAndFamily |= FF_ROMAN; + else + lf.lfPitchAndFamily |= FF_DONTCARE; + + memset(&cf, 0, sizeof(CHOOSEFONT)); + cf.lStructSize = sizeof(CHOOSEFONT); + cf.hwndOwner = w->window->iconwin; + cf.lpLogFont = &lf; + cf.Flags = CF_SCREENFONTS | CF_EFFECTS | CF_INITTOLOGFONTSTRUCT; + cf.rgbColors = RGB(0,0,0); + cf.nFontType = SCREEN_FONTTYPE; + if (ChooseFont(&cf) == 0) return Failed; + sprintf(buf, "%s,%d%s%s", lf.lfFaceName, + ((lf.lfHeight > 0) ? lf.lfHeight : -lf.lfHeight), + (lf.lfItalic ? ",italic" : ""), + ((lf.lfWeight > 500) ? ",bold" : "")); + return Succeeded; +} + +/* + * common dialog functions + */ +COLORREF aclrCust[16]; +CHOOSECOLOR cc; + +char *nativecolordialog(wbp w, long r, long g, long b, char *buf) +{ + aclrCust[0] = RGB(255,255,255); + aclrCust[1] = RGB(239,239,239); + aclrCust[2] = RGB(223,223,223); + aclrCust[3] = RGB(207,207,207); + aclrCust[4] = RGB(191,191,191); + aclrCust[5] = RGB(175,175,175); + aclrCust[6] = RGB(159,159,159); + aclrCust[7] = RGB(143,143,143); + aclrCust[8] = RGB(127,127,127); + aclrCust[9] = RGB(111,111,111); + aclrCust[10] = RGB(95,95,95); + aclrCust[11] = RGB(79,79,79); + aclrCust[12] = RGB(63,63,63); + aclrCust[13] = RGB(47,47,47); + aclrCust[14] = RGB(31,31,31); + aclrCust[15] = RGB(15,15,15); + memset(&cc, 0, sizeof(CHOOSECOLOR)); + cc.lStructSize = sizeof(CHOOSECOLOR); + cc.hwndOwner = w->window->iconwin; + cc.lpCustColors = aclrCust; + cc.rgbResult = mscolor(w, r, g, b); + cc.Flags = CC_FULLOPEN | CC_RGBINIT; + if (ChooseColor(&cc) == 0) { + return NULL; + } + sprintf(buf, "%d,%d,%d", (RED(cc.rgbResult)<<8) | 0xFF, + (GREEN(cc.rgbResult) << 8) | 0xFF, + (BLUE(cc.rgbResult) << 8) | 0xFF); + return buf; +} + + + + +char *nativeselectdialog(wbp w, struct b_list *L, char *s) +{ + int i, j, okflag=0, yesnoflag=0, cancelflag=0, retryflag=0, otherflag=0; + tended struct b_list *hp = L; + tended char *s1 = NULL; + tended struct descrip d, d2; + char s3[8]; + wsp ws = w->window; + int lsize; + + if (hp == NULL) { + okflag = 1; + } + else { + BlkLoc(d2) = (union block *)hp; + d2.dword = D_List; + lsize = hp->size; + + for(i=0; i < lsize; i++) { + c_get(hp, &d); + if (!cnv:C_string(d, s1)) return NULL; + for(j=0; j<8; j++) { + s3[j] = tolower(s1[j]); + if (s3[j] == '\0') break; + } + if (!strcmp(s3, "ok")) okflag = 1; + else if (!strcmp(s3, "okay")) okflag = 1; + else if (!strcmp(s3, "no")) yesnoflag = MB_YESNO; + else if (!strcmp(s3, "yes")) yesnoflag = MB_YESNO; + else if (!strcmp(s3, "cancel")) cancelflag++; + else if (!strcmp(s3, "retry")) retryflag = MB_RETRYCANCEL; + else { otherflag++; return NULL; } + c_put(&d2, &d); + } + } + /* + * validate flags + */ + if (okflag && yesnoflag) return NULL; + if (okflag && retryflag) return NULL; + if (yesnoflag && retryflag) return NULL; + if (retryflag && !cancelflag) return NULL; + + if (cancelflag) { + if (okflag) { + okflag = MB_OKCANCEL; + } + else if (yesnoflag) yesnoflag = MB_YESNOCANCEL; + } + else if (okflag) okflag = MB_OK; + + j = MessageBox((ws->focusChild ? ws->focusChild : + (ws->win ? ws->win : ws->iconwin)), + s, " ", + okflag | yesnoflag | retryflag + | (strchr(s, '!') ? MB_ICONEXCLAMATION : + (strchr(s, '?') ? MB_ICONQUESTION : MB_ICONASTERISK))); + + switch (j) { + case IDOK: return "Okay"; + case IDCANCEL: return "Cancel"; + case IDYES: return "Yes"; + case IDNO: return "No"; + case IDRETRY: return "Retry"; + default: return NULL; + } +} + +OPENFILENAME ofn; + +char *nativeopendialog(wbp w, char *s1, char *s2, char *s3, int i, int j) +{ + char buf[128], buf2[64]; + + memset(&ofn, 0, sizeof(OPENFILENAME)); + ofn.lStructSize = sizeof(OPENFILENAME); + ofn.hwndOwner = w->window->iconwin; + ofn.lpstrFilter = s3; + ofn.nFilterIndex = j; + strcpy(buf, s2); + ofn.lpstrFile = buf; + ofn.nMaxFile = sizeof(buf); + ofn.lpstrTitle = s1; + ofn.lpstrFileTitle = buf2; + ofn.nMaxFileTitle = sizeof(buf2); + ofn.lpstrInitialDir = NULL; + ofn.Flags = OFN_SHOWHELP | OFN_PATHMUSTEXIST; + if (GetOpenFileName(&ofn) == 0) return NULL; + return ofn.lpstrFile; +} + + +char *nativesavedialog(wbp w, char *s1, char *s2, char *s3, int i, int j) +{ + char buf[128], buf2[64]; + /* + * Use the standard dialog to obtain a filename. + */ + memset(&ofn, 0, sizeof(OPENFILENAME)); + ofn.lStructSize = sizeof(OPENFILENAME); + ofn.hwndOwner = w->window->iconwin; + ofn.lpstrFilter = s3; + ofn.nFilterIndex = j; + strcpy(buf, s2); + ofn.lpstrFile = buf; + ofn.nMaxFile = sizeof(buf); + ofn.lpstrTitle = s1; + ofn.lpstrFileTitle = buf2; + ofn.nMaxFileTitle = sizeof(buf2); + ofn.lpstrInitialDir = NULL; + ofn.Flags = OFN_SHOWHELP | OFN_PATHMUSTEXIST; + if (GetSaveFileName(&ofn) == 0) return NULL; + return ofn.lpstrFile; +} + +/* + * flush a window - noop under Windows + */ +void wflush(w) +wbp w; + { + } + +#endif /* Graphics */ diff --git a/src/runtime/rstruct.r b/src/runtime/rstruct.r new file mode 100644 index 0000000..22ab704 --- /dev/null +++ b/src/runtime/rstruct.r @@ -0,0 +1,665 @@ +/* + * File: rstruct.r + * Contents: addmem, cpslots, cplist, cpset, hmake, hchain, hfirst, hnext, + * hgrow, hshrink, memb + */ + +/* + * addmem - add a new set element block in the correct spot in + * the bucket chain. + */ + +void addmem(ps,pe,pl) +union block **pl; +struct b_set *ps; +struct b_selem *pe; + { + ps->size++; + if (*pl != NULL ) + pe->clink = *pl; + *pl = (union block *) pe; + } + +/* + * cpslots(dp1, slotptr, i, j) - copy elements of sublist dp1[i:j] + * into an array of descriptors. + */ + +void cpslots(dp1, slotptr, i, j) +dptr dp1, slotptr; +word i, j; + { + word size; + tended struct b_list *lp1; + tended struct b_lelem *bp1; + /* + * Get pointers to the list and list elements for the source list + * (bp1, lp1). + */ + lp1 = (struct b_list *) BlkLoc(*dp1); + bp1 = (struct b_lelem *) lp1->listhead; + size = j - i; + + /* + * Locate the block containing element i in the source list. + */ + if (size > 0) { + while (i > bp1->nused) { + i -= bp1->nused; + bp1 = (struct b_lelem *) bp1->listnext; + } + } + + /* + * Copy elements from the source list into the sublist, moving to + * the next list block in the source list when all elements in a + * block have been copied. + */ + while (size > 0) { + j = bp1->first + i - 1; + if (j >= bp1->nslots) + j -= bp1->nslots; + *slotptr++ = bp1->lslots[j]; + if (++i > bp1->nused) { + i = 1; + bp1 = (struct b_lelem *) bp1->listnext; + } + size--; + } + } + + +/* + * cplist(dp1,dp2,i,j) - copy sublist dp1[i:j] into dp2. + */ + +int cplist(dp1, dp2, i, j) +dptr dp1, dp2; +word i, j; + { + word size, nslots; + tended struct b_list *lp2; + tended struct b_lelem *bp2; + + /* + * Calculate the size of the sublist. + */ + size = nslots = j - i; + if (nslots == 0) + nslots = MinListSlots; + + Protect(lp2 = (struct b_list *) alclist(size), return Error); + Protect(bp2 = (struct b_lelem *)alclstb(nslots,(word)0,size), return Error); + lp2->listhead = lp2->listtail = (union block *) bp2; +#ifdef ListFix + bp2->listprev = bp2->listnext = (union block *) lp2; +#endif /* ListFix */ + + cpslots(dp1, bp2->lslots, i, j); + + /* + * Fix type and location fields for the new list. + */ + dp2->dword = D_List; + BlkLoc(*dp2) = (union block *) lp2; + EVValD(dp2, E_Lcreate); + return Succeeded; + } + +#ifdef TableFix +/* + * cpset(dp1,dp2,n) - copy set dp1 to dp2, reserving memory for n entries. + */ +int cpset(dp1, dp2, n) +dptr dp1, dp2; +word n; + { + int i = cphash(dp1, dp2, n, T_Set); + EVValD(dp2, E_Screate); + return i; + } + +int cptable(dp1, dp2, n) +dptr dp1, dp2; +word n; + { + int i = cphash(dp1, dp2, n, T_Table); + BlkLoc(*dp2)->table.defvalue = BlkLoc(*dp1)->table.defvalue; + EVValD(dp2, E_Tcreate); + return i; + } + +int cphash(dp1, dp2, n, tcode) +dptr dp1, dp2; +word n; +int tcode; + { + union block *src; + tended union block *dst; + tended struct b_slots *seg; + tended struct b_selem *ep, *prev; + struct b_selem *se; + register word slotnum; + register int i; + + /* + * Make a new set organized like dp1, with room for n elements. + */ + dst = hmake(tcode, BlkLoc(*dp1)->set.mask + 1, n); + if (dst == NULL) + return Error; + /* + * Copy the header and slot blocks. + */ + src = BlkLoc(*dp1); + dst->set.size = src->set.size; /* actual set size */ + dst->set.mask = src->set.mask; /* hash mask */ + for (i = 0; i < HSegs && src->set.hdir[i] != NULL; i++) + memcpy((char *)dst->set.hdir[i], (char *)src->set.hdir[i], + src->set.hdir[i]->blksize); + /* + * Work down the chain of element blocks in each bucket + * and create identical chains in new set. + */ + for (i = 0; i < HSegs && (seg = dst->set.hdir[i]) != NULL; i++) + for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--) { + prev = NULL; + for (ep = (struct b_selem *)seg->hslots[slotnum]; + ep != NULL && BlkType(ep) != T_Table; + ep = (struct b_selem *)ep->clink) { + if (tcode == T_Set) { + Protect(se = alcselem(&ep->setmem, ep->hashnum), return Error); + se->clink = ep->clink; + } + else { + Protect(se = (struct b_selem *)alctelem(), return Error); + *(struct b_telem *)se = *(struct b_telem *)ep; /* copy table entry */ + if (BlkType(se->clink) == T_Table) + se->clink = dst; + } + if (prev == NULL) + seg->hslots[slotnum] = (union block *)se; + else + prev->clink = (union block *)se; + prev = se; + } + } + dp2->dword = tcode | D_Typecode | F_Ptr; + BlkLoc(*dp2) = dst; + if (TooSparse(dst)) + hshrink(dst); + return Succeeded; + } +#else /* TableFix */ +/* + * cpset(dp1,dp2,n) - copy set dp1 to dp2, reserving memory for n entries. + */ +int cpset(dp1, dp2, n) +dptr dp1, dp2; +word n; + { + union block *src; + tended union block *dst; + tended struct b_slots *seg; + tended struct b_selem *ep, *prev; + struct b_selem *se; + register word slotnum; + register int i; + + /* + * Make a new set organized like dp1, with room for n elements. + */ + dst = hmake(T_Set, BlkLoc(*dp1)->set.mask + 1, n); + if (dst == NULL) + return Error; + /* + * Copy the header and slot blocks. + */ + src = BlkLoc(*dp1); + dst->set.size = src->set.size; /* actual set size */ + dst->set.mask = src->set.mask; /* hash mask */ + for (i = 0; i < HSegs && src->set.hdir[i] != NULL; i++) + memcpy((char *)dst->set.hdir[i], (char *)src->set.hdir[i], + src->set.hdir[i]->blksize); + /* + * Work down the chain of element blocks in each bucket + * and create identical chains in new set. + */ + for (i = 0; i < HSegs && (seg = dst->set.hdir[i]) != NULL; i++) + for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--) { + prev = NULL; + for (ep = (struct b_selem *)seg->hslots[slotnum]; + ep != NULL; ep = (struct b_selem *)ep->clink) { + Protect(se = alcselem(&ep->setmem, ep->hashnum), return Error); + if (prev == NULL) + seg->hslots[slotnum] = (union block *)se; + else + prev->clink = (union block *)se; + se->clink = ep->clink; + prev = se; + } + } + dp2->dword = D_Set; + BlkLoc(*dp2) = dst; + if (TooSparse(dst)) + hshrink(dst); + Desc_EVValD(dst, E_Screate, D_Set); + return Succeeded; + } +#endif /* TableFix */ + +/* + * hmake - make a hash structure (Set or Table) with a given number of slots. + * If *nslots* is zero, a value appropriate for *nelem* elements is chosen. + * A return of NULL indicates allocation failure. + */ +union block *hmake(tcode, nslots, nelem) +int tcode; +word nslots, nelem; + { + word seg, t, blksize, elemsize; + tended union block *blk; + struct b_slots *segp; + + if (nslots == 0) + nslots = (nelem + MaxHLoad - 1) / MaxHLoad; + for (seg = t = 0; seg < (HSegs - 1) && (t += segsize[seg]) < nslots; seg++) + ; + nslots = ((word)HSlots) << seg; /* ensure legal power of 2 */ + if (tcode == T_Table) { + blksize = sizeof(struct b_table); + elemsize = sizeof(struct b_telem); + } + else { /* T_Set */ + blksize = sizeof(struct b_set); + elemsize = sizeof(struct b_selem); + } + if (!reserve(Blocks, (word)(blksize + (seg + 1) * sizeof(struct b_slots) + + (nslots - HSlots * (seg + 1)) * sizeof(union block *) + + nelem * elemsize))) return NULL; + Protect(blk = alchash(tcode), return NULL); + for (; seg >= 0; seg--) { + Protect(segp = alcsegment(segsize[seg]), return NULL); + blk->set.hdir[seg] = segp; +#ifdef TableFix + if (tcode == T_Table) { + int j; + for (j = 0; j < segsize[seg]; j++) + segp->hslots[j] = blk; + } +#endif /* TableFix */ + } + blk->set.mask = nslots - 1; + return blk; + } + +/* + * hchain - return a pointer to the word that points to the head of the hash + * chain for hash number hn in hashed structure s. + */ + +/* + * lookup table for log to base 2; must have powers of 2 through (HSegs-1)/2. + */ +static unsigned char log2h[] = { + 0,1,2,2, 3,3,3,3, 4,4,4,4, 4,4,4,4, 5,5,5,5, 5,5,5,5, 5,5,5,5, 5,5,5,5, + 6,6,6,6, 6,6,6,6, 6,6,6,6, 6,6,6,6, 6,6,6,6, 6,6,6,6, 6,6,6,6, 6,6,6,6, + 7,7,7,7, 7,7,7,7, 7,7,7,7, 7,7,7,7, 7,7,7,7, 7,7,7,7, 7,7,7,7, 7,7,7,7, + 7,7,7,7, 7,7,7,7, 7,7,7,7, 7,7,7,7, 7,7,7,7, 7,7,7,7, 7,7,7,7, 7,7,7,7, + 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, + 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, + 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, + 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, 8,8,8,8, + 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, + 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, + 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, + 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, + 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, + 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, + 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, + 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, 9,9,9,9, + }; + +union block **hchain(pb, hn) +union block *pb; +register uword hn; + { + register struct b_set *ps; + register word slotnum, segnum, segslot; + + ps = (struct b_set *)pb; + slotnum = hn & ps->mask; + if (slotnum >= HSlots * sizeof(log2h)) + segnum = log2h[slotnum >> (LogHSlots + HSegs/2)] + HSegs/2; + else + segnum = log2h[slotnum >> LogHSlots]; + segslot = hn & (segsize[segnum] - 1); + return &ps->hdir[segnum]->hslots[segslot]; + } + +/* + * hgfirst - initialize for generating set or table, and return first element. + */ + +union block *hgfirst(bp, s) +union block *bp; +struct hgstate *s; + { + int i; + + s->segnum = 0; /* set initial state */ + s->slotnum = -1; + s->tmask = bp->table.mask; + for (i = 0; i < HSegs; i++) + s->sghash[i] = s->sgmask[i] = 0; + return hgnext(bp, s, (union block *)0); /* get and return first value */ + } + +/* + * hgnext - return the next element of a set or table generation sequence. + * + * We carefully generate each element exactly once, even if the hash chains + * are split between calls. We do this by recording the state of things at + * the time of the split and checking past history when starting to process + * a new chain. + * + * Elements inserted or deleted between calls may or may not be generated. + * + * We assume that no structure *shrinks* after its initial creation; they + * can only *grow*. + */ + +union block *hgnext(bp, s, ep) +union block *bp; +struct hgstate *s; +union block *ep; + { + int i; + word d, m; + uword hn; + + /* + * Check to see if the set or table's hash buckets were split (once or + * more) since the last call. We notice this unless the next entry + * has same hash value as the current one, in which case we defer it + * by doing nothing now. + */ +#ifdef TableFix + if (bp->table.mask != s->tmask && + (ep->selem.clink == NULL || BlkType(ep->telem.clink) == T_Table || + ep->telem.clink->telem.hashnum != ep->telem.hashnum)) { +#else /* TableFix */ + if (bp->table.mask != s->tmask && + (ep->selem.clink == NULL || + ep->telem.clink->telem.hashnum != ep->telem.hashnum)) { +#endif /* TableFix */ + /* + * Yes, they did split. Make a note of the current state. + */ + hn = ep->telem.hashnum; + for (i = 1; i < HSegs; i++) + if ((((word)HSlots) << (i - 1)) > s->tmask) { + /* + * For the newly created segments only, save the mask and + * hash number being processed at time of creation. + */ + s->sgmask[i] = s->tmask; + s->sghash[i] = hn; + } + s->tmask = bp->table.mask; + /* + * Find the next element in our original segment by starting + * from the beginning and skipping through the current hash + * number. We can't just follow the link from the current + * element, because it may have moved to a new segment. + */ + ep = bp->table.hdir[s->segnum]->hslots[s->slotnum]; +#ifdef TableFix + while (ep != NULL && BlkType(ep) != T_Table && + ep->telem.hashnum <= hn) +#else /* TableFix */ + while (ep != NULL && ep->telem.hashnum <= hn) +#endif /* TableFix */ + ep = ep->telem.clink; + } + + else { + /* + * There was no split, or else if there was we're between items + * that have identical hash numbers. Find the next element in + * the current hash chain. + */ +#ifdef TableFix + if (ep != NULL && BlkType(ep) != T_Table) /* NULL on very first call */ +#else /* TableFix */ + if (ep != NULL) /* already NULL on very first call */ +#endif /* TableFix */ + ep = ep->telem.clink; /* next element in chain, if any */ + } + + /* + * If we don't yet have an element, search successive slots. + */ +#ifdef TableFix + while (ep == NULL || BlkType(ep) == T_Table) { +#else /* TableFix */ + while (ep == NULL) { +#endif /* TableFix */ + /* + * Move to the next slot and pick the first entry. + */ + s->slotnum++; + if (s->slotnum >= segsize[s->segnum]) { + s->slotnum = 0; /* need to move to next segment */ + s->segnum++; + if (s->segnum >= HSegs || bp->table.hdir[s->segnum] == NULL) + return 0; /* return NULL at end of set/table */ + } + ep = bp->table.hdir[s->segnum]->hslots[s->slotnum]; + /* + * Check to see if parts of this hash chain were already processed. + * This could happen if the elements were in a different chain, + * but a split occurred while we were suspended. + */ + for (i = s->segnum; (m = s->sgmask[i]) != 0; i--) { + d = (word)(m & s->slotnum) - (word)(m & s->sghash[i]); + if (d < 0) /* if all elements processed earlier */ + ep = NULL; /* skip this slot */ + else if (d == 0) { + /* + * This chain was split from its parent while the parent was + * being processed. Skip past elements already processed. + */ +#ifdef TableFix + while (ep != NULL && BlkType(ep) != T_Table && + ep->telem.hashnum <= s->sghash[i]) +#else /* TableFix */ + while (ep != NULL && ep->telem.hashnum <= s->sghash[i]) +#endif /* TableFix */ + ep = ep->telem.clink; + } + } + } + + /* + * Return the element. + */ +#ifdef TableFix + if (ep && BlkType(ep) == T_Table) ep = NULL; +#endif /* TableFix */ + return ep; + } + +/* + * hgrow - split a hashed structure (doubling the buckets) for faster access. + */ + +void hgrow(bp) +union block *bp; + { + register union block **tp0, **tp1, *ep; + register word newslots, slotnum, segnum; + tended struct b_set *ps; + struct b_slots *seg, *newseg; + union block **curslot; + + ps = (struct b_set *) bp; + if (ps->hdir[HSegs-1] != NULL) + return; /* can't split further */ + newslots = ps->mask + 1; + Protect(newseg = alcsegment(newslots), return); +#ifdef TableFix + if (BlkType(bp) == T_Table) { + int j; + for(j=0; j<newslots; j++) newseg->hslots[j] = bp; + } +#endif /* TableFix */ + + curslot = newseg->hslots; + for (segnum = 0; (seg = ps->hdir[segnum]) != NULL; segnum++) + for (slotnum = 0; slotnum < segsize[segnum]; slotnum++) { + tp0 = &seg->hslots[slotnum]; /* ptr to tail of old slot */ + tp1 = curslot++; /* ptr to tail of new slot */ +#ifdef TableFix + for (ep = *tp0; + ep != NULL && BlkType(ep) != T_Table; + ep = ep->selem.clink) { +#else /* TableFix */ + for (ep = *tp0; ep != NULL; ep = ep->selem.clink) { +#endif /* TableFix */ + if ((ep->selem.hashnum & newslots) == 0) { + *tp0 = ep; /* element does not move */ + tp0 = &ep->selem.clink; + } + else { + *tp1 = ep; /* element moves to new slot */ + tp1 = &ep->selem.clink; + } + } +#ifdef TableFix + if ( BlkType(bp) == T_Table ) + *tp0 = *tp1 = bp; + else + *tp0 = *tp1 = NULL; +#else /* TableFix */ + *tp0 = *tp1 = NULL; +#endif /* TableFix */ + } + ps->hdir[segnum] = newseg; + ps->mask = (ps->mask << 1) | 1; + } + +/* + * hshrink - combine buckets in a set or table that is too sparse. + * + * Call this only for newly created structures. Shrinking an active structure + * can wreak havoc on suspended generators. + */ +void hshrink(bp) +union block *bp; + { + register union block **tp, *ep0, *ep1; + int topseg, curseg; + word slotnum; + tended struct b_set *ps; + struct b_slots *seg; + union block **uppslot; + + ps = (struct b_set *)bp; + topseg = 0; + for (topseg = 1; topseg < HSegs && ps->hdir[topseg] != NULL; topseg++) + ; + topseg--; + while (TooSparse(ps)) { + uppslot = ps->hdir[topseg]->hslots; + ps->hdir[topseg--] = NULL; + for (curseg = 0; (seg = ps->hdir[curseg]) != NULL; curseg++) + for (slotnum = 0; slotnum < segsize[curseg]; slotnum++) { + tp = &seg->hslots[slotnum]; /* tail pointer */ + ep0 = seg->hslots[slotnum]; /* lower slot entry pointer */ + ep1 = *uppslot++; /* upper slot entry pointer */ +#ifdef TableFix + while (ep0 != NULL && BlkType(ep0) != T_Table && + ep1 != NULL && BlkType(ep1) != T_Table) +#else /* TableFix */ + while (ep0 != NULL && ep1 != NULL) +#endif /* TableFix */ + if (ep0->selem.hashnum < ep1->selem.hashnum) { + *tp = ep0; + tp = &ep0->selem.clink; + ep0 = ep0->selem.clink; + } + else { + *tp = ep1; + tp = &ep1->selem.clink; + ep1 = ep1->selem.clink; + } +#ifdef TableFix + while (ep0 != NULL && BlkType(ep0) != T_Table) { +#else /* TableFix */ + while (ep0 != NULL) { +#endif /* TableFix */ + *tp = ep0; + tp = &ep0->selem.clink; + ep0 = ep0->selem.clink; + } +#ifdef TableFix + while (ep1 != NULL && BlkType(ep1) != T_Table) { +#else /* TableFix */ + while (ep1 != NULL) { +#endif /* TableFix */ + *tp = ep1; + tp = &ep1->selem.clink; + ep1 = ep1->selem.clink; + } + } + ps->mask >>= 1; + } + } + +/* + * memb - sets res flag to 1 if x is a member of a set or table, or to 0 if not. + * Returns a pointer to the word which points to the element, or which + * would point to it if it were there. + */ + +union block **memb(pb, x, hn, res) +union block *pb; +dptr x; +register uword hn; +int *res; /* pointer to integer result flag */ + { + struct b_set *ps; + register union block **lp; + register struct b_selem *pe; + register uword eh; + + ps = (struct b_set *)pb; + lp = hchain(pb, hn); + /* + * Look for x in the hash chain. + */ + *res = 0; +#ifdef TableFix + while ((pe = (struct b_selem *)*lp) != NULL && BlkType(pe) != T_Table) { +#else /* TableFix */ + while ((pe = (struct b_selem *)*lp) != NULL) { +#endif /* TableFix */ + eh = pe->hashnum; + if (eh > hn) /* too far - it isn't there */ + return lp; + else if ((eh == hn) && (equiv(&pe->setmem, x))) { + *res = 1; + return lp; + } + /* + * We haven't reached the right hashnumber yet or + * the element isn't the right one so keep looking. + */ + lp = &(pe->clink); + } + /* + * At end of chain - not there. + */ + return lp; + } diff --git a/src/runtime/rsys.r b/src/runtime/rsys.r new file mode 100644 index 0000000..f4bdfc1 --- /dev/null +++ b/src/runtime/rsys.r @@ -0,0 +1,252 @@ +/* + * File: rsys.r + * Contents: getstrg, host, longread, putstr + */ + +/* + * getstrg - read a line into buf from file fbp. At most maxi characters + * are read. getstrg returns the length of the line, not counting the + * newline. Returns -1 if EOF and -2 if length was limited by maxi. + * Discards \r before \n in translated mode. [[ Needs ferror() check. ]] + */ + +int getstrg(buf, maxi, fbp) +register char *buf; +int maxi; +struct b_file *fbp; + { + register int c, l; + FILE *fd; + + fd = fbp->fd; + + #ifdef XWindows + if (isatty(fileno(fd))) wflushall(); + #endif /* XWindows */ + + l = 0; + while (1) { + + #ifdef Graphics + /* insert non-blocking read/code to service windows here */ + #endif /* Graphics */ + + if ((c = fgetc(fd)) == '\n') /* \n terminates line */ + break; + if (c == '\r' && (fbp->status & Fs_Untrans) == 0) { + /* \r terminates line in translated mode */ + if ((c = fgetc(fd)) != '\n') /* consume following \n */ + ungetc(c, fd); /* (put back if not \n) */ + break; + } + if (c == EOF) { + if (l > 0) return l; + else return -1; + } + if (++l > maxi) { + ungetc(c, fd); + return -2; + } + *buf++ = c; + } + return l; + } + +/* + * iconhost - return some sort of host name into the buffer pointed at + * by hostname. This code accommodates several different host name + * fetching schemes. + */ +void iconhost(hostname) +char *hostname; + { + /* + * Use the uname system call. (POSIX) + */ + struct utsname utsn; + uname(&utsn); + strcpy(hostname,utsn.nodename); + } + +/* + * Read a long string in shorter parts. (Standard read may not handle long + * strings.) + */ +word longread(s,width,len,fd) +FILE *fd; +int width; +char *s; +long len; +{ + tended char *ts = s; + long tally = 0; + long n = 0; + +#ifdef XWindows + if (isatty(fileno(fd))) wflushall(); +#endif /* XWindows */ + + while (len > 0) { + n = fread(ts, width, (int)((len < MaxIn) ? len : MaxIn), fd); + if (n <= 0) { + return tally; + } + tally += n; + ts += n; + len -= n; + } + return tally; + } + +/* + * Print string referenced by descriptor d. Note, d must not move during + * a garbage collection. + */ + +int putstr(f, d) +register FILE *f; +dptr d; + { + register char *s; + register word l; + + l = StrLen(*d); + if (l == 0) + return Succeeded; + s = StrLoc(*d); + if (longwrite(s,l,f) < 0) + return Failed; + else + return Succeeded; + } + +/* + * idelay(n) - delay for n milliseconds + */ +int idelay(n) +int n; + { + #if MSWIN + Sleep(n); + return Succeeded; + #else /* MSWIN */ + struct timeval t; + t.tv_sec = n / 1000; + t.tv_usec = (n % 1000) * 1000; + select(1, NULL, NULL, NULL, &t); + return Succeeded; + #endif /* MSWIN */ + } + +#ifdef KeyboardFncs + +/* + * Documentation notwithstanding, the Unix versions of the keyboard functions + * read from standard input and not necessarily from the keyboard (/dev/tty). + */ +#define STDIN 0 + +/* + * int getch() -- read character without echoing + * int getche() -- read character with echoing + * + * Read and return a character from standard input in non-canonical + * ("cbreak") mode. Return -1 for EOF. + * + * Reading is done even if stdin is not a tty; + * the tty get/set functions are just rejected by the system. + */ + +int rchar(int with_echo); + +int getch(void) { return rchar(0); } +int getche(void) { return rchar(1); } + +int rchar(int with_echo) +{ + struct termios otty, tty; + char c; + int n; + + tcgetattr(STDIN, &otty); /* get current tty attributes */ + + tty = otty; + tty.c_lflag &= ~ICANON; + if (with_echo) + tty.c_lflag |= ECHO; + else + tty.c_lflag &= ~ECHO; + tcsetattr(STDIN, TCSANOW, &tty); /* set temporary attributes */ + + n = read(STDIN, &c, 1); /* read one char from stdin */ + + tcsetattr(STDIN, TCSANOW, &otty); /* reset tty to original state */ + + if (n == 1) /* if read succeeded */ + return c & 0xFF; + else + return -1; +} + +/* + * kbhit() -- return nonzero if characters are available for getch/getche. + */ +int kbhit(void) +{ + struct termios otty, tty; + fd_set fds; + struct timeval tv; + int rv; + + tcgetattr(STDIN, &otty); /* get current tty attributes */ + + tty = otty; + tty.c_lflag &= ~ICANON; /* disable input batching */ + tcsetattr(STDIN, TCSANOW, &tty); /* set attribute temporarily */ + + FD_ZERO(&fds); /* initialize fd struct */ + FD_SET(STDIN, &fds); /* set STDIN bit */ + tv.tv_sec = tv.tv_usec = 0; /* set immediate return */ + rv = select(STDIN + 1, &fds, NULL, NULL, &tv); + + tcsetattr(STDIN, TCSANOW, &otty); /* reset tty to original state */ + + return rv; /* return result */ +} + +#endif /* KeyboardFncs */ + +#ifdef FAttrib +/* + * make_mode takes mode_t type (an integer) input and returns the + * file permission in the format of a string. +*/ +char *make_mode (mode_t st_mode) +{ + char *buf; + + if ( (buf = (char *) malloc(sizeof(char)*11)) == NULL ) { + fprintf(stderr,"fatal malloc error\n"); + return NULL; + } + + if ( st_mode & S_IFIFO ) buf[0] = 'f'; + else if ( st_mode & S_IFCHR ) buf[0] = 'c'; + else if ( st_mode & S_IFDIR ) buf[0] = 'd'; + else if ( st_mode & S_IFREG ) buf[0] = '-'; + else buf[0] = '\?'; + + if (st_mode & S_IREAD) buf[1] = 'r'; else buf[1] = '-'; + if (st_mode & S_IWRITE) buf[2] = 'w'; else buf[2] = '-'; + if (st_mode & S_IEXEC) buf[3] = 'x'; else buf[3] = '-'; + if (st_mode & S_IREAD) buf[4] = 'r'; else buf[4] = '-'; + if (st_mode & S_IWRITE) buf[5] = 'w'; else buf[5] = '-'; + if (st_mode & S_IEXEC) buf[6] = 'x'; else buf[6] = '-'; + if (st_mode & S_IREAD) buf[7] = 'r'; else buf[7] = '-'; + if (st_mode & S_IWRITE) buf[8] = 'w'; else buf[8] = '-'; + if (st_mode & S_IEXEC) buf[9] = 'x'; else buf[9] = '-'; + + buf[10] = '\0'; + return buf; +} +#endif /* FAttrib */ diff --git a/src/runtime/rwindow.r b/src/runtime/rwindow.r new file mode 100644 index 0000000..752baa2 --- /dev/null +++ b/src/runtime/rwindow.r @@ -0,0 +1,1727 @@ +/* + * File: rwindow.r + * non window-system-specific window support routines + */ + +#ifdef Graphics + +static int setpos (wbp w, char *s); +static int sicmp (siptr sip1, siptr sip2); + +int canvas_serial, context_serial; + +#ifndef MultiThread +struct descrip amperX = {D_Integer}; +struct descrip amperY = {D_Integer}; +struct descrip amperCol = {D_Integer}; +struct descrip amperRow = {D_Integer}; +struct descrip amperInterval = {D_Integer}; +struct descrip lastEventWin = {D_Null}; +int lastEvFWidth = 0, lastEvLeading = 0, lastEvAscent = 0; +uword xmod_control, xmod_shift, xmod_meta; +#endif /* MultiThread */ + + +/* + * subscript the already-processed-events "queue" to index i. + * used in "cooked mode" I/O to determine, e.g. how far to backspace. + */ +char *evquesub(w,i) +wbp w; +int i; + { + wsp ws = w->window; + int j = ws->eQback+i; + + if (i < 0) { + if (j < 0) j+= EQUEUELEN; + else if (j > EQUEUELEN) j -= EQUEUELEN; + return &(ws->eventQueue[j]); + } + else { + /* "this isn't getting called in the forwards direction!\n" */ + return NULL; + } + } + + +/* + * get event from window, assigning to &x, &y, and &interval + * + * returns 0 for success, -1 if window died or EOF, -2 for malformed queue + */ +int wgetevent(w,res) +wbp w; +dptr res; + { + struct descrip xdesc, ydesc; + uword i; + + if (wstates != NULL && wstates->next != NULL /* if multiple windows*/ + && (BlkLoc(w->window->listp)->list.size == 0)) { /* & queue is empty */ + while (BlkLoc(w->window->listp)->list.size == 0) { + #ifdef WinGraphics + if (ISCURSORON(w) && w->window->hasCaret == 0) { + wsp ws = w->window; + CreateCaret(ws->iconwin, NULL, FWIDTH(w), FHEIGHT(w)); + SetCaretBlinkTime(500); + SetCaretPos(ws->x, ws->y - ASCENT(w)); + ShowCaret(ws->iconwin); + ws->hasCaret = 1; + } + #endif /* WinGraphics */ + if (pollevent() < 0) /* poll all windows */ + break; /* break on error */ + idelay(POLLSLEEP); + } + } + + if (wgetq(w,res) == -1) + return -1; /* window died */ + + if (BlkLoc(w->window->listp)->list.size < 2) + return -2; /* malformed queue */ + + wgetq(w,&xdesc); + wgetq(w,&ydesc); + + if (xdesc.dword != D_Integer || ydesc.dword != D_Integer) + return -2; /* bad values on queue */ + + IntVal(amperX) = IntVal(xdesc) & 0xFFFF; /* &x */ + if (IntVal(amperX) >= 0x8000) + IntVal(amperX) -= 0x10000; + IntVal(amperY) = IntVal(ydesc) & 0xFFFF; /* &y */ + if (IntVal(amperY) >= 0x8000) + IntVal(amperY) -= 0x10000; + IntVal(amperX) -= w->context->dx; + IntVal(amperY) -= w->context->dy; + MakeInt(1 + XTOCOL(w,IntVal(amperX)), &(amperCol)); /* &col */ + MakeInt(YTOROW(w,IntVal(amperY)) , &(amperRow)); /* &row */ + + xmod_control = IntVal(xdesc) & EQ_MOD_CONTROL; /* &control */ + xmod_meta = IntVal(xdesc) & EQ_MOD_META; /* &meta */ + xmod_shift = IntVal(xdesc) & EQ_MOD_SHIFT; /* &shift */ + + i = (((uword) IntVal(ydesc)) >> 16) & 0xFFF; /* mantissa */ + i <<= 4 * ((((uword) IntVal(ydesc)) >> 28) & 0x7); /* scale it */ + IntVal(amperInterval) = i; /* &interval */ + return 0; + } + +/* + * get event from window (drop mouse events), no echo + * + * return: 1 = success, -1 = window died, -2 = malformed queue, -3 = EOF + */ +int wgetchne(w,res) +wbp w; +dptr res; + { + int i; + + while (1) { + i = wgetevent(w,res); + if (i != 0) + return i; + if (is:string(*res)) { +#ifdef WinGraphics + if (*StrLoc(*res) == '\032') return -3; /* control-Z gives EOF */ +#endif /* WinGraphics */ + return 1; + } + } + } + +/* + * get event from window (drop mouse events), with echo + * + * returns 1 for success, -1 if window died, -2 for malformed queue, -3 for EOF + */ +int wgetche(w,res) +wbp w; +dptr res; + { + int i; + i = wgetchne(w,res); + if (i != 1) + return i; + i = *StrLoc(*res); + if ((0 <= i) && (i <= 127) && (ISECHOON(w))) { + wputc(i, w); + if (i == '\r') wputc((int)'\n', w); /* CR -> CR/LF */ + } + return 1; + } + +/* + * Get a window that has an event pending (queued) + */ +wsp getactivewindow() + { + static LONG next = 0; + LONG i, j, nwindows = 0; + wsp ptr, ws, stdws = NULL; + extern FILE *ConsoleBinding; + + if (wstates == NULL) return NULL; + for(ws = wstates; ws; ws=ws->next) nwindows++; + if (ConsoleBinding) stdws = ((wbp)ConsoleBinding)->window; + /* + * make sure we are still in bounds + */ + next %= nwindows; + /* + * position ptr on the next window to get events from + */ + for (ptr = wstates, i = 0; i < next; i++, ptr = ptr->next); + /* + * Infinite loop, checking for an event somewhere, sleeping awhile + * each iteration. + */ + for (;;) { + /* + * Check for any new pending events. + */ + switch (pollevent()) { + case -1: ReturnErrNum(141, NULL); + case 0: return NULL; + } + /* + * go through windows, looking for one with an event pending + */ + for (ws = ptr, i = 0, j = next + 1; i < nwindows; + (ws = (ws->next) ? ws->next : wstates), i++, j++) + if (ws != stdws && BlkLoc(ws->listp)->list.size > 0) { + next = j; + return ws; + } + /* + * couldn't find a pending event - wait awhile + */ + idelay(POLLSLEEP); + } + } + +/* + * wlongread(s,elsize,nelem,f) -- read string from window for reads(w) + * + * returns length(>=0) for success, -1 if window died, -2 for malformed queue + * -3 on EOF + */ +int wlongread(s, elsize, nelem, f) +char *s; +int elsize, nelem; +FILE *f; + { + int c; + tended char *ts = s; + struct descrip foo; + long l = 0, bytes = elsize * nelem; + + while (l < bytes) { + c = wgetche((wbp)f, &foo); + if (c == -3 && l > 0) + return l; + if (c < 0) + return c; + c = *StrLoc(foo); + switch(c) { + case '\177': + case '\010': + if (l > 0) { ts--; l--; } + break; + default: + *ts++ = c; l++; + break; + } + } + return l; + } + +/* + * wgetstrg(s,maxlen,f) -- get string from window for read(w) or !w + * + * returns length(>=0) for success, -1 if window died, -2 for malformed queue + * -3 for EOF, -4 if length was limited by maxi + */ +int wgetstrg(s, maxlen, f) +char *s; +long maxlen; +FILE *f; + { + int c; + tended char *ts = s; + long l = 0; + struct descrip foo; + + while (l < maxlen) { + c = wgetche((wbp)f,&foo); + if (c == -3 && l > 0) + return l; + if (c < 0) + return c; + c = *StrLoc(foo); + switch(c) { + case '\177': + case '\010': + if (l > 0) { ts--; l--; } + break; + case '\r': + case '\n': + return l; + default: + *ts++ = c; l++; + break; + } + } + return -4; + } + + +/* + * Assignment side-effects for &x,&y,&row,&col + */ +int xyrowcol(dx) +dptr dx; +{ + if (VarLoc(*dx) == &erX) { /* update &col too */ + wbp w; + if (!is:file(lastEventWin) || + ((BlkLoc(lastEventWin)->file.status & Fs_Window) == 0) || + ((BlkLoc(lastEventWin)->file.status & (Fs_Read|Fs_Write)) == 0)) { + MakeInt(1 + IntVal(amperX)/lastEvFWidth, &erCol); + } + else { + w = (wbp)BlkLoc(lastEventWin)->file.fd; + MakeInt(1 + XTOCOL(w, IntVal(amperX)), &erCol); + } + } + else if (VarLoc(*dx) == &erY) { /* update &row too */ + wbp w; + if (!is:file(lastEventWin) || + ((BlkLoc(lastEventWin)->file.status & Fs_Window) == 0) || + ((BlkLoc(lastEventWin)->file.status & (Fs_Read|Fs_Write)) == 0)) { + MakeInt(IntVal(amperY) / lastEvLeading + 1, &erRow); + } + else { + w = (wbp)BlkLoc(lastEventWin)->file.fd; + MakeInt(YTOROW(w, IntVal(amperY)), &erRow); + } + } + else if (VarLoc(*dx) == &erCol) { /* update &x too */ + wbp w; + if (!is:file(lastEventWin) || + ((BlkLoc(lastEventWin)->file.status & Fs_Window) == 0) || + ((BlkLoc(lastEventWin)->file.status & (Fs_Read|Fs_Write)) == 0)) { + MakeInt((IntVal(amperCol) - 1) * lastEvFWidth, &erX); + } + else { + w = (wbp)BlkLoc(lastEventWin)->file.fd; + MakeInt(COLTOX(w, IntVal(amperCol)), &erX); + } + } + else if (VarLoc(*dx) == &erRow) { /* update &y too */ + wbp w; + if (!is:file(lastEventWin) || + ((BlkLoc(lastEventWin)->file.status & Fs_Window) == 0) || + ((BlkLoc(lastEventWin)->file.status & (Fs_Read|Fs_Write)) == 0)) { + MakeInt((IntVal(amperRow)-1) * lastEvLeading + lastEvAscent, &erY); + } + else { + w = (wbp)BlkLoc(lastEventWin)->file.fd; + MakeInt(ROWTOY(w, IntVal(amperRow)), &erY); + } + } + return 0; + } + + +/* + * Enqueue an event, encoding time interval and key state with x and y values. + */ +void qevent(ws,e,x,y,t,f) +wsp ws; /* canvas */ +dptr e; /* event code (descriptor pointer) */ +int x, y; /* x and y values */ +uword t; /* ms clock value */ +long f; /* modifier key flags */ + { + dptr q = &(ws->listp); /* a window's event queue (Icon list value) */ + struct descrip d; + uword ivl, mod; + int expo; + + mod = 0; /* set modifier key bits */ + if (f & ControlMask) mod |= EQ_MOD_CONTROL; + if (f & Mod1Mask) mod |= EQ_MOD_META; + if (f & ShiftMask) mod |= EQ_MOD_SHIFT; + + if (t != ~(uword)0) { /* if clock value supplied */ + if (ws->timestamp == 0) /* if first time */ + ws->timestamp = t; + if (t < ws->timestamp) /* if clock went backwards */ + t = ws->timestamp; + ivl = t - ws->timestamp; /* calc interval in milliseconds */ + ws->timestamp = t; /* save new clock value */ + expo = 0; + while (ivl >= 0x1000) { /* if too big */ + ivl >>= 4; /* reduce significance */ + expo += 0x1000; /* bump exponent */ + } + ivl += expo; /* combine exponent with mantissa */ + } + else + ivl = 0; /* report 0 if interval unknown */ + + c_put(q, e); + d.dword = D_Integer; + IntVal(d) = mod | (x & 0xFFFF); + c_put(q, &d); + IntVal(d) = (ivl << 16) | (y & 0xFFFF); + c_put(q, &d); + } + +/* + * setpos() - set (move) canvas position on the screen + */ +static int setpos(w,s) +wbp w; +char *s; + { + char *s2, tmp[32]; + int posx, posy; + + s2 = s; + while (isspace(*s2)) s2++; + if (!isdigit(*s2) && (*s2 != '-')) return Error; + posx = atol(s2); + if (*s2 == '-') s2++; + while (isdigit(*s2)) s2++; + if (*s2 == '.') { + s2++; + while (isdigit(*s2)) s2++; + } + if (*s2++ != ',') return Error; + if (!isdigit(*s2) && (*s2 != '-')) return Error; + posy = atol(s2); + if (*s2 == '-') s2++; + while (isdigit(*s2)) s2++; + if (*s2 == '.') { + s2++; + while (isdigit(*s2)) s2++; + } + if (*s2) return Error; + if (posx < 0) { + if (posy < 0) sprintf(tmp,"%d%d",posx,posy); + else sprintf(tmp,"%d+%d",posx,posy); + } + else { + if (posy < 0) sprintf(tmp,"+%d%d",posx,posy); + else sprintf(tmp,"+%d+%d",posx,posy); + } + return setgeometry(w,tmp); + } + +/* + * setsize() - set canvas size + */ +int setsize(w,s) +wbp w; +char *s; + { + char *s2, tmp[32]; + int width, height; + + s2 = s; + while (isspace(*s2)) s2++; + if (!isdigit(*s2) && (*s2 != '-')) return Error; + width = atol(s2); + if (*s2 == '-') s2++; + while (isdigit(*s2)) s2++; + if (*s2 == '.') { + s2++; + while (isdigit(*s2)) s2++; + } + if (*s2++ != ',') return Error; + height = atol(s2); + if (*s2 == '-') s2++; + while (isdigit(*s2)) s2++; + if (*s2 == '.') { + s2++; + while (isdigit(*s2)) s2++; + } + if (*s2) return Error; + sprintf(tmp,"%dx%d",width,height); + return setgeometry(w,tmp); + } + + + +/* + * put a string out to a window using the current attributes + */ +void wputstr(w,s,len) +wbp w; +char *s; +int len; + { + char *s2 = s; + wstate *ws = w->window; + /* turn off the cursor */ + hidecrsr(ws); + + while (len > 0) { + /* + * find a chunk of printable text + */ +#ifdef WinGraphics + while (len > 0) { + if (IsDBCSLeadByte(*s2)) { + s2++; s2++; len--; len--; + } + else if (isprint(*s2)) { + s2++; len--; + } + else break; + } +#else /* WinGraphics */ + while (isprint(*s2) && len > 0) { + s2++; len--; + } +#endif /* WinGraphics */ + /* + * if a chunk was parsed, write it out + */ + if (s2 != s) + xdis(w, s, s2 - s); + /* + * put the 'unprintable' character, if didn't just hit the end + */ + if (len-- > 0) { + wputc(*s2++, w); + } + s = s2; + } + + /* show the cursor again */ + UpdateCursorPos(ws, w->context); + showcrsr(ws); + return; +} + +/* + * mapping from recognized style attributes to flag values + */ +stringint fontwords[] = { + { 0, 17 }, /* number of entries */ + { "bold", FONTATT_WEIGHT | FONTFLAG_BOLD }, + { "condensed", FONTATT_WIDTH | FONTFLAG_CONDENSED }, + { "demi", FONTATT_WEIGHT | FONTFLAG_DEMI }, + { "demibold", FONTATT_WEIGHT | FONTFLAG_DEMI | FONTFLAG_BOLD }, + { "extended", FONTATT_WIDTH | FONTFLAG_EXTENDED }, + { "italic", FONTATT_SLANT | FONTFLAG_ITALIC }, + { "light", FONTATT_WEIGHT | FONTFLAG_LIGHT }, + { "medium", FONTATT_WEIGHT | FONTFLAG_MEDIUM }, + { "mono", FONTATT_SPACING | FONTFLAG_MONO }, + { "narrow", FONTATT_WIDTH | FONTFLAG_NARROW }, + { "normal", FONTATT_WIDTH | FONTFLAG_NORMAL }, + { "oblique", FONTATT_SLANT | FONTFLAG_OBLIQUE }, + { "proportional", FONTATT_SPACING | FONTFLAG_PROPORTIONAL }, + { "roman", FONTATT_SLANT | FONTFLAG_ROMAN }, + { "sans", FONTATT_SERIF | FONTFLAG_SANS }, + { "serif", FONTATT_SERIF | FONTFLAG_SERIF }, + { "wide", FONTATT_WIDTH | FONTFLAG_WIDE }, +}; + +/* + * parsefont - extract font family name, style attributes, and size + * + * these are window system independent values, so they require + * further translation into window system dependent values. + * + * returns 1 on an OK font name + * returns 0 on a "malformed" font (might be a window-system fontname) + */ +int parsefont(s, family, style, size) +char *s; +char family[MAXFONTWORD+1]; +int *style; +int *size; + { + char c, *a, attr[MAXFONTWORD+1]; + int tmp; + + /* + * set up the defaults + */ + *family = '\0'; + *style = 0; + *size = -1; + + /* + * now, scan through the raw and break out pieces + */ + for (;;) { + + /* + * find start of next comma-separated attribute word + */ + while (isspace(*s) || *s == ',') /* trim leading spaces & empty words */ + s++; + if (*s == '\0') /* stop at end of string */ + break; + + /* + * copy word, converting to lower case to implement case insensitivity + */ + for (a = attr; (c = *s) != '\0' && c != ','; s++) { + if (isupper(c)) + c = tolower(c); + *a++ = c; + if (a - attr >= MAXFONTWORD) + return 0; /* too long */ + } + + /* + * trim trailing spaces and terminate word + */ + while (isspace(a[-1])) + a--; + *a = '\0'; + + /* + * interpret word as family name, size, or style characteristic + */ + if (*family == '\0') + strcpy(family, attr); /* first word is the family name */ + + else if (sscanf(attr, "%d%c", &tmp, &c) == 1 && tmp > 0) { + if (*size != -1 && *size != tmp) + return 0; /* if conflicting sizes given */ + *size = tmp; /* integer value is a size */ + } + + else { /* otherwise it's a style attribute */ + tmp = si_s2i(fontwords, attr); /* look up in table */ + if (tmp != -1) { /* if recognized */ + if ((tmp & *style) != 0 && (tmp & *style) != tmp) + return 0; /* conflicting attribute */ + *style |= tmp; + } + } + } + + /* got to end of string; it's OK if it had at least a font family */ + return (*family != '\0'); + } + +/* + * parsepattern() - parse an encoded numeric stipple pattern + */ +int parsepattern(s, len, width, nbits, bits) +char *s; +int len; +int *width, *nbits; +C_integer *bits; + { + C_integer v; + int i, j, hexdigits_per_row, maxbits = *nbits; + + /* + * Get the width + */ + if (sscanf(s, "%d,", width) != 1) return Error; + if (*width < 1) return Failed; + + /* + * skip over width + */ + while ((len > 0) && isdigit(*s)) { + len--; s++; + } + if ((len <= 1) || (*s != ',')) return Error; + len--; s++; /* skip over ',' */ + + if (*s == '#') { + /* + * get remaining bits as hex constant + */ + s++; len--; + if (len == 0) return Error; + hexdigits_per_row = *width / 4; + if (*width % 4) hexdigits_per_row++; + *nbits = len / hexdigits_per_row; + if (len % hexdigits_per_row) (*nbits)++; + if (*nbits > maxbits) return Failed; + for (i = 0; i < *nbits; i++) { + v = 0; + for (j = 0; j < hexdigits_per_row; j++, len--, s++) { + if (len == 0) break; + v <<= 4; + if (isdigit(*s)) v += *s - '0'; + else switch (*s) { + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + v += *s - 'a' + 10; break; + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + v += *s - 'A' + 10; break; + default: return Error; + } + } + *bits++ = v; + } + } + else { + if (*width > 32) return Failed; + /* + * get remaining bits as comma-separated decimals + */ + v = 0; + *nbits = 0; + while (len > 0) { + while ((len > 0) && isdigit(*s)) { + v = v * 10 + *s - '0'; + len--; s++; + } + (*nbits)++; + if (*nbits > maxbits) return Failed; + *bits++ = v; + v = 0; + + if (len > 0) { + if (*s == ',') { len--; s++; } + else { + ReturnErrNum(205, Error); + } + } + } + } + return Succeeded; + } + +/* + * parsegeometry - parse a string of the form: intxint[+-]int[+-]int + * Returns: + * 0 on bad value, 1 if size is set, 2 if position is set, 3 if both are set + */ +int parsegeometry(buf, x, y, width, height) +char *buf; +SHORT *x, *y, *width, *height; + { + int retval = 0; + if (isdigit(*buf)) { + retval++; + if ((*width = atoi(buf)) <= 0) return 0; + while (isdigit(*++buf)); + if (*buf++ != 'x') return 0; + if ((*height = atoi(buf)) <= 0) return 0; + while (isdigit(*++buf)); + } + + if (*buf == '+' || *buf == '-') { + retval += 2; + *x = atoi(buf); + buf++; /* skip over +/- */ + while (isdigit(*buf)) buf++; + + if (*buf != '+' && *buf != '-') return 0; + *y = atoi(buf); + buf++; /* skip over +/- */ + while (isdigit(*buf)) buf++; + if (*buf) return 0; + } + return retval; + } + + +/* return failure if operation returns either failure or error */ +#define AttemptAttr(operation) if ((operation) != Succeeded) return Failed; + +/* does string (already checked for "on" or "off") say "on"? */ +#define ATOBOOL(s) (s[1]=='n') + +/* + * Attribute manipulation + * + * wattrib() - get/set a single attribute in a window, return the result attr + * string. + */ +int wattrib(w, s, len, answer, abuf) +wbp w; +char *s; +long len; +dptr answer; +char * abuf; + { + char val[128], *valptr; + struct descrip d; + char *mid, *midend, c; + int r, a; + C_integer tmp; + long lenattr, lenval; + double gamma; + SHORT new_height, new_width; + wsp ws = w->window; + wcp wc = w->context; + + valptr = val; + /* + * catch up on any events pending - mainly to update pointerx, pointery + */ + if (pollevent() == -1) + fatalerr(141,NULL); + + midend = s + len; + for (mid = s; mid < midend; mid++) + if (*mid == '=') break; + + if (mid < midend) { + /* + * set an attribute + */ + lenattr = mid - s; + lenval = len - lenattr - 1; + mid++; + + strncpy(abuf, s, lenattr); + abuf[lenattr] = '\0'; + strncpy(val, mid, lenval); + val[lenval] = '\0'; + StrLen(d) = strlen(val); + StrLoc(d) = val; + + switch (a = si_s2i(attribs, abuf)) { + case A_LINES: case A_ROWS: { + if (!cnv:C_integer(d, tmp)) + return Failed; + if ((new_height = tmp) < 1) + return Failed; + new_height = ROWTOY(w, new_height); + new_height += MAXDESCENDER(w); + if (setheight(w, new_height) == Failed) return Failed; + break; + } + case A_COLUMNS: { + if (!cnv:C_integer(d, tmp)) + return Failed; + if ((new_width = tmp) < 1) + return Failed; + new_width = COLTOX(w, new_width + 1); + if (setwidth(w, new_width) == Failed) return Failed; + break; + } + case A_HEIGHT: { + if (!cnv:C_integer(d, tmp)) + return Failed; + if ((new_height = tmp) < 1) return Failed; + if (setheight(w, new_height) == Failed) return Failed; + break; + } + case A_WIDTH: { + if (!cnv:C_integer(d, tmp)) + return Failed; + if ((new_width = tmp) < 1) return Failed; + if (setwidth(w, new_width) == Failed) return Failed; + break; + } + case A_SIZE: { + AttemptAttr(setsize(w, val)); + break; + } + case A_GEOMETRY: { + AttemptAttr(setgeometry(w, val)); + break; + } + case A_RESIZE: { + if (strcmp(val, "on") & strcmp(val, "off")) + return Failed; + allowresize(w, ATOBOOL(val)); + break; + } + case A_ROW: { + if (!cnv:C_integer(d, tmp)) + return Failed; + ws->y = ROWTOY(w, tmp) + wc->dy; + break; + } + case A_COL: { + if (!cnv:C_integer(d, tmp)) + return Failed; + ws->x = COLTOX(w, tmp) + wc->dx; + break; + } + case A_CANVAS: { + AttemptAttr(setcanvas(w,val)); + break; + } + case A_ICONIC: { + AttemptAttr(seticonicstate(w,val)); + break; + } + case A_ICONIMAGE: { + if (!val[0]) return Failed; + AttemptAttr(seticonimage(w, &d)); + break; + } + case A_ICONLABEL: { + AttemptAttr(seticonlabel(w, val)); + break; + } + case A_ICONPOS: { + AttemptAttr(seticonpos(w,val)); + break; + } + case A_LABEL: + case A_WINDOWLABEL: { + AttemptAttr(setwindowlabel(w, val)); + break; + } + case A_CURSOR: { + int on_off; + if (strcmp(val, "on") & strcmp(val, "off")) + return Failed; + on_off = ATOBOOL(val); + setcursor(w, on_off); + break; + } + case A_FONT: { + AttemptAttr(setfont(w, &valptr)); + break; + } + case A_PATTERN: { + AttemptAttr(SetPattern(w, val, strlen(val))); + break; + } + case A_POS: { + AttemptAttr(setpos(w, val)); + break; + } + case A_POSX: { + char tmp[20]; + sprintf(tmp,"%s,%d",val,ws->posy); + AttemptAttr(setpos(w, tmp)); + break; + } + case A_POSY: { + char tmp[20]; + sprintf(tmp,"%d,%s",ws->posx,val); + AttemptAttr(setpos(w, tmp)); + break; + } + case A_FG: { + if (cnv:C_integer(d, tmp) && tmp < 0) { + if (isetfg(w, tmp) != Succeeded) return Failed; + } + else { + if (setfg(w, val) != Succeeded) return Failed; + } + break; + } + case A_BG: { + if (cnv:C_integer(d, tmp) && tmp < 0) { + if (isetbg(w, tmp) != Succeeded) return Failed; + } + else { + if (setbg(w, val) != Succeeded) return Failed; + } + break; + } + case A_GAMMA: { + if (sscanf(val, "%lf%c", &gamma, &c) != 1 || gamma <= 0.0) + return Failed; + if (setgamma(w, gamma) != Succeeded) + return Failed; + break; + } + case A_FILLSTYLE: { + AttemptAttr(setfillstyle(w, val)); + break; + } + case A_LINESTYLE: { + AttemptAttr(setlinestyle(w, val)); + break; + } + case A_LINEWIDTH: { + if (!cnv:C_integer(d, tmp)) + return Failed; + if (setlinewidth(w, tmp) == Error) + return Failed; + break; + } + case A_POINTER: { + AttemptAttr(setpointer(w, val)); + break; + } + case A_DRAWOP: { + AttemptAttr(setdrawop(w, val)); + break; + } + case A_DISPLAY: { + AttemptAttr(setdisplay(w,val)); + break; + } + case A_X: { + if (!cnv:C_integer(d, tmp)) + return Failed; + ws->x = tmp + wc->dx; + UpdateCursorPos(ws, wc); /* tell system where to blink it */ + break; + } + case A_Y: { + if (!cnv:C_integer(d, tmp)) + return Failed; + ws->y = tmp + wc->dy; + UpdateCursorPos(ws, wc); /* tell system where to blink it */ + break; + } + case A_DX: { + if (!cnv:C_integer(d, tmp)) + return Failed; + wc->dx = tmp; + UpdateCursorPos(ws, wc); /* tell system where to blink it */ + break; + } + case A_DY: { + if (!cnv:C_integer(d, tmp)) + return Failed; + wc->dy = tmp; + UpdateCursorPos(ws, wc); /* tell system where to blink it */ + break; + } + case A_LEADING: { + if (!cnv:C_integer(d, tmp)) + return Failed; + setleading(w, tmp); + break; + } + case A_IMAGE: { + /* first try GIF; then try platform-dependent format */ + r = readGIF(val, 0, &ws->initimage); + if (r == Succeeded) { + setwidth(w, ws->initimage.width); + setheight(w, ws->initimage.height); + } + else + r = setimage(w, val); + AttemptAttr(r); + break; + } + case A_ECHO: { + if (strcmp(val, "on") & strcmp(val, "off")) + return Failed; + if (ATOBOOL(val)) SETECHOON(w); + else CLRECHOON(w); + break; + } + case A_CLIPX: + case A_CLIPY: + case A_CLIPW: + case A_CLIPH: { + if (!*val) { + wc->clipx = wc->clipy = 0; + wc->clipw = wc->cliph = -1; + unsetclip(w); + } + else { + if (!cnv:C_integer(d, tmp)) + return Failed; + if (wc->clipw < 0) { + wc->clipx = wc->clipy = 0; + wc->clipw = ws->width; + wc->cliph = ws->height; + } + switch (a) { + case A_CLIPX: wc->clipx = tmp; break; + case A_CLIPY: wc->clipy = tmp; break; + case A_CLIPW: wc->clipw = tmp; break; + case A_CLIPH: wc->cliph = tmp; break; + } + setclip(w); + } + break; + } + case A_REVERSE: { + if (strcmp(val, "on") && strcmp(val, "off")) + return Failed; + if ((!ATOBOOL(val) && ISREVERSE(w)) || + (ATOBOOL(val) && !ISREVERSE(w))) { + toggle_fgbg(w); + ISREVERSE(w) ? CLRREVERSE(w) : SETREVERSE(w); + } + break; + } + case A_POINTERX: { + if (!cnv:C_integer(d, tmp)) + return Failed; + ws->pointerx = tmp + wc->dx; + warpPointer(w, ws->pointerx, ws->pointery); + break; + } + case A_POINTERY: { + if (!cnv:C_integer(d, tmp)) + return Failed; + ws->pointery = tmp + wc->dy; + warpPointer(w, ws->pointerx, ws->pointery); + break; + } + case A_POINTERCOL: { + if (!cnv:C_integer(d, tmp)) + return Failed; + ws->pointerx = COLTOX(w, tmp) + wc->dx; + warpPointer(w, ws->pointerx, ws->pointery); + break; + } + case A_POINTERROW: { + if (!cnv:C_integer(d, tmp)) + return Failed; + ws->pointery = ROWTOY(w, tmp) + wc->dy; + warpPointer(w, ws->pointerx, ws->pointery); + break; + } + /* + * remaining valid attributes are error #147 + */ + case A_DEPTH: + case A_DISPLAYHEIGHT: + case A_DISPLAYWIDTH: + case A_FHEIGHT: + case A_FWIDTH: + case A_ASCENT: + case A_DESCENT: + ReturnErrNum(147, Error); + /* + * invalid attribute + */ + default: + ReturnErrNum(145, Error); + } + strncpy(abuf, s, len); + abuf[len] = '\0'; + } + else { + int a; + /* + * get an attribute + */ + strncpy(abuf, s, len); + abuf[len] = '\0'; + switch (a=si_s2i(attribs, abuf)) { + case A_IMAGE: + ReturnErrNum(147, Error); + case A_VISUAL: + if (getvisual(w, abuf) == Failed) return Failed; + MakeStr(abuf, strlen(abuf), answer); + break; + case A_DEPTH: + MakeInt(SCREENDEPTH(w), answer); + break; + case A_DISPLAY: + getdisplay(w, abuf); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_ASCENT: + MakeInt(ASCENT(w), answer); + break; + case A_DESCENT: + MakeInt(DESCENT(w), answer); + break; + case A_FHEIGHT: + MakeInt(FHEIGHT(w), answer); + break; + case A_FWIDTH: + MakeInt(FWIDTH(w), answer); + break; + case A_ROW: + MakeInt(YTOROW(w, ws->y - wc->dy), answer); + break; + case A_COL: + MakeInt(1 + XTOCOL(w, ws->x - wc->dx), answer); + break; + case A_POINTERROW: { + XPoint xp; + query_pointer(w, &xp); + MakeInt(YTOROW(w, xp.y - wc->dy), answer); + break; + } + case A_POINTERCOL: { + XPoint xp; + query_pointer(w, &xp); + MakeInt(1 + XTOCOL(w, xp.x - wc->dx), answer); + break; + } + case A_LINES: + case A_ROWS: + MakeInt(YTOROW(w,ws->height - DESCENT(w)), answer); + break; + case A_COLUMNS: + MakeInt(XTOCOL(w,ws->width), answer); + break; + case A_POS: case A_POSX: case A_POSY: + if (getpos(w) == Failed) + return Failed; + switch (a) { + case A_POS: + sprintf(abuf, "%d,%d", ws->posx, ws->posy); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_POSX: + MakeInt(ws->posx, answer); + break; + case A_POSY: + MakeInt(ws->posy, answer); + break; + } + break; + case A_FG: + getfg(w, abuf); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_BG: + getbg(w, abuf); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_GAMMA: + Protect(BlkLoc(*answer) = (union block *)alcreal(wc->gamma), + return Error); + answer->dword = D_Real; + break; + case A_FILLSTYLE: + sprintf(abuf, "%s", + (wc->fillstyle == FS_SOLID) ? "solid" : + (wc->fillstyle == FS_STIPPLE) ? "masked" : "textured"); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_LINESTYLE: + getlinestyle(w, abuf); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_LINEWIDTH: + MakeInt(LINEWIDTH(w), answer); + break; + case A_HEIGHT: { MakeInt(ws->height, answer); break; } + case A_WIDTH: { MakeInt(ws->width, answer); break; } + case A_SIZE: + sprintf(abuf, "%d,%d", ws->width, ws->height); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_RESIZE: + sprintf(abuf,"%s",(ISRESIZABLE(w)?"on":"off")); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_DISPLAYHEIGHT: + MakeInt(DISPLAYHEIGHT(w), answer); + break; + case A_DISPLAYWIDTH: + MakeInt(DISPLAYWIDTH(w), answer); + break; + case A_CURSOR: + sprintf(abuf,"%s",(ISCURSORON(w)?"on":"off")); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_ECHO: + sprintf(abuf,"%s",(ISECHOON(w)?"on":"off")); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_REVERSE: + sprintf(abuf,"%s",(ISREVERSE(w)?"on":"off")); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_FONT: + getfntnam(w, abuf); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_X: MakeInt(ws->x - wc->dx, answer); break; + case A_Y: MakeInt(ws->y - wc->dy, answer); break; + case A_DX: MakeInt(wc->dx, answer); break; + case A_DY: MakeInt(wc->dy, answer); break; + case A_LEADING: MakeInt(LEADING(w), answer); break; + case A_POINTERX: { + XPoint xp; + query_pointer(w, &xp); + MakeInt(xp.x - wc->dx, answer); + break; + } + case A_POINTERY: { + XPoint xp; + query_pointer(w, &xp); + MakeInt(xp.y - wc->dy, answer); + break; + } + case A_POINTER: + getpointername(w, abuf); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_DRAWOP: + getdrawop(w, abuf); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_GEOMETRY: + if (getpos(w) == Failed) return Failed; + if (ws->win) + sprintf(abuf, "%dx%d+%d+%d", + ws->width, ws->height, ws->posx, ws->posy); + else + sprintf(abuf, "%dx%d", ws->pixwidth, ws->pixheight); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_CANVAS: + getcanvas(w, abuf); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_ICONIC: + geticonic(w, abuf); + MakeStr(abuf, strlen(abuf), answer); + break; + case A_ICONIMAGE: + if (ICONFILENAME(w) != NULL) + sprintf(abuf, "%s", ICONFILENAME(w)); + else *abuf = '\0'; + MakeStr(abuf, strlen(abuf), answer); + break; + case A_ICONLABEL: + if (ICONLABEL(w) != NULL) + sprintf(abuf, "%s", ICONLABEL(w)); + else return Failed; + MakeStr(abuf, strlen(abuf), answer); + break; + case A_LABEL: + case A_WINDOWLABEL: + if (WINDOWLABEL(w) != NULL) + sprintf(abuf,"%s", WINDOWLABEL(w)); + else return Failed; + MakeStr(abuf, strlen(abuf), answer); + break; + case A_ICONPOS: { + switch (geticonpos(w,abuf)) { + case Failed: return Failed; + case Error: return Failed; + } + MakeStr(abuf, strlen(abuf), answer); + break; + } + case A_PATTERN: { + s = w->context->patternname; + if (s != NULL) + MakeStr(s, strlen(s), answer); + else + MakeStr("black", 5, answer); + break; + } + case A_CLIPX: + if (wc->clipw >= 0) + MakeInt(wc->clipx, answer); + else + *answer = nulldesc; + break; + case A_CLIPY: + if (wc->clipw >= 0) + MakeInt(wc->clipy, answer); + else + *answer = nulldesc; + break; + case A_CLIPW: + if (wc->clipw >= 0) + MakeInt(wc->clipw, answer); + else + *answer = nulldesc; + break; + case A_CLIPH: + if (wc->clipw >= 0) + MakeInt(wc->cliph, answer); + else + *answer = nulldesc; + break; + default: + ReturnErrNum(145, Error); + } + } + wflush(w); + return Succeeded; + } + +/* + * rectargs -- interpret rectangle arguments uniformly + * + * Given an arglist and the index of the next x value, rectargs sets + * x/y/width/height to explicit or defaulted values. These result values + * are in canonical form: Width and height are nonnegative and x and y + * have been corrected by dx and dy. + * + * Returns index of bad argument, if any, or -1 for success. + */ +int rectargs(w, argc, argv, i, px, py, pw, ph) +wbp w; +int argc; +dptr argv; +int i; +C_integer *px, *py, *pw, *ph; + { + int defw, defh; + wcp wc = w->context; + wsp ws = w->window; + + /* + * Get x and y, defaulting to -dx and -dy. + */ + if (i >= argc) + *px = -wc->dx; + else if (!def:C_integer(argv[i], -wc->dx, *px)) + return i; + + if (++i >= argc) + *py = -wc->dy; + else if (!def:C_integer(argv[i], -wc->dy, *py)) + return i; + + *px += wc->dx; + *py += wc->dy; + + /* + * Get w and h, defaulting to extend to the edge + */ + defw = ws->width - *px; + defh = ws->height - *py; + + if (++i >= argc) + *pw = defw; + else if (!def:C_integer(argv[i], defw, *pw)) + return i; + + if (++i >= argc) + *ph = defh; + else if (!def:C_integer(argv[i], defh, *ph)) + return i; + + /* + * Correct negative w/h values. + */ + if (*pw < 0) + *px -= (*pw = -*pw); + if (*ph < 0) + *py -= (*ph = -*ph); + + return -1; + } + +/* + * docircles -- draw or file circles. + * + * Helper for DrawCircle and FillCircle. + * Returns index of bad argument, or -1 for success. + */ +int docircles(w, argc, argv, fill) +wbp w; +int argc; +dptr argv; +int fill; + { + XArc arc; + int i, dx, dy; + double x, y, r, theta, alpha; + + dx = w->context->dx; + dy = w->context->dy; + + for (i = 0; i < argc; i += 5) { /* for each set of five args */ + + /* + * Collect arguments. + */ + if (i + 2 >= argc) + return i + 2; /* missing y or r */ + if (!cnv:C_double(argv[i], x)) + return i; + if (!cnv:C_double(argv[i + 1], y)) + return i + 1; + if (!cnv:C_double(argv[i + 2], r)) + return i + 2; + if (i + 3 >= argc) + theta = 0.0; + else if (!def:C_double(argv[i + 3], 0.0, theta)) + return i + 3; + if (i + 4 >= argc) + alpha = 2 * Pi; + else if (!def:C_double(argv[i + 4], 2 * Pi, alpha)) + return i + 4; + + /* + * Put in canonical form: r >= 0, -2*pi <= theta < 0, alpha >= 0. + */ + if (r < 0) { /* ensure positive radius */ + r = -r; + theta += Pi; + } + if (alpha < 0) { /* ensure positive extent */ + theta += alpha; + alpha = -alpha; + } + + theta = fmod(theta, 2 * Pi); + if (theta > 0) /* normalize initial angle */ + theta -= 2 * Pi; + + /* + * Build the Arc descriptor. + */ + arc.x = x + dx - r; + arc.y = y + dy - r; + ARCWIDTH(arc) = 2 * r; + ARCHEIGHT(arc) = 2 * r; + + arc.angle1 = ANGLE(theta); + if (alpha >= 2 * Pi) + arc.angle2 = EXTENT(2 * Pi); + else + arc.angle2 = EXTENT(alpha); + + /* + * Draw or fill the arc. + */ + if (fill) { /* {} required due to form of macros */ + fillarcs(w, &arc, 1); + } + else { + drawarcs(w, &arc, 1); + } + } + return -1; + } + + +/* + * genCurve - draw a smooth curve through a set of points. Algorithm from + * Barry, Phillip J., and Goldman, Ronald N. (1988). + * A Recursive Evaluation Algorithm for a class of Catmull-Rom Splines. + * Computer Graphics 22(4), 199-204. + */ +void genCurve(w, p, n, helper) +wbp w; +XPoint *p; +int n; +void (*helper) (wbp, XPoint [], int); + { + int i, j, steps; + float ax, ay, bx, by, stepsize, stepsize2, stepsize3; + float x, dx, d2x, d3x, y, dy, d2y, d3y; + XPoint *thepoints = NULL; + long npoints = 0; + + for (i = 3; i < n; i++) { + /* + * build the coefficients ax, ay, bx and by, using: + * _ _ _ _ + * i i 1 | -1 3 -3 1 | | Pi-3 | + * Q (t) = T * M * G = - | 2 -5 4 -1 | | Pi-2 | + * CR Bs 2 | -1 0 1 0 | | Pi-1 | + * |_ 0 2 0 0_| |_Pi _| + */ + + ax = p[i].x - 3 * p[i-1].x + 3 * p[i-2].x - p[i-3].x; + ay = p[i].y - 3 * p[i-1].y + 3 * p[i-2].y - p[i-3].y; + bx = 2 * p[i-3].x - 5 * p[i-2].x + 4 * p[i-1].x - p[i].x; + by = 2 * p[i-3].y - 5 * p[i-2].y + 4 * p[i-1].y - p[i].y; + + /* + * calculate the forward differences for the function using + * intervals of size 0.1 + */ +#ifndef abs +#define abs(x) ((x)<0?-(x):(x)) +#endif +#ifndef max +#define max(x,y) ((x>y)?x:y) +#endif + + steps = max(abs(p[i-1].x - p[i-2].x), abs(p[i-1].y - p[i-2].y)) + 10; + if (steps+4 > npoints) { + if (thepoints != NULL) free(thepoints); + thepoints = malloc((steps+4) * sizeof(XPoint)); + npoints = steps+4; + } + + stepsize = 1.0/steps; + stepsize2 = stepsize * stepsize; + stepsize3 = stepsize * stepsize2; + + x = thepoints[0].x = p[i-2].x; + y = thepoints[0].y = p[i-2].y; + dx = (stepsize3*0.5)*ax + (stepsize2*0.5)*bx + (stepsize*0.5)*(p[i-1].x-p[i-3].x); + dy = (stepsize3*0.5)*ay + (stepsize2*0.5)*by + (stepsize*0.5)*(p[i-1].y-p[i-3].y); + d2x = (stepsize3*3) * ax + stepsize2 * bx; + d2y = (stepsize3*3) * ay + stepsize2 * by; + d3x = (stepsize3*3) * ax; + d3y = (stepsize3*3) * ay; + + /* calculate the points for drawing the curve */ + + for (j = 0; j < steps; j++) { + x = x + dx; + y = y + dy; + dx = dx + d2x; + dy = dy + d2y; + d2x = d2x + d3x; + d2y = d2y + d3y; + thepoints[j + 1].x = (int)x; + thepoints[j + 1].y = (int)y; + } + helper(w, thepoints, steps + 1); + } + if (thepoints != NULL) { + free(thepoints); + thepoints = NULL; + } + } + +static void curveHelper(wbp w, XPoint *thepoints, int n) + { + /* + * Could use drawpoints(w, thepoints, n) + * but that ignores the linewidth and linestyle attributes... + * Might make linestyle work a little better by "compressing" straight + * sections produced by genCurve into single drawline points. + */ + drawlines(w, thepoints, n); + } + +/* + * draw a smooth curve through the array of points + */ +void drawCurve(w, p, n) +wbp w; +XPoint *p; +int n; + { + genCurve(w, p, n, curveHelper); + } + +/* + * Compare two unsigned long values for qsort or qsearch. + */ +int ulcmp(p1, p2) +pointer p1, p2; + { + register unsigned long u1 = *(unsigned int *)p1; + register unsigned long u2 = *(unsigned int *)p2; + + if (u1 < u2) + return -1; + else + return (u1 > u2); + } + +/* + * the next section consists of code to deal with string-integer + * (stringint) symbols. See graphics.h. + */ + +/* + * string-integer comparison, for qsearch() + */ +static int sicmp(sip1,sip2) +siptr sip1, sip2; +{ + return strcmp(sip1->s, sip2->s); +} + +/* + * string-integer lookup function: given a string, return its integer + */ +int si_s2i(sip,s) +siptr sip; +char *s; +{ + stringint key; + siptr p; + key.s = s; + + p = (siptr)qsearch((char *)&key,(char *)(sip+1),sip[0].i,sizeof(key),sicmp); + if (p) return p->i; + return -1; +} + +/* + * string-integer inverse function: given an integer, return its string + */ +char *si_i2s(sip,i) +siptr sip; +int i; +{ + register siptr sip2 = sip+1; + for(;sip2<=sip+sip[0].i;sip2++) if (sip2->i == i) return sip2->s; + return NULL; +} + + +/* + * And now, the stringint data. + * Convention: the 0'th element of a stringint array contains the + * NULL string, and an integer count of the # of elements in the array. + */ + +stringint attribs[] = { + { 0, NUMATTRIBS}, + {"ascent", A_ASCENT}, + {"bg", A_BG}, + {"canvas", A_CANVAS}, + {"ceol", A_CEOL}, + {"cliph", A_CLIPH}, + {"clipw", A_CLIPW}, + {"clipx", A_CLIPX}, + {"clipy", A_CLIPY}, + {"col", A_COL}, + {"columns", A_COLUMNS}, + {"cursor", A_CURSOR}, + {"depth", A_DEPTH}, + {"descent", A_DESCENT}, + {"display", A_DISPLAY}, + {"displayheight", A_DISPLAYHEIGHT}, + {"displaywidth", A_DISPLAYWIDTH}, + {"drawop", A_DRAWOP}, + {"dx", A_DX}, + {"dy", A_DY}, + {"echo", A_ECHO}, + {"fg", A_FG}, + {"fheight", A_FHEIGHT}, + {"fillstyle", A_FILLSTYLE}, + {"font", A_FONT}, + {"fwidth", A_FWIDTH}, + {"gamma", A_GAMMA}, + {"geometry", A_GEOMETRY}, + {"height", A_HEIGHT}, + {"iconic", A_ICONIC}, + {"iconimage", A_ICONIMAGE}, + {"iconlabel", A_ICONLABEL}, + {"iconpos", A_ICONPOS}, + {"image", A_IMAGE}, + {"label", A_LABEL}, + {"leading", A_LEADING}, + {"lines", A_LINES}, + {"linestyle", A_LINESTYLE}, + {"linewidth", A_LINEWIDTH}, + {"pattern", A_PATTERN}, + {"pointer", A_POINTER}, + {"pointercol", A_POINTERCOL}, + {"pointerrow", A_POINTERROW}, + {"pointerx", A_POINTERX}, + {"pointery", A_POINTERY}, + {"pos", A_POS}, + {"posx", A_POSX}, + {"posy", A_POSY}, + {"resize", A_RESIZE}, + {"reverse", A_REVERSE}, + {"row", A_ROW}, + {"rows", A_ROWS}, + {"size", A_SIZE}, + {"visual", A_VISUAL}, + {"width", A_WIDTH}, + {"windowlabel", A_WINDOWLABEL}, + {"x", A_X}, + {"y", A_Y}, +}; + + +/* + * There are more, X-specific stringint arrays in ../common/xwindow.c + */ + +#endif /* Graphics */ diff --git a/src/runtime/rwinrsc.r b/src/runtime/rwinrsc.r new file mode 100644 index 0000000..a9091be --- /dev/null +++ b/src/runtime/rwinrsc.r @@ -0,0 +1,49 @@ +/* + * File: rwinrsc.r + * Icon graphics interface resources + * + * Resources are allocated through a layer of internal management + * routines in order to handle aliasing and resource sharing. + */ +#ifdef Graphics + +/* + * global variables. + */ + +wcp wcntxts = NULL; +wsp wstates = NULL; +wbp wbndngs = NULL; +int win_highwater = -1; + +#ifdef XWindows +#include "rxrsc.ri" +#endif /* XWindows */ + +/* + * allocate a window binding structure + */ +wbp alc_wbinding() + { + wbp w; + + GRFX_ALLOC(w, _wbinding); + GRFX_LINK(w, wbndngs); + return w; + } + +/* + * free a window binding. + */ +void free_binding(w) +wbp w; + { + w->refcount--; + if(w->refcount == 0) { + if (w->window) free_window(w->window); + if (w->context) free_context(w->context); + GRFX_UNLINK(w, wbndngs); + } + } + +#endif /* Graphics */ diff --git a/src/runtime/rwinsys.r b/src/runtime/rwinsys.r new file mode 100644 index 0000000..084607e --- /dev/null +++ b/src/runtime/rwinsys.r @@ -0,0 +1,17 @@ +/* + * File: rwinsys.r + * Window-system-specific window support routines. + * This file simply includes an appropriate r*win.ri file. + */ + +#ifdef Graphics + + #ifdef XWindows + #include "rxwin.ri" + #endif /* XWindows */ + + #ifdef WinGraphics + #include "rmswin.ri" + #endif /* WinGraphics */ + +#endif /* Graphics */ diff --git a/src/runtime/rxrsc.ri b/src/runtime/rxrsc.ri new file mode 100644 index 0000000..c99edeb --- /dev/null +++ b/src/runtime/rxrsc.ri @@ -0,0 +1,995 @@ +/* + * File: rxrsc.ri - X Window specific resource allocation/deallocation + * + * Resources are allocated through a layer of internal management + * routines in order to handle aliasing and resource sharing. + */ + +static int rgbhash[5000]; /* rgb hash table */ + +wdp wdsplys; + +wfp findfont(wbp w, char *fam, int size, int flags); +int okfont(char *spec, int size, int flags); +int fontcmp(char *font1, char *font2, int size, int flags); + +/* check for color match */ +#define CMATCH(cp, rr, gg, bb) \ + ((cp)->r == (rr) && (cp)->g == (gg) && (cp->b) == (bb) && \ + (cp)->type == SHARED && (cp)->refcount > 0) + +/* + * Allocate a color given linear r, g, b. Colors are shared on a + * per-display basis, but they are often freed on a per-window basis, + * so they are remembered in two structures. + */ +wclrp alc_rgb(w,s,r,g,b,is_iconcolor) +wbp w; +char *s; +unsigned int r,g,b; +int is_iconcolor; + { + wclrp cp; + LinearColor lc; + XColor color; + int h, i; + int *numColors; + short *theColors; + STDLOCALS(w); + + /* + * handle black and white specially (no allocation) + */ + if ((r == 0) && (g == 0) && (b == 0)) + return wd->colrptrs[0]; + if ((r == 65535) && (g == 65535) && (b == 65535)) + return wd->colrptrs[1]; + + if (is_iconcolor) { + if (ws->iconColors == NULL) { + ws->iconColors = (short *)calloc(WMAXCOLORS, sizeof(short)); + if (ws->iconColors == NULL) return NULL; + } + numColors = &(ws->numiColors); + theColors = ws->iconColors; + } + else { + if (ws->theColors == NULL) { + ws->theColors = (short *)calloc(WMAXCOLORS, sizeof(short)); + if (ws->theColors == NULL) return NULL; + } + numColors = &(ws->numColors); + theColors = ws->theColors; + } + + /* + * Change into server-dependent R G B + */ + lc.red = r; + lc.green = g; + lc.blue = b; + color = xcolor(w, lc); + r = color.red; + g = color.green; + b = color.blue; + h = (503 * r + 509 * g + 499 * b) % ElemCount(rgbhash); + + /* + * Search for the color in w's display + */ + if (wd->visual->class == TrueColor) { + /* + * TrueColor entries are linked on hash chains. + */ + i = rgbhash[h]; + while (i != 0 && !CMATCH(wd->colrptrs[i],r,g,b)) + i = wd->colrptrs[i]->next; + if (i == 0) + i = wd->numColors; /* indicate not found */ + } + else { + /* + * Search linearly through the list of colors. + */ + for (i = 2; i < wd->numColors; i++) + if (CMATCH(wd->colrptrs[i],r,g,b)) + break; + } + + if (i >= wd->numColors) { + int j; + /* + * color not found, must allocate + */ + if (!XAllocColor(stddpy, wd->cmap, &color)) { + /* try again with a virtual colormap (but not for an icon) */ + if (is_iconcolor || !go_virtual(w) || + !XAllocColor(stddpy, wd->cmap, &color)) + return NULL; + } + + j = alc_centry(wd); + if (j == 0) + return NULL; + cp = wd->colrptrs[j]; + cp->next = rgbhash[h]; + rgbhash[h] = j; + strcpy(cp->name, s); + /* + * Store server color as requested in color table. + */ + cp->r = r; + cp->g = g; + cp->b = b; + cp->c = color.pixel; + cp->type = SHARED; + /* + * Remember in window color list, too, if not TrueColor visual. + */ + if (wd->visual->class != TrueColor && *numColors < WMAXCOLORS) + theColors[(*numColors)++] = j; + return cp; + } + else { + /* color is found, alias it and put it in the window color table */ + int k; + for(k=0; k < *numColors; k++){ + if (theColors[k] == i) { + /* already there, no further action needed */ + return wd->colrptrs[i]; + } + } + wd->colrptrs[i]->refcount++; + /* + * Remember in window color list, too, if not TrueColor visual. + */ + if (wd->visual->class != TrueColor && *numColors < WMAXCOLORS) + theColors[(*numColors)++] = i; + return wd->colrptrs[i]; + } + } + +/* + * allocate a color entry, return index + */ +int alc_centry(wd) +wdp wd; +{ + int j; + + if (wd->visual->class == TrueColor) { + /* + * TrueColor entries are never freed, so skip the search. + */ + j = wd->numColors; + } + else { + /* + * Look for allocated but unused entry (beyond reserved entries 0 and 1) + */ + for (j = 2; j < wd->numColors; j++) { + if (wd->colrptrs[j]->refcount == 0) { + wd->colrptrs[j]->refcount = 1; + return j; + } + } + } + + /* + * No unused entry found. Make sure there's room for another pointer. + */ + if (wd->numColors == wd->cpSize) { + j = 2 * wd->cpSize; /* double the array size */ + wd->colrptrs = realloc(wd->colrptrs, j * sizeof(struct wcolor *)); + if (wd->colrptrs == NULL) + ReturnErrNum(305, 0); + wd->cpSize = j; + } + /* + * Now allocate a new entry. + */ + j = wd->numColors; + wd->colrptrs[j] = calloc(1, sizeof(struct wcolor)); + if (wd->colrptrs[j] == NULL) + ReturnErrNum(305, 0); + wd->colrptrs[j]->refcount = 1; + wd->numColors++; + return j; +} + +/* + * allocate by named color and return Icon color pointer. + * This is used by setfg and setbg. + */ +wclrp alc_color(w,s) +wbp w; +char *s; + { + wclrp rv; + long r, g, b; + + /* + * convert color to an r,g,b triple + */ + if (parsecolor(w, s, &r, &g, &b) != Succeeded) + return 0; + + /* + * return Icon color structure, allocated & reference counted in display + */ + Protect(rv = alc_rgb(w, s, r, g, b, 0), return 0); + return rv; + } + +/* + * copy color entries to reflect pixel transmission via CopyArea() + * (assumes w1 and w2 are on the same display) + */ +void copy_colors(w1, w2) +wbp w1, w2; + { + wsp ws1 = w1->window, ws2 = w2 -> window; + wdp wd = ws1->display; + int i1, i2, j; + + for (i1 = 0; i1 < ws1->numColors; i1++) { + j = ws1->theColors[i1]; + if (wd->colrptrs[j]->refcount > 0 && wd->colrptrs[j]->type != MUTABLE) { + for (i2 = 0; i2 < ws2->numColors; i2++) { + if (j == ws2->theColors[i2]) + break; + } + if (i2 >= ws2->numColors) { + /* need to add this color */ + wd->colrptrs[j]->refcount++; + if (ws2->display->visual->class != TrueColor + && ws2->numColors < WMAXCOLORS) { + if (ws2->theColors == NULL) + ws2->theColors = (short *)calloc(WMAXCOLORS, sizeof(short)); + if (ws2->theColors == NULL) + break; /* unlikely bug; should fail or something */ + ws2->theColors[ws2->numColors++] = j; + } + /* else cannot record it -- table full, or unneeded for TrueColor */ + } + } + } + } + +/* + * free a single color allocated by a given window + */ +void free_xcolor(w,c) +wbp w; +unsigned long c; + { + int i; + STDLOCALS(w); + + for (i = 0; i < ws->numColors; i++) { + if (wd->colrptrs[ws->theColors[i]]->c == c) break; + } + if (i >= ws->numColors) { + /* "free_xcolor couldn't find the color in the window\n" */ + /* (for TrueColor visuals, this is normal) */ + } + else { + if (--(wd->colrptrs[ws->theColors[i]]->refcount) == 0) { + XFreeColors(stddpy, wd->cmap, &c, 1, 0); + ws->numColors--; + if (ws->numColors != i) + ws->theColors[i] = ws->theColors[ws->numColors]; + } + } + } + +/* + * free the colors allocated by a given window. extent indicates how much + * to free. extent == 0 implies window colors except black, white, + * fg, bg, wbg, and mutable colors. extent == 1 implies free icon colors. + * extent == 2 implies free window AND fg/bg/wbg (window is closed) + */ +void free_xcolors(w, extent) +wbp w; +int extent; + { + int i; + unsigned long toFree[WMAXCOLORS]; + int freed = 0; + int *numColors; + int numSaved; + short *theColors; + STDLOCALS(w); + + numColors = (extent==1 ? &(ws->numiColors) : &(ws->numColors)); + theColors = (extent==1 ? ws->iconColors : ws->theColors); + + numSaved = 0; + for (i = *numColors-1; i >= 0; i--) { + int j = theColors[i]; + + if (j < 2) /* black & white are permanent residents */ + continue; + /* + * don't free fg, bg, or mutable color + */ + if (((extent==0) && (wd->colrptrs[j] == w->context->fg)) || + ((extent==0) && (wd->colrptrs[j] == w->context->bg)) || + (wd->colrptrs[j]->type == MUTABLE)) { + theColors[numSaved++] = j; + continue; + } + +#ifdef FreeColorFix + /* + * don't free ANY context's fg or bg + */ + { + wcp wc; int numhits = 0; + for(wc=wcntxts; wc; wc=wc->next) { + if ((wc->fg == wd->colrptrs[j]) || + (wc->bg == wd->colrptrs[j])) { + if (numhits == 0) + theColors[numSaved++] = j; + numhits++; + } + } + if (numhits) { + if (numhits > wd->colrptrs[j]->refcount) + wd->colrptrs[j]->refcount = numhits; + continue; + } + } +#endif /* FreeColorFix */ + + if (--(wd->colrptrs[j]->refcount) == 0) { + toFree[freed++] = wd->colrptrs[j]->c; + } + } + if (freed>0) + XFreeColors(stddpy, wd->cmap, toFree, freed,0); + *numColors = numSaved; + } + +/* + * Allocate a virtual colormap with all colors used by the client copied from + * the default colormap to new colormap, and set all windows to use this new + * colormap. Returns 0 on failure. + */ +int go_virtual(w) +wbp w; +{ + wsp win; + STDLOCALS(w); + + if (wd->cmap != DefaultColormap(stddpy,wd->screen)) + return 0; /* already using a virtual colormap */ + + wd->cmap = XCopyColormapAndFree(stddpy,wd->cmap); + + /* set the colormap for all the windows to the new colormap */ + + for (win = wstates; win; win = win->next) + if ((win->display->display == stddpy) & (win->win != (Window)NULL)) + XSetWindowColormap(stddpy, win->win, wd->cmap); + + return 1; +} + +/* + * allocate a display on machine s + */ +wdp alc_display(s) +char *s; + { + int i; + double g; + wdp wd; + XColor color; + wclrp cp; + + if (s == NULL) s = getenv("DISPLAY"); + if (s == NULL) s = ""; + for(wd = wdsplys; wd; wd = wd->next) + if (!strcmp(wd->name,s)) { + wd->refcount++; + return wd; + } + + GRFX_ALLOC(wd, _wdisplay); + + strcpy(wd->name,s); + wd->display = XOpenDisplay((*s=='\0') ? NULL : s); + + if (wd->display == NULL) { + wd->refcount = 0; + free(wd); + return NULL; + } + wd->screen = DefaultScreen(wd->display); + wd->visual = DefaultVisual(wd->display, wd->screen); + wd->cmap = DefaultColormap(wd->display, wd->screen); + + /* + * Allocate initial set of color slots. + */ + wd->cpSize = 8; /* start with room for 8 colors */ + wd->colrptrs = alloc(wd->cpSize * sizeof(struct wcolor *)); + if (wd->colrptrs == NULL) + ReturnErrNum(305, NULL); + + /* + * Color slots 0 and 1 are permanently reserved for black and white + * respectively. + */ + alc_centry(wd); /* allocate slot 0 (ambiguous return value) */ + if (!alc_centry(wd)) /* allocate slot 1 */ + ReturnErrNum(305, NULL); + + cp = wd->colrptrs[0]; + strcpy(cp->name,"black"); + cp->type = SHARED; + cp->r = cp->g = cp->b = 0; + color.red = color.green = color.blue = 0; + if (XAllocColor(wd->display, wd->cmap, &color)) + cp->c = color.pixel; + else + cp->c = BlackPixel(wd->display,wd->screen); + + cp = wd->colrptrs[1]; + strcpy(cp->name,"white"); + cp->type = SHARED; + cp->r = cp->g = cp->b = 65535; + color.red = color.green = color.blue = 65535; + if (XAllocColor(wd->display, wd->cmap, &color)) + cp->c = color.pixel; + else + cp->c = WhitePixel(wd->display,wd->screen); + + /* + * Set the default gamma correction value for windows that are + * opened on this display. Start with configuration default, + * but if we can get an interpretation of "RGBi:.5/.5/.5", + * calculate a gamma value from that instead. + */ + wd->gamma = GammaCorrection; + if (XParseColor(wd->display, wd->cmap, "RGBi:.5/.5/.5", &color)) { + g = .299 * color.red + .587 * color.green + .114 * color.blue; + g /= 65535; + if (g >= 0.1 && g <= 0.9) /* sanity check */ + wd->gamma = log(0.5) / log(g); + } + + /* + * Initialize fonts and other things. + */ + wd->numFonts = 1; + wd->fonts = (wfp)malloc(sizeof(struct _wfont)); + if (wd->fonts == NULL) { + free(wd); + return NULL; + } + wd->fonts->refcount = 1; + wd->fonts->next = wd->fonts->previous = NULL; + wd->fonts->name = malloc(6); + if (wd->fonts->name == NULL) { + free(wd); + return NULL; + } + strcpy(wd->fonts->name,"fixed"); + wd->fonts->fsp = XLoadQueryFont(wd->display, "fixed"); + if (wd->fonts->fsp == NULL) { /* couldn't load "fixed"! */ + free(wd); + return NULL; + } + + { + XGCValues gcv; + Display *stddpy = wd->display; + gcv.font = wd->fonts->fsp->fid; + gcv.foreground = wd->colrptrs[0]->c; + gcv.background = wd->colrptrs[1]->c; + gcv.fill_style = FillSolid; + gcv.cap_style = CapProjecting; + wd->icongc = XCreateGC(stddpy, DefaultRootWindow(stddpy), + GCFont | GCForeground | GCBackground | GCFillStyle | GCCapStyle, &gcv); + if (wd->icongc == NULL) { + free(wd); + return NULL; + } + } + + wd->fonts->height = wd->fonts->fsp->ascent + wd->fonts->fsp->descent; + + GRFX_LINK(wd, wdsplys); + return wd; + } + +/* + * allocate font s in the display attached to w + */ +wfp alc_font(w,s) +wbp w; +char **s; + { + int flags, size; + wfp rv; + char family[MAXFONTWORD+1]; + char *stdfam; + + if (strcmp(*s, "fixed") != 0 && parsefont(*s, family, &flags, &size)) { + /* + * This is a legal Icon font spec (and it's not an unadorned "fixed"). + * Check first for special "standard" family names. + */ + if (!strcmp(family, "mono")) { + stdfam = "lucidatypewriter"; + flags |= FONTFLAG_MONO + FONTFLAG_SANS; + } + else if (!strcmp(family, "typewriter")) { + stdfam = "courier"; + flags |= FONTFLAG_MONO + FONTFLAG_SERIF; + } + else if (!strcmp(family, "sans")) { + stdfam = "helvetica"; + flags |= FONTFLAG_PROPORTIONAL + FONTFLAG_SANS; + } + else if (!strcmp(family, "serif")) { + stdfam = "times"; + flags |= FONTFLAG_PROPORTIONAL + FONTFLAG_SERIF; + } + else stdfam = NULL; + + if (stdfam) { + /* + * Standard name: first try preferred family, then generalize. + */ + rv = findfont(w, stdfam, size, flags); + if (!rv) + rv = findfont(w, "*", size, flags); + } + else { + /* + * Any other name: must match as specified. + */ + rv = findfont(w, family, size, flags); + } + + if (rv != NULL) + return rv; + } + + /* + * Not found as an Icon name; may be an X font name. + */ + return tryfont(w, *s); + } + +/* + * return pointer to field i inside XLFD (X Logical Font Description) s. + */ +char *xlfd_field(s, i) +char *s; +int i; + { + int j = 0; + while (j < i) { + if (*s == '\0') return ""; /* if no such field */ + if (*s++ == '-') j++; + } + return s; + } + +/* + * return size of font, treating a scalable font as having size n + */ +int xlfd_size(s, n) +char *s; +int n; + { + char *f; + int z; + + f = xlfd_field(s, XLFD_Size); + if (!*f) + return 0; + z = atoi(f); + if (z != 0) + return z; + else + return n; + } + +/* + * Find the best font matching a set of specifications. + */ +wfp findfont(w, family, size, flags) +wbp w; +char *family; +int size, flags; + { + char fontspec[MAXFONTWORD+100]; + char *p, *weight, *slant, *width, *spacing, **fontlist; + int n, champ, challenger, bestsize; + + /* + * Construct a font specification that enforces any stated requirements + * of size, weight, slant, set width, or proportionality. + */ + if (size > 0) + bestsize = size; + else + bestsize = DEFAULTFONTSIZE; + + if (flags & FONTFLAG_MEDIUM) + weight = "medium"; + else if ((flags & FONTFLAG_DEMI) && (flags & FONTFLAG_BOLD)) + weight = "demibold"; + else if (flags & FONTFLAG_BOLD) + weight = "bold"; + else if (flags & FONTFLAG_DEMI) + weight = "demi"; + else if (flags & FONTFLAG_LIGHT) + weight = "light"; + else + weight = "*"; + + if (flags & FONTFLAG_ITALIC) + slant = "i"; + else if (flags & FONTFLAG_OBLIQUE) + slant = "o"; + else if (flags & FONTFLAG_ROMAN) + slant = "r"; + else + slant = "*"; + + if (flags & FONTFLAG_NARROW) + width = "narrow"; + else if (flags & FONTFLAG_CONDENSED) + width = "condensed"; + else if (flags & FONTFLAG_NORMAL) + width = "normal"; + else if (flags & FONTFLAG_WIDE) + width = "wide"; + else if (flags & FONTFLAG_EXTENDED) + width = "extended"; + else + width = "*"; + + if (flags & FONTFLAG_PROPORTIONAL) + spacing = "p"; + else + spacing = "*"; /* can't specify {m or c} to X */ + + sprintf(fontspec, "-*-%s-%s-%s-%s-*-*-*-*-*-%s-*-*-*", + family, weight, slant, width, spacing); + + /* + * Get a list of matching fonts from the X server and find the best one. + */ + fontlist = XListFonts(w->window->display->display, fontspec, 2500, &n); + champ = 0; + while (champ < n && !okfont(fontlist[champ], size, flags)) + champ++; + if (champ >= n) { + XFreeFontNames(fontlist); + return NULL; /* nothing acceptable */ + } + for (challenger = champ + 1; challenger < n; challenger++) + if (okfont(fontlist[challenger], size, flags) + && fontcmp(fontlist[challenger], fontlist[champ], bestsize, flags) < 0) + champ = challenger; + + /* + * Set the scaling field, if needed, and load the font. + */ + p = xlfd_field(fontlist[champ], XLFD_Size); + if (p[0] == '0' && p[1] == '-') + sprintf(fontspec, "%.*s%d%s", p - fontlist[champ], + fontlist[champ], bestsize, p + 1); + else + strcpy(fontspec, fontlist[champ]); + XFreeFontNames(fontlist); + return tryfont(w, fontspec); + } + +/* + * check for minimum acceptability of a font + * (things that couldn't be filtered by the XLFD pattern): + * -- size wrong (there's a bug in OpenWindows 3.3 else X could do it) + * -- not monospaced (can't set pattern to match m or c but not p) + */ +int okfont(spec, size, flags) +char *spec; +int size, flags; + { + if (size > 0 && xlfd_size(spec, size) != size) + return 0; /* can't match explicit size request */ + if ((flags & FONTFLAG_MONO) && xlfd_field(spec, XLFD_Spacing)[0] == 'p') + return 0; /* requested mono, but this isn't */ + return 1; + } + +/* + * rank two fonts based on whether XLFD field n matches a preferred value. + * returns <0 if font1 is better, >0 if font2 is better, else 0. + */ +int fieldcmp(font1, font2, value, field) +char *font1, *font2, *value; +int field; + { + int len, r1, r2; + + len = strlen(value); + r1 = (strncmp(xlfd_field(font1, field), value, len) == 0); + r2 = (strncmp(xlfd_field(font2, field), value, len) == 0); + return r2 - r1; /* -1, 0, or 1 */ + } + +/* + * rank two fonts. + * returns <0 if font1 is better, >0 if font2 is better, else 0. + * + * Note that explicit requests for size, slant, weight, and width caused + * earlier filtering in findfont(), so all those flags aren't checked + * again here; normal values are just favored in case nothing was specified. + */ +int fontcmp(font1, font2, size, flags) +char *font1, *font2; +int size, flags; + { + int n; + +/* return if exactly one of the fonts matches value s in field n */ +#define PREFER(s,n) \ +do { int r = fieldcmp(font1, font2, s, n); if (r != 0) return r; } while (0) + +/* return if exactly one of the fonts does NOT match value s in field n */ +#define SPURN(s,n) \ +do { int r = fieldcmp(font1, font2, s, n); if (r != 0) return -r; } while (0) + + /* + * Prefer the font that is closest to the desired size. + */ + n = abs(size - xlfd_size(font1, size)) - abs(size - xlfd_size(font2, size)); + if (n != 0) + return n; + + /* + * try to check serifs (though not always indicated in X font description) + */ + if (flags & FONTFLAG_SANS) { + PREFER("sans", XLFD_AddStyle); + SPURN("serif", XLFD_AddStyle); + } + else if (flags & FONTFLAG_SERIF) { + PREFER("serif", XLFD_AddStyle); + SPURN("sans", XLFD_AddStyle); + } + + /* + * prefer normal values for other fields. These only have an effect + * for fields that were wildcarded when requesting the font list. + */ + PREFER("r", XLFD_Slant); /* prefer roman slant */ + PREFER("medium", XLFD_Weight); /* prefer medium weight */ + SPURN("demi", XLFD_Weight); /* prefer non-demi if no medium */ + PREFER("normal", XLFD_SetWidth); /* prefer normal width */ + PREFER("iso8859", XLFD_CharSet); /* prefer font of ASCII chars */ + SPURN("0", XLFD_PointSize); /* prefer tuned font to scaled */ + PREFER("adobe", XLFD_Foundry); /* these look better than others */ + + /* no significant difference */ + return 0; + } + +/* + * load a font and return a font structure. + */ + +wfp tryfont(w,s) +wbp w; +char *s; + { + wdp wd = w->window->display; + wfp rv; + /* + * see if the font is already loaded on this display + */ + for(rv = wd->fonts; rv != NULL; rv = rv->next) { + if (!strcmp(s,rv->name)) break; + } + if (rv != NULL) { + rv->refcount++; + return rv; + } + + /* + * load a new font + */ + GRFX_ALLOC(rv, _wfont); + rv->name = malloc(strlen(s) + 1); + if (rv->name == NULL) ReturnErrNum(305, NULL); + strcpy(rv->name, s); + rv->fsp = XLoadQueryFont(wd->display, rv->name); + if (rv->fsp == NULL){ + free(rv->name); + free(rv); + return NULL; + } + rv->height = rv->fsp->ascent + rv->fsp->descent; + w->context->leading = rv->height; + + /* + * link the font into this displays fontlist (but not at the head!) + */ + rv->next = wd->fonts->next; + rv->previous = wd->fonts; + if (wd->fonts->next) wd->fonts->next->previous = rv; + wd->fonts->next = rv; + return rv; + } + +/* + * allocate a context. Can't be called until w has a display and window. + */ +wcp alc_context(w) +wbp w; + { + wcp wc; + wdp wd = w->window->display; + + GRFX_ALLOC(wc, _wcontext); + wc->serial = ++context_serial; + wc->display = wd; + wd->refcount++; + wc->fg = wd->colrptrs[0]; + wc->fg->refcount++; + wc->bg = wd->colrptrs[1]; + wc->bg->refcount++; + wc->font = wd->fonts; + wc->leading = wd->fonts->height; + wc->drawop = GXcopy; + wc->gamma = wd->gamma; + wc->clipx = wc->clipy = 0; + wc->clipw = wc->cliph = -1; + wc->linewidth = 1; + + GRFX_LINK(wc, wcntxts); + return wc; + } + +/* + * allocate a context, cloning attributes from an existing context + */ +wcp clone_context(w) +wbp w; + { + wcp wc, rv; + XGCValues gcv; + XRectangle rec; + unsigned long gcmask = GCFont | GCForeground | GCBackground | + GCFillStyle | GCCapStyle | GCLineWidth | GCLineStyle; + + wc = w->context; + Protect(rv = alc_context(w), return NULL); + + rv->dx = wc->dx; + rv->dy = wc->dy; + rv->clipx = wc->clipx; + rv->clipy = wc->clipy; + rv->clipw = wc->clipw; + rv->cliph = wc->cliph; + rv->fg = wc->fg; + rv->fg->refcount++; + rv->bg = wc->bg; + rv->bg->refcount++; + rv->font = wc->font; + rv->font->refcount++; + rv->fillstyle = wc->fillstyle; + rv->linestyle = wc->linestyle; + rv->linewidth = wc->linewidth; + rv->drawop = wc->drawop; + rv->gamma = wc->gamma; + rv->bits = wc->bits; + + if (ISXORREVERSE(w)) + gcv.foreground = rv->fg->c ^ rv->bg->c; + else + gcv.foreground = rv->fg->c; + gcv.background = rv->bg->c; + gcv.font = rv->font->fsp->fid; + gcv.line_style = rv->linestyle; + gcv.line_width = rv->linewidth; + if (rv->linewidth > 1) { + gcv.dashes = 3 * rv->linewidth; + gcmask |= GCDashList; + } + gcv.fill_style = rv->fillstyle; + gcv.cap_style = CapProjecting; + rv->gc = XCreateGC(w->window->display->display,w->window->pix,gcmask,&gcv); + if (rv->gc == NULL) { + free(rv); + return NULL; + } + if (rv->clipw >= 0) { + rec.x = rv->clipx; + rec.y = rv->clipy; + rec.width = rv->clipw; + rec.height = rv->cliph; + XSetClipRectangles(rv->display->display, rv->gc, 0, 0, &rec, 1,Unsorted); + } + return rv; + } + +/* + * allocate a window state structure + */ +wsp alc_winstate() + { + wsp ws; + + GRFX_ALLOC(ws, _wstate); + ws->serial = ++canvas_serial; + ws->bits = 1024; /* echo ON; others OFF */ + ws->filep = nulldesc; + ws->listp = nulldesc; + ws->theCursor = si_s2i(cursorsyms, "left ptr") >> 1; + ws->iconic = NormalState; + ws->posx = ws->posy = -(MaxInt); + GRFX_LINK(ws, wstates); + return ws; + } + +/* + * free a window state + */ +int free_window(ws) +wsp ws; + { + ws->refcount--; + if(ws->refcount == 0) { + ws->bits |= 1; /* SETZOMBIE */ + if (ws->win != (Window) NULL) { + XDestroyWindow(ws->display->display, ws->win); + XFlush(ws->display->display); + while (ws->win != (Window) NULL) + if (pollevent() == -1) return -1; + } + GRFX_UNLINK(ws, wstates); + } + return 0; + } + +/* + * free a window context + */ +void free_context(wc) +wcp wc; + { + wc->refcount--; + if(wc->refcount == 0) { + if (wc->gc != NULL) + XFreeGC(wc->display->display, wc->gc); + free_display(wc->display); + GRFX_UNLINK(wc, wcntxts); + } + } + +/* + * free a display + */ +void free_display(wd) +wdp wd; + { + wd->refcount--; + if(wd->refcount == 0) { + if (wd->cmap != DefaultColormap(wd->display, wd->screen)) + XFreeColormap(wd->display, wd->cmap); + XCloseDisplay(wd->display); + if (wd->previous) wd->previous->next = wd->next; + else wdsplys = wd->next; + if (wd->next) wd->next->previous = wd->previous; + free(wd); + } + } diff --git a/src/runtime/rxwin.ri b/src/runtime/rxwin.ri new file mode 100644 index 0000000..c2dc48c --- /dev/null +++ b/src/runtime/rxwin.ri @@ -0,0 +1,3475 @@ +/* + * File: rxwin.ri - X11 system-specific graphics interface code. + */ + +#ifdef Graphics + +#define RootState IconicState+1 + +/* + * Global variables specific to X + */ +static XSizeHints size_hints; + +/* + * function prototypes + */ +static int handle_misc (wdp display, wbp w); +static int handle_config (wbp w, XConfigureEvent *event); +static int handle_exposures (wbp w, XExposeEvent *event); +static void handle_mouse (wbp w, XButtonEvent *event); +static void handle_keypress (wbp w, XKeyEvent *event); +static void postcursor (wbp w); +static void scrubcursor (wbp w); +static XImage * getximage (wbp w, int x, int y, + int width, int height, int init); +static void moveWindow (wbp w, int x, int y); +static void makeIcon (wbp w, int x, int y); +static int wmap (wbp w); +static Pixmap loadimage (wbp w, char *filename, unsigned int *height, + unsigned int *width, int atorigin, int *status); + + +/* + * write some text to both the window and the pixmap + */ +void xdis(w,s,n) +register wbp w; +char *s; +int n; + { + int x, y, delta_x; + STDLOCALS(w); + + pollctr>>=1; pollctr++; + x = ws->x; + y = ws->y; + delta_x = XTextWidth(wc->font->fsp,s,n); + RENDER4(XDrawImageString,x,y,s,n); + ws->x += delta_x; + } + + + +/* + * put a character out to a window using the current attributes + */ +int wputc(ci,w) +int ci; +wbp w; + { + int fh, lh, width, height, over; + char c = (char)ci; + STDLOCALS(w); + + fh = wc->font->height; + lh = wc->leading; + width = ws->width; + height = ws->height; + + switch(c) { + case '\r': { + ws->x = wc->dx; + break; + } + case '\n': { + if (ISCEOLON(w)) { + /* + * Clear the rest of the line, like a terminal would. + * Its arguable whether this should clear to the window + * background or the current context background. If you + * change it to use the context background you have to + * change the XClearArea call to another XFillRectangle + * (cf. eraseArea()). + */ + if (wc->drawop != GXcopy) XSetFunction(stddpy, stdgc, GXcopy); + XSetForeground(stddpy, stdgc, wc->bg->c); + XClearArea(stddpy, stdwin, + ws->x, ws->y-wc->font->fsp->max_bounds.ascent, + width-ws->x, lh, False); + XFillRectangle(stddpy, stdpix, stdgc, + ws->x, ws->y - wc->font->fsp->max_bounds.ascent, + width - ws->x, lh); + XSetForeground(stddpy, stdgc,wc->fg->c^(ISXORREVERSE(w)?wc->bg->c:0)); + if (wc->drawop != GXcopy) XSetFunction(stddpy, stdgc, wc->drawop); + } + ws->y += lh; + ws->x = wc->dx; + /* + * Now for the exciting part: do we scroll the window? + * Copy the pixmap upward, then repaint the window. + */ + over = ws->y + wc->font->fsp->max_bounds.descent - height; + if (over > 0) { + ws->y -= over; + + if (wc->drawop != GXcopy) XSetFunction(stddpy, stdgc, GXcopy); + XCopyArea(stddpy, stdpix, stdpix, stdgc, + 0, over, /* x, y */ + width, height - over, /* w, h */ + 0, 0); /* dstx,dsty */ + XSetForeground(stddpy, stdgc, wc->bg->c); + XFillRectangle(stddpy, stdpix, stdgc, + 0, height - over, width, over); + XSetForeground(stddpy, stdgc,wc->fg->c^(ISXORREVERSE(w)?wc->bg->c:0)); + if (stdwin) + XCopyArea(stddpy, stdpix, stdwin, stdgc, 0, 0, width, height, 0,0); + if (wc->drawop != GXcopy) XSetFunction(stddpy, stdgc, wc->drawop); + } + break; + } + case '\t': { + xdis(w, " ", 8 - ((XTOCOL(w,ws->x))&7)); + break; + } + /* + * Handle backspaces. This implements cooked mode echo handling. + */ + case '\177': + case '\010': { + int i = 0, pre_x; + /* + * Start with the last character queued up. + */ + i--; + /* + * Trot back to the control-H itself. + */ + while ((i>-EQUEUELEN) && (EVQUESUB(w,i) != c)) i--; + if (i == -EQUEUELEN) break; + /* + * Go past the control-H. + */ + i--; + /* + * Go back through any number of control-H's from prior lifetimes. + */ + while((i > -EQUEUELEN) && !isprint(EVQUESUB(w,i))) i--; + if (i == -EQUEUELEN) break; + + /* + * OK, here's the character we're actually rubbing out. Back up. + */ + c = EVQUESUB(w,i); + pre_x = ws->x; + ws->x -= XTextWidth(wc->font->fsp, &c, 1); + /* + * Physically erase the character from the queue. This results in + * two control-H's present in the queue. + */ + *evquesub(w,i) = '\010'; + /* + * Save the backed-up position, and draw spaces through the erased. + */ + i = ws->x; + while(ws->x < pre_x) xdis(w," ",1); + ws->x = i; + break; + } + default: { + xdis(w,&c,1); + } + } + return 1; + } + + +/* + * handle_misc processes pending events on display. + * if w is non-null, block until a returnable event arrives. + * returns 1 on success, 0 on failure, and -1 on error. + */ +int handle_misc(wd, w) +wdp wd; +wbp w; + { + XEvent event; + Window evwin; + static int presscount = 0; + wbp wb; + wsp ws; + + while ((w != NULL) || XPending(wd->display)) { + + XNextEvent(wd->display, &event); + evwin = event.xexpose.window; /* go ahead, criticize all you like */ + +/* could avoid doing this search every event by handling 1 window at a time */ + for (wb = wbndngs; wb; wb=wb->next) { + ws = wb->window; + + if ((ws->display == wd) && + ((ws->win == evwin) || (ws->iconwin == evwin) || + (ws->pix == evwin) || (ws->initialPix == evwin))) break; + } + if (!wb) continue; + if (evwin == ws->iconwin) { + switch (event.type) { + case Expose: + if (ws->iconpix) + XCopyArea(wd->display, ws->iconpix, ws->iconwin, + wd->icongc, 0, 0, ws->iconw, ws->iconh, 3, 3); + else + XDrawString(wd->display, evwin, wd->icongc, 4, + ws->display->fonts->fsp->max_bounds.ascent + 2, + ws->iconlabel, strlen(ws->iconlabel)); + if (ws->iconic == IconicState) + SETEXPOSED(wb); + break; + case KeyPress: + handle_keypress(wb, (XKeyEvent *)&event); + break; + case ButtonPress: + if (ws->iconic == IconicState) + XMapWindow(ws->display->display, ws->win); + ws->iconic = NormalState; /* set the current state */ + break; + case ConfigureNotify: + ws->iconx = ((XConfigureEvent *)&event)->x; + ws->icony = ((XConfigureEvent *)&event)->y; + break; + } + } + else { + switch (event.type) { + case KeyPress: + handle_keypress(wb, (XKeyEvent *)&event); + break; + case ButtonPress: + presscount++; + handle_mouse(wb, (XButtonEvent *)&event); + break; + case ButtonRelease: + if (--presscount < 0) presscount = 0; + handle_mouse(wb, (XButtonEvent *)&event); + break; + case MotionNotify: + if (presscount) + handle_mouse(wb, (XButtonEvent *)&event); + break; + case NoExpose: + break; + case Expose: + if (!handle_exposures(wb, (XExposeEvent *)&event)) + return 1; + continue; + case UnmapNotify: + wb->window->iconic = IconicState; + continue; + case MapNotify: + if ((ws->width != DisplayWidth(wd->display, wd->screen)) || + (ws->height != DisplayHeight(wd->display, wd->screen))) + ws->iconic = NormalState; + else + ws->iconic = MaximizedState; + continue; + case ConfigureNotify: + if (!handle_config(wb, (XConfigureEvent *)&event)) { + return 0; + } + break; + case DestroyNotify: + if (!ISZOMBIE(wb)) return -1; /* error #141 */ + + /* + * first of all, we are done with this window + */ + ws->win = (Window) NULL; + + /* + * if there are no more references, we are done with the pixmap + * too. Free it and the colors allocated for this canvas. + */ + if (ws->refcount == 0) { + if (wb->window->pix) { + Display *d = ws->display->display; + XSync(d, False); + if (ws->pix) + XFreePixmap(d, ws->pix); + ws->pix = (Pixmap) NULL; + } + if (ws->initialPix != (Pixmap) NULL) { + Display *d = ws->display->display; + XSync(d, False); + XFreePixmap(d, ws->initialPix); + ws->initialPix = (Pixmap) NULL; + } + free_xcolors(wb, 2); /* free regular colors */ + free_xcolors(wb, 1); /* free icon colors */ + } + break; + default: + continue; + } + if ((w != NULL) && + ((evwin == w->window->win) || (evwin == w->window->iconwin))) { + return 1; + } + } + } + return 1; + } + +/* + * poll for available events on all opened displays. + * this is where the interpreter calls into the X interface. + */ +int pollevent() + { + wdp wd; + int hm; + for (wd = wdsplys; wd; wd = wd->next) { + if ((hm = handle_misc(wd, NULL)) < 1) { + if (hm == -1) return -1; + else if (hm == 0) { + /* how to handle failure? */ + } + } + } + return 400; + } + +/* + * get a single item from w's pending queue + */ +int wgetq(w,res) +wbp w; +dptr res; + { + int posted = 0; + + while (1) { + STDLOCALS(w); /* leave inside loop; ws->pix can change! */ + if (!EVQUEEMPTY(w)) { + EVQUEGET(w,*res); + if (posted) + scrubcursor(w); + return 1; + } + postcursor(w); /* post every time in case resize erased it */ + posted = 1; + if (handle_misc(wd, w) == -1) { + if (posted) + scrubcursor(w); + return -1; + } + } + } + +/* + * postcursor/scrubcursor calls must be paired without any intervening output. + */ +static void postcursor(w) +wbp w; + { + STDLOCALS(w); + + if (!ISCURSORON(w) || !stdwin) return; + if (wc->drawop != GXcopy) XSetFunction(stddpy, stdgc, GXcopy); + if (ISXORREVERSE(w)) XSetForeground(stddpy, stdgc, wc->fg->c); + + /* Draw only on window, not on backing pixmap */ + XFillRectangle(stddpy, stdwin, stdgc, ws->x, ws->y, FWIDTH(w), DESCENT(w)); + XSync(stddpy, False); + } + +static void scrubcursor(w) +wbp w; + { + STDLOCALS(w); + + if (!ISCURSORON(w) || !stdwin) return; + + XCopyArea(stddpy, stdpix, stdwin, stdgc, /* restore window from pixmap */ + ws->x, ws->y, FWIDTH(w), DESCENT(w), ws->x, ws->y); + + if (wc->drawop != GXcopy) XSetFunction(stddpy, stdgc, wc->drawop); + if (ISXORREVERSE(w)) XSetForeground(stddpy, stdgc, wc->fg->c ^ wc->bg->c); + } + +/* + * wclose - close a window. If is a real on-screen window, + * wait for a DestroyNotify event from the server before returning. + */ +int wclose(w) +wbp w; + { + STDLOCALS(w); + + XSync(stddpy, False); + if (pollevent() == -1) return -1; + + /* + * Force window to close (turn into a pixmap) + */ + if (ws->win && ws->refcount > 1) { + SETZOMBIE(w); + XDestroyWindow(stddpy,stdwin); + XFlush(stddpy); + ws->refcount--; + while (ws->win) + if (pollevent() == -1) return -1; + } + /* + * Entire canvas terminates + */ + else { + free_xcolors(w, 2); + free_xcolors(w, 1); + free_window(ws); + } + + return 0; + } +/* + * flush a window + */ +void wflush(w) +wbp w; + { + STDLOCALS(w); + XFlush(stddpy); + } +/* + * flush all windows + */ +void wflushall() + { + wdp wd; + for (wd = wdsplys; wd != NULL; wd = wd->next) { + XFlush(wd->display); + } + } +/* + * sync all the servers + */ +void wsync(w) +wbp w; + { + wdp wd; + if (w == NULL) { + for (wd = wdsplys; wd != NULL; wd = wd->next) { + XSync(wd->display, False); + } + } + else + XSync(w->window->display->display, False); + } + +/* + * open a window + * This routine really just allocates a window data structure. + * The interesting part is done in wmap, after the user preferences + * passed to Icon have been parsed. Returns NULL on error/failure; + * err_index is set to one of: + * >= 0: the index of an offending attribute value + * -1 : ordinary failure + * -2 : out of memory + */ +FILE *wopen(name, lp, attr, n, err_index) +char *name; +struct b_list *lp; +dptr attr; +int n, *err_index; + { + wbp w; + wsp ws; + char dispchrs[256]; + char answer[128]; + char *display = NULL; + int i; + tended struct b_list *tlp; + tended struct descrip attrrslt; + + tlp = lp; + + for(i=0;i<n;i++) { + if (is:string(attr[i]) && + (StrLen(attr[i])>8) && + !strncmp("display=",StrLoc(attr[i]),8)) { + strncpy(dispchrs,StrLoc(attr[i])+8,StrLen(attr[i])-8); + dispchrs[StrLen(attr[i]) - 8] = '\0'; + display = dispchrs; + } + } + + if ((w = alc_wbinding()) == NULL) { + *err_index = -2; + return NULL; + } + if ((w->window = alc_winstate()) == NULL) { + *err_index = -2; + free_binding(w); + return NULL; + } + if ((w->window->display = alc_display(display)) == NULL) { + *err_index = -1; /* might be out of memory, probably bad DISPLAY var. */ + free_binding(w); + return NULL; + } + ws = w->window; + ws->listp.dword = D_List; + BlkLoc(ws->listp) = (union block *)tlp; + + /* + * some attributes of the display and window are used in the context + */ + if ((w->context = alc_context(w)) == NULL) { + *err_index = -2; + free_binding(w); + return NULL; + } + + /* + * some attributes of the context determine window defaults + */ + ws->height = w->context->font->height * 12; + ws->width = w->context->font->fsp->max_bounds.width * 80; + ws->y = w->context->font->fsp->max_bounds.ascent; + ws->x = 0; + ws->y += w->context->dy; + ws->x += w->context->dx; + + /* + * Loop through any remaining arguments. + */ + for (i = 0; i < n; i++){ + /* + * write the attribute, + * except "display=" attribute, which is done earlier + */ + if((StrLen(attr[i])<9)||strncmp(StrLoc(attr[i]),"display=",8)) { + switch (wattrib((wbp) w, StrLoc(attr[i]), StrLen(attr[i]), &attrrslt, + answer)) { + case Error: + *err_index = i; + return NULL; + case Failed: + free_binding((wbp)w); + *err_index = -1; + return NULL; + } + } + } + if (ws->windowlabel == NULL) { + ws->windowlabel = salloc(name); + if (ws->windowlabel == NULL) { /* out of memory */ + *err_index = -2; + return NULL; + } + } + + if ((i = wmap(w)) != Succeeded) { + if (i == Failed) *err_index = -1; + else *err_index = 0; + return NULL; + } + return (FILE *)w; + } + +/* + * make an icon for a window + */ +void makeIcon(w, x, y) +wbp w; +int x, y; /* current mouse position */ +{ + int status; + STDLOCALS(w); + + /* if a pixmap image has been specified, load it */ + if (ws->initicon.width) { + ws->iconpix = XCreatePixmap(stddpy, DefaultRootWindow(stddpy), + ws->iconw, ws->iconh, + DefaultDepth(stddpy,wd->screen)); + } + else if (ws->iconimage && strcmp(ws->iconimage, "")) { + ws->iconpix = loadimage(w, ws->iconimage, &(ws->iconh), &(ws->iconw), + 0, &status); + ws->iconh += 6; + ws->iconw += 6; + } + else { /* determine the size of the icon window */ + ws->iconh = wd->fonts->fsp->max_bounds.ascent + + wd->fonts->fsp->max_bounds.descent + 5; + if (ws->iconlabel == NULL) ws->iconlabel = ""; + ws->iconw = XTextWidth(wd->fonts->fsp, ws->iconlabel, + strlen(ws->iconlabel)) + 6; + } + + /* if icon position hint exists, get it */ + if (ws->wmhintflags & IconPositionHint) { + x = ws->iconx; + y = ws->icony; + } + + /* create the icon window */ + ws->iconwin = XCreateSimpleWindow(stddpy, DefaultRootWindow(stddpy), x, y, + ws->iconw, ws->iconh, 2, wc->fg->c, + wc->bg->c); + + /* select events for the icon window */ + XSelectInput(stddpy, ws->iconwin, + ExposureMask | KeyPressMask | ButtonPressMask | + StructureNotifyMask); + +} + +/* + * Create a canvas. + * If a window, cause the window to actually become visible on the screen. + * returns Succeeded, Failed, or Error + */ +int wmap(w) +wbp w; + { + XWindowAttributes attrs; + XGCValues gcv; + unsigned long gcmask = + GCFont | GCForeground | GCBackground | GCFillStyle | GCCapStyle; + struct imgdata *imd; + int i, r; + int new_pixmap = 0; + char *p, *s; + XWMHints wmhints; + XClassHint clhints; + STDLOCALS(w); + + /* + * Create a pixmap for this canvas if there isn't one already. + */ + if (ws->pix == (Pixmap) NULL) { + if (ws->initialPix) { + ws->pix = ws->initialPix; + ws->initialPix = (Pixmap) NULL; + ws->pixwidth = ws->width; + ws->pixheight = ws->height; + } + else { + ws->pix = XCreatePixmap(stddpy, DefaultRootWindow(stddpy), + ws->width, ws->height, + DefaultDepth(stddpy,wd->screen)); + ws->pixwidth = ws->width; + ws->pixheight = ws->height; + new_pixmap = 1; + } + stdpix = ws->pix; + } + + /* + * create the X window (or use the DefaultRootWindow if requested) + */ + if (ws->iconic != HiddenState) { + ws->win = ((ws->iconic == RootState) ? DefaultRootWindow(stddpy) : + XCreateSimpleWindow(stddpy, DefaultRootWindow(stddpy), + ws->posx < 0 ? 0 : ws->posx, + ws->posy < 0 ? 0 : ws->posy, ws->width, + ws->height, 1, wc->fg->c, wc->bg->c)); + if (ws->win == (Window) NULL) + return Failed; + stdwin = ws->win; + XClearWindow(stddpy, stdwin); + } + + /* + * before creating the graphics context, construct a description + * of any non-default initial graphics context values. + */ + gcv.foreground = wc->fg->c ^ (ISXORREVERSE(w) ? wc->bg->c : 0); + gcv.background = wc->bg->c; + gcv.font = wc->font->fsp->fid; + if (wc->fillstyle) + gcv.fill_style = wc->fillstyle; + else + gcv.fill_style = wc->fillstyle = FillSolid; + if (wc->linestyle || wc->linewidth) { + gcmask |= (GCLineWidth | GCLineStyle); + gcv.line_width = wc->linewidth; + gcv.line_style = wc->linestyle; + if (wc->linewidth > 1) { + gcv.dashes = 3 * wc->linewidth; + gcmask |= GCDashList; + } + } + else + wc->linestyle = LineSolid; + gcv.cap_style = CapProjecting; + + /* + * Create a graphics context (or change an existing one to conform + * with initial values). + */ + if (stdgc == NULL) { + wc->gc = XCreateGC(stddpy, stdpix, gcmask, &gcv); + stdgc = wc->gc; + if (stdgc == NULL) return Failed; + } + else + XChangeGC(stddpy, stdgc, gcmask, &gcv); + + if (wc->clipw >= 0) + setclip(w); + + if (new_pixmap) { + XSetForeground(stddpy, stdgc, wc->bg->c); + XFillRectangle(stddpy, ws->pix, stdgc, 0, 0, ws->width, ws->height); + XSetForeground(stddpy, stdgc, wc->fg->c ^(ISXORREVERSE(w)?wc->bg->c:0)); + } + + imd = &ws->initimage; + if (imd->width) { + r = strimage(w, 0, 0, imd->width, imd->height, imd->paltbl, + imd->data, (word)imd->width * (word)imd->height, 0); + free((pointer)imd->paltbl); + free((pointer)imd->data); + imd->width = 0; + if (r < 0) + return Failed; + } + + imd = &ws->initicon; + if (imd->width) { + r = strimage(w, 0, 0, imd->width, imd->height, imd->paltbl, + imd->data, (word)imd->width * (word)imd->height, 1); + free((pointer)imd->paltbl); + free((pointer)imd->data); + imd->width = 0; + if (r < 0) + return Failed; + wmhints.icon_window = ws->iconwin; + ws->wmhintflags |= IconWindowHint; + } + + if (wc->patternname != NULL) { + if (SetPattern(w, wc->patternname, strlen(wc->patternname)) != Succeeded) + return Failed; + } + + /* + * if we are opening a pixmap, we are done at this point. + */ + if (stdwin == (Window) NULL) return Succeeded; + + if (ws->iconic != RootState) { + size_hints.flags = PSize | PMinSize | PMaxSize; + size_hints.width = ws->width; + size_hints.height= ws->height; + if (ws->posx == -(MaxInt)) ws->posx = 0; + else size_hints.flags |= USPosition; + if (ws->posy == -(MaxInt)) ws->posy = 0; + else size_hints.flags |= USPosition; + size_hints.x = ws->posx; + size_hints.y = ws->posy; + if (ISRESIZABLE(w)) { + size_hints.min_width = 0; + size_hints.min_height = 0; + size_hints.max_width = DisplayWidth(stddpy, wd->screen); + size_hints.max_height = DisplayHeight(stddpy, wd->screen); + } + else { + size_hints.min_width = size_hints.max_width = ws->width; + size_hints.min_height = size_hints.max_height = ws->height; + } + if (ws->iconlabel == NULL) { + if ((ws->iconlabel = salloc(ws->windowlabel)) == NULL) + ReturnErrNum(305, Error); + } + XSetStandardProperties(stddpy, stdwin, ws->windowlabel, ws->iconlabel, + 0,0,0, &size_hints); + XSelectInput(stddpy, stdwin, ExposureMask | KeyPressMask | + ButtonPressMask | ButtonReleaseMask | ButtonMotionMask | + StructureNotifyMask); + } + + wmhints.input = True; + wmhints.flags = InputHint; + if (ws->iconic != RootState) { + if (ws->iconimage != NULL) { + makeIcon(w, ws->posx < 0 ? 0 : ws->posx, ws->posy < 0 ? 0 : ws->posy); + wmhints.icon_window = ws->iconwin; + ws->wmhintflags |= IconWindowHint; + } + wmhints.flags |= (ws->wmhintflags | StateHint); + wmhints.initial_state = ws->iconic; + wmhints.icon_x = ws->iconx; + wmhints.icon_y = ws->icony; + } + XSetWMHints(stddpy, stdwin, &wmhints); + + /* + * Set the class hints that name the program (for reference by the + * window manager) following conventions given in O'Reilly. + */ + if (! (s = getenv("RESOURCE_NAME"))) { + p = StrLoc(kywd_prog); + s = p + StrLen(kywd_prog); + while (s > p && s[-1] != '/') + s--; /* find tail of prog_name */ + } + clhints.res_name = s; + clhints.res_class = "IconProg"; + XSetClassHint(stddpy, stdwin, &clhints); + + if (wd->cmap != DefaultColormap(stddpy,wd->screen)) + XSetWindowColormap(stddpy, stdwin, wd->cmap); + + if (ws->iconic != RootState) { + CLREXPOSED(w); + XMapWindow(stddpy, stdwin); + } + + XGetWindowAttributes(stddpy, stdwin, &attrs); + ws->width = attrs.width; + ws->height = attrs.height; + if (!resizePixmap(w, ws->width, ws->height)) return Failed; + + if (stdwin) { + i = ws->theCursor; + if (!(wd->cursors[i])) + wd->cursors[i] = XCreateFontCursor(stddpy, 2 * i); + XDefineCursor(stddpy, stdwin, wd->cursors[i]); + } + + /* + * busy loop for an expose event, unless of course we are starting out + * in an iconic state + */ + CLRZOMBIE(w); + if (ws->win != (Window) NULL) { + int hm; + while (!ISEXPOSED(w) && (ws->iconic != IconicState || ws->iconwin)) { + if ((hm = handle_misc(wd, w)) < 1) { + if (hm == -1) return Error; + else if (hm == 0) { + /* how to handle failure? */ + } + } + } + } + + XSetFunction(stddpy, stdgc, wc->drawop); + XSync(stddpy, False); + return Succeeded; +} + + +int do_config(w, status) +wbp w; +int status; + { + wsp ws = w->window; + wdp wd = ws->display; + int wid = ws->width, ht = ws->height; + int posx = ws->posx, posy = ws->posy; + XTextProperty textprop; + + if (! resizePixmap(w, ws->width, ws->height)) + return Failed; + if (ws->win) { + XSync(wd->display, False); + pollevent(); + if (status == 1) + moveWindow(w, posx, posy); + else { + if (status == 2) + posx = posy = -MaxInt; + if (moveResizeWindow(w, posx, posy, wid, ht) == Failed) + return Failed; + } + + /* XSync is not enough because the window manager gets involved here. */ + XFlush(wd->display); /* force out request */ + XGetWMName(wd->display, ws->win, &textprop); /* force WM round trip */ + XSync(wd->display, False); /* NOW sync */ + } + return Succeeded; + } + +int setheight(w, new_height) +wbp w; +SHORT new_height; + { + STDLOCALS(w); + if (new_height < 0) return Failed; + ws->height = size_hints.height = new_height; + return Succeeded; + } + +int setwidth(w, new_width) +wbp w; +SHORT new_width; +{ + STDLOCALS(w); + if (new_width < 0) return Failed; + ws->width = size_hints.width = new_width; + return Succeeded; +} + +int setgeometry(w, geo) +wbp w; +char *geo; + { + int width = 0, height = 0; + int x = 0, y = 0, status; + STDLOCALS(w); + + if ((status = parsegeometry(geo, &x, &y, &width, &height)) == 0) + return Error; + if (status & 1) { + ws->width = size_hints.width = width; + ws->height = size_hints.height = height; + } + /* + * can't set position on hidden windows + */ + if ((stdwin || !stdpix) && (status & 2)) { + ws->posx = x; + ws->posy = y; + } + /* insert assigns here: + * ws->posx = ((sign > 0) ? tmp : + * DisplayWidth(stddpy,wd->screen) - ws->width - tmp); + * ws->posy = ((sign > 0) ? tmp : + * DisplayHeight(stddpy,wd->screen) - ws->height - tmp); + */ + return Succeeded; + } + +int allowresize(w, on) +wbp w; +int on; + { + if (on) + SETRESIZABLE(w); + else + CLRRESIZABLE(w); + return Succeeded; + } + +void warpPointer(w, x, y) +wbp w; +int x, y; + { + wsp ws = w->window; + XWarpPointer(ws->display->display, None, ws->win, 0,0,0,0, x, y); + } + +/* + * #@#@ This is a bug + */ +int seticonlabel(w, val) +wbp w; +char *val; + { + STDLOCALS(w); + if (ws->iconlabel != NULL) free(ws->iconlabel); + if ((ws->iconlabel = salloc(val)) == NULL) + ReturnErrNum(305, Error); + + if (stddpy && stdwin) { + XSetIconName(stddpy, stdwin, w->window->iconlabel); + if (ws->iconic == IconicState && !ws->iconpix && ws->iconwin) { + XClearWindow(stddpy, ws->iconwin); + XDrawString(stddpy, ws->iconwin, wd->icongc, 4, + wd->fonts->fsp->max_bounds.ascent + 2, + ws->iconlabel, strlen(ws->iconlabel)); + } + } + return Succeeded; + } + +/* + * setwindowlabel + */ +int setwindowlabel(w, s) +wbp w; +char *s; +{ + wsp ws = w->window; + if (ws->windowlabel != NULL) free(ws->windowlabel); + if ((ws->windowlabel = salloc(s)) == NULL) + ReturnErrNum(305, Error); + if (ws->display && ws->display->display && ws->win) + XStoreName(ws->display->display, ws->win, + *ws->windowlabel ? ws->windowlabel : " "); /* empty string fails */ + return Succeeded; +} + +/* + * setcursor() - a no-op under X at present + */ +int setcursor(w, on) +wbp w; +int on; +{ + if (on) + SETCURSORON(w); + else + CLRCURSORON(w); + return Succeeded; +} + + +/* + * setpointer() - define a mouse pointer shape + */ +int setpointer(w, val) +wbp w; +char *val; + { + int i = si_s2i(cursorsyms,val) >> 1; + STDLOCALS(w); + if (i < 0 || i >= NUMCURSORSYMS) return Failed; + + ws->theCursor = i; + if (!(wd->cursors[i])) + wd->cursors[i] = XCreateFontCursor(stddpy, 2 * i); + if (stdwin) + XDefineCursor(stddpy, stdwin, wd->cursors[i]); + return Succeeded; + } + +/* + * setdrawop() - set the drawing operation + */ +int setdrawop(w, val) +wbp w; +char *val; + { + STDLOCALS(w); + XSync(stddpy, False); + if (!strcmp(val,"reverse")) { + if (!ISXORREVERSE(w)) { + SETXORREVERSE(w); + wc->drawop = GXxor; + if (stdgc) + XSetForeground(stddpy, stdgc, wc->fg->c ^ wc->bg->c); + } + } + else { + if (ISXORREVERSE(w)) { + CLRXORREVERSE(w); + if (stdgc) + XSetForeground(stddpy, stdgc, wc->fg->c); + } + wc->drawop = si_s2i(drawops,val); + if (wc->drawop == -1) { wc->drawop = GXcopy; return Error; } + } + if (stdgc) XSetFunction(stddpy, stdgc, wc->drawop); + return Succeeded; + } + +/* + * rebind() - bind w's context to that of w2. + */ +int rebind(w, w2) +wbp w, w2; + { + if (w->window->display != w2->context->display) return Failed; + w->context = w2->context; + return Succeeded; + } + + +void setclip(w) +wbp w; + { + wcp wc = w->context; + XRectangle rec; + if (wc->gc) { + rec.x = wc->clipx; + rec.y = wc->clipy; + rec.width = wc->clipw; + rec.height = wc->cliph; + XSetClipRectangles(wc->display->display, wc->gc, 0, 0, &rec, 1,Unsorted); + } + } + +void unsetclip(w) +wbp w; + { + wcp wc = w->context; + if (wc->gc) { + XSetClipMask(wc->display->display, wc->gc, None); + } + } + +void getcanvas(w, s) +wbp w; +char *s; + { + if (w->window->win == (Window) NULL) sprintf(s, "hidden"); + else + switch (w->window->iconic) { + case RootState: + sprintf(s, "root"); + break; + case NormalState: + sprintf(s, "normal"); + break; + case IconicState: + sprintf(s, "iconic"); + break; + case MaximizedState: + sprintf(s, "maximal"); + break; + case HiddenState: + sprintf(s, "hidden"); + break; + default: + sprintf(s, "???"); + } + } + +/* + * Set the canvas type, either during open (pixmap is null, set a flag) + * or change an existing canvas to a different type. + */ +int setcanvas(w,s) +wbp w; +char *s; + { + int hm; + XTextProperty textprop; + STDLOCALS(w); + + if (!strcmp(s, "iconic")) { + if (ws->pix == (Pixmap) NULL) { + ws->wmhintflags |= StateHint; + ws->iconic = IconicState; + } + else { + if (ws->iconic != IconicState) { +#ifdef Iconify + if (ws->win == (Window) NULL) { + wmap(w); + } + XIconifyWindow(ws->display->display, ws->win, ws->display->screen); + XSync(stddpy, False); + while (ws->iconic != IconicState) + if ((hm = handle_misc(wd, NULL)) < 1) { + if (hm == -1) return Error; + else if (hm == 0) { + return Failed; + } + } +#else /* Iconify */ + return Failed; +#endif /* Iconify */ + } + } + } + + else if (!strcmp(s, "normal")) { + if (ws->pix == (Pixmap) NULL) { + ws->iconic = NormalState; + } + else { + if (ws->win == (Window) NULL) { + ws->iconic = NormalState; + ws->initialPix = ws->pix; + ws->pix = (Window) NULL; + wmap(w); + } + else if (ws->iconic == IconicState) { + XMapWindow(stddpy, stdwin); + XSync(stddpy, False); + while (ws->iconic == IconicState) + pollevent(); + } + else if (ws->iconic == MaximizedState) { + moveResizeWindow(w, ws->normalx, ws->normaly, + ws->normalw, ws->normalh); + ws->iconic = NormalState; + } + } + } + else if (!strcmp(s, "maximal")) { + if (ws->iconic != MaximizedState) { + int expect_config= (ws->width != DisplayWidth(stddpy, wd->screen)) || + (ws->height != DisplayHeight(stddpy, wd->screen)); + ws->normalx = ws->posx; + ws->normaly = ws->posy; + ws->normalw = ws->width; + ws->normalh = ws->height; + ws->width = DisplayWidth(stddpy, wd->screen); + ws->height= DisplayHeight(stddpy, wd->screen); + if (ws->pix != (Pixmap) NULL) { + if (ws->win == (Window) NULL) { + ws->iconic = MaximizedState; + ws->initialPix = ws->pix; + ws->pix = (Window) NULL; + wmap(w); + } + else if (ws->iconic == IconicState) { + XMapWindow(stddpy, stdwin); + XSync(stddpy, False); + while (ws->iconic == IconicState) + pollevent(); + } + else if (expect_config) { + moveResizeWindow(w, 0, 0, ws->width, ws->height); + /* XSync is not enough because window manager gets involved. */ + XFlush(wd->display); /* flush req */ + XGetWMName(wd->display, ws->win, &textprop); /* force WM RT */ + XSync(wd->display, False); /* NOW sync */ + if (pollevent() == -1) return Error; + moveWindow(w, -ws->posx, -ws->posy); + XFlush(wd->display); /* flush req */ + XGetWMName(wd->display, ws->win, &textprop); /* force WM RT */ + XSync(wd->display, False); /* NOW sync */ + } + } + ws->iconic = MaximizedState; + } + } + else if (!strcmp(s, "hidden")) { + if (ws->pix == (Pixmap)NULL) { + ws->iconic = HiddenState; + } + else { + if (ws->win != (Window) NULL) { + if (ws->iconic == MaximizedState) { + ws->posx = ws->normalx; + ws->posy = ws->normaly; + ws->width = ws->normalw; + ws->height = ws->normalh; + ws->iconic = NormalState; + } + if (ws->iconic != IconicState) { + SETZOMBIE(w); + XDestroyWindow(stddpy, stdwin); + XFlush(stddpy); + while (ws->win) + if (pollevent() == -1) + return Error; + } + } + } + } + else return Error; + XSync(ws->display->display, False); + return Succeeded; + } + +int seticonicstate(w,s) +wbp w; +char *s; + { + STDLOCALS(w); + + if (!strcmp(s, "icon")) { + if (ws->pix == (Pixmap) NULL) { + ws->wmhintflags |= StateHint; + ws->iconic = IconicState; + } + else { + if (ws->iconic != IconicState) { +#ifdef Iconify + XIconifyWindow(ws->display->display, ws->win, ws->display->screen); +#else /* Iconify */ + return Failed; +#endif /* Iconify */ + } + } + } + else if (!strcmp(s, "window")) { + if (ws->win != (Window) NULL) { + if (ws->iconic == IconicState) { + XMapWindow(stddpy, stdwin); + } + } + } + else if (!strcmp(s, "root")) { + if (ws->win == (Window) NULL) + ws->iconic = RootState; + else return Failed; + } + else return Error; + XSync(ws->display->display, False); + return Succeeded; + } + +int seticonpos(w,s) +wbp w; +char *s; + { + char *s2; + wsp ws = w->window; + + ws->wmhintflags |= IconPositionHint; + s2 = s; + ws->iconx = atol(s2); + while (isspace(*s2)) s2++; + while (isdigit(*s2)) s2++; + if (*s2++ != ',') return Error; + ws->icony = atol(s2); + + if (ws->win) { + if (ws->iconwin == (Window) NULL) + makeIcon(w, ws->iconx, ws->icony); + if (remap(w, ws->iconx, ws->icony) == -1) return Error; + } + return Succeeded; + } + +int geticonpos(w, s) +wbp w; +char *s; + { + wsp ws = w->window; + sprintf(s,"%d,%d", ws->iconx, ws->icony); + return Succeeded; + } + + +/* + * if the window exists and is visible, set its position to (x,y) + */ +void moveWindow(w,x,y) +wbp w; +int x, y; +{ + STDLOCALS(w); + ws->posx = x; + ws->posy = y; + if (stdwin) { + XMoveWindow(stddpy, stdwin, ws->posx, ws->posy); + XSync(stddpy, False); + } +} + +int moveResizeWindow(w, x, y, width, height) +wbp w; +int x, y, width, height; + { + wsp ws = w->window; + wdp wd = ws->display; + ws->width = width; + ws->height = height; + + size_hints.flags = PMinSize | PMaxSize; + if (ISRESIZABLE(w)) { + size_hints.min_width = 0; + size_hints.min_height = 0; + size_hints.max_width = DisplayWidth(wd->display, wd->screen); + size_hints.max_height = DisplayHeight(wd->display, wd->screen); + } + else { + size_hints.min_width = size_hints.max_width = width; + size_hints.min_height = size_hints.max_height = height; + } + XSetNormalHints(wd->display, ws->win, &size_hints); + + if (resizePixmap(w, width, height) == 0) return Failed; + + if (ws->win != (Window) NULL) { + if (x == -MaxInt && y == -MaxInt) + XResizeWindow(wd->display, ws->win, width, height); + else + XMoveResizeWindow(wd->display, ws->win, x, y, width, height); + XSync(wd->display, False); + } + return Succeeded; + } + +/* + * Set the context's fill style by name. + */ +int setfillstyle(w, s) +wbp w; +char *s; + { + STDLOCALS(w); + + if (!strcmp(s, "solid")) { + wc->fillstyle = FillSolid; + } + else if (!strcmp(s, "masked") + || !strcmp(s, "stippled") || !strcmp(s, "patterned")) { + wc->fillstyle = FillStippled; + } + else if (!strcmp(s, "textured") + || !strcmp(s, "opaquestippled") || !strcmp(s, "opaquepatterned")) { + wc->fillstyle = FillOpaqueStippled; + } + else return Error; + if (stdpix) { + XSetFillStyle(stddpy, stdgc, wc->fillstyle); + } + return Succeeded; + } + +/* + * Set the context's line style by name. + */ +int setlinestyle(w, s) +wbp w; +char *s; + { + STDLOCALS(w); + + if (!strcmp(s, "solid")) { + wc->linestyle = LineSolid; + } + else if (!strcmp(s, "onoff") || !strcmp(s, "dashed")) { + wc->linestyle = LineOnOffDash; + } + else if (!strcmp(s, "doubledash") || !strcmp(s, "striped")) { + wc->linestyle = LineDoubleDash; + } + else return Error; + if (stdpix) { + XSetLineAttributes(stddpy, stdgc, + wc->linewidth, wc->linestyle, CapProjecting, JoinMiter); + } + return Succeeded; + } + +/* + * Set the context's line width + */ +int setlinewidth(w, linewid) +wbp w; +LONG linewid; + { + unsigned long gcmask; + XGCValues gcv; + STDLOCALS(w); + + if (linewid < 0) return Error; + wc->linewidth = linewid; + if (stdpix) { + gcv.line_width = linewid; + gcv.line_style = wc->linestyle; + if (linewid > 1) + gcv.dashes = 3 * wc->linewidth; + else + gcv.dashes = 4; + gcmask = GCLineWidth | GCLineStyle | GCDashList; + XChangeGC(stddpy, stdgc, gcmask, &gcv); + } + + return Succeeded; + } + +/* + * Reset the context's foreground color to whatever it is supposed to be. + */ +int resetfg(w) +wbp w; + { + wcp wc = w->context; + if (wc->gc != NULL) + XSetForeground(wc->display->display, wc->gc, + wc->fg->c ^ (ISXORREVERSE(w) ? wc->bg->c : 0)); + return Succeeded; + } + +/* + * Set the context's foreground color by name. + */ +int setfg(w,s) +wbp w; +char *s; + { + wclrp cp; + STDLOCALS(w); + + Protect(cp = alc_color(w,s), return Failed); + wc->fg = cp; + return resetfg(w); + } + +int setfgrgb(w, r, g, b) +wbp w; +int r, g, b; +{ + char sbuf1[MaxCvtLen]; + sprintf(sbuf1, "%d,%d,%d", r, g, b); + return setfg(w, sbuf1); +} + +/* + * Set the context's foreground color by color cell. + */ +int isetfg(w,fg) +wbp w; +int fg; + { + int i, r, g, b; + STDLOCALS(w); + + if (fg >= 0) { + b = fg & 255; + fg >>= 8; + g = fg & 255; + fg >>= 8; + r = fg & 255; + return setfgrgb(w, r * 257, g * 257, b * 257); + } + for (i = 2; i < wd->numColors; i++) + if (wd->colrptrs[i]->type == MUTABLE && wd->colrptrs[i]->c == -fg - 1) + break; + if (i == wd->numColors) return Failed; + wc->fg = wd->colrptrs[i]; + return resetfg(w); + } + +/* + * Set the window context's background color by name. + */ +int setbg(w,s) +wbp w; +char *s; + { + wclrp cp; + STDLOCALS(w); + + Protect(cp = alc_color(w,s), return Failed); + wc->bg = cp; + + if (stdgc != NULL) + XSetBackground(stddpy, stdgc, wc->bg->c); + return ISXORREVERSE(w) ? resetfg(w) : Succeeded; + } + +int setbgrgb(w, r, g, b) +wbp w; +int r, g, b; +{ + char sbuf1[MaxCvtLen]; + sprintf(sbuf1, "%d,%d,%d", r, g, b); + return setbg(w, sbuf1); +} + +/* + * Set the context's background color by color cell. + */ +int isetbg(w,bg) +wbp w; +int bg; + { + int i, r, g, b; + STDLOCALS(w); + + if (bg >= 0) { + b = bg & 255; + bg >>= 8; + g = bg & 255; + bg >>= 8; + r = bg & 255; + return setbgrgb(w, r * 257, g * 257, b * 257); + } + for (i = 2; i < wd->numColors; i++) + if (wd->colrptrs[i]->type == MUTABLE && wd->colrptrs[i]->c == -bg - 1) + break; + if (i == wd->numColors) return Failed; + wc->bg = wd->colrptrs[i]; + if (stdgc != NULL) + XSetBackground(stddpy, stdgc, wc->bg->c); + return ISXORREVERSE(w) ? resetfg(w) : Succeeded; + } + +/* + * Set the gamma correction value. + */ +int setgamma(w, gamma) +wbp w; +double gamma; + { + w->context->gamma = gamma; + setfg(w, w->context->fg->name); /* reinterpret current Fg/Bg spec */ + setbg(w, w->context->bg->name); + return Succeeded; + } + +/* + * Set the display by name. Really should cache answers as per fonts below; + * for now just open a new display each time. Note that this can only be + * called before a window is instantiated... + */ +int setdisplay(w,s) +wbp w; +char *s; + { + wdp d; + /* can't change display for mapped window! */ + if (w->window->pix != (Pixmap) NULL) + return Failed; + + Protect(d = alc_display(s), return 0); + w->window->display = d; + w->context->fg = d->colrptrs[0]; + w->context->bg = d->colrptrs[1]; + w->context->font = d->fonts; + return Succeeded; + } + +int setleading(w, i) +wbp w; +int i; +{ + w->context->leading = i; + return Succeeded; +} + +int setimage(w, val) +wbp w; +char *val; + { + wsp ws = w->window; + int status; + ws->initialPix = loadimage(w, val, &(ws->height), &(ws->width), + 0, &status); + if (ws->initialPix == (Pixmap) NULL) return Failed; + return Succeeded; + } + +void toggle_fgbg(w) +wbp w; +{ + wclrp tmp; + STDLOCALS(w); + tmp = wc->fg; + wc->fg = wc->bg; + wc->bg = tmp; + if (stdpix) { + XSetForeground(stddpy, stdgc, + wc->fg->c ^ (ISXORREVERSE(w)?wc->bg->c:0)); + XSetBackground(stddpy, stdgc, wc->bg->c); + } +} + +void getdisplay(w, answer) +wbp w; +char *answer; + { + char *tmp; + wdp wd = w->window->display; + if (!strcmp(wd->name, "")) { + if ((tmp = getenv("DISPLAY")) != NULL) + sprintf(answer, "%s", tmp); + else + *answer = '\0'; + } + else sprintf(answer, "%s", wd->name); + } + +int getvisual(w, answer) +wbp w; +char *answer; +{ + wdp wd = w->window->display; + Visual * v = DefaultVisual(wd->display,wd->screen); + sprintf(answer, "%d,%d,%d", v->class, v->bits_per_rgb, v->map_entries ); + return Succeeded; +} +/* + * getpos() - update the window state's notion of its current position + */ +int getpos(w) +wbp w; +{ + Window garbage1, garbage2; + int root_x, root_y, win_x, win_y; + unsigned int key_buttons; + STDLOCALS(w); + if (!stdwin) return Failed; + /* + * This call is made because it is guaranteed to generate + * a synchronous request of the server, not just ask Xlib + * what the window position was last it knew. + */ + if (XQueryPointer(stddpy, stdwin, &garbage1, &garbage2, + &root_x, &root_y, &win_x, &win_y, &key_buttons) == + False) { + return Failed; + } + ws->posx = root_x - win_x; + ws->posy = root_y - win_y; + return Succeeded; +} + +void getfg(w, answer) +wbp w; +char *answer; +{ + sprintf(answer, "%s", w->context->fg->name); +} + +void getbg(w, answer) +wbp w; +char *answer; +{ + sprintf(answer, "%s", w->context->bg->name); +} + +void getlinestyle(w, answer) +wbp w; +char *answer; +{ + wcp wc = w->context; + sprintf(answer,"%s", + (wc->linestyle==LineSolid)?"solid": + ((wc->linestyle==LineOnOffDash)?"dashed":"striped")); +} + +void getfntnam(w, answer) +wbp w; +char *answer; +{ + sprintf(answer,"%s", w->context->font->name); +} + +void getpointername(w, answer) +wbp w; +char *answer; +{ + strcpy(answer, si_i2s(cursorsyms, 2 * w->window->theCursor)); +} + +void getdrawop(w, answer) +wbp w; +char *answer; +{ + char *s; + if (ISXORREVERSE(w)) s = "reverse"; + else s = si_i2s(drawops, w->context->drawop); + if (s) sprintf(answer, "%s", s); + else strcpy(answer, "copy"); +} + +void geticonic(w, answer) +wbp w; +char *answer; +{ + switch (w->window->iconic) { + case RootState: + sprintf(answer, "root"); + break; + case NormalState: + sprintf(answer, "window"); + break; + case IconicState: + sprintf(answer, "icon"); + break; + default: + sprintf(answer, "???"); + } +} + +/* + * Set the window's font by name. + */ +int setfont(w,s) +wbp w; +char **s; + { + wfp tmp; + STDLOCALS(w); + + /* could free up previously allocated font here */ + + Protect(tmp = alc_font(w,s), return Failed); + wc->font = tmp; + + if (stdgc != NULL) + XSetFont(stddpy, stdgc, wc->font->fsp->fid); + + if (stdpix == (Pixmap) NULL) { + ws->y = wc->font->fsp->max_bounds.ascent; + ws->x = 0; + } + return Succeeded; + } + +/* + * callback procedures + */ + +static int handle_exposures(w, event) +wbp w; +XExposeEvent *event; + { + int returnval; + STDLOCALS(w); + + returnval = ISEXPOSED(w); + SETEXPOSED(w); + if (stdwin && !ISZOMBIE(w)) { + if (wc->drawop != GXcopy) + XSetFunction(stddpy, stdgc, GXcopy); + if (wc->clipw >= 0) + unsetclip(w); + XCopyArea(stddpy, stdpix, stdwin, stdgc, event->x,event->y, + event->width,event->height, event->x,event->y); + if (wc->clipw >= 0) + setclip(w); + if (wc->drawop != GXcopy) + XSetFunction(stddpy,stdgc,wc->drawop); + } + return returnval; + } +#ifndef min +#define min(x,y) (((x)<(y))?(x):(y)) +#define max(x,y) (((x)>(y))?(x):(y)) +#endif + +/* + * resizePixmap(w,width,height) -- ensure w's backing pixmap is at least + * width x height pixels. + * + * Resizes the backing pixmap, if needed. Called when X resize events + * arrive, as well as when programs make explicit resize requests. + * + * Returns 0 on failure. + */ +int resizePixmap(w,width,height) +wbp w; +int width; +int height; + { + Pixmap p; + STDLOCALS(w); + if (ws->pix == (Pixmap) NULL) return 1; + if ((width > ws->pixwidth) || (height > ws->pixheight)) { + int x = ws->pixwidth, y = ws->pixheight; + + ws->pixheight = max(ws->pixheight, height); + ws->pixwidth = max(ws->pixwidth, width); + p = XCreatePixmap(stddpy, DefaultRootWindow(stddpy), ws->pixwidth, + ws->pixheight, DefaultDepth(stddpy,wd->screen)); + if (p == (Pixmap) NULL) + return 0; + + /* + * This staggering amount of redudancy manages to make sure the new + * pixmap gets initialized including areas not in the old pixmap. + * The window is redrawn. + */ + XSetForeground(stddpy, stdgc, wc->bg->c); + if (wc->drawop != GXcopy) + XSetFunction(stddpy, stdgc, GXcopy); + if (wc->fillstyle != FillSolid) + XSetFillStyle(stddpy, stdgc, FillSolid); + if (wc->clipw >= 0) + unsetclip(w); + + if (width > x) { + XFillRectangle(stddpy, p, stdgc, x, 0, width-x, ws->pixheight); + if (stdwin != (Window) NULL) + XFillRectangle(stddpy,stdwin,stdgc, x, 0, width-x, ws->pixheight); + } + if (height > y) { + XFillRectangle(stddpy, p, stdgc, 0, y, x, height - y); + if (stdwin != (Window) NULL) + XFillRectangle(stddpy, stdwin, stdgc, 0, y, x, height - y); + } + XSetForeground(stddpy, stdgc, wc->fg->c ^ (ISXORREVERSE(w)?wc->bg->c:0)); + XCopyArea(stddpy, stdpix, p, stdgc, 0, 0, x, y, 0, 0); + if (wc->drawop != GXcopy) + XSetFunction(stddpy,stdgc,wc->drawop); + if (wc->fillstyle != FillSolid) + XSetFillStyle(stddpy, stdgc, wc->fillstyle); + if (wc->clipw >= 0) + setclip(w); + + XFreePixmap(stddpy, stdpix); /* free old pixmap */ + ws->pix = p; + } + return 1; + } + +/* + * Resize operations are made as painless as possible, but the + * user program is informed anyhow. The integer coordinates are + * the new size of the window, in pixels. + */ +static int handle_config(w, event) +wbp w; +XConfigureEvent *event; + { + struct descrip d; + STDLOCALS(w); + + /* + * Update X-Icon's information about the window's configuration + */ + ws->x = min(ws->x, event->width - FWIDTH(w)); + ws->y = min(ws->y, event->height); + + ws->posx = event->x; + ws->posy = event->y; + + /* + * If this was not a resize, drop it + */ + if ((event->width == ws->width) && (event->height == ws->height)) + return 1; + + ws->width = event->width; + ws->height = event->height; + + if (! resizePixmap(w, event->width, event->height)) return 0; + + /* + * The initial configure event generates no Icon-level "events" + */ + if (!ISEXPOSED(w)) + return 1; + + MakeInt(RESIZED, &d); + qevent(w->window, &d, ws->width, ws->height, ~(uword)0, 0); + return 1; + } + +/* + * Queue up characters for keypress events. + */ +static void handle_keypress(w,event) +wbp w; +XKeyEvent *event; + { + int i,j; + char s[10]; + struct descrip d; + KeySym k; + + w->window->pointerx = event->x; + w->window->pointery = event->y; + + switch (i=translate_key_event(event, s, &k)) { + case -1: + return; + case 0: + MakeInt(k, &d); + qevent(w->window, &d, event->x, event->y, + (uword)event->time, event->state); + break; + default: + StrLen(d) = 1; + for (j = 0; j < i; j++) { + StrLoc(d) = (char *)&allchars[s[j] & 0xFF]; + qevent(w->window, &d, event->x, event->y, + (uword)event->time, event->state); + } + } + } + +#define swap(a,b) { tmp = a; a = b; b = tmp; } +/* + * Handle button presses and drag events. In the case of drags, we should + * really be looking at an XMotionEvent instead of an XButtonEvent, but + * the structures are identical up to the button field (which we do not + * examine for drag events). Mouse coordinates are queued up after the event. + */ +static void handle_mouse(w,event) +wbp w; +XButtonEvent *event; + { + static unsigned int buttonorder[3] = + { Button1Mask, Button2Mask, Button3Mask }; + unsigned int tmp; + int eventcode = 0; + struct descrip d; + + if (event->type == MotionNotify) { + if (event->state | buttonorder[0]) { + if (buttonorder[0] == Button1Mask) + eventcode = MOUSELEFTDRAG; + else if (buttonorder[0] == Button2Mask) + eventcode = MOUSEMIDDRAG; + else + eventcode = MOUSERIGHTDRAG; + } + else if (event->state | buttonorder[1]) { + if (buttonorder[1] == Button1Mask) + eventcode = MOUSELEFTDRAG; + else if (buttonorder[1] == Button2Mask) + eventcode = MOUSEMIDDRAG; + else + eventcode = MOUSERIGHTDRAG; + } + else if (event->state | buttonorder[2]) { + if (buttonorder[2] == Button1Mask) + eventcode = MOUSELEFTDRAG; + else if (buttonorder[2] == Button2Mask) + eventcode = MOUSEMIDDRAG; + else + eventcode = MOUSERIGHTDRAG; + } + } + else switch (event->button) { + case Button1: { + eventcode = MOUSELEFT; + if (buttonorder[2] == Button1Mask) + swap(buttonorder[1],buttonorder[2]); + if (buttonorder[1] == Button1Mask) + swap(buttonorder[0],buttonorder[1]); + break; + } + case Button2: { + eventcode = MOUSEMID; + if (buttonorder[2] == Button2Mask) + swap(buttonorder[1],buttonorder[2]); + if (buttonorder[1] == Button2Mask) + swap(buttonorder[0],buttonorder[1]); + break; + } + case Button3: { + eventcode = MOUSERIGHT; + if (buttonorder[2] == Button3Mask) + swap(buttonorder[1],buttonorder[2]); + if (buttonorder[1] == Button3Mask) + swap(buttonorder[0],buttonorder[1]); + break; + } + } + if (event->type == ButtonRelease) { + eventcode -= (MOUSELEFT - MOUSELEFTUP); + swap(buttonorder[0],buttonorder[1]); + swap(buttonorder[1],buttonorder[2]); + } + + w->window->pointerx = event->x; + w->window->pointery = event->y; + MakeInt(eventcode,&d); + qevent(w->window, &d, event->x, event->y, (uword)event->time, event->state); + } + + +/* + * fill a series of rectangles + */ +void fillrectangles(w, recs, nrecs) +wbp w; +XRectangle *recs; +int nrecs; + { + STDLOCALS(w); + + /* + * Free colors if drawop=copy, fillstyle~=masked, no clipping, + * and a single rectangle that fills the whole window. + */ + if (!RECX(*recs) && !RECY(*recs) && RECWIDTH(*recs) >= ws->width && + RECHEIGHT(*recs) >= ws->height && nrecs == 1 && + wc->drawop == GXcopy && wc->fillstyle != FillStippled && wc->clipw < 0) { + RECWIDTH(*recs) = ws->pixwidth; /* fill hidden part */ + RECHEIGHT(*recs) = ws->pixheight; + free_xcolors(w, 0); /* free old colors */ + } + RENDER2(XFillRectangles, recs, nrecs); + } + +/* + * erase an area + */ +void eraseArea(w,x,y,width,height) +wbp w; +int x, y, width, height; + { + STDLOCALS(w); + + /* + * if width >= window width or height >= window height, clear any + * offscreen portion as well in order to allow the freeing of colors. + */ + if (x + width >= ws->width) width = ws->pixwidth - x; + if (y + height >= ws->height) height = ws->pixheight - y; + + /* + * fill the rectangle with the background color + */ + XSetForeground(stddpy, stdgc, wc->bg->c); + if (wc->drawop != GXcopy) XSetFunction(stddpy, stdgc, GXcopy); + if (wc->fillstyle != FillSolid) XSetFillStyle(stddpy, stdgc, FillSolid); + RENDER4(XFillRectangle, x, y, width, height); + XSetForeground(stddpy, stdgc, wc->fg->c ^ (ISXORREVERSE(w)?wc->bg->c:0)); + if (wc->drawop != GXcopy) XSetFunction(stddpy, stdgc, wc->drawop); + if (wc->fillstyle != FillSolid) XSetFillStyle(stddpy, stdgc, wc->fillstyle); + + /* + * if the entire window is cleared, free up colors + */ + if (!x && !y && width >= ws->pixwidth && height >= ws->pixheight && + wc->clipw < 0) + free_xcolors(w, 0); + } + +/* + * copy an area + */ +int copyArea(w,w2,x,y,width,height,x2,y2) +wbp w, w2; +int x, y, width, height, x2, y2; + { + int lpad, rpad, tpad, bpad; + Pixmap src; + wsp ws1 = w->window, ws2 = w2->window; + wclrp cp1, cp2 = NULL, *cpp; + STDLOCALS(w2); + + if (w->window->display->display != w2->window->display->display) { + wdp wd1 = ws1->display; + unsigned long c = 0; + int i, j; + Display *d1 = wd1->display; + XColor clr; + XImage *xim; + + /* + * Copying is between windows on two different displays. + */ + if (x<0 || y<0 || x+width > ws1->pixwidth || y+height > ws1->pixheight) + return Failed; /*#%#%# BOGUS, NEEDS FIXING */ + xim = XGetImage(d1, ws1->pix, x, y, width, height, + (1<<DefaultDepth(d1,wd1->screen))-1,XYPixmap); + XSetFunction(stddpy, stdgc, GXcopy); + for (i=0; i < width; i++) { + for (j=0; j < height; j++) { + clr.pixel = XGetPixel(xim, i, j); + if (cp2 != NULL && c == clr.pixel) { + XSetForeground(stddpy, stdgc, cp2->c); + RENDER2(XDrawPoint, i + x2, j + y2); + continue; + } + c = clr.pixel; + cp2 = NULL; + for (cpp = wd1->colrptrs; cpp < wd1->colrptrs+wd->numColors; cpp++){ + cp1 = *cpp; + if (cp1->c == c) { + if (cp1->name[0]=='\0') { + XQueryColor(d1, wd1->cmap, &clr); + cp1->r = clr.red; + cp1->g = clr.green; + cp1->b = clr.blue; + sprintf(cp1->name,"%d,%d,%d",cp1->r,cp1->g,cp1->b); + } + cp2 = alc_rgb(w2, cp1->name, cp1->r, cp1->g, cp1->b, 0); + if (cp2 == NULL) return Failed; + break; + } + } + if (cp2 == NULL) { + XQueryColor(d1, wd1->cmap, &clr); + cp2 = alc_rgb(w2, "unknown", clr.red, clr.green, clr.blue, 0); + } + if (cp2 == NULL) return Failed; + XSetForeground(stddpy, stdgc, cp2->c); + RENDER2(XDrawPoint, i + x2, j + y2); + } + } + XSetForeground(stddpy, stdgc, + wc->fg->c ^ (ISXORREVERSE(w2) ? wc->bg->c : 0)); + XSetFunction(stddpy, stdgc, wc->drawop); + XSync(stddpy,False); + XDestroyImage(xim); + } + else { + /* + * Copying is between windows on one display, perhaps the same window. + */ + src = ws1->pix; + if (src != stdpix) { + /* copying between different windows; handle color bookkeeping */ + if (!x2 && !y2 && + ((width >= ws2->pixwidth) || !width) && + ((height >= ws2->pixheight) || !height) && w2->context->clipw < 0) + free_xcolors(w2, 0); + copy_colors(w, w2); + } + + XSetForeground(stddpy, stdgc, wc->bg->c); + XSetFunction(stddpy, stdgc, GXcopy); + + if (x+width<0 || y+height<0 || x>=ws1->pixwidth || y>=ws1->pixheight) { + /* source is entirely offscreen */ + RENDER4(XFillRectangle, x2, y2, width, height); + } + else { + /* + * Check for source partially offscreen, but copy first and + * fill later in case the source and destination overlap. + */ + lpad = rpad = tpad = bpad = 0; + if (x < 0) { /* source extends past left edge */ + lpad = -x; + width -= lpad; + x2 += lpad; + x = 0; + } + if (x + width > ws1->pixwidth) { /* source extends past right edge */ + rpad = x + width - ws1->pixwidth; + width -= rpad; + } + if (y < 0) { /* source extends above top edge */ + tpad = -y; + height -= tpad; + y2 += tpad; + y = 0; + } + if (y + height > ws1->pixheight) { /* source extends below bottom */ + bpad = y + height - ws1->pixheight; + height -= bpad; + } + /* + * Copy the area. + */ + if (stdwin) + XCopyArea(stddpy, src, stdwin, stdgc, x, y, width, height, x2, y2); + XCopyArea(stddpy, src, stdpix, stdgc, x, y, width, height, x2, y2); + /* + * Fill any edges not provided by source. + */ + if (lpad > 0) + RENDER4(XFillRectangle, x2-lpad, y2-tpad, lpad, tpad+height+bpad); + if (rpad > 0) + RENDER4(XFillRectangle, x2+width, y2-tpad, rpad, tpad+height+bpad); + if (tpad > 0) + RENDER4(XFillRectangle, x2, y2-tpad, width, tpad); + if (bpad > 0) + RENDER4(XFillRectangle, x2, y2+height, width, bpad); + } + + XSetForeground(stddpy,stdgc,wc->fg->c^(ISXORREVERSE(w2) ? wc->bg->c :0)); + XSetFunction(stddpy, stdgc, wc->drawop); + } + return Succeeded; + } + +int getdefault(w, prog, opt, answer) +wbp w; +char *prog, *opt, *answer; + { + char *p; + STDLOCALS(w); + + + if ((p = XGetDefault(stddpy,prog,opt)) == NULL) + return Failed; + strcpy(answer, p); + return Succeeded; + } + + +/* + * Allocate a mutable color + */ +int mutable_color(w, argv, ac, retval) +wbp w; +dptr argv; +int ac; +int *retval; + { + XColor colorcell; + LinearColor clr; + unsigned long plane_masks[1], pixels[1]; + char *colorname; + tended char *str; + int i; + { + STDLOCALS(w); + + if (!XAllocColorCells(stddpy,wd->cmap,False,plane_masks,0,pixels,1)) { + /* + * try again with a virtual colormap + */ + if (!go_virtual(w) || + !XAllocColorCells(stddpy,wd->cmap,False,plane_masks,0,pixels,1)) + return Failed; /* cannot allocate an entry */ + } + + /* + * allocate a slot in wdisplay->colors and wstate->theColors arrays + */ + i = alc_centry(wd); + if (i == 0) + return Failed; + wd->colrptrs[i]->type = MUTABLE; + wd->colrptrs[i]->c = pixels[0]; + + /* save color index as "name", followed by a null string for value */ + colorname = wd->colrptrs[i]->name; + sprintf(colorname, "%ld", -pixels[0] - 1); /* index is name */ + colorname = colorname + strlen(colorname) + 1; + *colorname = '\0'; /* value unknown */ + + if (ws->numColors < WMAXCOLORS) { + if (ws->theColors == NULL) { + ws->theColors = (short *)calloc(WMAXCOLORS, sizeof(short)); + if (ws->theColors == NULL) + return Error; + } + ws->theColors[ws->numColors++] = i; + } + + if (ac > 0) { /* set the color */ + if (ac != 1) return Error; + /* + * old-style check for C integer + */ + else if (argv[0].dword == D_Integer) {/* check for color cell */ + if (IntVal(argv[0]) >= 0) + return Failed; /* must be negative */ + colorcell.pixel = -IntVal(argv[0]) - 1; + XQueryColor(stddpy, wd->cmap, &colorcell); + clr = lcolor(w, colorcell); + sprintf(colorname, "%ld,%ld,%ld", clr.red, clr.green, clr.blue); + } + else { + if (!cnv:C_string(argv[0],str)) { + ReturnErrVal(103,argv[0], Error); + } + if (parsecolor(w, str, &clr.red, &clr.green, &clr.blue) != Succeeded) { + free_xcolor(w, pixels[0]); + return Failed; /* invalid color specification */ + } + strcpy(colorname, str); + colorcell = xcolor(w, clr); + } + colorcell.pixel = pixels[0]; + XStoreColor(stddpy, wd->cmap, &colorcell); + } + + *retval = (-pixels[0] - 1); + return Succeeded; + } + } + +char *get_mutable_name(w, mute_index) +wbp w; +int mute_index; + { + wdp dp; + Display *d; + int i; + char *colorname; + + dp = w->window->display; + d = dp->display; + + for (i = 2; i < dp->numColors; i++) + if (dp->colrptrs[i]->type == MUTABLE + && dp->colrptrs[i]->c == - mute_index - 1) + break; + if (i == dp->numColors) + return NULL; + colorname = dp->colrptrs[i]->name; /* color name field */ + colorname = colorname + strlen(colorname) + 1; /* set value follows */ + return colorname; + } + +int set_mutable(w, i, s) +wbp w; +int i; +char *s; + { + LinearColor clr; + XColor colorcell; + wdp dp = w->window->display; + + if (parsecolor(w, s, &clr.red, &clr.green, &clr.blue) != Succeeded) + return Failed; /* invalid color specification */ + colorcell = xcolor(w, clr); + colorcell.pixel = -i - 1; + XStoreColor(dp->display, dp->cmap, &colorcell); + return Succeeded; + } + +void free_mutable(w, mute_index) +wbp w; +int mute_index; + { + wdp dp; + Display *d; + int i; + + dp = w->window->display; + d = dp->display; + + for (i = 2; i < dp->numColors; i++) + if (dp->colrptrs[i]->type == MUTABLE + && dp->colrptrs[i]->c == - mute_index - 1) + break; + if (i != dp->numColors) + free_xcolor(w, dp->colrptrs[i]->c); + } + + +void freecolor(w, s) +wbp w; +char *s; + { + wdp dp; + Display *d; + int i; + LinearColor clr; + XColor color; + + if (parsecolor(w, s, &clr.red, &clr.green, &clr.blue) != Succeeded) + return; + dp = w->window->display; + d = dp->display; + color = xcolor(w, clr); + + for (i = 2; i < dp->numColors; i++) + if (dp->colrptrs[i]->r == color.red && dp->colrptrs[i]->g == color.green + && dp->colrptrs[i]->b == color.blue && dp->colrptrs[i]->type != MUTABLE) + break; + if (i != dp->numColors) + free_xcolor(w, dp->colrptrs[i]->c); + } + +/* + * Draw a bilevel image + */ +int blimage(w, x, y, width, height, ch, s, len) +wbp w; +int x, y, width, height, ch; +unsigned char *s; +word len; + { + unsigned int m, msk1, c, ix, iy; + long fg, bg; + XImage *im; + STDLOCALS(w); + + /* + * Get an XImage structure and free the old color set if possible. + */ + im = getximage(w, x, y, width, height, ch == TCH1); + if (im == NULL) + return Error; + + /* + * Read the image string and set the pixel values. Note that + * the hex digits in sequence fill the rows *right to left*. + */ + m = width % 4; + if (m == 0) + msk1 = 8; + else + msk1 = 1 << (m - 1); /* mask for first byte of row */ + + fg = wc->fg->c; + bg = wc->bg->c; + ix = width; + iy = 0; + m = msk1; + while (len--) { + if (isxdigit(c = *s++)) { /* if hexadecimal character */ + if (!isdigit(c)) /* fix bottom 4 bits if necessary */ + c += 9; + while (m > 0) { /* set (usually) 4 pixel values */ + --ix; + if (c & m) + XPutPixel(im, ix, iy, fg); + else if (ch != TCH1) /* if zeroes aren't transparent */ + XPutPixel(im, ix, iy, bg); + m >>= 1; + } + if (ix == 0) { /* if end of row */ + ix = width; + iy++; + m = msk1; + } + else + m = 8; + } + } + if (ix > 0) /* pad final row if incomplete */ + while (ix < width) + XPutPixel(im, ix++, iy, bg); + + /* + * Put it on the screen. + */ + if (wc->drawop != GXcopy) XSetFunction(stddpy, stdgc, GXcopy); + RENDER7(XPutImage, im, 0, 0, x, y, width, height); + XDestroyImage(im); + if (wc->drawop != GXcopy) XSetFunction(stddpy, stdgc, wc->drawop); + return Succeeded; + } + +/* + * Draw a character-per-pixel image + */ +int strimage(w, x, y, width, height, e, s, len, on_icon) +wbp w; +int x, y, width, height; +struct palentry *e; +unsigned char *s; +word len; +int on_icon; + { + int c, v, ret, trans; + unsigned int r, g, b, ix, iy; + wclrp cp, cplist[256]; + char tmp[24]; + XImage *im; + STDLOCALS(w); + + /* + * Get an XImage structure and free the old color set if possible. + */ + trans = 0; + for (c = 0; c < 256; c++) + trans |= e[c].used && e[c].transpt; + im = getximage(w, x, y, width, height, trans); + if (im == NULL) + return -1; + + /* + * Allocate the colors we need. Use black or white if unsuccessful. + */ + ret = 0; + for (c = 0; c < 256; c++) + if (e[c].used && e[c].valid) { + r = e[c].clr.red; + g = e[c].clr.green; + b = e[c].clr.blue; + sprintf(tmp, "%d,%d,%d", r, g, b); + cp = alc_rgb(w, tmp, r, g, b, 0); + if (cp == NULL) { + ret++; + if ((0.299 * r + 0.587 * g + 0.114 * b) > 32767) + cp = alc_rgb(w, "white", 65535, 65535, 65535, 0); + else + cp = alc_rgb(w, "black", 0, 0, 0, 0); + } + cplist[c] = cp; + } + + /* + * Read the image string and set the pixel values. + */ + ix = iy = 0; + while (len--) { + c = *s++; + v = e[c].valid; + if (v) /* put char if valid */ + XPutPixel(im, ix, iy, cplist[c]->c); + if (v || e[c].transpt) { /* advance if valid or transparent */ + if (++ix >= width) { + ix = 0; /* reset for new row */ + iy++; + } + } + } + if (ix > 0) /* pad final row if incomplete */ + while (ix < width) + XPutPixel(im, ix++, iy, wc->bg->c); + + /* + * Put it on the screen. + */ + if (wc->drawop != GXcopy) XSetFunction(stddpy, stdgc, GXcopy); + if (on_icon) { + if (ws->iconwin == (Window) NULL) makeIcon(w, 0, 0); + XPutImage(stddpy, ws->iconwin, stdgc, im, 0, 0, x, y, width, height); + XPutImage(stddpy, ws->iconpix, stdgc, im, 0, 0, x, y, width, height); + } + else { + XPutImage(stddpy, ws->pix, stdgc, im, 0, 0, x, y, width, height); + if (ws->win) + XCopyArea(stddpy, ws->pix, ws->win, stdgc, x, y, width, height, x, y); + } + XDestroyImage(im); + if (wc->drawop != GXcopy) XSetFunction(stddpy, stdgc, wc->drawop); + return ret; + } + +/* + * capture(w, x, y, width, height, data) -- get image region. + * + * Stores the specified subimage in data as 15-bit linear color. + */ +int capture(w, x, y, width, height, data) +wbp w; +int x, y, width, height; +short *data; + { + Visual *v; + XImage *im; + XColor colorcell; + LinearColor lc; + wclrp *cpp; + unsigned char cmap[256]; + short *cval; + int i, r, g, b, ncolors; + unsigned long px, clist[GIFMAX], *lp, *ckey; + double gamma = w->context->gamma; + STDLOCALS(w); + + /* + * Get an XImage structure containing window pixel values. + */ + im = getximage(w, x, y, width, height, 1); + if (!im) + return 0; + + /* + * Make a mapping table from X color to 5-bit linear color. + */ + for (i = 0; i < 256; i++) + cmap[i] = 31 * pow(i / 255., gamma) + 0.5; + + /* + * Translate the colors and store in the data buffer. + */ + v = wd->visual; + if (v->class == TrueColor && v->red_mask == 0x00FF0000L + && v->green_mask == 0x0000FF00L && v->blue_mask == 0x000000FFL) { + /* + * 24-bit RGB is decomposed and mapped directly + */ + for (y = 0; y < height; y++) { + for (x = 0; x < width; x++) { + px = XGetPixel(im, x, y); + r = cmap[(px >> 16) & 0xFF]; + g = cmap[(px >> 8) & 0xFF]; + b = cmap[px & 0xFF]; + *data++ = (r << 10) | (g << 5) | b; + } + } + } + else { + /* + * General case uses a cache to improve performance. + */ + #define CCACHE 4987 /* cache size; should be odd */ + ckey = calloc(CCACHE, sizeof(ckey[0])); + cval = calloc(CCACHE, sizeof(cval[0])); + if (!ckey || !cval) + return 0; + for (y = 0; y < height; y++) { + for (x = 0; x < width; x++) { + px = XGetPixel(im, x, y); /* get pixel value */ + i = px % CCACHE; /* get cache index */ + if (ckey[i] != px) { /* if color not cached */ + colorcell.pixel = px; + colorcell.flags = DoRed | DoGreen | DoBlue; + XQueryColor(stddpy, wd->cmap, &colorcell); /* costly */ + ckey[i] = px; + cval[i] = (cmap[colorcell.red >> 8] << 10) | + (cmap[colorcell.green >> 8] << 5) | cmap[colorcell.blue >> 8]; + } + *data++ = cval[i]; /* save rgb15 color value */ + } + } + free(cval); + free(ckey); + } + XDestroyImage(im); + return 1; + } + +/* + * Create an XImage structure corresponding to subimage (x, y, w, h). + * If init is nonzero, initialize it with current contents. + * If init is zero and (x,y,w,h) fills the window, free existing color set. + */ +static XImage *getximage(w, x, y, width, height, init) +wbp w; +int x, y, width, height, init; + { + int tx, ty; + XImage *im; + STDLOCALS(w); + + im = XCreateImage(stddpy, DefaultVisual(stddpy, wd->screen), + DefaultDepth(stddpy, wd->screen), ZPixmap, 0, NULL, width, height, 32, 0); + if (im == NULL) + return NULL; + im->data = malloc(im->bytes_per_line * height); + if (im->data == NULL) { + XDestroyImage(im); + return NULL; + } + + if (!init) { + if (x <= 0 && y <= 0 && x + width >= ws->pixwidth && + y + height >= ws->pixheight && wc->clipw < 0) + free_xcolors(w, 0); + return im; + } + + tx = ty = 0; + if (x < 0) { tx -= x; width += x; x = 0; } + if (y < 0) { ty -= y; height += y; y = 0; } + if (x + width > ws->width) { width = ws->width - x; } + if (y + height > ws->height) { height = ws->height - y; } + if (width > 0 && height > 0) + XGetSubImage(stddpy, stdpix, x, y, width, height, AllPlanes, ZPixmap, + im, tx, ty); + return im; + } + +int readimage(w, filename, x, y, status) +wbp w; +char *filename; +int x, y, *status; + { + Pixmap p; + unsigned int width, height; + STDLOCALS(w); + if (!x && !y) + p = loadimage(w, filename, &height, &width, 1, status); + else + p = loadimage(w, filename, &height, &width, 0, status); + if (p == (Pixmap) NULL) return Failed; + + if (wc->drawop != GXcopy) + XSetFunction(stddpy, stdgc, GXcopy); + if (stdwin) + XCopyArea(stddpy, p, stdwin, stdgc, 0, 0, width, height, x, y); + XCopyArea(stddpy, p, stdpix, stdgc, 0, 0, width, height, x, y); + if (wc->drawop != GXcopy) + XSetFunction(stddpy,stdgc,wc->drawop); + + /* + * Make sure previous ops on p are complete, then free it. + */ + XSync(stddpy, False); + XFreePixmap(stddpy, p); + return Succeeded; + } + + +/* + * Initialize client for producing pixels from a window + */ +int getpixel_init(w, imem) +wbp w; +struct imgmem *imem; + { + STDLOCALS(w); + + if (imem->width <= 0 || imem->height <= 0) { + imem->im = NULL; + return Succeeded; + } + + imem->im = XGetImage(stddpy, stdpix, + imem->x, imem->y, imem->width, imem->height, + (1 << DefaultDepth(stddpy, wd->screen))-1, XYPixmap); + + if (imem->im == NULL) return Failed; + return Succeeded; + } + +int getpixel_term(w, imem) +wbp w; +struct imgmem *imem; + { + if (imem->im != NULL) + XDestroyImage(imem->im); + return Succeeded; + } + +/* + * Return pixel (x,y) from a window in long value (rv) + */ +int getpixel(w, x, y, rv, s, imem) +wbp w; +int x, y; +long *rv; +char *s; +struct imgmem *imem; + { + XColor colorcell; + LinearColor clr; + wclrp *cpp; + unsigned long c; + STDLOCALS(w); + + if (x < imem->x || x >= imem->x + imem->width || + y < imem->y || y >= imem->y + imem->height) + c = colorcell.pixel = wc->bg->c; + else + c = colorcell.pixel = XGetPixel(imem->im, x - imem->x, y - imem->y); + *rv = 0xff000000; + + for (cpp = wd->colrptrs ; cpp < wd->colrptrs + wd->numColors; cpp++) { + if ((*cpp)->c == c) { + if ((*cpp)->type == MUTABLE) + *rv = -c - 1; + else { + *rv = 1; + colorcell.red = (*cpp)->r; + colorcell.green = (*cpp)->g; + colorcell.blue = (*cpp)->b; + clr = lcolor(w, colorcell); + sprintf(s, "%ld,%ld,%ld", clr.red, clr.green, clr.blue); + } + break; + } + } + if (*rv == 0xff000000) { + XQueryColor(stddpy, wd->cmap, &colorcell); + *rv = 1; + clr = lcolor(w, colorcell); + sprintf(s, "%ld,%ld,%ld", clr.red, clr.green, clr.blue); + } + return Succeeded; + } + + +int query_pointer(w, pp) +wbp w; +XPoint *pp; + { + Display *theDisplay; + Window theWindow; + Window garbage1, garbage2; + int root_x, root_y, win_x, win_y; + unsigned int key_buttons; + + theDisplay = w->window->display->display; + theWindow = w->window->win; + if (theWindow == (Window) NULL) return Failed; + + XQueryPointer(theDisplay, theWindow, &garbage1, &garbage2, + &root_x, &root_y, &win_x, &win_y, &key_buttons); + pp->x = w->window->pointerx = win_x; + pp->y = w->window->pointery = win_y; + return Succeeded; + } + +int query_rootpointer(pp) +XPoint *pp; + { + Display *theDisplay; + Window theWindow; + Window garbage1, garbage2; + int root_x, root_y, win_x, win_y; + unsigned int key_buttons; + wdp wd; + if (wdsplys == NULL) { + /* + * Initialize the window system + */ + Protect(wd = alc_display(NULL), return Failed); + + theDisplay = wd->display; + theWindow = DefaultRootWindow(wd->display); + } + else { + wd = wdsplys; + theDisplay = wd->display; + theWindow = DefaultRootWindow(wd->display); + } + XQueryPointer(theDisplay, theWindow, &garbage1, &garbage2, + &root_x, &root_y, &win_x, &win_y, &key_buttons); + pp->x = root_x; + pp->y = root_y; + return Succeeded; + } + + +int patbits[] = { + 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF, + 0xFE,0xFF,0xEF,0xFF,0xFE,0xFF,0xEF,0xFF, + 0x77,0xDD,0x77,0xDD,0x77,0xDD,0x77,0xDD, + 0x55,0xAA,0x55,0xAA,0x55,0xAA,0x55,0xAA, + 0x11,0x44,0x11,0x44,0x11,0x44,0x11,0x44, + 0x01,0x00,0x10,0x00,0x01,0x00,0x10,0x00, + 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, + + 0x10,0x10,0x10,0x10,0x10,0x10,0x10,0x10, + 0x80,0x40,0x20,0x10,0x08,0x04,0x02,0x01, + 0x00,0x00,0x00,0xFF,0x00,0x00,0x00,0x00, + 0x10,0x10,0x10,0xFF,0x10,0x10,0x10,0x10, + 0x82,0x44,0x28,0x10,0x28,0x44,0x82,0x01, + + 0x0F,0x0F,0x0F,0x0F,0xF0,0xF0,0xF0,0xF0, + 0x1B,0x18,0x81,0xB1,0x36,0x06,0x60,0x63, + 0x02,0x02,0x05,0xF8,0x20,0x20,0x50,0x8F, + 0x03,0x84,0x48,0x30,0x03,0x84,0x48,0x30, +}; + +/* + * pattern symbols + */ +stringint siPatternSyms[] = { + {0, 16}, + { "black", 0}, + { "checkers", 12}, + { "darkgray", 2}, + { "diagonal", 8}, + { "grains", 13}, + { "gray", 3}, + { "grid", 10}, + { "horizontal",9}, + { "lightgray", 4}, + { "scales", 14}, + { "trellis", 11}, + { "vertical", 7}, + { "verydark", 1}, + { "verylight", 5}, + { "waves", 15}, + { "white", 6}, +}; + +/* + * SetPattern + */ +int SetPattern(w, name, len) +wbp w; +char *name; +int len; + { + int width, nbits; + int i; + int symbol; + C_integer v, bits[MAXXOBJS]; + Pixmap p; + char data[MAXXOBJS]; + char *buf = data; + STDLOCALS(w); + + if (wc->patternname != NULL) + free(wc->patternname); + wc->patternname = malloc(len+1); + if (wc->patternname == NULL) ReturnErrNum(305, Error); + strncpy(wc->patternname, name, len); + wc->patternname[len] = '\0'; + + /* + * If the pattern starts with a number it is a width , bits encoding + */ + if ((len > 0) && isdigit(name[0])) { + nbits = MAXXOBJS; + switch (parsepattern(name, len, &width, &nbits, bits)) { + case Failed: + return Failed; + case Error: + ReturnErrNum(145, Error); + } + if (!stdgc) return Succeeded; + return SetPatternBits(w, width, bits, nbits); + } + + /* + * Otherwise, it is a named pattern. Find the symbol id. + */ + if ((symbol = si_s2i(siPatternSyms, wc->patternname)) >= 0) { + if (!stdgc) return Succeeded; + for(i = 0; i < 8; i++) { + v = patbits[symbol * 8 + i]; + *buf++ = v; + } + p = XCreateBitmapFromData(stddpy, stdpix, data, 8, 8); + XSetStipple(stddpy, stdgc, p); + XSync(stddpy, False); + XFreePixmap(stddpy, p); + return Succeeded; + } + return Failed; + } + +int SetPatternBits(w, width, bits, nbits) +wbp w; +int width; +C_integer *bits; +int nbits; + { + C_integer v; + int i, j; + Pixmap p; + char data[MAXXOBJS]; + char *buf = data; + STDLOCALS(w); + + for(i = 0; i < nbits; i++) { + v = bits[i]; + for(j=0; j<width; j+=8) { + *buf++ = v; + v >>= 8; + } + } + + p = XCreateBitmapFromData(stddpy, stdpix, data, width, nbits); + XSetStipple(stddpy, stdgc, p); + XSync(stddpy, False); + XFreePixmap(stddpy, p); + return Succeeded; + } + + + +/* + * remap a window ... this time with an iconwin + */ +int remap(w,x,y) +wbp w; +int x,y; + { + XSizeHints size_hints; + XWMHints *wmhints; + STDLOCALS(w); + + XGetSizeHints(stddpy, stdwin, &size_hints, XA_WM_NORMAL_HINTS); + wmhints = XGetWMHints(stddpy, stdwin); + if (ws->iconwin) + XDestroyWindow(stddpy, ws->iconwin); + if (stdwin) + XDestroyWindow(stddpy, stdwin); + + ws->win = XCreateSimpleWindow(stddpy, DefaultRootWindow(stddpy), + ws->posx, ws->posy, ws->width, + ws->height, 4, wc->fg->c, wc->bg->c); + XSetStandardProperties(stddpy, ws->win, ws->windowlabel, + ws->iconlabel, 0, 0, 0, &size_hints); + XSelectInput(stddpy, ws->win, ExposureMask | KeyPressMask | + ButtonPressMask | ButtonReleaseMask | ButtonMotionMask | + StructureNotifyMask); + + ws->iconwin = XCreateSimpleWindow(stddpy, DefaultRootWindow(stddpy), + ws->iconx, ws->icony, ws->iconw, + ws->iconh, 2, wc->fg->c, wc->bg->c); + XSelectInput(stddpy, ws->iconwin, + ExposureMask | KeyPressMask | ButtonPressMask); + + wmhints->flags |= IconPositionHint; + wmhints->icon_x = x; + wmhints->icon_y = y; + wmhints->initial_state = ws->iconic; + wmhints->icon_window = ws->iconwin; + wmhints->flags |= IconWindowHint; + XSetWMHints(stddpy, ws->win, wmhints); + CLREXPOSED(w); + XMapWindow(stddpy, ws->win); + if (ws->iconic == NormalState) { + while (!ISEXPOSED(w)) + if (pollevent() == -1) return -1; + } + ws->iconx = x; + ws->icony = y; + XSync(stddpy, False); + XFree((char *)wmhints); + return 1; + } + + +int seticonimage(w, dp) +wbp w; +dptr dp; + { + int status; + Pixmap pix; + tended char *tmp; + { + STDLOCALS(w); + /* + * get the preloaded (in another window value) pixmap image + */ + if (is:file(*dp) && (BlkLoc(*dp)->file.status & Fs_Window)) { + wbp x = (wbp)BlkLoc(*dp)->file.fd; + if ((ws->iconimage = salloc(x->window->windowlabel)) == NULL) + ReturnErrNum(305, Error); + pix = XCreatePixmap(stddpy, DefaultRootWindow(stddpy), + x->window->width, x->window->height, + DefaultDepth(stddpy,wd->screen)); + + XCopyArea(stddpy, x->window->pix, pix, wd->icongc, 0, 0, + x->window->width, x->window->height, 0, 0); + if (ws->iconpix) { + XSync(stddpy, False); + XFreePixmap(stddpy, ws->iconpix); + } + ws->iconpix = pix; + ws->iconw = x->window->width; + ws->iconh = x->window->height; + if (!ws->iconx && !ws->icony) { + ws->iconx = ws->x; + ws->icony = ws->y; + } + if (remap(w,ws->iconx,ws->icony) == -1) + ReturnErrNum(144, Error); + + } + /* get the pixmap file named by x */ + else if (is:string(*dp)) { + unsigned int height, width; + if (!cnv:C_string(*dp,tmp)) + ReturnErrVal(103, *dp, Error); + + if ((ws->iconimage != NULL) && strcmp(ws->iconimage, "")) + free(ws->iconimage); + if ((ws->iconimage = salloc(tmp)) == NULL) + ReturnErrNum(305, Error); + if (ws->iconwin == (Window) NULL) makeIcon(w,0,0); + else { + pix = loadimage(w, ws->iconimage, &height, &width, 0, &status); + if (pix == (Pixmap) NULL) + return Failed; + XCopyArea(stddpy, pix, ws->iconwin, wd->icongc, + 0, 0, width, height, 0, 0); + if (ws->iconpix) { + XSync(stddpy, False); + XFreePixmap(stddpy, ws->iconpix); + } + ws->iconpix = pix; + ws->iconw = width; + ws->iconh = height; + if (remap(w,ws->iconx,ws->icony) == -1) + ReturnErrNum(144, Error); + } + } + else + return Failed; + return Succeeded; + } + } + + +/* + * dumpimage -- write an image to a disk file in an X format. + * + * Accepts only .xpm and .xbm file names, returning NoCvt for anything else. + */ + +int dumpimage(w,filename,x,y,width,height) +wbp w; +char *filename; +unsigned int x, y, height, width; + { + int status; + STDLOCALS(w); + + /* + * Check for bilevel XBM (X BitMap) format. + */ + if (!strcmp(".xbm", filename + strlen(filename) - 4) || + !strcmp(".XBM", filename + strlen(filename) - 4)) { + /* + * Write a bitmap from a "color" window (presumed to have only BW in it). + * BlackPixel ^ WhitePixel will have a 1 in the first bit in which + * they are different, so this bit is the plane we want to copy. + */ + + if (DefaultDepth(stddpy,wd->screen) != 1) { + unsigned long bw = + BlackPixel(stddpy,wd->screen) ^ WhitePixel(stddpy,wd->screen); + Pixmap p1 = XCreatePixmap(stddpy, DefaultRootWindow(stddpy), + width, height, 1); + XGCValues xgc; + GC thinGC; + int i; + /* + * pick out the bitplane on which Black and White differ + */ + for(i=0;!((1<<i) & bw);i++); + bw &= (1<<i); + /* + * Construct a 1-bit-deep GC for use in copying the plane. + */ + xgc.foreground = BlackPixel(stddpy,wd->screen); + xgc.background = WhitePixel(stddpy,wd->screen); + thinGC = XCreateGC(stddpy,p1,GCForeground|GCBackground,&xgc); + + if (i>DefaultDepth(stddpy,wd->screen)) return Failed; + XCopyPlane(stddpy,stdpix,p1,thinGC,x,y,width,height,0,0,bw); + status= XWriteBitmapFile(stddpy, filename, p1, width, height, -1, -1); + + XSync(stddpy, False); + XFreePixmap(stddpy, p1); + XFreeGC(stddpy,thinGC); + if (status != BitmapSuccess) return Failed; + } + else { + if(x || y) { + Pixmap p1 = XCreatePixmap(stddpy, DefaultRootWindow(stddpy), width, + height, DefaultDepth(stddpy,wd->screen)); + + XCopyArea(stddpy, stdpix, p1, stdgc, x, y, width, height, 0, 0); + XSync(stddpy, False); + + status = XWriteBitmapFile(stddpy,filename,p1,width,height,-1,-1); + + XSync(stddpy, False); + XFreePixmap(stddpy, p1); + + if (status != BitmapSuccess) return Failed; + + } + else if (XWriteBitmapFile(stddpy, filename, stdpix, + width, height, -1, -1) != BitmapSuccess) + return Failed; + + } + return Succeeded; + } + /* + * Check for XPM (color X PixMap) format. + */ + else if (!strcmp(".xpm", filename + strlen(filename) - 4) || + !strcmp(".XPM", filename + strlen(filename) - 4) || + !strcmp(".xpm.Z", filename + strlen(filename) - 6)) { +#ifdef HaveXpmFormat + /* + * Could optimize by calling XpmWriteFileFromPixmap directly on the + * stdpix... + */ + Pixmap p1 = XCreatePixmap(stddpy, DefaultRootWindow(stddpy), width, + height, DefaultDepth(stddpy,wd->screen)); + + XCopyArea(stddpy, stdpix, p1, stdgc, x, y, width, height, 0, 0); + XSync(stddpy, False); + + status = XpmWriteFileFromPixmap(stddpy, filename, p1, + (Pixmap) NULL, NULL); + XSync(stddpy, False); + XFreePixmap(stddpy, p1); + + if (status == XpmSuccess) + return Succeeded; +#endif /* HaveXpmFormat */ + return Failed; + } + else + return NoCvt; /* not an X format -- write GIF instead */ + } + +/* + * Load an image, in any format we can figure out. + */ +Pixmap loadimage(w, filename, height, width, atorigin, status) +wbp w; +char *filename; +unsigned int *height, *width; +int atorigin; +int *status; + { + Pixmap p1, p2 = (Pixmap) NULL; + int xhot, yhot, i, j; + XGCValues gcv; + unsigned long gcmask = GCFont | GCForeground | GCBackground; + int isxbm; + STDLOCALS(w); + + if (!strcmp(".xbm", filename + strlen(filename) - 4)) + isxbm = 1; + else if (!strcmp(".xpm", filename + strlen(filename) - 4) || + !strcmp(".xpm.Z", filename + strlen(filename) - 6)) + isxbm = 0; + else { + /* + * Not sure what kind of file this is, make a guess + * For example, the format might be on the first line of the file, + * so open it up and read some. + */ + FILE *ftemp = fopen(filename,"r"); + char s[6]; + int i; + + if (!ftemp) { + return (Pixmap) NULL; + } + if ((long)fread(s,1,6,ftemp) < (long)6) { + fclose(ftemp); + return (Pixmap) NULL; + } + fclose(ftemp); + /* check s for XPM string */ + isxbm = 1; /* default to xbm */ + for (i = 0; i <= 3; i++) + if (!strncmp(&s[i], "XPM", 3)) + isxbm = 0; + } + + if (isxbm) { /* isxbm = 1 => .xbm file */ + if (XReadBitmapFile(stddpy, DefaultRootWindow(stddpy), filename, + width, height, &p1, &xhot, &yhot) != BitmapSuccess) + return (Pixmap) NULL; + else *status = 0; + p2 = XCreatePixmap(stddpy, DefaultRootWindow(stddpy), *width, *height, + DefaultDepth(stddpy,DefaultScreen(stddpy))); + } + else { /* isxbm == 0 => .xpm file */ +#ifndef HaveXpmFormat + return NULL; +#else /* HaveXpmFormat */ + XpmAttributes a; + XColor color; + LinearColor clr; + Pixmap dummy; + a.npixels = 0; + a.colormap = wd->cmap; + a.valuemask = XpmReturnPixels | XpmColormap; + + *status = XpmReadFileToPixmap(stddpy, DefaultRootWindow(stddpy), + filename, &p2, &dummy, &a); + + if (*status == XpmColorFailed && go_virtual(w)) { + /* try again with a virtual colormap */ + a.npixels = 0; + a.colormap = wd->cmap; + a.valuemask = XpmReturnPixels | XpmColormap; + *status = XpmReadFileToPixmap(stddpy, DefaultRootWindow(stddpy), + filename, &p2, &dummy, &a); + } + + if (*status != XpmSuccess) { + if (*status == XpmColorFailed) + *status = 1; + else + return (Pixmap) NULL; + } + else *status = 0; + *height = a.height; + *width = a.width; + + /* + * if the loaded image is to cover an entire window, free up colors + * currently in use by the window + */ + if (atorigin && *width >= ws->pixwidth && *height >= ws->pixheight + && wc->clipw < 0) + free_xcolors(w, 0); + + /* + * OK, now register all the allocated colors with the display + * and window in which we are residing. + */ + for (i = 0; i < a.npixels; i++) { + j = alc_centry(wd); + if (j == 0) + return (Pixmap) NULL; + /* + * Store their allocated pixel (r,g,b) values. + */ + color.pixel = wd->colrptrs[j]->c = a.pixels[i]; + XQueryColor(stddpy, wd->cmap, &color); + wd->colrptrs[j]->r = color.red; + wd->colrptrs[j]->g = color.green; + wd->colrptrs[j]->b = color.blue; + clr = lcolor(w, color); + sprintf(wd->colrptrs[j]->name, "%ld,%ld,%ld", + clr.red, clr.green, clr.blue); + if (ws->numColors <= WMAXCOLORS) { + if (ws->theColors == NULL) { + ws->theColors = (short *)calloc(WMAXCOLORS, sizeof(short)); + if (ws->theColors == NULL) + return (Pixmap) NULL; + } + ws->theColors[ws->numColors++] = j; + } + } +#endif /* HaveXpmFormat */ + } + + if (p2 == (Pixmap) NULL) { + return (Pixmap) NULL; + } + + if (stdgc == NULL) { + gcv.foreground = wc->fg->c; + gcv.background = wc->bg->c; + gcv.font = wc->font->fsp->fid; + wc->gc = XCreateGC(stddpy, p2, gcmask, &gcv); + stdgc = wc->gc; + } + + if (isxbm) { + XCopyPlane(stddpy, p1, p2, stdgc, 0, 0, *width, *height, 0, 0, 1); + XSync(stddpy, False); + XFreePixmap(stddpy, p1); + } + return p2; + } + +/* + * Interpret a platform-specific color name s. + * Under X, we can do this only if there is a window. + */ +int nativecolor(w, s, r, g, b) +wbp w; +char *s; +long *r, *g, *b; + { + XColor colorcell; + LinearColor clr; + wsp ws; + wdp wd; + + if (!w) /* if no window, give up */ + return 0; + ws = w->window; + wd = ws->display; + if (!XParseColor(wd->display, wd->cmap, s, &colorcell)) + return 0; /* if unknown to X */ + clr = lcolor(w, colorcell); + *r = clr.red; + *g = clr.green; + *b = clr.blue; + return 1; + } + +/* + * Convert an X color into an Icon linear color. + */ +LinearColor lcolor(w, colorcell) +wbp w; +XColor colorcell; + { + LinearColor l; + double gamma = w->context->gamma; + + l.red = 65535 * pow((int)colorcell.red / 65535.0, gamma); + l.green = 65535 * pow((int)colorcell.green / 65535.0, gamma); + l.blue = 65535 * pow((int)colorcell.blue / 65535.0, gamma); + return l; + } + +/* + * Convert an Icon linear color into an X colorcell. + */ +XColor xcolor(w, c) +wbp w; +LinearColor c; + { + XColor x; + double invgamma = 1.0 / w->context->gamma; + + x.red = 65535 * pow(c.red / 65535.0, invgamma); + x.green = 65535 * pow(c.green / 65535.0, invgamma); + x.blue = 65535 * pow(c.blue / 65535.0, invgamma); + x.flags = DoRed | DoGreen | DoBlue; + return x; + } + + +int raiseWindow(w) +wbp w; + { + wsp ws = w->window; + if (ws->win) { + XRaiseWindow(ws->display->display, ws->win); + XSetInputFocus(ws->display->display,ws->win,RevertToParent,CurrentTime); + } + return Succeeded; + } + +int lowerWindow(w) +wbp w; + { + if (w->window->win) + XLowerWindow(w->window->display->display, w->window->win); + return Succeeded; + } + +int walert(w, volume) +wbp w; +int volume; +{ + STDLOCALS(w); + XBell(stddpy, volume); + XFlush(stddpy); + return Succeeded; + } + +#endif /* Graphics */ |