[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Gcl-commits] gcl acconfig.h configure configure.in makefile ... [Versio
|
From: |
Camm Maguire |
|
Subject: |
[Gcl-commits] gcl acconfig.h configure configure.in makefile ... [Version_2_6_8pre] |
|
Date: |
Fri, 09 Jun 2006 15:53:36 +0000 |
CVSROOT: /cvsroot/gcl
Module name: gcl
Branch: Version_2_6_8pre
Changes by: Camm Maguire <camm> 06/06/09 15:53:32
Modified files:
. : acconfig.h configure configure.in makefile
binutils/intl : Makefile.in
debian : changelog copyright
h : gclincl.h.in
lsp : gcl_auto_new.lsp gcl_mislib.lsp
o : main.c
xgcl-2 : dwdoc.tex gcl_X.lsp gcl_draw-gates.lsp
gcl_draw.lsp gcl_drawtrans.lsp gcl_dwindow.lsp
gcl_dwtest.lsp gcl_dwtrans.lsp gcl_general.lsp
gcl_menu-set.lsp general-c.c makefile
sysdef.lisp
Added files:
debian : in.gcl-doc.doc-base.xgcl
xgcl-2 : gcl_dwexports.lsp gcl_dwimportsb.lsp
gcl_dwtestcases.lsp gcl_editors.lsp
gcl_editorstrans.lsp gcl_lispserver.lsp
gcl_lispservertrans.lsp gcl_menu-settrans.lsp
Log message:
xgcl integration
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/gcl/acconfig.h?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.22.6.9.2.1.6.1.4.1.4.3&r2=1.22.6.9.2.1.6.1.4.1.4.4
http://cvs.savannah.gnu.org/viewcvs/gcl/configure?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.107.4.1.2.2.2.48.2.3.2.1.4.2.4.2.4.12&r2=1.107.4.1.2.2.2.48.2.3.2.1.4.2.4.2.4.13
http://cvs.savannah.gnu.org/viewcvs/gcl/configure.in?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.112.4.1.2.2.2.47.2.3.2.1.4.2.4.2.4.12&r2=1.112.4.1.2.2.2.47.2.3.2.1.4.2.4.2.4.13
http://cvs.savannah.gnu.org/viewcvs/gcl/makefile?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.73.4.2.2.21.6.1.8.3&r2=1.73.4.2.2.21.6.1.8.4
http://cvs.savannah.gnu.org/viewcvs/gcl/binutils/intl/Makefile.in?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.2.1&r2=1.1.2.2
http://cvs.savannah.gnu.org/viewcvs/gcl/debian/changelog?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.220.2.1.4.1.2.1.2.1.2.2.2.1.2.19.2.207.2.23.2.11.2.14.2.13.4.7.2.22.2.43&r2=1.220.2.1.4.1.2.1.2.1.2.2.2.1.2.19.2.207.2.23.2.11.2.14.2.13.4.7.2.22.2.44
http://cvs.savannah.gnu.org/viewcvs/gcl/debian/copyright?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.4&r2=1.4.20.1
http://cvs.savannah.gnu.org/viewcvs/gcl/debian/in.gcl-doc.doc-base.xgcl?cvsroot=gcl&only_with_tag=Version_2_6_8pre&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/gcl/h/gclincl.h.in?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.27.6.10.8.1.4.1.4.3&r2=1.27.6.10.8.1.4.1.4.4
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_auto_new.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.2.1&r2=1.1.2.1.14.1
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_mislib.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.2.5.2.1.4.1.8.1&r2=1.1.2.5.2.1.4.1.8.2
http://cvs.savannah.gnu.org/viewcvs/gcl/o/main.c?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.26.4.1.2.21.6.1.4.1.2.2&r2=1.26.4.1.2.21.6.1.4.1.2.3
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/dwdoc.tex?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.1.1&r2=1.1.1.1.20.1
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_X.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.2.1&r2=1.1.2.2
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_draw-gates.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.2.1&r2=1.1.2.2
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_draw.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.2.1&r2=1.1.2.2
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_drawtrans.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.2.1&r2=1.1.2.2
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_dwindow.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.2.1&r2=1.1.2.2
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_dwtest.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.2.1&r2=1.1.2.2
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_dwtrans.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.2.1&r2=1.1.2.2
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_general.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.2.1&r2=1.1.2.2
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_menu-set.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.2.1&r2=1.1.2.2
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/general-c.c?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.1.1.2.1.18.1&r2=1.1.1.1.2.1.18.2
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/makefile?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.3.2.1&r2=1.3.2.1.18.1
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/sysdef.lisp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&r1=1.1.1.1.2.1.18.1&r2=1.1.1.1.2.1.18.2
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_dwexports.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_dwimportsb.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_dwtestcases.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_editors.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_editorstrans.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_lispserver.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_lispservertrans.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/gcl/xgcl-2/gcl_menu-settrans.lsp?cvsroot=gcl&only_with_tag=Version_2_6_8pre&rev=1.1.2.1
Patches:
Index: acconfig.h
===================================================================
RCS file: /cvsroot/gcl/gcl/acconfig.h,v
retrieving revision 1.22.6.9.2.1.6.1.4.1.4.3
retrieving revision 1.22.6.9.2.1.6.1.4.1.4.4
diff -u -b -r1.22.6.9.2.1.6.1.4.1.4.3 -r1.22.6.9.2.1.6.1.4.1.4.4
--- acconfig.h 15 Dec 2005 18:14:16 -0000 1.22.6.9.2.1.6.1.4.1.4.3
+++ acconfig.h 9 Jun 2006 15:53:29 -0000 1.22.6.9.2.1.6.1.4.1.4.4
@@ -253,3 +253,4 @@
#undef HZ
#undef ADDR_NO_RANDOMIZE
#undef LEADING_UNDERSCORE
+#undef HAVE_XGCL
Index: configure
===================================================================
RCS file: /cvsroot/gcl/gcl/configure,v
retrieving revision 1.107.4.1.2.2.2.48.2.3.2.1.4.2.4.2.4.12
retrieving revision 1.107.4.1.2.2.2.48.2.3.2.1.4.2.4.2.4.13
diff -u -b -r1.107.4.1.2.2.2.48.2.3.2.1.4.2.4.2.4.12
-r1.107.4.1.2.2.2.48.2.3.2.1.4.2.4.2.4.13
--- configure 9 Jan 2006 19:54:32 -0000
1.107.4.1.2.2.2.48.2.3.2.1.4.2.4.2.4.12
+++ configure 9 Jun 2006 15:53:29 -0000
1.107.4.1.2.2.2.48.2.3.2.1.4.2.4.2.4.13
@@ -42,6 +42,8 @@
ac_help="$ac_help
--enable-xdr=yes will compile in support for XDR"
ac_help="$ac_help
+ --enable-xgcl=yes will compile in support for XGCL"
+ac_help="$ac_help
--enable-dlopen uses dlopen for loading objects, which can then not be
retained in saved images
"
ac_help="$ac_help
@@ -751,6 +753,15 @@
fi
+# Check whether --enable-xgcl or --disable-xgcl was given.
+if test "${enable_xgcl+set}" = set; then
+ enableval="$enable_xgcl"
+ enable_xgcl=$enableval
+else
+ enable_xgcl="yes"
+fi
+
+
#
# Host information
#
@@ -782,7 +793,7 @@
fi
echo $ac_n "checking host system type""... $ac_c" 1>&6
-echo "configure:786: checking host system type" >&5
+echo "configure:797: checking host system type" >&5
host_alias=$host
case "$host_alias" in
@@ -1195,7 +1206,7 @@
# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:1199: checking for $ac_word" >&5
+echo "configure:1210: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -1225,7 +1236,7 @@
# Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:1229: checking for $ac_word" >&5
+echo "configure:1240: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -1276,7 +1287,7 @@
# Extract the first word of "cl", so it can be a program name with args.
set dummy cl; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:1280: checking for $ac_word" >&5
+echo "configure:1291: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -1308,7 +1319,7 @@
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""...
$ac_c" 1>&6
-echo "configure:1312: checking whether the C compiler ($CC $CFLAGS $LDFLAGS)
works" >&5
+echo "configure:1323: checking whether the C compiler ($CC $CFLAGS $LDFLAGS)
works" >&5
ac_ext=c
# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
@@ -1319,12 +1330,12 @@
cat > conftest.$ac_ext << EOF
-#line 1323 "configure"
+#line 1334 "configure"
#include "confdefs.h"
main(){return(0);}
EOF
-if { (eval echo configure:1328: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:1339: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
ac_cv_prog_cc_works=yes
# If we can't run a trivial program, we are probably using a cross compiler.
if (./conftest; exit) 2>/dev/null; then
@@ -1350,12 +1361,12 @@
{ echo "configure: error: installation or configuration problem: C compiler
cannot create executables." 1>&2; exit 1; }
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a
cross-compiler""... $ac_c" 1>&6
-echo "configure:1354: checking whether the C compiler ($CC $CFLAGS $LDFLAGS)
is a cross-compiler" >&5
+echo "configure:1365: checking whether the C compiler ($CC $CFLAGS $LDFLAGS)
is a cross-compiler" >&5
echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6
cross_compiling=$ac_cv_prog_cc_cross
echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
-echo "configure:1359: checking whether we are using GNU C" >&5
+echo "configure:1370: checking whether we are using GNU C" >&5
if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -1364,7 +1375,7 @@
yes;
#endif
EOF
-if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1368:
\"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
+if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1379:
\"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
ac_cv_prog_gcc=yes
else
ac_cv_prog_gcc=no
@@ -1383,7 +1394,7 @@
ac_save_CFLAGS="$CFLAGS"
CFLAGS=
echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
-echo "configure:1387: checking whether ${CC-cc} accepts -g" >&5
+echo "configure:1398: checking whether ${CC-cc} accepts -g" >&5
if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -1415,7 +1426,7 @@
fi
echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
-echo "configure:1419: checking how to run the C preprocessor" >&5
+echo "configure:1430: checking how to run the C preprocessor" >&5
# On Suns, sometimes $CPP names a directory.
if test -n "$CPP" && test -d "$CPP"; then
CPP=
@@ -1430,13 +1441,13 @@
# On the NeXT, cc -E runs the code through the compiler's parser,
# not just through cpp.
cat > conftest.$ac_ext <<EOF
-#line 1434 "configure"
+#line 1445 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1440: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1451: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
@@ -1447,13 +1458,13 @@
rm -rf conftest*
CPP="${CC-cc} -E -traditional-cpp"
cat > conftest.$ac_ext <<EOF
-#line 1451 "configure"
+#line 1462 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1457: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1468: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
@@ -1464,13 +1475,13 @@
rm -rf conftest*
CPP="${CC-cc} -nologo -E"
cat > conftest.$ac_ext <<EOF
-#line 1468 "configure"
+#line 1479 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1474: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1485: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
@@ -1543,7 +1554,7 @@
# Extract the first word of "$ac_prog", so it can be a program name with args.
set dummy $ac_prog; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:1547: checking for $ac_word" >&5
+echo "configure:1558: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_AWK'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -1583,7 +1594,7 @@
EOF
echo $ac_n "checking for text start""... $ac_c" 1>&6
-echo "configure:1587: checking for text start" >&5
+echo "configure:1598: checking for text start" >&5
echo 'int main () {return(0);}' >foo.c
$CC foo.c -o foo
GCL_GPROF_START=`nm foo | $AWK '/ *T *__*start$/ {print $NF}'`
@@ -1659,7 +1670,7 @@
# there are a few systems, like Next, where this doesn't work.
echo $ac_n "checking system version (for dynamic loading)""... $ac_c" 1>&6
-echo "configure:1663: checking system version (for dynamic loading)" >&5
+echo "configure:1674: checking system version (for dynamic loading)" >&5
if machine=`uname -m` ; then true; else machine=unknown ; fi
for ac_prog in makeinfo
@@ -1667,7 +1678,7 @@
# Extract the first word of "$ac_prog", so it can be a program name with args.
set dummy $ac_prog; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:1671: checking for $ac_word" >&5
+echo "configure:1682: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_MAKEINFO'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -1724,17 +1735,17 @@
ac_safe=`echo "unistd.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for unistd.h""... $ac_c" 1>&6
-echo "configure:1728: checking for unistd.h" >&5
+echo "configure:1739: checking for unistd.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1733 "configure"
+#line 1744 "configure"
#include "confdefs.h"
#include <unistd.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1738: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1749: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -1751,7 +1762,7 @@
if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
echo "$ac_t""yes" 1>&6
echo $ac_n "checking for sysconf in -lc""... $ac_c" 1>&6
-echo "configure:1755: checking for sysconf in -lc" >&5
+echo "configure:1766: checking for sysconf in -lc" >&5
ac_lib_var=`echo c'_'sysconf | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -1759,7 +1770,7 @@
ac_save_LIBS="$LIBS"
LIBS="-lc $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 1763 "configure"
+#line 1774 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@@ -1770,7 +1781,7 @@
sysconf()
; return 0; }
EOF
-if { (eval echo configure:1774: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:1785: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -1786,12 +1797,12 @@
if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
echo "$ac_t""yes" 1>&6
echo $ac_n "checking "for _SC_CLK_TCK"""... $ac_c" 1>&6
-echo "configure:1790: checking "for _SC_CLK_TCK"" >&5
+echo "configure:1801: checking "for _SC_CLK_TCK"" >&5
if test "$cross_compiling" = yes; then
hz=0
else
cat > conftest.$ac_ext <<EOF
-#line 1795 "configure"
+#line 1806 "configure"
#include "confdefs.h"
#include <unistd.h>
#include <stdio.h>
@@ -1803,7 +1814,7 @@
return 0;
}
EOF
-if { (eval echo configure:1807: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:1818: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
hz=`cat conftest1`
cat >> confdefs.h <<EOF
@@ -1847,17 +1858,17 @@
if test "$enable_dynsysgmp" = "yes" ; then
ac_safe=`echo "gmp.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for gmp.h""... $ac_c" 1>&6
-echo "configure:1851: checking for gmp.h" >&5
+echo "configure:1862: checking for gmp.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1856 "configure"
+#line 1867 "configure"
#include "confdefs.h"
#include <gmp.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1861: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1872: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -1874,7 +1885,7 @@
if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
echo "$ac_t""yes" 1>&6
echo $ac_n "checking for __gmpz_init in -lgmp""... $ac_c" 1>&6
-echo "configure:1878: checking for __gmpz_init in -lgmp" >&5
+echo "configure:1889: checking for __gmpz_init in -lgmp" >&5
ac_lib_var=`echo gmp'_'__gmpz_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -1882,7 +1893,7 @@
ac_save_LIBS="$LIBS"
LIBS="-lgmp $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 1886 "configure"
+#line 1897 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@@ -1893,7 +1904,7 @@
__gmpz_init()
; return 0; }
EOF
-if { (eval echo configure:1897: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:1908: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -1909,12 +1920,12 @@
if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
echo "$ac_t""yes" 1>&6
echo $ac_n "checking "for external gmp version"""... $ac_c" 1>&6
-echo "configure:1913: checking "for external gmp version"" >&5
+echo "configure:1924: checking "for external gmp version"" >&5
if test "$cross_compiling" = yes; then
echo "Cannot use dynamic gmp lib"
else
cat > conftest.$ac_ext <<EOF
-#line 1918 "configure"
+#line 1929 "configure"
#include "confdefs.h"
#include <gmp.h>
int main() {
@@ -1925,7 +1936,7 @@
#endif
}
EOF
-if { (eval echo configure:1929: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:1940: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
# MPFILES=$GMPDIR/mpn/mul_n.o
# PATCHED_SYMBOLS=__gmpn_toom3_mul_n
@@ -1972,7 +1983,7 @@
if test "$NEED_LOCAL_GMP" != "" ; then
echo $ac_n "checking use_gmp=yes, doing configure in gmp
directory""... $ac_c" 1>&6
-echo "configure:1976: checking use_gmp=yes, doing configure in gmp directory"
>&5
+echo "configure:1987: checking use_gmp=yes, doing configure in gmp directory"
>&5
echo
echo "#"
echo "#"
@@ -2004,7 +2015,7 @@
fi
echo $ac_n "checking "for leading underscore in object symbols"""... $ac_c"
1>&6
-echo "configure:2008: checking "for leading underscore in object symbols"" >&5
+echo "configure:2019: checking "for leading underscore in object symbols"" >&5
cat>foo.c <<EOFF
#include <math.h>
#include <stdio.h>
@@ -2023,7 +2034,7 @@
echo "$ac_t"""no"" 1>&6
fi
echo $ac_n "checking "for GNU ld option -Map"""... $ac_c" 1>&6
-echo "configure:2027: checking "for GNU ld option -Map"" >&5
+echo "configure:2038: checking "for GNU ld option -Map"" >&5
touch map
$CC -o foo -Wl,-Map map foo.o >/dev/null 2>&1
if test `cat map | wc -l` != "0" ; then
@@ -2040,12 +2051,12 @@
rm -f foo.c foo.o foo map
echo $ac_n "checking "for size of gmp limbs"""... $ac_c" 1>&6
-echo "configure:2044: checking "for size of gmp limbs"" >&5
+echo "configure:2055: checking "for size of gmp limbs"" >&5
if test "$cross_compiling" = yes; then
mpsize=0
else
cat > conftest.$ac_ext <<EOF
-#line 2049 "configure"
+#line 2060 "configure"
#include "confdefs.h"
#include <stdio.h>
#include "$MP_INCLUDE"
@@ -2056,7 +2067,7 @@
return 0;
}
EOF
-if { (eval echo configure:2060: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:2071: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
mpsize=`cat conftest1`
else
@@ -2079,12 +2090,12 @@
echo "$ac_t""$mpsize" 1>&6
echo $ac_n "checking "_SHORT_LIMB"""... $ac_c" 1>&6
-echo "configure:2083: checking "_SHORT_LIMB"" >&5
+echo "configure:2094: checking "_SHORT_LIMB"" >&5
if test "$cross_compiling" = yes; then
echo "$ac_t""no" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2088 "configure"
+#line 2099 "configure"
#include "confdefs.h"
#include <stdio.h>
#include "$MP_INCLUDE"
@@ -2096,7 +2107,7 @@
#endif
}
EOF
-if { (eval echo configure:2100: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:2111: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
cat >> confdefs.h <<\EOF
#define __SHORT_LIMB 1
@@ -2112,12 +2123,12 @@
fi
echo $ac_n "checking "_LONG_LONG_LIMB"""... $ac_c" 1>&6
-echo "configure:2116: checking "_LONG_LONG_LIMB"" >&5
+echo "configure:2127: checking "_LONG_LONG_LIMB"" >&5
if test "$cross_compiling" = yes; then
echo "$ac_t""no" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2121 "configure"
+#line 2132 "configure"
#include "confdefs.h"
#include <stdio.h>
#include "$MP_INCLUDE"
@@ -2129,7 +2140,7 @@
#endif
}
EOF
-if { (eval echo configure:2133: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:2144: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
cat >> confdefs.h <<\EOF
#define __LONG_LONG_LIMB 1
@@ -2163,12 +2174,14 @@
# X windows
#
-# If we find X, set shell vars x_includes and x_libraries to the
+if test "$enable_xgcl" = "yes" ; then
+
+ # If we find X, set shell vars x_includes and x_libraries to the
# paths, otherwise set no_x=yes.
# Uses ac_ vars as temps to allow command line to override cache and checks.
# --without-x overrides everything else, but does not touch the cache.
echo $ac_n "checking for X""... $ac_c" 1>&6
-echo "configure:2172: checking for X" >&5
+echo "configure:2185: checking for X" >&5
# Check whether --with-x or --without-x was given.
if test "${with_x+set}" = set; then
@@ -2230,12 +2243,12 @@
# First, try using that file with no special directory specified.
cat > conftest.$ac_ext <<EOF
-#line 2234 "configure"
+#line 2247 "configure"
#include "confdefs.h"
#include <$x_direct_test_include>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:2239: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:2252: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -2304,14 +2317,14 @@
ac_save_LIBS="$LIBS"
LIBS="-l$x_direct_test_library $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 2308 "configure"
+#line 2321 "configure"
#include "confdefs.h"
int main() {
${x_direct_test_function}()
; return 0; }
EOF
-if { (eval echo configure:2315: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:2328: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
LIBS="$ac_save_LIBS"
# We can link X programs with no special library path.
@@ -2417,17 +2430,17 @@
case "`(uname -sr) 2>/dev/null`" in
"SunOS 5"*)
echo $ac_n "checking whether -R must be followed by a space""... $ac_c"
1>&6
-echo "configure:2421: checking whether -R must be followed by a space" >&5
+echo "configure:2434: checking whether -R must be followed by a space" >&5
ac_xsave_LIBS="$LIBS"; LIBS="$LIBS -R$x_libraries"
cat > conftest.$ac_ext <<EOF
-#line 2424 "configure"
+#line 2437 "configure"
#include "confdefs.h"
int main() {
; return 0; }
EOF
-if { (eval echo configure:2431: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:2444: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
ac_R_nospace=yes
else
@@ -2443,14 +2456,14 @@
else
LIBS="$ac_xsave_LIBS -R $x_libraries"
cat > conftest.$ac_ext <<EOF
-#line 2447 "configure"
+#line 2460 "configure"
#include "confdefs.h"
int main() {
; return 0; }
EOF
-if { (eval echo configure:2454: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:2467: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
ac_R_space=yes
else
@@ -2482,7 +2495,7 @@
# libraries were built with DECnet support. And address@hidden says
# the Alpha needs dnet_stub (dnet does not exist).
echo $ac_n "checking for dnet_ntoa in -ldnet""... $ac_c" 1>&6
-echo "configure:2486: checking for dnet_ntoa in -ldnet" >&5
+echo "configure:2499: checking for dnet_ntoa in -ldnet" >&5
ac_lib_var=`echo dnet'_'dnet_ntoa | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -2490,7 +2503,7 @@
ac_save_LIBS="$LIBS"
LIBS="-ldnet $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 2494 "configure"
+#line 2507 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@@ -2501,7 +2514,7 @@
dnet_ntoa()
; return 0; }
EOF
-if { (eval echo configure:2505: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:2518: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -2523,7 +2536,7 @@
if test $ac_cv_lib_dnet_dnet_ntoa = no; then
echo $ac_n "checking for dnet_ntoa in -ldnet_stub""... $ac_c" 1>&6
-echo "configure:2527: checking for dnet_ntoa in -ldnet_stub" >&5
+echo "configure:2540: checking for dnet_ntoa in -ldnet_stub" >&5
ac_lib_var=`echo dnet_stub'_'dnet_ntoa | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -2531,7 +2544,7 @@
ac_save_LIBS="$LIBS"
LIBS="-ldnet_stub $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 2535 "configure"
+#line 2548 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@@ -2542,7 +2555,7 @@
dnet_ntoa()
; return 0; }
EOF
-if { (eval echo configure:2546: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:2559: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -2571,12 +2584,12 @@
# The nsl library prevents programs from opening the X display
# on Irix 5.2, according to address@hidden
echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6
-echo "configure:2575: checking for gethostbyname" >&5
+echo "configure:2588: checking for gethostbyname" >&5
if eval "test \"`echo '$''{'ac_cv_func_gethostbyname'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2580 "configure"
+#line 2593 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char gethostbyname(); below. */
@@ -2599,7 +2612,7 @@
; return 0; }
EOF
-if { (eval echo configure:2603: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:2616: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_gethostbyname=yes"
else
@@ -2620,7 +2633,7 @@
if test $ac_cv_func_gethostbyname = no; then
echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6
-echo "configure:2624: checking for gethostbyname in -lnsl" >&5
+echo "configure:2637: checking for gethostbyname in -lnsl" >&5
ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -2628,7 +2641,7 @@
ac_save_LIBS="$LIBS"
LIBS="-lnsl $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 2632 "configure"
+#line 2645 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@@ -2639,7 +2652,7 @@
gethostbyname()
; return 0; }
EOF
-if { (eval echo configure:2643: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:2656: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -2669,12 +2682,12 @@
# -lsocket must be given before -lnsl if both are needed.
# We assume that if connect needs -lnsl, so does gethostbyname.
echo $ac_n "checking for connect""... $ac_c" 1>&6
-echo "configure:2673: checking for connect" >&5
+echo "configure:2686: checking for connect" >&5
if eval "test \"`echo '$''{'ac_cv_func_connect'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2678 "configure"
+#line 2691 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char connect(); below. */
@@ -2697,7 +2710,7 @@
; return 0; }
EOF
-if { (eval echo configure:2701: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:2714: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_connect=yes"
else
@@ -2718,7 +2731,7 @@
if test $ac_cv_func_connect = no; then
echo $ac_n "checking for connect in -lsocket""... $ac_c" 1>&6
-echo "configure:2722: checking for connect in -lsocket" >&5
+echo "configure:2735: checking for connect in -lsocket" >&5
ac_lib_var=`echo socket'_'connect | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -2726,7 +2739,7 @@
ac_save_LIBS="$LIBS"
LIBS="-lsocket $X_EXTRA_LIBS $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 2730 "configure"
+#line 2743 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@@ -2737,7 +2750,7 @@
connect()
; return 0; }
EOF
-if { (eval echo configure:2741: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:2754: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -2761,12 +2774,12 @@
# address@hidden says -lposix is necessary on A/UX.
echo $ac_n "checking for remove""... $ac_c" 1>&6
-echo "configure:2765: checking for remove" >&5
+echo "configure:2778: checking for remove" >&5
if eval "test \"`echo '$''{'ac_cv_func_remove'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2770 "configure"
+#line 2783 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char remove(); below. */
@@ -2789,7 +2802,7 @@
; return 0; }
EOF
-if { (eval echo configure:2793: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:2806: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_remove=yes"
else
@@ -2810,7 +2823,7 @@
if test $ac_cv_func_remove = no; then
echo $ac_n "checking for remove in -lposix""... $ac_c" 1>&6
-echo "configure:2814: checking for remove in -lposix" >&5
+echo "configure:2827: checking for remove in -lposix" >&5
ac_lib_var=`echo posix'_'remove | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -2818,7 +2831,7 @@
ac_save_LIBS="$LIBS"
LIBS="-lposix $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 2822 "configure"
+#line 2835 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@@ -2829,7 +2842,7 @@
remove()
; return 0; }
EOF
-if { (eval echo configure:2833: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:2846: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -2853,12 +2866,12 @@
# BSDI BSD/OS 2.1 needs -lipc for XOpenDisplay.
echo $ac_n "checking for shmat""... $ac_c" 1>&6
-echo "configure:2857: checking for shmat" >&5
+echo "configure:2870: checking for shmat" >&5
if eval "test \"`echo '$''{'ac_cv_func_shmat'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2862 "configure"
+#line 2875 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char shmat(); below. */
@@ -2881,7 +2894,7 @@
; return 0; }
EOF
-if { (eval echo configure:2885: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:2898: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_shmat=yes"
else
@@ -2902,7 +2915,7 @@
if test $ac_cv_func_shmat = no; then
echo $ac_n "checking for shmat in -lipc""... $ac_c" 1>&6
-echo "configure:2906: checking for shmat in -lipc" >&5
+echo "configure:2919: checking for shmat in -lipc" >&5
ac_lib_var=`echo ipc'_'shmat | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -2910,7 +2923,7 @@
ac_save_LIBS="$LIBS"
LIBS="-lipc $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 2914 "configure"
+#line 2927 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@@ -2921,7 +2934,7 @@
shmat()
; return 0; }
EOF
-if { (eval echo configure:2925: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:2938: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -2954,7 +2967,7 @@
# libraries we check for below, so use a different variable.
# address@hidden, address@hidden
echo $ac_n "checking for IceConnectionNumber in -lICE""... $ac_c" 1>&6
-echo "configure:2958: checking for IceConnectionNumber in -lICE" >&5
+echo "configure:2971: checking for IceConnectionNumber in -lICE" >&5
ac_lib_var=`echo ICE'_'IceConnectionNumber | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -2962,7 +2975,7 @@
ac_save_LIBS="$LIBS"
LIBS="-lICE $X_EXTRA_LIBS $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 2966 "configure"
+#line 2979 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@@ -2973,7 +2986,7 @@
IceConnectionNumber()
; return 0; }
EOF
-if { (eval echo configure:2977: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:2990: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -2997,14 +3010,14 @@
fi
-echo $X_CFLAGS
-echo $X_LIBS
-echo $X_EXTRA_LIBS
-echo $X_PRE_LIBS
-
-miss=0
-echo $ac_n "checking for main in -lXmu""... $ac_c" 1>&6
-echo "configure:3008: checking for main in -lXmu" >&5
+ echo $X_CFLAGS
+ echo $X_LIBS
+ echo $X_EXTRA_LIBS
+ echo $X_PRE_LIBS
+
+ miss=0
+ echo $ac_n "checking for main in -lXmu""... $ac_c" 1>&6
+echo "configure:3021: checking for main in -lXmu" >&5
ac_lib_var=`echo Xmu'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -3012,14 +3025,14 @@
ac_save_LIBS="$LIBS"
LIBS="-lXmu $X_LIBS $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3016 "configure"
+#line 3029 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
-if { (eval echo configure:3023: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:3036: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -3040,8 +3053,8 @@
miss=1
fi
-echo $ac_n "checking for main in -lXt""... $ac_c" 1>&6
-echo "configure:3045: checking for main in -lXt" >&5
+ echo $ac_n "checking for main in -lXt""... $ac_c" 1>&6
+echo "configure:3058: checking for main in -lXt" >&5
ac_lib_var=`echo Xt'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -3049,14 +3062,14 @@
ac_save_LIBS="$LIBS"
LIBS="-lXt $X_LIBS $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3053 "configure"
+#line 3066 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
-if { (eval echo configure:3060: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:3073: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -3077,8 +3090,8 @@
miss=1
fi
-echo $ac_n "checking for main in -lXext""... $ac_c" 1>&6
-echo "configure:3082: checking for main in -lXext" >&5
+ echo $ac_n "checking for main in -lXext""... $ac_c" 1>&6
+echo "configure:3095: checking for main in -lXext" >&5
ac_lib_var=`echo Xext'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -3086,14 +3099,14 @@
ac_save_LIBS="$LIBS"
LIBS="-lXext $X_LIBS $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3090 "configure"
+#line 3103 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
-if { (eval echo configure:3097: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:3110: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -3114,23 +3127,23 @@
miss=1
fi
-echo $ac_n "checking for main in -lXaw""... $ac_c" 1>&6
-echo "configure:3119: checking for main in -lXaw" >&5
-ac_lib_var=`echo Xaw'_'main | sed 'y%./+-%__p_%'`
+ echo $ac_n "checking for main in -lXaw6""... $ac_c" 1>&6
+echo "configure:3132: checking for main in -lXaw6" >&5
+ac_lib_var=`echo Xaw6'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
-LIBS="-lXaw $X_LIBS $LIBS"
+LIBS="-lXaw6 $X_LIBS $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3127 "configure"
+#line 3140 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
-if { (eval echo configure:3134: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:3147: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -3145,14 +3158,14 @@
fi
if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
echo "$ac_t""yes" 1>&6
- X_LIBS="$X_LIBS -lXaw"
+ X_LIBS="$X_LIBS -lXaw6"
else
echo "$ac_t""no" 1>&6
miss=1
fi
-echo $ac_n "checking for main in -lX11""... $ac_c" 1>&6
-echo "configure:3156: checking for main in -lX11" >&5
+ echo $ac_n "checking for main in -lX11""... $ac_c" 1>&6
+echo "configure:3169: checking for main in -lX11" >&5
ac_lib_var=`echo X11'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -3160,14 +3173,14 @@
ac_save_LIBS="$LIBS"
LIBS="-lX11 $X_LIBS $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3164 "configure"
+#line 3177 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
-if { (eval echo configure:3171: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:3184: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -3189,10 +3202,16 @@
fi
-if test "$miss" = "1" ; then
+ if test "$miss" = "1" ; then
X_CFLAGS=
X_LIBS=
echo missing x libraries -- cannot compile xgcl
+ else
+ cat >> confdefs.h <<\EOF
+#define HAVE_XGCL 1
+EOF
+
+ fi
fi
@@ -3206,7 +3225,7 @@
if test "$enable_dlopen" = "yes" ; then
echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6
-echo "configure:3210: checking for dlopen in -ldl" >&5
+echo "configure:3229: checking for dlopen in -ldl" >&5
ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -3214,7 +3233,7 @@
ac_save_LIBS="$LIBS"
LIBS="-ldl $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3218 "configure"
+#line 3237 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@@ -3225,7 +3244,7 @@
dlopen()
; return 0; }
EOF
-if { (eval echo configure:3229: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:3248: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -3261,17 +3280,17 @@
if test "$enable_statsysbfd" = "yes" || test "$enable_dynsysbfd" = "yes" ; then
ac_safe=`echo "bfd.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for bfd.h""... $ac_c" 1>&6
-echo "configure:3265: checking for bfd.h" >&5
+echo "configure:3284: checking for bfd.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3270 "configure"
+#line 3289 "configure"
#include "confdefs.h"
#include <bfd.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:3275: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:3294: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -3288,7 +3307,7 @@
if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
echo "$ac_t""yes" 1>&6
echo $ac_n "checking for bfd_init in -lbfd""... $ac_c" 1>&6
-echo "configure:3292: checking for bfd_init in -lbfd" >&5
+echo "configure:3311: checking for bfd_init in -lbfd" >&5
ac_lib_var=`echo bfd'_'bfd_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -3296,7 +3315,7 @@
ac_save_LIBS="$LIBS"
LIBS="-lbfd -liberty $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 3300 "configure"
+#line 3319 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@@ -3307,7 +3326,7 @@
bfd_init()
; return 0; }
EOF
-if { (eval echo configure:3311: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:3330: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -3326,18 +3345,18 @@
# Old binutils appear to need CONST defined to const
#
echo $ac_n "checking if need to define CONST for
bfd""... $ac_c" 1>&6
-echo "configure:3330: checking if need to define CONST for bfd" >&5
+echo "configure:3349: checking if need to define CONST for bfd" >&5
if test "$cross_compiling" = yes; then
echo "$ac_t""cannot use bfd" 1>&6 exit 1;
else
cat > conftest.$ac_ext <<EOF
-#line 3335 "configure"
+#line 3354 "configure"
#include "confdefs.h"
#define IN_GCC
#include <bfd.h>
int main() { symbol_info t; return 0;}
EOF
-if { (eval echo configure:3341: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3360: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
echo "$ac_t""no" 1>&6
else
@@ -3348,14 +3367,14 @@
echo "$ac_t""cannot use bfd" 1>&6 exit 1;
else
cat > conftest.$ac_ext <<EOF
-#line 3352 "configure"
+#line 3371 "configure"
#include "confdefs.h"
#define CONST const
#define IN_GCC
#include <bfd.h>
int main() {symbol_info t; return
0;}
EOF
-if { (eval echo configure:3359: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3378: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
echo "$ac_t""yes" 1>&6
cat >> confdefs.h <<\EOF
@@ -3395,19 +3414,19 @@
#
echo $ac_n "checking for useable bfd_boolean""... $ac_c" 1>&6
-echo "configure:3399: checking for useable bfd_boolean" >&5
+echo "configure:3418: checking for useable bfd_boolean" >&5
if test "$cross_compiling" = yes; then
echo "$ac_t""no" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3404 "configure"
+#line 3423 "configure"
#include "confdefs.h"
#define IN_GCC
#include <bfd.h>
bfd_boolean foo() {return FALSE;}
int main() {return 0;}
EOF
-if { (eval echo configure:3411: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3430: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
echo "$ac_t""yes" 1>&6
cat >> confdefs.h <<\EOF
@@ -3515,7 +3534,7 @@
# addresses, in calculating a page for an address in the heap.
echo $ac_n "checking size of long""... $ac_c" 1>&6
-echo "configure:3519: checking size of long" >&5
+echo "configure:3538: checking size of long" >&5
if eval "test \"`echo '$''{'ac_cv_sizeof_long'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -3523,7 +3542,7 @@
ac_cv_sizeof_long=0
else
cat > conftest.$ac_ext <<EOF
-#line 3527 "configure"
+#line 3546 "configure"
#include "confdefs.h"
#include <stdio.h>
#include <sys/types.h>
@@ -3535,7 +3554,7 @@
exit(0);
}
EOF
-if { (eval echo configure:3539: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3558: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
ac_cv_sizeof_long=`cat conftestval`
else
@@ -3555,7 +3574,7 @@
echo $ac_n "checking sizeof struct contblock""... $ac_c" 1>&6
-echo "configure:3559: checking sizeof struct contblock" >&5
+echo "configure:3578: checking sizeof struct contblock" >&5
# work around MSYS pwd result incompatibility
if test "$use" = "mingw" ; then
@@ -3563,7 +3582,7 @@
echo Cannot find sizeof struct contblock;exit 1
else
cat > conftest.$ac_ext <<EOF
-#line 3567 "configure"
+#line 3586 "configure"
#include "confdefs.h"
#include <stdio.h>
#define EXTER
@@ -3577,7 +3596,7 @@
return 0;
}
EOF
-if { (eval echo configure:3581: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3600: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
sizeof_contblock=`cat conftest1`
else
@@ -3594,7 +3613,7 @@
echo Cannot find sizeof struct contblock;exit 1
else
cat > conftest.$ac_ext <<EOF
-#line 3598 "configure"
+#line 3617 "configure"
#include "confdefs.h"
#include <stdio.h>
#define EXTER
@@ -3608,7 +3627,7 @@
return 0;
}
EOF
-if { (eval echo configure:3612: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3631: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
sizeof_contblock=`cat conftest1`
else
@@ -3633,17 +3652,17 @@
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:3637: checking for $ac_hdr" >&5
+echo "configure:3656: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3642 "configure"
+#line 3661 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:3647: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:3666: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -3664,18 +3683,18 @@
#define $ac_tr_hdr 1
EOF
echo $ac_n "checking "endianness"""... $ac_c" 1>&6
-echo "configure:3668: checking "endianness"" >&5
+echo "configure:3687: checking "endianness"" >&5
if test "$cross_compiling" = yes; then
echo "$ac_t""big" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3673 "configure"
+#line 3692 "configure"
#include "confdefs.h"
#define __ARMEB__
#include <endian.h>
int main() { return BYTE_ORDER == __LITTLE_ENDIAN ? 0 : 1;}
EOF
-if { (eval echo configure:3679: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3698: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
cat >> confdefs.h <<\EOF
#define LITTLE_END 1
@@ -3702,13 +3721,13 @@
# this and restore the traditional behavior here
echo $ac_n "checking for sbrk""... $ac_c" 1>&6
-echo "configure:3706: checking for sbrk" >&5
+echo "configure:3725: checking for sbrk" >&5
HAVE_SBRK=""
if test "$cross_compiling" = yes; then
echo "$ac_t""no: WARNING you must be able to emulate sbrk: as on mingw or
macosx" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3712 "configure"
+#line 3731 "configure"
#include "confdefs.h"
#include <unistd.h>
#include <stdio.h>
@@ -3720,7 +3739,7 @@
return 0;
}
EOF
-if { (eval echo configure:3724: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3743: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
HAVE_SBRK=1
echo "$ac_t""yes" 1>&6
@@ -3736,12 +3755,12 @@
if test "$HAVE_SBRK" = "1" ; then
echo $ac_n "checking for randomized sbrk""... $ac_c" 1>&6
-echo "configure:3740: checking for randomized sbrk" >&5
+echo "configure:3759: checking for randomized sbrk" >&5
if test "$cross_compiling" = yes; then
SBRK=0
else
cat > conftest.$ac_ext <<EOF
-#line 3745 "configure"
+#line 3764 "configure"
#include "confdefs.h"
#include <unistd.h>
#include <stdio.h>
@@ -3753,7 +3772,7 @@
return 0;
}
EOF
-if { (eval echo configure:3757: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3776: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
SBRK=`cat conftest1`
else
@@ -3773,7 +3792,7 @@
SBRK1=0
else
cat > conftest.$ac_ext <<EOF
-#line 3777 "configure"
+#line 3796 "configure"
#include "confdefs.h"
#include <unistd.h>
#include <stdio.h>
@@ -3785,7 +3804,7 @@
return 0;
}
EOF
-if { (eval echo configure:3789: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3808: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
SBRK1=`cat conftest1`
else
@@ -3832,21 +3851,21 @@
EOF
echo $ac_n "checking for ADDR_NO_RANOMIZE constant""... $ac_c"
1>&6
-echo "configure:3836: checking for ADDR_NO_RANOMIZE constant" >&5
+echo "configure:3855: checking for ADDR_NO_RANOMIZE constant" >&5
echo "$ac_t""$ADDR_NO_RANDOMIZE" 1>&6
ac_safe=`echo "sys/personality.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for sys/personality.h""... $ac_c" 1>&6
-echo "configure:3840: checking for sys/personality.h" >&5
+echo "configure:3859: checking for sys/personality.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3845 "configure"
+#line 3864 "configure"
#include "confdefs.h"
#include <sys/personality.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:3850: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:3869: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -3872,7 +3891,7 @@
SBRK=0
else
cat > conftest.$ac_ext <<EOF
-#line 3876 "configure"
+#line 3895 "configure"
#include "confdefs.h"
#include <syscall.h>
#include <sys/personality.h>
@@ -3892,7 +3911,7 @@
return 0;
}
EOF
-if { (eval echo configure:3896: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3915: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
SBRK=`cat conftest1`
else
@@ -3912,7 +3931,7 @@
SBRK1=0
else
cat > conftest.$ac_ext <<EOF
-#line 3916 "configure"
+#line 3935 "configure"
#include "confdefs.h"
#include <syscall.h>
#include <sys/personality.h>
@@ -3932,7 +3951,7 @@
return 0;
}
EOF
-if { (eval echo configure:3936: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3955: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
SBRK1=`cat conftest1`
else
@@ -3949,7 +3968,7 @@
exit 1
fi
echo $ac_n "checking for randomized brk remedy""... $ac_c" 1>&6
-echo "configure:3953: checking for randomized brk remedy" >&5
+echo "configure:3972: checking for randomized brk remedy" >&5
if test "$SBRK" = "$SBRK1" ; then
echo "$ac_t""yes" 1>&6
cat >> confdefs.h <<\EOF
@@ -3970,12 +3989,12 @@
old_LDFLAGS="$LDFLAGS"
LDFLAGS="$TLDFLAGS"
echo $ac_n "checking "finding DBEGIN"""... $ac_c" 1>&6
-echo "configure:3974: checking "finding DBEGIN"" >&5
+echo "configure:3993: checking "finding DBEGIN"" >&5
if test "$cross_compiling" = yes; then
dbegin=0
else
cat > conftest.$ac_ext <<EOF
-#line 3979 "configure"
+#line 3998 "configure"
#include "confdefs.h"
#include <stdio.h>
#include <stdlib.h>
@@ -4013,7 +4032,7 @@
return 0;
}
EOF
-if { (eval echo configure:4017: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:4036: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
dbegin=`cat conftest1`
else
@@ -4036,12 +4055,12 @@
echo $ac_n "checking "finding CSTACK_ADDRESS"""... $ac_c" 1>&6
-echo "configure:4040: checking "finding CSTACK_ADDRESS"" >&5
+echo "configure:4059: checking "finding CSTACK_ADDRESS"" >&5
if test "$cross_compiling" = yes; then
cstack_address=0
else
cat > conftest.$ac_ext <<EOF
-#line 4045 "configure"
+#line 4064 "configure"
#include "confdefs.h"
#include <stdio.h>
main()
@@ -4053,7 +4072,7 @@
return 0;
}
EOF
-if { (eval echo configure:4057: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:4076: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
cstack_address=`cat conftest1`
else
@@ -4075,13 +4094,13 @@
echo $ac_n "checking "sizeof long long int"""... $ac_c" 1>&6
-echo "configure:4079: checking "sizeof long long int"" >&5
+echo "configure:4098: checking "sizeof long long int"" >&5
if test "$cross_compiling" = yes; then
echo "$ac_t""no" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4085 "configure"
+#line 4104 "configure"
#include "confdefs.h"
#include <stdio.h>
main()
@@ -4091,7 +4110,7 @@
}
EOF
-if { (eval echo configure:4095: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:4114: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
cat >> confdefs.h <<\EOF
#define HAVE_LONG_LONG 1
@@ -4149,12 +4168,12 @@
# pagewidth
echo $ac_n "checking for pagewidth""... $ac_c" 1>&6
-echo "configure:4153: checking for pagewidth" >&5
+echo "configure:4172: checking for pagewidth" >&5
if test "$cross_compiling" = yes; then
PAGEWIDTH=0
else
cat > conftest.$ac_ext <<EOF
-#line 4158 "configure"
+#line 4177 "configure"
#include "confdefs.h"
#include <stdio.h>
#include <unistd.h>
@@ -4165,7 +4184,7 @@
fprintf(fp,"%u",j);
return 0;}
EOF
-if { (eval echo configure:4169: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:4188: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
PAGEWIDTH=`cat conftest1`
else
@@ -4192,12 +4211,12 @@
for ac_func in getcwd
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:4196: checking for $ac_func" >&5
+echo "configure:4215: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4201 "configure"
+#line 4220 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
@@ -4220,7 +4239,7 @@
; return 0; }
EOF
-if { (eval echo configure:4224: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:4243: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
@@ -4247,12 +4266,12 @@
for ac_func in getwd
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:4251: checking for $ac_func" >&5
+echo "configure:4270: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4256 "configure"
+#line 4275 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
@@ -4275,7 +4294,7 @@
; return 0; }
EOF
-if { (eval echo configure:4279: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:4298: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
@@ -4300,12 +4319,12 @@
done
echo $ac_n "checking for uname""... $ac_c" 1>&6
-echo "configure:4304: checking for uname" >&5
+echo "configure:4323: checking for uname" >&5
if eval "test \"`echo '$''{'ac_cv_func_uname'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4309 "configure"
+#line 4328 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char uname(); below. */
@@ -4328,7 +4347,7 @@
; return 0; }
EOF
-if { (eval echo configure:4332: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:4351: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_uname=yes"
else
@@ -4352,12 +4371,12 @@
fi
echo $ac_n "checking for gettimeofday""... $ac_c" 1>&6
-echo "configure:4356: checking for gettimeofday" >&5
+echo "configure:4375: checking for gettimeofday" >&5
if eval "test \"`echo '$''{'ac_cv_func_gettimeofday'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4361 "configure"
+#line 4380 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char gettimeofday(); below. */
@@ -4380,7 +4399,7 @@
; return 0; }
EOF
-if { (eval echo configure:4384: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:4403: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_gettimeofday=yes"
else
@@ -4409,17 +4428,17 @@
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:4413: checking for $ac_hdr" >&5
+echo "configure:4432: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4418 "configure"
+#line 4437 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:4423: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:4442: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -4451,17 +4470,17 @@
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:4455: checking for $ac_hdr" >&5
+echo "configure:4474: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4460 "configure"
+#line 4479 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:4465: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:4484: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -4501,12 +4520,12 @@
#--------------------------------------------------------------------
echo $ac_n "checking for BSDgettimeofday""... $ac_c" 1>&6
-echo "configure:4505: checking for BSDgettimeofday" >&5
+echo "configure:4524: checking for BSDgettimeofday" >&5
if eval "test \"`echo '$''{'ac_cv_func_BSDgettimeofday'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4510 "configure"
+#line 4529 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char BSDgettimeofday(); below. */
@@ -4529,7 +4548,7 @@
; return 0; }
EOF
-if { (eval echo configure:4533: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:4552: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_BSDgettimeofday=yes"
else
@@ -4550,12 +4569,12 @@
else
echo "$ac_t""no" 1>&6
echo $ac_n "checking for gettimeofday""... $ac_c" 1>&6
-echo "configure:4554: checking for gettimeofday" >&5
+echo "configure:4573: checking for gettimeofday" >&5
if eval "test \"`echo '$''{'ac_cv_func_gettimeofday'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4559 "configure"
+#line 4578 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char gettimeofday(); below. */
@@ -4578,7 +4597,7 @@
; return 0; }
EOF
-if { (eval echo configure:4582: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:4601: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_gettimeofday=yes"
else
@@ -4605,10 +4624,10 @@
echo $ac_n "checking for gettimeofday declaration""... $ac_c" 1>&6
-echo "configure:4609: checking for gettimeofday declaration" >&5
+echo "configure:4628: checking for gettimeofday declaration" >&5
cat > conftest.$ac_ext <<EOF
-#line 4612 "configure"
+#line 4631 "configure"
#include "confdefs.h"
#include <sys/time.h>
EOF
@@ -4629,7 +4648,7 @@
echo $ac_n "checking for sin in -lm""... $ac_c" 1>&6
-echo "configure:4633: checking for sin in -lm" >&5
+echo "configure:4652: checking for sin in -lm" >&5
ac_lib_var=`echo m'_'sin | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -4637,7 +4656,7 @@
ac_save_LIBS="$LIBS"
LIBS="-lm $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 4641 "configure"
+#line 4660 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@@ -4648,7 +4667,7 @@
sin()
; return 0; }
EOF
-if { (eval echo configure:4652: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:4671: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -4670,7 +4689,7 @@
fi
echo $ac_n "checking for main in -lmingwex""... $ac_c" 1>&6
-echo "configure:4674: checking for main in -lmingwex" >&5
+echo "configure:4693: checking for main in -lmingwex" >&5
ac_lib_var=`echo mingwex'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -4678,14 +4697,14 @@
ac_save_LIBS="$LIBS"
LIBS="-lmingwex $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 4682 "configure"
+#line 4701 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
-if { (eval echo configure:4689: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:4708: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -4713,17 +4732,17 @@
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:4717: checking for $ac_hdr" >&5
+echo "configure:4736: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4722 "configure"
+#line 4741 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:4727: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:4746: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -4761,17 +4780,17 @@
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:4765: checking for $ac_hdr" >&5
+echo "configure:4784: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4770 "configure"
+#line 4789 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:4775: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:4794: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -4808,17 +4827,17 @@
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:4812: checking for $ac_hdr" >&5
+echo "configure:4831: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4817 "configure"
+#line 4836 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:4822: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:4841: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -4858,17 +4877,17 @@
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:4862: checking for $ac_hdr" >&5
+echo "configure:4881: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4867 "configure"
+#line 4886 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:4872: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:4891: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -4905,17 +4924,17 @@
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:4909: checking for $ac_hdr" >&5
+echo "configure:4928: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4914 "configure"
+#line 4933 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:4919: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:4938: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -4952,17 +4971,17 @@
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:4956: checking for $ac_hdr" >&5
+echo "configure:4975: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4961 "configure"
+#line 4980 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:4966: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:4985: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -4998,12 +5017,12 @@
# test makes sense. CM
#
echo $ac_n "checking for isnormal""... $ac_c" 1>&6
-echo "configure:5002: checking for isnormal" >&5
+echo "configure:5021: checking for isnormal" >&5
if test "$cross_compiling" = yes; then
HAVE_ISNORMAL=0 echo "$ac_t""no" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5007 "configure"
+#line 5026 "configure"
#include "confdefs.h"
#define _GNU_SOURCE
#include <math.h>
@@ -5012,7 +5031,7 @@
return isnormal(f) || !isnormal(f) ? 0 : 1;
}
EOF
-if { (eval echo configure:5016: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:5035: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
cat >> confdefs.h <<\EOF
#define HAVE_ISNORMAL 1
@@ -5023,12 +5042,12 @@
cat conftest.$ac_ext >&5
rm -fr conftest*
echo $ac_n "checking for fpclass in ieeefp.h""... $ac_c" 1>&6
-echo "configure:5027: checking for fpclass in ieeefp.h" >&5
+echo "configure:5046: checking for fpclass in ieeefp.h" >&5
if test "$cross_compiling" = yes; then
HAVE_IEEEFP=0 echo "$ac_t""no" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5032 "configure"
+#line 5051 "configure"
#include "confdefs.h"
#include <ieeefp.h>
int main() {
@@ -5036,7 +5055,7 @@
return fpclass(f)>=FP_NZERO ||
fpclass(f)<FP_NZERO ? 0 : 1;
}
EOF
-if { (eval echo configure:5040: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:5059: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
cat >> confdefs.h <<\EOF
#define HAVE_IEEEFP 1
@@ -5058,12 +5077,12 @@
echo $ac_n "checking for isfinite""... $ac_c" 1>&6
-echo "configure:5062: checking for isfinite" >&5
+echo "configure:5081: checking for isfinite" >&5
if test "$cross_compiling" = yes; then
HAVE_ISFINITE=0 echo "$ac_t""no" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5067 "configure"
+#line 5086 "configure"
#include "confdefs.h"
#define _GNU_SOURCE
#include <math.h>
@@ -5072,7 +5091,7 @@
return isfinite(f) || !isfinite(f) ? 0 : 1;
}
EOF
-if { (eval echo configure:5076: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:5095: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
cat >> confdefs.h <<\EOF
#define HAVE_ISFINITE 1
@@ -5083,12 +5102,12 @@
cat conftest.$ac_ext >&5
rm -fr conftest*
echo $ac_n "checking for finite()""... $ac_c" 1>&6
-echo "configure:5087: checking for finite()" >&5
+echo "configure:5106: checking for finite()" >&5
if test "$cross_compiling" = yes; then
HAVE_FINITE=0 echo "$ac_t""no" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5092 "configure"
+#line 5111 "configure"
#include "confdefs.h"
#include <math.h>
#include <ieeefp.h>
@@ -5097,7 +5116,7 @@
return finite(f) || !finite(f) ? 0 : 1;
}
EOF
-if { (eval echo configure:5101: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:5120: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
cat >> confdefs.h <<\EOF
#define HAVE_FINITE 1
@@ -5138,15 +5157,15 @@
# if -lsocket doesn't work by itself.
#--------------------------------------------------------------------
echo $ac_n "checking for sockets""... $ac_c" 1>&6
-echo "configure:5142: checking for sockets" >&5
+echo "configure:5161: checking for sockets" >&5
tcl_checkBoth=0
echo $ac_n "checking for connect""... $ac_c" 1>&6
-echo "configure:5145: checking for connect" >&5
+echo "configure:5164: checking for connect" >&5
if eval "test \"`echo '$''{'ac_cv_func_connect'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5150 "configure"
+#line 5169 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char connect(); below. */
@@ -5169,7 +5188,7 @@
; return 0; }
EOF
-if { (eval echo configure:5173: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:5192: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_connect=yes"
else
@@ -5191,7 +5210,7 @@
if test "$tcl_checkSocket" = 1; then
echo $ac_n "checking for main in -lsocket""... $ac_c" 1>&6
-echo "configure:5195: checking for main in -lsocket" >&5
+echo "configure:5214: checking for main in -lsocket" >&5
ac_lib_var=`echo socket'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -5199,14 +5218,14 @@
ac_save_LIBS="$LIBS"
LIBS="-lsocket $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 5203 "configure"
+#line 5222 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
-if { (eval echo configure:5210: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:5229: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -5234,12 +5253,12 @@
tk_oldLibs=$TLIBS
TLIBS="$TLIBS -lsocket -lnsl"
echo $ac_n "checking for accept""... $ac_c" 1>&6
-echo "configure:5238: checking for accept" >&5
+echo "configure:5257: checking for accept" >&5
if eval "test \"`echo '$''{'ac_cv_func_accept'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5243 "configure"
+#line 5262 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char accept(); below. */
@@ -5262,7 +5281,7 @@
; return 0; }
EOF
-if { (eval echo configure:5266: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:5285: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_accept=yes"
else
@@ -5284,12 +5303,12 @@
fi
echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6
-echo "configure:5288: checking for gethostbyname" >&5
+echo "configure:5307: checking for gethostbyname" >&5
if eval "test \"`echo '$''{'ac_cv_func_gethostbyname'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5293 "configure"
+#line 5312 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char gethostbyname(); below. */
@@ -5312,7 +5331,7 @@
; return 0; }
EOF
-if { (eval echo configure:5316: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:5335: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_gethostbyname=yes"
else
@@ -5330,7 +5349,7 @@
else
echo "$ac_t""no" 1>&6
echo $ac_n "checking for main in -lnsl""... $ac_c" 1>&6
-echo "configure:5334: checking for main in -lnsl" >&5
+echo "configure:5353: checking for main in -lnsl" >&5
ac_lib_var=`echo nsl'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -5338,14 +5357,14 @@
ac_save_LIBS="$LIBS"
LIBS="-lnsl $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 5342 "configure"
+#line 5361 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
-if { (eval echo configure:5349: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:5368: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -5375,17 +5394,17 @@
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:5379: checking for $ac_hdr" >&5
+echo "configure:5398: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5384 "configure"
+#line 5403 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:5389: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:5408: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -5406,7 +5425,7 @@
#define $ac_tr_hdr 1
EOF
echo $ac_n "checking for main in -lreadline""... $ac_c" 1>&6
-echo "configure:5410: checking for main in -lreadline" >&5
+echo "configure:5429: checking for main in -lreadline" >&5
ac_lib_var=`echo readline'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -5414,14 +5433,14 @@
ac_save_LIBS="$LIBS"
LIBS="-lreadline -lncurses $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 5418 "configure"
+#line 5437 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
-if { (eval echo configure:5425: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:5444: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -5458,7 +5477,7 @@
# These tests discover differences between readline 4.1 and 4.3
echo $ac_n "checking for rl_completion_matches in -lreadline""...
$ac_c" 1>&6
-echo "configure:5462: checking for rl_completion_matches in -lreadline" >&5
+echo "configure:5481: checking for rl_completion_matches in -lreadline" >&5
ac_lib_var=`echo readline'_'rl_completion_matches | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -5466,7 +5485,7 @@
ac_save_LIBS="$LIBS"
LIBS="-lreadline $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 5470 "configure"
+#line 5489 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@@ -5477,7 +5496,7 @@
rl_completion_matches()
; return 0; }
EOF
-if { (eval echo configure:5481: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:5500: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -5510,9 +5529,9 @@
echo $ac_n "checking For network code for nsocket.c""... $ac_c" 1>&6
-echo "configure:5514: checking For network code for nsocket.c" >&5
+echo "configure:5533: checking For network code for nsocket.c" >&5
cat > conftest.$ac_ext <<EOF
-#line 5516 "configure"
+#line 5535 "configure"
#include "confdefs.h"
#include <sys/time.h>
@@ -5539,7 +5558,7 @@
; return 0; }
EOF
-if { (eval echo configure:5543: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:5562: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
cat >> confdefs.h <<\EOF
#define HAVE_NSOCKET 1
@@ -5556,9 +5575,9 @@
echo $ac_n "checking check for listen using fcntl""... $ac_c" 1>&6
-echo "configure:5560: checking check for listen using fcntl" >&5
+echo "configure:5579: checking check for listen using fcntl" >&5
cat > conftest.$ac_ext <<EOF
-#line 5562 "configure"
+#line 5581 "configure"
#include "confdefs.h"
#include <stdio.h>
#include <fcntl.h>
@@ -5571,7 +5590,7 @@
; return 0; }
EOF
-if { (eval echo configure:5575: \"$ac_compile\") 1>&5; (eval $ac_compile)
2>&5; }; then
+if { (eval echo configure:5594: \"$ac_compile\") 1>&5; (eval $ac_compile)
2>&5; }; then
rm -rf conftest*
cat >> confdefs.h <<\EOF
#define LISTEN_USE_FCNTL 1
@@ -5590,12 +5609,12 @@
echo $ac_n "checking for profil""... $ac_c" 1>&6
-echo "configure:5594: checking for profil" >&5
+echo "configure:5613: checking for profil" >&5
if eval "test \"`echo '$''{'ac_cv_func_profil'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5599 "configure"
+#line 5618 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char profil(); below. */
@@ -5618,7 +5637,7 @@
; return 0; }
EOF
-if { (eval echo configure:5622: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:5641: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_profil=yes"
else
@@ -5643,12 +5662,12 @@
echo $ac_n "checking for setenv""... $ac_c" 1>&6
-echo "configure:5647: checking for setenv" >&5
+echo "configure:5666: checking for setenv" >&5
if eval "test \"`echo '$''{'ac_cv_func_setenv'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5652 "configure"
+#line 5671 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char setenv(); below. */
@@ -5671,7 +5690,7 @@
; return 0; }
EOF
-if { (eval echo configure:5675: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:5694: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_setenv=yes"
else
@@ -5697,12 +5716,12 @@
if test "$no_setenv" = "1" ; then
echo $ac_n "checking for putenv""... $ac_c" 1>&6
-echo "configure:5701: checking for putenv" >&5
+echo "configure:5720: checking for putenv" >&5
if eval "test \"`echo '$''{'ac_cv_func_putenv'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5706 "configure"
+#line 5725 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char putenv(); below. */
@@ -5725,7 +5744,7 @@
; return 0; }
EOF
-if { (eval echo configure:5729: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:5748: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_putenv=yes"
else
@@ -5751,12 +5770,12 @@
fi
echo $ac_n "checking for _cleanup""... $ac_c" 1>&6
-echo "configure:5755: checking for _cleanup" >&5
+echo "configure:5774: checking for _cleanup" >&5
if eval "test \"`echo '$''{'ac_cv_func__cleanup'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5760 "configure"
+#line 5779 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char _cleanup(); below. */
@@ -5779,7 +5798,7 @@
; return 0; }
EOF
-if { (eval echo configure:5783: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:5802: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func__cleanup=yes"
else
@@ -5805,7 +5824,7 @@
gcl_ok=no
cat > conftest.$ac_ext <<EOF
-#line 5809 "configure"
+#line 5828 "configure"
#include "confdefs.h"
#include <ctype.h>
EOF
@@ -5833,7 +5852,7 @@
# if test "x$enable_machine" = "x" ; then
echo $ac_n "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O""... $ac_c"
1>&6
-echo "configure:5837: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5
+echo "configure:5856: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5
case $system in
OSF*)
@@ -5864,9 +5883,9 @@
echo $ac_n "checking check for SV_ONSTACK""... $ac_c" 1>&6
-echo "configure:5868: checking check for SV_ONSTACK" >&5
+echo "configure:5887: checking check for SV_ONSTACK" >&5
cat > conftest.$ac_ext <<EOF
-#line 5870 "configure"
+#line 5889 "configure"
#include "confdefs.h"
#include <signal.h>
int joe=SV_ONSTACK;
@@ -5875,7 +5894,7 @@
; return 0; }
EOF
-if { (eval echo configure:5879: \"$ac_compile\") 1>&5; (eval $ac_compile)
2>&5; }; then
+if { (eval echo configure:5898: \"$ac_compile\") 1>&5; (eval $ac_compile)
2>&5; }; then
rm -rf conftest*
cat >> confdefs.h <<\EOF
#define HAVE_SV_ONSTACK 1
@@ -5892,9 +5911,9 @@
rm -f conftest*
echo $ac_n "checking check for SIGSYS""... $ac_c" 1>&6
-echo "configure:5896: checking check for SIGSYS" >&5
+echo "configure:5915: checking check for SIGSYS" >&5
cat > conftest.$ac_ext <<EOF
-#line 5898 "configure"
+#line 5917 "configure"
#include "confdefs.h"
#include <signal.h>
int joe=SIGSYS;
@@ -5903,7 +5922,7 @@
; return 0; }
EOF
-if { (eval echo configure:5907: \"$ac_compile\") 1>&5; (eval $ac_compile)
2>&5; }; then
+if { (eval echo configure:5926: \"$ac_compile\") 1>&5; (eval $ac_compile)
2>&5; }; then
rm -rf conftest*
cat >> confdefs.h <<\EOF
#define HAVE_SIGSYS 1
@@ -5921,9 +5940,9 @@
echo $ac_n "checking check for SIGEMT""... $ac_c" 1>&6
-echo "configure:5925: checking check for SIGEMT" >&5
+echo "configure:5944: checking check for SIGEMT" >&5
cat > conftest.$ac_ext <<EOF
-#line 5927 "configure"
+#line 5946 "configure"
#include "confdefs.h"
#include <signal.h>
int joe=SIGEMT;
@@ -5932,7 +5951,7 @@
; return 0; }
EOF
-if { (eval echo configure:5936: \"$ac_compile\") 1>&5; (eval $ac_compile)
2>&5; }; then
+if { (eval echo configure:5955: \"$ac_compile\") 1>&5; (eval $ac_compile)
2>&5; }; then
rm -rf conftest*
cat >> confdefs.h <<\EOF
#define HAVE_SIGEMT 1
@@ -5956,17 +5975,17 @@
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:5960: checking for $ac_hdr" >&5
+echo "configure:5979: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5965 "configure"
+#line 5984 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:5970: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:5989: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -5996,17 +6015,17 @@
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:6000: checking for $ac_hdr" >&5
+echo "configure:6019: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 6005 "configure"
+#line 6024 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:6010: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:6029: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -6033,9 +6052,9 @@
done
echo $ac_n "checking for sigcontext...""... $ac_c" 1>&6
-echo "configure:6037: checking for sigcontext..." >&5
+echo "configure:6056: checking for sigcontext..." >&5
cat > conftest.$ac_ext <<EOF
-#line 6039 "configure"
+#line 6058 "configure"
#include "confdefs.h"
#include <signal.h>
@@ -6045,7 +6064,7 @@
; return 0; }
EOF
-if { (eval echo configure:6049: \"$ac_compile\") 1>&5; (eval $ac_compile)
2>&5; }; then
+if { (eval echo configure:6068: \"$ac_compile\") 1>&5; (eval $ac_compile)
2>&5; }; then
rm -rf conftest*
sigcontext_works=1;
@@ -6066,9 +6085,9 @@
rm -f conftest*
if test "$sigcontext_works" = 0 ; then
echo $ac_n "checking for sigcontext...""... $ac_c" 1>&6
-echo "configure:6070: checking for sigcontext..." >&5
+echo "configure:6089: checking for sigcontext..." >&5
cat > conftest.$ac_ext <<EOF
-#line 6072 "configure"
+#line 6091 "configure"
#include "confdefs.h"
#include <signal.h>
#ifdef HAVE_ASM_SIGCONTEXT_H
@@ -6084,7 +6103,7 @@
; return 0; }
EOF
-if { (eval echo configure:6088: \"$ac_compile\") 1>&5; (eval $ac_compile)
2>&5; }; then
+if { (eval echo configure:6107: \"$ac_compile\") 1>&5; (eval $ac_compile)
2>&5; }; then
rm -rf conftest*
cat >> confdefs.h <<\EOF
@@ -6126,7 +6145,7 @@
# Extract the first word of "emacs", so it can be a program name with args.
set dummy emacs; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:6130: checking for $ac_word" >&5
+echo "configure:6149: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_path_EMACS'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -6174,7 +6193,7 @@
EOF
echo $ac_n "checking emacs site lisp directory""... $ac_c" 1>&6
-echo "configure:6178: checking emacs site lisp directory" >&5
+echo "configure:6197: checking emacs site lisp directory" >&5
if [ "$EMACS_SITE_LISP" = "unknown" ] ; then
if [ "$EMACS" != "" ] ; then
EMACS_SITE_LISP=`$EMACS -q -batch --no-site-file -l conftest.el
2>&1 | grep -v ^Warning: | sed -e /Loading/d | sed -e /load/d `
@@ -6198,7 +6217,7 @@
EOF
echo $ac_n "checking emacs default.el""... $ac_c" 1>&6
-echo "configure:6202: checking emacs default.el" >&5
+echo "configure:6221: checking emacs default.el" >&5
if [ "$EMACS" != "" ] ; then
EMACS_DEFAULT_EL=`$EMACS -q -batch --no-site-file -l conftest.el 2>&1 |
sed -e /Loading/d | sed -e /load/d `
else
@@ -6227,7 +6246,7 @@
EOF
echo $ac_n "checking emacs info/dir""... $ac_c" 1>&6
-echo "configure:6231: checking emacs info/dir" >&5
+echo "configure:6250: checking emacs info/dir" >&5
if test "$use" = "mingw" ; then
INFO_DIR=\$\(prefix\)/lib/gcl-$VERSION/info/
else
@@ -6245,7 +6264,7 @@
echo $ac_n "checking for tcl/tk""... $ac_c" 1>&6
-echo "configure:6249: checking for tcl/tk" >&5
+echo "configure:6268: checking for tcl/tk" >&5
if test -d "${TCL_CONFIG_PREFIX}" ; then true ; else
@@ -6268,7 +6287,7 @@
# Extract the first word of "tclsh", so it can be a program name with args.
set dummy tclsh; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:6272: checking for $ac_word" >&5
+echo "configure:6291: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_TCLSH'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -6368,7 +6387,7 @@
fi
fi
echo $ac_n "checking for main in -llieee""... $ac_c" 1>&6
-echo "configure:6372: checking for main in -llieee" >&5
+echo "configure:6391: checking for main in -llieee" >&5
ac_lib_var=`echo lieee'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -6376,14 +6395,14 @@
ac_save_LIBS="$LIBS"
LIBS="-llieee $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 6380 "configure"
+#line 6399 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
-if { (eval echo configure:6387: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
+if { (eval echo configure:6406: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -6448,16 +6467,16 @@
# the time handling for unixtime, add timezone
echo $ac_n "checking alloca""... $ac_c" 1>&6
-echo "configure:6452: checking alloca" >&5
+echo "configure:6471: checking alloca" >&5
if test "$cross_compiling" = yes; then
gcl_ok=no
else
cat > conftest.$ac_ext <<EOF
-#line 6457 "configure"
+#line 6476 "configure"
#include "confdefs.h"
int main() { exit(alloca(500) != NULL ? 0 : 1);}
EOF
-if { (eval echo configure:6461: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:6480: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
:
else
@@ -6480,12 +6499,12 @@
gcl_ok=no
else
cat > conftest.$ac_ext <<EOF
-#line 6484 "configure"
+#line 6503 "configure"
#include "confdefs.h"
#include <alloca.h>
int main() { exit(alloca(500) != NULL ? 0 : 1)}
EOF
-if { (eval echo configure:6489: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:6508: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } &&
test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
:
else
@@ -6546,7 +6565,7 @@
# redhat/cygnus released for some reason a buggy version of gcc,
# which no one else released. Catch that here.
echo $ac_n "checking Checking for buggy gcc version from redhat""... $ac_c"
1>&6
-echo "configure:6550: checking Checking for buggy gcc version from redhat" >&5
+echo "configure:6569: checking Checking for buggy gcc version from redhat" >&5
if 2>&1 $CC -v | fgrep "gcc version 2.96" > /dev/null
then
BROKEN_O4_OPT=1
Index: configure.in
===================================================================
RCS file: /cvsroot/gcl/gcl/configure.in,v
retrieving revision 1.112.4.1.2.2.2.47.2.3.2.1.4.2.4.2.4.12
retrieving revision 1.112.4.1.2.2.2.47.2.3.2.1.4.2.4.2.4.13
diff -u -b -r1.112.4.1.2.2.2.47.2.3.2.1.4.2.4.2.4.12
-r1.112.4.1.2.2.2.47.2.3.2.1.4.2.4.2.4.13
--- configure.in 9 Jan 2006 19:54:33 -0000
1.112.4.1.2.2.2.47.2.3.2.1.4.2.4.2.4.12
+++ configure.in 9 Jun 2006 15:53:31 -0000
1.112.4.1.2.2.2.47.2.3.2.1.4.2.4.2.4.13
@@ -64,6 +64,9 @@
AC_ARG_ENABLE(xdr,[ --enable-xdr=yes will compile in support for XDR],
[try_xdr=$enableval],[try_xdr="no"])
+AC_ARG_ENABLE(xgcl,[ --enable-xgcl=yes will compile in support for XGCL],
+[enable_xgcl=$enableval],[enable_xgcl="yes"])
+
#
# Host information
#
@@ -731,23 +734,28 @@
# X windows
#
-AC_PATH_XTRA
-echo $X_CFLAGS
-echo $X_LIBS
-echo $X_EXTRA_LIBS
-echo $X_PRE_LIBS
-
-miss=0
-AC_CHECK_LIB(Xmu,main,X_LIBS="$X_LIBS -lXmu",miss=1,$X_LIBS)
-AC_CHECK_LIB(Xt,main,X_LIBS="$X_LIBS -lXt",miss=1,$X_LIBS)
-AC_CHECK_LIB(Xext,main,X_LIBS="$X_LIBS -lXext",miss=1,$X_LIBS)
-AC_CHECK_LIB(Xaw,main,X_LIBS="$X_LIBS -lXaw",miss=1,$X_LIBS)
-AC_CHECK_LIB(X11,main,X_LIBS="$X_LIBS -lX11",miss=1,$X_LIBS)
+if test "$enable_xgcl" = "yes" ; then
+
+ AC_PATH_XTRA
+ echo $X_CFLAGS
+ echo $X_LIBS
+ echo $X_EXTRA_LIBS
+ echo $X_PRE_LIBS
+
+ miss=0
+ AC_CHECK_LIB(Xmu,main,X_LIBS="$X_LIBS -lXmu",miss=1,$X_LIBS)
+ AC_CHECK_LIB(Xt,main,X_LIBS="$X_LIBS -lXt",miss=1,$X_LIBS)
+ AC_CHECK_LIB(Xext,main,X_LIBS="$X_LIBS -lXext",miss=1,$X_LIBS)
+ AC_CHECK_LIB(Xaw6,main,X_LIBS="$X_LIBS -lXaw6",miss=1,$X_LIBS)
+ AC_CHECK_LIB(X11,main,X_LIBS="$X_LIBS -lX11",miss=1,$X_LIBS)
-if test "$miss" = "1" ; then
+ if test "$miss" = "1" ; then
X_CFLAGS=
X_LIBS=
echo missing x libraries -- cannot compile xgcl
+ else
+ AC_DEFINE(HAVE_XGCL)
+ fi
fi
Index: makefile
===================================================================
RCS file: /cvsroot/gcl/gcl/makefile,v
retrieving revision 1.73.4.2.2.21.6.1.8.3
retrieving revision 1.73.4.2.2.21.6.1.8.4
diff -u -b -r1.73.4.2.2.21.6.1.8.3 -r1.73.4.2.2.21.6.1.8.4
--- makefile 5 Jan 2006 16:47:03 -0000 1.73.4.2.2.21.6.1.8.3
+++ makefile 9 Jun 2006 15:53:31 -0000 1.73.4.2.2.21.6.1.8.4
@@ -34,7 +34,11 @@
VERSION=`cat majvers`.`cat minvers`
-all: $(BUILD_BFD) $(PORTDIR)/$(FLISP) command cmpnew/gcl_collectfn.o
lsp/gcl_info.o do-gcl-tk do-info
+all: $(BUILD_BFD) system command cmpnew/gcl_collectfn.o lsp/gcl_info.o
do-gcl-tk do-info
+
+system: $(PORTDIR)/$(FLISP)
+ [ "$X_LIBS" == "" ] || cd xgcl-2 && make saved_xgcl LISP=../$< && mv
saved_xgcl ../$(PORTDIR)/$(FLISP)
+ touch $@
xgcl: $(PORTDIR)/saved_xgcl
@@ -129,7 +133,7 @@
merge:
$(CC) -o merge merge.c
-LISP_LIB=cmpnew/gcl_collectfn.o cmpnew/gcl_collectfn.lsp lsp/gcl_gprof.lsp
lsp/gcl_info.o lsp/gcl_profile.lsp lsp/gcl_export.lsp lsp/gcl_autoload.lsp
cmpnew/gcl_cmpmain.lsp cmpnew/gcl_cmpopt.lsp cmpnew/gcl_lfun_list.lsp
lsp/gcl_auto_new.lsp h/cmpinclude.h unixport/init_$(SYSTEM).lsp
unixport/lib$(SYSTEM).a unixport/libgclp.a gcl-tk/tk-package.lsp $(TK_LISP_LIB)
$(RL_LIB) $(FIRST_FILE) $(LAST_FILE) $(addsuffix /sys-proclaim.lisp,lsp cmpnew
pcl clcs)
+LISP_LIB=cmpnew/gcl_collectfn.o cmpnew/gcl_collectfn.lsp xgcl-2/gcl_dwtest.lsp
xgcl-2/gcl_dwtestcases.lsp lsp/gcl_gprof.lsp lsp/gcl_info.o lsp/gcl_profile.lsp
lsp/gcl_export.lsp lsp/gcl_autoload.lsp cmpnew/gcl_cmpmain.lsp
cmpnew/gcl_cmpopt.lsp cmpnew/gcl_lfun_list.lsp lsp/gcl_auto_new.lsp
h/cmpinclude.h unixport/init_$(SYSTEM).lsp unixport/lib$(SYSTEM).a
unixport/libgclp.a gcl-tk/tk-package.lsp $(TK_LISP_LIB) $(RL_LIB) $(FIRST_FILE)
$(LAST_FILE) $(addsuffix /sys-proclaim.lisp,lsp cmpnew pcl clcs)
install-command:
rm -f $(DESTDIR)$(prefix)/bin/gcl
@@ -193,6 +197,7 @@
# echo '(load "../tkl.o")(TK::GET-AUTOLOADS (directory "*.lisp"))' |
../../$(PORTDIR)/$(FLISP)$(EXE)) ; fi
if test "$(EMACS_SITE_LISP)" != "" ; then (cd elisp ; $(MAKE) install
DESTDIR=$(DESTDIR)) ; fi
if test "$(INFO_DIR)" != "unknown"; then (cd info ; $(MAKE) ; $(MAKE)
install DESTDIR=$(DESTDIR)) ; fi
+ if test "$(INFO_DIR)" != "unknown"; then (cd xgcl-2 ; $(MAKE) install
DESTDIR=$(DESTDIR)) ; fi
if gcc --version | grep -i mingw >/dev/null 2>&1 ; then cp
COPYING.LIB-2.0 readme-bin.mingw $(prefix) ; fi
if gcc --version | grep -i mingw >/dev/null 2>&1 ; then cp gcl.ico
$(prefix)/bin ; fi
if gcc --version | grep -i mingw >/dev/null 2>&1 ; then rm -rf
$(prefix)/install; mkdir $(prefix)/install ; cp windows/install.lsp
$(prefix)/install ; windows/instdos.sh windows/sysdir.bat
$(prefix)/bin/sysdir.bat ; fi
@@ -221,7 +226,7 @@
windows/install.lsp windows/sysdir.bat
rm -rf windows/Output
rm -f ansi-tests/test_results ansi-tests/gazonk*lsp
- rm -f config.log config.cache config.status tmpx $(PORTDIR)/gmon.out
machine
+ rm -f config.log config.cache config.status tmpx $(PORTDIR)/gmon.out
machine system
clean: gclclean
-(cd $(GMPDIR) ; $(MAKE) distclean)
Index: binutils/intl/Makefile.in
===================================================================
RCS file: /cvsroot/gcl/gcl/binutils/intl/Makefile.in,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -b -r1.1.2.1 -r1.1.2.2
--- binutils/intl/Makefile.in 30 Sep 2005 02:10:25 -0000 1.1.2.1
+++ binutils/intl/Makefile.in 9 Jun 2006 15:53:31 -0000 1.1.2.2
@@ -172,7 +172,7 @@
clean: mostlyclean
distclean: clean
- rm -f Makefile ID TAGS po2msg.sed po2tbl.sed libintl.h config.log
+ rm -f Makefile ID TAGS po2msg.sed po2tbl.sed libintl.h config.log
config.cache config.h config.status stamp-h
maintainer-clean: distclean
@echo "This command is intended for maintainers to use;"
Index: debian/changelog
===================================================================
RCS file: /cvsroot/gcl/gcl/debian/changelog,v
retrieving revision
1.220.2.1.4.1.2.1.2.1.2.2.2.1.2.19.2.207.2.23.2.11.2.14.2.13.4.7.2.22.2.43
retrieving revision
1.220.2.1.4.1.2.1.2.1.2.2.2.1.2.19.2.207.2.23.2.11.2.14.2.13.4.7.2.22.2.44
diff -u -b
-r1.220.2.1.4.1.2.1.2.1.2.2.2.1.2.19.2.207.2.23.2.11.2.14.2.13.4.7.2.22.2.43
-r1.220.2.1.4.1.2.1.2.1.2.2.2.1.2.19.2.207.2.23.2.11.2.14.2.13.4.7.2.22.2.44
--- debian/changelog 8 Jun 2006 18:38:09 -0000
1.220.2.1.4.1.2.1.2.1.2.2.2.1.2.19.2.207.2.23.2.11.2.14.2.13.4.7.2.22.2.43
+++ debian/changelog 9 Jun 2006 15:53:31 -0000
1.220.2.1.4.1.2.1.2.1.2.2.2.1.2.19.2.207.2.23.2.11.2.14.2.13.4.7.2.22.2.44
@@ -54,8 +54,9 @@
* updates for lsp/sys-proclaim
* fix read-char-no-hang
* string comparison functions are not predicates
+ * xgcl integration
- -- Camm Maguire <address@hidden> Thu, 8 Jun 2006 18:37:55 +0000
+ -- Camm Maguire <address@hidden> Fri, 9 Jun 2006 15:53:02 +0000
gcl (2.6.7-7) unstable; urgency=high
Index: debian/copyright
===================================================================
RCS file: /cvsroot/gcl/gcl/debian/copyright,v
retrieving revision 1.4
retrieving revision 1.4.20.1
diff -u -b -r1.4 -r1.4.20.1
--- debian/copyright 28 Feb 2003 00:03:35 -0000 1.4
+++ debian/copyright 9 Jun 2006 15:53:31 -0000 1.4.20.1
@@ -24,3 +24,41 @@
On Debian GNU/Linux systems, the complete text of the GNU Lesser General
Public License can be found in `/usr/share/common-licenses/LGPL'.
+The source under xgcl-2 is
+
+Copyright (c) 1995 Gordon S. Novak Jr., Hiep Huu Nguyen, William F. Schelter,
+and The University of Texas at Austin.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+and
+
+;;**********************************************************
+;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts,
+;;and the Massachusetts Institute of Technology, Cambridge, Massachusetts.
+
+;; All Rights Reserved
+
+;;Permission to use, copy, modify, and distribute this software and its
+;;documentation for any purpose and without fee is hereby granted,
+;;provided that the above copyright notice appear in all copies and that
+;;both that copyright notice and this permission notice appear in
+;;supporting documentation, and that the names of Digital or MIT not be
+;;used in advertising or publicity pertaining to distribution of the
+;;software without specific, written prior permission.
+
+;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+;;SOFTWARE.
+
+;;*****************************************************************
+
+On Debian GNU/Linux systems, the complete text of the GNU General
+Public License can be found in `/usr/share/common-licenses/GPL'.
Index: h/gclincl.h.in
===================================================================
RCS file: /cvsroot/gcl/gcl/h/gclincl.h.in,v
retrieving revision 1.27.6.10.8.1.4.1.4.3
retrieving revision 1.27.6.10.8.1.4.1.4.4
diff -u -b -r1.27.6.10.8.1.4.1.4.3 -r1.27.6.10.8.1.4.1.4.4
--- h/gclincl.h.in 15 Dec 2005 18:14:18 -0000 1.27.6.10.8.1.4.1.4.3
+++ h/gclincl.h.in 9 Jun 2006 15:53:31 -0000 1.27.6.10.8.1.4.1.4.4
@@ -207,6 +207,7 @@
#undef HZ
#undef ADDR_NO_RANDOMIZE
#undef LEADING_UNDERSCORE
+#undef HAVE_XGCL
/* The number of bytes in a long. */
#undef SIZEOF_LONG
Index: lsp/gcl_auto_new.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_auto_new.lsp,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.1.14.1
diff -u -b -r1.1.2.1 -r1.1.2.1.14.1
--- lsp/gcl_auto_new.lsp 14 Sep 2003 02:30:35 -0000 1.1.2.1
+++ lsp/gcl_auto_new.lsp 9 Jun 2006 15:53:31 -0000 1.1.2.1.14.1
@@ -198,8 +198,7 @@
(AUTOLOAD 'offer-choices '|tinfo|)
(AUTOLOAD 'tkconnect '|tkl|)
-
-
+(AUTOLOAD 'user::xgcl '|gcl_dwtest|)
;; the sun has a broken ypbind business, if one wants to save.
;; So to stop users from invoking this
Index: lsp/gcl_mislib.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_mislib.lsp,v
retrieving revision 1.1.2.5.2.1.4.1.8.1
retrieving revision 1.1.2.5.2.1.4.1.8.2
diff -u -b -r1.1.2.5.2.1.4.1.8.1 -r1.1.2.5.2.1.4.1.8.2
--- lsp/gcl_mislib.lsp 24 Feb 2006 21:06:07 -0000 1.1.2.5.2.1.4.1.8.1
+++ lsp/gcl_mislib.lsp 9 Jun 2006 15:53:31 -0000 1.1.2.5.2.1.4.1.8.2
@@ -122,7 +122,7 @@
(defun default-system-banner ()
(let (gpled-modules)
- (dolist (l '(:unexec :bfd :readline))
+ (dolist (l '(:unexec :bfd :readline :xgcl))
(when (member l *features*)
(push l gpled-modules)))
(format nil "GCL (GNU Common Lisp) ~a.~a.~a ~a ~a ~a~%~a~%~a
~a~%~a~%~a~%~%~a~%"
@@ -130,7 +130,7 @@
(if (member :ansi-cl *features*) "ANSI" "CLtL1")
(if (member :gprof *features*) "profiling" "")
(si::gcl-compile-time)
- "Source License: LGPL(gcl,gmp), GPL(unexec,bfd)"
+ "Source License: LGPL(gcl,gmp), GPL(unexec,bfd,xgcl)"
"Binary License: "
(if gpled-modules (format nil "GPL due to GPL'ed components: ~a"
gpled-modules)
"LGPL")
@@ -157,7 +157,7 @@
(setq si::*lib-directory* s)
(setq si::*system-directory* (si::string-concatenate s "unixport/"))
(let (nl)
- (dolist (l '("cmpnew/" "gcl-tk/" "lsp/"))
+ (dolist (l '("cmpnew/" "gcl-tk/" "lsp/" "xgcl-2/"))
(push (si::string-concatenate s l) nl))
(setq si::*load-path* nl))
nil)
Index: o/main.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/main.c,v
retrieving revision 1.26.4.1.2.21.6.1.4.1.2.2
retrieving revision 1.26.4.1.2.21.6.1.4.1.2.3
diff -u -b -r1.26.4.1.2.21.6.1.4.1.2.2 -r1.26.4.1.2.21.6.1.4.1.2.3
--- o/main.c 12 Oct 2005 23:13:06 -0000 1.26.4.1.2.21.6.1.4.1.2.2
+++ o/main.c 9 Jun 2006 15:53:31 -0000 1.26.4.1.2.21.6.1.4.1.2.3
@@ -1091,6 +1091,9 @@
#endif
#endif
ADD_FEATURE("UNEXEC");
+#ifdef HAVE_XGCL
+ ADD_FEATURE("XGCL");
+#endif
#ifdef HAVE_GNU_LD
ADD_FEATURE("GNU-LD");
Index: xgcl-2/dwdoc.tex
===================================================================
RCS file: /cvsroot/gcl/gcl/xgcl-2/dwdoc.tex,v
retrieving revision 1.1.1.1
retrieving revision 1.1.1.1.20.1
diff -u -b -r1.1.1.1 -r1.1.1.1.20.1
--- xgcl-2/dwdoc.tex 13 Aug 2002 03:24:30 -0000 1.1.1.1
+++ xgcl-2/dwdoc.tex 9 Jun 2006 15:53:31 -0000 1.1.1.1.20.1
@@ -1,5 +1,5 @@
% dwdoc.tex Gordon S. Novak Jr.
-% 08 Oct 92; 08 Oct 93; 16 Nov 94; 05 Jan 95
+% 08 Oct 92; 08 Oct 93; 16 Nov 94; 05 Jan 95; 25 Jan 06; 26 Jan 06
\documentstyle[12pt]{article}
\setlength{\oddsidemargin}{0 in}
@@ -12,17 +12,21 @@
\begin{document}
-\begin{center}\Large{{\bf Interface from GCL to X Windows}} \\
+\Large
+\begin{center} {\bf Interface from GCL to X Windows} \\ \end{center}
+
+\normalsize
\vspace*{0.1in}
+\begin{center}
\large{Gordon S. Novak Jr. \\
Department of Computer Sciences \\
University of Texas at Austin \\
Austin, TX 78712} \\
\end{center}
-Software copyright \copyright 1994 by Gordon S. Novak Jr. and
+Software copyright \copyright \/ by Gordon S. Novak Jr. and
The University of Texas at Austin. Distribution and use are allowed
under the Gnu Public License. Also see the copyright section at the end
of this document for the copyright on X Consortium software.
@@ -33,7 +37,7 @@
This document describes a relatively easy-to-use interface between
XGCL (X version of Gnu Common Lisp) and X windows. The interface
-consists of two parts:
+consists of several parts:
\begin{enumerate}
\item Hiep Huu Nguyen has written (and adapted from X Consortium software)
an interface between GCL and Xlib, the X library in C.
@@ -44,6 +48,9 @@
\item The {\tt dwindow} functions described in this document, which call
the Xlib functions and provide an easier interface for Lisp programs.
+
+\item It is possible to make an interactive graphical interface
+within a web page; this is described in a section below.
\end{enumerate}
The source file for the interface (written in GLISP) is
{\tt dwindow.lsp}; this file is compiled into a file in plain Lisp,
@@ -62,8 +69,8 @@
({\tt window} is a Lisp data structure used by the {\tt dwindow} functions).
Both the Xlib and {\tt dwindow} functions are in the package {\tt xlib:}.
-The file {\tt imports.lsp} may be used to import the {\tt dwindow} symbols
-to the {\tt :user} package.
+In order to use these functions, the Lisp command {\tt (use-package 'xlib)}
+should be used to import the {\tt dwindow} symbols.
\section{Examples and Utilities}
@@ -93,6 +100,16 @@
{\tt (draw-out file names)} will write definitions of drawings in the
list {\tt names} to the file {\tt file}.
+\subsection{{\tt editors}}
+
+The file {\tt editorstrans.lsp} contains some interactive editing programs;
+it is a translation of the file {\tt editors.lsp} .
+One useful editor is the color editor; after entering {\tt (wtesta)}
+(in file {\tt dwtest.lsp}), enter {\tt (edit-color myw)} to edit a
+color. The result is an {\tt rgb} list as used in {\tt window-set-color}.
+
+A simple line editor and an Emacs-like text editor are described in sections
+\ref{texted} and \ref{emacsed} below.
\section{Menus}
@@ -227,10 +244,10 @@
Each of the {\tt buttons} in a picmenu is a list: \\
\vspace{-0.1in}
-{\tt \hspace*{0.5in} (name offset size highlightfn unhighlightfn)} \\
+{\tt \hspace*{0.5in} (buttonname offset size highlightfn unhighlightfn)} \\
\vspace{-0.1in}
-{\tt name} is the name of the button; it is the value returned when that
+{\tt buttonname} is the name of the button; it is the value returned when that
button is selected.
{\tt offset} is a vector {\tt (x y)} that gives the offset of the center
of the button from the lower-left corner of the picture.
@@ -556,7 +573,7 @@
{\tt *window-xcolor*}, or the specified color.
-\subsection{Character Input}
+\subsection{Character Input} \label{texted}
Characters can be input within a window by the call:
@@ -572,6 +589,27 @@
{\tt size} (default 100) is erased to the right of the initial caret.
+\subsection{Emacs-like Editing} \label{emacsed}
+
+{\tt window-edit} allows editing of text using an Emacs-subset editor.
+Only a few simple Emacs commands are implemented.
+\begin{verbatim}
+ (window-edit w x y width height &optional strings boxflg scroll endp)
+\end{verbatim}
+{\tt x y width height} specify the offset and size of the editing
+area; it is a good idea to draw a box around this area first.
+{\tt strings} is an initial list of strings; the return value is a list
+of strings.
+{\tt scroll} is number of lines to scroll down before displaying text,
+ or {\tt T} to have one line only and terminate on return.
+{\tt endp} is {\tt T} to begin editing at the end of the first line.
+Example:
+\begin{verbatim}
+ (window-draw-box-xy myw 48 48 204 204)
+ (window-edit myw 50 50 200 200 '("Now is the time" "for all" "good"))
+\end{verbatim}
+
+
\section{Mouse Interaction}
{\tt \hspace*{0.5in} (window-get-point w)} \\
@@ -705,6 +743,22 @@
due to an error.
+\section{Examples}
+
+Several interactive programs using this software for their graphical
+interface can be found at {\tt http://www.cs.utexas.edu/users/novak/}
+under the heading Software Demos.
+
+
+\section{Web Interface}
+
+This software allows a Lisp program to be used interactively within
+a web page. There are two approaches, either using an X server on
+the computer of the person viewing the web page, or using WeirdX, a
+Java program that emulates an X server. Details can be found at:
+{\tt http://www.cs.utexas.edu/users/novak/dwindow.html}
+
+
\section{Files}
\begin{tabular}{ll}
@@ -713,13 +767,19 @@
{\tt drawtrans.lsp} & {\tt draw.lsp} translated into plain Lisp \\
{\tt draw-gates.lsp} & Code to draw {\tt nand} gates etc. \\
{\tt dwdoc.tex} & \LaTeX \ source for this document \\
+{\tt dwexports.lsp} & exported symbols \\
+{\tt dwimportsb.lsp} & imported symbols \\
{\tt dwindow.lsp} & GLISP source code for {\tt dwindow} functions \\
{\tt dwtest.lsp} & Examples of use of {\tt dwindow} functions \\
{\tt dwtrans.lsp} & {\tt dwindow.lsp} translated into plain Lisp \\
+{\tt editors.lsp} & Editors for colors etc. \\
+{\tt editorstrans.lsp} & translation of {\tt editors.lsp} \\
{\tt gnu.license} & GNU General Public License \\
{\tt ice-cream.lsp} & Drawing of an ice cream cone made with {\tt draw} \\
-{\tt imports.lsp} & file to import symbols to {\tt :user} package \\
+{\tt lispserver.lsp} & Example web demo: a Lisp server \\
+{\tt lispservertrans.lsp} & translation of {\tt lispserver.lsp} \\
{\tt menu-set.lsp} & GLISP source code for menu-set functions \\
+{\tt menu-settrans.lsp} & translation of {\tt menu-set.lsp} \\
{\tt pcalc.lsp} & Pocket calculator implemented as a {\tt picmenu} \\
\end{tabular}
@@ -786,7 +846,7 @@
\vspace*{-.2in}
\begin{verbatim}
-(picmenu-button (list (name symbol)
+(picmenu-button (list (buttonname symbol)
(offset vector)
(size vector)
(highlightfn anything)
Index: xgcl-2/gcl_X.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/xgcl-2/gcl_X.lsp,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -b -r1.1.2.1 -r1.1.2.2
--- xgcl-2/gcl_X.lsp 5 Jan 2006 17:55:35 -0000 1.1.2.1
+++ xgcl-2/gcl_X.lsp 9 Jun 2006 15:53:31 -0000 1.1.2.2
@@ -518,7 +518,7 @@
;; Polygon shapes
-(defconstant Complex 0 ) ;; paths may intersect
+;(defconstant Complex 0 ) ;; paths may intersect
(defconstant Nonconvex 1 ) ;; no paths intersect, but not convex
(defconstant Convex 2 ) ;; wholly convex
@@ -684,6 +684,6 @@
(defconstant MSBFirst 1)
-(defconstant NULL 0)
+;(defconstant NULL 0)
Index: xgcl-2/gcl_draw-gates.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/xgcl-2/gcl_draw-gates.lsp,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -b -r1.1.2.1 -r1.1.2.2
--- xgcl-2/gcl_draw-gates.lsp 5 Jan 2006 17:55:35 -0000 1.1.2.1
+++ xgcl-2/gcl_draw-gates.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.2
@@ -1,6 +1,6 @@
; draw-gates.lsp Gordon S. Novak Jr. 20 Oct 94
-; Copyright (c) 1994 Gordon S. Novak Jr. and The University of Texas at Austin.
+; Copyright (c) 1995 Gordon S. Novak Jr. and The University of Texas at Austin.
; See the file gnu.license .
@@ -21,8 +21,6 @@
; Written by: Gordon S. Novak Jr., Department of Computer Sciences,
; University of Texas at Austin 78712. address@hidden
-(in-package :user)
-
(defun draw-nand (w x y)
(window-draw-arc-xy w (+ x 24) (+ y 16) 16 16 -90 180)
(window-draw-circle-xy w (+ x 45) (+ y 16) 4)
Index: xgcl-2/gcl_draw.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/xgcl-2/gcl_draw.lsp,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -b -r1.1.2.1 -r1.1.2.2
--- xgcl-2/gcl_draw.lsp 5 Jan 2006 17:55:35 -0000 1.1.2.1
+++ xgcl-2/gcl_draw.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.2
@@ -1,10 +1,12 @@
-; draw.lsp Gordon S. Novak Jr. 11 Nov 94
+; draw.lsp Gordon S. Novak Jr. ; 05 Jan 04
; Functions to make drawings interactively
-; Copyright (c) 1994 Gordon S. Novak Jr. and The University of Texas at Austin.
+; Copyright (c) 2004 Gordon S. Novak Jr. and The University of Texas at Austin.
-; See the file gnu.license .
+; 11 Nov 94; 05 Jan 95; 15 Jan 98; 09 Feb 99; 04 Dec 00; 28 Feb 02
+
+; See the file gnu.license
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
@@ -34,8 +36,6 @@
; The small square in the drawing menu is a "button" for picture menus.
; If buttons are used, a picmenu-spec will be produced with the program.
-(in-package :user)
-
(defvar *draw-window* nil)
(defvar *draw-window-width* 600)
(defvar *draw-window-height* 600)
@@ -151,15 +151,15 @@
(radius ((max radiusx radiusy)))
(center (offset + size / 2))
(delta ((sqrt (abs (radiusx ^ 2 - radiusy ^ 2)))))
- (p1 ((if (radiusx > radiusy)
- then (a vector x = (x center) - delta
+ (p1 ((if (radiusx > radiusy) ; 05 Jan 04
+ (a vector x = (x center) - delta
y = (y center))
- else (a vector x = (x center)
+ (a vector x = (x center)
y = (y center) - delta))))
(p2 ((if (radiusx > radiusy)
- then (a vector x = (x center) + delta
+ (a vector x = (x center) + delta
y = (y center))
- else (a vector x = (x center)
+ (a vector x = (x center)
y = (y center) + delta)))) )
msg ((draw draw-ellipse-draw)
(snap draw-ellipse-snap)
@@ -225,13 +225,14 @@
) ; glispobjects
+; 05 Jan 04
; Get drawing description associated with name
-(gldefun draw-desc (name\:symbol)
+(gldefun draw-desc ((name symbol))
(result draw-desc)
- (let (dd\:draw-desc)
- (dd \:= (draw-descr name))
- (if ~ dd then (dd \:= (a draw-desc with name = name))
- (setf (draw-descr name) dd))
+ (let ((dd draw-desc))
+ (dd = (draw-descr name))
+ (if ~ dd (progn (dd = (a draw-desc with name = name))
+ (setf (draw-descr name) dd)))
dd))
; Make a window to draw in.
@@ -243,22 +244,23 @@
"Draw window"))) )
; 09 Sep 92; 11 Sep 92; 14 Sep 92; 16 Sep 92; 21 Oct 92; 21 May 93; 17 Dec 93
-(gldefun draw (name\:symbol)
- (let (w dd done sel (redraw t) new\:draw-object)
- (w \:= (draw-window))
+; 05 Jan 04
+(gldefun draw ((name symbol))
+ (let (w dd done sel (redraw t) (new draw-object))
+ (w = (draw-window))
(open w)
(or *draw-menu-set* (draw-init-menus))
- (dd \:= (draw-desc name))
+ (dd = (draw-desc name))
(unless (member name *draw-objects*)
(setq *draw-objects* (nconc *draw-objects* (list name))))
(draw dd w)
(while ~ done do
- (sel \:= (menu-set-select *draw-menu-set* redraw))
- (redraw \:= nil)
+ (sel = (menu-set-select *draw-menu-set* redraw))
+ (redraw = nil)
(case (menu-name sel)
(command
(case (port sel)
- (done (done \:= t))
+ (done (done = t))
(move (draw-desc-move dd w))
(delete (draw-desc-delete dd w))
(copy (draw-desc-copy dd w))
@@ -275,192 +277,193 @@
(format t "Latex Mode is now ~A~%" *draw-latex-mode*))
))
(draw
- (new \:= nil)
+ (new = nil)
(case (port sel)
- (rectangle (new \:= (draw-box-get dd w)))
- (rcbox (new \:= (draw-rcbox-get dd w)))
- (circle (new \:= (draw-circle-get dd w)))
- (ellipse (new \:= (draw-ellipse-get dd w)))
- (line (new \:= (draw-line-get dd w)))
- (arrow (new \:= (draw-arrow-get dd w)))
- (dot (new \:= (draw-dot-get dd w)))
- (erase (new \:= (draw-erase-get dd w)))
- (button (new \:= (draw-button-get dd w)))
- (text (new \:= (draw-text-get dd w)))
- (refpt (new \:= (draw-refpt-get dd w))))
+ (rectangle (new = (draw-box-get dd w)))
+ (rcbox (new = (draw-rcbox-get dd w)))
+ (circle (new = (draw-circle-get dd w)))
+ (ellipse (new = (draw-ellipse-get dd w)))
+ (line (new = (draw-line-get dd w)))
+ (arrow (new = (draw-arrow-get dd w)))
+ (dot (new = (draw-dot-get dd w)))
+ (erase (new = (draw-erase-get dd w)))
+ (button (new = (draw-button-get dd w)))
+ (text (new = (draw-text-get dd w)))
+ (refpt (new = (draw-refpt-get dd w))))
(if new
- then ((offset new) _- (offset dd))
+ (progn ((offset new) _- (offset dd))
((objects dd) _+ new)
- (draw new w (offset dd))))
+ (draw new w (offset dd)))))
(background nil)) )
(setf (draw-descr name) dd)
(unless *draw-leave-window* (close w))
name ))
; 09 Sep 92
-(gldefun draw-desc-draw (dd\:draw-desc w\:window)
+(gldefun draw-desc-draw ((dd draw-desc) (w window))
(let ( (off (offset dd)) )
(clear w)
(for obj in (objects dd) (draw obj w off))
(force-output w) ))
-; 11 Sep 92; 12 Sep 92; 06 Oct 92
+; 11 Sep 92; 12 Sep 92; 06 Oct 92; 05 Jan 04
; Find a draw-object such that point p selects it
-(gldefun draw-desc-selected (dd\:draw-desc p\:vector)
+(gldefun draw-desc-selected ((dd draw-desc) (p vector))
(result draw-object)
(let (objs objsb obj)
- (objs \:= (for obj in objects when (selectedp obj p (offset dd))
+ (objs = (for obj in objects when (selectedp obj p (offset dd))
collect obj))
(if objs
- then (if (null (rest objs))
- then (obj \:= (first objs))
- else (objsb \:= (for z in objs
+ (if (null (rest objs))
+ (obj = (first objs))
+ (progn (objsb = (for z in objs
when (member (first z)
'(draw-button draw-dot))
collect z))
(if (and objsb (null (rest objsb)))
- then (obj \:= (first objsb)))) )
+ (obj = (first objsb)))) ) )
obj))
-; 11 Sep 92; 12 Sep 92; 13 Sep 92
+; 11 Sep 92; 12 Sep 92; 13 Sep 92; 05 Jan 04
; Find a draw-object such that point p selects it
-(gldefun draw-desc-find (dd\:draw-desc w\:window &optional crossflg\:boolean)
+(gldefun draw-desc-find ((dd draw-desc) (w window) &optional (crossflg
boolean))
(result draw-object)
(let (p obj)
(while ~ obj do
- (p \:= (if crossflg then (draw-get-cross dd w)
- else (draw-get-crosshairs dd w)))
- (obj \:= (draw-desc-selected dd p)) )
+ (p = (if crossflg (draw-get-cross dd w)
+ (draw-get-crosshairs dd w)))
+ (obj = (draw-desc-selected dd p)) )
obj))
; 15 Sep 92
-(gldefun draw-get-cross (dd\:draw-desc w\:window)
+(gldefun draw-get-cross ((dd draw-desc) (w window))
(result vector)
(draw-desc-snap dd (window-get-cross w)))
; 15 Sep 92
-(gldefun draw-get-crosshairs (dd\:draw-desc w\:window)
+(gldefun draw-get-crosshairs ((dd draw-desc) (w window))
(result vector)
(draw-desc-snap dd (window-get-crosshairs w)))
; 12 Sep 92; 14 Sep 92; 06 Oct 92
; Delete selected object
-(gldefun draw-desc-delete (dd\:draw-desc w\:window)
+(gldefun draw-desc-delete ((dd draw-desc) (w window))
(let (obj)
- (obj \:= (draw-desc-find dd w t))
+ (obj = (draw-desc-find dd w t))
(erase obj w (offset dd))
((objects dd) _- obj) ))
; 12 Sep 92; 07 Oct 92
; Copy selected object
-(gldefun draw-desc-copy (dd\:draw-desc w\:window)
- (let (obj objb\:draw-object)
- (obj \:= (draw-desc-find dd w))
- (objb \:= (copy-tree obj))
+(gldefun draw-desc-copy ((dd draw-desc) (w window))
+ (let (obj (objb draw-object))
+ (obj = (draw-desc-find dd w))
+ (objb = (copy-tree obj))
(draw-get-object-pos objb w)
((offset objb) _- (offset dd))
(draw objb w (offset dd))
(force-output w)
((objects dd) _+ objb) ))
-; 12 Sep 92; 13 Sep 92; 07 Oct 92
+; 12 Sep 92; 13 Sep 92; 07 Oct 92; 05 Jan 04
; Move selected object
-(gldefun draw-desc-move (dd\:draw-desc w\:window)
+(gldefun draw-desc-move ((dd draw-desc) (w window))
(let (obj)
- (if (obj \:= (draw-desc-find dd w))
- then (move obj w (offset dd))) ))
+ (if (obj = (draw-desc-find dd w))
+ (move obj w (offset dd))) ))
-; 14 Sep 92
+; 14 Sep 92; 28 Feb 02; 05 Jan 04
; Reset origin of object group
-(gldefun draw-desc-origin (dd\:draw-desc w\:window)
+(gldefun draw-desc-origin ((dd draw-desc) (w window))
(let (sel)
(draw-desc-bounds dd)
- (sel \:= (menu '(("To zero" . zero) ("Select" . select))))
- (if (sel = 'select)
- then ((offset dd) \:= (get-box-position w (x (size dd)) (y (size dd))))
- elseif (sel = 'zero) then ((offset dd) \:= (a vector x 0 y 0)) ) ))
+ (sel = (menu '(("To zero" . zero) ("Select" . select))))
+ (if (sel == 'select)
+ ((offset dd) = (get-box-position w (x (size dd)) (y (size dd))))
+ (if (sel == 'zero) ((offset dd) = (a vector x 0 y 0)) ) )))
; 14 Sep 92
; Compute boundaries of objects in a drawing; set offset and size of
; the draw-desc and reset offsets of items relative to it.
-(gldefun draw-desc-bounds (dd\:draw-desc)
+(gldefun draw-desc-bounds ((dd draw-desc))
(let ((xmin 9999) (ymin 9999) (xmax 0) (ymax 0) basev)
(for obj in objects do
- (xmin \:= (min xmin (x (offset obj))
+ (xmin = (min xmin (x (offset obj))
((x (offset obj)) + (x (size obj)))))
- (ymin \:= (min ymin (y (offset obj))
+ (ymin = (min ymin (y (offset obj))
((y (offset obj)) + (y (size obj)))))
- (xmax \:= (max xmax (x (offset obj))
+ (xmax = (max xmax (x (offset obj))
((x (offset obj)) + (x (size obj)))))
- (ymax \:= (max ymax (y (offset obj))
+ (ymax = (max ymax (y (offset obj))
((y (offset obj)) + (y (size obj))))) )
- ((x (size dd)) \:= (xmax - xmin))
- ((y (size dd)) \:= (ymax - ymin))
- (basev \:= (a vector with x = xmin y = ymin))
- ((offset dd) \:= basev)
+ ((x (size dd)) = (xmax - xmin))
+ ((y (size dd)) = (ymax - ymin))
+ (basev = (a vector with x = xmin y = ymin))
+ ((offset dd) = basev)
(for obj in objects do ((offset obj) _- basev)) ))
-; 14 Sep 92; 16 Sep 92; 19 Dec 93
+; 14 Sep 92; 16 Sep 92; 19 Dec 93; 15 Jan 98
; Produce LaTex output for object group.
; LaTex can only *approximately* reproduce the picture.
-(gldefun draw-desc-latex (dd\:draw-desc)
+(gldefun draw-desc-latex ((dd draw-desc))
(let (base bx by sx sy)
- (format t " \\begin{picture}(~5,2F,~5,2F)(0,0)~%"
+ (format t " \\begin{picture}(~5,0F,~5,0F)(0,0)~%"
(x (size dd) * *draw-latex-factor*)
(y (size dd) * *draw-latex-factor*) )
(for obj in (objects dd) do
- (base \:= (offset dd) + (offset obj))
- (bx \:= (x base) * *draw-latex-factor*)
- (by \:= (y base) * *draw-latex-factor*)
- (sx \:= (x (size obj)) * *draw-latex-factor*)
- (sy \:= (y (size obj)) * *draw-latex-factor*)
+ (base = (offset dd) + (offset obj))
+ (bx = (x base) * *draw-latex-factor*)
+ (by = (y base) * *draw-latex-factor*)
+ (sx = (x (size obj)) * *draw-latex-factor*)
+ (sy = (y (size obj)) * *draw-latex-factor*)
(case (first obj)
(draw-line (latex-line (x base) (y base)
((x base) + sx) ((y base) + sy)))
(draw-arrow (latex-line (x base) (y base)
((x base) + sx) ((y base) + sy) t) )
(draw-box
- (format t " \\put(~5,2F,~5,2F) {\\framebox(~5,2F,~5,2F)}~%"
+ (format t " \\put(~5,0F,~5,0F) {\\framebox(~5,0F,~5,0F)}~%"
bx by sx sy))
(draw-rcbox
- (format t " \\put(~5,2F,~5,2F) {\\oval(~5,2F,~5,2F)}~%"
+ (format t " \\put(~5,0F,~5,0F) {\\oval(~5,0F,~5,0F)}~%"
(bx + sx / 2) (by + sy / 2) sx sy))
(draw-circle
- (format t " \\put(~5,2F,~5,2F) {\\circle{~5,2F}}~%"
+ (format t " \\put(~5,0F,~5,0F) {\\circle{~5,0F}}~%"
(bx + sx / 2) (by + sy / 2) sx))
(draw-ellipse
- (format t " \\put(~5,2F,~5,2F) {\\oval(~5,2F,~5,2F)}~%"
+ (format t " \\put(~5,0F,~5,0F) {\\oval(~5,0F,~5,0F)}~%"
(bx + sx / 2) (by + sy / 2) sx sy))
(draw-button
- (format t " \\put(~5,2F,~5,2F) {\\framebox(~5,2F,~5,2F)}~%"
+ (format t " \\put(~5,0F,~5,0F) {\\framebox(~5,0F,~5,0F)}~%"
bx by sx sy))
(draw-erase )
(draw-dot
- (format t " \\put(~5,2F,~5,2F) {\\circle*{~5,2F}}~%"
+ (format t " \\put(~5,0F,~5,0F) {\\circle*{~5,0F}}~%"
(bx + sx / 2) (by + sy / 2) sx))
(draw-text
- (format t " \\put(~5,2F,~5,2F) {~A}~%"
+ (format t " \\put(~5,0F,~5,0F) {~A}~%"
bx (by + 4 * *draw-latex-factor*) (contents obj)) ) ) )
(format t " \\end{picture}~%") ))
-; 14 Sep 92; 15 Sep 92; 16 Sep 92; 05 Oct 92; 17 Dec 93; 21 Dec 93
+; 14 Sep 92; 15 Sep 92; 16 Sep 92; 05 Oct 92; 17 Dec 93; 21 Dec 93; 28 Feb 02
+; 05 Jan 04
; Produce program to draw object group
-(gldefun draw-desc-program (dd\:draw-desc)
+(gldefun draw-desc-program ((dd draw-desc))
(let (base bx by sx sy tox toy r rx ry s code fncode fnname cd)
- (code \:= (for obj in (objects dd) when
- (cd \:= (progn
- (base \:= (offset dd) + (offset obj) - (refpt dd))
- (bx \:= (x base))
- (by \:= (y base))
- (sx \:= (x (size obj)))
- (sy \:= (y (size obj)))
- (tox \:= bx + sx)
- (toy \:= by + sy)
- (if ((car obj) = 'draw-circle)
- then (r \:= (x (size obj)) / 2))
- (if ((car obj) = 'draw-ellipse)
- then (rx \:= (x (size obj)) / 2)
- (ry \:= (y (size obj)) / 2))
+ (code = (for obj in (objects dd) when
+ (cd = (progn
+ (base = (offset dd) + (offset obj) - (refpt dd))
+ (bx = (x base))
+ (by = (y base))
+ (sx = (x (size obj)))
+ (sy = (y (size obj)))
+ (tox = bx + sx)
+ (toy = by + sy)
+ (if ((car obj) == 'draw-circle)
+ (r = (x (size obj)) / 2))
+ (if ((car obj) == 'draw-ellipse)
+ (progn (rx = (x (size obj)) / 2)
+ (ry = (y (size obj)) / 2)))
(draw-optimize
(case (first obj)
(draw-line `(window-draw-line-xy w (+ x ,bx) (+ y ,by)
@@ -482,15 +485,15 @@
,sx ,sy))
(draw-dot `(window-draw-dot-xy w (+ x ,(+ 2 bx))
(+ y ,(+ 2 by))))
- (draw-text (s \:= (stringify (contents obj)))
+ (draw-text (s = (stringify (contents obj)))
`(window-printat-xy w ,s (+ x ,bx) (+ y ,by)))
)) ))
collect cd))
- (fncode \:= (cons 'lambda (cons (list 'w 'x 'y)
+ (fncode = (cons 'lambda (cons (list 'w 'x 'y)
(nconc code
(list (list 'window-force-output
'w))))))
- (fnname \:= (fnname dd))
+ (fnname = (fnname dd))
(setf (symbol-function fnname) fncode)
(format t "Constructed program (~A w x y)~%" fnname)
(draw-desc-picmenu dd)
@@ -501,35 +504,35 @@
(defun draw-optimize (x) (if (fboundp 'glunwrap) (glunwrap x nil) x))
; 14 Sep 92
-(gldefun draw-desc-fnname (dd\:draw-desc)
+(gldefun draw-desc-fnname ((dd draw-desc))
(intern (concatenate 'string "DRAW-" (symbol-name (name dd)))) )
-; 14 Sep 92; 06 Oct 92; 08 Apr 93
+; 14 Sep 92; 06 Oct 92; 08 Apr 93; 28 Feb 02; 05 Jan 04
; Produce a picmenu-spec from the buttons of a drawing description
-(gldefun draw-desc-picmenu (dd\:draw-desc)
+(gldefun draw-desc-picmenu ((dd draw-desc))
(let (buttons)
- (buttons \:= (for obj in (objects dd) when ((first obj) = 'draw-button)
+ (buttons = (for obj in (objects dd) when ((first obj) == 'draw-button)
collect (list (contents obj)
((a vector x 2 y 2) + (offset obj)
+ (offset dd) )) ) )
(if buttons
- then (setf (get (name dd) 'picmenu-spec)
+ (setf (get (name dd) 'picmenu-spec)
(list 'picmenu-spec (x (size dd)) (y (size dd)) buttons
t (fnname dd) '9x15))) ))
-; 15 Sep 92
-(gldefun draw-desc-snap (dd\:draw-desc p\:vector)
+; 15 Sep 92; 05 Jan 04
+(gldefun draw-desc-snap ((dd draw-desc) (p vector))
(result vector)
(let (psnap obj (objs (objects dd)) )
(if *draw-snap-flag*
- then (while objs and ~ psnap do
- (obj \:= (pop objs))
- (psnap \:= (draw-object-snap obj p (offset dd))) ) )
+ (while objs and ~ psnap do
+ (obj = (pop objs))
+ (psnap = (draw-object-snap obj p (offset dd))) ) )
(or psnap p) ))
; 10 Sep 92; 12 Sep 92
; Move specified object
-(gldefun draw-object-move (d\:draw-object w\:window off\:vector)
+(gldefun draw-object-move ((d draw-object) (w window) (off vector))
(let ()
(erase d w off)
(draw-get-object-pos d w)
@@ -558,63 +561,63 @@
(defun draw-object-selectedp (d w off)
(funcall (glmethod (car d) 'selectedp) d w off) )
-; 12 Sep 92; 07 Oct 92
-(gldefun draw-get-object-pos (d\:draw-object w\:window)
+; 12 Sep 92; 07 Oct 92; 28 Feb 02; 05 Jan 04
+(gldefun draw-get-object-pos ((d draw-object) (w window))
(window-get-icon-position w
- (if ((first d) = 'draw-text) then #'draw-text-draw-outline
- else #'draw-object-draw-at)
+ (if ((first d) == 'draw-text) #'draw-text-draw-outline
+ #'draw-object-draw-at)
(list d)) )
-; 10 Sep 92; 15 Sep 92
-(gldefun draw-object-erase (d\:draw-object w\:window off\:vector)
+; 10 Sep 92; 15 Sep 92; 05 Jan 04
+(gldefun draw-object-erase ((d draw-object) (w window) (off vector))
(let ()
(if ((first d) <> 'draw-erase)
- then (set-xor w)
+ (progn (set-xor w)
(draw d w off)
- (unset w)) ))
+ (unset w)) )))
-; 09 Sep 92; 17 Dec 93; 19 Dec 93
-(gldefun draw-line-draw (d\:draw-line w\:window off\:vector)
- (let ((from (off + (offset d))) (to (off + (offset d)) + (size d)) )
+; 09 Sep 92; 17 Dec 93; 19 Dec 93; 04 Dec 00
+(gldefun draw-line-draw ((d draw-line) (w window) (off vector))
+ (let ((from (off + (offset d))) (to ((off + (offset d)) + (size d))) )
(draw-line-xy w (x from) (y from) (x to) (y to)) ))
-; 11 Sep 92; 17 Dec 93; 19 Dec 93
-(gldefun draw-arrow-draw (d\:draw-arrow w\:window off\:vector)
- (let ((from (off + (offset d))) (to (off + (offset d)) + (size d)) )
+; 11 Sep 92; 17 Dec 93; 19 Dec 93; 04 Dec 00
+(gldefun draw-arrow-draw ((d draw-arrow) (w window) (off vector))
+ (let ((from (off + (offset d))) (to ((off + (offset d)) + (size d))) )
(draw-arrow-xy w (x from) (y from) (x to) (y to)) ))
; 09 Sep 92; 10 Sep 92; 12 Sep 92
-(gldefun draw-line-selectedp (d\:draw-line pt\:vector off\:vector)
+(gldefun draw-line-selectedp ((d draw-line) (pt vector) (off vector))
(let ((ptp (pt - off)))
(and (contains? (vregion d) ptp)
((distance (line d) ptp) < 5) ) ))
-; 09 Sep 92; 10 Sep 92; 15 Sep 92; 17 Dec 93
-(gldefun draw-line-get (dd\:draw-desc w\:window)
+; 09 Sep 92; 10 Sep 92; 15 Sep 92; 17 Dec 93; 05 Jan 04
+(gldefun draw-line-get ((dd draw-desc) (w window))
(let (from to)
- (from \:= (draw-get-crosshairs dd w))
- (to \:= (if *draw-latex-mode*
- then (window-get-latex-position w (x from) (y from) nil)
- else (draw-desc-snap dd
+ (from = (draw-get-crosshairs dd w))
+ (to = (if *draw-latex-mode*
+ (window-get-latex-position w (x from) (y from) nil)
+ (draw-desc-snap dd
(window-get-line-position w (x from) (y from)))))
(a draw-line with offset = from size = (to - from)) ))
-; 11 Sep 92; 15 Sep 92; 17 Dec 93
-(gldefun draw-arrow-get (dd\:draw-desc w\:window)
+; 11 Sep 92; 15 Sep 92; 17 Dec 93; 05 Jan 04
+(gldefun draw-arrow-get ((dd draw-desc) (w window))
(let (from to)
- (from \:= (draw-get-crosshairs dd w))
- (to \:= (if *draw-latex-mode*
- then (window-get-latex-position w (x from) (y from) nil)
- else (draw-desc-snap dd
+ (from = (draw-get-crosshairs dd w))
+ (to = (if *draw-latex-mode*
+ (window-get-latex-position w (x from) (y from) nil)
+ (draw-desc-snap dd
(window-get-line-position w (x from) (y from)))))
(a draw-arrow with offset = from size = (to - from)) ))
; 09 Sep 92
-(gldefun draw-box-draw (d\:draw-box w\:window off\:vector)
+(gldefun draw-box-draw ((d draw-box) (w window) (off vector))
(draw-box w (off + (offset d)) (size d)) )
; 09 Sep 92; 11 Sep 92
-(gldefun draw-box-selectedp (d\:draw-box p\:vector off\:vector)
+(gldefun draw-box-selectedp ((d draw-box) (p vector) (off vector))
(let ((pt (p - off)))
(or (and ((y pt) < (top (vregion d)) + 5)
((y pt) > (bottom (vregion d)) - 5)
@@ -626,20 +629,20 @@
((abs (y pt) - (bottom (vregion d))) < 5))) ) ))
; 11 Sep 92
-(gldefun draw-box-get (dd\:draw-desc w\:window)
+(gldefun draw-box-get ((dd draw-desc) (w window))
(let (box)
- (box \:= (window-get-region w))
+ (box = (window-get-region w))
(a draw-box with offset = (start box) size = (size box)) ))
; (dotimes (i 10) (print (draw-box-selectedp db (window-get-point dw))))
; 16 Sep 92
-(gldefun draw-rcbox-draw (d\:draw-box w\:window off\:vector)
+(gldefun draw-rcbox-draw ((d draw-box) (w window) (off vector))
(draw-rcbox-xy w ((x off) + (x (offset d))) ((y off) + (y (offset d)))
(x (size d)) (y (size d)) 8) )
; 16 Sep 92
-(gldefun draw-rcbox-selectedp (d\:draw-box p\:vector off\:vector)
+(gldefun draw-rcbox-selectedp ((d draw-box) (p vector) (off vector))
(let ((pt (p - off)))
(or (and ((y pt) < (top (vregion d)) - 3)
((y pt) > (bottom (vregion d)) + 3)
@@ -651,37 +654,37 @@
((abs (y pt) - (bottom (vregion d))) < 5))) ) ))
; 16 Sep 92
-(gldefun draw-rcbox-get (dd\:draw-desc w\:window)
+(gldefun draw-rcbox-get ((dd draw-desc) (w window))
(let (box)
- (box \:= (window-get-region w))
+ (box = (window-get-region w))
(a draw-rcbox with offset = (start box) size = (size box)) ))
; 09 Sep 92
-(gldefun draw-circle-draw (d\:draw-circle w\:window off\:vector)
+(gldefun draw-circle-draw ((d draw-circle) (w window) (off vector))
(draw-circle w (off + (center d)) (radius d)) )
; 09 Sep 92; 11 Sep 92; 17 Sep 92
-(gldefun draw-circle-selectedp (d\:draw-circle p\:vector off\:vector)
+(gldefun draw-circle-selectedp ((d draw-circle) (p vector) (off vector))
((abs (radius d) - (magnitude ((center d) + off) - p)) < 5) )
; 11 Sep 92; 15 Sep 92
-(gldefun draw-circle-get (dd\:draw-desc w\:window)
+(gldefun draw-circle-get ((dd draw-desc) (w window))
(let (cir cent)
- (cent \:= (draw-get-crosshairs dd w))
- (cir \:= (window-get-circle w cent))
+ (cent = (draw-get-crosshairs dd w))
+ (cir = (window-get-circle w cent))
(a draw-circle with
offset = (a vector with x = ( (x (center cir)) - (radius cir) )
y = ( (y (center cir)) - (radius cir) ))
size = (a vector with x = 2 * (radius cir) y = 2 * (radius cir))) ))
; 11 Sep 92
-(gldefun draw-ellipse-draw (d\:draw-ellipse w\:window off\:vector)
+(gldefun draw-ellipse-draw ((d draw-ellipse) (w window) (off vector))
(let ((c (off + (center d))))
(draw-ellipse-xy w (x c) (y c) (radiusx d) (radiusy d)) ))
; 11 Sep 92; 15 Sep 92; 17 Sep 92
; Uses the fact that sum of distances from foci is constant.
-(gldefun draw-ellipse-selectedp (d\:draw-ellipse p\:vector off\:vector)
+(gldefun draw-ellipse-selectedp ((d draw-ellipse) (p vector) (off vector))
(let ((pt (p - off)))
( (abs ( (magnitude ((p1 d) - pt)) + (magnitude ((p2 d) - pt)) )
- 2 * (radius d)) < 2) ))
@@ -698,10 +701,10 @@
(terpri)) ))
; 11 Sep 92
-(gldefun draw-ellipse-get (dd\:draw-desc w\:window)
+(gldefun draw-ellipse-get ((dd draw-desc) (w window))
(let (ell cent)
- (cent \:= (draw-get-crosshairs dd w))
- (ell \:= (window-get-ellipse w cent))
+ (cent = (draw-get-crosshairs dd w))
+ (ell = (window-get-ellipse w cent))
(a draw-ellipse with
offset = (a vector with x = ( (x (center ell)) - (x (halfsize ell)) )
y = ( (y (center ell)) - (y (halfsize ell)) ))
@@ -709,142 +712,142 @@
y = 2 * (y (halfsize ell)))) ))
; 10 Sep 92
-(gldefun draw-null-draw (d\:draw-null w\:window off\:vector) nil)
+(gldefun draw-null-draw ((d draw-null) (w window) (off vector)) nil)
; 10 Sep 92; 11 Sep 92
-(gldefun draw-null-selectedp (d\:draw-null pt\:vector off\:vector) nil)
+(gldefun draw-null-selectedp ((d draw-null) (pt vector) (off vector)) nil)
; 11 Sep 92
-(gldefun draw-button-draw (d\:draw-button w\:window off\:vector)
+(gldefun draw-button-draw ((d draw-button) (w window) (off vector))
(draw-box w (off + (offset d)) (a vector x = 4 y = 4)) )
; 11 Sep 92
-(gldefun draw-button-selectedp (d\:draw-button p\:vector off\:vector)
+(gldefun draw-button-selectedp ((d draw-button) (p vector) (off vector))
(let ( (ptx (((x p) - (x off)) - (x (offset d))))
(pty (((y p) - (y off)) - (y (offset d)))) )
(and (ptx > -2) (ptx < 6) (pty > -2) (pty < 6) ) ))
))
; 11 Sep 92
-(gldefun draw-button-get (dd\:draw-desc w\:window)
+(gldefun draw-button-get ((dd draw-desc) (w window))
(let (cent var)
(princ "Enter button name: ")
- (var \:= (read))
- (cent \:= (draw-get-crosshairs dd w))
+ (var = (read))
+ (cent = (draw-get-crosshairs dd w))
(a draw-button with
offset = (a vector with x = ((x cent) - 2) y = ((y cent) - 2))
size = (a vector with x = 4 y = 4)
contents = var) ))
; 14 Sep 92
-(gldefun draw-erase-draw (d\:draw-box w\:window off\:vector)
+(gldefun draw-erase-draw ((d draw-box) (w window) (off vector))
(erase-area w (off + (offset d)) (size d)) )
; 14 Sep 92
-(gldefun draw-erase-selectedp (d\:draw-box p\:vector off\:vector)
+(gldefun draw-erase-selectedp ((d draw-box) (p vector) (off vector))
(let ((pt (p - off)))
(contains? (region d) pt) ))
; 14 Sep 92
-(gldefun draw-erase-get (dd\:draw-desc w\:window)
+(gldefun draw-erase-get ((dd draw-desc) (w window))
(let (box)
- (box \:= (window-get-region w))
+ (box = (window-get-region w))
(a draw-erase with offset = (start box) size = (size box)) ))
; 11 Sep 92; 14 Sep 92
-(gldefun draw-dot-draw (d\:draw-dot w\:window off\:vector)
+(gldefun draw-dot-draw ((d draw-dot) (w window) (off vector))
(window-draw-dot-xy w ((x off) + (x (offset d)) + 2)
((y off) + (y (offset d)) + 2) ) )
; 11 Sep 92; 15 Sep 92
-(gldefun draw-dot-get (dd\:draw-desc w\:window)
+(gldefun draw-dot-get ((dd draw-desc) (w window))
(let (cent)
- (cent \:= (draw-get-crosshairs dd w))
+ (cent = (draw-get-crosshairs dd w))
(a draw-dot with
offset = (a vector with x = ((x cent) - 2) y = ((y cent) - 2))
size = (a vector with x = 4 y = 4)) ))
; 17 Dec 93
-(gldefun draw-refpt-draw (d\:draw-refpt w\:window off\:vector)
+(gldefun draw-refpt-draw ((d draw-refpt) (w window) (off vector))
(window-draw-crosshairs-xy w ((x off) + (x (offset d)))
((y off) + (y (offset d))) ) )
; 17 Dec 93
-(gldefun draw-refpt-selectedp (d\:draw-button p\:vector off\:vector)
+(gldefun draw-refpt-selectedp ((d draw-button) (p vector) (off vector))
(let ( (ptx (((x p) - (x off)) - (x (offset d))))
(pty (((y p) - (y off)) - (y (offset d)))) )
(and (ptx > -3) (ptx < 3) (pty > -3) (pty < 3) ) ))
-; 17 Dec 93
-(gldefun draw-refpt-get (dd\:draw-desc w\:window)
+; 17 Dec 93; 05 Jan 04
+(gldefun draw-refpt-get ((dd draw-desc) (w window))
(let (cent refpt)
- (if (refpt \:= (assoc 'draw-refpt (objects dd)))
- then (set-erase *draw-window*)
+ (if (refpt = (assoc 'draw-refpt (objects dd)))
+ (progn (set-erase *draw-window*)
(draw refpt *draw-window* (a vector with x = 0 y = 0))
(unset *draw-window*)
- ((objects dd) _- refpt) )
- (cent \:= (draw-get-crosshairs dd w))
+ ((objects dd) _- refpt) ) )
+ (cent = (draw-get-crosshairs dd w))
(a draw-refpt with offset = cent
size = (a vector with x = 0 y = 0)) ))
-; 17 Dec 93
-(gldefun draw-desc-refpt (dd\:draw-desc) (result vector)
+; 17 Dec 93; 05 Jan 04
+(gldefun draw-desc-refpt ((dd draw-desc)) (result vector)
(let (refpt)
- (refpt \:= (assoc 'draw-refpt (objects dd)))
- (if refpt then (offset refpt)
- else (a vector x = 0 y = 0)) ))
+ (refpt = (assoc 'draw-refpt (objects dd)))
+ (if refpt (offset refpt)
+ (a vector x = 0 y = 0)) ))
; 11 Sep 92; 06 Oct 92; 19 Dec 93; 11 Nov 94
-(gldefun draw-text-draw (d\:draw-text w\:window off\:vector)
+(gldefun draw-text-draw ((d draw-text) (w window) (off vector))
(printat-xy w (contents d) ((x off) + (x (offset d)))
((y off) + (y (offset d)))) )
; 07 Oct 92
-(gldefun draw-text-draw-outline (w\:window x\:integer y\:integer d\:draw-text)
+(gldefun draw-text-draw-outline ((w window) (x integer) (y integer) (d
draw-text))
(setf (second d) (list x y))
(draw-box-xy w x (y + 2) (x (size d)) (y (size d))) )
; 11 Sep 92
-(gldefun draw-text-selectedp (d\:draw-text pt\:vector off\:vector)
+(gldefun draw-text-selectedp ((d draw-text) (pt vector) (off vector))
(let ((ptp (pt - off)))
(contains? (vregion d) ptp)))
; 11 Sep 92; 17 Sep 92; 06 Oct 92; 11 Nov 94
-(gldefun draw-text-get (dd\:draw-desc w\:window)
+(gldefun draw-text-get ((dd draw-desc) (w window))
(let (txt lng off)
(princ "Enter text string: ")
- (txt \:= (stringify (read)))
- (lng \:= (string-width w txt))
- (off \:= (get-box-position w lng 14))
+ (txt = (stringify (read)))
+ (lng = (string-width w txt))
+ (off = (get-box-position w lng 14))
(a draw-text with offset = (off + (a vector x 0 y 4))
size = (a vector with x = lng y = 14)
contents = txt) ))
-; 15 Sep 92
+; 15 Sep 92; 05 Jan 04
; Test if a point p1 is close to a point p2. If so, result is p2, else nil.
-(gldefun draw-snapp (p1\:vector off\:vector p2x\:integer p2y\:integer)
+(gldefun draw-snapp ((p1 vector) (off vector) (p2x integer) (p2y integer))
(if (and ((abs ((x p1) - (x off) - p2x)) < 4)
((abs ((y p1) - (y off) - p2y)) < 4) )
- then (a vector with x = ((x off) + p2x) y = ((y off) + p2y)) ))
+ (a vector with x = ((x off) + p2x) y = ((y off) + p2y)) ))
; 15 Sep 92
-(gldefun draw-dot-snap (d\:draw-dot p\:vector off\:vector)
+(gldefun draw-dot-snap ((d draw-dot) (p vector) (off vector))
(draw-snapp p off ((x (offset d)) + 2)
((y (offset d)) + 2) ) )
; 17 Dec 93
-(gldefun draw-refpt-snap (d\:draw-refpt p\:vector off\:vector)
+(gldefun draw-refpt-snap ((d draw-refpt) (p vector) (off vector))
(draw-snapp p off (x (offset d)) (y (offset d)) ) )
; 15 Sep 92
-(gldefun draw-line-snap (d\:draw-line p\:vector off\:vector)
+(gldefun draw-line-snap ((d draw-line) (p vector) (off vector))
(or (draw-snapp p off (x (offset d)) (y (offset d)))
(draw-snapp p off ( (x (offset d)) + (x (size d)) )
( (y (offset d)) + (y (size d)) ) ) ))
; 15 Sep 92; 19 Dec 93
; Snap for square: corners, middle of sides.
-(gldefun draw-box-snap (d\:draw-box p\:vector off\:vector)
+(gldefun draw-box-snap ((d draw-box) (p vector) (off vector))
(let ((xoff (x (offset d))) (yoff (y (offset d)))
(xsize (x (size d)) ) (ysize (y (size d)) ) )
(or (draw-snapp p off xoff yoff)
@@ -857,7 +860,7 @@
(draw-snapp p off (xoff + xsize) (yoff + ysize / 2)) ) ))
; 15 Sep 92
-(gldefun draw-circle-snap (d\:draw-circle p\:vector off\:vector)
+(gldefun draw-circle-snap ((d draw-circle) (p vector) (off vector))
(or (draw-snapp p off ( (x (offset d)) + (radius d) )
( (y (offset d)) + (radius d) ) )
(draw-snapp p off ( (x (offset d)) + (radius d) )
@@ -870,7 +873,7 @@
( (y (offset d)) + (radius d) ) ) ))
; 15 Sep 92
-(gldefun draw-ellipse-snap (d\:draw-ellipse p\:vector off\:vector)
+(gldefun draw-ellipse-snap ((d draw-ellipse) (p vector) (off vector))
(or (draw-snapp p off ( (x (offset d)) + (radiusx d) )
( (y (offset d)) + (radiusy d) ) )
(draw-snapp p off ( (x (offset d)) + (radiusx d) )
@@ -883,7 +886,7 @@
( (y (offset d)) + (radiusy d) ) ) ))
; 16 Sep 92
-(gldefun draw-rcbox-snap (d\:draw-rcbox p\:vector off\:vector)
+(gldefun draw-rcbox-snap ((d draw-rcbox) (p vector) (off vector))
(let ( (rx ((x (size d)) / 2)) (ry ((y (size d)) / 2)) )
(or (draw-snapp p off ( (x (offset d)) + rx ) (y (offset d)) )
(draw-snapp p off (x (offset d)) ( (y (offset d)) + ry ) )
@@ -893,10 +896,10 @@
( (y (offset d)) + ry ) ) ) ))
; 15 Sep 92
-(gldefun draw-no-snap (d\:draw-ellipse p\:vector off\:vector) nil)
+(gldefun draw-no-snap ((d draw-ellipse) (p vector) (off vector)) nil)
; 11 Sep 92
-(gldefun draw-multi-draw (d\:draw-multi w\:window off\:vector)
+(gldefun draw-multi-draw ((d draw-multi) (w window) (off vector))
(let ( (totaloff ((offset d) + off)) )
(for subd in (contents d) do
(draw subd w totaloff)) ))
@@ -959,7 +962,7 @@
(window-draw-crosshairs-xy w (+ x 15) (+ y 9))
(window-draw-circle-xy w (+ x 15) (+ y 9) 2))
-; 14 Sep 92
+; 14 Sep 92; 15 Jan 98
; Draw a line or arrow in LaTex form
(defun latex-line (fromx fromy x y &optional arrowflg)
(let (dx dy sx sy siz err errb)
@@ -989,7 +992,7 @@
(setq sy (1+ j))))))
(setq sx (* sx (latex-sign dx)))
(setq sy (* sy (latex-sign dy))) )))
- (format t " \\put(~5,2F,~5,2F) {\\~A(~D,~D){~5,2F}}~%"
+ (format t " \\put(~5,0F,~5,0F) {\\~A(~D,~D){~5,0F}}~%"
(* fromx *draw-latex-factor*) (* fromy *draw-latex-factor*)
(if arrowflg "vector" "line") sx sy siz) ))
@@ -1052,10 +1055,11 @@
"glisp/draw-header.lsp") ; header file
(cf drawtrans) )
-; 16 Nov 92; 08 Apr 93; 08 Oct 93; 20 Apr 94; 29 Oct 94
+; 16 Nov 92; 08 Apr 93; 08 Oct 93; 20 Apr 94; 29 Oct 94; 09 Feb 99
; Output drawing descriptions and functions to the specified file
-(defun draw-out (&optional file names)
+(defun draw-out (&optional names file)
(or names (setq names *draw-objects*))
(if (not (consp names)) (setq names (list names)))
(draw-output (or file "glisp/draw.del") names)
- (setq *draw-objects* (set-difference *draw-objects* names)) )
+ (setq *draw-objects* (set-difference *draw-objects* names))
+ names )
Index: xgcl-2/gcl_drawtrans.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/xgcl-2/gcl_drawtrans.lsp,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -b -r1.1.2.1 -r1.1.2.2
--- xgcl-2/gcl_drawtrans.lsp 5 Jan 2006 17:55:35 -0000 1.1.2.1
+++ xgcl-2/gcl_drawtrans.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.2
@@ -1,14 +1,12 @@
-; 29 Oct 1994 14:39:13
+; 27 Jan 2006 14:58:53 CST
; drawtrans.lsp -- translation of draw.lsp Gordon S. Novak Jr.
-; Copyright (c) 1994 Gordon S. Novak Jr. and The University of Texas at Austin.
-
-; See the file gnu.license .
+; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin.
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
-; the Free Software Foundation; either version 1, or (at your option)
-; any later version.
+; the Free Software Foundation; either version 2 of the License, or
+; (at your option) any later version.
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -17,12 +15,11 @@
; You should have received a copy of the GNU General Public License
; along with this program; if not, write to the Free Software
-; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Written by: Gordon S. Novak Jr., Department of Computer Sciences,
; University of Texas at Austin 78712. address@hidden
-
(IN-PACKAGE :USER)
(defmacro while (test &rest forms) `(loop (unless ,test (return)) ,@forms) )
@@ -32,8 +29,6 @@
(defmacro glmethod (class selector)
`(cadr (assoc ,selector (getf (cdr (get ,class 'glstructure)) 'msg))) )
-(IN-PACKAGE :USER)
-
(SETF (GET 'MENU-SET 'GLSTRUCTURE)
'((LISTOBJECT (WINDOW WINDOW) (MENU-ITEMS (LISTOF MENU-SET-ITEM))
(COMMANDFN ANYTHING))
@@ -62,6 +57,8 @@
'((TRANSPARENT MENU) MSG ((DRAW MENU-MDRAW))))
(SETF (GET 'MENU-PORT 'GLSTRUCTURE)
'((LIST (PORT SYMBOL) (MENU-NAME SYMBOL))))
+(SETF (GET 'MENU-SELECTION 'GLSTRUCTURE)
+ '((LIST (PORT SYMBOL) (MENU-NAME SYMBOL) (BUTTON INTEGER))))
(SETF (GET 'MENU-SET-CONN 'GLSTRUCTURE)
'((LIST (FROM MENU-PORT) (TO MENU-PORT))))
(SETF (GET 'MENU-CONNS 'GLSTRUCTURE)
@@ -78,48 +75,57 @@
(REMOVE-ITEMS MENU-CONNS-REMOVE-ITEMS)
(FIND-CONNS MENU-CONNS-FIND-CONNS)
(CONNECTED-PORTS MENU-CONNS-CONNECTED-PORTS)
- (NAMED-MENU MENU-CONNS-NAMED-MENU))))
+ (NEW-CONN MENU-CONNS-NEW-CONN)
+ (NAMED-MENU MENU-CONNS-NAMED-MENU)
+ (NAMED-ITEM MENU-CONNS-NAMED-ITEM))))
(DEFUN MENU-SET-CREATE (W &OPTIONAL FN) (LIST 'MENU-SET W NIL FN))
+(SETF (GET 'MENU-SET-CREATE 'GLARGUMENTS)
+ '((W WINDOW) (&OPTIONAL NIL) (FN NIL)))
(SETF (GET 'MENU-SET-CREATE 'GLFNRESULTTYPE) 'MENU-SET)
(DEFUN MENU-SET-SELECT (MS &OPTIONAL REDRAW ENABLED)
(LET (RES RESB ITM SEL LASTX LASTY)
(IF REDRAW (MENU-SET-DRAW MS))
- (TAGBODY
- GLLABEL4237
- (UNLESS (OR RES RESB)
+ (WHILE (NOT (OR RES RESB))
(SETQ ITM
(WINDOW-TRACK-MOUSE (CADR MS)
#'(LAMBDA (X Y CODE)
(OR (AND (PLUSP CODE) (SETQ LASTX X)
(SETQ LASTY Y) CODE)
- (FIND-IF #'(LAMBDA (GLVAR4236)
+ (SOME #'(LAMBDA (GLVAR22053)
+ (IF
(AND
(>= X
- (FIFTH (CADDR GLVAR4236)))
+ (FIFTH (CADDR GLVAR22053)))
(<= X
- (+ (FIFTH (CADDR GLVAR4236))
- (SEVENTH (CADDR GLVAR4236))))
+ (+ (FIFTH (CADDR GLVAR22053))
+ (SEVENTH (CADDR GLVAR22053))))
(>= Y
- (SIXTH (CADDR GLVAR4236)))
+ (SIXTH (CADDR GLVAR22053)))
(<= Y
- (+ (SIXTH (CADDR GLVAR4236))
- (EIGHTH (CADDR GLVAR4236))))))
+ (+ (SIXTH (CADDR GLVAR22053))
+ (EIGHTH (CADDR GLVAR22053)))))
+ GLVAR22053))
(CADDR MS))))))
(IF (NUMBERP ITM)
- (SETQ RESB (LIST 'BACKGROUND (LIST LASTX LASTY) ITM))
+ (SETQ RESB (LIST (LIST LASTX LASTY) 'BACKGROUND ITM))
(WHEN (OR (ATOM ENABLED) (MEMBER (CAR ITM) ENABLED))
(SETQ SEL (MENU-MSELECT (CADDR ITM) (EQ ENABLED T)))
- (IF SEL (SETQ RES (LIST SEL (CAR ITM)))
- (UNLESS (ZEROP *WINDOW-MENU-CODE*)
- (SETQ RES (LIST NIL (CAR ITM)))))))
- (GO GLLABEL4237)))
- (XFLUSH *WINDOW-DISPLAY*)
+ (IF SEL
+ (SETQ RES (LIST SEL (CAR ITM) *WINDOW-MENU-CODE*))
+ (IF (AND *WINDOW-MENU-CODE*
+ (NOT (ZEROP *WINDOW-MENU-CODE*)))
+ (SETQ RES
+ (LIST NIL (CAR ITM) *WINDOW-MENU-CODE*)))))))
+ (WINDOW-FORCE-OUTPUT (CADR MS))
(OR RES RESB)))
-(SETF (GET 'MENU-SET-SELECT 'GLFNRESULTTYPE) 'MENU-PORT)
+(SETF (GET 'MENU-SET-SELECT 'GLARGUMENTS)
+ '((MS MENU-SET) (&OPTIONAL NIL) (REDRAW BOOLEAN)
+ (ENABLED (LISTOF SYMBOL))))
+(SETF (GET 'MENU-SET-SELECT 'GLFNRESULTTYPE) 'MENU-SELECTION)
(DEFUN MENU-SET-ADD-MENU (MS NAME SYM TITLE ITEMS &OPTIONAL OFFSET)
@@ -128,22 +134,23 @@
(MENU-CREATE ITEMS TITLE (CADR MS) (CAR OFFSET) (CADR OFFSET)
T T))
(MENU-INIT MENU)
- (UNLESS OFFSET
+ (IF (NOT OFFSET)
(SETQ OFFSET
(WINDOW-GET-BOX-POSITION (CADR MS) (SEVENTH MENU)
(EIGHTH MENU))))
(SETF (FIFTH MENU) (CAR OFFSET))
(SETF (SIXTH MENU) (CADR OFFSET))
(MENU-SET-ADD-ITEM MS NAME SYM MENU)))
-(SETF (GET 'MENU-SET-ADD-MENU 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM))
-
(DEFUN MENU-SET-ADD-ITEM (MS NAME SYM MENU)
(SETF (CADDR MS) (NCONC (CADDR MS) (CONS (LIST NAME SYM MENU) NIL))))
+(SETF (GET 'MENU-SET-ADD-ITEM 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (MENU MENU)))
(SETF (GET 'MENU-SET-ADD-ITEM 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM))
(DEFUN MENU-SET-REMOVE-ITEMS (MS) (SETF (CADDR MS) NIL))
+(SETF (GET 'MENU-SET-REMOVE-ITEMS 'GLARGUMENTS) '((MS MENU-SET)))
(SETF (GET 'MENU-SET-REMOVE-ITEMS 'GLFNRESULTTYPE)
'(LISTOF MENU-SET-ITEM))
@@ -151,82 +158,112 @@
(DEFUN MENU-SET-ADD-PICMENU
(MS NAME SYM TITLE SPEC &OPTIONAL OFFSET NOBOX)
(LET (MENU MAXWIDTH MAXHEIGHT)
- (IF (SYMBOLP SPEC) (SETQ SPEC (GET SPEC 'PICMENU-SPEC)))
+ (IF (AND SPEC (SYMBOLP SPEC)) (SETQ SPEC (GET SPEC 'PICMENU-SPEC)))
(SETQ MENU
(PICMENU-CREATE-FROM-SPEC SPEC TITLE (CADR MS) (CAR OFFSET)
(CADR OFFSET) T T (NOT NOBOX)))
(SETQ MAXWIDTH
(MAX (IF TITLE (+ 6 (* 9 (LENGTH TITLE))) 0) (CADR SPEC)))
(SETQ MAXHEIGHT (+ (IF TITLE 15 0) (CADDR SPEC)))
- (UNLESS OFFSET
+ (IF (NOT OFFSET)
(SETQ OFFSET
(WINDOW-GET-BOX-POSITION (CADR MS) MAXWIDTH MAXHEIGHT)))
(SETF (FIFTH MENU) (CAR OFFSET))
(SETF (SIXTH MENU) (CADR OFFSET))
(MENU-SET-ADD-ITEM MS NAME SYM MENU)))
+(SETF (GET 'MENU-SET-ADD-PICMENU 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (TITLE STRING)
+ (SPEC PICMENU-SPEC) (&OPTIONAL NIL) (OFFSET VECTOR)
+ (NOBOX BOOLEAN)))
(SETF (GET 'MENU-SET-ADD-PICMENU 'GLFNRESULTTYPE)
'(LISTOF MENU-SET-ITEM))
(DEFUN MENU-SET-ADD-COMPONENT (MS NAME &OPTIONAL OFFSET)
(MENU-SET-ADD-PICMENU MS (MENU-SET-NAME NAME) NAME NIL NAME OFFSET T))
+(SETF (GET 'MENU-SET-ADD-COMPONENT 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL) (&OPTIONAL NIL) (OFFSET VECTOR)))
(SETF (GET 'MENU-SET-ADD-COMPONENT 'GLFNRESULTTYPE)
'(LISTOF MENU-SET-ITEM))
(DEFUN MENU-SET-ADD-BARMENU (MS NAME SYM MENU TITLE &OPTIONAL OFFSET)
(BARMENU-INIT MENU)
- (UNLESS OFFSET
+ (IF (NOT OFFSET)
(SETQ OFFSET
(WINDOW-GET-BOX-POSITION (CADR MS) (SEVENTH MENU)
(EIGHTH MENU))))
(SETF (FIFTH MENU) (CAR OFFSET))
(SETF (SIXTH MENU) (CADR OFFSET))
(MENU-SET-ADD-ITEM MS NAME SYM MENU))
+(SETF (GET 'MENU-SET-ADD-BARMENU 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (MENU BARMENU)
+ (TITLE STRING) (&OPTIONAL NIL) (OFFSET VECTOR)))
(SETF (GET 'MENU-SET-ADD-BARMENU 'GLFNRESULTTYPE)
'(LISTOF MENU-SET-ITEM))
(DEFUN MENU-SET-NAME (NM)
(INTERN (SYMBOL-NAME (GENSYM (SYMBOL-NAME NM)))))
+(SETF (GET 'MENU-SET-NAME 'GLARGUMENTS) '((NM SYMBOL)))
(SETF (GET 'MENU-SET-NAME 'GLFNRESULTTYPE) 'SYMBOL)
(DEFUN MENU-SET-NAMED-ITEM (MS NAME) (ASSOC NAME (CADDR MS)))
+(SETF (GET 'MENU-SET-NAMED-ITEM 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL)))
(SETF (GET 'MENU-SET-NAMED-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM)
(DEFUN MENU-SET-NAMED-MENU (MS NAME)
(CADDR (MENU-SET-NAMED-ITEM MS NAME)))
+(SETF (GET 'MENU-SET-NAMED-MENU 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL)))
(SETF (GET 'MENU-SET-NAMED-MENU 'GLFNRESULTTYPE) 'MENU-SET-MENU)
+(DEFUN MENU-CONNS-NAMED-ITEM (MC NAME)
+ (MENU-SET-NAMED-ITEM (CADR MC) NAME))
+(SETF (GET 'MENU-CONNS-NAMED-ITEM 'GLARGUMENTS)
+ '((MC MENU-CONNS) (NAME SYMBOL)))
+(SETF (GET 'MENU-CONNS-NAMED-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM)
+
+
(DEFUN MENU-CONNS-NAMED-MENU (MC NAME)
(MENU-SET-NAMED-MENU (CADR MC) NAME))
+(SETF (GET 'MENU-CONNS-NAMED-MENU 'GLARGUMENTS)
+ '((MC MENU-CONNS) (NAME SYMBOL)))
(SETF (GET 'MENU-CONNS-NAMED-MENU 'GLFNRESULTTYPE) 'MENU-SET-MENU)
(DEFUN MENU-SET-FIND-ITEM (MS POS)
(LET (MITEM)
(DOLIST (MI (CADDR MS))
- (IF (LET ((GLVAR4241 (CADDR MI)))
- (AND (>= (CAR POS)
- (IF (CADDR GLVAR4241) (FIFTH GLVAR4241) 0))
+ (IF (AND (>= (CAR POS)
+ (LET ((SELF (CADDR MI)))
+ (IF (CADDR SELF) (FIFTH SELF) 0)))
(<= (CAR POS)
- (+ (IF (CADDR GLVAR4241) (FIFTH GLVAR4241) 0)
- (SEVENTH GLVAR4241)))
+ (+ (LET ((SELF (CADDR MI)))
+ (IF (CADDR SELF) (FIFTH SELF) 0))
+ (SEVENTH (CADDR MI))))
(>= (CADR POS)
- (IF (CADDR GLVAR4241) (SIXTH GLVAR4241) 0))
+ (LET ((SELF (CADDR MI)))
+ (IF (CADDR SELF) (SIXTH SELF) 0)))
(<= (CADR POS)
- (+ (IF (CADDR GLVAR4241) (SIXTH GLVAR4241) 0)
- (EIGHTH GLVAR4241)))))
+ (+ (LET ((SELF (CADDR MI)))
+ (IF (CADDR SELF) (SIXTH SELF) 0))
+ (EIGHTH (CADDR MI)))))
(SETQ MITEM MI)))
MITEM))
+(SETF (GET 'MENU-SET-FIND-ITEM 'GLARGUMENTS)
+ '((MS MENU-SET) (POS VECTOR)))
(SETF (GET 'MENU-SET-FIND-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM)
(DEFUN MENU-SET-DELETE-ITEM (MS MI)
(SETF (CADDR MS) (REMOVE MI (CADDR MS))))
+(SETF (GET 'MENU-SET-DELETE-ITEM 'GLARGUMENTS)
+ '((MS MENU-SET) (MI MENU-SET-ITEM)))
(SETF (GET 'MENU-SET-DELETE-ITEM 'GLFNRESULTTYPE)
'(LISTOF MENU-SET-ITEM))
@@ -236,14 +273,14 @@
(SETQ SEL (MENU-SET-SELECT MS NIL T))
(SETQ M (MENU-SET-NAMED-MENU MS (CADR SEL)))
(MENU-REPOSITION M)))
-(SETF (GET 'MENU-SET-MOVE 'GLFNRESULTTYPE) 'INTEGER)
-
(DEFUN MENU-MDRAW (M)
(CASE (FIRST M)
(MENU (MENU-DRAW M))
(PICMENU (PICMENU-DRAW M))
(BARMENU (BARMENU-DRAW M))
+ (TEXTMENU (TEXTMENU-DRAW M))
+ (EDITMENU (EDITMENU-DRAW M))
(T (GLSEND M DRAW))))
(DEFUN MENU-MSELECT (M &OPTIONAL ANYCLICK)
@@ -251,6 +288,8 @@
(MENU (MENU-SELECT M T))
(PICMENU (PICMENU-SELECT M T ANYCLICK))
(BARMENU (BARMENU-SELECT M))
+ (TEXTMENU (TEXTMENU-SELECT M T))
+ (EDITMENU (EDITMENU-SELECT M T))
(T (GLSEND M SELECT))))
(DEFUN MENU-MITEM-POSITION (M NAME LOC)
@@ -260,10 +299,7 @@
(T (GLSEND M ITEM-POSITION NAME LOC))))
(DEFUN MENU-SET-DRAW (MS)
- (LET ((GLVAR4242 (CADR MS)))
- (XMAPWINDOW *WINDOW-DISPLAY* (CADR GLVAR4242))
- (XFLUSH *WINDOW-DISPLAY*)
- (WINDOW-WAIT-EXPOSURE GLVAR4242))
+ (WINDOW-OPEN (CADR MS))
(DOLIST (ITEM (CADDR MS)) (MENU-MDRAW (CADDR ITEM))))
(DEFUN MENU-SET-ITEM-POSITION (MS DESC &OPTIONAL LOC)
@@ -271,6 +307,8 @@
(SETQ M (MENU-SET-NAMED-MENU MS (CADR DESC)))
(OR (MENU-MITEM-POSITION M (CAR DESC) LOC)
(MENU-MITEM-POSITION M NIL LOC))))
+(SETF (GET 'MENU-SET-ITEM-POSITION 'GLARGUMENTS)
+ '((MS MENU-SET) (DESC MENU-PORT) (&OPTIONAL NIL) (LOC SYMBOL)))
(SETF (GET 'MENU-SET-ITEM-POSITION 'GLFNRESULTTYPE) 'VECTOR)
@@ -284,11 +322,10 @@
(SETQ DESCB TMP))
(SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'RIGHT))
(SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'LEFT))
- (WINDOW-DRAW-CIRCLE-XY (CADR MS) (CAR PA) (CADR PA) 3 NIL)
- (WINDOW-DRAW-LINE-XY (CADR MS) (CAR PA) (CADR PA) (CAR PB)
- (CADR PB) NIL)
- (WINDOW-DRAW-CIRCLE-XY (CADR MS) (CAR PB) (CADR PB) 3 NIL)
- (XFLUSH *WINDOW-DISPLAY*)))
+ (WINDOW-DRAW-CIRCLE (CADR MS) PA 3)
+ (WINDOW-DRAW-LINE (CADR MS) PA PB)
+ (WINDOW-DRAW-CIRCLE (CADR MS) PB 3)
+ (WINDOW-FORCE-OUTPUT (CADR MS))))
(DEFUN MENU-SET-ADJUST (MS NAME EDGE FROM OFFSET)
(LET (M FROMM PLACE)
@@ -316,10 +353,14 @@
(LEFT (SETF (FIFTH (CADDR M)) (+ PLACE OFFSET)))
(RIGHT (SETF (FIFTH (CADDR M))
(- (- PLACE (SEVENTH (CADDR M))) OFFSET)))))))
+(SETF (GET 'MENU-SET-ADJUST 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL) (EDGE SYMBOL) (FROM SYMBOL)
+ (OFFSET INTEGER)))
(SETF (GET 'MENU-SET-ADJUST 'GLFNRESULTTYPE) 'INTEGER)
(DEFUN MENU-CONNS-CREATE (MS) (LIST 'MENU-CONNS MS NIL))
+(SETF (GET 'MENU-CONNS-CREATE 'GLARGUMENTS) '((MS MENU-SET)))
(SETF (GET 'MENU-CONNS-CREATE 'GLFNRESULTTYPE) 'MENU-CONNS)
@@ -329,13 +370,11 @@
(DEFUN MENU-CONNS-MOVE (MC)
(MENU-SET-MOVE (CADR MC))
- (XCLEARWINDOW *WINDOW-DISPLAY* (CADR (CADADR MC)))
- (XFLUSH *WINDOW-DISPLAY*)
+ (WINDOW-CLEAR (CADADR MC))
(MENU-CONNS-DRAW MC))
(DEFUN MENU-CONNS-REDRAW (MC)
- (XCLEARWINDOW *WINDOW-DISPLAY* (CADR (CADADR MC)))
- (XFLUSH *WINDOW-DISPLAY*)
+ (WINDOW-CLEAR (CADADR MC))
(MENU-CONNS-DRAW MC))
(DEFUN MENU-CONNS-ADD-CONN (MC)
@@ -344,14 +383,30 @@
(IF (EQ (CADR SEL) 'BACKGROUND) SEL
(PROGN
(SETQ SELB (MENU-SET-SELECT (CADR MC)))
- (UNLESS (EQ (CAR SELB) 'BACKGROUND)
+ (WHEN (NOT (EQ (CADR SELB) 'BACKGROUND))
(SETQ CONN (LIST SEL SELB))
(MENU-SET-DRAW-CONN (CADR MC) CONN)
(SETF (CADDR MC) (NCONC (CADDR MC) (CONS CONN NIL))))
NIL))))
+(SETF (GET 'MENU-CONNS-ADD-CONN 'GLARGUMENTS) '((MC MENU-CONNS)))
+(SETF (GET 'MENU-CONNS-ADD-CONN 'GLFNRESULTTYPE) 'MENU-SELECTION)
+
+
+(DEFUN MENU-CONNS-NEW-CONN (MC FROMNAME FROMPORT TONAME TOPORT)
+ (LET (CONN)
+ (SETQ CONN (LIST (LIST FROMPORT FROMNAME) (LIST TOPORT TONAME)))
+ (SETF (CADDR MC) (NCONC (CADDR MC) (CONS CONN NIL)))))
+(SETF (GET 'MENU-CONNS-NEW-CONN 'GLARGUMENTS)
+ '((MC MENU-CONNS) (FROMNAME SYMBOL) (FROMPORT SYMBOL)
+ (TONAME SYMBOL) (TOPORT SYMBOL)))
+(SETF (GET 'MENU-CONNS-NEW-CONN 'GLFNRESULTTYPE)
+ '(LISTOF MENU-SET-CONN))
+
(DEFUN MENU-CONNS-ADD-ITEM (MC NAME SYM MENU)
(MENU-SET-ADD-ITEM (CADR MC) NAME SYM MENU))
+(SETF (GET 'MENU-CONNS-ADD-ITEM 'GLARGUMENTS)
+ '((MC MENU-CONNS) (NAME SYMBOL) (SYM SYMBOL) (MENU MENU)))
(SETF (GET 'MENU-CONNS-ADD-ITEM 'GLFNRESULTTYPE)
'(LISTOF MENU-SET-ITEM))
@@ -372,24 +427,31 @@
(SETQ DESCB TMP))
(SETF (CAR LS) (MENU-SET-ITEM-POSITION MS DESCA 'RIGHT))
(SETF (CADR LS) (MENU-SET-ITEM-POSITION MS DESCB 'LEFT))
- (WHEN (< (ABS (LET ((DX (- (CAADR LS) (CAAR LS)))
- (DY (- (CADADR LS) (CADAR LS))))
- (/ (- (* DX (- (CADR PT) (CADAR LS)))
- (* DY (- (CAR PT) (CAAR LS))))
- (SQRT (+ (EXPT DX 2) (EXPT DY 2))))))
+ (WHEN (< (ABS (/ (- (* (- (CAADR LS) (CAAR LS))
+ (- (CADR PT) (CADAR LS)))
+ (* (- (CADADR LS) (CADAR LS))
+ (- (CAR PT) (CAAR LS))))
+ (SQRT (+ (EXPT (- (CAADR LS) (CAAR LS)) 2)
+ (EXPT (- (CADADR LS) (CADAR LS)) 2)))))
5)
(SETQ FOUND T)
(SETQ RES CONN))))
RES))
+(SETF (GET 'MENU-CONNS-FIND-CONN 'GLARGUMENTS)
+ '((MC MENU-CONNS) (PT VECTOR)))
(SETF (GET 'MENU-CONNS-FIND-CONN 'GLFNRESULTTYPE) 'MENU-SET-CONN)
(DEFUN MENU-CONNS-FIND-ITEM (MC PT) (MENU-SET-FIND-ITEM (CADR MC) PT))
+(SETF (GET 'MENU-CONNS-FIND-ITEM 'GLARGUMENTS)
+ '((MC MENU-CONNS) (PT VECTOR)))
(SETF (GET 'MENU-CONNS-FIND-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM)
(DEFUN MENU-CONNS-DELETE-CONN (MC CONN)
(SETF (CADDR MC) (REMOVE CONN (CADDR MC))))
+(SETF (GET 'MENU-CONNS-DELETE-CONN 'GLARGUMENTS)
+ '((MC MENU-CONNS) (CONN MENU-SET-CONN)))
(SETF (GET 'MENU-CONNS-DELETE-CONN 'GLFNRESULTTYPE)
'(LISTOF MENU-SET-CONN))
@@ -405,6 +467,7 @@
(DEFUN MENU-CONNS-REMOVE-ITEMS (MC)
(MENU-SET-REMOVE-ITEMS (CADR MC))
(SETF (CADDR MC) NIL))
+(SETF (GET 'MENU-CONNS-REMOVE-ITEMS 'GLARGUMENTS) '((MC MENU-CONNS)))
(SETF (GET 'MENU-CONNS-REMOVE-ITEMS 'GLFNRESULTTYPE)
'(LISTOF MENU-SET-CONN))
@@ -424,6 +487,8 @@
(IF (AND (EQ BOXNAME (CADAR CONN)) (EQ PORT (CAAR CONN)))
(SETQ RES (NCONC RES (CONS (CADR CONN) NIL)))))
RES))
+(SETF (GET 'MENU-CONNS-FIND-CONNS 'GLARGUMENTS)
+ '((MC MENU-CONNS) (BOXNAME SYMBOL) (PORT SYMBOL)))
(SETF (GET 'MENU-CONNS-FIND-CONNS 'GLFNRESULTTYPE) '(LISTOF MENU-PORT))
@@ -433,7 +498,11 @@
"glisp/menu-set-header.lsp")
(COMPILE-FILE "glisp/menu-settrans.lsp"))
-(IN-PACKAGE :USER)
+(DEFUN COMPILE-MENU-SETB ()
+ (GLCOMPFILES *DIRECTORY*
+ '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp")
+ '("glisp/menu-set.lsp") "glisp/menu-settrans.lsp"
+ "glisp/menu-set-header.lsp"))
(DEFVAR *DRAW-WINDOW* NIL)
@@ -539,11 +608,11 @@
((RADIUSX ((X SIZE) / 2)) (RADIUSY ((Y SIZE) / 2))
(RADIUS ((MAX RADIUSX RADIUSY))) (CENTER (OFFSET + SIZE / 2))
(DELTA ((SQRT (ABS (RADIUSX ^ 2 - RADIUSY ^ 2)))))
- (P1 ((IF (RADIUSX > RADIUSY) THEN
- (A VECTOR X = (X CENTER) - DELTA Y = (Y CENTER)) ELSE
+ (P1 ((IF (RADIUSX > RADIUSY)
+ (A VECTOR X = (X CENTER) - DELTA Y = (Y CENTER))
(A VECTOR X = (X CENTER) Y = (Y CENTER) - DELTA))))
- (P2 ((IF (RADIUSX > RADIUSY) THEN
- (A VECTOR X = (X CENTER) + DELTA Y = (Y CENTER)) ELSE
+ (P2 ((IF (RADIUSX > RADIUSY)
+ (A VECTOR X = (X CENTER) + DELTA Y = (Y CENTER))
(A VECTOR X = (X CENTER) Y = (Y CENTER) + DELTA)))))
MSG
((DRAW DRAW-ELLIPSE-DRAW) (SNAP DRAW-ELLIPSE-SNAP)
@@ -596,12 +665,13 @@
(DEFUN DRAW-DESC (NAME)
(LET (DD)
(SETQ DD (DRAW-DESCR NAME))
- (UNLESS DD
+ (WHEN (NOT DD)
(SETQ DD
(LIST 'DRAW-DESC NAME NIL (COPY-LIST '(0 0))
(COPY-LIST '(0 0))))
(SETF (DRAW-DESCR NAME) DD))
DD))
+(SETF (GET 'DRAW-DESC 'GLARGUMENTS) '((NAME SYMBOL)))
(SETF (GET 'DRAW-DESC 'GLFNRESULTTYPE) 'DRAW-DESC)
@@ -616,17 +686,13 @@
(DEFUN DRAW (NAME)
(LET (W DD DONE SEL (REDRAW T) NEW)
(SETQ W (DRAW-WINDOW))
- (XMAPWINDOW *WINDOW-DISPLAY* (CADR W))
- (XFLUSH *WINDOW-DISPLAY*)
- (WINDOW-WAIT-EXPOSURE W)
+ (WINDOW-OPEN W)
(OR *DRAW-MENU-SET* (DRAW-INIT-MENUS))
(SETQ DD (DRAW-DESC NAME))
(UNLESS (MEMBER NAME *DRAW-OBJECTS*)
(SETQ *DRAW-OBJECTS* (NCONC *DRAW-OBJECTS* (LIST NAME))))
(DRAW-DESC-DRAW DD W)
- (TAGBODY
- GLLABEL4253
- (UNLESS DONE
+ (WHILE (NOT DONE)
(SETQ SEL (MENU-SET-SELECT *DRAW-MENU-SET* REDRAW))
(SETQ REDRAW NIL)
(CASE (CADR SEL)
@@ -635,17 +701,14 @@
(MOVE (DRAW-DESC-MOVE DD W))
(DELETE (DRAW-DESC-DELETE DD W))
(COPY (DRAW-DESC-COPY DD W))
- (REDRAW (XCLEARWINDOW *WINDOW-DISPLAY* (CADR W))
- (XFLUSH *WINDOW-DISPLAY*) (SETQ REDRAW T)
+ (REDRAW (WINDOW-CLEAR W) (SETQ REDRAW T)
(DRAW-DESC-DRAW DD W))
(ORIGIN (DRAW-DESC-ORIGIN DD W)
- (XCLEARWINDOW *WINDOW-DISPLAY* (CADR W))
- (XFLUSH *WINDOW-DISPLAY*) (SETQ REDRAW T)
+ (WINDOW-CLEAR W) (SETQ REDRAW T)
(DRAW-DESC-DRAW DD W))
(PROGRAM (DRAW-DESC-PROGRAM DD))
(LATEX (DRAW-DESC-LATEX DD))
- (LATEXMODE
- (SETQ *DRAW-LATEX-MODE*
+ (LATEXMODE (SETQ *DRAW-LATEX-MODE*
(NOT *DRAW-LATEX-MODE*))
(FORMAT T "Latex Mode is now ~A~%"
*DRAW-LATEX-MODE*))))
@@ -664,29 +727,24 @@
(REFPT (SETQ NEW (DRAW-REFPT-GET DD W))))
(WHEN NEW
(SETF (CADR NEW)
- (LET ((GLVAR4251 (CADR NEW))
- (GLVAR4252 (CADDDR DD)))
- (LIST (- (CAR GLVAR4251) (CAR GLVAR4252))
- (- (CADR GLVAR4251) (CADR GLVAR4252)))))
- (SETF (CADDR DD) (NCONC (CADDR DD) (CONS NEW NIL)))
+ (LIST (- (CAADR NEW) (CAR (CADDDR DD)))
+ (- (CADADR NEW) (CADR (CADDDR DD)))))
+ (SETF (CADDR DD)
+ (NCONC (CADDR DD) (CONS NEW NIL)))
(DRAW-OBJECT-DRAW NEW W (CADDDR DD))))
- (BACKGROUND))
- (GO GLLABEL4253)))
+ (BACKGROUND)))
(SETF (DRAW-DESCR NAME) DD)
- (UNLESS *DRAW-LEAVE-WINDOW*
- (PROGN
- (XUNMAPWINDOW *WINDOW-DISPLAY* (CADR W))
- (XFLUSH *WINDOW-DISPLAY*)
- (WINDOW-WAIT-UNMAP W)))
+ (UNLESS *DRAW-LEAVE-WINDOW* (WINDOW-CLOSE W))
NAME))
+(SETF (GET 'DRAW 'GLARGUMENTS) '((NAME SYMBOL)))
(SETF (GET 'DRAW 'GLFNRESULTTYPE) 'SYMBOL)
(DEFUN DRAW-DESC-DRAW (DD W)
- (XCLEARWINDOW *WINDOW-DISPLAY* (CADR W))
- (XFLUSH *WINDOW-DISPLAY*)
- (DOLIST (OBJ (CADDR DD)) (DRAW-OBJECT-DRAW OBJ W (CADDDR DD)))
- (XFLUSH *WINDOW-DISPLAY*))
+ (LET ((OFF (CADDDR DD)))
+ (WINDOW-CLEAR W)
+ (DOLIST (OBJ (CADDR DD)) (DRAW-OBJECT-DRAW OBJ W OFF))
+ (WINDOW-FORCE-OUTPUT W)))
(DEFUN DRAW-DESC-SELECTED (DD P)
(LET (OBJS OBJSB OBJ)
@@ -696,7 +754,7 @@
(CONS OBJ NIL)))
(CADDR DD)))
(IF OBJS
- (IF (REST OBJS)
+ (IF (NULL (REST OBJS)) (SETQ OBJ (FIRST OBJS))
(PROGN
(SETQ OBJSB
(MAPCAN #'(LAMBDA (Z)
@@ -705,32 +763,35 @@
(CONS Z NIL)))
OBJS))
(IF (AND OBJSB (NULL (REST OBJSB)))
- (SETQ OBJ (FIRST OBJSB))))
- (SETQ OBJ (FIRST OBJS))))
+ (SETQ OBJ (FIRST OBJSB))))))
OBJ))
+(SETF (GET 'DRAW-DESC-SELECTED 'GLARGUMENTS)
+ '((DD DRAW-DESC) (P VECTOR)))
(SETF (GET 'DRAW-DESC-SELECTED 'GLFNRESULTTYPE) 'DRAW-OBJECT)
(DEFUN DRAW-DESC-FIND (DD W &OPTIONAL CROSSFLG)
(LET (P OBJ)
- (TAGBODY
- GLLABEL4254
- (UNLESS OBJ
+ (WHILE (NOT OBJ)
(SETQ P
(IF CROSSFLG (DRAW-GET-CROSS DD W)
(DRAW-GET-CROSSHAIRS DD W)))
- (SETQ OBJ (DRAW-DESC-SELECTED DD P))
- (GO GLLABEL4254)))
+ (SETQ OBJ (DRAW-DESC-SELECTED DD P)))
OBJ))
+(SETF (GET 'DRAW-DESC-FIND 'GLARGUMENTS)
+ '((DD DRAW-DESC) (W WINDOW) (&OPTIONAL NIL) (CROSSFLG BOOLEAN)))
(SETF (GET 'DRAW-DESC-FIND 'GLFNRESULTTYPE) 'DRAW-OBJECT)
(DEFUN DRAW-GET-CROSS (DD W) (DRAW-DESC-SNAP DD (WINDOW-GET-CROSS W)))
+(SETF (GET 'DRAW-GET-CROSS 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-GET-CROSS 'GLFNRESULTTYPE) 'VECTOR)
(DEFUN DRAW-GET-CROSSHAIRS (DD W)
(DRAW-DESC-SNAP DD (WINDOW-GET-CROSSHAIRS W)))
+(SETF (GET 'DRAW-GET-CROSSHAIRS 'GLARGUMENTS)
+ '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-GET-CROSSHAIRS 'GLFNRESULTTYPE) 'VECTOR)
@@ -739,6 +800,8 @@
(SETQ OBJ (DRAW-DESC-FIND DD W T))
(DRAW-OBJECT-ERASE OBJ W (CADDDR DD))
(SETF (CADDR DD) (REMOVE OBJ (CADDR DD)))))
+(SETF (GET 'DRAW-DESC-DELETE 'GLARGUMENTS)
+ '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-DESC-DELETE 'GLFNRESULTTYPE) '(LISTOF DRAW-OBJECT))
@@ -748,12 +811,12 @@
(SETQ OBJB (COPY-TREE OBJ))
(DRAW-GET-OBJECT-POS OBJB W)
(SETF (CADR OBJB)
- (LET ((GLVAR4255 (CADR OBJB)) (GLVAR4256 (CADDDR DD)))
- (LIST (- (CAR GLVAR4255) (CAR GLVAR4256))
- (- (CADR GLVAR4255) (CADR GLVAR4256)))))
+ (LIST (- (CAADR OBJB) (CAR (CADDDR DD)))
+ (- (CADADR OBJB) (CADR (CADDDR DD)))))
(DRAW-OBJECT-DRAW OBJB W (CADDDR DD))
- (XFLUSH *WINDOW-DISPLAY*)
+ (WINDOW-FORCE-OUTPUT W)
(SETF (CADDR DD) (NCONC (CADDR DD) (CONS OBJB NIL)))))
+(SETF (GET 'DRAW-DESC-COPY 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-DESC-COPY 'GLFNRESULTTYPE) '(LISTOF DRAW-OBJECT))
@@ -765,13 +828,14 @@
(DEFUN DRAW-DESC-ORIGIN (DD W)
(LET (SEL)
(DRAW-DESC-BOUNDS DD)
- (SETQ SEL (MENU '(("To zero" . ZERO) ("Select" . SELECT))))
- (COND
- ((EQ SEL 'SELECT)
+ (SETQ SEL (MENU '(("To zero" . TOZERO) ("Select" . SELECT))))
+ (IF (EQ SEL 'SELECT)
(SETF (CADDDR DD)
(WINDOW-GET-BOX-POSITION W (CAR (FIFTH DD))
- (CADR (FIFTH DD)))))
- ((EQ SEL 'ZERO) (SETF (CADDDR DD) (COPY-LIST '(0 0)))))))
+ (CADR (FIFTH DD))))
+ (IF (EQ SEL 'TOZERO) (SETF (CADDDR DD) (COPY-LIST '(0 0)))))))
+(SETF (GET 'DRAW-DESC-ORIGIN 'GLARGUMENTS)
+ '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-DESC-ORIGIN 'GLFNRESULTTYPE) 'VECTOR)
@@ -790,20 +854,18 @@
(SETF (CADDDR DD) BASEV)
(DOLIST (OBJ (CADDR DD))
(SETF (CADR OBJ)
- (LET ((GLVAR4257 (CADR OBJ)))
- (LIST (- (CAR GLVAR4257) (CAR BASEV))
- (- (CADR GLVAR4257) (CADR BASEV))))))))
+ (LIST (- (CAADR OBJ) (CAR BASEV))
+ (- (CADADR OBJ) (CADR BASEV)))))))
(DEFUN DRAW-DESC-LATEX (DD)
(LET (BASE BX BY SX SY)
- (FORMAT T " \\begin{picture}(~5,2F,~5,2F)(0,0)~%"
+ (FORMAT T " \\begin{picture}(~5,0F,~5,0F)(0,0)~%"
(* (CAR (FIFTH DD)) *DRAW-LATEX-FACTOR*)
(* (CADR (FIFTH DD)) *DRAW-LATEX-FACTOR*))
(DOLIST (OBJ (CADDR DD))
(SETQ BASE
- (LET ((GLVAR4260 (CADDDR DD)) (GLVAR4261 (CADR OBJ)))
- (LIST (+ (CAR GLVAR4260) (CAR GLVAR4261))
- (+ (CADR GLVAR4260) (CADR GLVAR4261)))))
+ (LIST (+ (CAR (CADDDR DD)) (CAADR OBJ))
+ (+ (CADR (CADDDR DD)) (CADADR OBJ))))
(SETQ BX (* (CAR BASE) *DRAW-LATEX-FACTOR*))
(SETQ BY (* (CADR BASE) *DRAW-LATEX-FACTOR*))
(SETQ SX (* (CAADDR OBJ) *DRAW-LATEX-FACTOR*))
@@ -817,27 +879,27 @@
(+ (CADR BASE) SY) T))
(DRAW-BOX
(FORMAT T
- " \\put(~5,2F,~5,2F) {\\framebox(~5,2F,~5,2F)}~%"
+ " \\put(~5,0F,~5,0F) {\\framebox(~5,0F,~5,0F)}~%"
BX BY SX SY))
(DRAW-RCBOX
- (FORMAT T " \\put(~5,2F,~5,2F) {\\oval(~5,2F,~5,2F)}~%"
+ (FORMAT T " \\put(~5,0F,~5,0F) {\\oval(~5,0F,~5,0F)}~%"
(+ BX (/ SX 2)) (+ BY (/ SY 2)) SX SY))
(DRAW-CIRCLE
- (FORMAT T " \\put(~5,2F,~5,2F) {\\circle{~5,2F}}~%"
+ (FORMAT T " \\put(~5,0F,~5,0F) {\\circle{~5,0F}}~%"
(+ BX (/ SX 2)) (+ BY (/ SY 2)) SX))
(DRAW-ELLIPSE
- (FORMAT T " \\put(~5,2F,~5,2F) {\\oval(~5,2F,~5,2F)}~%"
+ (FORMAT T " \\put(~5,0F,~5,0F) {\\oval(~5,0F,~5,0F)}~%"
(+ BX (/ SX 2)) (+ BY (/ SY 2)) SX SY))
(DRAW-BUTTON
(FORMAT T
- " \\put(~5,2F,~5,2F) {\\framebox(~5,2F,~5,2F)}~%"
+ " \\put(~5,0F,~5,0F) {\\framebox(~5,0F,~5,0F)}~%"
BX BY SX SY))
(DRAW-ERASE)
(DRAW-DOT
- (FORMAT T " \\put(~5,2F,~5,2F) {\\circle*{~5,2F}}~%"
+ (FORMAT T " \\put(~5,0F,~5,0F) {\\circle*{~5,0F}}~%"
(+ BX (/ SX 2)) (+ BY (/ SY 2)) SX))
(DRAW-TEXT
- (FORMAT T " \\put(~5,2F,~5,2F) {~A}~%" BX
+ (FORMAT T " \\put(~5,0F,~5,0F) {~A}~%" BX
(+ BY (* 4 *DRAW-LATEX-FACTOR*)) (CADDDR OBJ)))))
(FORMAT T " \\end{picture}~%")))
@@ -849,21 +911,18 @@
(PROGN
(SETQ BASE
(LET
- ((GLVAR4264
- (LET
- ((GLVAR4262 (CADDDR DD))
- (GLVAR4263 (CADR OBJ)))
+ ((GLVAR25425
(LIST
- (+ (CAR GLVAR4262)
- (CAR GLVAR4263))
- (+ (CADR GLVAR4262)
- (CADR GLVAR4263)))))
- (GLVAR4265 (DRAW-DESC-REFPT DD)))
+ (+ (CAR (CADDDR DD))
+ (CAADR OBJ))
+ (+ (CADR (CADDDR DD))
+ (CADADR OBJ))))
+ (GLVAR25428 (DRAW-DESC-REFPT DD)))
(LIST
- (- (CAR GLVAR4264)
- (CAR GLVAR4265))
- (- (CADR GLVAR4264)
- (CADR GLVAR4265)))))
+ (- (CAR GLVAR25425)
+ (CAR GLVAR25428))
+ (- (CADR GLVAR25425)
+ (CADR GLVAR25428)))))
(SETQ BX (CAR BASE))
(SETQ BY (CADR BASE))
(SETQ SX (CAADDR OBJ))
@@ -871,12 +930,10 @@
(SETQ TOX (+ BX SX))
(SETQ TOY (+ BY SY))
(IF (EQ (CAR OBJ) 'DRAW-CIRCLE)
- (SETQ R (TRUNCATE (CAADDR OBJ) 2)))
+ (SETQ R (/ (CAADDR OBJ) 2)))
(WHEN (EQ (CAR OBJ) 'DRAW-ELLIPSE)
- (SETQ RX
- (TRUNCATE (CAADDR OBJ) 2))
- (SETQ RY
- (TRUNCATE (CADR (CADDR OBJ)) 2)))
+ (SETQ RX (/ (CAADDR OBJ) 2))
+ (SETQ RY (/ (CADR (CADDR OBJ)) 2)))
(DRAW-OPTIMIZE
(CASE (FIRST OBJ)
(DRAW-LINE
@@ -931,6 +988,7 @@
(SETF (SYMBOL-FUNCTION FNNAME) FNCODE)
(FORMAT T "Constructed program (~A w x y)~%" FNNAME)
(DRAW-DESC-PICMENU DD)))
+(SETF (GET 'DRAW-DESC-PROGRAM 'GLARGUMENTS) '((DD DRAW-DESC)))
(SETF (GET 'DRAW-DESC-PROGRAM 'GLFNRESULTTYPE)
'(LIST GLTYPE INTEGER INTEGER (LISTOF (LIST ANYTHING VECTOR))
BOOLEAN SYMBOL SYMBOL))
@@ -940,6 +998,7 @@
(DEFUN DRAW-DESC-FNNAME (DD)
(INTERN (CONCATENATE 'STRING "DRAW-" (SYMBOL-NAME (CADR DD)))))
+(SETF (GET 'DRAW-DESC-FNNAME 'GLARGUMENTS) '((DD DRAW-DESC)))
(SETF (GET 'DRAW-DESC-FNNAME 'GLFNRESULTTYPE) 'SYMBOL)
@@ -950,28 +1009,27 @@
(AND (EQ (FIRST OBJ) 'DRAW-BUTTON)
(CONS (LIST (CADDDR OBJ)
(LET
- ((GLVAR4268
+ ((GLVAR25733
(LET
- ((GLVAR4266
- (COPY-LIST '(2 2)))
- (GLVAR4267 (CADR OBJ)))
+ ((GLVAR25709
+ (COPY-LIST '(2 2))))
(LIST
- (+ (CAR GLVAR4266)
- (CAR GLVAR4267))
- (+ (CADR GLVAR4266)
- (CADR GLVAR4267)))))
- (GLVAR4269 (CADDDR DD)))
+ (+ (CAR GLVAR25709)
+ (CAADR OBJ))
+ (+ (CADR GLVAR25709)
+ (CADADR OBJ))))))
(LIST
- (+ (CAR GLVAR4268)
- (CAR GLVAR4269))
- (+ (CADR GLVAR4268)
- (CADR GLVAR4269)))))
+ (+ (CAR GLVAR25733)
+ (CAR (CADDDR DD)))
+ (+ (CADR GLVAR25733)
+ (CADR (CADDDR DD))))))
NIL)))
(CADDR DD)))
(IF BUTTONS
(SETF (GET (CADR DD) 'PICMENU-SPEC)
(LIST 'PICMENU-SPEC (CAR (FIFTH DD)) (CADR (FIFTH DD))
BUTTONS T (DRAW-DESC-FNNAME DD) '9X15)))))
+(SETF (GET 'DRAW-DESC-PICMENU 'GLARGUMENTS) '((DD DRAW-DESC)))
(SETF (GET 'DRAW-DESC-PICMENU 'GLFNRESULTTYPE)
'(LIST GLTYPE INTEGER INTEGER (LISTOF (LIST ANYTHING VECTOR))
BOOLEAN SYMBOL SYMBOL))
@@ -980,13 +1038,10 @@
(DEFUN DRAW-DESC-SNAP (DD P)
(LET (PSNAP OBJ (OBJS (CADDR DD)))
(IF *DRAW-SNAP-FLAG*
- (TAGBODY
- GLLABEL4270
- (WHEN (AND OBJS (NOT PSNAP))
- (SETQ OBJ (POP OBJS))
- (SETQ PSNAP (DRAW-OBJECT-SNAP OBJ P (CADDDR DD)))
- (GO GLLABEL4270))))
+ (WHILE (AND OBJS (NOT PSNAP)) (SETQ OBJ (POP OBJS))
+ (SETQ PSNAP (DRAW-OBJECT-SNAP OBJ P (CADDDR DD)))))
(OR PSNAP P)))
+(SETF (GET 'DRAW-DESC-SNAP 'GLARGUMENTS) '((DD DRAW-DESC) (P VECTOR)))
(SETF (GET 'DRAW-DESC-SNAP 'GLFNRESULTTYPE) 'VECTOR)
@@ -994,11 +1049,9 @@
(DRAW-OBJECT-ERASE D W OFF)
(DRAW-GET-OBJECT-POS D W)
(SETF (CADR D)
- (LET ((GLVAR4271 (CADR D)))
- (LIST (- (CAR GLVAR4271) (CAR OFF))
- (- (CADR GLVAR4271) (CADR OFF)))))
+ (LIST (- (CAADR D) (CAR OFF)) (- (CADADR D) (CADR OFF))))
(DRAW-OBJECT-DRAW D W OFF)
- (XFLUSH *WINDOW-DISPLAY*))
+ (WINDOW-FORCE-OUTPUT W))
(DEFUN DRAW-OBJECT-DRAW-AT (W X Y D)
(SETF (SECOND D) (LIST X Y))
@@ -1018,61 +1071,33 @@
(IF (EQ (FIRST D) 'DRAW-TEXT) #'DRAW-TEXT-DRAW-OUTLINE
#'DRAW-OBJECT-DRAW-AT)
(LIST D)))
+(SETF (GET 'DRAW-GET-OBJECT-POS 'GLARGUMENTS)
+ '((D DRAW-OBJECT) (W WINDOW)))
(SETF (GET 'DRAW-GET-OBJECT-POS 'GLFNRESULTTYPE) 'VECTOR)
(DEFUN DRAW-OBJECT-ERASE (D W OFF)
- (UNLESS (EQ (FIRST D) 'DRAW-ERASE)
- (LET ((GC (CADDR W)))
- (SETQ *WINDOW-SAVE-FUNCTION*
- (PROGN
- (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) GCFUNCTION
- *GC-VALUES*)
- (XGCVALUES-FUNCTION *GC-VALUES*)))
- (XSETFUNCTION *WINDOW-DISPLAY* GC GXXOR)
- (SETQ *WINDOW-SAVE-FOREGROUND*
- (PROGN
- (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) GCFOREGROUND
- *GC-VALUES*)
- (XGCVALUES-FOREGROUND *GC-VALUES*)))
- (XSETFOREGROUND *WINDOW-DISPLAY* GC
- (LOGXOR *WINDOW-SAVE-FOREGROUND*
- (PROGN
- (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W)
- GCBACKGROUND *GC-VALUES*)
- (XGCVALUES-BACKGROUND *GC-VALUES*)))))
+ (WHEN (NOT (EQ (FIRST D) 'DRAW-ERASE))
+ (WINDOW-SET-XOR W)
(DRAW-OBJECT-DRAW D W OFF)
- (LET ((GC (CADDR W)))
- (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*)
- (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))))
+ (WINDOW-UNSET W)))
(DEFUN DRAW-LINE-DRAW (D W OFF)
- (LET ((FROM (LET ((GLVAR4272 (CADR D)))
- (LIST (+ (CAR OFF) (CAR GLVAR4272))
- (+ (CADR OFF) (CADR GLVAR4272)))))
- (TO (LET ((GLVAR4274
- (LET ((GLVAR4273 (CADR D)))
- (LIST (+ (CAR OFF) (CAR GLVAR4273))
- (+ (CADR OFF) (CADR GLVAR4273)))))
- (GLVAR4275 (CADDR D)))
- (LIST (+ (CAR GLVAR4274) (CAR GLVAR4275))
- (+ (CADR GLVAR4274) (CADR GLVAR4275))))))
- (LET ((QQWHEIGHT (CADDDR W)))
- (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (CAR FROM)
- (- QQWHEIGHT (CADR FROM)) (CAR TO) (- QQWHEIGHT (CADR TO)))
- NIL)))
+ (LET ((FROM (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D))))
+ (TO (LET ((GLVAR26041
+ (LIST (+ (CAR OFF) (CAADR D))
+ (+ (CADR OFF) (CADADR D)))))
+ (LIST (+ (CAR GLVAR26041) (CAADDR D))
+ (+ (CADR GLVAR26041) (CADR (CADDR D)))))))
+ (WINDOW-DRAW-LINE-XY W (CAR FROM) (CADR FROM) (CAR TO) (CADR TO))))
(DEFUN DRAW-ARROW-DRAW (D W OFF)
- (LET ((FROM (LET ((GLVAR4280 (CADR D)))
- (LIST (+ (CAR OFF) (CAR GLVAR4280))
- (+ (CADR OFF) (CADR GLVAR4280)))))
- (TO (LET ((GLVAR4282
- (LET ((GLVAR4281 (CADR D)))
- (LIST (+ (CAR OFF) (CAR GLVAR4281))
- (+ (CADR OFF) (CADR GLVAR4281)))))
- (GLVAR4283 (CADDR D)))
- (LIST (+ (CAR GLVAR4282) (CAR GLVAR4283))
- (+ (CADR GLVAR4282) (CADR GLVAR4283))))))
+ (LET ((FROM (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D))))
+ (TO (LET ((GLVAR26179
+ (LIST (+ (CAR OFF) (CAADR D))
+ (+ (CADR OFF) (CADADR D)))))
+ (LIST (+ (CAR GLVAR26179) (CAADDR D))
+ (+ (CADR GLVAR26179) (CADR (CADDR D)))))))
(WINDOW-DRAW-ARROW-XY W (CAR FROM) (CADR FROM) (CAR TO) (CADR TO))))
(DEFUN DRAW-LINE-SELECTEDP (D PT OFF)
@@ -1086,11 +1111,13 @@
(+ 2
(+ (+ (CADADR D) (MIN 0 (CADR (CADDR D))))
(ABS (CADR (CADDR D))))))
- (< (ABS (LET ((DX (CAADDR D)) (DY (CADR (CADDR D))))
- (/ (- (* DX (- (CADR PTP) (CADADR D)))
- (* DY (- (CAR PTP) (CAADR D))))
- (SQRT (+ (EXPT DX 2) (EXPT DY 2))))))
+ (< (ABS (/ (- (* (CAADDR D) (- (CADR PTP) (CADADR D)))
+ (* (CADR (CADDR D)) (- (CAR PTP) (CAADR D))))
+ (SQRT (+ (EXPT (CAADDR D) 2)
+ (EXPT (CADR (CADDR D)) 2)))))
5))))
+(SETF (GET 'DRAW-LINE-SELECTEDP 'GLARGUMENTS)
+ '((D DRAW-LINE) (PT VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-LINE-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN)
@@ -1105,6 +1132,7 @@
(LIST 'DRAW-LINE FROM
(LIST (- (CAR TO) (CAR FROM)) (- (CADR TO) (CADR FROM))) NIL
0)))
+(SETF (GET 'DRAW-LINE-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-LINE-GET 'GLFNRESULTTYPE) 'DRAW-LINE)
@@ -1119,17 +1147,14 @@
(LIST 'DRAW-ARROW FROM
(LIST (- (CAR TO) (CAR FROM)) (- (CADR TO) (CADR FROM))) NIL
0)))
+(SETF (GET 'DRAW-ARROW-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-ARROW-GET 'GLFNRESULTTYPE) 'DRAW-ARROW)
(DEFUN DRAW-BOX-DRAW (D W OFF)
- (LET ((GLVAR4289
- (LET ((GLVAR4288 (CADR D)))
- (LIST (+ (CAR OFF) (CAR GLVAR4288))
- (+ (CADR OFF) (CADR GLVAR4288)))))
- (GLVAR4290 (CADDR D)))
- (WINDOW-DRAW-BOX-XY W (CAR GLVAR4289) (CADR GLVAR4289)
- (CAR GLVAR4290) (CADR GLVAR4290) NIL)))
+ (WINDOW-DRAW-BOX W
+ (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D)))
+ (CADDR D)))
(DEFUN DRAW-BOX-SELECTEDP (D P OFF)
(LET ((PT (LIST (- (CAR P) (CAR OFF)) (- (CADR P) (CADR OFF)))))
@@ -1163,6 +1188,8 @@
(- (CADR PT)
(+ (CADADR D) (MIN 0 (CADR (CADDR D)))))))
5))))))
+(SETF (GET 'DRAW-BOX-SELECTEDP 'GLARGUMENTS)
+ '((D DRAW-BOX) (P VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-BOX-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN)
@@ -1170,6 +1197,7 @@
(LET (BOX)
(SETQ BOX (WINDOW-GET-REGION W))
(LIST 'DRAW-BOX (CAR BOX) (CADR BOX) NIL 0)))
+(SETF (GET 'DRAW-BOX-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-BOX-GET 'GLFNRESULTTYPE) 'DRAW-BOX)
@@ -1206,6 +1234,8 @@
(- (CADR PT)
(+ (CADADR D) (MIN 0 (CADR (CADDR D)))))))
5))))))
+(SETF (GET 'DRAW-RCBOX-SELECTEDP 'GLARGUMENTS)
+ '((D DRAW-BOX) (P VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-RCBOX-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN)
@@ -1213,50 +1243,46 @@
(LET (BOX)
(SETQ BOX (WINDOW-GET-REGION W))
(LIST 'DRAW-RCBOX (CAR BOX) (CADR BOX) NIL 0)))
+(SETF (GET 'DRAW-RCBOX-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-RCBOX-GET 'GLFNRESULTTYPE) 'DRAW-RCBOX)
(DEFUN DRAW-CIRCLE-DRAW (D W OFF)
- (LET ((GLVAR4295
- (LET ((GLVAR4294
- (LET ((GLVAR4292 (CADR D))
- (GLVAR4293
- (LET ((GLVAR4291 (CADDR D)))
- (LIST (TRUNCATE (CAR GLVAR4291) 2)
- (TRUNCATE (CADR GLVAR4291) 2)))))
- (LIST (+ (CAR GLVAR4292) (CAR GLVAR4293))
- (+ (CADR GLVAR4292) (CADR GLVAR4293))))))
- (LIST (+ (CAR OFF) (CAR GLVAR4294))
- (+ (CADR OFF) (CADR GLVAR4294))))))
- (WINDOW-DRAW-CIRCLE-XY W (CAR GLVAR4295) (CADR GLVAR4295)
- (TRUNCATE (CAADDR D) 2) NIL)))
+ (WINDOW-DRAW-CIRCLE W
+ (LET ((GLVAR27825
+ (LET ((GLVAR27802
+ (LIST (/ (CAADDR D) 2)
+ (/ (CADR (CADDR D)) 2))))
+ (LIST (+ (CAADR D) (CAR GLVAR27802))
+ (+ (CADADR D) (CADR GLVAR27802))))))
+ (LIST (+ (CAR OFF) (CAR GLVAR27825))
+ (+ (CADR OFF) (CADR GLVAR27825))))
+ (/ (CAADDR D) 2)))
(DEFUN DRAW-CIRCLE-SELECTEDP (D P OFF)
- (< (ABS (- (TRUNCATE (CAADDR D) 2)
- (LET ((SELF (LET ((GLVAR4301
+ (< (ABS (- (/ (CAADDR D) 2)
+ (SQRT (LET ((SELF (LET ((GLVAR27972
(LET
- ((GLVAR4300
+ ((GLVAR27949
(LET
- ((GLVAR4298 (CADR D))
- (GLVAR4299
- (LET ((GLVAR4297 (CADDR D)))
- (LIST
- (TRUNCATE (CAR GLVAR4297)
- 2)
- (TRUNCATE (CADR GLVAR4297)
- 2)))))
+ ((GLVAR27928
+ (LIST (/ (CAADDR D) 2)
+ (/ (CADR (CADDR D)) 2))))
(LIST
- (+ (CAR GLVAR4298)
- (CAR GLVAR4299))
- (+ (CADR GLVAR4298)
- (CADR GLVAR4299))))))
+ (+ (CAADR D)
+ (CAR GLVAR27928))
+ (+ (CADADR D)
+ (CADR GLVAR27928))))))
(LIST
- (+ (CAR GLVAR4300) (CAR OFF))
- (+ (CADR GLVAR4300) (CADR OFF))))))
- (LIST (- (CAR GLVAR4301) (CAR P))
- (- (CADR GLVAR4301) (CADR P))))))
- (SQRT (+ (EXPT (CAR SELF) 2) (EXPT (CADR SELF) 2))))))
+ (+ (CAR GLVAR27949) (CAR OFF))
+ (+ (CADR GLVAR27949)
+ (CADR OFF))))))
+ (LIST (- (CAR GLVAR27972) (CAR P))
+ (- (CADR GLVAR27972) (CADR P))))))
+ (+ (EXPT (CAR SELF) 2) (EXPT (CADR SELF) 2))))))
5))
+(SETF (GET 'DRAW-CIRCLE-SELECTEDP 'GLARGUMENTS)
+ '((D DRAW-CIRCLE) (P VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-CIRCLE-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN)
@@ -1267,111 +1293,100 @@
(LIST 'DRAW-CIRCLE
(LIST (- (CAAR CIR) (CADR CIR)) (- (CADAR CIR) (CADR CIR)))
(LIST (* 2 (CADR CIR)) (* 2 (CADR CIR))) NIL 0)))
+(SETF (GET 'DRAW-CIRCLE-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-CIRCLE-GET 'GLFNRESULTTYPE) 'DRAW-CIRCLE)
(DEFUN DRAW-ELLIPSE-DRAW (D W OFF)
- (LET ((C (LET ((GLVAR4305
- (LET ((GLVAR4303 (CADR D))
- (GLVAR4304
- (LET ((GLVAR4302 (CADDR D)))
- (LIST (TRUNCATE (CAR GLVAR4302) 2)
- (TRUNCATE (CADR GLVAR4302) 2)))))
- (LIST (+ (CAR GLVAR4303) (CAR GLVAR4304))
- (+ (CADR GLVAR4303) (CADR GLVAR4304))))))
- (LIST (+ (CAR OFF) (CAR GLVAR4305))
- (+ (CADR OFF) (CADR GLVAR4305))))))
- (LET ((GLVAR4308 (TRUNCATE (CAADDR D) 2))
- (GLVAR4309 (TRUNCATE (CADR (CADDR D)) 2)))
- (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W)
- (- (CAR C) GLVAR4308) (- (CADDDR W) (+ (CADR C) GLVAR4309))
- (* 2 GLVAR4308) (* 2 GLVAR4309) 0 23040)
- NIL)))
+ (LET ((C (LET ((GLVAR28162
+ (LET ((GLVAR28139
+ (LIST (/ (CAADDR D) 2)
+ (/ (CADR (CADDR D)) 2))))
+ (LIST (+ (CAADR D) (CAR GLVAR28139))
+ (+ (CADADR D) (CADR GLVAR28139))))))
+ (LIST (+ (CAR OFF) (CAR GLVAR28162))
+ (+ (CADR OFF) (CADR GLVAR28162))))))
+ (WINDOW-DRAW-ELLIPSE-XY W (CAR C) (CADR C) (/ (CAADDR D) 2)
+ (/ (CADR (CADDR D)) 2))))
(DEFUN DRAW-ELLIPSE-SELECTEDP (D P OFF)
(LET ((PT (LIST (- (CAR P) (CAR OFF)) (- (CADR P) (CADR OFF)))))
- (< (ABS (- (+ (LET ((SELF (LET ((GLVAR4323
+ (< (ABS (- (+ (SQRT (LET ((SELF (LET
+ ((GLVAR28502
(IF
- (> (TRUNCATE (CAADDR D) 2)
- (TRUNCATE (CADR (CADDR D)) 2))
+ (> (/ (CAADDR D) 2)
+ (/ (CADR (CADDR D)) 2))
(LIST
(ROUND
(-
(+ (CAADR D)
- (TRUNCATE (CAADDR D) 2))
+ (/ (CAADDR D) 2))
(SQRT
(ABS
- (-
- (EXPT
- (TRUNCATE (CAADDR D) 2) 2)
- (EXPT
- (TRUNCATE (CADR (CADDR D))
- 2)
- 2))))))
+ (/
+ (- (EXPT (CAADDR D) 2)
+ (EXPT (CADR (CADDR D))
+ 2))
+ 4)))))
(+ (CADADR D)
- (TRUNCATE (CADR (CADDR D)) 2)))
+ (/ (CADR (CADDR D)) 2)))
(LIST
- (+ (CAADR D)
- (TRUNCATE (CAADDR D) 2))
+ (+ (CAADR D) (/ (CAADDR D) 2))
(ROUND
(-
(+ (CADADR D)
- (TRUNCATE (CADR (CADDR D)) 2))
+ (/ (CADR (CADDR D)) 2))
(SQRT
(ABS
- (-
- (EXPT
- (TRUNCATE (CAADDR D) 2) 2)
- (EXPT
- (TRUNCATE (CADR (CADDR D))
- 2)
- 2))))))))))
- (LIST (- (CAR GLVAR4323) (CAR PT))
- (- (CADR GLVAR4323) (CADR PT))))))
- (SQRT (+ (EXPT (CAR SELF) 2) (EXPT (CADR SELF) 2))))
- (LET ((SELF (LET ((GLVAR4336
+ (/
+ (- (EXPT (CAADDR D) 2)
+ (EXPT (CADR (CADDR D))
+ 2))
+ 4)))))))))
+ (LIST
+ (- (CAR GLVAR28502) (CAR PT))
+ (- (CADR GLVAR28502) (CADR PT))))))
+ (+ (EXPT (CAR SELF) 2) (EXPT (CADR SELF) 2))))
+ (SQRT (LET ((SELF (LET
+ ((GLVAR28750
(IF
- (> (TRUNCATE (CAADDR D) 2)
- (TRUNCATE (CADR (CADDR D)) 2))
+ (> (/ (CAADDR D) 2)
+ (/ (CADR (CADDR D)) 2))
(LIST
(ROUND
(+
(+ (CAADR D)
- (TRUNCATE (CAADDR D) 2))
+ (/ (CAADDR D) 2))
(SQRT
(ABS
- (-
- (EXPT
- (TRUNCATE (CAADDR D) 2) 2)
- (EXPT
- (TRUNCATE (CADR (CADDR D))
- 2)
- 2))))))
+ (/
+ (- (EXPT (CAADDR D) 2)
+ (EXPT (CADR (CADDR D))
+ 2))
+ 4)))))
(+ (CADADR D)
- (TRUNCATE (CADR (CADDR D)) 2)))
+ (/ (CADR (CADDR D)) 2)))
(LIST
- (+ (CAADR D)
- (TRUNCATE (CAADDR D) 2))
+ (+ (CAADR D) (/ (CAADDR D) 2))
(ROUND
(+
(+ (CADADR D)
- (TRUNCATE (CADR (CADDR D)) 2))
+ (/ (CADR (CADDR D)) 2))
(SQRT
(ABS
- (-
- (EXPT
- (TRUNCATE (CAADDR D) 2) 2)
- (EXPT
- (TRUNCATE (CADR (CADDR D))
- 2)
- 2))))))))))
- (LIST (- (CAR GLVAR4336) (CAR PT))
- (- (CADR GLVAR4336) (CADR PT))))))
- (SQRT (+ (EXPT (CAR SELF) 2) (EXPT (CADR SELF) 2)))))
- (* 2
- (MAX (TRUNCATE (CAADDR D) 2)
- (TRUNCATE (CADR (CADDR D)) 2)))))
+ (/
+ (- (EXPT (CAADDR D) 2)
+ (EXPT (CADR (CADDR D))
+ 2))
+ 4)))))))))
+ (LIST
+ (- (CAR GLVAR28750) (CAR PT))
+ (- (CADR GLVAR28750) (CADR PT))))))
+ (+ (EXPT (CAR SELF) 2) (EXPT (CADR SELF) 2)))))
+ (* 2 (MAX (/ (CAADDR D) 2) (/ (CADR (CADDR D)) 2)))))
2)))
+(SETF (GET 'DRAW-ELLIPSE-SELECTEDP 'GLARGUMENTS)
+ '((D DRAW-ELLIPSE) (P VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-ELLIPSE-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN)
@@ -1394,6 +1409,8 @@
(LIST (- (CAAR ELL) (CAADR ELL))
(- (CADAR ELL) (CADADR ELL)))
(LIST (* 2 (CAADR ELL)) (* 2 (CADADR ELL))) NIL 0)))
+(SETF (GET 'DRAW-ELLIPSE-GET 'GLARGUMENTS)
+ '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-ELLIPSE-GET 'GLFNRESULTTYPE) 'DRAW-ELLIPSE)
@@ -1402,18 +1419,16 @@
(DEFUN DRAW-NULL-SELECTEDP (D PT OFF) NIL)
(DEFUN DRAW-BUTTON-DRAW (D W OFF)
- (LET ((GLVAR4338
- (LET ((GLVAR4337 (CADR D)))
- (LIST (+ (CAR OFF) (CAR GLVAR4337))
- (+ (CADR OFF) (CADR GLVAR4337)))))
- (GLVAR4339 (COPY-LIST '(4 4))))
- (WINDOW-DRAW-BOX-XY W (CAR GLVAR4338) (CADR GLVAR4338)
- (CAR GLVAR4339) (CADR GLVAR4339) NIL)))
+ (WINDOW-DRAW-BOX W
+ (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D)))
+ (COPY-LIST '(4 4))))
(DEFUN DRAW-BUTTON-SELECTEDP (D P OFF)
(LET ((PTX (- (- (CAR P) (CAR OFF)) (CAADR D)))
(PTY (- (- (CADR P) (CADR OFF)) (CADADR D))))
(AND (> PTX -2) (< PTX 6) (> PTY -2) (< PTY 6))))
+(SETF (GET 'DRAW-BUTTON-SELECTEDP 'GLARGUMENTS)
+ '((D DRAW-BUTTON) (P VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-BUTTON-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN)
@@ -1424,23 +1439,22 @@
(SETQ CENT (DRAW-GET-CROSSHAIRS DD W))
(LIST 'DRAW-BUTTON (LIST (+ -2 (CAR CENT)) (+ -2 (CADR CENT)))
(COPY-LIST '(4 4)) VAR 0)))
+(SETF (GET 'DRAW-BUTTON-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-BUTTON-GET 'GLFNRESULTTYPE) 'DRAW-BUTTON)
(DEFUN DRAW-ERASE-DRAW (D W OFF)
- (LET ((GLVAR4341
- (LET ((GLVAR4340 (CADR D)))
- (LIST (+ (CAR OFF) (CAR GLVAR4340))
- (+ (CADR OFF) (CADR GLVAR4340)))))
- (GLVAR4342 (CADDR D)))
- (WINDOW-ERASE-AREA-XY W (CAR GLVAR4341) (CADR GLVAR4341)
- (CAR GLVAR4342) (CADR GLVAR4342))))
+ (WINDOW-ERASE-AREA W
+ (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D)))
+ (CADDR D)))
(DEFUN DRAW-ERASE-SELECTEDP (D P OFF)
(LET ((PT (LIST (- (CAR P) (CAR OFF)) (- (CADR P) (CADR OFF)))))
(AND (>= (CAR PT) (CAADR D)) (<= (CAR PT) (+ (CAADR D) (CAADDR D)))
(>= (CADR PT) (CADADR D))
(<= (CADR PT) (+ (CADADR D) (CADR (CADDR D)))))))
+(SETF (GET 'DRAW-ERASE-SELECTEDP 'GLARGUMENTS)
+ '((D DRAW-BOX) (P VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-ERASE-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN)
@@ -1448,6 +1462,7 @@
(LET (BOX)
(SETQ BOX (WINDOW-GET-REGION W))
(LIST 'DRAW-ERASE (CAR BOX) (CADR BOX) NIL 0)))
+(SETF (GET 'DRAW-ERASE-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-ERASE-GET 'GLFNRESULTTYPE) 'DRAW-ERASE)
@@ -1460,6 +1475,7 @@
(SETQ CENT (DRAW-GET-CROSSHAIRS DD W))
(LIST 'DRAW-DOT (LIST (+ -2 (CAR CENT)) (+ -2 (CADR CENT)))
(COPY-LIST '(4 4)) NIL 0)))
+(SETF (GET 'DRAW-DOT-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-DOT-GET 'GLFNRESULTTYPE) 'DRAW-DOT)
@@ -1471,36 +1487,21 @@
(LET ((PTX (- (- (CAR P) (CAR OFF)) (CAADR D)))
(PTY (- (- (CADR P) (CADR OFF)) (CADADR D))))
(AND (> PTX -3) (< PTX 3) (> PTY -3) (< PTY 3))))
+(SETF (GET 'DRAW-REFPT-SELECTEDP 'GLARGUMENTS)
+ '((D DRAW-BUTTON) (P VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-REFPT-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN)
(DEFUN DRAW-REFPT-GET (DD W)
(LET (CENT REFPT)
(WHEN (SETQ REFPT (ASSOC 'DRAW-REFPT (CADDR DD)))
- (LET ((GC (CADDR *DRAW-WINDOW*)))
- (SETQ *WINDOW-SAVE-FUNCTION*
- (PROGN
- (XGETGCVALUES *WINDOW-DISPLAY* (CADDR *DRAW-WINDOW*)
- GCFUNCTION *GC-VALUES*)
- (XGCVALUES-FUNCTION *GC-VALUES*)))
- (XSETFUNCTION *WINDOW-DISPLAY* GC GXCOPY)
- (SETQ *WINDOW-SAVE-FOREGROUND*
- (PROGN
- (XGETGCVALUES *WINDOW-DISPLAY* (CADDR *DRAW-WINDOW*)
- GCFOREGROUND *GC-VALUES*)
- (XGCVALUES-FOREGROUND *GC-VALUES*)))
- (XSETFOREGROUND *WINDOW-DISPLAY* GC
- (PROGN
- (XGETGCVALUES *WINDOW-DISPLAY* (CADDR *DRAW-WINDOW*)
- GCBACKGROUND *GC-VALUES*)
- (XGCVALUES-BACKGROUND *GC-VALUES*))))
+ (WINDOW-SET-ERASE *DRAW-WINDOW*)
(DRAW-OBJECT-DRAW REFPT *DRAW-WINDOW* (COPY-LIST '(0 0)))
- (LET ((GC (CADDR *DRAW-WINDOW*)))
- (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*)
- (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))
+ (WINDOW-UNSET *DRAW-WINDOW*)
(SETF (CADDR DD) (REMOVE REFPT (CADDR DD))))
(SETQ CENT (DRAW-GET-CROSSHAIRS DD W))
(LIST 'DRAW-REFPT CENT (COPY-LIST '(0 0)) NIL 0)))
+(SETF (GET 'DRAW-REFPT-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-REFPT-GET 'GLFNRESULTTYPE) 'DRAW-REFPT)
@@ -1508,15 +1509,13 @@
(LET (REFPT)
(SETQ REFPT (ASSOC 'DRAW-REFPT (CADDR DD)))
(IF REFPT (CADR REFPT) (COPY-LIST '(0 0)))))
+(SETF (GET 'DRAW-DESC-REFPT 'GLARGUMENTS) '((DD DRAW-DESC)))
(SETF (GET 'DRAW-DESC-REFPT 'GLFNRESULTTYPE) 'VECTOR)
(DEFUN DRAW-TEXT-DRAW (D W OFF)
- (LET ((SSTR (STRINGIFY (CADDDR D))))
- (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W)
- (+ (CAR OFF) (CAADR D))
- (+ -4 (- (CADDDR W) (+ (CADR OFF) (CADADR D))))
- (GET-C-STRING SSTR) (LENGTH SSTR))))
+ (WINDOW-PRINTAT-XY W (CADDDR D) (+ (CAR OFF) (CAADR D))
+ (+ (CADR OFF) (CADADR D))))
(DEFUN DRAW-TEXT-DRAW-OUTLINE (W X Y D)
(SETF (SECOND D) (LIST X Y))
@@ -1533,6 +1532,8 @@
(+ 2
(+ (+ (CADADR D) (MIN 0 (CADR (CADDR D))))
(ABS (CADR (CADDR D)))))))))
+(SETF (GET 'DRAW-TEXT-SELECTEDP 'GLARGUMENTS)
+ '((D DRAW-TEXT) (PT VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-TEXT-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN)
@@ -1540,11 +1541,14 @@
(LET (TXT LNG OFF)
(PRINC "Enter text string: ")
(SETQ TXT (STRINGIFY (READ)))
- (SETQ LNG
- (LET ((SSTR (STRINGIFY TXT)))
- (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR))))
+ (SETQ LNG (WINDOW-STRING-WIDTH W TXT))
(SETQ OFF (WINDOW-GET-BOX-POSITION W LNG 14))
- (LIST 'DRAW-TEXT OFF (LIST LNG 14) TXT 0)))
+ (LIST 'DRAW-TEXT
+ (LET ((GLVAR29986 (COPY-LIST '(0 4))))
+ (LIST (+ (CAR OFF) (CAR GLVAR29986))
+ (+ (CADR OFF) (CADR GLVAR29986))))
+ (LIST LNG 14) TXT 0)))
+(SETF (GET 'DRAW-TEXT-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW)))
(SETF (GET 'DRAW-TEXT-GET 'GLFNRESULTTYPE) 'DRAW-TEXT)
@@ -1552,16 +1556,22 @@
(IF (AND (< (ABS (- (- (CAR P1) (CAR OFF)) P2X)) 4)
(< (ABS (- (- (CADR P1) (CADR OFF)) P2Y)) 4))
(LIST (+ (CAR OFF) P2X) (+ (CADR OFF) P2Y))))
+(SETF (GET 'DRAW-SNAPP 'GLARGUMENTS)
+ '((P1 VECTOR) (OFF VECTOR) (P2X INTEGER) (P2Y INTEGER)))
(SETF (GET 'DRAW-SNAPP 'GLFNRESULTTYPE) 'VECTOR)
(DEFUN DRAW-DOT-SNAP (D P OFF)
(DRAW-SNAPP P OFF (+ 2 (CAADR D)) (+ 2 (CADADR D))))
+(SETF (GET 'DRAW-DOT-SNAP 'GLARGUMENTS)
+ '((D DRAW-DOT) (P VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-DOT-SNAP 'GLFNRESULTTYPE) 'VECTOR)
(DEFUN DRAW-REFPT-SNAP (D P OFF)
(DRAW-SNAPP P OFF (CAADR D) (CADADR D)))
+(SETF (GET 'DRAW-REFPT-SNAP 'GLARGUMENTS)
+ '((D DRAW-REFPT) (P VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-REFPT-SNAP 'GLFNRESULTTYPE) 'VECTOR)
@@ -1569,6 +1579,8 @@
(OR (DRAW-SNAPP P OFF (CAADR D) (CADADR D))
(DRAW-SNAPP P OFF (+ (CAADR D) (CAADDR D))
(+ (CADADR D) (CADR (CADDR D))))))
+(SETF (GET 'DRAW-LINE-SNAP 'GLARGUMENTS)
+ '((D DRAW-LINE) (P VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-LINE-SNAP 'GLFNRESULTTYPE) 'VECTOR)
@@ -1579,60 +1591,62 @@
(DRAW-SNAPP P OFF (+ XOFF XSIZE) (+ YOFF YSIZE))
(DRAW-SNAPP P OFF (+ XOFF XSIZE) YOFF)
(DRAW-SNAPP P OFF XOFF (+ YOFF YSIZE))
- (DRAW-SNAPP P OFF (+ XOFF (TRUNCATE XSIZE 2)) YOFF)
- (DRAW-SNAPP P OFF XOFF (+ YOFF (TRUNCATE YSIZE 2)))
- (DRAW-SNAPP P OFF (+ XOFF (TRUNCATE XSIZE 2)) (+ YOFF YSIZE))
- (DRAW-SNAPP P OFF (+ XOFF XSIZE) (+ YOFF (TRUNCATE YSIZE 2))))))
+ (DRAW-SNAPP P OFF (+ XOFF (/ XSIZE 2)) YOFF)
+ (DRAW-SNAPP P OFF XOFF (+ YOFF (/ YSIZE 2)))
+ (DRAW-SNAPP P OFF (+ XOFF (/ XSIZE 2)) (+ YOFF YSIZE))
+ (DRAW-SNAPP P OFF (+ XOFF XSIZE) (+ YOFF (/ YSIZE 2))))))
+(SETF (GET 'DRAW-BOX-SNAP 'GLARGUMENTS)
+ '((D DRAW-BOX) (P VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-BOX-SNAP 'GLFNRESULTTYPE) 'VECTOR)
(DEFUN DRAW-CIRCLE-SNAP (D P OFF)
- (OR (DRAW-SNAPP P OFF (+ (CAADR D) (TRUNCATE (CAADDR D) 2))
- (+ (CADADR D) (TRUNCATE (CAADDR D) 2)))
- (DRAW-SNAPP P OFF (+ (CAADR D) (TRUNCATE (CAADDR D) 2))
- (CADADR D))
- (DRAW-SNAPP P OFF (CAADR D)
- (+ (CADADR D) (TRUNCATE (CAADDR D) 2)))
- (DRAW-SNAPP P OFF (+ (CAADR D) (TRUNCATE (CAADDR D) 2))
+ (OR (DRAW-SNAPP P OFF (+ (CAADR D) (/ (CAADDR D) 2))
+ (+ (CADADR D) (/ (CAADDR D) 2)))
+ (DRAW-SNAPP P OFF (+ (CAADR D) (/ (CAADDR D) 2)) (CADADR D))
+ (DRAW-SNAPP P OFF (CAADR D) (+ (CADADR D) (/ (CAADDR D) 2)))
+ (DRAW-SNAPP P OFF (+ (CAADR D) (/ (CAADDR D) 2))
(+ (CADADR D) (CADR (CADDR D))))
(DRAW-SNAPP P OFF (+ (CAADR D) (CAADDR D))
- (+ (CADADR D) (TRUNCATE (CAADDR D) 2)))))
+ (+ (CADADR D) (/ (CAADDR D) 2)))))
+(SETF (GET 'DRAW-CIRCLE-SNAP 'GLARGUMENTS)
+ '((D DRAW-CIRCLE) (P VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-CIRCLE-SNAP 'GLFNRESULTTYPE) 'VECTOR)
(DEFUN DRAW-ELLIPSE-SNAP (D P OFF)
- (OR (DRAW-SNAPP P OFF (+ (CAADR D) (TRUNCATE (CAADDR D) 2))
- (+ (CADADR D) (TRUNCATE (CADR (CADDR D)) 2)))
- (DRAW-SNAPP P OFF (+ (CAADR D) (TRUNCATE (CAADDR D) 2))
- (CADADR D))
+ (OR (DRAW-SNAPP P OFF (+ (CAADR D) (/ (CAADDR D) 2))
+ (+ (CADADR D) (/ (CADR (CADDR D)) 2)))
+ (DRAW-SNAPP P OFF (+ (CAADR D) (/ (CAADDR D) 2)) (CADADR D))
(DRAW-SNAPP P OFF (CAADR D)
- (+ (CADADR D) (TRUNCATE (CADR (CADDR D)) 2)))
- (DRAW-SNAPP P OFF (+ (CAADR D) (TRUNCATE (CAADDR D) 2))
+ (+ (CADADR D) (/ (CADR (CADDR D)) 2)))
+ (DRAW-SNAPP P OFF (+ (CAADR D) (/ (CAADDR D) 2))
(+ (CADADR D) (CADR (CADDR D))))
(DRAW-SNAPP P OFF (+ (CAADR D) (CAADDR D))
- (+ (CADADR D) (TRUNCATE (CADR (CADDR D)) 2)))))
+ (+ (CADADR D) (/ (CADR (CADDR D)) 2)))))
+(SETF (GET 'DRAW-ELLIPSE-SNAP 'GLARGUMENTS)
+ '((D DRAW-ELLIPSE) (P VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-ELLIPSE-SNAP 'GLFNRESULTTYPE) 'VECTOR)
(DEFUN DRAW-RCBOX-SNAP (D P OFF)
- (LET ((RX (TRUNCATE (CAADDR D) 2))
- (RY (TRUNCATE (CADR (CADDR D)) 2)))
+ (LET ((RX (/ (CAADDR D) 2)) (RY (/ (CADR (CADDR D)) 2)))
(OR (DRAW-SNAPP P OFF (+ (CAADR D) RX) (CADADR D))
(DRAW-SNAPP P OFF (CAADR D) (+ (CADADR D) RY))
(DRAW-SNAPP P OFF (+ (CAADR D) RX)
(+ (CADADR D) (CADR (CADDR D))))
(DRAW-SNAPP P OFF (+ (CAADR D) (CAADDR D)) (+ (CADADR D) RY)))))
+(SETF (GET 'DRAW-RCBOX-SNAP 'GLARGUMENTS)
+ '((D DRAW-RCBOX) (P VECTOR) (OFF VECTOR)))
(SETF (GET 'DRAW-RCBOX-SNAP 'GLFNRESULTTYPE) 'VECTOR)
(DEFUN DRAW-NO-SNAP (D P OFF) NIL)
(DEFUN DRAW-MULTI-DRAW (D W OFF)
- (DOLIST (SUBD (CADDDR D))
- (DRAW-OBJECT-DRAW SUBD W
- (LET ((GLVAR4346 (CADR D)))
- (LIST (+ (CAR GLVAR4346) (CAR OFF))
- (+ (CADR GLVAR4346) (CADR OFF)))))))
+ (LET ((TOTALOFF
+ (LIST (+ (CAADR D) (CAR OFF)) (+ (CADADR D) (CADR OFF)))))
+ (DOLIST (SUBD (CADDDR D)) (DRAW-OBJECT-DRAW SUBD W TOTALOFF))))
(DEFUN DRAW-INIT-MENUS ()
(LET ((W (DRAW-WINDOW)))
@@ -1720,7 +1734,7 @@
(SETQ SY (1+ J))))))
(SETQ SX (* SX (LATEX-SIGN DX)))
(SETQ SY (* SY (LATEX-SIGN DY))))))
- (FORMAT T " \\put(~5,2F,~5,2F) {\\~A(~D,~D){~5,2F}}~%"
+ (FORMAT T " \\put(~5,0F,~5,0F) {\\~A(~D,~D){~5,0F}}~%"
(* FROMX *DRAW-LATEX-FACTOR*) (* FROMY *DRAW-LATEX-FACTOR*)
(IF ARROWFLG "vector" "line") SX SY SIZ)))
@@ -1783,8 +1797,15 @@
"glisp/draw-header.lsp")
(CF DRAWTRANS))
-(DEFUN DRAW-OUT (&OPTIONAL FILE NAMES)
+(DEFUN COMPILE-DRAWB ()
+ (GLCOMPFILES *DIRECTORY*
+ '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp")
+ '("glisp/menu-set.lsp" "glisp/draw.lsp") "glisp/drawtrans.lsp"
+ "glisp/draw-header.lsp"))
+
+(DEFUN DRAW-OUT (&OPTIONAL NAMES FILE)
(OR NAMES (SETQ NAMES *DRAW-OBJECTS*))
(IF (NOT (CONSP NAMES)) (SETQ NAMES (LIST NAMES)))
(DRAW-OUTPUT (OR FILE "glisp/draw.del") NAMES)
- (SETQ *DRAW-OBJECTS* (SET-DIFFERENCE *DRAW-OBJECTS* NAMES)))
+ (SETQ *DRAW-OBJECTS* (SET-DIFFERENCE *DRAW-OBJECTS* NAMES))
+ NAMES)
Index: xgcl-2/gcl_dwindow.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/xgcl-2/gcl_dwindow.lsp,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -b -r1.1.2.1 -r1.1.2.2
--- xgcl-2/gcl_dwindow.lsp 5 Jan 2006 17:55:35 -0000 1.1.2.1
+++ xgcl-2/gcl_dwindow.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.2
@@ -1,15 +1,18 @@
-; dwindow.lsp Gordon S. Novak Jr. 14 Mar 95
+; dwindow.lsp Gordon S. Novak Jr. ; 26 Jan 06
; Window types and interface functions for using X windows from GNU Common Lisp
-; Copyright (c) 1995 Gordon S. Novak Jr. and The University of Texas at Austin.
+; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin.
+
+; 08 Jan 97; 17 May 02; 17 May 04; 18 May 04; 01 Jun 04; 18 Aug 04; 24 Jan 06
+; 26 Jan 06
; See the files gnu.license and dec.copyright .
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
-; the Free Software Foundation; either version 1, or (at your option)
-; any later version.
+; the Free Software Foundation; either version 2 of the License, or
+; (at your option) any later version.
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -18,7 +21,7 @@
; You should have received a copy of the GNU General Public License
; along with this program; if not, write to the Free Software
-; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Some of the files that interface to the Xlib are adapted from DEC/MIT files.
; See the file dec.copyright for details.
@@ -42,7 +45,10 @@
(defvar *window-fonts* (list
(list 'courier-bold-12
"*-*-courier-bold-r-*-*-12-*-*-*-*-*-iso8859-1")
- (list '8x10 "8x10")
+ (list 'courier-medium-12
+ "*-*-courier-medium-r-*-*-12-*-*-*-*-*-iso8859-1")
+ (list '6x12 "6x12")
+ (list '8x13 "8x13")
(list '9x15 "9x15")))
(glispglobals (*window-menu* menu)
@@ -100,12 +106,6 @@
(defvar *window-meta*) ; set if meta down when char is pressed
(defvar *window-ctrl*) ; set if ctrl down when char is pressed
(defvar *window-shift*) ; set if shift down when char is pressed
-(defvar *window-string* (make-string 100))
-(defvar *window-string-count*)
-(defvar *window-string-max*)
-(defvar *window-input-string-x*)
-(defvar *window-input-string-y*)
-(defvar *window-input-string-charwidth*)
(defvar *window-shift-keys* nil)
(defvar *window-control-keys* nil)
@@ -139,8 +139,8 @@
(title-present (title and ((length title) > 0)))
(width (picture-width))
(height (picture-height))
- (base-x ((if flat then parent-offset-x else 0)))
- (base-y ((if flat then parent-offset-y else 0)))
+ (base-x ((if flat parent-offset-x 0)))
+ (base-y ((if flat parent-offset-y 0)))
(offset menu-offset)
(size menu-size)
(region ((virtual region with start = voffset size = vsize)))
@@ -206,7 +206,7 @@
(drawfn anything)
(menu-font symbol) ))
-(picmenu-button (list (name symbol)
+(picmenu-button (list (buttonname symbol)
(offset vector)
(size vector)
(highlightfn anything)
@@ -230,10 +230,10 @@
(subtrackfn anything)
(subtrackparms (listof anything)))
prop ((menuw (menu-window or (barmenu-init self)) result window)
- (picture-width ((if (horizontal m) then (maxval m)
- else (barwidth m)) ))
- (picture-height ((if (horizontal m) then (barwidth m)
- else (maxval m)) )) )
+ (picture-width ((if (horizontal m) (maxval m)
+ (barwidth m)) ))
+ (picture-height ((if (horizontal m) (barwidth m)
+ (maxval m)) )) )
msg ((init barmenu-init)
(init? ((menu-window and (picture-height > 0))
or (init self)))
@@ -244,6 +244,67 @@
(calculate-size barmenu-calculate-size) )
supers (menu))
+; Note: data through 'permanent' must be same as in menu.
+(textmenu (listobject (menu-window window)
+ (flat boolean)
+ (parent-window drawable)
+ (parent-offset-x integer)
+ (parent-offset-y integer)
+ (picture-width integer)
+ (picture-height integer)
+ (title string)
+ (permanent boolean)
+ (text string)
+ (drawing-width integer)
+ (drawing-height integer)
+ (boxflg boolean)
+ (menu-font symbol) )
+
+ prop ((menuw (menu-window or (textmenu-init self)) result window) )
+ msg ((init textmenu-init)
+ (init? ((menu-window and (picture-height > 0)) or (init self)))
+ (create textmenu-create result textmenu)
+ (select textmenu-select)
+ (draw textmenu-draw)
+ (calculate-size textmenu-calculate-size)
+ (set-text textmenu-set-text open t) )
+ supers (menu) )
+
+; Note: data through 'permanent' must be same as in menu.
+(editmenu (listobject (menu-window window)
+ (flat boolean)
+ (parent-window drawable)
+ (parent-offset-x integer)
+ (parent-offset-y integer)
+ (picture-width integer)
+ (picture-height integer)
+ (title string)
+ (permanent boolean)
+ (text (listof string))
+ (drawing-width integer)
+ (drawing-height integer)
+ (boxflg boolean)
+ (menu-font symbol)
+ (column integer)
+ (line integer)
+ (scrollval integer) )
+ prop ((menuw (menu-window or (editmenu-init self)) result window)
+ (scroll ((if (numberp scrollval)
+ scrollval
+ 0))) )
+
+ msg ((init editmenu-init)
+ (init? ((menu-window and (picture-height > 0)) or (init self)))
+ (create editmenu-create result editmenu)
+ (select editmenu-select)
+ (draw editmenu-draw)
+ (edit editmenu-edit)
+ (carat editmenu-carat)
+ (display editmenu-display)
+ (calculate-size editmenu-calculate-size)
+ (line-y editmenu-line-y open t) )
+ supers (menu) )
+
(window (listobject (parent drawable)
(gcontext anything)
(drawable-height integer)
@@ -261,7 +322,9 @@
(yposition window-yposition result integer open t)
(wfunction window-wfunction open t)
(foreground window-foreground open t)
- (background window-background open t) )
+ (background window-background open t)
+ (font-width ((string-width self "W")))
+ (font-height ((string-height self "Tg"))) )
msg ((force-output window-force-output open t)
(set-font window-set-font)
(set-foreground window-set-foreground open t)
@@ -355,6 +418,10 @@
(free-color window-free-color)
(get-chars window-get-chars)
(input-string window-input-string)
+ (string-width window-string-width)
+ (string-extents window-string-extents)
+ (string-height window-string-height)
+ (draw-carat window-draw-carat)
))
(rgb (list (red integer) (green integer) (blue integer)))
@@ -408,20 +475,21 @@
(setq *mouse-window* (int-pos *child-return* 0)) )
; 13 Aug 91; 14 Aug 91; 06 Sep 91; 12 Sep 91; 06 Dec 91; 01 May 92; 01 Sep 92
+(setf (glfnresulttype 'window-create) 'window)
(gldefun window-create (width height &optional str parentw pos-x pos-y font)
(let (w pw fg-color bg-color)
(or *window-display* (window-Xinit))
(setq fg-color *default-fg-color*)
(setq bg-color *default-bg-color*)
- (unless pos-x (pos-x \:= *window-default-pos-x*))
- (unless pos-y (pos-y \:= *window-default-pos-y*))
- (w \:= (a window with
+ (unless pos-x (pos-x = *window-default-pos-x*))
+ (unless pos-y (pos-y = *window-default-pos-y*))
+ (w = (a window with
drawable-width = width
drawable-height = height
- label = (if str (stringify str) else " ") ))
- (pw \:= (or parentw *root-window*))
+ label = (if str (stringify str) " ") ))
+ (pw = (or parentw *root-window*))
(window-get-geometry-b pw)
- ((parent w) \:=
+ ((parent w) =
(XCreateSimpleWindow *window-display* pw
pos-x
((int-pos *height-return* 0)
@@ -440,7 +508,7 @@
(get-c-string (label w)) ; icon name
none null null
*default-size-hints*)
- ((gcontext w) \:= (XCreateGC *window-display* (parent w) 0 null))
+ ((gcontext w) = (XCreateGC *window-display* (parent w) 0 null))
(set-foreground w fg-color)
(set-background w bg-color)
(set-font w (or font *window-default-font-name*))
@@ -456,20 +524,19 @@
(open w)
w ))
-; 06 Aug 91
+; 06 Aug 91; 17 May 04
; Set the font for a window to the one specified by fontsymbol.
; derived from Nguyen's my-load-font.
-(gldefun window-set-font (w\:window fontsymbol\:symbol)
+(gldefun window-set-font ((w window) (fontsymbol symbol))
(let (fontstring font-info (display *window-display*))
- (fontstring \:= (or (cadr (assoc fontsymbol *window-fonts*))
+ (fontstring = (or (cadr (assoc fontsymbol *window-fonts*))
(stringify fontsymbol)))
- (font-info \:= (XloadQueryFont display
+ (font-info = (XloadQueryFont display
(get-c-string fontstring)))
(if (eql 0 font-info)
- then (format t "~%can't open font ~a ~a~%" fontsymbol fontstring)
- else (XsetFont display (gcontext w)
- (Xfontstruct-fid font-info))
- ((font w) \:= font-info) ) ))
+ (format t "~%can't open font ~a ~a~%" fontsymbol fontstring)
+ (progn (XsetFont display (gcontext w) (Xfontstruct-fid font-info))
+ ((font w) = font-info)) ) ))
; 15 Oct 91
(defun window-font-info (fontsymbol)
@@ -480,45 +547,45 @@
; Functions to allow access to window properties from plain Lisp
-(gldefun window-gcontext (w\:window) (gcontext w))
-(gldefun window-parent (w\:window) (parent w))
-(gldefun window-drawable-height (w\:window) (drawable-height w))
-(gldefun window-drawable-width (w\:window) (drawable-width w))
-(gldefun window-label (w\:window) (label w))
-(gldefun window-font (w\:window) (font w))
+(gldefun window-gcontext ((w window)) (gcontext w))
+(gldefun window-parent ((w window)) (parent w))
+(gldefun window-drawable-height ((w window)) (drawable-height w))
+(gldefun window-drawable-width ((w window)) (drawable-width w))
+(gldefun window-label ((w window)) (label w))
+(gldefun window-font ((w window)) (font w))
; 07 Aug 91; 14 Aug 91
-(gldefun window-foreground (w\:window)
+(gldefun window-foreground ((w window))
(XGetGCValues *window-display* (gcontext w) GCForeground
*GC-Values*)
(XGCValues-foreground *GC-Values*) )
-(gldefun window-set-foreground (w\:window fg-color\:integer)
+(gldefun window-set-foreground ((w window) (fg-color integer))
(XsetForeground *window-display* (gcontext w) fg-color))
-(gldefun window-background (w\:window)
+(gldefun window-background ((w window))
(XGetGCValues *window-display* (gcontext w) GCBackground
*GC-Values*)
(XGCValues-Background *GC-Values*) )
-(gldefun window-set-background (w\:window bg-color\:integer)
+(gldefun window-set-background ((w window) (bg-color integer))
(XsetBackground *window-display* (gcontext w) bg-color))
; 08 Aug 91
-(gldefun window-wfunction (w\:window)
+(gldefun window-wfunction ((w window))
(XGetGCValues *window-display* (gcontext w) GCFunction
*GC-Values*)
(XGCValues-function *GC-Values*) )
; 08 Aug 91
; Get the geometry parameters of a window into global variables
-(gldefun window-get-geometry (w\:window) (window-get-geometry-b (parent w)))
+(gldefun window-get-geometry ((w window)) (window-get-geometry-b (parent w)))
; 06 Dec 91
; Set cursor to a selected cursor number
-(gldefun window-set-cursor (w\:window n\:integer)
+(gldefun window-set-cursor ((w window) (n integer))
(let (c)
- (c \:= (XCreateFontCursor *window-display* n) )
+ (c = (XCreateFontCursor *window-display* n) )
(XDefineCursor *window-display* (parent w) c) ))
(defun window-get-geometry-b (w)
@@ -528,7 +595,7 @@
; 15 Aug 91
; clear event queue of previous motion events
-(gldefun window-sync (w\:window)
+(gldefun window-sync ((w window))
(Xsync *window-display* 1) )
; 03 Oct 91; 06 Oct 94
@@ -538,12 +605,12 @@
; 08 Aug 91; 12 Sep 91; 28 Oct 91
; Make a list of window geometry, (x y width height border-width).
-(gldefun window-geometry (w\:window)
+(gldefun window-geometry ((w window))
(let (sh)
- (sh \:= (window-screen-height))
+ (sh = (window-screen-height))
(get-geometry w)
- ((drawable-width w) \:= (int-pos *width-return* 0))
- ((drawable-height w) \:= (int-pos *height-return* 0))
+ ((drawable-width w) = (int-pos *width-return* 0))
+ ((drawable-height w) = (int-pos *height-return* 0))
(list (int-pos *x-return* 0)
(sh - (int-pos *y-return* 0)
- (int-pos *height-return* 0))
@@ -552,43 +619,44 @@
(int-pos *border-width-return* 0)) ))
; 27 Nov 91
-(gldefun window-size (w\:window) (result vector)
+(gldefun window-size ((w window)) (result vector)
(get-geometry w)
- (list ((drawable-width w) \:= (int-pos *width-return* 0))
- ((drawable-height w) \:= (int-pos *height-return* 0)) ) )
+ (list ((drawable-width w) = (int-pos *width-return* 0))
+ ((drawable-height w) = (int-pos *height-return* 0)) ) )
-(gldefun window-left (w\:window)
+(gldefun window-left ((w window))
(get-geometry w)
(int-pos *x-return* 0))
; Get top of window in X (y increasing downwards) coordinates.
-(gldefun window-top-neg-y (w\:window)
+(gldefun window-top-neg-y ((w window))
(get-geometry w)
(int-pos *y-return* 0))
; 08 Aug 91
; Reset the local geometry parameters of a window from its X values.
; Needed, for example, if the user resizes the window by mouse command.
-(gldefun window-reset-geometry (w\:window)
+(gldefun window-reset-geometry ((w window))
(get-geometry w)
- ((drawable-width w) \:= (int-pos *width-return* 0))
- ((drawable-height w) \:= (int-pos *height-return* 0)) )
+ ((drawable-width w) = (int-pos *width-return* 0))
+ ((drawable-height w) = (int-pos *height-return* 0)) )
-(gldefun window-force-output (&optional w\:window)
+(gldefun window-force-output (&optional (w window))
(Xflush *window-display*))
-(gldefun window-query-pointer (w\:window) (window-query-pointer-b (parent w)) )
+(gldefun window-query-pointer ((w window))
+ (window-query-pointer-b (parent w)) )
(defun window-query-pointer-b (w)
(XQueryPointer *window-display* w
*root-return* *child-return* *root-x-return* *root-y-return*
*win-x-return* *win-y-return* *mask-return*) )
-(gldefun window-positive-y (w\:\window y\:integer) ((height w) - y))
+(gldefun window-positive-y ((w window) (y integer)) ((height w) - y))
; 08 Aug 91
; Set parameters of a window for drawing by XOR, saving old values.
-(gldefun window-set-xor (w\:window)
+(gldefun window-set-xor ((w window))
(let ((gc (gcontext w)) )
(setq *window-save-function* (wfunction w))
(XsetFunction *window-display* gc GXxor)
@@ -598,14 +666,14 @@
; 08 Aug 91
; Reset parameters of a window after change, using saved values.
-(gldefun window-unset (w\:window)
+(gldefun window-unset ((w window))
(let ((gc (gcontext w)) )
(XsetFunction *window-display* gc *window-save-function*)
(XsetForeground *window-display* gc *window-save-foreground*) ))
; 04 Sep 91
; Reset parameters of a window, using default values.
-(gldefun window-reset (w\:window)
+(gldefun window-reset ((w window))
(let ((gc (gcontext w)) )
(XsetFunction *window-display* gc GXcopy)
(XsetForeground *window-display* gc *default-fg-color*)
@@ -613,14 +681,14 @@
; 09 Aug 91; 03 Sep 92
; Set parameters of a window for erasing, saving old values.
-(gldefun window-set-erase (w\:window)
+(gldefun window-set-erase ((w window))
(let ((gc (gcontext w)) )
(setq *window-save-function* (wfunction w))
(XsetFunction *window-display* gc GXcopy)
(setq *window-save-foreground* (foreground w))
(XsetForeground *window-display* gc (background w)) ))
-(gldefun window-set-copy (w\:window)
+(gldefun window-set-copy ((w window))
(let ((gc (gcontext w)) )
(setq *window-save-function* (wfunction w))
(XsetFunction *window-display* gc GXcopy)
@@ -628,7 +696,7 @@
; 12 Aug 91
; Set parameters of a window for inversion, saving old values.
-(gldefun window-set-invert (w\:window)
+(gldefun window-set-invert ((w window))
(let ((gc (gcontext w)) )
(setq *window-save-function* (wfunction w))
(XsetFunction *window-display* gc GXxor)
@@ -637,7 +705,7 @@
(logxor *window-save-foreground* (background w))) ))
; 13 Aug 91
-(gldefun window-set-line-width (w\:window width\:integer)
+(gldefun window-set-line-width ((w window) (width integer))
(set-line-attr w width nil nil nil))
; 13 Aug 91; 12 Sep 91
@@ -651,21 +719,21 @@
; 13 Aug 91
; Set standard line attributes
-(gldefun window-std-line-attr (w\:window)
+(gldefun window-std-line-attr ((w window))
(XsetLineAttributes *window-display* (gcontext w)
1 LineSolid CapButt JoinMiter) )
; 06 Aug 91; 08 Aug 91; 12 Sep 91
-(gldefun window-draw-line (w\:window from\:vector to\:vector
+(gldefun window-draw-line ((w window) (from vector) (to vector)
&optional linewidth)
(window-draw-line-xy w (x from) (y from) (x to) (y to) linewidth) )
; 19 Dec 90; 07 Aug 91; 08 Aug 91; 09 Aug 91; 13 Aug 91; 12 Sep 91; 28 Sep 94
-(gldefun window-draw-line-xy (w\:window fromx\:integer
- fromy\:integer
- tox\:integer toy\:integer
+(gldefun window-draw-line-xy ((w window) (fromx integer)
+ (fromy integer)
+ (tox integer) (toy integer)
&optional linewidth
- operation\:atom)
+ (operation atom))
(let ( (qqwheight (drawable-height w)) )
(if (linewidth and (linewidth <> 1)) (set-line-width w linewidth))
(case operation
@@ -711,7 +779,7 @@
; 08 Aug 91; 14 Aug 91; 12 Sep 91
(gldefun window-draw-box
- (w\:window offset\:vector size\:vector &optional linewidth)
+ ((w window) (offset vector) (size vector) &optional linewidth)
(window-draw-box-xy w (x offset) (y offset) (x size) (y size) linewidth) )
; 08 Aug 91; 12 Sep 91; 11 Dec 91; 01 Sep 92; 02 Sep 92
@@ -719,16 +787,16 @@
; was (XDrawRectangle *window-display* (parent w) (gcontext w)
; offsetx (- qqwheight (offsety + sizey)) sizex sizey)
(gldefun window-draw-box-xy
- (w\:window offsetx\:integer offsety\:integer
- sizex\:integer sizey\:integer
+ ((w window) (offsetx integer) (offsety integer)
+ (sizex integer) (sizey integer)
&optional linewidth)
(let ((qqwheight (drawable-height w)) miny lw lw2 lw2b (pw (parent w))
(gc (gcontext w)))
(if (linewidth and (linewidth <> 1)) (set-line-width w linewidth))
- (lw \:= (or linewidth 1))
- (lw2 \:= lw / 2)
- (lw2b \:= (lw + 1) / 2)
- (miny \:= offsety - lw2b)
+ (lw = (or linewidth 1))
+ (lw2 = lw / 2)
+ (lw2b = (lw + 1) / 2)
+ (miny = offsety - lw2b)
(XdrawLine *window-display* pw gc offsetx (- qqwheight miny)
offsetx (- qqwheight (miny + sizey + lw)))
(XdrawLine *window-display* pw gc
@@ -744,8 +812,8 @@
; 26 Nov 91
(gldefun window-xor-box-xy
- (w\:window offsetx\:integer offsety\:integer
- sizex\:integer sizey\:integer
+ ((w window) (offsetx integer) (offsety integer)
+ (sizex integer) (sizey integer)
&optional linewidth)
(window-set-xor w)
(window-draw-box-xy w offsetx offsety sizex sizey linewidth)
@@ -753,23 +821,24 @@
; 15 Aug 91; 12 Sep 91
; Draw a box whose corners are specified
-(gldefun window-draw-box-corners (w\:window xa\:integer ya\:integer
- xb\:integer yb\:integer
+(gldefun window-draw-box-corners ((w window) (xa integer) (ya integer)
+ (xb integer) (yb integer)
&optional lw)
(draw-box-xy w (min xa xb) (min ya yb) (abs (- xa xb)) (abs (- ya yb)) lw) )
; 13 Sep 91
; Draw a box with round corners
-(gldefun window-draw-rcbox-xy (w\:window x\:integer y\:integer width\:integer
- height\:integer radius\:integer
+(gldefun window-draw-rcbox-xy ((w window) (x integer) (y integer)
+ (width integer)
+ (height integer) (radius integer)
&optional linewidth)
(let (x1 x2 y1 y2 r)
- (r \:= (max 0 (min radius (truncate (abs width) 2)
+ (r = (max 0 (min radius (truncate (abs width) 2)
(truncate (abs height) 2))))
- (x1 \:= x + r)
- (x2 \:= x + width - r)
- (y1 \:= y + r)
- (y2 \:= y + height - r)
+ (x1 = x + r)
+ (x2 = x + width - r)
+ (y1 = y + r)
+ (y2 = y + height - r)
(draw-line-xy w x1 y x2 y linewidth)
(draw-line-xy w (x + width) y1 (x + width) y2 linewidth)
(draw-line-xy w x1 (y + height) x2 (y + height) linewidth)
@@ -780,9 +849,9 @@
(draw-arc-xy w x1 y2 r r 90 90 linewidth) ))
; 13 Aug 91; 15 Aug 91; 12 Sep 91
-(gldefun window-draw-arc-xy (w\:window x\:integer y\:integer
- radiusx\:integer radiusy\:integer
- anglea\:number angleb\:number
+(gldefun window-draw-arc-xy ((w window) (x integer) (y integer)
+ (radiusx integer) (radiusy integer)
+ (anglea number) (angleb number)
&optional linewidth)
(if (linewidth and (linewidth <> 1)) (set-line-width w linewidth))
(XdrawArc *window-display* (parent w) (gcontext w)
@@ -792,8 +861,8 @@
(if (linewidth and (linewidth <> 1)) (set-line-width w 1)) )
; 08 Aug 91; 12 Sep 91
-(gldefun window-draw-circle-xy (w\:window x\:integer y\:integer
- radius\:integer
+(gldefun window-draw-circle-xy ((w window) (x integer) (y integer)
+ (radius integer)
&optional linewidth)
(if (linewidth and (linewidth <> 1)) (set-line-width w linewidth))
(XdrawArc *window-display* (parent w) (gcontext w)
@@ -802,26 +871,26 @@
(if (linewidth and (linewidth <> 1)) (set-line-width w 1)) )
; 06 Aug 91; 14 Aug 91; 12 Sep 91
-(gldefun window-draw-circle (w\:window pos\:vector radius\:integer
+(gldefun window-draw-circle ((w window) (pos vector) (radius integer)
&optional linewidth)
(window-draw-circle-xy w (x pos) (y pos) radius linewidth) )
; 08 Aug 91; 09 Sep 91
-(gldefun window-erase-area (w\:window offset\:vector size\:vector)
+(gldefun window-erase-area ((w window) (offset vector) (size vector))
(window-erase-area-xy w (x offset) (y offset) (x size) (y size)))
; 09 Sep 91; 11 Dec 91
-(gldefun window-erase-area-xy (w\:window xoff\:integer yoff\:integer
- xsize\:integer ysize\:integer)
+(gldefun window-erase-area-xy ((w window) (xoff integer) (yoff integer)
+ (xsize integer) (ysize integer))
(XClearArea *window-display* (parent w)
xoff (positive-y w (yoff + ysize - 1))
xsize ysize
0 )) ; exposures
; 21 Dec 93
-(gldefun window-erase-box-xy (w\:window xoff\:integer yoff\:integer
- xsize\:integer ysize\:integer
- &optional linewidth\:integer)
+(gldefun window-erase-box-xy ((w window) (xoff integer) (yoff integer)
+ (xsize integer) (ysize integer)
+ &optional (linewidth integer))
(XClearArea *window-display* (parent w)
(xoff - (or linewidth 1) / 2)
(positive-y w (yoff + ysize + (or linewidth 1) / 2))
@@ -830,13 +899,13 @@
0 )) ; exposures
; 15 Aug 91; 12 Sep 91
-(gldefun window-draw-ellipse-xy (w\:window x\:integer y\:integer
- rx\:integer ry\:integer &optional lw)
+(gldefun window-draw-ellipse-xy ((w window) (x integer) (y integer)
+ (rx integer) (ry integer) &optional lw)
(draw-arc-xy w x y rx ry 0 360 lw))
; 09 Aug 91
-(gldefun window-copy-area-xy (w\:window fromx fromy\:integer
- tox toy\:integer width height)
+(gldefun window-copy-area-xy ((w window) fromx (fromy integer)
+ tox (toy integer) width height)
(let ((qqwheight (drawable-height w)))
(set-copy w)
(XCopyArea *window-display* (parent w) (parent w) (gcontext w)
@@ -846,16 +915,16 @@
(unset w) ))
; 07 Dec 90; 09 Aug 91; 12 Sep 91
-(gldefun window-invertarea (w\:window area\:region)
+(gldefun window-invertarea ((w window) (area region))
(window-invert-area-xy w (left area) (bottom area)
(width area) (height area)))
; 07 Dec 90; 09 Aug 91; 12 Sep 91
-(gldefun window-invert-area (w\:window offset\:vector size\:vector)
+(gldefun window-invert-area ((w window) (offset vector) (size vector))
(window-invert-area-xy w (x offset) (y offset) (x size) (y size)) )
; 12 Aug 91; 15 Aug 91; 13 Dec 91
-(gldefun window-invert-area-xy (w\:window left bottom\:integer width height)
+(gldefun window-invert-area-xy ((w window) left (bottom integer) width height)
(set-invert w)
(XFillRectangle *window-display* (parent w) (gcontext w)
left (- (drawable-height w) (bottom + height - 1))
@@ -863,56 +932,88 @@
(unset w) )
; 05 Dec 90; 15 Aug 91
-(gldefun window-prettyprintat (w\:window s\:string pos\:vector)
+(gldefun window-prettyprintat ((w window) (s string) (pos vector))
(printat w s pos) )
-(gldefun window-prettyprintat-xy (w\:window s\:string x\:integer y\:integer)
+(gldefun window-prettyprintat-xy ((w window) (s string) (x integer)
+ (y integer))
(printat-xy w s x y))
; 06 Aug 91; 08 Aug 91; 15 Aug 91
-(gldefun window-printat (w\:window s\:string pos\:vector)
+(gldefun window-printat ((w window) (s string) (pos vector))
(printat-xy w s (x pos) (y pos)) )
; 06 Aug 91; 08 Aug 91; 12 Aug 91
-(gldefun window-printat-xy (w\:window s\:string x\:integer y\:integer)
+(gldefun window-printat-xy ((w window) (s string) (x integer) (y integer))
(let ( (sstr (stringify s)) )
(XdrawImageString *window-display* (parent w) (gcontext w)
x (- (drawable-height w) y)
(get-c-string sstr) (length sstr)) ))
+; 19 Apr 95; 02 May 95; 17 May 04
+; Print a string that may contain #\Newline characters in a window.
+(gldefun window-print-line ((w window) (str string) (x integer) (y integer)
+ &optional (deltay integer))
+ (let ((lng (length str)) (n 0) end strb done)
+ (while ~done
+ (end = (position #\Newline str :test #'char= :start n))
+ (strb = (subseq str n end))
+ (printat-xy w strb x y)
+ (if (numberp end)
+ (n = (1+ end))
+ (done = t))
+ (y _- (or deltay 16))
+ (if (y < 0) (done = t)))
+ (force-output w) ))
+
+; 02 May 95; 08 May 95
+; Print a list of strings in a window.
+(gldefun window-print-lines ((w window) (lines (listof string))
+ (x integer) (y integer)
+ &optional (deltay integer))
+ (for str in lines when (y > 0) (printat-xy w str x y) (y _- (or deltay 16)))
)
+
; 08 Aug 91
; Find the width of a string when printed in a given window
-(gldefun window-string-width (w\:window s\:string)
+(gldefun window-string-width ((w window) (s string))
(let ((sstr (stringify s)))
(XTextWidth (font w) (get-c-string sstr) (length sstr)) ))
; 01 Dec 93
; Find the ascent and descent of a string when printed in a given window
-(gldefun window-string-extents (w\:window s\:string)
+(gldefun window-string-extents ((w window) (s string))
(let ((sstr (stringify s)))
(XTextExtents (font w) (get-c-string sstr) (length sstr)
*direction-return* *ascent-return* *descent-return* *overall-return*)
(list (int-pos *ascent-return* 0)
(int-pos *descent-return* 0)) ))
+; Find the height (ascent + descent) of a string when printed in a given window
+(gldefun window-string-height ((w window) (s string))
+ (let ((sstr (stringify s)))
+ (XTextExtents (font w) (get-c-string sstr) (length sstr)
+ *direction-return* *ascent-return* *descent-return* *overall-return*)
+ (+ (int-pos *ascent-return* 0)
+ (int-pos *descent-return* 0)) ))
+
; 15 Oct 91
-(gldefun window-font-string-width (font s\:string)
+(gldefun window-font-string-width (font (s string))
(let ((sstr (stringify s)))
(XTextWidth font (get-c-string sstr) (length sstr)) ))
-(gldefun window-yposition (w\:window)
+(gldefun window-yposition ((w window))
(window-get-mouse-position)
(positive-y w (- *mouse-y* (top-neg-y w))) )
-(gldefun window-centeroffset (w\:window v\:vector)
+(gldefun window-centeroffset ((w window) (v vector))
(a vector with x = (truncate ((width w) - (x v)) 2)
y = (truncate ((height w) - (y v)) 2)))
; 18 Aug 89; 15 Aug 91
; Command to a window display manager
-(gldefun dowindowcom (w\:window)
+(gldefun dowindowcom ((w window))
(let (comm)
- (comm \:= (select (window-menu)) )
+ (comm = (select (window-menu)) )
(case comm
(close (close w))
(paint (paint w))
@@ -928,30 +1029,30 @@
(a menu with items = '(close paint clear move)))) )
; 06 Dec 90; 11 Mar 93
-(gldefun window-close (w\:window)
+(gldefun window-close ((w window))
(unmap w)
(force-output w)
(window-wait-unmap w))
-(gldefun window-unmap (w\:window)
+(gldefun window-unmap ((w window))
(XUnMapWindow *window-display* (parent w)) )
; 06 Aug 91; 22 Aug 91
-(gldefun window-open (w\:window)
+(gldefun window-open ((w window))
(mapw w)
(force-output w)
(wait-exposure w) )
-(gldefun window-map (w\:window)
+(gldefun window-map ((w window))
(XMapWindow *window-display* (parent w)) )
; 08 Aug 91; 02 Sep 91
-(gldefun window-destroy (w\:window)
+(gldefun window-destroy ((w window))
(XDestroyWindow *window-display* (parent w))
(force-output w)
- ((parent w) \:= nil)
+ ((parent w) = nil)
(XFreeGC *window-display* (gcontext w))
- ((gcontext w) \:= nil) )
+ ((gcontext w) = nil) )
; 09 Sep 91
; Wait 3 seconds, then destroy the window where the mouse is. Use with care.
@@ -968,12 +1069,12 @@
(Xflush *window-display*))) ))
; 07 Aug 91
-(gldefun window-clear (w\:window)
+(gldefun window-clear ((w window))
(XClearWindow *window-display* (parent w))
(force-output w) )
; 08 Aug 91
-(gldefun window-moveto-xy (w\:window x\:integer y\:integer)
+(gldefun window-moveto-xy ((w window) (x integer) (y integer))
(XMoveWindow *window-display* (parent w)
x (- (window-screen-height) y)) )
@@ -991,13 +1092,13 @@
; 15 Aug 91; 06 May 93
; Move a window.
-(gldefun window-move (w\:window)
+(gldefun window-move ((w window))
(window-get-mouse-position)
(XMoveWindow *window-display* (parent w)
*mouse-x* (- (window-screen-height) *mouse-y*)) )
; 15 Sep 93; 06 Jan 94
-(gldefun window-draw-border (w\:window)
+(gldefun window-draw-border ((w window))
(draw-box-xy w 0 1 ((x (size w)) - 1) ((y (size w)) - 1))
(force-output w) )
@@ -1106,12 +1207,12 @@
; 14 Dec 90; 17 Dec 90; 13 Aug 91; 20 Aug 91; 30 Aug 91; 09 Sep 91; 11 Sep 91
; 15 Oct 91; 16 Oct 91; 10 Feb 92; 25 Sep 92; 26 Sep 92
; Initialize a menu
-(gldefun menu-init (m\:menu)
+(gldefun menu-init ((m menu))
(let ()
(or *window-display* (window-Xinit)) ; init windows if necessary
(calculate-size m)
(if ~ (flat m)
- ((menu-window m) \:= (window-create (picture-width m)
+ ((menu-window m) = (window-create (picture-width m)
(picture-height m)
((title m) or "")
(parent-window m)
@@ -1119,186 +1220,189 @@
(parent-offset-y m)
(menu-font m) )) ) ))
-; 25 Sep 92; 26 Sep 92; 11 Mar 93; 05 Oct 93; 08 Oct 93
+; 25 Sep 92; 26 Sep 92; 11 Mar 93; 05 Oct 93; 08 Oct 93; 17 May 04
; Calculate the displayed size of a menu
-(gldefun menu-calculate-size (m\:menu)
+(gldefun menu-calculate-size ((m menu))
(let (maxwidth maxheight nitems)
- (or (menu-font m) ((menu-font m) \:= '9x15))
- (maxwidth \:= (find-item-width m (title m))
+ (or (menu-font m) ((menu-font m) = '9x15))
+ (maxwidth = (find-item-width m (title m))
+ (if (or (flat m) *window-add-menu-title*)
- then 0 else *menu-title-pad*))
- (maxheight \:= 13) ; ***** fix for font
- (nitems \:= (if (and (title-present m)
+ 0
+ *menu-title-pad*))
+ (maxheight = 13) ; ***** fix for font
+ (nitems = (if (and (title-present m)
(or (flat m) *window-add-menu-title*))
- then 1 else 0))
+ 1 0))
(for item in (items m) do
(nitems _+ 1)
- (maxwidth \:= (max maxwidth (find-item-width m item)))
- (maxheight \:= (max maxheight (find-item-height m item))) )
- ((item-width m) \:= maxwidth + 6)
- ((picture-width m) \:= (item-width m) + 1)
- ((item-height m) \:= maxheight + 2)
- ((picture-height m) \:= ((item-height m) * nitems) + 2)
+ (maxwidth = (max maxwidth (find-item-width m item)))
+ (maxheight = (max maxheight (find-item-height m item))) )
+ ((item-width m) = maxwidth + 6)
+ ((picture-width m) = (item-width m) + 1)
+ ((item-height m) = maxheight + 2)
+ ((picture-height m) = ((item-height m) * nitems) + 2)
(adjust-offset m) ))
-; 06 Sep 91; 09 Sep 91; 10 Sep 91; 21 May 93
+; 06 Sep 91; 09 Sep 91; 10 Sep 91; 21 May 93; 30 May 02; 17 May 04
; Adjust a menu's offset position if necessary to keep it in parent window.
-(gldefun menu-adjust-offset (m\:menu)
+(gldefun menu-adjust-offset ((m menu))
(let (xbase ybase wbase hbase xoff yoff wgm width height)
- (width \:= (picture-width m))
- (height \:= (picture-height m))
+ (width = (picture-width m))
+ (height = (picture-height m))
(if ~ (parent-window m)
- then (window-get-mouse-position) ; put it where the mouse is
- (wgm \:= t) ; set flag that we got mouse position
- ((parent-window m) \:= *root-window*)) ; 21 May 93 was
*mouse-window*
+ (progn (window-get-mouse-position) ; put it where the mouse is
+ (wgm = t) ; set flag that we got mouse position
+ ((parent-window m) = *root-window*))) ; 21 May 93 was
*mouse-window*
(window-get-geometry-b (parent-window m))
(setq xbase (int-pos *x-return* 0))
(setq ybase (int-pos *y-return* 0))
(setq wbase (int-pos *width-return* 0))
(setq hbase (int-pos *height-return* 0))
- (if (~ (parent-offset-x m) or (parent-offset-x m) = 0)
- then (or wgm (window-get-mouse-position))
- (xoff \:= ((*mouse-x* - xbase) - (width / 2) - 4))
- (yoff \:= ((hbase - (*mouse-y* - ybase)) - (height / 2)))
- else (xoff \:= (parent-offset-x m))
- (yoff \:= (parent-offset-y m)))
- ((parent-offset-x m) \:= (max 0 (min xoff (wbase - width))))
- ((parent-offset-y m) \:= (max 0 (min yoff (hbase - height)))) ))
+ (if (~ (parent-offset-x m) or (parent-offset-x m) == 0)
+ (progn (or wgm (window-get-mouse-position))
+ (xoff = ((*mouse-x* - xbase) - (width / 2) - 4))
+ (yoff = ((hbase - (*mouse-y* - ybase)) - (height / 2))))
+ (progn (xoff = (parent-offset-x m))
+ (yoff = (parent-offset-y m))))
+ ((parent-offset-x m) = (max 0 (min xoff (wbase - width))))
+ ((parent-offset-y m) = (max 0 (min yoff (hbase - height)))) ))
; 07 Dec 90; 14 Dec 90; 12 Aug 91; 22 Aug 91; 09 Sep 91; 10 Sep 91; 28 Jan 92;
-; 10 Feb 92; 26 Sep 92; 11 Mar 93; 08 Oct 93
-(gldefun menu-draw (m\:menu)
+; 10 Feb 92; 26 Sep 92; 11 Mar 93; 08 Oct 93; 17 May 04
+(gldefun menu-draw ((m menu))
(let (mw xzero yzero bottom)
(init? m)
- (xzero \:= (menu-x m 0))
- (yzero \:= (menu-y m 0))
- (mw \:= (menu-window m))
+ (xzero = (menu-x m 0))
+ (yzero = (menu-y m 0))
+ (mw = (menu-window m))
(open mw)
(clear m)
(if (flat m) (draw-box-xy mw (xzero - 1) yzero ((picture-width m) + 2)
((picture-height m) + 1) 1))
- (bottom \:= (yzero + (picture-height m) + 3))
+ (bottom = (yzero + (picture-height m) + 3))
(if (and (title-present m)
(or (flat m) *window-add-menu-title*))
- then (bottom _- (item-height m))
+ (progn (bottom _- (item-height m))
(printat-xy mw (stringify (title m)) (+ xzero 3) bottom)
(invert-area-xy mw xzero (bottom - 2)
- ((picture-width m) + 1) (item-height m)))
+ ((picture-width m) + 1) (item-height m))))
(for item in (items m) do
(bottom _- (item-height m))
(display-item m item (+ xzero 3) bottom) )
(force-output mw) ))
+; 17 May 04
(gldefun menu-item-value (self item)
- (if (consp item) then (cdr item) else item))
+ (if (consp item) (cdr item) item))
-; 06 Sep 91; 11 Sep 91; 15 Oct 91; 16 Oct 91; 23 Oct 91
-(gldefun menu-find-item-width (self\:menu item)
- (let (tmp\:vector)
+; 06 Sep 91; 11 Sep 91; 15 Oct 91; 16 Oct 91; 23 Oct 91; 17 May 04
+(gldefun menu-find-item-width ((self menu) item)
+ (let ((tmp vector))
(if (and (consp item)
(symbolp (car item))
(fboundp (car item)))
- then (or (and (tmp \:= (get (car item) 'display-size))
+ (or (and (tmp = (get (car item) 'display-size))
(x tmp))
40)
- else (window-font-string-width
+ (window-font-string-width
(or (and (flat self)
(menu-window self)
(font (menu-window self)))
(window-font-info (menu-font self)))
- (stringify (if (consp item) then (car item) else item)))) ))
+ (stringify (if (consp item) (car item) item)))) ))
-; 09 Sep 91; 10 Sep 91; 11 Sep 91
-(gldefun menu-find-item-height (self\:menu item) ; ***** fix for font
- (let (tmp\:vector)
+; 09 Sep 91; 10 Sep 91; 11 Sep 91; 17 mAY 04
+(gldefun menu-find-item-height ((self menu) item) ; ***** fix for font
+ (let ((tmp vector))
(if (and (consp item)
(symbolp (car item))
- (tmp \:= (get (car item) 'display-size)))
- then ((y tmp) + 3)
- else 15) ))
+ (tmp = (get (car item) 'display-size)))
+ ((y tmp) + 3)
+ 15) ))
-; 09 Sep 91; 10 Sep 91; 10 Feb 92
-(gldefun menu-clear (m\:menu)
+; 09 Sep 91; 10 Sep 91; 10 Feb 92; 17 May 04
+(gldefun menu-clear ((m menu))
(if (flat m)
(erase-area-xy (menu-window m) ((base-x m) - 1) ((base-y m) - 1)
((picture-width m) + 3) ((picture-height m) + 3))
- else (clear (menu-window m))) )
+ (clear (menu-window m))) )
-; 06 Sep 91; 04 Dec 91
-(gldefun menu-display-item (self\:menu item x y)
+; 06 Sep 91; 04 Dec 91; 17 May 04
+(gldefun menu-display-item ((self menu) item x y)
(let ((mw (menu-window self)))
(if (consp item)
- then (if (and (symbolp (car item))
+ (if (and (symbolp (car item))
(fboundp (car item)))
- then (funcall (car item) mw x y)
- elseif (or (stringp (car item)) (symbolp (car item))
+ (funcall (car item) mw x y)
+ (if (or (stringp (car item)) (symbolp (car item))
(numberp (car item)))
- then (printat-xy mw (car item) x y)
- else (printat-xy mw (stringify item) x y))
- else (printat-xy mw (stringify item) x y)) ))
+ (printat-xy mw (car item) x y)
+ (printat-xy mw (stringify item) x y)))
+ (printat-xy mw (stringify item) x y)) ))
; 07 Dec 90; 18 Dec 90; 15 Aug 91; 27 Aug 91; 06 Sep 91; 10 Sep 91; 29 Sep 92
-; 04 Aug 93; 07 Jan 94
-(gldefun menu-choose (m\:menu inside\:boolean)
+; 04 Aug 93; 07 Jan 94; 17 May 04; 18 May 04
+(gldefun menu-choose ((m menu) (inside boolean))
(let (mw current-item-n newn itemh itms nitems val maxx xzero yzero)
(init? m)
- (mw \:= (menu-window m))
+ (mw = (menu-window m))
(draw m)
- (xzero \:= (menu-x m 0))
- (yzero \:= (menu-y m 0))
- (maxx \:= (+ xzero (picture-width m)))
- (itemh \:= (item-height m))
- (itms \:= (items m))
- (nitems \:= (length itms))
+ (xzero = (menu-x m 0))
+ (yzero = (menu-y m 0))
+ (maxx = (+ xzero (picture-width m)))
+ (itemh = (item-height m))
+ (itms = (items m))
+ (nitems = (length itms))
(track-mouse mw
#'(lambda (x y code)
(setq *window-menu-code* code)
(setq newn (1- (- nitems (truncate (- y (+ yzero 3)) itemh))))
(if ((x >= xzero) and (x <= maxx)
and (newn >= 0) and (newn < nitems))
- then
+ (progn
(if current-item-n
- then (if (/= newn current-item-n)
- then (unbox-item m current-item-n)
+ (if (/= newn current-item-n)
+ (progn (unbox-item m current-item-n)
(box-item m newn)
- (current-item-n \:= newn))
- else (inside \:= t)
+ (current-item-n = newn)))
+ (progn (inside = t)
(box-item m newn)
- (current-item-n \:= newn))
+ (current-item-n = newn)))
(if (and current-item-n (> code 0))
- (unbox-item m current-item-n)
- (val \:= current-item-n))
- else (if current-item-n
- then (unbox-item m current-item-n)
- (current-item-n \:= nil))
+ (progn (unbox-item m current-item-n)
+ (val = current-item-n))))
+ (progn (if current-item-n
+ (progn (unbox-item m current-item-n)
+ (current-item-n = nil)))
(if (> code 0) or
(inside and ((x < xzero) or (x > maxx)
or (y < yzero)
or (y > (yzero + (picture-height m)))))
- then (val \:= -777))))
+ (val = -777)))))
t)
(if (val <> -777) (item-value m (nth val itms)) ) ))
; 07 Dec 90; 12 Aug 91; 10 Sep 91; 05 Oct 92
-(gldefun menu-box-item (m\:menu item\:integer)
+(gldefun menu-box-item ((m menu) (item integer))
(let (itemh nitems (mw (menuw m)) )
- (itemh \:= (item-height m))
- (nitems \:= (length (items m)))
+ (itemh = (item-height m))
+ (nitems = (length (items m)))
(set-xor mw)
(draw-box-xy mw (menu-x m 1) (menu-y m ((nitems - item - 1) * itemh + 2))
((item-width m) - 2) itemh 1)
(unset mw) ))
; 07 Dec 90; 12 Aug 91; 14 Aug 91; 15 Aug 91; 05 Oct 92
-(gldefun menu-unbox-item (m\:menu item\:integer)
+(gldefun menu-unbox-item ((m menu) (item integer))
(box-item m item) )
; 11 Sep 91; 08 Sep 92; 28 Sep 92; 18 Jan 94
-(gldefun menu-item-position (m\:menu itemname\:symbol &optional place\:symbol)
+(gldefun menu-item-position ((m menu) (itemname symbol)
+ &optional (place symbol))
(let ((n 0) found itms item (xsize (item-width m)) (ysize (item-height m)))
- (itms \:= (items m))
- (found \:= (null itemname))
+ (itms = (items m))
+ (found = (null itemname))
(while itms and ~ found do
(n _+ 1)
(item -_ itms)
@@ -1310,7 +1414,7 @@
(eq (cdr item) itemname)
(and (consp (cdr item))
(eq (cadr item) itemname)))))
- (found \:= t)))
+ (found = t)))
(if found (a vector with
x = ((menu-x m 0) +
(case place
@@ -1325,25 +1429,26 @@
(top ysize)
else 0)) )) ))
-; 10 Dec 90; 13 Dec 90; 10 Sep 91; 29 Sep 92
+; 10 Dec 90; 13 Dec 90; 10 Sep 91; 29 Sep 92; 17 May 04
; Choose from menu, then close it
-(gldefun menu-select (m\:menu &optional inside) (menu-select-b m nil inside))
-(gldefun menu-select! (m\:menu) (menu-select-b m t nil))
-(gldefun menu-select-b (m\:menu flg\:boolean inside\:boolean)
+(gldefun menu-select ((m menu) &optional inside) (menu-select-b m nil inside))
+(gldefun menu-select! ((m menu)) (menu-select-b m t nil))
+(gldefun menu-select-b ((m menu) (flg boolean) (inside boolean))
(prog (res)
-lp (res \:= (choose m inside))
+lp (res = (choose m inside))
(if (flg and ~res) (go lp))
(if ~(permanent m)
- (if (flat m) then (clear m)
- (force-output (menu-window m))
- else (close (menu-window m))))
+ (if (flat m)
+ (progn (clear m)
+ (force-output (menu-window m)))
+ (close (menu-window m))))
(return res)))
-; 12 Aug 91
-(gldefun menu-destroy (m\:menu)
+; 12 Aug 91; 17 May 04
+(gldefun menu-destroy ((m menu))
(if ~ (flat m)
- then (destroy (menu-window m))
- ((menu-window m) \:= nil) ))
+ (progn (destroy (menu-window m))
+ ((menu-window m) = nil) )))
; 19 Aug 91; 02 Sep 91
; Easy interface to make a menu, select from it, and destroy it.
@@ -1354,12 +1459,13 @@
(menu-destroy m)
res ))
-; 12 Aug 91; 15 Aug 91; 06 Sep 91; 09 Sep 91; 12 Sep 91; 23 Oct 91
+; 12 Aug 91; 15 Aug 91; 06 Sep 91; 09 Sep 91; 12 Sep 91; 23 Oct 91; 17 May 04
; Simple call from plain Lisp to make a menu.
-(gldefun menu-create (items &optional title parentw\:window x y
- perm\:boolean flat\:boolean font\:symbol)
- (a menu with title = (if title (stringify title) else "")
- menu-window = (if flat then parentw)
+(setf (glfnresulttype 'menu-create) 'menu)
+(gldefun menu-create (items &optional title (parentw window) x y
+ (perm boolean) (flat boolean) (font symbol))
+ (a menu with title = (if title (stringify title) "")
+ menu-window = (if flat parentw)
items = items
parent-window = (parent parentw)
parent-offset-x = x
@@ -1369,48 +1475,53 @@
menu-font = font ))
; 15 Oct 91; 30 Oct 91
-(gldefun menu-offset (m\:menu)
+(gldefun menu-offset ((m menu))
(result vector)
(a vector with x = (base-x m) y = (base-y m)))
-; 15 Oct 91; 30 Oct 91; 25 Sep 92; 29 Sep 92
-(gldefun menu-size (m\:menu)
+; 15 Oct 91; 30 Oct 91; 25 Sep 92; 29 Sep 92; 18 Apr 95; 25 Jul 96
+(gldefun menu-size ((m menu))
(result vector)
(if ((picture-width m) <= 0)
- (if ((first m) = 'picmenu)
- then (picmenu-calculate-size m)
- else (menu-calculate-size m)))
+ (case (first m)
+ (picmenu (picmenu-calculate-size m))
+ (barmenu (barmenu-calculate-size m))
+ (textmenu (textmenu-calculate-size m))
+ (editmenu (editmenu-calculate-size m))
+ (t (menu-calculate-size m))))
(a vector with x = (picture-width m) y = (picture-height m)) )
-; 15 Oct 91
-(gldefun menu-moveto-xy (m\:menu x\:integer y\:integer)
+; 15 Oct 91; 17 May 04
+(gldefun menu-moveto-xy ((m menu) (x integer) (y integer))
(if (flat m)
- then ((parent-offset-x m) \:= x)
- ((parent-offset-y m) \:= y)
- (adjust-offset m)) )
+ (progn ((parent-offset-x m) = x)
+ ((parent-offset-y m) = y)
+ (adjust-offset m)) ))
-; 27 Nov 92
+; 27 Nov 92; 17 May 04
; Reposition a menu to a position specified by the user by mouse click
-(gldefun menu-reposition (m\:menu)
+(gldefun menu-reposition ((m menu))
(let (sizev pos)
(if (flat m)
- (sizev \:= (size m))
- (pos \:= (get-box-position (menu-window m) (x sizev) (y sizev)))
- (moveto-xy m (x pos) (y pos)) ) ))
+ (progn (sizev = (size m))
+ (pos = (get-box-position (menu-window m) (x sizev) (y sizev)))
+ (moveto-xy m (x pos) (y pos)) ) )))
; 09 Sep 91; 11 Sep 91; 12 Sep 91; 14 Sep 91
; Simple call from plain Lisp to make a picture menu.
+(setf (glfnresulttype 'picmenu-create) 'picmenu)
(gldefun picmenu-create
- (buttons width\:integer height\:integer drawfn
- &optional title dotflg\:boolean parentw\:window x y
- perm\:boolean flat\:boolean font\:symbol boxflg\:boolean)
+ (buttons (width integer) (height integer) drawfn
+ &optional title (dotflg boolean) (parentw window) x y (perm boolean)
+ (flat boolean) (font symbol) (boxflg boolean))
(picmenu-create-from-spec
(picmenu-create-spec buttons width height drawfn dotflg font)
title parentw x y perm flat boxflg))
; 14 Sep 91
-(gldefun picmenu-create-spec (buttons width\:integer height\:integer drawfn
- &optional dotflg\:boolean font\:symbol)
+(setf (glfnresulttype 'picmenu-create-spec) 'picmenu-spec)
+(gldefun picmenu-create-spec (buttons (width integer) (height integer) drawfn
+ &optional (dotflg boolean) (font symbol))
(a picmenu-spec with drawing-width = width
drawing-height = height
buttons = buttons
@@ -1418,12 +1529,13 @@
drawfn = drawfn
menu-font = (font or '9x15)))
-; 14 Sep 91
+; 14 Sep 91; 17 May 04
+(setf (glfnresulttype 'picmenu-create-from-spec) 'picmenu)
(gldefun picmenu-create-from-spec
- (spec\:picmenu-spec &optional title parentw\:window x y
- perm\:boolean flat\:boolean boxflg\:boolean)
- (a picmenu with title = (if title (stringify title) else "")
- menu-window = (if flat then parentw)
+ ((spec picmenu-spec) &optional title (parentw window) x y
+ (perm boolean) (flat boolean) (boxflg boolean))
+ (a picmenu with title = (if title (stringify title) "")
+ menu-window = (if flat parentw)
parent-window = (if parentw (parent parentw))
parent-offset-x = x
parent-offset-y = y
@@ -1432,27 +1544,27 @@
spec = spec
boxflg = boxflg))
-; 29 Sep 92; 13 Oct 93
-(gldefun picmenu-calculate-size (m\:picmenu)
+; 29 Sep 92; 13 Oct 93; 17 May 04
+(gldefun picmenu-calculate-size ((m picmenu))
(let (maxwidth maxheight)
- (maxwidth \:= (max (if (title m) then ((* 9 (length (title m))) + 6)
- else 0)
+ (maxwidth = (max (if (title m) ((* 9 (length (title m))) + 6)
+ 0)
(drawing-width m)))
- (maxheight \:= (if (and (title-present m)
+ (maxheight = (if (and (title-present m)
(or (flat m) *window-add-menu-title*))
- then 15 else 0)
+ 15 0)
+ (drawing-height m))
- ((picture-width m) \:= maxwidth)
- ((picture-height m) \:= maxheight) ))
+ ((picture-width m) = maxwidth)
+ ((picture-height m) = maxheight) ))
; 09 Sep 91; 10 Sep 91; 29 Sep 92
; Initialize a picture menu
-(gldefun picmenu-init (m\:picmenu)
+(gldefun picmenu-init ((m picmenu))
(let ()
(calculate-size m)
(adjust-offset m)
(if ~ (flat m)
- ((menu-window m) \:= (window-create (picture-width m)
+ ((menu-window m) = (window-create (picture-width m)
(picture-height m)
((title m) or "")
(parent-window m)
@@ -1461,30 +1573,31 @@
(menu-font m) )) ) ))
; 09 Sep 91; 10 Sep 91; 11 Sep 91; 10 Feb 92; 05 Oct 92; 30 Oct 92; 13 Oct 93
+; 17 May 04
; Draw a picture menu
-(gldefun picmenu-draw (m\:picmenu)
+(gldefun picmenu-draw ((m picmenu))
(let (mw bottom xzero yzero)
(init? m)
- (mw \:= (menu-window m))
+ (mw = (menu-window m))
(open mw)
(clear m)
- (xzero \:= (menu-x m 0))
- (yzero \:= (menu-y m 0))
- (bottom \:= yzero + (picture-height m))
+ (xzero = (menu-x m 0))
+ (yzero = (menu-y m 0))
+ (bottom = yzero + (picture-height m))
(if (and (title-present m)
(or (flat m) *window-add-menu-title*))
- then (printat-xy mw (stringify (title m)) (xzero + 3) (bottom - 13))
- (invert-area-xy mw xzero (bottom - 15) (picture-width m) 16))
+ (progn (printat-xy mw (stringify (title m)) (xzero + 3) (bottom - 13))
+ (invert-area-xy mw xzero (bottom - 15) (picture-width m) 16)))
(funcall (drawfn m) mw xzero yzero)
(if (boxflg m) (draw-box-xy mw xzero yzero
(picture-width m) (picture-height m) 1))
(if (dotflg m)
- then (for b in (buttons m) do (draw-button m b)) )
- ((deleted-buttons m) \:= nil)
+ (for b in (buttons m) do (draw-button m b)) )
+ ((deleted-buttons m) = nil)
(force-output mw) ))
; 05 Oct 92
-(gldefun picmenu-draw-button (m\:picmenu b\:picmenu-button)
+(gldefun picmenu-draw-button ((m picmenu) (b picmenu-button))
(let ((mw (menu-window m)))
(set-invert mw)
(draw-box-xy mw ((menu-x m 0) + (x (offset b)) - 2)
@@ -1492,115 +1605,117 @@
4 4 1)
(unset mw) ))
-; 05 Oct 92; 30 Oct 92
+; 05 Oct 92; 30 Oct 92; 17 May 04
; Delete a button and erase it from the display
-(gldefun picmenu-delete-named-button (m\:picmenu name\:symbol)
+(gldefun picmenu-delete-named-button ((m picmenu) (name symbol))
(let (b)
- (if (and (b \:= (assoc name (buttons m)))
+ (if (and (b = (assoc name (buttons m)))
~ (name <= (deleted-buttons m)))
- then (if (dotflg m) (draw-button m b))
- ((deleted-buttons m) +_ name) )
+ (progn (if (dotflg m) (draw-button m b))
+ ((deleted-buttons m) +_ name) ))
(force-output (menu-window m)) ))
; 09 Sep 91; 10 Sep 91; 18 Sep 91; 29 Sep 92; 26 Oct 92; 30 Oct 92; 06 May 93
-; 04 Aug 93; 07 JAN 94
+; 04 Aug 93; 07 Jan 94; 30 May 02; 17 May 04; 18 May 04; 01 Jun 04; 24 Jan 06
; inside = t if the mouse is already inside the menu area
; anyclick = value to return for a mouse click that is not on a button.
-(gldefun picmenu-select (m\:picmenu &optional inside anyclick)
- (let (mw current-button\:picmenu-button item items val\:picmenu-button
+(gldefun picmenu-select ((m picmenu) &optional inside anyclick)
+ (let (mw (current-button picmenu-button) item items (val picmenu-button)
xzero yzero codeval)
- (mw \:= (menuw m))
+ (mw = (menuw m))
(if ~ (permanent m) (draw m))
- (xzero \:= (menu-x m 0))
- (yzero \:= (menu-y m 0))
+ (xzero = (menu-x m 0))
+ (yzero = (menu-y m 0))
(track-mouse mw
#'(lambda (x y code)
(setq *window-menu-code* code)
- (x \:= (x - xzero))
- (y \:= (y - yzero))
+ (x = (x - xzero))
+ (y = (y - yzero))
(if ((x >= 0) and (x <= (picture-width m))
and (y >= 0) and (y <= (picture-height m)))
- then (inside \:= t))
+ (inside = t))
(if current-button
(if ~ (containsxy? current-button x y)
- then (unbox-item m current-button)
- (current-button \:= nil)))
+ (progn (unbox-item m current-button)
+ (current-button = nil))))
(if ~ current-button
- then (items \:= (buttons m))
+ (progn (items = (buttons m))
(while ~ current-button and (item -_ items) do
(if (and (containsxy? item x y)
- ~ ((name item) <= (deleted-buttons m)))
- then (box-item m item)
- (current-button \:= item))))
+ (not ((buttonname item) <=
+ (deleted-buttons m))))
+ (progn (box-item m item)
+ (current-button = item))))))
(if (or (> code 0)
(and inside (or (x < 0) (x > (picture-width m))
(y < 0) (y > (picture-height m)))))
- then (if current-button then (unbox-item m current-button))
- (codeval \:= code)
- (val \:= (if (and (> code 0) current-button)
- then current-button
- else *picmenu-no-selection*)) ))
+ (progn (if current-button (unbox-item m current-button))
+ (codeval = code)
+ (val = (if (and (> code 0) current-button)
+ current-button
+ *picmenu-no-selection*)) )))
t)
(if ~(permanent m)
- (if (flat m) then (clear m)
- (force-output (menu-window m))
- else (close (menu-window m))))
- (if (val = *picmenu-no-selection*)
- then (and (> codeval 0) anyclick)
- else (name val)) ))
+ (if (flat m) (progn (clear m)
+ (force-output (menu-window m)))
+ (close (menu-window m))))
+ (if (val == *picmenu-no-selection*)
+ (and (> codeval 0) anyclick)
+ (buttonname val)) ))
-; 09 Sep 91; 10 Sep 91
-(gldefun picmenu-box-item (m\:picmenu item\:picmenu-button)
+; 09 Sep 91; 10 Sep 91; 17 May 04
+(gldefun picmenu-box-item ((m picmenu) (item picmenu-button))
(let ((mw (menuw m)) xoff yoff siz)
- (xoff \:= (menu-x m (x (offset item))))
- (yoff \:= (menu-y m (y (offset item))))
+ (xoff = (menu-x m (x (offset item))))
+ (yoff = (menu-y m (y (offset item))))
(if (highlightfn item)
- then (funcall (highlightfn item) (menuw m) xoff yoff)
- else (set-xor mw)
- (if (siz \:= (size item))
- then (draw-box-xy mw (xoff - (x siz) / 2)
+ (funcall (highlightfn item) (menuw m) xoff yoff)
+ (progn (set-xor mw)
+ (if (siz = (size item))
+ (draw-box-xy mw (xoff - (x siz) / 2)
(yoff - (y siz) / 2)
(x siz) (y siz) 1)
- else (draw-box-xy mw (xoff - 6) (yoff - 6) 12 12 1))
+ (draw-box-xy mw (xoff - 6) (yoff - 6) 12 12 1))
(unset mw)
- (force-output mw) ) ))
+ (force-output mw) ) )))
-; 09 Sep 91; 06 May 93
-(gldefun picmenu-unbox-item (m\:picmenu item\:picmenu-button)
+; 09 Sep 91; 06 May 93; 17 May 04
+(gldefun picmenu-unbox-item ((m picmenu) (item picmenu-button))
(let ((mw (menuw m)))
(if (unhighlightfn item)
- then (funcall (unhighlightfn item) (menuw m)
+ (progn (funcall (unhighlightfn item) (menuw m)
(x (offset item)) (y (offset item)))
- (force-output mw)
- else (box-item m item) ) ))
+ (force-output mw))
+ (box-item m item) ) ))
(defun picmenu-destroy (m) (menu-destroy m))
; 09 Sep 91; 10 Sep 91; 11 Sep 91
-(gldefun picmenu-button-containsxy? (b\:picmenu-button x\:integer y\:integer)
+(gldefun picmenu-button-containsxy? ((b picmenu-button) (x integer)
+ (y integer))
(let ((xsize 6) (ysize 6))
- (if (size b) then (xsize \:= (x (size b)) / 2)
- (ysize \:= (y (size b)) / 2))
+ (if (size b) (progn (xsize = (x (size b)) / 2)
+ (ysize = (y (size b)) / 2)))
((x >= ((x (offset b)) - xsize)) and (x <= ((x (offset b)) + xsize)) and
(y >= ((y (offset b)) - ysize)) and (y <= ((y (offset b)) + ysize)) ) ))
-; 11 Sep 91; 08 Sep 92; 18 Jan 94
-(gldefun picmenu-item-position (m\:picmenu itemname\:symbol
- &optional place\:symbol)
- (let (b\:picmenu-button (xsize 0) (ysize 0) xoff yoff)
+; 11 Sep 91; 08 Sep 92; 18 Jan 94; 30 May 02; 17 May 04; 24 Jan 06
+(gldefun picmenu-item-position ((m picmenu) (itemname symbol)
+ &optional (place symbol))
+ (let ((b picmenu-button) (xsize 0) (ysize 0) xoff yoff)
(if (null itemname)
- then (xsize \:= (picture-width m))
- (ysize \:= ((picture-height m) - (drawing-height m)) / 2)
- (xoff \:= xsize / 2)
- (yoff \:= (drawing-height m) + ysize / 2)
- else (if (b \:= (that (buttons m) with name = itemname))
- then (if (size b)
- then (xsize \:= (x (size b)))
- (ysize \:= (y (size b))))
- (xoff \:= (x (offset b)))
- (yoff \:= (y (offset b))) ) )
- (if xoff then (a vector with
+ (progn (xsize = (picture-width m))
+ (ysize = ((picture-height m) - (drawing-height m)) / 2)
+ (xoff = xsize / 2)
+ (yoff = (drawing-height m) + ysize / 2))
+ (if (b = (that (buttons m) with buttonname == itemname))
+ (progn (if (size b)
+ (progn (xsize = (x (size b)))
+ (ysize = (y (size b)))))
+ (xoff = (x (offset b)))
+ (yoff = (y (offset b))) ) ))
+ (if xoff (a vector with
x = ((menu-x m xoff) + (case place
((center top bottom) 0)
(left (- (xsize / 2)))
@@ -1612,14 +1727,15 @@
(top (ysize / 2))
else 0))) ) ))
-; 03 Jan 94; 18 Jan 94
+; 03 Jan 94; 18 Jan 94; 17 May 04
; Simple call from plain Lisp to make a picture menu.
+(setf (glfnresulttype 'barmenu-create) 'barmenu)
(gldefun barmenu-create
- (maxval\:integer initval\:integer barwidth\:integer
- &optional title horizontal\:boolean subtrackfn subtrackparms
- parentw\:window x y perm\:boolean flat\:boolean color\:rgb)
- (a barmenu with title = (if title (stringify title) else "")
- menu-window = (if flat then parentw)
+ ((maxval integer) (initval integer) (barwidth integer)
+ &optional title (horizontal boolean) subtrackfn subtrackparms
+ (parentw window) x y (perm boolean) (flat boolean) (color rgb))
+ (a barmenu with title = (if title (stringify title) "")
+ menu-window = (if flat parentw)
parent-window = (if parentw (parent parentw))
parent-offset-x = (or x 0)
parent-offset-y = (or y 0)
@@ -1633,97 +1749,198 @@
subtrackparms = subtrackparms
color = color) )
-; 03 Jan 94
-(gldefun barmenu-calculate-size (m\:barmenu)
+; 03 Jan 94; 17 May 04
+(gldefun barmenu-calculate-size ((m barmenu))
(let (maxwidth maxheight)
- (maxwidth \:= (max (if (title m) then ((* 9 (length (title m))) + 6)
- else 0)
+ (maxwidth = (max (if (title m) ((* 9 (length (title m))) + 6)
+ 0)
(barwidth m)))
- (maxheight \:= (if (and (title-present m)
+ (maxheight = (if (and (title-present m)
(or (flat m) *window-add-menu-title*))
- then 15 else 0)
+ 15 0)
+ (maxval m))
- ((picture-width m) \:= maxwidth)
- ((picture-height m) \:= maxheight) ))
+ ((picture-width m) = maxwidth)
+ ((picture-height m) = maxheight) ))
; 03 Jan 94
; Initialize a picture menu
-(gldefun barmenu-init (m\:barmenu)
+(gldefun barmenu-init ((m barmenu))
(let ()
(calculate-size m)
(adjust-offset m)
(if ~ (flat m)
- ((menu-window m) \:= (window-create (picture-width m)
+ ((menu-window m) = (window-create (picture-width m)
(picture-height m)
((title m) or "")
(parent-window m)
(parent-offset-x m)
(parent-offset-y m) )) ) ))
-; 03 Jan 94; 18 Jan 94
+; 03 Jan 94; 18 Jan 94; 17 May 04; 18 May 04
; Draw a picture menu
-(gldefun barmenu-draw (m\:barmenu)
+(gldefun barmenu-draw ((m barmenu))
(let (mw xzero yzero)
(init? m)
- (mw \:= (menu-window m))
+ (mw = (menu-window m))
(open mw)
(clear m)
- (xzero \:= (menu-x m ((picture-width m) / 2)))
- (yzero \:= (menu-y m 0))
- (if (color m) then (window-set-color mw (color m)))
+ (xzero = (menu-x m ((picture-width m) / 2)))
+ (yzero = (menu-y m 0))
+ (if (color m) (window-set-color mw (color m)))
(if (horizontal m)
- then (draw-line-xy (menu-window m) xzero yzero
+ (draw-line-xy (menu-window m) xzero yzero
(xzero + (value m)) yzero (barwidth m))
- else (draw-line-xy (menu-window m) xzero yzero
+ (draw-line-xy (menu-window m) xzero yzero
xzero (+ yzero (value m)) (barwidth m)) )
- (if (color m) then (window-reset-color mw))
+ (if (color m) (window-reset-color mw))
(force-output mw) ))
; 03 Jan 94; 04 Jan 94; 07 Jan 94; 18 Jan 94
; inside = t if the mouse is already inside the menu area
-(gldefun barmenu-select (m\:barmenu &optional inside)
+(gldefun barmenu-select ((m barmenu) &optional inside)
(let (mw xzero yzero val)
- (mw \:= (menuw m))
+ (mw = (menuw m))
(if ~ (permanent m) (draw m))
- (xzero \:= (menu-x m ((picture-width m) / 2)))
- (yzero \:= (menu-y m 0))
+ (xzero = (menu-x m ((picture-width m) / 2)))
+ (yzero = (menu-y m 0))
(when (window-track-mouse-in-region mw (menu-x m 0) yzero
(picture-width m) (picture-height m) t t)
(track-mouse mw
#'(lambda (x y code)
(setq *window-menu-code* code)
- (val \:= (if (horizontal m) then (x - xzero) else (y - yzero)))
+ (val = (if (horizontal m) (x - xzero) (y - yzero)))
(update-value m val)
(if (> code 0) code) ))
val) ))
-; 03 Jan 93
+; 03 Jan 93; 17 May 04
(defvar *barmenu-update-value-cons* (cons nil nil)) ; reusable cons
-(gldefun barmenu-update-value (m\:barmenu val\:integer)
+(gldefun barmenu-update-value ((m barmenu) (val integer))
(let ((mw (menuw m)) xzero yzero)
- (val \:= (max 0 (min val (maxval m))))
+ (val = (max 0 (min val (maxval m))))
(if (val <> (value m))
- then (if (val < (value m))
- then (set-erase mw)
- else (if (color m) then (window-set-color mw (color m))))
- (xzero \:= (menu-x m ((picture-width m) / 2)))
- (yzero \:= (menu-y m 0))
+ (progn (if (val < (value m))
+ (set-erase mw)
+ (if (color m) (window-set-color mw (color m))))
+ (xzero = (menu-x m ((picture-width m) / 2)))
+ (yzero = (menu-y m 0))
(if (horizontal m)
- then (draw-line-xy (menu-window m)
+ (draw-line-xy (menu-window m)
(+ xzero (value m)) yzero
(+ xzero val) yzero (barwidth m))
- else (draw-line-xy (menu-window m)
+ (draw-line-xy (menu-window m)
xzero (+ yzero (value m))
xzero (+ yzero val) (barwidth m)) )
(if (val < (value m))
- then (unset mw)
- else (if (color m) then (window-reset-color mw)) )
- ((value m) \:= val)
+ (unset mw)
+ (if (color m) (window-reset-color mw)) )
+ ((value m) = val)
(if (subtrackfn m)
- then ((car *barmenu-update-value-cons*) \:= val)
- ((cdr *barmenu-update-value-cons*) \:= (subtrackparms m))
- (apply (subtrackfn m) *barmenu-update-value-cons*))
- (force-output mw) ) ))
+ (progn ((car *barmenu-update-value-cons*) = val)
+ ((cdr *barmenu-update-value-cons*) = (subtrackparms m))
+ (apply (subtrackfn m) *barmenu-update-value-cons*)))
+ (force-output mw) ) )))
+
+; Functions for text input "menus". Derived from picmenu code.
+; Making text input analogous to menus allows use with menu-sets.
+
+; 18 Apr 95; 17 May 04
+; (setq tm (textmenu-create 200 30 nil myw 50 50 t t '9x15 t "Rutabagas"))
+; Simple call from plain Lisp to make a text menu.
+(setf (glfnresulttype 'textmenu-create) 'textmenu)
+(gldefun textmenu-create ((width integer) (height integer)
+ &optional title (parentw window) x y
+ (perm boolean) (flat boolean)
+ (font symbol) (boxflg boolean)
+ (initial-text string))
+ (a textmenu with title = (if title (stringify title) "")
+ menu-window = (if flat parentw)
+ parent-window = (if parentw (parent parentw))
+ parent-offset-x = (or x 0)
+ parent-offset-y = (or y 0)
+ permanent = perm
+ flat = flat
+ drawing-width = width
+ drawing-height = height
+ menu-font = (font or '9x15)
+ boxflg = boxflg
+ text = initial-text) )
+
+; 18 Apr 95; 17 May 04
+(gldefun textmenu-calculate-size ((m textmenu))
+ (let (maxwidth maxheight)
+ (maxwidth = (max (if (title m) ((* 9 (length (title m))) + 6)
+ 0)
+ (drawing-width m)))
+ (maxheight = (if (and (title-present m)
+ (or (flat m) *window-add-menu-title*))
+ 15 0)
+ + (drawing-height m))
+ ((picture-width m) = maxwidth)
+ ((picture-height m) = maxheight) ))
+
+; 18 Apr 95
+; Initialize a picture menu
+(gldefun textmenu-init ((m textmenu))
+ (let ()
+ (calculate-size m)
+ (adjust-offset m)
+ (if ~ (flat m)
+ ((menu-window m) =
+ (window-create (picture-width m) (picture-height m)
+ ((title m) or "") (parent-window m)
+ (parent-offset-x m) (parent-offset-y m)
+ (menu-font m) )) ) ))
+
+; 18 Apr 95; 14 Aug 96; 17 May 04
+; Draw a picture menu
+(gldefun textmenu-draw ((m textmenu))
+ (let (mw bottom xzero yzero)
+ (init? m)
+ (mw = (menu-window m))
+ (open mw)
+ (clear m)
+ (xzero = (menu-x m 0))
+ (yzero = (menu-y m 0))
+ (bottom = yzero + (picture-height m))
+ (if (and (title-present m)
+ (or (flat m) *window-add-menu-title*))
+ (progn (printat-xy mw (stringify (title m)) (xzero + 3) (bottom - 13))
+ (invert-area-xy mw xzero (bottom - 15) (picture-width m) 16)))
+ (if (text m)
+ (printat-xy mw (text m) (xzero + 10)
+ (yzero + (picture-height m) / 2 - 8)))
+ (if (boxflg m) (draw-box-xy mw xzero yzero
+ (picture-width m) (picture-height m) 1))
+ (force-output mw) ))
+
+; 18 Apr 95; 20 Apr 95; 21 Apr 95; 14 Aug 96; 17 May 04; 01 Jun 04
+(gldefun textmenu-select ((m textmenu) &optional inside)
+ (let (mw xzero yzero codeval res)
+ (mw = (menuw m))
+ (if ~ (permanent m) (draw m))
+ (xzero = (menu-x m 0))
+ (yzero = (menu-y m 0))
+ (track-mouse mw
+ #'(lambda (x y code)
+ (setq *window-menu-code* code)
+ (x = (x - xzero))
+ (y = (y - yzero))
+ (if (or (> code 0)
+ (or (x < 0) (x > (picture-width m))
+ (y < 0) (y > (picture-height m))))
+ (codeval = code)) )
+ t)
+ (if (and (not (permanent m)) (not (flat m)))
+ (close (menu-window m)))
+ (if (codeval > 0)
+ (progn (draw m)
+ (input-string mw (text m) (xzero + 10)
+ (yzero + (picture-height m) / 2 - 8)
+ ((picture-width m) - 12)) ) )))
+
+(gldefun textmenu-set-text ((m textmenu) &optional (s string))
+ ((text m) = (or s "")))
; 15 Aug 91
; Get a point position by mouse click. Returns (x y).
@@ -2036,7 +2253,7 @@
; 31 Dec 93
; Reset window colors to default foreground and background.
-(gldefun window-reset-color (w\:window)
+(gldefun window-reset-color ((w window))
(XSetForeground *window-display* (gcontext w) *default-fg-color*)
(XSetBackground *window-display* (gcontext w) *default-bg-color*) )
@@ -2077,10 +2294,11 @@
(XFreeColors *window-display*
*default-colormap* xcolor 1 0)) ) )
-; 31 Dec 93
-; Get characters within a window, calling function fn with arg (char).
+; 31 Dec 93; 18 Jul 96; 25 Jul 96
+; Get characters or mouse clicks within a window, calling function fn
+; with arguments (char button x y args).
; Tracking continues until fn returns non-nil; result is that value.
-(defun window-get-chars (w fn)
+(defun window-get-chars (w fn &optional args)
(let (win res)
(or *window-keyinit* (window-init-keymap))
(setq *window-shift* nil)
@@ -2089,22 +2307,23 @@
(setq win (window-parent w))
(Xsync *window-display* 1) ; clear event queue of prev motion events
(Xselectinput *window-display* win
- (+ KeyPressMask KeyReleaseMask))
+ (+ KeyPressMask KeyReleaseMask ButtonPressMask))
;; Event processing loop: stop when function returns non-nil.
(while (null res)
(XNextEvent *window-display* *window-event*)
(let ((type (XAnyEvent-type *window-event*))
(eventwindow (XAnyEvent-window *window-event*)))
(if (eql eventwindow win)
- (setq res (window-process-char-event w type fn))) ))
+ (setq res (window-process-char-event w type fn args))) ))
res))
-; 31 Dec 93; 18 Jan 94; 04 Oct 94
+; 31 Dec 93; 18 Jan 94; 04 Oct 94; 18 Jul 96; 19 Jul 96; 22 Jul 96; 23 Jul 96
+; 25 Jul 96
; Process a character event. type is event type.
; For Control, Shift, and Meta, global flags are set.
-; fn is called for other characters.
-(defun window-process-char-event (w type fn)
- (let (code)
+; (fn char button x y) is called for other characters.
+(defun window-process-char-event (w type fn args)
+ (let (code eventwindow)
(if (eql type KeyRelease)
(progn
(setq code (XButtonEvent-button *window-event*))
@@ -2123,11 +2342,26 @@
(progn (setq *window-ctrl* t) nil)
(if (member code *window-meta-keys*)
(progn (setq *window-meta* t) nil)
- (funcall fn w (or (aref (if *window-shift*
- *window-shiftkeymap*
- *window-keymap*)
- code)
- #\Space)) ))))) ) ))
+ (funcall fn w (window-char-decode code) 0 0 0
+ args) ))))
+ (if (eql type ButtonPress)
+ (funcall fn w 0 (XButtonEvent-button *window-event*)
+ (XMotionEvent-x *window-event*)
+ (- (window-drawable-height w)
+ (XMotionEvent-y *window-event*))
+ args)) ) ) ))
+
+; 23 Jul 96; 23 Dec 96
+; Change keyboard code into character; assumes ASCII for control chars
+(defun window-char-decode (code)
+ (let (char)
+ (setq char (aref (if *window-shift* *window-shiftkeymap* *window-keymap*)
+ code))
+ (if (and char *window-ctrl*)
+ (setq char (code-char (- (char-code (char-upcase char)) 64))))
+ (if (and char *window-meta*) ; simulate meta using 128
+ (setq char (code-char (+ (char-code (char-upcase char)) 128))))
+ (or char #\Space) ))
; 31 Dec 93; 04 Oct 94; 16 Nov 94
; Get character within a window, calling function fn with arg (char).
@@ -2152,68 +2386,450 @@
(setq res (XButtonEvent-button *window-event*)) ) ))
res))
-; 31 Dec 93
+; 31 Dec 93; 19 Jul 96; 12 Aug 96; 13 Aug 96
; Input a string from keyboard, echo in window. str is initial string.
; Backspace is handled; terminate with return. Size is max width in pixels.
(defun window-input-string (w str x y &optional size)
+ (car (window-edit w x y (or size 100) 16 (list (or str "")) nil t t) ) )
+
+; 19 Jul 96; 22 Jul 96; 12 Aug 96; 13 Aug 96
+; Edit strings in a window area with Emacs-subset editor
+; strings is a list of strings, which is the return value
+; scroll is number of lines to scroll down before displaying text,
+; or t to have one line only and terminate on return.
+; endp is T to begin edit at end of first line
+; e.g. (window-draw-box-xy myw 48 48 204 204)
+; (window-edit myw 50 50 200 200 '("Now is the time" "for all" "good"))
+(gldefun window-edit (w x y width height &optional strings boxflg scroll endp)
+ (let (em)
+ (em = (editmenu-create width height nil w x y nil t '9x15 boxflg
+ strings scroll endp))
+ (edit em)
+ (carat em) ; erase the carat
+ (text em) ))
+
+; 25 Jul 96; 26 Jul 96; 12 Aug 96; 13 Aug 96; 15 Aug 96; 17 May 04
+; (setq em (editmenu-create 200 30 nil myw 50 50 t t '9x15 t ("Rutabagas")))
+; Simple call from plain Lisp to make an edit menu.
+(setf (glfnresulttype 'editmenu-create) 'editmenu)
+(gldefun editmenu-create ((width integer) (height integer)
+ &optional title (parentw window) x y
+ (perm boolean) (flat boolean)
+ (font symbol) (boxflg boolean)
+ (initial-text (listof string))
+ scrollval (endp boolean))
+ (an editmenu with title = (if title (stringify title) "")
+ menu-window = (if flat parentw)
+ parent-window = (if parentw (parent parentw))
+ parent-offset-x = (or x 0)
+ parent-offset-y = (or y 0)
+ permanent = perm
+ flat = flat
+ drawing-width = width
+ drawing-height = height
+ menu-font = (font or '9x15)
+ boxflg = boxflg
+ text = (or initial-text (list ""))
+ scrollval = (or scrollval 0)
+ line = (if (numberp scrollval)
+ scrollval
+ 0)
+ column = (if endp
+ (length (car (nthcdr
+ (if (numberp scrollval)
+ scrollval
+ 0)
+ initial-text)))
+ 0)) )
+
+; 25 Jul 96
+(gldefun editmenu-calculate-size ((m editmenu))
+ ((picture-width m) = (drawing-width m))
+ ((picture-height m) = (drawing-height m)) )
+
+; 18 Apr 95
+; Initialize a picture menu
+(gldefun editmenu-init ((m editmenu))
(let ()
- (setq *window-input-string-x* x)
- (setq *window-input-string-y* y)
- (setq *window-input-string-charwidth* (window-string-width w "M"))
- (setq *window-string-max* (if size
- (/ size *window-input-string-charwidth*)
- 100))
- (setq *window-string-count* (if str (min (length str)
- *window-string-max*)
- 0))
- (window-erase-area-xy w x (- y 2) (or size 100) 14)
- (if (> *window-string-count* 0)
- (progn (dotimes (i *window-string-count*)
- (setf (char *window-string* i) (char str i)) )
- (window-printat-xy w str x y)))
- (window-draw-carat w)
- (window-get-chars w #'window-input-char-fn) ))
+ (calculate-size m)
+ (adjust-offset m)
+ (if ~ (flat m)
+ ((menu-window m) =
+ (window-create (picture-width m) (picture-height m)
+ ((title m) or "") (parent-window m)
+ (parent-offset-x m) (parent-offset-y m)
+ (menu-font m) )) ) ))
-; 31 Dec 93
-; Process input characters for window-input-string
-(defun window-input-char-fn (w char)
- (let ((tmpstring "Z"))
- (window-draw-carat w) ; erase the input pointer
- (if (char= char #\Return)
- (subseq *window-string* 0 *window-string-count*)
- (progn
- (if (char= char #\Backspace)
- (if (> *window-string-count* 0)
- (progn (decf *window-string-count*)
- (window-printat-xy w " "
- (+ *window-input-string-x*
- (* *window-string-count*
- *window-input-string-charwidth*))
- *window-input-string-y*)
- (window-draw-carat w)))
- (if (< *window-string-count* *window-string-max*)
- (progn (setf (char *window-string* *window-string-count*)
- char)
- (incf *window-string-count*)
- (setf (char tmpstring 0) char)
- (window-printat-xy w tmpstring
- (+ *window-input-string-x*
- (* (1- *window-string-count*)
- *window-input-string-charwidth*))
- *window-input-string-y*)
- (window-draw-carat w))))
- nil) ) )) ; return nil to continue input
+; 25 Jul 96; 31 July 96; 14 Aug 96
+(gldefun editmenu-draw ((m editmenu))
+ (let (mw xzero yzero)
+ (init? m)
+ (mw = (menu-window m))
+ (open mw)
+ (clear m)
+ (xzero = (menu-x m 0))
+ (yzero = (menu-y m 0))
+ (if (boxflg m) (draw-box-xy mw xzero yzero
+ (picture-width m) (picture-height m) 1))
+ (display m 0 0 (not (numberp scrollval))) ))
-; 31 Dec 93
-(defun window-draw-carat (w)
- (let ((origx *window-input-string-x*) (y *window-input-string-y*) x)
- (setq x (+ origx (* *window-input-string-charwidth*
- *window-string-count*)))
+; 19 Jul 96; 22 Jul 96; 23 Jul 96; 25 Jul 96; 31 July 96; 01 Aug 96; 17 May 04
+; 18 Aug 04; 27 Jan 06
+; Display contents of edit area
+; Begin with the specified line and char number; one line only if only is T.
+(gldefun editmenu-display ((m editmenu) line char only)
+ (let (lines y maxwidth linewidth (w (menuw m)))
+ (setq lines (nthcdr line (text m)))
+ (setq y (line-y m (- line (scroll m))))
+ (setq maxwidth (truncate (- (picture-width m) 6) (font-width (menuw m))))
+ (while (and lines (>= y (menu-y m 4)))
+ (when (< char maxwidth)
+ (if (> char 0)
+ (printat-xy w (subseq (first lines) char
+ (min maxwidth (length (first lines))))
+ (menu-x m (+ 2 (* char (font-width (menuw m)))))
+ y)
+ (printat-xy w (if (<= (length (first lines)) maxwidth)
+ (first lines)
+ (subseq (first lines) 0 maxwidth))
+ (menu-x m 2) y)))
+ (setq linewidth (+ 2 (* (font-width (menuw m)) (length (first lines)))))
+ (window-erase-area-xy w (menu-x m linewidth)
+ (- y 2)
+ (- (picture-width m) (+ linewidth 2))
+ (font-height (menuw m)))
+ (y _- (font-height (menuw m)))
+ (if only (setq lines nil)
+ (progn (pop lines)
+ (if (and (null lines) (>= y (menu-y m 4)))
+ ; erase an extra line at the end
+ (window-erase-area-xy w (menu-x m 2)
+ (- y 2)
+ (- (picture-width m) 4)
+ (font-height (menuw m))) ) ))
+ (setq char 0) )
+ (force-output w) ))
+
+; 19 Jul 96; 22 Jul 96; 25 Jul 96; 31 Jul 96; 01 Aug 96
+; draw/erase carat at the specified position
+(gldefun editmenu-carat ((m editmenu))
+ (let ((w (menuw m)))
+ (draw-carat w (menu-x m (+ 2 (* (column m) (font-width (menuw m)))))
+ (- (line-y m (line m)) 2))
+ (force-output w) ))
+
+; 19 Jul 96; 25 Jul 96; 31 Jul 96; 01 Aug 96; 17 May 04
+; erase at the current position. onep = t to erase only one char
+(gldefun editmenu-erase ((m editmenu) onep)
+ (let ((w (menuw m)) xw)
+ (xw = (+ 2 (* (font-width w) (column m))))
+ (erase-area-xy w (menu-x m xw)
+ (- (line-y m (line m)) (cadr (string-extents w "Tg")))
+ (if onep (font-width w)
+ (- (picture-width m) xw))
+ (font-height w))
+ (force-output w) ))
+
+; 01 Aug 96
+; Calculate the y position of the current line
+(gldefun editmenu-line-y ((m editmenu) (line integer))
+ (menu-y m (- (picture-height m)
+ (+ -1 (* (font-height (menuw m))
+ (1+ (- line (scroll m))))))) )
+
+; 25 Jul 96; 30 Jul 96; 31 Jul 96; 01 Aug 96; 13 Aug 96; 24 Sep 96; 08 Jan 97
+; 17 May 04
+(gldefun editmenu-select ((m editmenu) &optional inside)
+ (let (mw codeval res xval yval)
+ (mw = (menuw m))
+ (if ~ (permanent m) (draw m))
+ (track-mouse mw
+ #'(lambda (x y code)
+ (setq *window-menu-code* code)
+ (if (or (> code 0)
+ (x < (parent-offset-x m))
+ (x > (+ (parent-offset-x m) (picture-width m)))
+ (y < (parent-offset-y m))
+ (y > (+ (parent-offset-y m) (picture-height m))))
+ (progn (codeval = code)
+ (xval = x)
+ (yval = y)) ))
+ t)
+; (if (and (not (permanent m)) (not (flat m)) (close (menu-window m)))) ; ??
+ (if (codeval > 0)
+ (editmenu-edit m codeval xval yval)) ))
+
+; 13 Aug 96; 15 Aug 96
+; begin active editing of an editmenu.
+; (code x y), if present, represent a mouse click in the window.
+(gldefun editmenu-edit ((m editmenu) &optional code x y)
+ (let ((mw (menuw m)))
+ (draw m)
+ (carat m)
+ (if code (editmenu-edit-fn mw nil code x y (list m)) )
+ (setq *window-editmenu-kill-strings* nil)
+ (window-get-chars mw #'editmenu-edit-fn (list m))
+ (text m) ))
+
+
+; 31 Dec 93; 18 Jul 96; 19 Jul 96; 22 Jul 96; 23 Jul 96; 25 Jul 96; 26 Jul 96
+; 30 Jul 96; 13 Aug 96; 14 Aug 96; 23 Dec 96; 17 May 04; 18 May 04
+; Process input characters and mouse clicks for editmenu eidting
+(gldefun editmenu-edit-fn ((w window) char (button integer) (buttonx integer)
+ (buttony integer) args)
+ (let (m\:editmenu inside done)
+ (m = (car args))
+ (carat m) ; erase carat
+ (if (and (numberp button)
+ (not (zerop button)))
+ (progn (inside = (editmenu-setxy m buttonx buttony))
+ (case button
+ (1 (if inside
+ (progn (carat m) nil) ; return nil to continue input
+ t)) ; quit on click outside the editing area
+ (2 (if inside
+ (progn (editmenu-yank m)
+ (carat m)
+ nil)) )))
+ (progn (if (< (char-code char) 32)
+ (case char of
+ (#\Return (if (numberp (scrollval m))
+ (editmenu-return m)
+ (done = t)) )
+ (#\Backspace (editmenu-backspace m))
+ (#\^D (editmenu-delete m))
+ (#\^N (if (numberp (scrollval m))
+ (editmenu-next m)))
+ (#\^P (editmenu-previous m))
+ (#\^F (editmenu-forward m))
+ (#\^B (editmenu-backward m))
+ (#\^A (editmenu-beginning m))
+ (#\^E (editmenu-end m))
+ (#\^K (editmenu-kill m))
+ (#\^Y (editmenu-yank m))
+ else nil)
+ (if (> (char-code char) 128)
+ (progn (setq char (code-char
+ (- (char-code char) 128)))
+ (case char of
+ (#\B (editmenu-meta-b m))
+ (#\F (editmenu-meta-f m))
+ else nil))
+ (editmenu-char m char)))
+ (carat m)
+ done) ))) ; return nil to continue input
+
+; 31 Jul 96; 15 Aug 96; 17 May 04
+; Set cursor location based on mouse click; returns T if inside menu region
+(gldefun editmenu-setxy ((m editmenu) (buttonx integer) (buttony integer))
+ (let (linecons okay)
+ (setq okay
+ (and (>= buttonx (parent-offset-x m))
+ (<= buttonx (+ (parent-offset-x m) (picture-width m)))
+ (>= buttony (parent-offset-y m))
+ (<= buttony (+ (parent-offset-y m) (picture-height m))) ))
+ (if okay
+ (progn ((line m) = (min (1- (length (text m)))
+ (+ (scroll m)
+ (truncate (- (menu-y m (- (picture-height m) 6))
+ buttony)
+ (font-height (menuw m))))))
+ (linecons = (nthcdr (line m) (text m)))
+ ((column m) = (min (length (car linecons))
+ (truncate (- buttonx (menu-x m 2))
+ (font-width (menuw m))))) ))
+ okay))
+
+; 19 Jul 96; 22 Jul 96; 25 Jul 96; 17 May 04
+; Process an ordinary input character
+(gldefun editmenu-char ((m editmenu) char)
+ (let ((linecons (nthcdr (line m) (text m))) )
+ (if (<= (length (car linecons)) (column m))
+ ((car linecons) = ; insert char at end of line
+ (concatenate 'string (car linecons) (string char)))
+ ((car linecons) = ; insert char in middle of line
+ (concatenate 'string
+ (subseq (car linecons) 0 (column m))
+ (string char)
+ (subseq (car linecons) (column m)))) )
+ (display m (line m) (column m) t)
+ ((column m) _+ 1) ))
+
+; 23 Dec 96
+; Get the current character in an editment
+(gldefun editmenu-current-char ((m editmenu))
+ (let ((linecons (nthcdr (line m) (text m))) )
+ (char (car linecons) (column m)) ))
+
+; 19 Jul 96; 22 Jul 96; 25 Jul 96; 17 May 04
+; Process a Return character
+(gldefun editmenu-return ((m editmenu))
+ (let ((linecons (nthcdr (line m) (text m))))
+ (if (<= (length (car linecons)) (column m))
+ ((cdr linecons) = (cons "" (cdr linecons))) ; end of line
+ (progn ((cdr linecons) = (cons (subseq (car linecons) (column m))
+ (cdr linecons)))
+ ((car linecons) = (subseq (car linecons) 0 (column m)))))
+ (display m (line m) 0 nil)
+ ((line m) _+ 1)
+ ((column m) = 0) ))
+
+; 19 Jul 96; 22 Jul 96; 25 Jul 96; 30 Jul 96; 31 Jul 96; 17 May 04
+; Process a backspace
+(gldefun editmenu-backspace ((m editmenu))
+ (let (tmp linedel (linecons (nthcdr (line m) (text m))))
+ (if (> (column m) 0)
+ (progn ((column m) _- 1) ; middle/end of line
+ ((car linecons) =
+ (concatenate 'string
+ (subseq (car linecons) 0 (column m))
+ (subseq (car linecons)
+ (1+ (column m))))))
+ (if (> (line m) 0)
+ (progn ((line m) _- 1)
+ (linedel = t)
+ (linecons = (nthcdr (line m) (text m)))
+ ((column m) = (length (car linecons)))
+ (tmp = (concatenate 'string (car linecons)
+ (cadr linecons)))
+ ((cdr linecons) = (cddr linecons))
+ ((car linecons) = tmp) ) ))
+ (display m (line m) (column m) (not linedel)) ))
+
+; 23 Jul 96; 25 Jul 96
+; Move cursor to end of line: C-E
+(gldefun editmenu-end ((m editmenu))
+ (let ((linecons (nthcdr (line m) (text m))) )
+ ((column m) = (length (car linecons))) ))
+
+; 23 Jul 96; 25 Jul 96
+; Move cursor to beginning of line: C-A
+(gldefun editmenu-beginning ((m editmenu))
+ ((column m) = 0))
+
+; 22 Jul 96; 25 Jul 96; 14 Aug 96; 17 May 04
+; Move cursor forward: C-F
+(gldefun editmenu-forward ((m editmenu))
+ (let ((linecons (nthcdr (line m) (text m))))
+ (if (< (column m) (length (car linecons)))
+ ((column m) _+ 1)
+ (if (numberp (scrollval m))
+ (progn ((line m) _+ 1)
+ (if (null (cdr linecons))
+ ((cdr linecons) = (list "")))
+ ((column m) = 0)) ) )))
+
+; 23 Dec 96; 17 May 04
+; Move cursor forward over a word: M-F
+(gldefun editmenu-meta-f ((m editmenu))
+ (let (found done)
+ (while (and (or (< (line m) (1- (length (text m))))
+ (< (column m) (length (nth (line m) (text m)))))
+ (not found))
+ (if (editmenu-alphanumbericp (editmenu-current-char m))
+ (found = t)
+ (editmenu-forward m) ) )
+ (if found
+ (while (and (or (< (line m) (1- (length (text m))))
+ (< (column m) (length (nth (line m) (text m)))))
+ (not done))
+ (if (editmenu-alphanumbericp (editmenu-current-char m))
+ (editmenu-forward m)
+ (done = t) )) ) ))
+
+; 23 Dec 96
+; alphanumbericp not defined in gcl
+(defun editmenu-alphanumbericp (x)
+ (or (alpha-char-p x) (not (null (digit-char-p x)))) )
+
+; 22 Jul 96; 25 Jul 96
+; Move cursor to next line: C-N
+(gldefun editmenu-next ((m editmenu))
+ (let ((linecons (nthcdr (line m) (text m))))
+ ((line m)_+ 1)
+ (if (null (cdr linecons))
+ ((cdr linecons) = (list "")))
+ (setq linecons (cdr linecons))
+ ((column m) = (min (column m) (length (car linecons)))) ))
+
+; 22 Jul 96; 23 Jul 96; 25 Jul 96; 30 Jul 96; 17 May 04
+; Move cursor backward: C-B
+(gldefun editmenu-backward ((m editmenu))
+ (if (> (column m) 0)
+ ((column m) _- 1)
+ (if (> (line m) 0)
+ (progn ((line m) _- 1)
+ ((column m) = (length (nth (line m) (text m)))) ) ) ))
+
+; 23 Dec 96; 17 May 04
+; Move cursor backward over a word: M-B
+(gldefun editmenu-meta-b ((m editmenu))
+ (let (found done)
+ (while (and (or (> (column m) 0) (> (line m) 0))
+ (not found))
+ (editmenu-backward m)
+ (if (editmenu-alphanumbericp (editmenu-current-char m))
+ (found = t)))
+ (if found
+ (progn (while (and (or (> (column m) 0) (> (line m) 0))
+ (not done))
+ (if (editmenu-alphanumbericp (editmenu-current-char m))
+ (editmenu-backward m)
+ (done = t) ))
+ (unless (editmenu-alphanumbericp (editmenu-current-char m))
+ (editmenu-forward m)) ) )))
+
+; 22 Jul 96; 23 Jul 96; 25 Jul 96; 17 May 04
+; Move cursor to previous line: C-P
+(gldefun editmenu-previous ((m editmenu))
+ (if (> (line m) 0)
+ (progn ((line m) _- 1)
+ ((column m) = (min (column m)
+ (length (nth (line m) (text m))))))))
+
+; 23 Jul 96; 25 Jul 96
+; Delete character ahead of cursor: C-D
+(gldefun editmenu-delete ((m editmenu))
+ (editmenu-forward m)
+ (editmenu-backspace m))
+
+(defvar *window-editmenu-kill-strings* nil)
+
+; 31 Jul 96; 17 May 04
+(gldefun editmenu-kill ((m editmenu))
+ (let ((linecons (nthcdr (line m) (text m))))
+ (if ((column m) < (length (car linecons)))
+ (progn (setq *window-editmenu-kill-strings*
+ (list (subseq (car linecons) (column m))))
+ ((car linecons) = (subseq (car linecons) 0 (column m)))
+ (display m (line m) (column m) t))
+ (editmenu-delete m) ) ))
+
+; 31 Jul 96; 01 Aug 96; 17 May 04
+(gldefun editmenu-yank ((m editmenu))
+ (let ((linecons (nthcdr (line m) (text m))) (col (column m)))
+ (when *window-editmenu-kill-strings*
+ (if (<= (length (car linecons)) (column m))
+ (progn ((car linecons) = ; insert at end of line
+ (concatenate 'string (car linecons)
+ (car *window-editmenu-kill-strings*)))
+ ((column m) = (length (car linecons))))
+ (progn ((car linecons) = ; insert in middle of line
+ (concatenate 'string
+ (subseq (car linecons) 0 col)
+ (car *window-editmenu-kill-strings*)
+ (subseq (car linecons) col)))
+ ((column m) _+ (length (car *window-editmenu-kill-strings*))) ))
+ (display m (line m) col t) ) ))
+
+; 31 Dec 93; 19 Jul 96
+; Draw a carat symbol /\ centered at x and with top at y.
+(defun window-draw-carat (w x y)
(window-set-xor w)
- (window-draw-line-xy w (- x 2) (- y 2) (+ x 3) y)
- (window-draw-line-xy w (+ x 3) y (+ x 8) (- y 2))
+ (window-draw-line-xy w (- x 5) (- y 2) x y)
+ (window-draw-line-xy w x y (+ x 5) (- y 2))
(window-unset w)
- (window-force-output w) ))
+ (window-force-output w) )
; 31 Dec 93; 04 Oct 94; 15 Nov 94; 16 Nov 94; 14 Mar 95
; Initialize mapping between keys and ASCII.
Index: xgcl-2/gcl_dwtest.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/xgcl-2/gcl_dwtest.lsp,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -b -r1.1.2.1 -r1.1.2.2
--- xgcl-2/gcl_dwtest.lsp 5 Jan 2006 17:55:35 -0000 1.1.2.1
+++ xgcl-2/gcl_dwtest.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.2
@@ -1,8 +1,8 @@
-; dwtest.lsp Gordon S. Novak Jr. 20 Oct 94
+; dwtest.lsp Gordon S. Novak Jr. 10 Jan 96
; Some examples for testing the window interface in dwindow.lsp / dwtrans.lsp
-; Copyright (c) 1994 Gordon S. Novak Jr. and The University of Texas at Austin.
+; Copyright (c) 1996 Gordon S. Novak Jr. and The University of Texas at Austin.
; See the file gnu.license .
@@ -23,62 +23,71 @@
; Written by: Gordon S. Novak Jr., Department of Computer Sciences,
; University of Texas at Austin 78712. address@hidden
-
-(defvar myw) ; my window
+(use-package :xlib)
+(defmacro while (test &rest forms)
+ `(loop (unless ,test (return)) ,@forms) )
+
+(defvar *myw*) ; my window
+(defvar myw)
+
+(defun xgcl nil
+ (format t "Welcome to xgcl! Please see dwdoc for details.~% Or try
(wtestc) .. (wtestk) for examples.~%")
+ (wtesta)
+ (wtestb))
; Make a window to play in.
(defun wtesta ()
- (setq myw (window-create 300 300 "test window")) )
+ (setq myw (setq *myw* (window-create 300 300 "test window"))) )
; 15 Aug 91; 12 Sep 91; 05 Oct 94; 06 Oct 94
; Draw some basic things in the window
(defun wtestb ()
- (window-clear myw)
- (window-draw-box-xy myw 50 50 50 20 1)
- (window-printat myw "howdy" '(58 55))
- (window-draw-line myw '(100 70) '(200 170))
- (window-draw-arrow-xy myw 200 170 165 205)
- (window-draw-circle-xy myw 200 170 50 2)
- (window-draw-ellipse-xy myw 100 170 40 20 1)
- (window-printat-xy myw "ellipse" 70 165)
- (window-draw-arc-xy myw 100 250 20 20 0 90 1)
- (window-draw-arc-xy myw 100 250 20 20 0 -90 1)
- (window-printat-xy myw "arcs" 80 244)
- (window-printat-xy myw "invert" 54 200)
- (window-invert-area-xy myw 50 160 60 60)
- (window-copy-area-xy myw 40 150 200 50 60 40)
- (window-printat-xy myw "copy" 210 100)
- (window-set-color-rgb myw 65535 0 0) ; red foreground
- (window-printat-xy myw "Red" 20 20)
- (window-draw-rcbox-xy myw 15 15 32 20 5)
- (window-set-color-rgb myw 0 0 65535 t) ; blue background
- (window-set-color-rgb myw 0 65535 0) ; green foreground
- (window-printat-xy myw "Green" 120 20)
- (window-set-color-rgb myw 0 65535 0 t) ; green background
- (window-set-color-rgb myw 0 0 65535) ; blue foreground
- (window-printat-xy myw "Blue" 220 20)
- (window-reset-color myw)
- (window-force-output myw) )
+ (window-clear *myw*)
+ (window-draw-box-xy *myw* 50 50 50 20 1)
+ (window-printat *myw* "howdy" '(58 55))
+ (window-draw-line *myw* '(100 70) '(200 170))
+ (window-draw-arrow-xy *myw* 200 170 165 205)
+ (window-draw-circle-xy *myw* 200 170 50 2)
+ (window-draw-ellipse-xy *myw* 100 170 40 20 1)
+ (window-printat-xy *myw* "ellipse" 70 165)
+ (window-draw-arc-xy *myw* 100 250 20 20 0 90 1)
+ (window-draw-arc-xy *myw* 100 250 20 20 0 -90 1)
+ (window-printat-xy *myw* "arcs" 80 244)
+ (window-printat-xy *myw* "invert" 54 200)
+ (window-invert-area-xy *myw* 50 160 60 60)
+ (window-copy-area-xy *myw* 40 150 200 50 60 40)
+ (window-printat-xy *myw* "copy" 210 100)
+ (window-set-color-rgb *myw* 65535 0 0) ; red foreground
+ (window-printat-xy *myw* "Red" 20 20)
+ (window-draw-rcbox-xy *myw* 15 15 32 20 5)
+ (window-set-color-rgb *myw* 0 0 65535 t) ; blue background
+ (window-set-color-rgb *myw* 0 65535 0) ; green foreground
+ (window-printat-xy *myw* "Green" 120 20)
+ (window-set-color-rgb *myw* 0 65535 0 t) ; green background
+ (window-set-color-rgb *myw* 0 0 65535) ; blue foreground
+ (window-printat-xy *myw* "Blue" 220 20)
+ (window-reset-color *myw*)
+ (window-force-output *myw*) )
-; 15 Aug 91; 19 Aug 91; 03 Sep 91
+; 15 Aug 91; 19 Aug 91; 03 Sep 91; 21 Apr 95
; Illustrate mouse interaction:
-; click in window myw (2 times for line, 3 times for region).
+; click in window *myw* (2 times for line, 3 times for region).
(defun wtestc ()
- (prog (command mymenu result start)
+ (let (mymenu result start done)
(setq mymenu (menu-create '(quit point line box region) "Choose One:"))
- lp (setq command (menu-select mymenu))
- (setq result (case command
- (quit (menu-destroy mymenu)
- (return))
- (point (window-get-point myw))
- (line (setq start (window-get-point myw))
+ (while (not done)
+ (setq result
+ (case (menu-select mymenu)
+ (quit (setq done t))
+ (point (window-get-point *myw*))
+ (line (setq start (window-get-point *myw*))
(list start
- (window-get-line-position myw (car start)
+ (window-get-line-position *myw* (car start)
(cadr start))))
- (box (window-get-box-position myw 40 20))
- (region (window-get-region myw)) ))
- (format t "Result: ~A~%" result)
- (go lp) ))
+ (box (window-get-box-position *myw* 40 20))
+ (region (window-get-region *myw*)) ))
+ (format t "Result: ~A~%" result) )
+ (menu-destroy mymenu) ))
; 09 Sep 91
; Illustrate icons in menus
@@ -122,12 +131,12 @@
(defvar mypm nil)
; 10 Sep 91; 11 Sep 91; 12 Sep 91; 14 Sep 91; 17 Sep 91
-; A picmenu that is "flat" within another window, in this case myw.
+; A picmenu that is "flat" within another window, in this case *myw*.
; Must do (wtesta) first.
(defun wtestf ()
(or mypms (mypms-init))
(or mypm (setq mypm (picmenu-create-from-spec mypms "Points on Square"
- myw 50 50 nil t t)))
+ *myw* 50 50 nil t t)))
(picmenu-select mypm))
(defun wteste-draw-square (w x y)
@@ -135,49 +144,49 @@
(defvar mym nil)
; 10 Sep 91; 17 Sep 91
-; A menu that is "flat" within another window, in this case myw.
+; A menu that is "flat" within another window, in this case *myw*.
; Must do (wtesta) first.
(defun wtestg ()
- (or mym (setq mym (menu-create '(red white blue) "Flag" myw 50 50 nil t)))
+ (or mym (setq mym (menu-create '(red white blue) "Flag" *myw* 50 50 nil t)))
(menu-select mym))
; 09 Oct 91
; Demonstrate arrows. Optional arg is line width.
(defun wtesth ( &optional (lw 1))
- (window-clear myw)
- (dotimes (i 5) (window-draw-arrow-xy myw 100 100 (+ 40 (* i 30)) 160 lw))
- (dotimes (i 5) (window-draw-arrow-xy myw 100 100 (+ 40 (* i 30)) 40 lw))
- (dotimes (i 5) (window-draw-arrow-xy myw 100 100 40 (+ 40 (* i 30)) lw))
- (dotimes (i 5) (window-draw-arrow-xy myw 100 100 160 (+ 40 (* i 30)) lw))
- (dotimes (i 5) (window-draw-arrow-xy myw 200 (+ 40 (* i 30))
+ (window-clear *myw*)
+ (dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 (+ 40 (* i 30)) 160 lw))
+ (dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 (+ 40 (* i 30)) 40 lw))
+ (dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 40 (+ 40 (* i 30)) lw))
+ (dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 160 (+ 40 (* i 30)) lw))
+ (dotimes (i 5) (window-draw-arrow-xy *myw* 200 (+ 40 (* i 30))
240 (+ 40 (* i 30))
(1+ i) ))
- (window-force-output myw) )
+ (window-force-output *myw*) )
; 04 Jan 94
; Redo some of the arrows from wtesth in color
(defun wtesti ()
- (window-set-color-rgb myw 65535 0 0)
- (window-draw-arrow-xy myw 200 70 240 70 2)
- (window-set-color-rgb myw 0 65535 0)
- (window-draw-arrow-xy myw 200 100 240 100 3)
- (window-set-color-rgb myw 0 0 65535)
- (window-draw-arrow-xy myw 200 130 240 130 4)
- (window-reset-color myw)
- (window-force-output myw) )
+ (window-set-color-rgb *myw* 65535 0 0)
+ (window-draw-arrow-xy *myw* 200 70 240 70 2)
+ (window-set-color-rgb *myw* 0 65535 0)
+ (window-draw-arrow-xy *myw* 200 100 240 100 3)
+ (window-set-color-rgb *myw* 0 0 65535)
+ (window-draw-arrow-xy *myw* 200 130 240 130 4)
+ (window-reset-color *myw*)
+ (window-force-output *myw*) )
; 04 Jan 94
; Get text from a window. Move mouse pointer into test window.
; Add characters and/or backspace, Return.
; Note: it might be necessary to change the keyboard mapping, using
-; (window-init-keyboard-mapping myw) and (window-print-keyboard-mapping)
-(defun wtestj () (window-input-string myw "Foo" 50 200 200))
+; (window-init-keyboard-mapping *myw*) and (window-print-keyboard-mapping)
+(defun wtestj () (window-input-string *myw* "Foo" 50 200 200))
; 04 Jan 94
; Change foreground and background colors and input a string
(defun wtestk ()
- (window-set-color-rgb myw 0 65535 0) ; green foreground
- (window-set-color-rgb myw 0 0 65535 t) ; blue background
- (prog1 (window-input-string myw "Foo" 50 200 200)
- (window-reset-color myw)
- (window-force-output myw) ) )
+ (window-set-color-rgb *myw* 0 65535 0) ; green foreground
+ (window-set-color-rgb *myw* 0 0 65535 t) ; blue background
+ (prog1 (window-input-string *myw* "Foo" 50 200 200)
+ (window-reset-color *myw*)
+ (window-force-output *myw*) ) )
Index: xgcl-2/gcl_dwtrans.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/xgcl-2/gcl_dwtrans.lsp,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -b -r1.1.2.1 -r1.1.2.2
--- xgcl-2/gcl_dwtrans.lsp 5 Jan 2006 17:55:35 -0000 1.1.2.1
+++ xgcl-2/gcl_dwtrans.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.2
@@ -1,14 +1,14 @@
-; 15 Mar 1995 15:50:07
+; 26 Jan 2006 15:17:04 CST ; 27 Jan 06
; dwtrans.lsp -- translation of dwindow.lsp
-; Copyright (c) 1995 Gordon S. Novak Jr. and The University of Texas at Austin.
+; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin.
; See the files gnu.license and dec.copyright .
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
-; the Free Software Foundation; either version 1, or (at your option)
-; any later version.
+; the Free Software Foundation; either version 2 of the License, or
+; (at your option) any later version.
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -17,7 +17,7 @@
; You should have received a copy of the GNU General Public License
; along with this program; if not, write to the Free Software
-; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Some of the files that interface to the Xlib are adapted from DEC/MIT files.
; See the file dec.copyright for details.
@@ -30,6 +30,158 @@
(defmacro while (test &rest forms) `(loop (unless ,test (return)) ,@forms) )
+; dwexports.lsp Gordon S. Novak Jr. 24 Jan 2006
+
+(setf (get 'xlib::int-pos 'user::glfnresulttype) 'lisp::integer)
+
+; exported symbols: from dwimports.lsp
+(dolist (x '( menu stringify window picmenu textmenu editmenu barmenu
+ display-size
+ window-get-mouse-position window-create window-set-font
+ window-font-info window-gcontext window-parent
+ window-drawable-height window-drawable-width window-label
+ window-font window-foreground window-set-foreground
+ window-background window-set-background window-wfunction
+ window-get-geometry window-get-geometry-b window-sync
+ window-screen-height window-geometry window-size
+ window-left window-top-neg-y window-reset-geometry
+ window-force-output window-query-pointer window-set-xor
+ window-unset window-reset window-set-erase
+ window-set-copy window-set-invert window-set-line-width
+ window-set-line-attr window-std-line-attr window-draw-line
+ window-draw-line-xy window-draw-arrowhead-xy
+ window-draw-arrow-xy window-draw-arrow2-xy window-draw-box
+ window-draw-box-xy window-xor-box-xy window-draw-box-corners
+ window-draw-rcbox-xy window-draw-arc-xy
+ window-draw-circle-xy window-draw-circle window-erase-area
+ window-erase-area-xy window-erase-box-xy
+ window-draw-ellipse-xy window-copy-area-xy window-invertarea
+ window-invert-area window-invert-area-xy
+ window-prettyprintat window-prettyprintat-xy window-printat
+ window-printat-xy window-string-width window-string-height
+ window-string-extents window-font-string-width
+ window-yposition window-centeroffset dowindowcom
+ window-menu window-close window-unmap window-open
+ window-map window-destroy window-destroy-selected-window
+ window-clear window-moveto-xy window-paint
+ window-move window-draw-border window-track-mouse
+ window-wait-exposure window-wait-unmap
+ window-init-mouse-poll window-poll-mouse menu-init
+ menu-calculate-size menu-adjust-offset menu-draw
+ menu-item-value menu-find-item-width menu-find-item-height
+ menu-clear menu-display-item menu-choose menu-box-item
+ menu-unbox-item menu-item-position menu-select
+ menu-select! menu-select-b menu-destroy
+ menu-create menu-offset menu-size menu-moveto-xy
+ menu-reposition picmenu-create picmenu-create-spec
+ picmenu-create-from-spec picmenu-calculate-size picmenu-init
+ picmenu-draw picmenu-draw-button picmenu-delete-named-button
+ picmenu-select picmenu-box-item picmenu-unbox-item
+ picmenu-destroy picmenu-button-containsxy?
+ picmenu-item-position barmenu-create
+ barmenu-calculate-size barmenu-init barmenu-draw
+ barmenu-select barmenu-update-value window-get-point
+ window-get-click window-get-line-position
+ window-get-latex-position window-get-box-position
+ window-get-icon-position window-get-region
+ window-get-box-size window-track-mouse-in-region
+ window-adjust-box-side window-adj-box-xy window-get-circle
+ window-circle-radius window-draw-circle-pt
+ window-get-ellipse window-draw-ellipse-pt
+ window-draw-vector-pt window-get-vector-end
+ window-get-crosshairs window-draw-crosshairs-xy
+ window-get-cross window-draw-cross-xy window-draw-dot-xy
+ window-draw-latex-xy window-reset-color
+ window-set-color-rgb window-set-xcolor window-set-color
+ window-set-color window-free-color window-get-chars
+ window-process-char-event window-input-string
+ window-input-char-fn window-draw-carat window-init-keymap
+ window-set-cursor window-positive-y window-code-char
+ window-get-raw-char
+ window-print-line window-print-lines textmenu-create
+ textmenu-calculate-size textmenu-init textmenu-draw
+ textmenu-select textmenu-set-text textmenu
+ editmenu editmenu-create editmenu-calculate-size
+ editmenu-init editmenu-draw editmenu-display
+ window-edit
+ window-edit-display editmenu-carat editmenu-erase
+ window-edit-erase editmenu-select editmenu-edit-fn
+ window-edit-fn editmenu-setxy editmenu-char
+ editmenu-edit
+ *window-editmenu-kill-strings*
+*window-add-menu-title*
+*window-menu*
+*mouse-x*
+*mouse-y*
+*mouse-window*
+*window-fonts*
+*window-display*
+*window-screen*
+*root-window*
+*black-pixel*
+*white-pixel*
+*default-fg-color*
+*default-bg-color*
+*default-size-hints*
+*default-GC*
+*default-colormap*
+*window-event*
+*window-default-pos-x*
+*window-default-pos-y*
+*window-default-border*
+*window-default-font-name*
+*window-default-cursor*
+*window-save-foreground*
+*window-save-function*
+*window-attributes*
+*window-attr*
+*menu-title-pad*
+*root-return*
+*child-return*
+*root-x-return*
+*root-y-return*
+*win-x-return*
+*win-y-return*
+*mask-return*
+*x-return*
+*y-return*
+*width-return*
+*height-return*
+*depth-return*
+*border-width-return*
+*text-width-return*
+*direction-return*
+*ascent-return*
+*descent-return*
+*overall-return*
+*GC-Values*
+*window-xcolor*
+*window-menu-code*
+
+*window-keymap*
+*window-shiftkeymap*
+*window-keyinit*
+*window-meta*
+*window-ctrl*
+*window-shift*
+*window-string*
+*window-string-count*
+*window-string-max*
+*window-input-string-x*
+*window-input-string-y*
+*window-input-string-charwidth*
+
+*window-shift-keys*
+*window-control-keys*
+*window-meta-keys*
+*barmenu-update-value-cons*
+*picmenu-no-selection*
+*min-keycodes-return*
+*max-keycodes-return*
+*keycodes-return*
+ ))
+ (export x)) ; export the above symbols
+
(DEFVAR *WINDOW-ADD-MENU-TITLE* NIL)
(DEFVAR *WINDOW-MENU* NIL)
@@ -43,7 +195,10 @@
(DEFVAR *WINDOW-FONTS*
(LIST (LIST 'COURIER-BOLD-12
"*-*-courier-bold-r-*-*-12-*-*-*-*-*-iso8859-1")
- (LIST '8X10 "8x10") (LIST '9X15 "9x15")))
+ (LIST 'COURIER-MEDIUM-12
+ "*-*-courier-medium-r-*-*-12-*-*-*-*-*-iso8859-1")
+ (LIST '6X12 "6x12") (LIST '8X13 "8x13")
+ (LIST '9X15 "9x15")))
@@ -143,18 +298,6 @@
(DEFVAR *WINDOW-SHIFT*)
-(DEFVAR *WINDOW-STRING* (MAKE-STRING 100))
-
-(DEFVAR *WINDOW-STRING-COUNT*)
-
-(DEFVAR *WINDOW-STRING-MAX*)
-
-(DEFVAR *WINDOW-INPUT-STRING-X*)
-
-(DEFVAR *WINDOW-INPUT-STRING-Y*)
-
-(DEFVAR *WINDOW-INPUT-STRING-CHARWIDTH*)
-
(DEFVAR *WINDOW-SHIFT-KEYS* NIL)
(DEFVAR *WINDOW-CONTROL-KEYS* NIL)
@@ -212,6 +355,8 @@
(SETQ *MOUSE-Y* (INT-POS *ROOT-Y-RETURN* 0))
(SETQ *MOUSE-WINDOW* (INT-POS *CHILD-RETURN* 0)))
+
+
(DEFUN WINDOW-CREATE
(WIDTH HEIGHT &OPTIONAL STR PARENTW POS-X POS-Y FONT)
(LET (W PW FG-COLOR BG-COLOR)
@@ -256,15 +401,17 @@
W))
(DEFUN WINDOW-SET-FONT (W FONTSYMBOL)
- (LET (FONTSTRING FONT-INFO (DISPLAY *WINDOW-DISPLAY*))
+ (LET (FONTSTRING FONT-INFO)
(SETQ FONTSTRING
(OR (CADR (ASSOC FONTSYMBOL *WINDOW-FONTS*))
(STRINGIFY FONTSYMBOL)))
- (SETQ FONT-INFO (XLOADQUERYFONT DISPLAY (GET-C-STRING FONTSTRING)))
+ (SETQ FONT-INFO
+ (XLOADQUERYFONT *WINDOW-DISPLAY* (GET-C-STRING FONTSTRING)))
(IF (ZEROP FONT-INFO)
(FORMAT T "~%can't open font ~a ~a~%" FONTSYMBOL FONTSTRING)
(PROGN
- (XSETFONT DISPLAY (CADDR W) (XFONTSTRUCT-FID FONT-INFO))
+ (XSETFONT *WINDOW-DISPLAY* (CADDR W)
+ (XFONTSTRUCT-FID FONT-INFO))
(SETF (SEVENTH W) FONT-INFO)))))
(DEFUN WINDOW-FONT-INFO (FONTSYMBOL)
@@ -315,7 +462,7 @@
*WIDTH-RETURN* *HEIGHT-RETURN* *BORDER-WIDTH-RETURN*
*DEPTH-RETURN*))
-(DEFUN WINDOW-SYNC (W) (XSYNC *WINDOW-DISPLAY* 1))
+(DEFUN WINDOW-SYNC (W) (declare (ignore w)) (XSYNC *WINDOW-DISPLAY* 1))
(DEFUN WINDOW-SCREEN-HEIGHT ()
(WINDOW-GET-GEOMETRY-B *ROOT-WINDOW*)
@@ -350,7 +497,7 @@
(SETF (FIFTH W) (INT-POS *WIDTH-RETURN* 0))
(SETF (CADDDR W) (INT-POS *HEIGHT-RETURN* 0)))
-(DEFUN WINDOW-FORCE-OUTPUT (&OPTIONAL W) (XFLUSH *WINDOW-DISPLAY*))
+(DEFUN WINDOW-FORCE-OUTPUT (&OPTIONAL W) (declare (ignore w))(XFLUSH
*WINDOW-DISPLAY*))
(DEFUN WINDOW-QUERY-POINTER (W) (WINDOW-QUERY-POINTER-B (CADR W)))
@@ -544,8 +691,8 @@
(XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1)
0 1 0))
(SETQ LW (OR LINEWIDTH 1))
- (SETQ LW2 (TRUNCATE LW 2))
- (SETQ LW2B (TRUNCATE (1+ LW) 2))
+ (SETQ LW2 (/ LW 2))
+ (SETQ LW2B (/ (1+ LW) 2))
(SETQ MINY (- OFFSETY LW2B))
(XDRAWLINE *WINDOW-DISPLAY* PW GC OFFSETX (- QQWHEIGHT MINY)
OFFSETX (- QQWHEIGHT (+ (+ MINY SIZEY) LW)))
@@ -676,9 +823,8 @@
(DEFUN WINDOW-ERASE-BOX-XY
(W XOFF YOFF XSIZE YSIZE &OPTIONAL LINEWIDTH)
- (XCLEARAREA *WINDOW-DISPLAY* (CADR W)
- (- XOFF (TRUNCATE (OR LINEWIDTH 1) 2))
- (- (CADDDR W) (+ (+ YOFF YSIZE) (TRUNCATE (OR LINEWIDTH 1) 2)))
+ (XCLEARAREA *WINDOW-DISPLAY* (CADR W) (- XOFF (/ (OR LINEWIDTH 1) 2))
+ (- (CADDDR W) (+ (+ YOFF YSIZE) (/ (OR LINEWIDTH 1) 2)))
(+ XSIZE (OR LINEWIDTH 1)) (+ YSIZE (OR LINEWIDTH 1)) 0))
(DEFUN WINDOW-DRAW-ELLIPSE-XY (W X Y RX RY &OPTIONAL LW)
@@ -758,6 +904,26 @@
(XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) X
(- (CADDDR W) Y) (GET-C-STRING SSTR) (LENGTH SSTR))))
+(DEFUN WINDOW-PRINT-LINE (W STR X Y &OPTIONAL DELTAY)
+ (LET ((N 0) END STRB DONE)
+ (WHILE (NOT DONE)
+ (SETQ END (POSITION #\Newline STR :TEST #'CHAR= :START N))
+ (SETQ STRB (SUBSEQ STR N END))
+ (LET ((SSTR (STRINGIFY STRB)))
+ (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) X
+ (- (CADDDR W) Y) (GET-C-STRING SSTR) (LENGTH SSTR)))
+ (IF (NUMBERP END) (SETQ N (1+ END)) (SETQ DONE T))
+ (DECF Y (OR DELTAY 16)) (IF (MINUSP Y) (SETQ DONE T)))
+ (XFLUSH *WINDOW-DISPLAY*)))
+
+(DEFUN WINDOW-PRINT-LINES (W LINES X Y &OPTIONAL DELTAY)
+ (DOLIST (STR LINES)
+ (WHEN (PLUSP Y)
+ (LET ((SSTR (STRINGIFY STR)))
+ (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) X
+ (- (CADDDR W) Y) (GET-C-STRING SSTR) (LENGTH SSTR)))
+ (DECF Y (OR DELTAY 16)))))
+
(DEFUN WINDOW-STRING-WIDTH (W S)
(LET ((SSTR (STRINGIFY S)))
(XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR))))
@@ -769,6 +935,13 @@
*OVERALL-RETURN*)
(LIST (INT-POS *ASCENT-RETURN* 0) (INT-POS *DESCENT-RETURN* 0))))
+(DEFUN WINDOW-STRING-HEIGHT (W S)
+ (LET ((SSTR (STRINGIFY S)))
+ (XTEXTEXTENTS (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR)
+ *DIRECTION-RETURN* *ASCENT-RETURN* *DESCENT-RETURN*
+ *OVERALL-RETURN*)
+ (+ (INT-POS *ASCENT-RETURN* 0) (INT-POS *DESCENT-RETURN* 0))))
+
(DEFUN WINDOW-FONT-STRING-WIDTH (FONT S)
(LET ((SSTR (STRINGIFY S)))
(XTEXTWIDTH FONT (GET-C-STRING SSTR) (LENGTH SSTR))))
@@ -957,7 +1130,7 @@
(DEFUN MENU-INIT (M)
(OR *WINDOW-DISPLAY* (WINDOW-XINIT))
(MENU-CALCULATE-SIZE M)
- (UNLESS (CADDR M)
+ (IF (NOT (CADDR M))
(SETF (CADR M)
(WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "")
(CADDDR M) (FIFTH M) (SIXTH M) (NTH 10 M)))))
@@ -988,7 +1161,7 @@
(LET (XBASE YBASE WBASE HBASE XOFF YOFF WGM WIDTH HEIGHT)
(SETQ WIDTH (SEVENTH M))
(SETQ HEIGHT (EIGHTH M))
- (UNLESS (CADDDR M)
+ (WHEN (NOT (CADDDR M))
(WINDOW-GET-MOUSE-POSITION)
(SETQ WGM T)
(SETF (CADDDR M) *ROOT-WINDOW*))
@@ -1000,9 +1173,8 @@
(IF (OR (NOT (FIFTH M)) (ZEROP (FIFTH M)))
(PROGN
(OR WGM (WINDOW-GET-MOUSE-POSITION))
- (SETQ XOFF (+ -4 (- (- *MOUSE-X* XBASE) (TRUNCATE WIDTH 2))))
- (SETQ YOFF
- (- (- HBASE (- *MOUSE-Y* YBASE)) (TRUNCATE HEIGHT 2))))
+ (SETQ XOFF (+ -4 (- (- *MOUSE-X* XBASE) (/ WIDTH 2))))
+ (SETQ YOFF (- (- HBASE (- *MOUSE-Y* YBASE)) (/ HEIGHT 2))))
(PROGN (SETQ XOFF (FIFTH M)) (SETQ YOFF (SIXTH M))))
(SETF (FIFTH M) (MAX 0 (MIN XOFF (- WBASE WIDTH))))
(SETF (SIXTH M) (MAX 0 (MIN YOFF (- HBASE HEIGHT))))))
@@ -1028,7 +1200,6 @@
(XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW)
(+ 3 XZERO) (- (CADDDR MW) BOTTOM) (GET-C-STRING SSTR)
(LENGTH SSTR)))
- (LET ((GLVAR1420 (NTH 12 M)))
(LET ((GC (CADDR MW)))
(SETQ *WINDOW-SAVE-FUNCTION*
(PROGN
@@ -1048,17 +1219,17 @@
*GC-VALUES*)
(XGCVALUES-BACKGROUND *GC-VALUES*)))))
(XFILLRECTANGLE *WINDOW-DISPLAY* (CADR MW) (CADDR MW) XZERO
- (- (CADDDR MW) (1- (+ (+ -2 BOTTOM) GLVAR1420)))
- (1+ (SEVENTH M)) GLVAR1420)
+ (- (CADDDR MW) (1- (+ (+ -2 BOTTOM) (NTH 12 M))))
+ (1+ (SEVENTH M)) (NTH 12 M))
(LET ((GC (CADDR MW)))
(XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*)
- (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))))
+ (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)))
(DOLIST (ITEM (NTH 13 M))
(DECF BOTTOM (NTH 12 M))
(MENU-DISPLAY-ITEM M ITEM (+ 3 XZERO) BOTTOM))
(XFLUSH *WINDOW-DISPLAY*)))
-(DEFUN MENU-ITEM-VALUE (SELF ITEM) (IF (CONSP ITEM) (CDR ITEM) ITEM))
+(DEFUN MENU-ITEM-VALUE (SELF ITEM) (declare (ignore self))(IF (CONSP ITEM)
(CDR ITEM) ITEM))
(DEFUN MENU-FIND-ITEM-WIDTH (SELF ITEM)
(LET (TMP)
@@ -1071,6 +1242,7 @@
(STRINGIFY (IF (CONSP ITEM) (CAR ITEM) ITEM))))))
(DEFUN MENU-FIND-ITEM-HEIGHT (SELF ITEM)
+ (declare (ignore self))
(LET (TMP)
(IF (AND (CONSP ITEM) (SYMBOLP (CAR ITEM))
(SETQ TMP (GET (CAR ITEM) 'DISPLAY-SIZE)))
@@ -1078,12 +1250,12 @@
(DEFUN MENU-CLEAR (M)
(IF (CADDR M)
- (LET ((GLVAR1421 (CADR M)) (GLVAR1425 (+ 3 (EIGHTH M))))
- (XCLEARAREA *WINDOW-DISPLAY* (CADR GLVAR1421)
+ (LET ((GLVAR96260 (+ 3 (EIGHTH M))))
+ (XCLEARAREA *WINDOW-DISPLAY* (CADADR M)
(1- (IF (CADDR M) (FIFTH M) 0))
- (- (CADDDR GLVAR1421)
- (1- (+ (1- (IF (CADDR M) (SIXTH M) 0)) GLVAR1425)))
- (+ 3 (SEVENTH M)) GLVAR1425 0))
+ (- (CADDDR (CADR M))
+ (1- (+ (1- (IF (CADDR M) (SIXTH M) 0)) GLVAR96260)))
+ (+ 3 (SEVENTH M)) GLVAR96260 0))
(PROGN
(XCLEARWINDOW *WINDOW-DISPLAY* (CADADR M))
(XFLUSH *WINDOW-DISPLAY*))))
@@ -1091,18 +1263,18 @@
(DEFUN MENU-DISPLAY-ITEM (SELF ITEM X Y)
(LET ((MW (CADR SELF)))
(IF (CONSP ITEM)
- (COND
- ((AND (SYMBOLP (CAR ITEM)) (FBOUNDP (CAR ITEM)))
- (FUNCALL (CAR ITEM) MW X Y))
- ((OR (STRINGP (CAR ITEM)) (SYMBOLP (CAR ITEM))
+ (IF (AND (SYMBOLP (CAR ITEM)) (FBOUNDP (CAR ITEM)))
+ (FUNCALL (CAR ITEM) MW X Y)
+ (IF (OR (STRINGP (CAR ITEM)) (SYMBOLP (CAR ITEM))
(NUMBERP (CAR ITEM)))
(LET ((SSTR (STRINGIFY (CAR ITEM))))
- (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW) X
- (- (CADDDR MW) Y) (GET-C-STRING SSTR) (LENGTH SSTR))))
- (T (LET ((SSTR (STRINGIFY (STRINGIFY ITEM))))
- (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW)
- X (- (CADDDR MW) Y) (GET-C-STRING SSTR)
- (LENGTH SSTR)))))
+ (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW)
+ (CADDR MW) X (- (CADDDR MW) Y)
+ (GET-C-STRING SSTR) (LENGTH SSTR)))
+ (LET ((SSTR (STRINGIFY (STRINGIFY ITEM))))
+ (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW)
+ (CADDR MW) X (- (CADDDR MW) Y)
+ (GET-C-STRING SSTR) (LENGTH SSTR)))))
(LET ((SSTR (STRINGIFY (STRINGIFY ITEM))))
(XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW) X
(- (CADDDR MW) Y) (GET-C-STRING SSTR) (LENGTH SSTR))))))
@@ -1149,8 +1321,7 @@
(SETQ VAL -777)))))
T)
(IF (/= VAL -777)
- (LET ((GLVAR1433 (NTH VAL ITMS)))
- (IF (CONSP GLVAR1433) (CDR GLVAR1433) GLVAR1433)))))
+ (IF (CONSP (NTH VAL ITMS)) (CDR (NTH VAL ITMS)) (NTH VAL ITMS)))))
(DEFUN MENU-BOX-ITEM (M ITEM)
(LET (ITEMH NITEMS (MW (OR (CADR M) (MENU-INIT M))))
@@ -1186,32 +1357,28 @@
(LET ((N 0) FOUND ITMS ITEM (XSIZE (NTH 11 M)) (YSIZE (NTH 12 M)))
(SETQ ITMS (NTH 13 M))
(SETQ FOUND (NULL ITEMNAME))
- (TAGBODY
- GLLABEL1437
- (WHEN (AND ITMS (NOT FOUND))
- (INCF N)
- (SETQ ITEM (POP ITMS))
+ (WHILE (AND ITMS (NOT FOUND)) (INCF N) (SETQ ITEM (POP ITMS))
(IF (OR (EQ ITEM ITEMNAME)
(AND (CONSP ITEM)
(OR (EQ ITEMNAME (CAR ITEM))
(AND (STRINGP (CAR ITEM))
- (STRING= (STRINGIFY ITEMNAME) (CAR ITEM)))
+ (STRING= (STRINGIFY ITEMNAME)
+ (CAR ITEM)))
(EQ (CDR ITEM) ITEMNAME)
(AND (CONSP (CDR ITEM))
(EQ (CADR ITEM) ITEMNAME)))))
- (SETQ FOUND T))
- (GO GLLABEL1437)))
+ (SETQ FOUND T)))
(IF FOUND
(LIST (+ (IF (CADDR M) (FIFTH M) 0)
(CASE PLACE
- ((CENTER TOP BOTTOM) (TRUNCATE XSIZE 2))
+ ((CENTER TOP BOTTOM) (/ XSIZE 2))
(LEFT -1)
(RIGHT (+ 2 XSIZE))
(T 0)))
(+ (+ (IF (CADDR M) (SIXTH M) 0)
(* (- (LENGTH (NTH 13 M)) N) YSIZE))
(CASE PLACE
- ((CENTER RIGHT LEFT) (TRUNCATE YSIZE 2))
+ ((CENTER RIGHT LEFT) (/ YSIZE 2))
(BOTTOM 0)
(TOP YSIZE)
(T 0)))))))
@@ -1225,22 +1392,21 @@
LP
(SETQ RES (MENU-CHOOSE M INSIDE))
(IF (AND FLG (NOT RES)) (GO LP))
- (UNLESS (TENTH M)
+ (IF (NOT (TENTH M))
(IF (CADDR M) (PROGN (MENU-CLEAR M) (XFLUSH *WINDOW-DISPLAY*))
- (LET ((GLVAR1440 (CADR M)))
- (XUNMAPWINDOW *WINDOW-DISPLAY* (CADR GLVAR1440))
+ (PROGN
+ (XUNMAPWINDOW *WINDOW-DISPLAY* (CADADR M))
(XFLUSH *WINDOW-DISPLAY*)
- (WINDOW-WAIT-UNMAP GLVAR1440))))
+ (WINDOW-WAIT-UNMAP (CADR M)))))
(RETURN RES)))
(DEFUN MENU-DESTROY (M)
- (UNLESS (CADDR M)
- (LET ((GLVAR1441 (CADR M)))
- (XDESTROYWINDOW *WINDOW-DISPLAY* (CADR GLVAR1441))
+ (WHEN (NOT (CADDR M))
+ (XDESTROYWINDOW *WINDOW-DISPLAY* (CADADR M))
(XFLUSH *WINDOW-DISPLAY*)
- (SETF (CADR GLVAR1441) NIL)
- (XFREEGC *WINDOW-DISPLAY* (CADDR GLVAR1441))
- (SETF (CADDR GLVAR1441) NIL))
+ (SETF (CADADR M) NIL)
+ (XFREEGC *WINDOW-DISPLAY* (CADDR (CADR M)))
+ (SETF (CADDR (CADR M)) NIL)
(SETF (CADR M) NIL)))
(DEFUN MENU (ITEMS &OPTIONAL TITLE)
@@ -1250,6 +1416,8 @@
(MENU-DESTROY M)
RES))
+
+
(DEFUN MENU-CREATE (ITEMS &OPTIONAL TITLE PARENTW X Y PERM FLAT FONT)
(LIST 'MENU (IF FLAT PARENTW) FLAT (CADR PARENTW) X Y 0 0
(IF TITLE (STRINGIFY TITLE) "") PERM FONT 0 0 ITEMS))
@@ -1259,8 +1427,12 @@
(DEFUN MENU-SIZE (M)
(IF (<= (SEVENTH M) 0)
- (IF (EQ (FIRST M) 'PICMENU) (PICMENU-CALCULATE-SIZE M)
- (MENU-CALCULATE-SIZE M)))
+ (CASE (FIRST M)
+ (PICMENU (PICMENU-CALCULATE-SIZE M))
+ (BARMENU (BARMENU-CALCULATE-SIZE M))
+ (TEXTMENU (TEXTMENU-CALCULATE-SIZE M))
+ (EDITMENU (EDITMENU-CALCULATE-SIZE M))
+ (T (MENU-CALCULATE-SIZE M))))
(LIST (SEVENTH M) (EIGHTH M)))
(DEFUN MENU-MOVETO-XY (M X Y)
@@ -1277,6 +1449,8 @@
(WINDOW-GET-BOX-POSITION (CADR M) (CAR SIZEV) (CADR SIZEV)))
(MENU-MOVETO-XY M (CAR POS) (CADR POS)))))
+
+
(DEFUN PICMENU-CREATE
(BUTTONS WIDTH HEIGHT DRAWFN &OPTIONAL TITLE DOTFLG PARENTW X Y
PERM FLAT FONT BOXFLG)
@@ -1284,11 +1458,15 @@
(PICMENU-CREATE-SPEC BUTTONS WIDTH HEIGHT DRAWFN DOTFLG FONT)
TITLE PARENTW X Y PERM FLAT BOXFLG))
+
+
(DEFUN PICMENU-CREATE-SPEC
(BUTTONS WIDTH HEIGHT DRAWFN &OPTIONAL DOTFLG FONT)
(LIST 'PICMENU-SPEC WIDTH HEIGHT BUTTONS DOTFLG DRAWFN
(OR FONT '9X15)))
+
+
(DEFUN PICMENU-CREATE-FROM-SPEC
(SPEC &OPTIONAL TITLE PARENTW X Y PERM FLAT BOXFLG)
(LIST 'PICMENU (IF FLAT PARENTW) FLAT (IF PARENTW (CADR PARENTW)) X Y
@@ -1310,7 +1488,7 @@
(DEFUN PICMENU-INIT (M)
(PICMENU-CALCULATE-SIZE M)
(MENU-ADJUST-OFFSET M)
- (UNLESS (CADDR M)
+ (IF (NOT (CADDR M))
(SETF (CADR M)
(WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "")
(CADDDR M) (FIFTH M) (SIXTH M) (SEVENTH (NTH 10 M))))))
@@ -1399,7 +1577,7 @@
(DEFUN PICMENU-SELECT (M &OPTIONAL INSIDE ANYCLICK)
(LET (MW CURRENT-BUTTON ITEM ITEMS VAL XZERO YZERO CODEVAL)
(SETQ MW (OR (CADR M) (PICMENU-INIT M)))
- (UNLESS (TENTH M) (PICMENU-DRAW M))
+ (IF (NOT (TENTH M)) (PICMENU-DRAW M))
(SETQ XZERO (IF (CADDR M) (FIFTH M) 0))
(SETQ YZERO (IF (CADDR M) (SIXTH M) 0))
(WINDOW-TRACK-MOUSE MW
@@ -1411,21 +1589,18 @@
(<= Y (EIGHTH M)))
(SETQ INSIDE T))
(IF CURRENT-BUTTON
- (UNLESS (PICMENU-BUTTON-CONTAINSXY? CURRENT-BUTTON X Y)
+ (WHEN (NOT (PICMENU-BUTTON-CONTAINSXY? CURRENT-BUTTON X
+ Y))
(PICMENU-UNBOX-ITEM M CURRENT-BUTTON)
(SETQ CURRENT-BUTTON NIL)))
- (UNLESS CURRENT-BUTTON
+ (WHEN (NOT CURRENT-BUTTON)
(SETQ ITEMS (CADDDR (NTH 10 M)))
- (TAGBODY
- GLLABEL1454
- (WHEN (AND (NOT CURRENT-BUTTON)
- (SETQ ITEM (POP ITEMS)))
+ (WHILE (AND (NOT CURRENT-BUTTON) (SETQ ITEM (POP ITEMS)))
(WHEN (AND (PICMENU-BUTTON-CONTAINSXY? ITEM X Y)
- (NOT (MEMBER (CAR ITEM) (NTH 12 M) :TEST
- #'EQUAL)))
+ (NOT (MEMBER (CAR ITEM) (NTH 12 M)
+ :TEST #'EQUAL)))
(PICMENU-BOX-ITEM M ITEM)
- (SETQ CURRENT-BUTTON ITEM))
- (GO GLLABEL1454))))
+ (SETQ CURRENT-BUTTON ITEM))))
(WHEN (OR (PLUSP CODE)
(AND INSIDE
(OR (MINUSP X) (> X (SEVENTH M)) (MINUSP Y)
@@ -1436,12 +1611,12 @@
(IF (AND (PLUSP CODE) CURRENT-BUTTON)
CURRENT-BUTTON *PICMENU-NO-SELECTION*))))
T)
- (UNLESS (TENTH M)
+ (IF (NOT (TENTH M))
(IF (CADDR M) (PROGN (MENU-CLEAR M) (XFLUSH *WINDOW-DISPLAY*))
- (LET ((GLVAR1456 (CADR M)))
- (XUNMAPWINDOW *WINDOW-DISPLAY* (CADR GLVAR1456))
+ (PROGN
+ (XUNMAPWINDOW *WINDOW-DISPLAY* (CADADR M))
(XFLUSH *WINDOW-DISPLAY*)
- (WINDOW-WAIT-UNMAP GLVAR1456))))
+ (WINDOW-WAIT-UNMAP (CADR M)))))
(IF (EQUAL VAL *PICMENU-NO-SELECTION*)
(AND (PLUSP CODEVAL) ANYCLICK) (CAR VAL))))
@@ -1472,9 +1647,8 @@
*GC-VALUES*)
(XGCVALUES-BACKGROUND *GC-VALUES*)))))
(IF (SETQ SIZ (CADDR ITEM))
- (WINDOW-DRAW-BOX-XY MW (- XOFF (TRUNCATE (CAR SIZ) 2))
- (- YOFF (TRUNCATE (CADR SIZ) 2)) (CAR SIZ) (CADR SIZ)
- 1)
+ (WINDOW-DRAW-BOX-XY MW (- XOFF (/ (CAR SIZ) 2))
+ (- YOFF (/ (CADR SIZ) 2)) (CAR SIZ) (CADR SIZ) 1)
(WINDOW-DRAW-BOX-XY MW (+ -6 XOFF) (+ -6 YOFF) 12 12 1))
(LET ((GC (CADDR MW)))
(XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*)
@@ -1495,39 +1669,41 @@
(DEFUN PICMENU-BUTTON-CONTAINSXY? (B X Y)
(LET ((XSIZE 6) (YSIZE 6))
(WHEN (CADDR B)
- (SETQ XSIZE (TRUNCATE (CAADDR B) 2))
- (SETQ YSIZE (TRUNCATE (CADR (CADDR B)) 2)))
+ (SETQ XSIZE (/ (CAADDR B) 2))
+ (SETQ YSIZE (/ (CADR (CADDR B)) 2)))
(AND (>= X (- (CAADR B) XSIZE)) (<= X (+ (CAADR B) XSIZE))
(>= Y (- (CADADR B) YSIZE)) (<= Y (+ (CADADR B) YSIZE)))))
(DEFUN PICMENU-ITEM-POSITION (M ITEMNAME &OPTIONAL PLACE)
(LET (B (XSIZE 0) (YSIZE 0) XOFF YOFF)
- (IF ITEMNAME
+ (IF (NULL ITEMNAME)
+ (PROGN
+ (SETQ XSIZE (SEVENTH M))
+ (SETQ YSIZE (/ (- (EIGHTH M) (CADDR (NTH 10 M))) 2))
+ (SETQ XOFF (/ XSIZE 2))
+ (SETQ YOFF (+ (CADDR (NTH 10 M)) (/ YSIZE 2))))
(WHEN (SETQ B (ASSOC ITEMNAME (CADDDR (NTH 10 M))))
(WHEN (CADDR B)
(SETQ XSIZE (CAADDR B))
(SETQ YSIZE (CADR (CADDR B))))
(SETQ XOFF (CAADR B))
- (SETQ YOFF (CADADR B)))
- (PROGN
- (SETQ XSIZE (SEVENTH M))
- (SETQ YSIZE (TRUNCATE (- (EIGHTH M) (CADDR (NTH 10 M))) 2))
- (SETQ XOFF (TRUNCATE XSIZE 2))
- (SETQ YOFF (+ (CADDR (NTH 10 M)) (TRUNCATE YSIZE 2)))))
+ (SETQ YOFF (CADADR B))))
(IF XOFF
(LIST (+ (+ (IF (CADDR M) (FIFTH M) 0) XOFF)
(CASE PLACE
((CENTER TOP BOTTOM) 0)
- (LEFT (- (TRUNCATE XSIZE 2)))
- (RIGHT (TRUNCATE XSIZE 2))
+ (LEFT (- (/ XSIZE 2)))
+ (RIGHT (/ XSIZE 2))
(T 0)))
(+ (+ (IF (CADDR M) (SIXTH M) 0) YOFF)
(CASE PLACE
((CENTER RIGHT LEFT) 0)
- (BOTTOM (- (TRUNCATE YSIZE 2)))
- (TOP (TRUNCATE YSIZE 2))
+ (BOTTOM (- (/ YSIZE 2)))
+ (TOP (/ YSIZE 2))
(T 0)))))))
+
+
(DEFUN BARMENU-CREATE
(MAXVAL INITVAL BARWIDTH &OPTIONAL TITLE HORIZONTAL SUBTRACKFN
SUBTRACKPARMS PARENTW X Y PERM FLAT COLOR)
@@ -1552,7 +1728,7 @@
(DEFUN BARMENU-INIT (M)
(BARMENU-CALCULATE-SIZE M)
(MENU-ADJUST-OFFSET M)
- (UNLESS (CADDR M)
+ (IF (NOT (CADDR M))
(SETF (CADR M)
(WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "")
(CADDDR M) (FIFTH M) (SIXTH M)))))
@@ -1565,42 +1741,39 @@
(XFLUSH *WINDOW-DISPLAY*)
(WINDOW-WAIT-EXPOSURE MW)
(MENU-CLEAR M)
- (SETQ XZERO
- (+ (IF (CADDR M) (FIFTH M) 0) (TRUNCATE (SEVENTH M) 2)))
+ (SETQ XZERO (+ (IF (CADDR M) (FIFTH M) 0) (/ (SEVENTH M) 2)))
(SETQ YZERO (IF (CADDR M) (SIXTH M) 0))
(IF (NTH 10 M) (WINDOW-SET-COLOR MW (NTH 10 M)))
(IF (NTH 14 M)
- (LET ((GLVAR1493 (CADR M)) (GLVAR1495 (NTH 13 M)))
- (LET ((QQWHEIGHT (CADDDR GLVAR1493)))
- (IF (AND GLVAR1495 (/= GLVAR1495 1))
- (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR GLVAR1493)
- (OR GLVAR1495 1) 0 1 0))
- (XDRAWLINE *WINDOW-DISPLAY* (CADR GLVAR1493)
- (CADDR GLVAR1493) XZERO (- QQWHEIGHT YZERO)
- (+ XZERO (NTH 11 M)) (- QQWHEIGHT YZERO))
- (IF (AND GLVAR1495 (/= GLVAR1495 1))
- (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR GLVAR1493)
- 1 0 1 0))))
- (LET ((GLVAR1496 (CADR M)) (GLVAR1498 (NTH 13 M)))
- (LET ((QQWHEIGHT (CADDDR GLVAR1496)))
- (IF (AND GLVAR1498 (/= GLVAR1498 1))
- (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR GLVAR1496)
- (OR GLVAR1498 1) 0 1 0))
- (XDRAWLINE *WINDOW-DISPLAY* (CADR GLVAR1496)
- (CADDR GLVAR1496) XZERO (- QQWHEIGHT YZERO) XZERO
+ (LET ((QQWHEIGHT (CADDDR (CADR M))))
+ (IF (AND (NTH 13 M) (/= (NTH 13 M) 1))
+ (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M))
+ (OR (NTH 13 M) 1) 0 1 0))
+ (XDRAWLINE *WINDOW-DISPLAY* (CADADR M) (CADDR (CADR M)) XZERO
+ (- QQWHEIGHT YZERO) (+ XZERO (NTH 11 M))
+ (- QQWHEIGHT YZERO))
+ (IF (AND (NTH 13 M) (/= (NTH 13 M) 1))
+ (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) 1 0
+ 1 0)))
+ (LET ((QQWHEIGHT (CADDDR (CADR M))))
+ (IF (AND (NTH 13 M) (/= (NTH 13 M) 1))
+ (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M))
+ (OR (NTH 13 M) 1) 0 1 0))
+ (XDRAWLINE *WINDOW-DISPLAY* (CADADR M) (CADDR (CADR M)) XZERO
+ (- QQWHEIGHT YZERO) XZERO
(- QQWHEIGHT (+ YZERO (NTH 11 M))))
- (IF (AND GLVAR1498 (/= GLVAR1498 1))
- (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR GLVAR1496)
- 1 0 1 0)))))
+ (IF (AND (NTH 13 M) (/= (NTH 13 M) 1))
+ (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) 1 0
+ 1 0))))
(IF (NTH 10 M) (WINDOW-RESET-COLOR MW))
(XFLUSH *WINDOW-DISPLAY*)))
(DEFUN BARMENU-SELECT (M &OPTIONAL INSIDE)
+ (declare (ignore inside))
(LET (MW XZERO YZERO VAL)
(SETQ MW (OR (CADR M) (BARMENU-INIT M)))
- (UNLESS (TENTH M) (BARMENU-DRAW M))
- (SETQ XZERO
- (+ (IF (CADDR M) (FIFTH M) 0) (TRUNCATE (SEVENTH M) 2)))
+ (IF (NOT (TENTH M)) (BARMENU-DRAW M))
+ (SETQ XZERO (+ (IF (CADDR M) (FIFTH M) 0) (/ (SEVENTH M) 2)))
(SETQ YZERO (IF (CADDR M) (SIXTH M) 0))
(WHEN (WINDOW-TRACK-MOUSE-IN-REGION MW (IF (CADDR M) (FIFTH M) 0)
YZERO (SEVENTH M) (EIGHTH M) T T)
@@ -1637,34 +1810,29 @@
*GC-VALUES*)
(XGCVALUES-BACKGROUND *GC-VALUES*))))
(IF (NTH 10 M) (WINDOW-SET-COLOR MW (NTH 10 M))))
- (SETQ XZERO
- (+ (IF (CADDR M) (FIFTH M) 0) (TRUNCATE (SEVENTH M) 2)))
+ (SETQ XZERO (+ (IF (CADDR M) (FIFTH M) 0) (/ (SEVENTH M) 2)))
(SETQ YZERO (IF (CADDR M) (SIXTH M) 0))
(IF (NTH 14 M)
- (LET ((GLVAR1503 (CADR M)) (GLVAR1506 (NTH 13 M)))
- (LET ((QQWHEIGHT (CADDDR GLVAR1503)))
- (IF (AND GLVAR1506 (/= GLVAR1506 1))
- (XSETLINEATTRIBUTES *WINDOW-DISPLAY*
- (CADDR GLVAR1503) (OR GLVAR1506 1) 0 1 0))
- (XDRAWLINE *WINDOW-DISPLAY* (CADR GLVAR1503)
- (CADDR GLVAR1503) (+ XZERO (NTH 11 M))
- (- QQWHEIGHT YZERO) (+ XZERO VAL)
+ (LET ((QQWHEIGHT (CADDDR (CADR M))))
+ (IF (AND (NTH 13 M) (/= (NTH 13 M) 1))
+ (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M))
+ (OR (NTH 13 M) 1) 0 1 0))
+ (XDRAWLINE *WINDOW-DISPLAY* (CADADR M) (CADDR (CADR M))
+ (+ XZERO (NTH 11 M)) (- QQWHEIGHT YZERO) (+ XZERO VAL)
(- QQWHEIGHT YZERO))
- (IF (AND GLVAR1506 (/= GLVAR1506 1))
- (XSETLINEATTRIBUTES *WINDOW-DISPLAY*
- (CADDR GLVAR1503) 1 0 1 0))))
- (LET ((GLVAR1507 (CADR M)) (GLVAR1510 (NTH 13 M)))
- (LET ((QQWHEIGHT (CADDDR GLVAR1507)))
- (IF (AND GLVAR1510 (/= GLVAR1510 1))
- (XSETLINEATTRIBUTES *WINDOW-DISPLAY*
- (CADDR GLVAR1507) (OR GLVAR1510 1) 0 1 0))
- (XDRAWLINE *WINDOW-DISPLAY* (CADR GLVAR1507)
- (CADDR GLVAR1507) XZERO
- (- QQWHEIGHT (+ YZERO (NTH 11 M))) XZERO
+ (IF (AND (NTH 13 M) (/= (NTH 13 M) 1))
+ (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) 1
+ 0 1 0)))
+ (LET ((QQWHEIGHT (CADDDR (CADR M))))
+ (IF (AND (NTH 13 M) (/= (NTH 13 M) 1))
+ (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M))
+ (OR (NTH 13 M) 1) 0 1 0))
+ (XDRAWLINE *WINDOW-DISPLAY* (CADADR M) (CADDR (CADR M))
+ XZERO (- QQWHEIGHT (+ YZERO (NTH 11 M))) XZERO
(- QQWHEIGHT (+ YZERO VAL)))
- (IF (AND GLVAR1510 (/= GLVAR1510 1))
- (XSETLINEATTRIBUTES *WINDOW-DISPLAY*
- (CADDR GLVAR1507) 1 0 1 0)))))
+ (IF (AND (NTH 13 M) (/= (NTH 13 M) 1))
+ (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) 1
+ 0 1 0))))
(IF (< VAL (NTH 11 M))
(LET ((GC (CADDR MW)))
(XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*)
@@ -1680,6 +1848,113 @@
+(DEFUN TEXTMENU-CREATE
+ (WIDTH HEIGHT &OPTIONAL TITLE PARENTW X Y PERM FLAT FONT BOXFLG
+ INITIAL-TEXT)
+ (LIST 'TEXTMENU (IF FLAT PARENTW) FLAT (IF PARENTW (CADR PARENTW))
+ (OR X 0) (OR Y 0) 0 0 (IF TITLE (STRINGIFY TITLE) "") PERM
+ INITIAL-TEXT WIDTH HEIGHT BOXFLG (OR FONT '9X15)))
+
+(DEFUN TEXTMENU-CALCULATE-SIZE (M)
+ (LET (MAXWIDTH MAXHEIGHT)
+ (SETQ MAXWIDTH
+ (MAX (IF (NINTH M) (+ 6 (* 9 (LENGTH (NINTH M)))) 0)
+ (NTH 11 M)))
+ (SETQ MAXHEIGHT
+ (+ (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M)))
+ (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*))
+ 15 0)
+ (NTH 12 M)))
+ (SETF (SEVENTH M) MAXWIDTH)
+ (SETF (EIGHTH M) MAXHEIGHT)))
+
+(DEFUN TEXTMENU-INIT (M)
+ (TEXTMENU-CALCULATE-SIZE M)
+ (MENU-ADJUST-OFFSET M)
+ (IF (NOT (CADDR M))
+ (SETF (CADR M)
+ (WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "")
+ (CADDDR M) (FIFTH M) (SIXTH M) (NTH 14 M)))))
+
+(DEFUN TEXTMENU-DRAW (M)
+ (LET (MW BOTTOM XZERO YZERO)
+ (OR (AND (CADR M) (PLUSP (EIGHTH M))) (TEXTMENU-INIT M))
+ (SETQ MW (CADR M))
+ (XMAPWINDOW *WINDOW-DISPLAY* (CADR MW))
+ (XFLUSH *WINDOW-DISPLAY*)
+ (WINDOW-WAIT-EXPOSURE MW)
+ (MENU-CLEAR M)
+ (SETQ XZERO (IF (CADDR M) (FIFTH M) 0))
+ (SETQ YZERO (IF (CADDR M) (SIXTH M) 0))
+ (SETQ BOTTOM (+ YZERO (EIGHTH M)))
+ (WHEN (AND (NINTH M) (PLUSP (LENGTH (NINTH M)))
+ (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*))
+ (LET ((SSTR (STRINGIFY (STRINGIFY (NINTH M)))))
+ (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW)
+ (+ 3 XZERO) (+ 13 (- (CADDDR MW) BOTTOM))
+ (GET-C-STRING SSTR) (LENGTH SSTR)))
+ (LET ((GC (CADDR MW)))
+ (SETQ *WINDOW-SAVE-FUNCTION*
+ (PROGN
+ (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1
+ *GC-VALUES*)
+ (XGCVALUES-FUNCTION *GC-VALUES*)))
+ (XSETFUNCTION *WINDOW-DISPLAY* GC 6)
+ (SETQ *WINDOW-SAVE-FOREGROUND*
+ (PROGN
+ (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4
+ *GC-VALUES*)
+ (XGCVALUES-FOREGROUND *GC-VALUES*)))
+ (XSETFOREGROUND *WINDOW-DISPLAY* GC
+ (LOGXOR *WINDOW-SAVE-FOREGROUND*
+ (PROGN
+ (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8
+ *GC-VALUES*)
+ (XGCVALUES-BACKGROUND *GC-VALUES*)))))
+ (XFILLRECTANGLE *WINDOW-DISPLAY* (CADR MW) (CADDR MW) XZERO
+ (- (CADDDR MW) BOTTOM) (SEVENTH M) 16)
+ (LET ((GC (CADDR MW)))
+ (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*)
+ (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)))
+ (IF (NTH 10 M)
+ (LET ((SSTR (STRINGIFY (NTH 10 M))))
+ (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW)
+ (+ 10 XZERO)
+ (+ 8 (- (CADDDR MW) (+ YZERO (/ (EIGHTH M) 2))))
+ (GET-C-STRING SSTR) (LENGTH SSTR))))
+ (IF (NTH 13 M)
+ (WINDOW-DRAW-BOX-XY MW XZERO YZERO (SEVENTH M) (EIGHTH M) 1))
+ (XFLUSH *WINDOW-DISPLAY*)))
+
+(DEFUN TEXTMENU-SELECT (M &OPTIONAL INSIDE)
+ (declare (ignore inside))
+ (LET (MW XZERO YZERO CODEVAL)
+ (SETQ MW (OR (CADR M) (TEXTMENU-INIT M)))
+ (IF (NOT (TENTH M)) (TEXTMENU-DRAW M))
+ (SETQ XZERO (IF (CADDR M) (FIFTH M) 0))
+ (SETQ YZERO (IF (CADDR M) (SIXTH M) 0))
+ (WINDOW-TRACK-MOUSE MW
+ #'(LAMBDA (X Y CODE)
+ (SETQ *WINDOW-MENU-CODE* CODE)
+ (DECF X XZERO)
+ (DECF Y YZERO)
+ (IF (OR (PLUSP CODE) (MINUSP X) (> X (SEVENTH M))
+ (MINUSP Y) (> Y (EIGHTH M)))
+ (SETQ CODEVAL CODE)))
+ T)
+ (WHEN (AND (NOT (TENTH M)) (NOT (CADDR M)))
+ (XUNMAPWINDOW *WINDOW-DISPLAY* (CADADR M))
+ (XFLUSH *WINDOW-DISPLAY*)
+ (WINDOW-WAIT-UNMAP (CADR M)))
+ (WHEN (PLUSP CODEVAL)
+ (TEXTMENU-DRAW M)
+ (WINDOW-INPUT-STRING MW (NTH 10 M) (+ 10 XZERO)
+ (+ -8 (+ YZERO (/ (EIGHTH M) 2))) (+ -12 (SEVENTH M))))))
+
+(DEFUN TEXTMENU-SET-TEXT (M &OPTIONAL S) (SETF (NTH 10 M) (OR S "")))
+
+
+
(DEFUN WINDOW-GET-POINT (W)
(LET (ORGX ORGY)
(WINDOW-TRACK-MOUSE W
@@ -1876,6 +2151,7 @@
(LIST CENTER (LIST RADIUSX (ABS (- (CADR PT) (CADR CENTER)))))))
(DEFUN WINDOW-DRAW-ELLIPSE-PT (W X Y CENTER RADIUSX)
+ (declare (ignore x))
(WINDOW-DRAW-ELLIPSE-XY W (CAR CENTER) (CADR CENTER) RADIUSX
(ABS (- Y (CADR CENTER)))))
@@ -1972,13 +2248,14 @@
BACKGROUND))
(DEFUN WINDOW-FREE-COLOR (W &OPTIONAL XCOLOR)
+ (declare (ignore w))
(OR XCOLOR (SETQ XCOLOR *WINDOW-XCOLOR*))
(IF XCOLOR
(UNLESS (OR (EQL XCOLOR *DEFAULT-FG-COLOR*)
(EQL XCOLOR *DEFAULT-BG-COLOR*))
(XFREECOLORS *WINDOW-DISPLAY* *DEFAULT-COLORMAP* XCOLOR 1 0))))
-(DEFUN WINDOW-GET-CHARS (W FN)
+(DEFUN WINDOW-GET-CHARS (W FN &OPTIONAL ARGS)
(LET (WIN RES)
(OR *WINDOW-KEYINIT* (WINDOW-INIT-KEYMAP))
(SETQ *WINDOW-SHIFT* NIL)
@@ -1986,16 +2263,18 @@
(SETQ *WINDOW-META* NIL)
(SETQ WIN (WINDOW-PARENT W))
(XSYNC *WINDOW-DISPLAY* 1)
- (XSELECTINPUT *WINDOW-DISPLAY* WIN (+ KEYPRESSMASK KEYRELEASEMASK))
+ (XSELECTINPUT *WINDOW-DISPLAY* WIN
+ (+ KEYPRESSMASK KEYRELEASEMASK BUTTONPRESSMASK))
(WHILE (NULL RES) (XNEXTEVENT *WINDOW-DISPLAY* *WINDOW-EVENT*)
(LET ((TYPE (XANYEVENT-TYPE *WINDOW-EVENT*))
(EVENTWINDOW (XANYEVENT-WINDOW *WINDOW-EVENT*)))
(IF (EQL EVENTWINDOW WIN)
- (SETQ RES (WINDOW-PROCESS-CHAR-EVENT W TYPE FN)))))
+ (SETQ RES (WINDOW-PROCESS-CHAR-EVENT W TYPE FN ARGS)))))
RES))
-(DEFUN WINDOW-PROCESS-CHAR-EVENT (W TYPE FN)
- (LET (CODE)
+(DEFUN WINDOW-PROCESS-CHAR-EVENT (W TYPE FN ARGS)
+ (LET (CODE EVENTWINDOW)
+ (declare (ignore eventwindow))
(IF (EQL TYPE KEYRELEASE)
(PROGN
(SETQ CODE (XBUTTONEVENT-BUTTON *WINDOW-EVENT*))
@@ -2014,14 +2293,26 @@
(PROGN (SETQ *WINDOW-CTRL* T) NIL)
(IF (MEMBER CODE *WINDOW-META-KEYS*)
(PROGN (SETQ *WINDOW-META* T) NIL)
- (FUNCALL FN W
- (OR
- (AREF
- (IF *WINDOW-SHIFT*
- *WINDOW-SHIFTKEYMAP*
+ (FUNCALL FN W (WINDOW-CHAR-DECODE CODE) 0 0 0
+ ARGS)))))
+ (IF (EQL TYPE BUTTONPRESS)
+ (FUNCALL FN W 0 (XBUTTONEVENT-BUTTON *WINDOW-EVENT*)
+ (XMOTIONEVENT-X *WINDOW-EVENT*)
+ (- (WINDOW-DRAWABLE-HEIGHT W)
+ (XMOTIONEVENT-Y *WINDOW-EVENT*))
+ ARGS))))))
+
+(DEFUN WINDOW-CHAR-DECODE (CODE)
+ (LET (CHAR)
+ (SETQ CHAR
+ (AREF (IF *WINDOW-SHIFT* *WINDOW-SHIFTKEYMAP*
*WINDOW-KEYMAP*)
- CODE)
- #\Space))))))))))
+ CODE))
+ (IF (AND CHAR *WINDOW-CTRL*)
+ (SETQ CHAR (CODE-CHAR (- (CHAR-CODE (CHAR-UPCASE CHAR)) 64))))
+ (IF (AND CHAR *WINDOW-META*)
+ (SETQ CHAR (CODE-CHAR (+ (CHAR-CODE (CHAR-UPCASE CHAR)) 128))))
+ (OR CHAR #\Space)))
(DEFUN WINDOW-GET-RAW-CHAR (W)
(LET (WIN RES)
@@ -2040,63 +2331,434 @@
RES))
(DEFUN WINDOW-INPUT-STRING (W STR X Y &OPTIONAL SIZE)
- (LET ()
- (SETQ *WINDOW-INPUT-STRING-X* X)
- (SETQ *WINDOW-INPUT-STRING-Y* Y)
- (SETQ *WINDOW-INPUT-STRING-CHARWIDTH* (WINDOW-STRING-WIDTH W "M"))
- (SETQ *WINDOW-STRING-MAX*
- (IF SIZE (/ SIZE *WINDOW-INPUT-STRING-CHARWIDTH*) 100))
- (SETQ *WINDOW-STRING-COUNT*
- (IF STR (MIN (LENGTH STR) *WINDOW-STRING-MAX*) 0))
- (WINDOW-ERASE-AREA-XY W X (- Y 2) (OR SIZE 100) 14)
- (IF (> *WINDOW-STRING-COUNT* 0)
- (PROGN
- (DOTIMES (I *WINDOW-STRING-COUNT*)
- (SETF (CHAR *WINDOW-STRING* I) (CHAR STR I)))
- (WINDOW-PRINTAT-XY W STR X Y)))
- (WINDOW-DRAW-CARAT W)
- (WINDOW-GET-CHARS W #'WINDOW-INPUT-CHAR-FN)))
-
-(DEFUN WINDOW-INPUT-CHAR-FN (W CHAR)
- (LET ((TMPSTRING "Z"))
- (WINDOW-DRAW-CARAT W)
- (IF (CHAR= CHAR #\Return)
- (SUBSEQ *WINDOW-STRING* 0 *WINDOW-STRING-COUNT*)
- (PROGN
- (IF (CHAR= CHAR #\Backspace)
- (IF (> *WINDOW-STRING-COUNT* 0)
- (PROGN
- (DECF *WINDOW-STRING-COUNT*)
- (WINDOW-PRINTAT-XY W " "
- (+ *WINDOW-INPUT-STRING-X*
- (* *WINDOW-STRING-COUNT*
- *WINDOW-INPUT-STRING-CHARWIDTH*))
- *WINDOW-INPUT-STRING-Y*)
- (WINDOW-DRAW-CARAT W)))
- (IF (< *WINDOW-STRING-COUNT* *WINDOW-STRING-MAX*)
- (PROGN
- (SETF (CHAR *WINDOW-STRING* *WINDOW-STRING-COUNT*)
- CHAR)
- (INCF *WINDOW-STRING-COUNT*)
- (SETF (CHAR TMPSTRING 0) CHAR)
- (WINDOW-PRINTAT-XY W TMPSTRING
- (+ *WINDOW-INPUT-STRING-X*
- (* (1- *WINDOW-STRING-COUNT*)
- *WINDOW-INPUT-STRING-CHARWIDTH*))
- *WINDOW-INPUT-STRING-Y*)
- (WINDOW-DRAW-CARAT W))))
- NIL))))
-
-(DEFUN WINDOW-DRAW-CARAT (W)
- (LET ((ORIGX *WINDOW-INPUT-STRING-X*) (Y *WINDOW-INPUT-STRING-Y*) X)
- (SETQ X
- (+ ORIGX
- (* *WINDOW-INPUT-STRING-CHARWIDTH* *WINDOW-STRING-COUNT*)))
+ (CAR (WINDOW-EDIT W X Y (OR SIZE 100) 16 (LIST (OR STR "")) NIL T T)))
+
+(DEFUN WINDOW-EDIT
+ (W X Y WIDTH HEIGHT &OPTIONAL STRINGS BOXFLG SCROLL ENDP)
+ (LET (EM)
+ (SETQ EM
+ (EDITMENU-CREATE WIDTH HEIGHT NIL W X Y NIL T '9X15 BOXFLG
+ STRINGS SCROLL ENDP))
+ (EDITMENU-EDIT EM)
+ (EDITMENU-CARAT EM)
+ (NTH 10 EM)))
+
+
+
+(DEFUN EDITMENU-CREATE
+ (WIDTH HEIGHT &OPTIONAL TITLE PARENTW X Y PERM FLAT FONT BOXFLG
+ INITIAL-TEXT SCROLLVAL ENDP)
+ (LIST 'EDITMENU (IF FLAT PARENTW) FLAT (IF PARENTW (CADR PARENTW))
+ (OR X 0) (OR Y 0) 0 0 (IF TITLE (STRINGIFY TITLE) "") PERM
+ (OR INITIAL-TEXT (LIST "")) WIDTH HEIGHT BOXFLG (OR FONT '9X15)
+ (IF ENDP
+ (LENGTH (NTH (IF (NUMBERP SCROLLVAL) SCROLLVAL 0)
+ INITIAL-TEXT))
+ 0)
+ (IF (NUMBERP SCROLLVAL) SCROLLVAL 0) (OR SCROLLVAL 0)))
+
+(DEFUN EDITMENU-CALCULATE-SIZE (M)
+ (SETF (SEVENTH M) (NTH 11 M))
+ (SETF (EIGHTH M) (NTH 12 M)))
+
+(DEFUN EDITMENU-INIT (M)
+ (EDITMENU-CALCULATE-SIZE M)
+ (MENU-ADJUST-OFFSET M)
+ (IF (NOT (CADDR M))
+ (SETF (CADR M)
+ (WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "")
+ (CADDDR M) (FIFTH M) (SIXTH M) (NTH 14 M)))))
+
+(DEFUN EDITMENU-DRAW (M)
+ (LET (MW XZERO YZERO)
+ (OR (AND (CADR M) (PLUSP (EIGHTH M))) (EDITMENU-INIT M))
+ (SETQ MW (CADR M))
+ (XMAPWINDOW *WINDOW-DISPLAY* (CADR MW))
+ (XFLUSH *WINDOW-DISPLAY*)
+ (WINDOW-WAIT-EXPOSURE MW)
+ (MENU-CLEAR M)
+ (SETQ XZERO (IF (CADDR M) (FIFTH M) 0))
+ (SETQ YZERO (IF (CADDR M) (SIXTH M) 0))
+ (IF (NTH 13 M)
+ (WINDOW-DRAW-BOX-XY MW XZERO YZERO (SEVENTH M) (EIGHTH M) 1))
+ (EDITMENU-DISPLAY M 0 0 (NOT (NUMBERP (NTH 17 M))))))
+
+(DEFUN EDITMENU-DISPLAY (M LINE CHAR ONLY)
+ (LET (LINES Y MAXWIDTH LINEWIDTH (W (OR (CADR M) (EDITMENU-INIT M))))
+ (SETQ LINES (NTHCDR LINE (NTH 10 M)))
+ (SETQ Y
+ (+ (IF (CADDR M) (SIXTH M) 0)
+ (- (EIGHTH M)
+ (1- (* (WINDOW-STRING-HEIGHT
+ (OR (CADR M) (EDITMENU-INIT M)) "Tg")
+ (1+ (- (- LINE
+ (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0))
+ (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0))))))))
+ (SETQ MAXWIDTH
+ (TRUNCATE (+ -6 (SEVENTH M))
+ (LET ((SSTR (STRINGIFY "W")))
+ (XTEXTWIDTH (SEVENTH (OR (CADR M) (EDITMENU-INIT M)))
+ (GET-C-STRING SSTR) (LENGTH SSTR)))))
+ (WHILE (AND LINES (>= Y (+ 4 (IF (CADDR M) (SIXTH M) 0)))) ; = by hand
+ (IF (< CHAR MAXWIDTH)
+ (IF (PLUSP CHAR)
+ (LET ((SSTR (STRINGIFY
+ (SUBSEQ (FIRST LINES) CHAR
+ (MIN MAXWIDTH
+ (LENGTH (FIRST LINES)))))))
+ (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W)
+ (CADDR W)
+ (+ (IF (CADDR M) (FIFTH M) 0)
+ (+ 2
+ (* CHAR
+ (LET ((SSTR (STRINGIFY "W")))
+ (XTEXTWIDTH
+ (SEVENTH
+ (OR (CADR M) (EDITMENU-INIT M)))
+ (GET-C-STRING SSTR) (LENGTH SSTR))))))
+ (- (CADDDR W) Y) (GET-C-STRING SSTR)
+ (LENGTH SSTR)))
+ (LET ((SSTR (STRINGIFY
+ (IF
+ (<= (LENGTH (FIRST LINES))
+ MAXWIDTH)
+ (FIRST LINES)
+ (SUBSEQ (FIRST LINES) 0 MAXWIDTH)))))
+ (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W)
+ (CADDR W) (+ 2 (IF (CADDR M) (FIFTH M) 0))
+ (- (CADDDR W) Y) (GET-C-STRING SSTR)
+ (LENGTH SSTR)))))
+ (SETQ LINEWIDTH
+ (+ 2
+ (* (LET ((SSTR (STRINGIFY "W")))
+ (XTEXTWIDTH
+ (SEVENTH (OR (CADR M) (EDITMENU-INIT M)))
+ (GET-C-STRING SSTR) (LENGTH SSTR)))
+ (LENGTH (FIRST LINES)))))
+ (WINDOW-ERASE-AREA-XY W
+ (+ (IF (CADDR M) (FIFTH M) 0) LINEWIDTH) (+ -2 Y)
+ (+ -2 (- (SEVENTH M) LINEWIDTH))
+ (WINDOW-STRING-HEIGHT (OR (CADR M) (EDITMENU-INIT M))
+ "Tg"))
+ (DECF Y
+ (WINDOW-STRING-HEIGHT (OR (CADR M) (EDITMENU-INIT M))
+ "Tg"))
+ (IF ONLY (SETQ LINES NIL)
+ (PROGN
+ (POP LINES)
+ (IF (AND (NULL LINES)
+ (>= Y (+ 4 (IF (CADDR M) (SIXTH M) 0))))
+ (WINDOW-ERASE-AREA-XY W
+ (+ 2 (IF (CADDR M) (FIFTH M) 0)) (+ -2 Y)
+ (+ -4 (SEVENTH M))
+ (WINDOW-STRING-HEIGHT
+ (OR (CADR M) (EDITMENU-INIT M)) "Tg")))))
+ (SETQ CHAR 0))
+ (XFLUSH *WINDOW-DISPLAY*)))
+
+(DEFUN EDITMENU-CARAT (M)
+ (WINDOW-DRAW-CARAT (OR (CADR M) (EDITMENU-INIT M))
+ (+ (IF (CADDR M) (FIFTH M) 0)
+ (+ 2
+ (* (NTH 15 M)
+ (LET ((SSTR (STRINGIFY "W")))
+ (XTEXTWIDTH (SEVENTH (OR (CADR M) (EDITMENU-INIT M)))
+ (GET-C-STRING SSTR) (LENGTH SSTR))))))
+ (+ -2
+ (+ (IF (CADDR M) (SIXTH M) 0)
+ (- (EIGHTH M)
+ (1- (* (WINDOW-STRING-HEIGHT
+ (OR (CADR M) (EDITMENU-INIT M)) "Tg")
+ (1+ (- (NTH 16 M)
+ (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0)))))))))
+ (XFLUSH *WINDOW-DISPLAY*))
+
+(DEFUN EDITMENU-ERASE (M ONEP)
+ (LET ((W (OR (CADR M) (EDITMENU-INIT M))) XW)
+ (SETQ XW
+ (+ 2
+ (* (LET ((SSTR (STRINGIFY "W")))
+ (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR)
+ (LENGTH SSTR)))
+ (NTH 15 M))))
+ (LET ((GLVAR113882 (WINDOW-STRING-HEIGHT W "Tg")))
+ (XCLEARAREA *WINDOW-DISPLAY* (CADR W)
+ (+ (IF (CADDR M) (FIFTH M) 0) XW)
+ (- (CADDDR W)
+ (1- (+ (- (+ (IF (CADDR M) (SIXTH M) 0)
+ (- (EIGHTH M)
+ (1- (* (WINDOW-STRING-HEIGHT
+ (OR (CADR M) (EDITMENU-INIT M))
+ "Tg")
+ (1+
+ (- (NTH 16 M)
+ (IF (NUMBERP (NTH 17 M))
+ (NTH 17 M) 0)))))))
+ (CADR (LET ((SSTR (STRINGIFY "Tg")))
+ (XTEXTEXTENTS (SEVENTH W)
+ (GET-C-STRING SSTR) (LENGTH SSTR)
+ *DIRECTION-RETURN* *ASCENT-RETURN*
+ *DESCENT-RETURN* *OVERALL-RETURN*)
+ (LIST (INT-POS *ASCENT-RETURN* 0)
+ (INT-POS *DESCENT-RETURN* 0)))))
+ GLVAR113882)))
+ (IF ONEP
+ (LET ((SSTR (STRINGIFY "W")))
+ (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR)
+ (LENGTH SSTR)))
+ (- (SEVENTH M) XW))
+ GLVAR113882 0))
+ (XFLUSH *WINDOW-DISPLAY*)))
+
+(DEFUN EDITMENU-LINE-Y (M LINE)
+ (+ (IF (CADDR M) (SIXTH M) 0)
+ (- (EIGHTH M)
+ (1- (* (WINDOW-STRING-HEIGHT (OR (CADR M) (EDITMENU-INIT M))
+ "Tg")
+ (1+ (- LINE (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0))))))))
+
+(DEFUN EDITMENU-SELECT (M &OPTIONAL INSIDE)
+ (declare (ignore inside))
+ (LET (MW CODEVAL XVAL YVAL)
+ (SETQ MW (OR (CADR M) (EDITMENU-INIT M)))
+ (IF (NOT (TENTH M)) (EDITMENU-DRAW M))
+ (WINDOW-TRACK-MOUSE MW
+ #'(LAMBDA (X Y CODE)
+ (SETQ *WINDOW-MENU-CODE* CODE)
+ (WHEN (OR (PLUSP CODE) (< X (FIFTH M))
+ (> X (+ (FIFTH M) (SEVENTH M))) (< Y (SIXTH M))
+ (> Y (+ (SIXTH M) (EIGHTH M))))
+ (SETQ CODEVAL CODE)
+ (SETQ XVAL X)
+ (SETQ YVAL Y)))
+ T)
+ (IF (PLUSP CODEVAL) (EDITMENU-EDIT M CODEVAL XVAL YVAL))))
+
+(DEFVAR *WINDOW-EDITMENU-KILL-STRINGS* NIL)
+
+(DEFUN EDITMENU-EDIT (M &OPTIONAL CODE X Y)
+ (LET ((MW (OR (CADR M) (EDITMENU-INIT M))))
+ (EDITMENU-DRAW M)
+ (EDITMENU-CARAT M)
+ (IF CODE (EDITMENU-EDIT-FN MW NIL CODE X Y (LIST M)))
+ (SETQ *WINDOW-EDITMENU-KILL-STRINGS* NIL)
+ (WINDOW-GET-CHARS MW #'EDITMENU-EDIT-FN (LIST M))
+ (NTH 10 M)))
+
+(DEFUN EDITMENU-EDIT-FN (W CHAR BUTTON BUTTONX BUTTONY ARGS)
+ (declare (ignore w))
+ (LET (M INSIDE DONE)
+ (SETQ M (CAR ARGS))
+ (EDITMENU-CARAT M)
+ (IF (AND (NUMBERP BUTTON) (NOT (ZEROP BUTTON)))
+ (PROGN
+ (SETQ INSIDE (EDITMENU-SETXY M BUTTONX BUTTONY))
+ (CASE BUTTON
+ (1 (IF INSIDE (PROGN (EDITMENU-CARAT M) NIL) T))
+ (2 (WHEN INSIDE (EDITMENU-YANK M) (EDITMENU-CARAT M) NIL))))
+ (PROGN
+ (IF (< (CHAR-CODE CHAR) 32)
+ (CASE CHAR
+ (#\Return
+ (IF (NUMBERP (NTH 17 M)) (EDITMENU-RETURN M)
+ (SETQ DONE T)))
+ (#\Backspace (EDITMENU-BACKSPACE M))
+ (#\^D (EDITMENU-DELETE M))
+ (#\^N (IF (NUMBERP (NTH 17 M)) (EDITMENU-NEXT M)))
+ (#\^P (EDITMENU-PREVIOUS M))
+ (#\^F (EDITMENU-FORWARD M))
+ (#\^B (EDITMENU-BACKWARD M))
+ (#\^A (EDITMENU-BEGINNING M))
+ (#\^E (EDITMENU-END M))
+ (#\^K (EDITMENU-KILL M))
+ (#\^Y (EDITMENU-YANK M))
+ (T NIL))
+ (IF (> (CHAR-CODE CHAR) 128)
+ (PROGN
+ (SETQ CHAR (CODE-CHAR (+ -128 (CHAR-CODE CHAR))))
+ (CASE CHAR
+ (#\B (EDITMENU-META-B M))
+ (#\F (EDITMENU-META-F M))
+ (T NIL)))
+ (EDITMENU-CHAR M CHAR)))
+ (EDITMENU-CARAT M)
+ DONE))))
+
+(DEFUN EDITMENU-SETXY (M BUTTONX BUTTONY)
+ (LET (LINECONS OKAY)
+ (SETQ OKAY
+ (AND (>= BUTTONX (FIFTH M))
+ (<= BUTTONX (+ (FIFTH M) (SEVENTH M)))
+ (>= BUTTONY (SIXTH M))
+ (<= BUTTONY (+ (SIXTH M) (EIGHTH M)))))
+ (WHEN OKAY
+ (SETF (NTH 16 M)
+ (MIN (1- (LENGTH (NTH 10 M)))
+ (+ (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0)
+ (TRUNCATE
+ (- (+ (IF (CADDR M) (SIXTH M) 0)
+ (+ -6 (EIGHTH M)))
+ BUTTONY)
+ (WINDOW-STRING-HEIGHT
+ (OR (CADR M) (EDITMENU-INIT M)) "Tg")))))
+ (SETQ LINECONS (NTHCDR (NTH 16 M) (NTH 10 M)))
+ (SETF (NTH 15 M)
+ (MIN (LENGTH (CAR LINECONS))
+ (TRUNCATE
+ (+ -2 (- BUTTONX (IF (CADDR M) (FIFTH M) 0)))
+ (LET ((SSTR (STRINGIFY "W")))
+ (XTEXTWIDTH
+ (SEVENTH (OR (CADR M) (EDITMENU-INIT M)))
+ (GET-C-STRING SSTR) (LENGTH SSTR)))))))
+ OKAY))
+
+(DEFUN EDITMENU-CHAR (M CHAR)
+ (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M))))
+ (IF (<= (LENGTH (CAR LINECONS)) (NTH 15 M))
+ (SETF (CAR LINECONS)
+ (CONCATENATE 'STRING (CAR LINECONS) (STRING CHAR)))
+ (SETF (CAR LINECONS)
+ (CONCATENATE 'STRING (SUBSEQ (CAR LINECONS) 0 (NTH 15 M))
+ (STRING CHAR) (SUBSEQ (CAR LINECONS) (NTH 15 M)))))
+ (EDITMENU-DISPLAY M (NTH 16 M) (NTH 15 M) T)
+ (INCF (NTH 15 M))))
+
+(DEFUN EDITMENU-CURRENT-CHAR (M)
+ (CHAR (NTH (NTH 16 M) (NTH 10 M)) (NTH 15 M)))
+
+(DEFUN EDITMENU-RETURN (M)
+ (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M))))
+ (IF (<= (LENGTH (CAR LINECONS)) (NTH 15 M))
+ (PUSH "" (CDR LINECONS))
+ (PROGN
+ (PUSH (SUBSEQ (CAR LINECONS) (NTH 15 M)) (CDR LINECONS))
+ (SETF (CAR LINECONS) (SUBSEQ (CAR LINECONS) 0 (NTH 15 M)))))
+ (EDITMENU-DISPLAY M (NTH 16 M) 0 NIL)
+ (INCF (NTH 16 M))
+ (SETF (NTH 15 M) 0)))
+
+(DEFUN EDITMENU-BACKSPACE (M)
+ (LET (TMP LINEDEL (LINECONS (NTHCDR (NTH 16 M) (NTH 10 M))))
+ (IF (PLUSP (NTH 15 M))
+ (PROGN
+ (DECF (NTH 15 M))
+ (SETF (CAR LINECONS)
+ (CONCATENATE 'STRING
+ (SUBSEQ (CAR LINECONS) 0 (NTH 15 M))
+ (SUBSEQ (CAR LINECONS) (1+ (NTH 15 M))))))
+ (WHEN (PLUSP (NTH 16 M))
+ (DECF (NTH 16 M))
+ (SETQ LINEDEL T)
+ (SETQ LINECONS (NTHCDR (NTH 16 M) (NTH 10 M)))
+ (SETF (NTH 15 M) (LENGTH (CAR LINECONS)))
+ (SETQ TMP
+ (CONCATENATE 'STRING (CAR LINECONS) (CADR LINECONS)))
+ (SETF (CDR LINECONS) (CDDR LINECONS))
+ (SETF (CAR LINECONS) TMP)))
+ (EDITMENU-DISPLAY M (NTH 16 M) (NTH 15 M) (NOT LINEDEL))))
+
+(DEFUN EDITMENU-END (M)
+ (SETF (NTH 15 M) (LENGTH (NTH (NTH 16 M) (NTH 10 M)))))
+
+(DEFUN EDITMENU-BEGINNING (M) (SETF (NTH 15 M) 0))
+
+(DEFUN EDITMENU-FORWARD (M)
+ (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M))))
+ (IF (< (NTH 15 M) (LENGTH (CAR LINECONS))) (INCF (NTH 15 M))
+ (WHEN (NUMBERP (NTH 17 M))
+ (INCF (NTH 16 M))
+ (IF (NULL (CDR LINECONS)) (SETF (CDR LINECONS) (LIST "")))
+ (SETF (NTH 15 M) 0)))))
+
+(DEFUN EDITMENU-META-F (M)
+ (LET (FOUND DONE)
+ (WHILE (AND (OR (< (NTH 16 M) (1- (LENGTH (NTH 10 M))))
+ (< (NTH 15 M) (LENGTH (NTH (NTH 16 M) (NTH 10 M)))))
+ (NOT FOUND))
+ (IF (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M))
+ (SETQ FOUND T) (EDITMENU-FORWARD M)))
+ (IF FOUND
+ (WHILE (AND (OR (< (NTH 16 M) (1- (LENGTH (NTH 10 M))))
+ (< (NTH 15 M)
+ (LENGTH (NTH (NTH 16 M) (NTH 10 M)))))
+ (NOT DONE))
+ (IF (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M))
+ (EDITMENU-FORWARD M) (SETQ DONE T))))))
+
+(DEFUN EDITMENU-ALPHANUMBERICP (X)
+ (OR (ALPHA-CHAR-P X) (NOT (NULL (DIGIT-CHAR-P X)))))
+
+(DEFUN EDITMENU-NEXT (M)
+ (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M))))
+ (INCF (NTH 16 M))
+ (IF (NULL (CDR LINECONS)) (SETF (CDR LINECONS) (LIST "")))
+ (SETQ LINECONS (CDR LINECONS))
+ (SETF (NTH 15 M) (MIN (NTH 15 M) (LENGTH (CAR LINECONS))))))
+
+(DEFUN EDITMENU-BACKWARD (M)
+ (IF (PLUSP (NTH 15 M)) (DECF (NTH 15 M))
+ (WHEN (PLUSP (NTH 16 M))
+ (DECF (NTH 16 M))
+ (SETF (NTH 15 M) (LENGTH (NTH (NTH 16 M) (NTH 10 M)))))))
+
+(DEFUN EDITMENU-META-B (M)
+ (LET (FOUND DONE)
+ (WHILE (AND (OR (PLUSP (NTH 15 M)) (PLUSP (NTH 16 M))) (NOT FOUND))
+ (EDITMENU-BACKWARD M)
+ (IF (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M))
+ (SETQ FOUND T)))
+ (WHEN FOUND
+ (WHILE (AND (OR (PLUSP (NTH 15 M)) (PLUSP (NTH 16 M)))
+ (NOT DONE))
+ (IF (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M))
+ (EDITMENU-BACKWARD M) (SETQ DONE T)))
+ (UNLESS (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M))
+ (EDITMENU-FORWARD M)))))
+
+(DEFUN EDITMENU-PREVIOUS (M)
+ (WHEN (PLUSP (NTH 16 M))
+ (DECF (NTH 16 M))
+ (SETF (NTH 15 M)
+ (MIN (NTH 15 M) (LENGTH (NTH (NTH 16 M) (NTH 10 M)))))))
+
+(DEFUN EDITMENU-DELETE (M)
+ (EDITMENU-FORWARD M)
+ (EDITMENU-BACKSPACE M))
+
+(DEFUN EDITMENU-KILL (M)
+ (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M))))
+ (IF (< (NTH 15 M) (LENGTH (CAR LINECONS)))
+ (PROGN
+ (SETQ *WINDOW-EDITMENU-KILL-STRINGS*
+ (LIST (SUBSEQ (CAR LINECONS) (NTH 15 M))))
+ (SETF (CAR LINECONS) (SUBSEQ (CAR LINECONS) 0 (NTH 15 M)))
+ (EDITMENU-DISPLAY M (NTH 16 M) (NTH 15 M) T))
+ (EDITMENU-DELETE M))))
+
+(DEFUN EDITMENU-YANK (M)
+ (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M))) (COL (NTH 15 M)))
+ (WHEN *WINDOW-EDITMENU-KILL-STRINGS*
+ (IF (<= (LENGTH (CAR LINECONS)) (NTH 15 M))
+ (PROGN
+ (SETF (CAR LINECONS)
+ (CONCATENATE 'STRING (CAR LINECONS)
+ (CAR *WINDOW-EDITMENU-KILL-STRINGS*)))
+ (SETF (NTH 15 M) (LENGTH (CAR LINECONS))))
+ (PROGN
+ (SETF (CAR LINECONS)
+ (CONCATENATE 'STRING (SUBSEQ (CAR LINECONS) 0 COL)
+ (CAR *WINDOW-EDITMENU-KILL-STRINGS*)
+ (SUBSEQ (CAR LINECONS) COL)))
+ (INCF (NTH 15 M)
+ (LENGTH (CAR *WINDOW-EDITMENU-KILL-STRINGS*)))))
+ (EDITMENU-DISPLAY M (NTH 16 M) COL T))))
+
+(DEFUN WINDOW-DRAW-CARAT (W X Y)
(WINDOW-SET-XOR W)
- (WINDOW-DRAW-LINE-XY W (- X 2) (- Y 2) (+ X 3) Y)
- (WINDOW-DRAW-LINE-XY W (+ X 3) Y (+ X 8) (- Y 2))
+ (WINDOW-DRAW-LINE-XY W (- X 5) (- Y 2) X Y)
+ (WINDOW-DRAW-LINE-XY W X Y (+ X 5) (- Y 2))
(WINDOW-UNSET W)
- (WINDOW-FORCE-OUTPUT W)))
+ (WINDOW-FORCE-OUTPUT W))
(DEFUN WINDOW-INIT-KEYMAP ()
(LET (MINCODE MAXCODE KEYCODE KEYSYM KEYNUM SHIFTKEYNUM CHAR)
Index: xgcl-2/gcl_general.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/xgcl-2/gcl_general.lsp,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -b -r1.1.2.1 -r1.1.2.2
--- xgcl-2/gcl_general.lsp 5 Jan 2006 17:55:35 -0000 1.1.2.1
+++ xgcl-2/gcl_general.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.2
@@ -1,5 +1,5 @@
(in-package :XLIB)
-; general.lsp Hiep Huu Nguyen 27 Aug 92
+; general.lsp Hiep Huu Nguyen ; 15 Sep 05; 24 Jan 06
; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin.
@@ -22,6 +22,10 @@
; Some of the files that interface to the Xlib are adapted from DEC/MIT files.
; See the file dec.copyright for details.
+; 27 Aug 92
+; 15 Sep 05: Edited by G. Novak to change C function headers to new form
+; 24 Jan 06: Edited by G. Novak to remove vertex-array entries.
+
(defentry free (int) (void free))
(defentry calloc(int int) (int calloc))
(defentry char-array (int) (int char_array))
@@ -42,9 +46,8 @@
(defentry get-c-string (object) (object "(object)object_to_string"))
-
;; General routines.
-(defCfun "object lisp_string(object a_string, int c_string )" 0
+(defCfun "object lisp_string(object a_string, int c_string) " 0
"int len = strlen(c_string);"
"a_string->st.st_dim = len;"
"a_string->st.st_fillp = len;"
@@ -67,11 +70,3 @@
(defun get-st-point (string)
( get-st-point2 (concatenate 'string string "")))
-(defentry vertex-array (int) (int vertex_array))
-(defentry vertex-pos-x (int int) (int vertex_pos_x))
-(defentry vertex-pos-y (int int) (int vertex_pos_y))
-(defentry vertex-pos-flag (int int) (int vertex_pos_flag))
-(defentry set-vertex-array (int int int int int) (void set_vertex_array))
-;(defentry Xdraw (int int int int int) (int "XDraw"))
-;(defentry Xdrawfilled (int int int int int) (int "XDrawFilled"))
-
Index: xgcl-2/gcl_menu-set.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/xgcl-2/gcl_menu-set.lsp,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -b -r1.1.2.1 -r1.1.2.2
--- xgcl-2/gcl_menu-set.lsp 5 Jan 2006 17:55:35 -0000 1.1.2.1
+++ xgcl-2/gcl_menu-set.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.2
@@ -1,8 +1,8 @@
-; menu-set.lsp Gordon S. Novak Jr. 05 Jan 95
+; menu-set.lsp Gordon S. Novak Jr. ; 02 Aug 04
; Functions to handle a set of menus within a single window.
-; Copyright (c) 1995 Gordon S. Novak Jr. and The University of Texas at Austin.
+; Copyright (c) 2004 Gordon S. Novak Jr. and The University of Texas at Austin.
; See the file gnu.license .
@@ -23,6 +23,8 @@
; Written by: Gordon S. Novak Jr., Department of Computer Sciences,
; University of Texas at Austin 78712. address@hidden
+; 12 Aug 96; 04 Nov 97; 28 Feb 02; 05 Jan 04; 03 Mar 04; 30 Jul 04
+
; (wtesta) ; in dwtest.lsp, to create window myw
; (setq ms (menu-set-create myw nil))
@@ -44,8 +46,6 @@
; repeat above as desired
; (menu-conns-move mc) ; click a menu and move it
-(in-package :user)
-
(glispobjects
(menu-set (listobject (window window)
@@ -82,6 +82,8 @@
(menu-port (list (port symbol) (menu-name symbol)) )
+(menu-selection (list (port symbol) (menu-name symbol) (button integer)) )
+
(menu-set-conn (list (from menu-port)
(to menu-port)))
@@ -100,25 +102,28 @@
(remove-items menu-conns-remove-items)
(find-conns menu-conns-find-conns)
(connected-ports menu-conns-connected-ports)
- (named-menu menu-conns-named-menu) ) )
+ (new-conn menu-conns-new-conn)
+ (named-menu menu-conns-named-menu)
+ (named-item menu-conns-named-item) ) )
) ; glispobjects
; 04 Sep 92; 09 Feb 94; 12 Oct 94
-(gldefun menu-set-create (w\:window &optional fn)
+(gldefun menu-set-create ((w window) &optional fn)
(a menu-set with window = w commandfn = fn))
; 05 Sep 92; 09 Sep 92; 10 Sep 92; 02 Nov 92; 05 May 93; 07 May 93; 04 Aug 93
-; 03 Jan 94; 07 Jan 94; 03 May 94; 05 Jan 95
+; 03 Jan 94; 07 Jan 94; 03 May 94; 05 Jan 95; 11 Apr 95; 03 Nov 97; 05 Jan 04
; Select from multiple menu-like regions within a window.
-; Result is a list of the name of the menu and the value selected from it,
-; e.g., (COMMAND QUIT) for selecting the QUIT item from the COMMAND menu.
+; Result is a menu-selection, i.e., a list of the value selected,
+; menu name, and button used,
+; e.g., (QUIT COMMAND 1) for selecting the QUIT item from the COMMAND menu.
; A click outside any menu returns ((x y) BACKGROUND button-code).
; enabled, if specified, is a list of names of menus enabled for selection.
-(gldefun menu-set-select (ms\:menu-set &optional redraw\:boolean
- enabled\:(listof symbol))
- (result menu-port)
- (let (res\:menu-port resb itm\:menu-set-item sel\:symbol lastx lasty)
+(gldefun menu-set-select ((ms menu-set) &optional (redraw boolean)
+ (enabled (listof symbol)))
+ (result menu-selection)
+ (let ((res menu-selection) resb (itm menu-set-item) (sel symbol) lastx lasty)
(if redraw (draw ms))
(while ~ (or res resb)
(setq itm (window-track-mouse (window ms)
@@ -130,147 +135,162 @@
(that menu-item with
(contains-xy (that menu-item) x y))))))
(if (numberp itm)
- then (resb \:= (list (a vector with x = lastx y = lasty)
- 'background itm))
- else (if (or (atom enabled)
+ (resb = (a menu-selection with
+ port (a vector with x = lastx y = lasty)
+ menu-name 'background
+ button itm))
+ (if (or (atom enabled)
(member (menu-name itm) enabled))
- then (sel \:= (menu-mselect (menu itm) (eq enabled t)))
+ (progn (sel = (menu-mselect (menu itm) (eq enabled t)))
(if sel
- then (res \:= (a menu-port with
+ (res = (a menu-selection with
menu-name (menu-name itm)
- port sel))
- else (if (*window-menu-code* <> 0)
- then (res \:= (a menu-port with
+ port sel
+ button *window-menu-code*))
+ (if (and *window-menu-code*
+ (*window-menu-code* <> 0))
+ (res = (a menu-selection with
menu-name (menu-name itm)
- port nil)))) ) ) )
+ port nil
+ button *window-menu-code*)))) ) )
))
(force-output (window ms))
(or res resb) ))
; 05 Sep 92; 25 Sep 92; 29 Sep 92
; Add a menu to a menu set.
; name is the name of the menu. sym is extra info such as data type.
-(gldefun menu-set-add-menu (ms\:menu-set name\:symbol sym\:symbol
- title\:string items
- &optional offset\:vector)
+(gldefun menu-set-add-menu ((ms menu-set) (name symbol) (sym symbol)
+ (title string) items
+ &optional (offset vector))
(let (menu)
- (menu \:= (menu-create items title (window ms) (x offset) (y offset) t t))
+ (menu = (menu-create items title (window ms) (x offset) (y offset) t t))
(init menu)
- (if ~ offset (offset \:= (get-box-position (window ms)
+ (if ~ offset (offset = (get-box-position (window ms)
(picture-width menu)
(picture-height menu))))
- ((parent-offset-x menu) \:= (x offset))
- ((parent-offset-y menu) \:= (y offset))
+ ((parent-offset-x menu) = (x offset))
+ ((parent-offset-y menu) = (y offset))
(add-item ms name sym menu) ))
; 25 Sep 92; 29 Sep 92; 07 May 93
-(gldefun menu-set-add-item (ms\:menu-set name\:symbol sym\:symbol menu\:menu)
+(gldefun menu-set-add-item ((ms menu-set) (name symbol) (sym symbol)
+ (menu menu))
((menu-items ms) _+ (a menu-set-item with menu-name = name sym = sym
menu = menu)) )
; 25 Sep 92
-(gldefun menu-set-remove-items (ms\:menu-set)
- ((menu-items ms) \:= nil) )
+(gldefun menu-set-remove-items ((ms menu-set))
+ ((menu-items ms) = nil) )
-; 06 Sep 92; 08 Sep 92; 14 Sep 92; 25 Sep 92; 29 Sep 92
-(gldefun menu-set-add-picmenu (ms\:menu-set name\:symbol sym\:symbol
- title\:string
- spec\:picmenu-spec
- &optional offset\:vector
- nobox\:boolean)
+; 06 Sep 92; 08 Sep 92; 14 Sep 92; 25 Sep 92; 29 Sep 92; 05 Jan 04; 23 Jun 04
+(gldefun menu-set-add-picmenu ((ms menu-set) (name symbol) (sym symbol)
+ (title string)
+ (spec picmenu-spec)
+ &optional (offset vector)
+ (nobox boolean))
(let (menu maxwidth maxheight)
- (if (symbolp spec)
- then (spec \:= (get spec 'picmenu-spec)) )
- (menu \:= (picmenu-create-from-spec spec title (window ms)
+ (if (and spec (symbolp spec))
+ (spec = (get spec 'picmenu-spec)) )
+ (menu = (picmenu-create-from-spec spec title (window ms)
(x offset) (y offset) t t (not nobox)))
- (maxwidth \:= (max (if title then ((* 9 (length title)) + 6)
- else 0)
+ (maxwidth = (max (if title ((* 9 (length title)) + 6) 0)
(drawing-width spec)))
- (maxheight \:= (if title then 15 else 0) + (drawing-height spec))
- (if ~ offset (offset \:= (get-box-position (window ms)
- maxwidth maxheight)))
- ((parent-offset-x menu) \:= (x offset))
- ((parent-offset-y menu) \:= (y offset))
+ (maxheight = (if title 15 0) + (drawing-height spec))
+ (if ~ offset (offset = (get-box-position (window ms) maxwidth maxheight)))
+ ((parent-offset-x menu) = (x offset))
+ ((parent-offset-y menu) = (y offset))
(add-item ms name sym menu) ))
; 11 Oct 93
-(gldefun menu-set-add-component (ms\:menu-set name\:symbol
- &optional offset\:vector)
+(gldefun menu-set-add-component ((ms menu-set) (name symbol)
+ &optional (offset vector))
(menu-set-add-picmenu ms (menu-set-name name) name nil name offset t))
-; 03 Jan 94
+; 03 Jan 94; 05 Jan 04
; Add a barmenu to a menu set.
-(gldefun menu-set-add-barmenu (ms\:menu-set name\:symbol sym\:symbol
- menu\:barmenu
- title\:string &optional offset\:vector)
+(gldefun menu-set-add-barmenu ((ms menu-set) (name symbol) (sym symbol)
+ (menu barmenu)
+ (title string) &optional (offset vector))
(let ()
(init menu)
- (if ~ offset (offset \:= (get-box-position (window ms)
- (picture-width menu)
- (picture-height menu))))
- ((parent-offset-x menu) \:= (x offset))
- ((parent-offset-y menu) \:= (y offset))
+ (if ~ offset
+ (offset = (get-box-position (window ms)
+ (picture-width menu) (picture-height menu))))
+ ((parent-offset-x menu) = (x offset))
+ ((parent-offset-y menu) = (y offset))
(add-item ms name sym menu) ))
; 11 Oct 93
-(gldefun menu-set-name (nm\:symbol) (result symbol)
+(gldefun menu-set-name ((nm symbol)) (result symbol)
(intern (symbol-name (gensym (symbol-name nm)))) )
-; 29 Sep 92; 07 May 93
-(gldefun menu-set-named-item (ms\:menu-set name\:symbol)
+; 29 Sep 92; 07 May 93; 28 Feb 02
+(gldefun menu-set-named-item ((ms menu-set) (name symbol))
(result menu-set-item)
- (that menu-item with (menu-name (that menu-item)) = name) )
+ (that menu-item with (menu-name (that menu-item)) == name) )
; 08 Sep 92; 29 Sep 92
-(gldefun menu-set-named-menu (ms\:menu-set name\:symbol)
+(gldefun menu-set-named-menu ((ms menu-set) (name symbol))
(result menu-set-menu)
(menu (named-item ms name)))
+; 30 Jul 04
+(gldefun menu-conns-named-item ((mc menu-conns) (name symbol))
+ (result menu-set-item)
+ (named-item (menu-set mc) name) )
+
; 01 Feb 94
-(gldefun menu-conns-named-menu (mc\:menu-conns name\:symbol)
+(gldefun menu-conns-named-menu ((mc menu-conns) (name symbol))
(result menu-set-menu)
(named-menu (menu-set mc) name) )
-; 29 Apr 93; 30 Apr 93
+; 29 Apr 93; 30 Apr 93; 05 Jan 04
; Find the item at specified position, if any
-(gldefun menu-set-find-item (ms\:menu-set pos\:vector)
+(gldefun menu-set-find-item ((ms menu-set) (pos vector))
(result menu-set-item)
(let (mitem)
(for mi in (menu-items ms) do
- (if (contains? (menu mi) pos) then (mitem \:= mi)))
+ (if (contains? (menu mi) pos)
+ (mitem = mi)))
mitem))
; 29 Apr 93
; Delete an item
-(gldefun menu-set-delete-item (ms\:menu-set mi\:menu-set-item)
+(gldefun menu-set-delete-item ((ms menu-set) (mi menu-set-item))
((menu-items ms) _- mi))
; 08 Sep 92; 10 Sep 92; 05 May 93; 06 May 93; 07 May 93
-(gldefun menu-set-move (ms\:menu-set)
+(gldefun menu-set-move ((ms menu-set))
(let (sel m)
- (sel \:= (menu-set-select ms nil t))
- (m \:= (named-menu ms (menu-name sel)))
+ (sel = (menu-set-select ms nil t))
+ (m = (named-menu ms (menu-name sel)))
(menu-reposition m) ))
-; 10 Sep 92; 05 Jan 94; 06 Jan 94
+; 10 Sep 92; 05 Jan 94; 06 Jan 94; 20 Apr 95; 12 Aug 96
; Draw either a menu or picmenu
(gldefun menu-mdraw (m)
(case (first m)
(menu (menu-draw m))
(picmenu (picmenu-draw m))
(barmenu (barmenu-draw m))
+ (textmenu (textmenu-draw m))
+ (editmenu (editmenu-draw m))
(t (glsend m draw)) ) )
-; 10 Sep 92; 29 Sep 92; 05 May 93; 03 Jan 94; 06 Jan 94
+; 10 Sep 92; 29 Sep 92; 05 May 93; 03 Jan 94; 06 Jan 94; 20 Apr 95; 21 Apr 95
+; 12 Aug 96
; Select from either a menu or picmenu
(gldefun menu-mselect (m &optional anyclick)
(case (first m)
(menu (menu-select m t))
(picmenu (picmenu-select m t anyclick))
(barmenu (barmenu-select m))
+ (textmenu (textmenu-select m t))
+ (editmenu (editmenu-select m t))
(t (glsend m select)) ) )
; 10 Sep 92; 06 Jan 94
-; Get item position from either a menu or picmenu
+; Get item position from either a menu or picmenu; 20 Apr 95
(gldefun menu-mitem-position (m name loc)
(case (first m)
(menu (menu-item-position m name loc))
@@ -278,170 +298,181 @@
(t (glsend m item-position name loc)) ) )
; 05 Sep 92; 08 Sep 92
-(gldefun menu-set-draw (ms\:menu-set)
+(gldefun menu-set-draw ((ms menu-set))
(let ()
(open (window ms))
(for item in (menu-items ms) do (draw (menu item))) ))
; 08 Sep 92; 28 Sep 92; 07 May 93; 25 Jan 94
-(gldefun menu-set-item-position (ms\:menu-set desc\:menu-port
- &optional loc\:symbol)
+(gldefun menu-set-item-position ((ms menu-set) (desc menu-port)
+ &optional (loc symbol))
(result vector)
(let (m)
- (m \:= (named-menu ms (menu-name desc)))
+ (m = (named-menu ms (menu-name desc)))
(or (menu-mitem-position m (port desc) loc)
(menu-mitem-position m nil loc)) )) ; header if it cannot be found
-; 08 Sep 92
-(gldefun menu-set-draw-conn (ms\:menu-set conn\:menu-set-conn)
+; 08 Sep 92; 05 Jan 04
+(gldefun menu-set-draw-conn ((ms menu-set) (conn menu-set-conn))
(let (pa pb tmp (desca (from conn)) (descb (to conn)))
- (pa \:= (menu-set-item-position ms desca 'center))
- (pb \:= (menu-set-item-position ms descb 'center))
+ (pa = (menu-set-item-position ms desca 'center))
+ (pb = (menu-set-item-position ms descb 'center))
(if ((x pa) > (x pb))
- then (tmp \:= desca)
- (desca \:= descb)
- (descb \:= tmp))
- (pa \:= (menu-set-item-position ms desca 'right))
- (pb \:= (menu-set-item-position ms descb 'left))
+ (progn (tmp = desca)
+ (desca = descb)
+ (descb = tmp)))
+ (pa = (menu-set-item-position ms desca 'right))
+ (pb = (menu-set-item-position ms descb 'left))
(draw-circle (window ms) pa 3)
(draw-line (window ms) pa pb)
(draw-circle (window ms) pb 3)
(force-output (window ms)) ))
-; 02 Dec 93; 07 Jan 94
-(gldefun menu-set-adjust (ms\:menu-set name\:symbol edge\:symbol
- from\:symbol offset\:integer)
+; 02 Dec 93; 07 Jan 94; 05 Jan 04
+(gldefun menu-set-adjust ((ms menu-set) (name symbol) (edge symbol)
+ (from symbol) (offset integer))
(let (m fromm place)
- (if (m \:= (named-item ms name))
- then (if from
- then (fromm \:= (named-item ms from))
- (place \:= (case edge
+ (if (m = (named-item ms name))
+ (progn
+ (if from
+ (progn (fromm = (named-item ms from))
+ (place = (case edge
(top (bottom fromm))
(bottom (top fromm))
(left (right fromm))
- (right (left fromm))))
- else (place \:= (case edge
+ (right (left fromm)))))
+ (place = (case edge
(top (height (window ms)))
((bottom left) 0)
(right (width (window ms))) )) )
- (case edge (top ((bottom m) \:= place - (height m) - offset))
- (bottom ((bottom m) \:= place + offset))
- (left ((left m) \:= place + offset))
- (right ((left m) \:= place - (width m) - offset)))) ))
+ (case edge (top ((bottom m) = place - (height m) - offset))
+ (bottom ((bottom m) = place + offset))
+ (left ((left m) = place + offset))
+ (right ((left m) = place - (width m) - offset)))) ) ))
-; 12 Oct 94
-(gldefun menu-conns-create (ms\:menu-set)
+; 12 Oct 94; 28 Feb 02
+(gldefun menu-conns-create ((ms menu-set))
(a menu-conns with menu-set = ms))
; 08 Sep 92
-(gldefun menu-conns-draw (mc\:menu-conns)
+(gldefun menu-conns-draw ((mc menu-conns))
(let ()
(draw (menu-set mc))
(for c in (connections mc) (draw-conn (menu-set mc) c)) ))
; 08 Sep 92
-(gldefun menu-conns-move (mc\:menu-conns)
+(gldefun menu-conns-move ((mc menu-conns))
(let ()
(menu-set-move (menu-set mc))
(clear (window mc))
(draw mc) ))
; 29 Apr 93
-(gldefun menu-conns-redraw (mc\:menu-conns)
+(gldefun menu-conns-redraw ((mc menu-conns))
(let ()
(clear (window mc))
(draw mc) ))
-; 08 Sep 92; 07 May 93; 21 Oct 93; 05 Jan 95
-(gldefun menu-conns-add-conn (mc\:menu-conns)
+; 08 Sep 92; 07 May 93; 21 Oct 93; 05 Jan 95; 28 Feb 02; 05 Jan 04
+(gldefun menu-conns-add-conn ((mc menu-conns))
(let (sel selb conn)
- (sel \:= (select (menu-set mc)))
- (if ((menu-name sel) = 'background)
- then sel
- else (selb \:= (select (menu-set mc)))
+ (sel = (select (menu-set mc)))
+ (if ((menu-name sel) == 'background)
+ sel
+ (progn (selb = (select (menu-set mc)))
(if ((menu-name selb) <> 'background)
- then (conn \:= (a menu-set-conn with from = sel to = selb))
+ (progn (conn = (a menu-set-conn with from = sel to = selb))
(draw-conn (menu-set mc) conn)
- ((connections mc) _+ conn))
- nil) ))
+ ((connections mc) _+ conn)))
+ nil) ) ))
+
+; 02 Aug 04
+(gldefun menu-conns-new-conn ((mc menu-conns) (fromname symbol)
+ (fromport symbol) (toname symbol)
+ (toport symbol))
+ (let (conn)
+ (conn = (a menu-set-conn with
+ from = (a menu-port with menu-name = fromname port = fromport)
+ to = (a menu-port with menu-name = toname port = toport)))
+ ((connections mc) _+ conn) ))
; 30 Apr 93
(gldefun menu-conns-add-item
- (mc\:menu-conns name\:symbol sym\:symbol menu\:menu)
+ ((mc menu-conns) (name symbol) (sym symbol) (menu menu))
(add-item (menu-set mc) name sym menu))
-; 29 Apr 93
+; 29 Apr 93; 05 Jan 04
; Find the connection that is selected by the given point, if any.
-(gldefun menu-conns-find-conn (mc\:menu-conns pt\:vector)
+(gldefun menu-conns-find-conn ((mc menu-conns) (pt vector))
(result menu-set-conn)
(let (ms ls found res pa pb tmp desca descb)
- (ls \:= (a line-segment))
- (ms \:= (menu-set mc))
+ (ls = (a line-segment))
+ (ms = (menu-set mc))
(for conn in (connections mc) when (not found) do
- (desca \:= (from conn))
- (descb \:= (to conn))
- (pa \:= (menu-set-item-position ms desca 'center))
- (pb \:= (menu-set-item-position ms descb 'center))
+ (desca = (from conn))
+ (descb = (to conn))
+ (pa = (menu-set-item-position ms desca 'center))
+ (pb = (menu-set-item-position ms descb 'center))
(if ((x pa) > (x pb))
- then (tmp \:= desca)
- (desca \:= descb)
- (descb \:= tmp))
- ((p1 ls) \:= (menu-set-item-position ms desca 'right))
- ((p2 ls) \:= (menu-set-item-position ms descb 'left))
+ (progn (tmp = desca)
+ (desca = descb)
+ (descb = tmp)))
+ ((p1 ls) = (menu-set-item-position ms desca 'right))
+ ((p2 ls) = (menu-set-item-position ms descb 'left))
(if (< (distance ls pt) 5)
- then (found \:= t)
- (res \:= conn)) )
+ (progn (found = t)
+ (res = conn)) ))
res))
; 29 Apr 93; 30 Apr 93
; Find the menu item that is selected by the given point, if any.
-(gldefun menu-conns-find-item (mc\:menu-conns pt\:vector)
+(gldefun menu-conns-find-item ((mc menu-conns) (pt vector))
(result menu-set-item)
(find-item (menu-set mc) pt))
; 29 Apr 93
; Delete a connection
-(gldefun menu-conns-delete-conn (mc\:menu-conns conn\:menu-set-conn)
+(gldefun menu-conns-delete-conn ((mc menu-conns) (conn menu-set-conn))
((connections mc) _- conn))
-; 29 Apr 93; 07 May 93
+; 29 Apr 93; 07 May 93; 28 Feb 02; 05 Jan 04
; Delete a menu item and all its connections
-(gldefun menu-conns-delete-item (mc\:menu-conns mi\:menu-set-item)
+(gldefun menu-conns-delete-item ((mc menu-conns) (mi menu-set-item))
(let (ms)
- (ms \:= (menu-set mc))
+ (ms = (menu-set mc))
(delete-item ms mi)
(for conn in (connections mc) do
- (if (or ((menu-name (from conn)) = (menu-name mi))
- ((menu-name (to conn)) = (menu-name mi)))
- then (delete-conn mc conn))) ))
+ (if (or ((menu-name (from conn)) == (menu-name mi))
+ ((menu-name (to conn)) == (menu-name mi)))
+ (delete-conn mc conn))) ))
; 30 Apr 93
-(gldefun menu-conns-remove-items (mc\:menu-conns)
+(gldefun menu-conns-remove-items ((mc menu-conns))
(remove-items (menu-set mc))
- ((connections mc) \:= nil))
+ ((connections mc) = nil))
-; 30 Apr 93; 07 May 93
+; 30 Apr 93; 07 May 93; 28 Feb 02; 05 Jan 04
; find all ports of a given named menu that are connected to something
-(gldefun menu-conns-connected-ports (mc\:menu-conns boxname\:symbol)
+(gldefun menu-conns-connected-ports ((mc menu-conns) (boxname symbol))
(let (ports)
(for conn in (connections mc) do
- (if (boxname = (menu-name (to conn)))
- then (pushnew (port (to conn)) ports)
- else (if (boxname = (menu-name (from conn)))
- then (pushnew (port (from conn)) ports))))
+ (if (boxname == (menu-name (to conn)))
+ (pushnew (port (to conn)) ports)
+ (if (boxname == (menu-name (from conn)))
+ (pushnew (port (from conn)) ports))))
ports))
-; 30 Apr 93; 07 May 93
+; 30 Apr 93; 07 May 93; 28 Feb 02
; Find connections of a given port of a named box
-(gldefun menu-conns-find-conns (mc\:menu-conns boxname\:symbol port\:symbol)
+(gldefun menu-conns-find-conns ((mc menu-conns) (boxname symbol) (port symbol))
(result (listof menu-port))
(let (res)
(for conn in (connections mc) do
- (if (and (boxname = (menu-name (to conn)))
- (port = (port (to conn))))
+ (if (and (boxname == (menu-name (to conn)))
+ (port == (port (to conn))))
(res _+ (from conn)))
- (if (and (boxname = (menu-name (from conn)))
- (port = (port (from conn))))
+ (if (and (boxname == (menu-name (from conn)))
+ (port == (port (from conn))))
(res _+ (to conn))) )
res))
Index: xgcl-2/general-c.c
===================================================================
RCS file: /cvsroot/gcl/gcl/xgcl-2/general-c.c,v
retrieving revision 1.1.1.1.2.1.18.1
retrieving revision 1.1.1.1.2.1.18.2
diff -u -b -r1.1.1.1.2.1.18.1 -r1.1.1.1.2.1.18.2
--- xgcl-2/general-c.c 5 Jan 2006 17:55:35 -0000 1.1.1.1.2.1.18.1
+++ xgcl-2/general-c.c 9 Jun 2006 15:53:32 -0000 1.1.1.1.2.1.18.2
@@ -1,4 +1,4 @@
-/* general-c.c Hiep Huu Nguyen 27 Aug 92 */
+/* general-c.c Hiep Huu Nguyen 27 Aug 92; 24 Jan 06 */
/* ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin.
@@ -21,187 +21,37 @@
; Some of the files that interface to the Xlib are adapted from DEC/MIT files.
; See the file dec.copyright for details. */
+/* 24 Jan 06: edited by G. Novak to remove vertex_array functions,
+ remove includes, change function arg lists to new form */
#include <stdlib.h>
-#include <stdio.h>
-#include <X11/Xlib.h>
-#include <X11/Xutil.h>
-
-/* $Xorg: X10.h,v 1.3 2000/08/17 19:46:42 cpqbld Exp $ */
-/*
- *
-Copyright 1985, 1986, 1987, 1998 The Open Group
-
-All Rights Reserved.
-
-The above copyright notice and this permission notice shall be included in
-all copies or substantial portions of the Software.
-
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-OPEN GROUP BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN
-AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-
-Except as contained in this notice, the name of The Open Group shall not be
-used in advertising or otherwise to promote the sale, use or other dealings
-in this Software without prior written authorization from The Open Group.
- *
- * The X Window System is a Trademark of The Open Group.
- *
- */
-
-
-/*
- * X10.h - Header definition and support file for the C subroutine
- * interface library for V10 support routines.
- */
-#ifndef _X10_H_
-#define _X10_H_
-
-/* Used in XDraw and XDrawFilled */
-
-typedef struct {
- short x, y;
- unsigned short flags;
-} Vertex;
-
-/* The meanings of the flag bits. If the bit is 1 the predicate is true */
-
-#define VertexRelative 0x0001 /* else absolute */
-#define VertexDontDraw 0x0002 /* else draw */
-#define VertexCurved 0x0004 /* else straight */
-#define VertexStartClosed 0x0008 /* else not */
-#define VertexEndClosed 0x0010 /* else not */
-/*#define VertexDrawLastPoint 0x0020 */ /* else don't */
-
-/*
-The VertexDrawLastPoint option has not been implemented in XDraw and
-XDrawFilled so it shouldn't be defined.
-*/
-
-/*
- * XAssoc - Associations used in the XAssocTable data structure. The
- * associations are used as circular queue entries in the association table
- * which is contains an array of circular queues (buckets).
- */
-typedef struct _XAssoc {
- struct _XAssoc *next; /* Next object in this bucket. */
- struct _XAssoc *prev; /* Previous obejct in this bucket. */
- Display *display; /* Display which ownes the id. */
- XID x_id; /* X Window System id. */
- char *data; /* Pointer to untyped memory. */
-} XAssoc;
-
-/*
- * XAssocTable - X Window System id to data structure pointer association
- * table. An XAssocTable is a hash table whose buckets are circular
- * queues of XAssoc's. The XAssocTable is constructed from an array of
- * XAssoc's which are the circular queue headers (bucket headers).
- * An XAssocTable consists an XAssoc pointer that points to the first
- * bucket in the bucket array and an integer that indicates the number
- * of buckets in the array.
- */
-typedef struct {
- XAssoc *buckets; /* Pointer to first bucket in bucket array.*/
- int size; /* Table size (number of buckets). */
-} XAssocTable;
-
-XAssocTable *XCreateAssocTable();
-char *XLookUpAssoc();
-#endif /* _X10_H_ */
-/* #include <X11/X10.h> */
-
-
-int char_array(size)
-int size;
+int char_array(int size)
{
return ((int) calloc (size, sizeof(char)));
}
-char char_pos (array, pos)
-char* array;
-int pos;
+char char_pos (char* array, int pos)
{
return (array[pos]);
}
-
-int int_array(size)
-int size;
-{
- return ((int) calloc (size, sizeof(int)));
-}
-
-
-
-int int_pos (array, pos)
-int* array;
-int pos;
-{
- return (array[pos]);
-}
-
-
-void set_char_array (array, pos, val)
-char* array;
-int pos;
-char val;
-{
-array[pos] = val;
-}
-
-void set_int_array (array, pos, val)
-int* array;
-int pos;
-int val;
+void set_char_array (char* array, int pos, char val)
{
array[pos] = val;
}
-
-
-
-int vertex_array (size)
-int size;
+int int_array(int size)
{
- return ((int) calloc (size, sizeof(Vertex)));
-
-}
-
-int vertex_pos_x (array, pos)
-Vertex* array;
-int pos;
-{
- return ((int) array[pos].x);
+ return ((int) calloc (size, sizeof(int)));
}
-int vertex_pos_y (array, pos)
-Vertex* array;
-int pos;
+int int_pos (int* array, int pos)
{
- return ((int) array[pos].y);
+ return (array[pos]);
}
-int vertex_pos_flag (array, pos)
-Vertex* array;
-int pos;
+void set_int_array (int* array, int pos, int val)
{
- return ((int) array[pos].flags);
+array[pos] = val;
}
-
-
-
-void set_vertex_array (array, pos, x, y, flag)
-Vertex* array;
-int pos;
-int x, y;
-int flag;
-{
- array[pos].x = x;
- array[pos].y = y;
- array[pos].flags = flag;
-
-}
Index: xgcl-2/makefile
===================================================================
RCS file: /cvsroot/gcl/gcl/xgcl-2/makefile,v
retrieving revision 1.3.2.1
retrieving revision 1.3.2.1.18.1
diff -u -b -r1.3.2.1 -r1.3.2.1.18.1
--- xgcl-2/makefile 20 Mar 2003 15:22:55 -0000 1.3.2.1
+++ xgcl-2/makefile 9 Jun 2006 15:53:32 -0000 1.3.2.1.18.1
@@ -1,76 +1,21 @@
-############ BEGIN Things you may have to change ##########
-
-include ../makedefs
-# The main gcl source directory. Expects to find $(GCLDIR)/o/*.o etc.
-# and it will put saved_xgcl in $(GCLDIR)/unixport/saved_xgcl
-#GCLDIR = /fix/t2/camm/b/gcl
-
-# The current directory:
-SYSDIR = $(GCLDIR)/xgcl-2
-# way to get xlibraries:
-#X_LIBS = -L/usr/X11R6/lib -lXaw -lXmu -lXt -lXext -lX11
-# for RS6000 at UT:
-#X_LIBS = -L/usr/local/X11R5/lib -lXaw -lXmu -lXt -lXext -lX11
-
-# for Sun's at UT use -I/usr/local/X11R5/include
-IFLAGS = -I../h -I../o $(X_CFLAGS)
-
-############ END Things you may have to change ###############
-
-SYSTEM=xgcl
-
-# How to invoke gcl
-LISP = $(PORTDIR)/saved_gcl $(PORTDIR)/
-
-SRC = .
-PORTDIR =$(GCLDIR)/unixport
-
-CFLAGS += $(IFLAGS)
-
-C_OBJS=$(SYSDIR)/Xutil-2.o $(SYSDIR)/Events.o $(SYSDIR)/XStruct-2.o \
- $(SYSDIR)/XStruct-4.o $(SYSDIR)/general-c.o
-
-all: $(PORTDIR)/saved_$(SYSTEM) Xgcl
-
-maxobjs: $(shell echo *.lsp) $(PORTDIR)/saved_gcl
- echo '(load "sysdef.lisp")(setq si::*multiply-stacks* 2)'\
- '(xlib::compile-xgcl)' | $(LISP)
-
-$(PORTDIR)/saved_$(SYSTEM): $(C_OBJS) maxobjs
- (cd $(PORTDIR) ; $(MAKE) saved_xgcl "INIT_SYSTEM_LSP=init_gcl.lsp"
"SYSTEM=$(SYSTEM)" "SYSTEM_OBJS=`cat $(SYSDIR)/maxobjs` $(C_OBJS) "
"EXTRA_LD_LIBS= $(X_LIBS) " "PORTDIR=$(PORTDIR)")
- rm -f $(PORTDIR)/raw_$(SYSTEM)
-
-Xgcl:
- echo $(PORTDIR)/saved_$(SYSTEM) $(PORTDIR)/ > Xgcl
- chmod a+x Xgcl
-
-############ the C code ###############
-
-cmpinclude.h: ../h/cmpinclude.h
- ln -snf $< $@
-
-$(SYSDIR)/Xutil-2.o: cmpinclude.h $(SYSDIR)/Xutil-2.c
- $(CC) -c Xutil-2.c $(CFLAGS)
-
-$(SYSDIR)/Events.o: cmpinclude.h $(SYSDIR)/Events.c
- $(CC) -c Events.c $(CFLAGS)
-
-$(SYSDIR)/XStruct-2.o: cmpinclude.h $(SYSDIR)/XStruct-2.c
- $(CC) -c XStruct-2.c $(CFLAGS)
-
-$(SYSDIR)/XStruct-4.o: cmpinclude.h $(SYSDIR)/XStruct-4.c
- $(CC) -c XStruct-4.c $(CFLAGS)
+all: dwdoc/index.html dwdoc.pdf
-general-c.o: cmpinclude.h general-c.c
- $(CC) -c general-c.c $(CFLAGS)
+dwdoc.pdf: dwdoc.tex
+ pdflatex $<
-tar:
- $(MAKE) tar1 TARD=xgcl-`cat version`
+dwdoc/index.html: dwdoc.tex
+ latex2html $<
-tar1:
- (cd .. ; tar cvf - $(TARD)/*.lsp $(TARD)/*.lisp $(TARD)/*.c
$(TARD)/*.paper $(TARD)/README $(TARD)/makefile $(TARD)/version | gzip -c >
$(TARD).tgz)
+saved_%: $(LISP)
+ echo '(load "sysdef.lisp")(xlib::compile-xgcl)(xlib::save-xgcl "$@")' |
$(LISP)
clean:
- rm -f *.o *.data Xgcl maxobjs $(PORTDIR)/saved_$(SYSTEM) cmpinclude.h
+ rm -f *.o *.data saved_* cmpinclude.h dwdoc.pdf dwdoc.aux dwdoc.log
+ rm -rf dwdoc
+install: all
+ -mkdir -p $(DESTDIR)$(INFO_DIR)../doc
+ -cp -r dwdoc $(DESTDIR)$(INFO_DIR)../doc
+ -cp *tex *.pdf $(DESTDIR)$(INFO_DIR)../doc
Index: xgcl-2/sysdef.lisp
===================================================================
RCS file: /cvsroot/gcl/gcl/xgcl-2/sysdef.lisp,v
retrieving revision 1.1.1.1.2.1.18.1
retrieving revision 1.1.1.1.2.1.18.2
diff -u -b -r1.1.1.1.2.1.18.1 -r1.1.1.1.2.1.18.2
--- xgcl-2/sysdef.lisp 5 Jan 2006 17:55:35 -0000 1.1.1.1.2.1.18.1
+++ xgcl-2/sysdef.lisp 9 Jun 2006 15:53:32 -0000 1.1.1.1.2.1.18.2
@@ -35,19 +35,30 @@
"gcl_X10"
"gcl_Xinit"
"gcl_dwtrans"
- "gcl_sysinit"
+; "gcl_sysinit"
))
(defun compile-xgcl()
- (mapcar #'(lambda (x)
- (compile-file (format nil "~a.lsp" x) :system-p t)) *files*)
- )
+ (mapc (lambda (x)
+ (let ((x (concatenate 'string compiler::*cc* "-I../h " (namestring
x))))
+ (unless (zerop (system x))
+ (error "compile failure: ~s~%" x))))
+ (directory "*.c"))
+ (mapc (lambda (x)
+ (compile-file (format nil "~a.lsp" x) :system-p t)) *files*))
(defun load-xgcl()
- (mapcar #'(lambda (x) (load (format nil "~a.o" x))) *files*))
+ (mapcar (lambda (x) (load (format nil "~a.o" x))) *files*))
+(defun save-xgcl (pn)
+ (let* ((x (mapcar (lambda (x) (probe-file (concatenate 'string x ".o")))
*files*))
+ (y (directory "*.o"))
+ (z (set-difference y x :test 'equal)))
+ (compiler::link x (namestring pn) (format nil "(load ~s)(mapc 'load '~s)"
"sysdef.lisp" x)
+ (reduce (lambda (&rest xy) (when xy (concatenate 'string
(namestring (car xy)) " " (cadr xy)))) z
+ :initial-value " -lXmu -lXt -lXext -lXaw6 -lX11"
:from-end t) nil)))
Index: debian/in.gcl-doc.doc-base.xgcl
===================================================================
RCS file: debian/in.gcl-doc.doc-base.xgcl
diff -N debian/in.gcl-doc.doc-base.xgcl
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ debian/in.gcl-doc.doc-base.xgcl 9 Jun 2006 15:53:31 -0000 1.1.2.1
@@ -0,0 +1,15 @@
+Document: address@hidden@-si-doc
+Title: GNU Common Lisp Documentation -- System Internals
+Author: W. Schelter
+Abstract: Documentation on GCL-specific Lisp system functions
+Section: Apps/Programming
+
+Format: TEX
+Files: /usr/share/doc/address@hidden@-doc/dwdoc.tex
+
+Format: PDF
+Files: /usr/share/doc/address@hidden@-doc/dwdoc.pdf
+
+Format: HTML
+Index: /usr/share/doc/address@hidden@-doc/dwdoc/index.html
+Files: /usr/share/doc/address@hidden@-doc/dwdoc/*.html
Index: xgcl-2/gcl_dwexports.lsp
===================================================================
RCS file: xgcl-2/gcl_dwexports.lsp
diff -N xgcl-2/gcl_dwexports.lsp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ xgcl-2/gcl_dwexports.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.1
@@ -0,0 +1,153 @@
+; dwexports.lsp Gordon S. Novak Jr. 26 Jan 2006
+
+
+(setf (get 'xlib::int-pos 'user::glfnresulttype) 'lisp::integer)
+
+(in-package :xlib)
+
+; exported symbols: from dwimports.lsp
+(dolist (x '( menu stringify window picmenu textmenu editmenu barmenu
+ window-get-mouse-position window-create window-set-font
+ window-font-info window-gcontext window-parent
+ window-drawable-height window-drawable-width window-label
+ window-font window-foreground window-set-foreground
+ window-background window-set-background window-wfunction
+ window-get-geometry window-get-geometry-b window-sync
+ window-screen-height window-geometry window-size
+ window-left window-top-neg-y window-reset-geometry
+ window-force-output window-query-pointer window-set-xor
+ window-unset window-reset window-set-erase
+ window-set-copy window-set-invert window-set-line-width
+ window-set-line-attr window-std-line-attr window-draw-line
+ window-draw-line-xy window-draw-arrowhead-xy
+ window-draw-arrow-xy window-draw-arrow2-xy window-draw-box
+ window-draw-box-xy window-xor-box-xy window-draw-box-corners
+ window-draw-rcbox-xy window-draw-arc-xy
+ window-draw-circle-xy window-draw-circle window-erase-area
+ window-erase-area-xy window-erase-box-xy
+ window-draw-ellipse-xy window-copy-area-xy window-invertarea
+ window-invert-area window-invert-area-xy
+ window-prettyprintat window-prettyprintat-xy window-printat
+ window-printat-xy window-string-width window-string-height
+ window-string-extents window-font-string-width
+ window-yposition window-centeroffset dowindowcom
+ window-menu window-close window-unmap window-open
+ window-map window-destroy window-destroy-selected-window
+ window-clear window-moveto-xy window-paint
+ window-move window-draw-border window-track-mouse
+ window-wait-exposure window-wait-unmap
+ window-init-mouse-poll window-poll-mouse menu-init
+ menu-calculate-size menu-adjust-offset menu-draw
+ menu-item-value menu-find-item-width menu-find-item-height
+ menu-clear menu-display-item menu-choose menu-box-item
+ menu-unbox-item menu-item-position menu-select
+ menu-select! menu-select-b menu-destroy
+ menu-create menu-offset menu-size menu-moveto-xy
+ menu-reposition picmenu-create picmenu-create-spec
+ picmenu-create-from-spec picmenu-calculate-size picmenu-init
+ picmenu-draw picmenu-draw-button picmenu-delete-named-button
+ picmenu-select picmenu-box-item picmenu-unbox-item
+ picmenu-destroy picmenu-button-containsxy?
+ picmenu-item-position barmenu-create
+ barmenu-calculate-size barmenu-init barmenu-draw
+ barmenu-select barmenu-update-value window-get-point
+ window-get-click window-get-line-position
+ window-get-latex-position window-get-box-position
+ window-get-icon-position window-get-region
+ window-get-box-size window-track-mouse-in-region
+ window-adjust-box-side window-adj-box-xy window-get-circle
+ window-circle-radius window-draw-circle-pt
+ window-get-ellipse window-draw-ellipse-pt
+ window-draw-vector-pt window-get-vector-end
+ window-get-crosshairs window-draw-crosshairs-xy
+ window-get-cross window-draw-cross-xy window-draw-dot-xy
+ window-draw-latex-xy window-reset-color
+ window-set-color-rgb window-set-xcolor window-set-color
+ window-set-color window-free-color window-get-chars
+ window-process-char-event window-input-string
+ window-input-char-fn window-draw-carat window-init-keymap
+ window-set-cursor window-positive-y window-code-char
+ window-get-raw-char
+ window-print-line window-print-lines textmenu-create
+ textmenu-calculate-size textmenu-init textmenu-draw
+ textmenu-select textmenu-set-text textmenu
+ editmenu editmenu-create editmenu-calculate-size
+ editmenu-init editmenu-draw editmenu-display
+ window-edit
+ window-edit-display editmenu-carat editmenu-erase
+ window-edit-erase editmenu-select editmenu-edit-fn
+ window-edit-fn editmenu-setxy editmenu-char
+ editmenu-edit
+ *window-editmenu-kill-strings*
+*window-add-menu-title*
+*window-menu*
+*mouse-x*
+*mouse-y*
+*mouse-window*
+*window-fonts*
+*window-display*
+*window-screen*
+*root-window*
+*black-pixel*
+*white-pixel*
+*default-fg-color*
+*default-bg-color*
+*default-size-hints*
+*default-GC*
+*default-colormap*
+*window-event*
+*window-default-pos-x*
+*window-default-pos-y*
+*window-default-border*
+*window-default-font-name*
+*window-default-cursor*
+*window-save-foreground*
+*window-save-function*
+*window-attributes*
+*window-attr*
+*menu-title-pad*
+*root-return*
+*child-return*
+*root-x-return*
+*root-y-return*
+*win-x-return*
+*win-y-return*
+*mask-return*
+*x-return*
+*y-return*
+*width-return*
+*height-return*
+*depth-return*
+*border-width-return*
+*text-width-return*
+*direction-return*
+*ascent-return*
+*descent-return*
+*overall-return*
+*GC-Values*
+*window-xcolor*
+*window-menu-code*
+
+*window-keymap*
+*window-shiftkeymap*
+*window-keyinit*
+*window-meta*
+*window-ctrl*
+*window-shift*
+*window-string*
+*window-string-count*
+*window-string-max*
+*window-input-string-x*
+*window-input-string-y*
+*window-input-string-charwidth*
+
+*window-shift-keys*
+*window-control-keys*
+*window-meta-keys*
+*barmenu-update-value-cons*
+*picmenu-no-selection*
+*min-keycodes-return*
+*max-keycodes-return*
+*keycodes-return*
+ ))
+ (export x)) ; export the above symbols
Index: xgcl-2/gcl_dwimportsb.lsp
===================================================================
RCS file: xgcl-2/gcl_dwimportsb.lsp
diff -N xgcl-2/gcl_dwimportsb.lsp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ xgcl-2/gcl_dwimportsb.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.1
@@ -0,0 +1,80 @@
+; dwimportsb.lsp Gordon S. Novak Jr. 24 Jan 06
+
+; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin.
+
+; See the file gnu.license .
+
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 1, or (at your option)
+; any later version.
+
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+; This file imports symbols from the dwindow.lsp file (in XLIB: package)
+; to the current package (such as the :USER package).
+; This will allow the dwindow.lsp functions to be called by just their
+; names and without any package qualifier.
+
+; This file should be loaded immediately after starting Lisp:
+; If Lisp has seen any of these symbols, loading this file will cause an error.
+
+(dolist (x '(
+ xlib::window xlib::picmenu xlib::picmenu-spec
+ xlib::picmenu-button xlib::barmenu xlib::rgb xlib::stringify
+ xlib::menu-window xlib::flat xlib::parent-window xlib::parent-offset-x
+ xlib::parent-offset-y xlib::picture-width xlib::picture-height
+ xlib::title xlib::permanent xlib::menu-font xlib::item-width xlib::item-height
+ xlib::items xlib::menuw xlib::title-present xlib::width xlib::height
+ xlib::base-x xlib::base-y xlib::offset xlib::size xlib::region xlib::voffset
+ xlib::vsize xlib::init xlib::init? xlib::contains? xlib::create xlib::clear
+ xlib::select xlib::select! xlib::choose xlib::draw xlib::destroy
+ xlib::moveto-xy xlib::reposition xlib::box-item xlib::unbox-item
+ xlib::display-item xlib::item-value xlib::item-position xlib::find-item-width
+ xlib::find-item-height xlib::adjust-offset xlib::calculate-size
+ xlib::menu-x xlib::menu-y xlib::spec xlib::boxflg xlib::deleted-buttons
+ xlib::draw-button xlib::delete-named-button xlib::drawing-width
+ xlib::drawing-height xlib::buttons xlib::dotflg xlib::drawfn xlib::menu-font
+ xlib::buttonname xlib::offset xlib::size xlib::highlightfn
+ xlib::unhighlightfn
+ xlib::containsxy? xlib::color xlib::value xlib::maxval xlib::barwidth
+ xlib::horizontal xlib::subtrackfn xlib::subtrackparms xlib::update-value
+ xlib::gcontext xlib::parent xlib::drawable-height xlib::drawable-width
+ xlib::label xlib::font xlib::width xlib::height xlib::left xlib::right
+ xlib::top-neg-y xlib::leftmargin xlib::rightmargin xlib::yposition
+ xlib::wfunction xlib::foreground xlib::background xlib::force-output
+ xlib::set-font xlib::set-foreground xlib::set-background xlib::set-cursor
+ xlib::set-erase xlib::set-xor xlib::set-invert xlib::set-copy
+ xlib::set-line-width xlib::set-line-attr xlib::std-line-attr xlib::unset
+ xlib::reset xlib::sync xlib::geometry xlib::size xlib::get-geometry
+ xlib::reset-geometry xlib::query-pointer xlib::wait-exposure xlib::wait-unmap
+ xlib::clear xlib::mapw xlib::unmap xlib::open xlib::close xlib::destroy
+ xlib::positive-y xlib::drawline xlib::draw-line xlib::draw-line-xy
+ xlib::draw-latex-xy xlib::draw-arrow-xy xlib::draw-arrow2-xy
+ xlib::draw-arrowhead-xy xlib::draw-box xlib::draw-box-xy
+ xlib::draw-box-corners xlib::draw-rcbox-xy xlib::xor-box-xy xlib::draw-circle
+ xlib::draw-circle-xy xlib::draw-ellipse-xy xlib::draw-arc-xy xlib::invertarea
+ xlib::invert-area xlib::invert-area-xy xlib::copy-area-xy xlib::printat
+ xlib::printat-xy xlib::prettyprintat-xy xlib::prettyprintat xlib::string-width
+ xlib::string-extents xlib::erase-area xlib::erase-area-xy xlib::erase-box-xy
+ xlib::moveto-xy xlib::move xlib::paint xlib::centeroffset xlib::draw-border
+ xlib::track-mouse xlib::track-mouse-in-region xlib::init-mouse-poll
+ xlib::poll-mouse xlib::get-point xlib::get-click xlib::get-line-position
+ xlib::get-latex-position xlib::get-icon-position xlib::get-box-position
+ xlib::get-box-size xlib::get-region xlib::adjust-box-side
+ xlib::get-mouse-position xlib::get-circle xlib::get-ellipse
+ xlib::get-crosshairs xlib::draw-crosshairs-xy xlib::get-cross
+ xlib::draw-cross-xy xlib::draw-dot-xy xlib::draw-vector-pt
+ xlib::get-vector-end xlib::reset-color xlib::set-color-rgb xlib::set-color
+ xlib::set-xcolor xlib::free-color xlib::get-chars xlib::input-string
+ xlib::courier-bold-12 xlib::8x10 xlib::9x15 xlib::center xlib::top
+ xlib::bottom xlib::xor xlib::erase xlib::display-size xlib::copy
+ )) (import x) )
+
\ No newline at end of file
Index: xgcl-2/gcl_dwtestcases.lsp
===================================================================
RCS file: xgcl-2/gcl_dwtestcases.lsp
diff -N xgcl-2/gcl_dwtestcases.lsp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ xgcl-2/gcl_dwtestcases.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.1
@@ -0,0 +1,32 @@
+(load "/stage/ftp/pub/novak/xgcl-4/gcl_dwtrans.lsp")
+(use-package 'xlib)
+(load "/stage/ftp/pub/novak/xgcl-4/gcl_drawtrans.lsp")
+(load "/stage/ftp/pub/novak/xgcl-4/gcl_editorstrans.lsp")
+(load "/stage/ftp/pub/novak/xgcl-4/gcl_lispservertrans.lsp")
+(load "/stage/ftp/pub/novak/xgcl-4/gcl_menu-settrans.lsp")
+(load "/stage/ftp/pub/novak/xgcl-4/gcl_dwtest.lsp")
+(load "/stage/ftp/pub/novak/xgcl-4/gcl_draw-gates.lsp")
+
+(wtesta)
+(wtestb)
+(wtestc)
+(wtestd)
+(wteste)
+(wtestf)
+(wtestg)
+(wtesth)
+(wtesti)
+(wtestj)
+(wtestk)
+
+(window-clear myw)
+(edit-color myw)
+
+(lisp-server)
+
+(draw 'foo)
+
+(window-draw-box-xy myw 48 48 204 204)
+(window-edit myw 50 50 200 200 '("Now is the time" "for all" "good"))
+
+(draw-nand myw 50 50)
Index: xgcl-2/gcl_editors.lsp
===================================================================
RCS file: xgcl-2/gcl_editors.lsp
diff -N xgcl-2/gcl_editors.lsp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ xgcl-2/gcl_editors.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.1
@@ -0,0 +1,458 @@
+; editors.lsp Gordon S. Novak Jr. ; 26 Jan 06
+
+; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin.
+
+; 13 Apr 95; 02 Jan 97; 28 Feb 02; 08 Jan 04; 03 Mar 04
+
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 2 of the License, or
+; (at your option) any later version.
+
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+; Graphical editor functions
+
+; (edit-thermom 75 myw 20 20 150 250)
+; (window-draw-thermometer myw 0 20 5 50 50 50 232)
+; (window-adjust-thermometer myw 0 20 5 50 50 50 232)
+
+; 20 Nov 91; 03 Dec 91; 27 Dec 91; 26 Dec 93; 28 Feb 02; 08 Jan 04
+; Edit an integer with a thermometer-like display
+(gldefun edit-thermom ((num number) (w window)
+ &optional (offsetx integer) (offsety integer)
+ (sizex integer) (sizey integer))
+ (prog (nmin ndel ndiv range pten drange pair neww (res num) off)
+ (if ~ sizex (progn (sizex = 150) (sizey = 250)))
+ (if ~ offsetx
+ (progn (off = (centeroffset w (a vector with x = sizex y = sizey)))
+ (offsetx = (x off))
+ (offsety = (y off))))
+ (neww = (window-create sizex sizey nil (parent w) offsetx offsety))
+ (window-draw-button neww "Typein" 80 20 50 25)
+ (window-draw-button neww "Adjust" 80 70 50 25)
+ (window-draw-button neww "Done" 80 120 50 25)
+ rn (range = (abs res) * 2)
+ (if (range == 0) (range = 50))
+ (if ((range < 8) and (integerp num)) (range = 10))
+ (pten = (expt 10 (truncate (log range 10))))
+ (drange = (range * 10) / pten)
+ (setq pair (car (some #'(lambda (x) (> (car x) drange))
+ '((14 2) (20 4) (40 5) (70 10) (101 20)))))
+ (setq ndel ((cadr pair) * pten / 10))
+ (setq ndiv (ceiling (range / ndel)))
+ (setq nmin (if (>= res 0)
+ 0
+ (- ndel * ndiv)))
+ (window-draw-thermometer neww nmin ndel ndiv res 10 10 (sizey - 20))
+ lp (case (button-select neww '((done (84 124) (42 17))
+ (adjust (84 74) (42 17))
+ (typein (84 24) (42 17))))
+ (done (destroy neww) (return res))
+ (adjust (setq res (window-adjust-thermometer neww nmin ndel ndiv res
+ 10 10 (sizey - 20)))
+ (go lp))
+ (typein (princ "Enter new value: ")
+ (setq res (read))
+ (if ((res >= nmin) and (res <= (nmin + ndel * ndiv)))
+ (progn (window-set-thermometer neww nmin ndel ndiv res
+ 10 10 (sizey - 20))
+ (go lp))
+ (go rn)) ) ) ))
+
+; 20 Nov 91; 04 Dec 91
+; Draw a button-like icon
+(gldefun window-draw-button ((w window) (s string)
+ (offsetx integer) (offsety integer)
+ (sizex integer) (sizey integer))
+ (let (sw)
+ (erase-area-xy w offsetx offsety sizex sizey 8)
+ (draw-rcbox-xy w offsetx offsety sizex sizey 8)
+ (sw = (string-width w s))
+ (printat-xy w s (offsetx + (sizex - sw) / 2) (offsety + 8))
+ (force-output w)))
+
+; 17 Dec 91
+; Print in the center of a specified region
+(gldefun window-center-print ((w window) (s string)
+ (offsetx integer) (offsety integer)
+ (sizex integer) (sizey integer))
+ (let (sw)
+ (erase-area-xy w offsetx offsety sizex sizey 8)
+ (sw = (string-width w s))
+ (printat-xy w s (offsetx + (sizex - sw) / 2)
+ (offsety + (sizey - 10) / 2) )
+ (force-output w)))
+
+; 20 Nov 91; 03 Dec 91; 26 Dec 93
+; Draw a thermometer-like icon
+(gldefun window-draw-thermometer ((w window) (nmin integer) (ndel integer)
+ (ndiv integer) (val number)
+ (offsetx integer) (offsety integer)
+ (sizey integer))
+ (let (hdel marky)
+ (erase-area-xy w offsetx offsety 66 sizey)
+ (editors-print-in-box val w offsetx offsety 40 20)
+ (draw-arc-xy w (offsetx + 12) (offsety + 36) 12 12 132 276)
+ (draw-line-xy w (offsetx + 4) (offsety + 44)
+ (offsetx + 4) (offsety + sizey - 8) )
+ (draw-line-xy w (offsetx + 20) (offsety + 44)
+ (offsetx + 20) (offsety + sizey - 8) )
+ (draw-arc-xy w (offsetx + 12) (offsety + sizey - 8) 8 8 0 180)
+ (draw-circle-xy w (offsetx + 12) (offsety + 36) 4 7)
+ (hdel = (sizey - 56) / ndiv)
+ (draw-line-xy w (offsetx + 12) (offsety + 35)
+ (offsetx + 12)
+ (offsety + 48 + hdel * ((val - nmin) / ndel)) 7)
+ (dotimes (i (1+ ndiv))
+ (marky = (offsety + 48 + i * hdel))
+ (draw-line-xy w (offsetx + 24) marky (offsetx + 34) marky)
+ (printat-xy w (nmin + i * ndel) (offsetx + 36) (marky - 6)) )
+ (force-output w)))
+
+
+; 20 Nov 91; 03 Dec 91; 13 Apr 95
+; Draw value for a thermometer-like icon
+(gldefun window-set-thermometer ((w window) (nmin integer) (ndel integer)
+ (ndiv integer) (val number)
+ (offsetx integer) (offsety integer)
+ (sizey integer))
+ (let (hdel)
+ (hdel = (sizey - 56) / ndiv)
+ (erase-area-xy w (offsetx + 7) (offsety + 48)
+ 10 (sizey - 56))
+ (draw-line-xy w (offsetx + 12) (offsety + 35)
+ (offsetx + 12)
+ (offsety + 48 + hdel * ((val - nmin) / ndel)) 7)
+ (editors-update-in-box val w offsetx offsety 40 20))))
+
+
+; 20 Nov 91; 03 Dec 91; 15 Oct 93; 02 Dec 93; 08 Jan 04
+; Adjust a thermometer-like icon with the mouse. Returns new value.
+(gldefun window-adjust-thermometer ((w window) (nmin integer) (ndel integer)
+ (ndiv integer) (val number)
+ (offsetx integer) (offsety
integer)
+ (sizey integer))
+ (let (hdel (lasty integer) xmin xmax ymin ymax inside (newval number))
+ (hdel = (sizey - 56) / ndiv)
+ (lasty = (truncate (offsety + 48 + hdel * ((val - nmin) / ndel))))
+ (xmin = offsetx + 4)
+ (xmax = offsetx + 20)
+ (ymin = offsety + 48)
+ (ymax = offsety + sizey - 8)
+ (window-track-mouse w
+ #'(lambda (x y code)
+ (inside = (and (>= x xmin) (<= x xmax)
+ (>= y ymin) (<= y ymax)))
+ (when (and inside (/= y lasty))
+ (if (> y lasty)
+ (draw-line-xy w (offsetx + 12) lasty (offsetx + 12) y 7)
+ (erase-area-xy w (offsetx + 7) (y + 1)
+ 10 (- lasty y)))
+ (lasty = y)
+ (newval = ( ( (lasty - (offsety + 48))
+ / (float hdel)) * ndel) + nmin)
+ (if (integerp val) (newval = (truncate newval)))
+ (editors-update-in-box newval w offsetx offsety 40 20))
+ (not (zerop code))))
+ (if inside
+ newval
+ val) ))
+
+; 20 Nov 91; 15 Oct 93; 08 Jan 04; 26 Jan 06
+; Get a mouse selection from a button area. cf. picmenu-select
+(gldefun button-select ((mw window) (buttons (listof picmenu-button)))
+ (let ((current-button picmenu-button) item items (val picmenu-button)
+ xzero yzero inside)
+ (xzero = 0) ; (menu-x m 0)
+ (yzero = 0) ; (menu-y m 0)
+ (track-mouse mw
+ #'(lambda (x y code)
+ (x = (x - xzero))
+ (y = (y - yzero))
+ (if ((x >= 0) and (y >= 0))
+ (inside = t))
+ (if current-button
+ (if ~ (button-containsxy? current-button x y)
+ (progn (button-invert mw current-button)
+ (current-button = nil))))
+ (if ~ current-button
+ (progn (items = buttons)
+ (while ~ current-button and (item -_ items) do
+ (if (button-containsxy? item x y)
+ (progn (current-button = item)
+ (button-invert mw current-button) )))))
+ (if (> code 0)
+ (progn (if current-button
+ (button-invert mw current-button) )
+ (val = (or current-button *picmenu-no-selection*)) )))
+ t)
+ (if (val <> *picmenu-no-selection*) (buttonname val)) ))
+
+; 03 Dec 91
+(gldefun button-invert ((w window) (button picmenu-button))
+ (window-invert-area w (offset button) (size button)) )
+
+(gldefun window-undraw-box ((w window) offset size &optional lw)
+ (set-erase w)
+ (window-draw-box w offset size lw)
+ (unset w) )
+
+; 20 Nov 91; 08 Jan 04
+(gldefun button-containsxy? ((b picmenu-button) (x integer) (y integer))
+ (let ((xsize 6) (ysize 6))
+ (if (size b)
+ (progn (xsize = (x (size b)))
+ (ysize = (y (size b)))))
+ ((x >= (x (offset b))) and (x <= ((x (offset b)) + xsize)) and
+ (y >= (y (offset b))) and (y <= ((y (offset b)) + ysize)) ) ))
+
+
+(glispobjects
+
+(menu-item (z anything)
+ prop ((value ((if z is atomic
+ z
+ (cdr z)))) )
+ msg ((print-size menu-item-print-size)
+ (draw menu-item-draw)) )
+
+) ; glispobjects
+
+(gldefun menu-item-print-size ((item menu-item) (w window))
+ (result vector)
+ (let (siz)
+ (if item is atomic
+ (a vector with x = (string-width w item) y = 11)
+ (if (car item) is a string
+ (a vector with x = (string-width w (car item)) y = 11)
+ (if ((symbolp (car item))
+ and (siz = (get (car item) 'display-size)))
+ siz
+ (a vector with x = 50 y = 11)))) ))
+
+; 17 Dec 91; 08 Jan 04
+(gldefun menu-item-draw ((item menu-item) (w window)
+ (offsetx integer) (offsety integer)
+ (sizex integer) (sizey integer))
+ (if item is atomic
+ (window-center-print w item offsetx offsety sizex sizey)
+ (if ((symbolp (car item)) and (fboundp (car item)))
+ (funcall (car item) w offsetx offsety)
+ (window-center-print w (car item) offsetx offsety
+ sizex sizey))) )
+
+; 03 Dec 91; 26 Dec 93; 08 Jan 04
+(gldefun pick-one-size ((items (listof menu-item)) (w window))
+ (let (wid)
+ (for item in items do
+ (wid = (if wid
+ (max wid (x (print-size item w)))
+ (x (print-size item w))) ) )
+ (a vector with x = wid y = 11) ))
+
+; 03 Dec 91; 26 Dec 93; 29 Jul 94; 28 Feb 02
+(gldefun draw-pick-one ((items (listof menu-item)) (val anything) (w window)
+ &optional (offsetx integer) (offsety integer)
+ (sizex integer) (sizey integer))
+ (let (itm)
+ (if (itm = (that item with (value (that item)) == val))
+ (draw itm w offsetx offsety sizex sizey))))
+
+; 04 Dec 91; 26 Dec 93; 29 Jul 94; 08 Jan 04
+(gldefun edit-pick-one ((items (listof menu-item)) (val anything) (w window)
+ &optional (offsetx integer) (offsety integer)
+ (sizex integer) (sizey integer))
+ (let (newval)
+ (if ((length items) <= 3)
+ (if (equal val (value (first items)))
+ (newval = (value (second items)))
+ (if (equal val (value (second items)))
+ (newval = (if (third items)
+ (value (third items))
+ (value (first items))))
+ (newval = (value (first items)))))
+ (newval = (menu items)) )
+ (draw-pick-one newval w items offsetx offsety sizex sizey)
+ newval ))
+
+
+; 13 Dec 91; 26 Dec 93; 28 Jul 94; 28 Feb 02; 08 Jan 04
+(gldefun draw-black-white ((items (listof menu-item)) (val anything) (w window)
+ &optional (offsetx integer) (offsety integer)
+ (sizex integer) (sizey integer))
+ (let (itm)
+ (erase-area-xy w offsetx offsety sizex sizey)
+ (if (itm = (that item with (value (that item)) == val))
+ (if (eql (if (consp itm)
+ (car itm)
+ itm)
+ 1)
+ (invert-area-xy w offsetx offsety sizex sizey)) ) ))
+
+; 13 Dec 91; 15 Dec 91; 26 Dec 93; 28 Jul 94; 08 Jan 04
+(gldefun edit-black-white ((items (listof menu-item)) (val anything) (w window)
+ &optional (offsetx integer) (offsety integer)
+ (sizex integer) (sizey integer))
+ (let (newval)
+ (if (equal val (value (first items)))
+ (newval = (value (second items)))
+ (if (equal val (value (second items)))
+ (newval = (value (first items)))))
+ (draw-black-white items newval w offsetx offsety sizex sizey)
+ newval ))
+
+; 23 Dec 91; 26 Dec 93
+(gldefun draw-integer ((val integer) (w window)
+ &optional (offsetx integer) (offsety integer)
+ (sizex integer) (sizey integer))
+ (editors-anything-print val w offsetx offsety sizex sizey) )
+
+; 24 Dec 91; 26 Dec 93
+(defun draw-real (val w &optional offsetx offsety sizex sizey)
+ (let (str nc lng fmt)
+ (if (null sizex) (setq sizex 50))
+ (setq nc (max 1 (truncate sizex 7)))
+ (setq str (princ-to-string val))
+ (setq lng (length str))
+ (if (> lng nc)
+ (if (or (find #\. str :start nc)
+ (find #\E str)
+ (find #\L str))
+ (if (>= nc 8)
+ (progn (setq fmt (cadr (or (assoc nc '((8 "~8,2E")
+ (9 "~9,2E") (10 "~10,2E")
+ (11 "~11,2E") (12 "~12,2E")
+ (13 "~13,2E") (14 "~14,2E")))
+ '(15 "~15,2E"))))
+ (setq str (format nil fmt val)))
+ (setq str "*******"))
+ (setq str (subseq str 0 nc)) ))
+ (editors-anything-print w str offsetx offsety sizex sizey) ))
+
+; 09 Dec 91; 10 Dec 91; 23 Dec 91; 26 Dec 93; 22 Jul 94
+; Display function for use when a more specific one is not found.
+(gldefun editors-anything-print (obj (w window) offsetx offsety sizex sizey)
+ (let ((s (stringify obj)) swidth smax dx dy)
+ (erase-area-xy w offsetx offsety sizex sizey)
+ (swidth = (string-width w s))
+ (smax = (min swidth sizex))
+ (dx = (sizex - smax) / 2)
+ (dy = (max 0 ((sizey - 10) / 2)))
+ (printat-xy w (editors-string-limit obj w smax)
+ (offsetx + dx) (offsety + dy))
+ ))
+
+; 26 Dec 93
+(gldefun editors-print-in-box (obj (w window) offsetx offsety sizex sizey)
+ (printat-xy w (editors-string-limit obj w sizex)
+ (offsetx + 4) (offsety + (sizey - 10) / 2))
+ (draw-box-xy w offsetx offsety sizex sizey) )
+
+; 26 Dec 93
+(gldefun editors-update-in-box (obj (w window) offsetx offsety sizex sizey)
+ (erase-area-xy w (offsetx + 3) (offsety + 3) (sizex - 6) (sizey - 6))
+ (printat-xy w (editors-string-limit obj w sizex)
+ (offsetx + 4) (offsety + (sizey - 10) / 2)) )
+
+; 28 Oct 91; 26 Dec 93; 08 Jan 04
+; Limit string to a specified number of pixels
+(gldefun editors-string-limit ((s string) (w window) (max integer))
+ (result string)
+ (let ((str (stringify s)) (lng integer) (nc integer))
+ (lng = (string-width w str))
+ (if (lng > max)
+ (progn (nc = (((length str) * max) / lng))
+ (subseq str 0 nc))
+ str) ))
+
+(defvar *edit-color-menu-set* nil)
+(defvar *edit-color-rmenu* nil)
+(defvar *edit-color-old-color* nil)
+(glispglobals (*edit-color-menu-set* menu-set)
+ (*edit-color-rmenu* barmenu))
+
+; 03 Jan 94; 04 Jan 94; 05 Jan 94
+(gldefun edit-color-init ((w window))
+ (let (rm gm bm rgb)
+ (rgb = (a rgb))
+ (*edit-color-menu-set* = (menu-set-create w nil))
+ (rm = (barmenu-create 256 200 10 "" nil #'edit-color-red (list rgb) w
+ 120 40 nil t (a rgb with red = 65535)))
+ (*edit-color-rmenu* = rm)
+ (gm = (barmenu-create 256 50 10 "" nil #'edit-color-green (list rgb) w
+ 170 40 nil t (a rgb with green = 65535)))
+ (bm = (barmenu-create 256 250 10 "" nil #'edit-color-blue (list rgb) w
+ 220 40 nil t (a rgb with blue = 65535)))
+ (add-barmenu *edit-color-menu-set* 'red nil rm "Red" '(120 40))
+ (add-barmenu *edit-color-menu-set* 'green nil gm "Green" '(170 40))
+ (add-barmenu *edit-color-menu-set* 'blue nil bm "Blue" '(220 40))
+ (add-menu *edit-color-menu-set* 'done nil "" '(("Done" . done)) '(30 150))
+ (edit-color-red 200 rgb)
+ (edit-color-green 50 rgb)
+ (edit-color-blue 250 rgb)
+ ))
+
+; 03 Jan 94; 04 Jan 94
+(gldefun edit-color-red ((val integer) (color rgb))
+ (let ((w (window *edit-color-menu-set*)))
+ (printat-xy w (format nil "~3D" val) 113 20)
+ ((red color) = (max 0 (val * 256 - 1)))
+ (edit-display-color w color) ))
+
+; 03 Jan 94; 04 Jan 94
+(gldefun edit-color-green ((val integer) (color rgb))
+ (let ((w (window *edit-color-menu-set*)))
+ (printat-xy w (format nil "~3D" val) 163 20)
+ ((green color) = (max 0 (val * 256 - 1)))
+ (edit-display-color w color) ))
+
+; 03 Jan 94; 04 Jan 94
+(gldefun edit-color-blue ((val integer) (color rgb))
+ (let ((w (window *edit-color-menu-set*)))
+ (printat-xy w (format nil "~3D" val) 213 20)
+ ((blue color) = (max 0 (val * 256 - 1)))
+ (edit-display-color w color) ))
+
+; 03 Jan 94
+(gldefun edit-display-color ((w window) (color rgb))
+ (window-set-color w color)
+ (window-draw-line-xy w 50 40 50 100 60)
+ (window-reset-color w)
+ (if *edit-color-old-color* (window-free-color w *edit-color-old-color*))
+ (*edit-color-old-color* = *window-xcolor*) )
+
+; 03 Jan 94; 04 Jan 94; 05 Jan 94; 28 Feb 02
+(gldefun edit-color ((w window))
+ (let (done (color rgb) sel)
+ (if (or (null *edit-color-menu-set*)
+ (not (eq w (menu-window (menu (first (menu-items
+ *edit-color-menu-set*)))))))
+ (edit-color-init w))
+ (color = (first (subtrackparms *edit-color-rmenu*)))
+ (draw *edit-color-menu-set*)
+ (edit-color-red (truncate (1+ (red color)) 256) color)
+ (edit-color-green (truncate (1+ (green color)) 256) color)
+ (edit-color-blue (truncate (1+ (blue color)) 256) color)
+ (while ~ done
+ (sel = (select *edit-color-menu-set*))
+ (done = (and sel ((first sel) == 'done))) )
+ color))
+
+; 15 Oct 93; 26 Jan 06
+; Compile the editors.lsp file into a plain Lisp file
+(defun compile-editors ()
+ (glcompfiles *directory*
+ '("glisp/vector.lsp" ; auxiliary files
+ "X/dwindow.lsp")
+ '("glisp/editors.lsp") ; translated files
+ "glisp/editorstrans.lsp" ; output file
+ "glisp/gpl.txt") ; header file
+ (cf editorstrans) )
Index: xgcl-2/gcl_editorstrans.lsp
===================================================================
RCS file: xgcl-2/gcl_editorstrans.lsp
diff -N xgcl-2/gcl_editorstrans.lsp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ xgcl-2/gcl_editorstrans.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.1
@@ -0,0 +1,459 @@
+; 27 Jan 2006 14:26:27 CST
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 2 of the License, or
+; (at your option) any later version.
+
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(DEFUN EDIT-THERMOM (NUM W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY)
+ (PROG (NMIN NDEL NDIV RANGE PTEN DRANGE PAIR NEWW (RES NUM) OFF)
+ (WHEN (NOT SIZEX) (SETQ SIZEX 150) (SETQ SIZEY 250))
+ (WHEN (NOT OFFSETX)
+ (SETQ OFF (WINDOW-CENTEROFFSET W (LIST SIZEX SIZEY)))
+ (SETQ OFFSETX (X OFF))
+ (SETQ OFFSETY (Y OFF)))
+ (SETQ NEWW
+ (WINDOW-CREATE SIZEX SIZEY NIL (CADR W) OFFSETX OFFSETY))
+ (WINDOW-DRAW-BUTTON NEWW "Typein" 80 20 50 25)
+ (WINDOW-DRAW-BUTTON NEWW "Adjust" 80 70 50 25)
+ (WINDOW-DRAW-BUTTON NEWW "Done" 80 120 50 25)
+ RN
+ (SETQ RANGE (* 2 (ABS RES)))
+ (IF (ZEROP RANGE) (SETQ RANGE 50))
+ (IF (AND (< RANGE 8) (INTEGERP NUM)) (SETQ RANGE 10))
+ (SETQ PTEN (EXPT 10 (TRUNCATE (LOG RANGE 10))))
+ (SETQ DRANGE (/ (* 10 RANGE) PTEN))
+ (SETQ PAIR
+ (CAR (SOME #'(LAMBDA (X) (> (CAR X) DRANGE))
+ '((14 2) (20 4) (40 5) (70 10) (101 20)))))
+ (SETQ NDEL (/ (* (CADR PAIR) PTEN) 10))
+ (SETQ NDIV (CEILING (/ RANGE NDEL)))
+ (SETQ NMIN (IF (>= RES 0) 0 (- (* NDEL NDIV))))
+ (WINDOW-DRAW-THERMOMETER NEWW NMIN NDEL NDIV RES 10 10
+ (+ -20 SIZEY))
+ LP
+ (CASE (BUTTON-SELECT NEWW
+ '((DONE (84 124) (42 17)) (ADJUST (84 74) (42 17))
+ (TYPEIN (84 24) (42 17))))
+ (DONE (WINDOW-DESTROY NEWW) (RETURN RES))
+ (ADJUST (SETQ RES
+ (WINDOW-ADJUST-THERMOMETER NEWW NMIN NDEL NDIV RES
+ 10 10 (+ -20 SIZEY)))
+ (GO LP))
+ (TYPEIN (PRINC "Enter new value: ") (SETQ RES (READ))
+ (IF (AND (>= RES NMIN) (<= RES (+ NMIN (* NDEL NDIV))))
+ (PROGN
+ (WINDOW-SET-THERMOMETER NEWW NMIN NDEL NDIV RES 10
+ 10 (+ -20 SIZEY))
+ (GO LP))
+ (GO RN))))))
+(SETF (GET 'EDIT-THERMOM 'GLARGUMENTS)
+ '((NUM NUMBER) (W WINDOW) (&OPTIONAL NIL) (OFFSETX INTEGER)
+ (OFFSETY INTEGER) (SIZEX INTEGER) (SIZEY INTEGER)))
+(SETF (GET 'EDIT-THERMOM 'GLFNRESULTTYPE) 'NUMBER)
+
+
+(DEFUN WINDOW-DRAW-BUTTON (W S OFFSETX OFFSETY SIZEX SIZEY)
+ (LET (SW)
+ (WINDOW-ERASE-AREA-XY W OFFSETX OFFSETY SIZEX SIZEY 8)
+ (WINDOW-DRAW-RCBOX-XY W OFFSETX OFFSETY SIZEX SIZEY 8)
+ (SETQ SW (WINDOW-STRING-WIDTH W S))
+ (WINDOW-PRINTAT-XY W S (+ OFFSETX (/ (- SIZEX SW) 2))
+ (+ 8 OFFSETY))
+ (WINDOW-FORCE-OUTPUT W)))
+
+(DEFUN WINDOW-CENTER-PRINT (W S OFFSETX OFFSETY SIZEX SIZEY)
+ (LET (SW)
+ (WINDOW-ERASE-AREA-XY W OFFSETX OFFSETY SIZEX SIZEY 8)
+ (SETQ SW (WINDOW-STRING-WIDTH W S))
+ (WINDOW-PRINTAT-XY W S (+ OFFSETX (/ (- SIZEX SW) 2))
+ (+ OFFSETY (+ -5 (/ SIZEY 2))))
+ (WINDOW-FORCE-OUTPUT W)))
+
+(DEFUN WINDOW-DRAW-THERMOMETER
+ (W NMIN NDEL NDIV VAL OFFSETX OFFSETY SIZEY)
+ (LET (HDEL MARKY)
+ (WINDOW-ERASE-AREA-XY W OFFSETX OFFSETY 66 SIZEY)
+ (EDITORS-PRINT-IN-BOX VAL W OFFSETX OFFSETY 40 20)
+ (WINDOW-DRAW-ARC-XY W (+ 12 OFFSETX) (+ 36 OFFSETY) 12 12 132 276)
+ (WINDOW-DRAW-LINE-XY W (+ 4 OFFSETX) (+ 44 OFFSETY) (+ 4 OFFSETX)
+ (+ -8 (+ OFFSETY SIZEY)))
+ (WINDOW-DRAW-LINE-XY W (+ 20 OFFSETX) (+ 44 OFFSETY) (+ 20 OFFSETX)
+ (+ -8 (+ OFFSETY SIZEY)))
+ (WINDOW-DRAW-ARC-XY W (+ 12 OFFSETX) (+ -8 (+ OFFSETY SIZEY)) 8 8 0
+ 180)
+ (WINDOW-DRAW-CIRCLE-XY W (+ 12 OFFSETX) (+ 36 OFFSETY) 4 7)
+ (SETQ HDEL (/ (+ -56 SIZEY) NDIV))
+ (WINDOW-DRAW-LINE-XY W (+ 12 OFFSETX) (+ 35 OFFSETY) (+ 12 OFFSETX)
+ (+ (+ 48 OFFSETY) (* HDEL (/ (- VAL NMIN) NDEL))) 7)
+ (DOTIMES (I (1+ NDIV))
+ (SETQ MARKY (+ (+ 48 OFFSETY) (* I HDEL)))
+ (WINDOW-DRAW-LINE-XY W (+ 24 OFFSETX) MARKY (+ 34 OFFSETX) MARKY)
+ (WINDOW-PRINTAT-XY W (+ NMIN (* I NDEL)) (+ 36 OFFSETX)
+ (+ -6 MARKY)))
+ (WINDOW-FORCE-OUTPUT W)))
+
+(DEFUN WINDOW-SET-THERMOMETER
+ (W NMIN NDEL NDIV VAL OFFSETX OFFSETY SIZEY)
+ (LET (HDEL)
+ (SETQ HDEL (/ (+ -56 SIZEY) NDIV))
+ (WINDOW-ERASE-AREA-XY W (+ 7 OFFSETX) (+ 48 OFFSETY) 10
+ (+ -56 SIZEY))
+ (WINDOW-DRAW-LINE-XY W (+ 12 OFFSETX) (+ 35 OFFSETY) (+ 12 OFFSETX)
+ (+ (+ 48 OFFSETY) (* HDEL (/ (- VAL NMIN) NDEL))) 7)
+ (EDITORS-UPDATE-IN-BOX VAL W OFFSETX OFFSETY 40 20)))
+
+(DEFUN WINDOW-ADJUST-THERMOMETER
+ (W NMIN NDEL NDIV VAL OFFSETX OFFSETY SIZEY)
+ (LET (HDEL LASTY XMIN XMAX YMIN YMAX INSIDE NEWVAL)
+ (SETQ HDEL (/ (+ -56 SIZEY) NDIV))
+ (SETQ LASTY
+ (TRUNCATE (+ (+ 48 OFFSETY) (* HDEL (/ (- VAL NMIN) NDEL)))))
+ (SETQ XMIN (+ 4 OFFSETX))
+ (SETQ XMAX (+ 20 OFFSETX))
+ (SETQ YMIN (+ 48 OFFSETY))
+ (SETQ YMAX (+ -8 (+ OFFSETY SIZEY)))
+ (WINDOW-TRACK-MOUSE W
+ #'(LAMBDA (X Y CODE)
+ (SETQ INSIDE
+ (AND (>= X XMIN) (<= X XMAX) (>= Y YMIN) (<= Y YMAX)))
+ (WHEN (AND INSIDE (/= Y LASTY))
+ (IF (> Y LASTY)
+ (WINDOW-DRAW-LINE-XY W (+ 12 OFFSETX) LASTY
+ (+ 12 OFFSETX) Y 7)
+ (WINDOW-ERASE-AREA-XY W (+ 7 OFFSETX) (1+ Y) 10
+ (- LASTY Y)))
+ (SETQ LASTY Y)
+ (SETQ NEWVAL
+ (+ (* (/ (+ -48 (- LASTY OFFSETY)) (FLOAT HDEL))
+ NDEL)
+ NMIN))
+ (IF (INTEGERP VAL) (SETQ NEWVAL (TRUNCATE NEWVAL)))
+ (EDITORS-UPDATE-IN-BOX NEWVAL W OFFSETX OFFSETY 40 20))
+ (NOT (ZEROP CODE))))
+ (IF INSIDE NEWVAL VAL)))
+(SETF (GET 'WINDOW-ADJUST-THERMOMETER 'GLARGUMENTS)
+ '((W WINDOW) (NMIN INTEGER) (NDEL INTEGER) (NDIV INTEGER)
+ (VAL NUMBER) (OFFSETX INTEGER) (OFFSETY INTEGER)
+ (SIZEY INTEGER)))
+(SETF (GET 'WINDOW-ADJUST-THERMOMETER 'GLFNRESULTTYPE) 'NUMBER)
+
+
+(DEFUN BUTTON-SELECT (MW BUTTONS)
+ (LET (CURRENT-BUTTON ITEM ITEMS VAL XZERO YZERO)
+ (SETQ XZERO 0)
+ (SETQ YZERO 0)
+ (WINDOW-TRACK-MOUSE MW
+ #'(LAMBDA (X Y CODE)
+ (DECF X XZERO)
+ (DECF Y YZERO)
+ (AND (>= X 0) (>= Y 0))
+ (IF CURRENT-BUTTON
+ (WHEN (NOT (BUTTON-CONTAINSXY? CURRENT-BUTTON X Y))
+ (BUTTON-INVERT MW CURRENT-BUTTON)
+ (SETQ CURRENT-BUTTON NIL)))
+ (WHEN (NOT CURRENT-BUTTON)
+ (SETQ ITEMS BUTTONS)
+ (WHILE (AND (NOT CURRENT-BUTTON) (SETQ ITEM (POP ITEMS)))
+ (WHEN (BUTTON-CONTAINSXY? ITEM X Y)
+ (SETQ CURRENT-BUTTON ITEM)
+ (BUTTON-INVERT MW CURRENT-BUTTON))))
+ (WHEN (PLUSP CODE)
+ (IF CURRENT-BUTTON (BUTTON-INVERT MW CURRENT-BUTTON))
+ (SETQ VAL (OR CURRENT-BUTTON *PICMENU-NO-SELECTION*))))
+ T)
+ (IF (NOT (EQUAL VAL *PICMENU-NO-SELECTION*)) (CAR VAL))))
+(SETF (GET 'BUTTON-SELECT 'GLARGUMENTS)
+ '((MW WINDOW) (BUTTONS (LISTOF PICMENU-BUTTON))))
+(SETF (GET 'BUTTON-SELECT 'GLFNRESULTTYPE) 'SYMBOL)
+
+
+(DEFUN BUTTON-INVERT (W BUTTON)
+ (WINDOW-INVERT-AREA W (CADR BUTTON) (CADDR BUTTON)))
+
+(DEFUN WINDOW-UNDRAW-BOX (W OFFSET SIZE &OPTIONAL LW)
+ (WINDOW-SET-ERASE W)
+ (WINDOW-DRAW-BOX W OFFSET SIZE LW)
+ (WINDOW-UNSET W))
+
+(DEFUN BUTTON-CONTAINSXY? (B X Y)
+ (LET ((XSIZE 6) (YSIZE 6))
+ (WHEN (CADDR B)
+ (SETQ XSIZE (CAADDR B))
+ (SETQ YSIZE (CADR (CADDR B))))
+ (AND (>= X (CAADR B)) (<= X (+ (CAADR B) XSIZE)) (>= Y (CADADR B))
+ (<= Y (+ (CADADR B) YSIZE)))))
+(SETF (GET 'BUTTON-CONTAINSXY? 'GLARGUMENTS)
+ '((B PICMENU-BUTTON) (X INTEGER) (Y INTEGER)))
+(SETF (GET 'BUTTON-CONTAINSXY? 'GLFNRESULTTYPE) 'BOOLEAN)
+
+
+(SETF (GET 'MENU-ITEM 'GLSTRUCTURE)
+ '((Z ANYTHING) PROP ((VALUE ((IF Z IS ATOMIC Z (CDR Z))))) MSG
+ ((PRINT-SIZE MENU-ITEM-PRINT-SIZE) (DRAW MENU-ITEM-DRAW))))
+
+
+(DEFUN MENU-ITEM-PRINT-SIZE (ITEM W)
+ (LET (SIZ)
+ (IF (ATOM ITEM) (LIST (WINDOW-STRING-WIDTH W ITEM) 11)
+ (IF (STRINGP (CAR ITEM))
+ (LIST (WINDOW-STRING-WIDTH W (CAR ITEM)) 11)
+ (IF (AND (SYMBOLP (CAR ITEM))
+ (SETQ SIZ (GET (CAR ITEM) 'DISPLAY-SIZE)))
+ SIZ (COPY-LIST '(50 11)))))))
+(SETF (GET 'MENU-ITEM-PRINT-SIZE 'GLARGUMENTS)
+ '((ITEM MENU-ITEM) (W WINDOW)))
+(SETF (GET 'MENU-ITEM-PRINT-SIZE 'GLFNRESULTTYPE) 'VECTOR)
+
+
+(DEFUN MENU-ITEM-DRAW (ITEM W OFFSETX OFFSETY SIZEX SIZEY)
+ (IF (ATOM ITEM)
+ (WINDOW-CENTER-PRINT W ITEM OFFSETX OFFSETY SIZEX SIZEY)
+ (IF (AND (SYMBOLP (CAR ITEM)) (FBOUNDP (CAR ITEM)))
+ (FUNCALL (CAR ITEM) W OFFSETX OFFSETY)
+ (WINDOW-CENTER-PRINT W (CAR ITEM) OFFSETX OFFSETY SIZEX
+ SIZEY))))
+
+(DEFUN PICK-ONE-SIZE (ITEMS W)
+ (LET (WID)
+ (DOLIST (ITEM ITEMS)
+ (SETQ WID
+ (IF WID (MAX WID (CAR (MENU-ITEM-PRINT-SIZE ITEM W)))
+ (CAR (MENU-ITEM-PRINT-SIZE ITEM W)))))
+ (LIST WID 11)))
+(SETF (GET 'PICK-ONE-SIZE 'GLARGUMENTS)
+ '((ITEMS (LISTOF MENU-ITEM)) (W WINDOW)))
+(SETF (GET 'PICK-ONE-SIZE 'GLFNRESULTTYPE) 'VECTOR)
+
+
+(DEFUN DRAW-PICK-ONE
+ (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY)
+ (LET (ITM)
+ (IF (SETQ ITM
+ (SOME #'(LAMBDA (GLVAR9633)
+ (IF (EQUAL (IF (ATOM GLVAR9633) GLVAR9633
+ (CDR GLVAR9633))
+ VAL)
+ GLVAR9633))
+ ITEMS))
+ (MENU-ITEM-DRAW ITM W OFFSETX OFFSETY SIZEX SIZEY))))
+
+(DEFUN EDIT-PICK-ONE
+ (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY)
+ (LET (NEWVAL)
+ (IF (<= (LENGTH ITEMS) 3)
+ (IF (EQUAL VAL
+ (LET ((SELF (FIRST ITEMS)))
+ (IF (ATOM SELF) SELF (CDR SELF))))
+ (SETQ NEWVAL
+ (LET ((SELF (SECOND ITEMS)))
+ (IF (ATOM SELF) SELF (CDR SELF))))
+ (IF (EQUAL VAL
+ (LET ((SELF (SECOND ITEMS)))
+ (IF (ATOM SELF) SELF (CDR SELF))))
+ (SETQ NEWVAL
+ (IF (THIRD ITEMS)
+ (LET ((SELF (THIRD ITEMS)))
+ (IF (ATOM SELF) SELF (CDR SELF)))
+ (LET ((SELF (FIRST ITEMS)))
+ (IF (ATOM SELF) SELF (CDR SELF)))))
+ (SETQ NEWVAL
+ (LET ((SELF (FIRST ITEMS)))
+ (IF (ATOM SELF) SELF (CDR SELF))))))
+ (SETQ NEWVAL (MENU ITEMS)))
+ (DRAW-PICK-ONE NEWVAL W ITEMS OFFSETX OFFSETY SIZEX SIZEY)
+ NEWVAL))
+
+(DEFUN DRAW-BLACK-WHITE
+ (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY)
+ (LET (ITM)
+ (WINDOW-ERASE-AREA-XY W OFFSETX OFFSETY SIZEX SIZEY)
+ (IF (AND (SETQ ITM
+ (SOME #'(LAMBDA (GLVAR9839)
+ (IF (EQUAL (IF (ATOM GLVAR9839) GLVAR9839
+ (CDR GLVAR9839))
+ VAL)
+ GLVAR9839))
+ ITEMS))
+ (EQL (IF (CONSP ITM) (CAR ITM) ITM) 1))
+ (WINDOW-INVERT-AREA-XY W OFFSETX OFFSETY SIZEX SIZEY))))
+
+(DEFUN EDIT-BLACK-WHITE
+ (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY)
+ (LET (NEWVAL)
+ (IF (EQUAL VAL
+ (LET ((SELF (FIRST ITEMS)))
+ (IF (ATOM SELF) SELF (CDR SELF))))
+ (SETQ NEWVAL
+ (LET ((SELF (SECOND ITEMS)))
+ (IF (ATOM SELF) SELF (CDR SELF))))
+ (IF (EQUAL VAL
+ (LET ((SELF (SECOND ITEMS)))
+ (IF (ATOM SELF) SELF (CDR SELF))))
+ (SETQ NEWVAL
+ (LET ((SELF (FIRST ITEMS)))
+ (IF (ATOM SELF) SELF (CDR SELF))))))
+ (DRAW-BLACK-WHITE ITEMS NEWVAL W OFFSETX OFFSETY SIZEX SIZEY)
+ NEWVAL))
+
+(DEFUN DRAW-INTEGER (VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY)
+ (EDITORS-ANYTHING-PRINT VAL W OFFSETX OFFSETY SIZEX SIZEY))
+
+(DEFUN DRAW-REAL (VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY)
+ (LET (STR NC LNG FMT)
+ (IF (NULL SIZEX) (SETQ SIZEX 50))
+ (SETQ NC (MAX 1 (TRUNCATE SIZEX 7)))
+ (SETQ STR (PRINC-TO-STRING VAL))
+ (SETQ LNG (LENGTH STR))
+ (IF (> LNG NC)
+ (IF (OR (FIND #\. STR :START NC) (FIND #\E STR) (FIND #\L STR))
+ (IF (>= NC 8)
+ (PROGN
+ (SETQ FMT
+ (CADR (OR (ASSOC NC
+ '((8 "~8,2E") (9 "~9,2E")
+ (10 "~10,2E") (11 "~11,2E")
+ (12 "~12,2E") (13 "~13,2E")
+ (14 "~14,2E")))
+ '(15 "~15,2E"))))
+ (SETQ STR (FORMAT NIL FMT VAL)))
+ (SETQ STR "*******"))
+ (SETQ STR (SUBSEQ STR 0 NC))))
+ (EDITORS-ANYTHING-PRINT W STR OFFSETX OFFSETY SIZEX SIZEY)))
+
+(DEFUN EDITORS-ANYTHING-PRINT (OBJ W OFFSETX OFFSETY SIZEX SIZEY)
+ (LET (SWIDTH SMAX DX DY)
+ (WINDOW-ERASE-AREA-XY W OFFSETX OFFSETY SIZEX SIZEY)
+ (SETQ SWIDTH (WINDOW-STRING-WIDTH W (STRINGIFY OBJ)))
+ (SETQ SMAX (MIN SWIDTH SIZEX))
+ (SETQ DX (/ (- SIZEX SMAX) 2))
+ (SETQ DY (MAX 0 (+ -5 (/ SIZEY 2))))
+ (WINDOW-PRINTAT-XY W (EDITORS-STRING-LIMIT OBJ W SMAX)
+ (+ OFFSETX DX) (+ OFFSETY DY))))
+
+(DEFUN EDITORS-PRINT-IN-BOX (OBJ W OFFSETX OFFSETY SIZEX SIZEY)
+ (WINDOW-PRINTAT-XY W (EDITORS-STRING-LIMIT OBJ W SIZEX) (+ 4 OFFSETX)
+ (+ OFFSETY (+ -5 (/ SIZEY 2))))
+ (WINDOW-DRAW-BOX-XY W OFFSETX OFFSETY SIZEX SIZEY))
+
+(DEFUN EDITORS-UPDATE-IN-BOX (OBJ W OFFSETX OFFSETY SIZEX SIZEY)
+ (WINDOW-ERASE-AREA-XY W (+ 3 OFFSETX) (+ 3 OFFSETY) (+ -6 SIZEX)
+ (+ -6 SIZEY))
+ (WINDOW-PRINTAT-XY W (EDITORS-STRING-LIMIT OBJ W SIZEX) (+ 4 OFFSETX)
+ (+ OFFSETY (+ -5 (/ SIZEY 2)))))
+
+(DEFUN EDITORS-STRING-LIMIT (S W MAX)
+ (LET ((STR (STRINGIFY S)) LNG NC)
+ (SETQ LNG (WINDOW-STRING-WIDTH W STR))
+ (IF (> LNG MAX)
+ (PROGN
+ (SETQ NC (/ (* (LENGTH STR) MAX) LNG))
+ (SUBSEQ STR 0 NC))
+ STR)))
+(SETF (GET 'EDITORS-STRING-LIMIT 'GLARGUMENTS)
+ '((S STRING) (W WINDOW) (MAX INTEGER)))
+(SETF (GET 'EDITORS-STRING-LIMIT 'GLFNRESULTTYPE) 'STRING)
+
+
+(DEFVAR *EDIT-COLOR-MENU-SET* NIL)
+
+(DEFVAR *EDIT-COLOR-RMENU* NIL)
+
+(DEFVAR *EDIT-COLOR-OLD-COLOR* NIL)
+
+(DEFVAR *EDIT-COLOR-MENU-SET*)
+(SETF (GET '*EDIT-COLOR-MENU-SET* 'GLISPGLOBALVAR) T)
+(SETF (GET '*EDIT-COLOR-MENU-SET* 'GLISPGLOBALVARTYPE) 'MENU-SET)
+(DEFVAR *EDIT-COLOR-RMENU*)
+(SETF (GET '*EDIT-COLOR-RMENU* 'GLISPGLOBALVAR) T)
+(SETF (GET '*EDIT-COLOR-RMENU* 'GLISPGLOBALVARTYPE) 'BARMENU)
+
+
+(DEFUN EDIT-COLOR-INIT (W)
+ (LET (RM GM BM RGB)
+ (SETQ RGB (COPY-LIST '(0 0 0)))
+ (SETQ *EDIT-COLOR-MENU-SET* (MENU-SET-CREATE W NIL))
+ (SETQ RM
+ (BARMENU-CREATE 256 200 10 "" NIL #'EDIT-COLOR-RED (LIST RGB)
+ W 120 40 NIL T (COPY-LIST '(65535 0 0))))
+ (SETQ *EDIT-COLOR-RMENU* RM)
+ (SETQ GM
+ (BARMENU-CREATE 256 50 10 "" NIL #'EDIT-COLOR-GREEN
+ (LIST RGB) W 170 40 NIL T (COPY-LIST '(0 65535 0))))
+ (SETQ BM
+ (BARMENU-CREATE 256 250 10 "" NIL #'EDIT-COLOR-BLUE
+ (LIST RGB) W 220 40 NIL T (COPY-LIST '(0 0 65535))))
+ (MENU-SET-ADD-BARMENU *EDIT-COLOR-MENU-SET* 'RED NIL RM "Red"
+ '(120 40))
+ (MENU-SET-ADD-BARMENU *EDIT-COLOR-MENU-SET* 'GREEN NIL GM "Green"
+ '(170 40))
+ (MENU-SET-ADD-BARMENU *EDIT-COLOR-MENU-SET* 'BLUE NIL BM "Blue"
+ '(220 40))
+ (MENU-SET-ADD-MENU *EDIT-COLOR-MENU-SET* 'DONE NIL ""
+ '(("Done" . DONE)) '(30 150))
+ (EDIT-COLOR-RED 200 RGB)
+ (EDIT-COLOR-GREEN 50 RGB)
+ (EDIT-COLOR-BLUE 250 RGB)))
+
+(DEFUN EDIT-COLOR-RED (VAL COLOR)
+ (LET ((W (CADR *EDIT-COLOR-MENU-SET*)))
+ (WINDOW-PRINTAT-XY W (FORMAT NIL "~3D" VAL) 113 20)
+ (SETF (CAR COLOR) (MAX 0 (1- (* 256 VAL))))
+ (EDIT-DISPLAY-COLOR W COLOR)))
+
+(DEFUN EDIT-COLOR-GREEN (VAL COLOR)
+ (LET ((W (CADR *EDIT-COLOR-MENU-SET*)))
+ (WINDOW-PRINTAT-XY W (FORMAT NIL "~3D" VAL) 163 20)
+ (SETF (CADR COLOR) (MAX 0 (1- (* 256 VAL))))
+ (EDIT-DISPLAY-COLOR W COLOR)))
+
+(DEFUN EDIT-COLOR-BLUE (VAL COLOR)
+ (LET ((W (CADR *EDIT-COLOR-MENU-SET*)))
+ (WINDOW-PRINTAT-XY W (FORMAT NIL "~3D" VAL) 213 20)
+ (SETF (CADDR COLOR) (MAX 0 (1- (* 256 VAL))))
+ (EDIT-DISPLAY-COLOR W COLOR)))
+
+(DEFUN EDIT-DISPLAY-COLOR (W COLOR)
+ (WINDOW-SET-COLOR W COLOR)
+ (WINDOW-DRAW-LINE-XY W 50 40 50 100 60)
+ (WINDOW-RESET-COLOR W)
+ (IF *EDIT-COLOR-OLD-COLOR*
+ (WINDOW-FREE-COLOR W *EDIT-COLOR-OLD-COLOR*))
+ (SETQ *EDIT-COLOR-OLD-COLOR* *WINDOW-XCOLOR*))
+
+(DEFUN EDIT-COLOR (W)
+ (LET (DONE COLOR SEL)
+ (IF (OR (NULL *EDIT-COLOR-MENU-SET*)
+ (NOT (EQ W (CADR (CADDR (CAADDR *EDIT-COLOR-MENU-SET*))))))
+ (EDIT-COLOR-INIT W))
+ (SETQ COLOR (FIRST (NTH 16 *EDIT-COLOR-RMENU*)))
+ (MENU-SET-DRAW *EDIT-COLOR-MENU-SET*)
+ (EDIT-COLOR-RED (TRUNCATE (1+ (CAR COLOR)) 256) COLOR)
+ (EDIT-COLOR-GREEN (TRUNCATE (1+ (CADR COLOR)) 256) COLOR)
+ (EDIT-COLOR-BLUE (TRUNCATE (1+ (CADDR COLOR)) 256) COLOR)
+ (WHILE (NOT DONE)
+ (SETQ SEL (MENU-SET-SELECT *EDIT-COLOR-MENU-SET*))
+ (SETQ DONE (AND SEL (EQ (FIRST SEL) 'DONE))))
+ COLOR))
+(SETF (GET 'EDIT-COLOR 'GLARGUMENTS) '((W WINDOW)))
+(SETF (GET 'EDIT-COLOR 'GLFNRESULTTYPE) 'RGB)
+
+
+(DEFUN COMPILE-EDITORS ()
+ (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp")
+ '("glisp/editors.lsp") "glisp/editorstrans.lsp" "glisp/gpl.txt")
+ (CF EDITORSTRANS))
+
+(DEFUN COMPILE-EDITORSB ()
+ (GLCOMPFILES *DIRECTORY*
+ '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp")
+ '("glisp/editors.lsp") "glisp/editorstrans.lsp" "glisp/gpl.txt"))
Index: xgcl-2/gcl_lispserver.lsp
===================================================================
RCS file: xgcl-2/gcl_lispserver.lsp
diff -N xgcl-2/gcl_lispserver.lsp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ xgcl-2/gcl_lispserver.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.1
@@ -0,0 +1,130 @@
+; lispserver.lsp Gordon S. Novak Jr. ; 26 Jan 06
+
+; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin.
+
+; 06 Jun 02
+
+; See the file gnu.license .
+
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 1, or (at your option)
+; any later version.
+
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+; Written by: Gordon S. Novak Jr., Department of Computer Sciences,
+; University of Texas at Austin 78712. address@hidden
+
+;------------------------------------------------------------------------
+
+; This is an example of a simple interactive graphical interface
+; to a Lisp program. It reads Lisp expressions from the user,
+; evaluates them, and prints the result.
+
+; Stand-alone usage using XGCL (edit file paths as appropriate):
+; (load "/u/novak/X/xgcl-2/dwsyms.lsp")
+; (load "/u/novak/X/xgcl-2/dwimports.lsp")
+; (load "/u/novak/X/solaris/dwtrans.o")
+; (load "/u/novak/glisp/menu-settrans.lsp")
+; (load "/u/novak/glisp/lispservertrans.lsp")
+; (lisp-server)
+
+; Usage with the WeirdX Java emulation of an X server begins with
+; the web page example.html and uses the files lispserver.cgi ,
+; nph-lisp-action.cgi , and lispdemo.lsp .
+
+;------------------------------------------------------------------------
+
+(defvar *wio-window* nil)
+(defvar *wio-window-width* 500)
+(defvar *wio-window-height* 300)
+(defvar *wio-menu-set* nil)
+(defvar *wio-font* '8x13)
+
+(glispglobals (*wio-window* window)
+ (*wio-window-width* integer)
+ (*wio-window-height* integer)
+ (*wio-menu-set* menu-set) )
+
+(defmacro while (test &rest forms)
+ `(loop (unless ,test (return)) ,@forms) )
+
+; 18 Apr 95; 20 Apr 95; 08 May 95; 31 May 02
+; Make a window to use.
+(setf (glfnresulttype 'wio-window) 'window)
+(defun wio-window (&optional title width height (posx 0) (posy 0) font)
+ (if width (setq *wio-window-width* width))
+ (if height (setq *wio-window-height* height))
+ (or *wio-window*
+ (setq *wio-window*
+ (window-create *wio-window-width* *wio-window-height* title
+ nil posx posy font))) )
+
+; 19 Apr 95
+(defun wio-init-menus (w commands)
+ (let ()
+ (window-clear w)
+ (setq *wio-menu-set* (menu-set-create w nil))
+ (menu-set-add-menu *wio-menu-set* 'command nil "Commands"
+ commands (list 0 0))
+ (menu-set-adjust *wio-menu-set* 'command 'top nil 2)
+ (menu-set-adjust *wio-menu-set* 'command 'right nil 2)
+ ))
+
+; 19 Apr 95; 20 Apr 95; 25 Apr 95; 02 May 95; 29 May 02
+; Lisp server example
+(gldefun lisp-server ()
+ (let (w inputm done sel (redraw t) str result)
+ (w = (wio-window "Lisp Server"))
+ (open w)
+ (clear w)
+ (set-font w *wio-font*)
+ (wio-init-menus w '(("Quit" . quit)))
+ (window-print-lines w
+ '("Click mouse in the input box, then enter"
+ "a Lisp expression followed by Return."
+ ""
+ "Input: e.g. (+ 3 4) or (sqrt 2)")
+ 10 (- *wio-window-height* 20))
+ (window-printat-xy w "Result:" 10 (- *wio-window-height* 150))
+ (inputm = (textmenu-create (- *wio-window-width* 100) 30 nil w
+ 20 (- *wio-window-height* 110) t t '9x15 t))
+ (add-item *wio-menu-set* 'input nil inputm)
+ (while ~ done do
+ (sel = (menu-set-select *wio-menu-set* redraw))
+ (redraw = nil)
+ (case (menu-name sel)
+ (command
+ (case (port sel)
+ (quit (done = t))
+ ))
+ (input (str = (port sel))
+ (result = (catch 'error
+ (eval (safe-read-from-string str))))
+ (erase-area-xy w 20 2 (- *wio-window-width* 20)
+ (- *wio-window-height* 160))
+ (window-print-line w (write-to-string result :pretty t)
+ 20 (- *wio-window-height* 170)))
+ ) )
+ (close w)
+ ))
+
+; 25 Apr 95; 14 Mar 01
+(defun safe-read-from-string (str)
+ (if (and (stringp str) (> (length str) 0))
+ (read-from-string str nil 'read-error)))
+
+(defun compile-lispserver ()
+ (glcompfiles *directory*
+ '("glisp/vector.lsp") ; auxiliary files
+ '("glisp/lispserver.lsp") ; translated files
+ "glisp/lispservertrans.lsp") ; output file
+ )
Index: xgcl-2/gcl_lispservertrans.lsp
===================================================================
RCS file: xgcl-2/gcl_lispservertrans.lsp
diff -N xgcl-2/gcl_lispservertrans.lsp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ xgcl-2/gcl_lispservertrans.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.1
@@ -0,0 +1,110 @@
+; 27 Jan 2006 14:38:08 CST
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 2 of the License, or
+; (at your option) any later version.
+
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(DEFVAR *WIO-WINDOW* NIL)
+
+(DEFVAR *WIO-WINDOW-WIDTH* 500)
+
+(DEFVAR *WIO-WINDOW-HEIGHT* 300)
+
+(DEFVAR *WIO-MENU-SET* NIL)
+
+(DEFVAR *WIO-FONT* '8X13)
+
+(DEFVAR *WIO-WINDOW*)
+(SETF (GET '*WIO-WINDOW* 'GLISPGLOBALVAR) T)
+(SETF (GET '*WIO-WINDOW* 'GLISPGLOBALVARTYPE) 'WINDOW)
+(DEFVAR *WIO-WINDOW-WIDTH*)
+(SETF (GET '*WIO-WINDOW-WIDTH* 'GLISPGLOBALVAR) T)
+(SETF (GET '*WIO-WINDOW-WIDTH* 'GLISPGLOBALVARTYPE) 'INTEGER)
+(DEFVAR *WIO-WINDOW-HEIGHT*)
+(SETF (GET '*WIO-WINDOW-HEIGHT* 'GLISPGLOBALVAR) T)
+(SETF (GET '*WIO-WINDOW-HEIGHT* 'GLISPGLOBALVARTYPE) 'INTEGER)
+(DEFVAR *WIO-MENU-SET*)
+(SETF (GET '*WIO-MENU-SET* 'GLISPGLOBALVAR) T)
+(SETF (GET '*WIO-MENU-SET* 'GLISPGLOBALVARTYPE) 'MENU-SET)
+
+
+(DEFMACRO WHILE (TEST &REST FORMS)
+ (LIST* 'LOOP (LIST 'UNLESS TEST '(RETURN)) FORMS))
+
+(SETF (GET 'WIO-WINDOW 'GLFNRESULTTYPE) 'WINDOW)
+
+(DEFUN WIO-WINDOW (&OPTIONAL TITLE WIDTH HEIGHT (POSX 0) (POSY 0) FONT)
+ (IF WIDTH (SETQ *WIO-WINDOW-WIDTH* WIDTH))
+ (IF HEIGHT (SETQ *WIO-WINDOW-HEIGHT* HEIGHT))
+ (OR *WIO-WINDOW*
+ (SETQ *WIO-WINDOW*
+ (WINDOW-CREATE *WIO-WINDOW-WIDTH* *WIO-WINDOW-HEIGHT* TITLE
+ NIL POSX POSY FONT))))
+
+(DEFUN WIO-INIT-MENUS (W COMMANDS)
+ (LET ()
+ (WINDOW-CLEAR W)
+ (SETQ *WIO-MENU-SET* (MENU-SET-CREATE W NIL))
+ (MENU-SET-ADD-MENU *WIO-MENU-SET* 'COMMAND NIL "Commands" COMMANDS
+ (LIST 0 0))
+ (MENU-SET-ADJUST *WIO-MENU-SET* 'COMMAND 'TOP NIL 2)
+ (MENU-SET-ADJUST *WIO-MENU-SET* 'COMMAND 'RIGHT NIL 2)))
+
+(DEFUN LISP-SERVER ()
+ (LET (W INPUTM DONE SEL (REDRAW T) STR RESULT)
+ (SETQ W (WIO-WINDOW "Lisp Server"))
+ (WINDOW-OPEN W)
+ (WINDOW-CLEAR W)
+ (WINDOW-SET-FONT W *WIO-FONT*)
+ (WIO-INIT-MENUS W '(("Quit" . QUIT)))
+ (WINDOW-PRINT-LINES W
+ '("Click mouse in the input box, then enter"
+ "a Lisp expression followed by Return." ""
+ "Input: e.g. (+ 3 4) or (sqrt 2)")
+ 10 (+ -20 *WIO-WINDOW-HEIGHT*))
+ (WINDOW-PRINTAT-XY W "Result:" 10 (+ -150 *WIO-WINDOW-HEIGHT*))
+ (SETQ INPUTM
+ (TEXTMENU-CREATE (+ -100 *WIO-WINDOW-WIDTH*) 30 NIL W 20
+ (+ -110 *WIO-WINDOW-HEIGHT*) T T '9X15 T))
+ (MENU-SET-ADD-ITEM *WIO-MENU-SET* 'INPUT NIL INPUTM)
+ (WHILE (NOT DONE)
+ (SETQ SEL (MENU-SET-SELECT *WIO-MENU-SET* REDRAW))
+ (SETQ REDRAW NIL)
+ (CASE (CADR SEL)
+ (COMMAND (CASE (CAR SEL) (QUIT (SETQ DONE T))))
+ (INPUT (SETQ STR (CAR SEL))
+ (SETQ RESULT
+ (CATCH 'ERROR
+ (EVAL (SAFE-READ-FROM-STRING STR))))
+ (WINDOW-ERASE-AREA-XY W 20 2
+ (+ -20 *WIO-WINDOW-WIDTH*)
+ (+ -160 *WIO-WINDOW-HEIGHT*))
+ (WINDOW-PRINT-LINE W
+ (WRITE-TO-STRING RESULT :PRETTY T) 20
+ (+ -170 *WIO-WINDOW-HEIGHT*)))))
+ (WINDOW-CLOSE W)))
+
+(DEFUN SAFE-READ-FROM-STRING (STR)
+ (IF (AND (STRINGP STR) (> (LENGTH STR) 0))
+ (READ-FROM-STRING STR NIL 'READ-ERROR)))
+
+(DEFUN COMPILE-LISPSERVER ()
+ (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp")
+ '("glisp/lispserver.lsp") "glisp/lispservertrans.lsp"
+ "glisp/gpl.txt"))
+
+(DEFUN COMPILE-LISPSERVERB ()
+ (GLCOMPFILES *DIRECTORY*
+ '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp")
+ '("glisp/lispserver.lsp") "glisp/lispservertrans.lsp"
+ "glisp/gpl.txt"))
Index: xgcl-2/gcl_menu-settrans.lsp
===================================================================
RCS file: xgcl-2/gcl_menu-settrans.lsp
diff -N xgcl-2/gcl_menu-settrans.lsp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ xgcl-2/gcl_menu-settrans.lsp 9 Jun 2006 15:53:32 -0000 1.1.2.1
@@ -0,0 +1,507 @@
+; 27 Jan 2006 14:33:25 CST
+
+; menu-settrans.lsp -- translation of menu-set.lsp Gordon S. Novak Jr.
+
+; Copyright 2006 Gordon S. Novak Jr. and The University of Texas at Austin.
+
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 2 of the License, or
+; (at your option) any later version.
+
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+; Written by: Gordon S. Novak Jr., Department of Computer Sciences,
+; University of Texas at Austin 78712. address@hidden
+
+(defmacro nconc1 (lst x) `(nconc ,lst (cons ,x nil)))
+
+(defmacro glmethod (class selector)
+ `(cadr (assoc ,selector (getf (cdr (get ,class 'glstructure)) 'msg))) )
+
+(SETF (GET 'MENU-SET 'GLSTRUCTURE)
+ '((LISTOBJECT (WINDOW WINDOW) (MENU-ITEMS (LISTOF MENU-SET-ITEM))
+ (COMMANDFN ANYTHING))
+ MSG
+ ((DRAW MENU-SET-DRAW) (SELECT MENU-SET-SELECT)
+ (NAMED-MENU MENU-SET-NAMED-MENU)
+ (NAMED-ITEM MENU-SET-NAMED-ITEM) (ADD-MENU MENU-SET-ADD-MENU)
+ (ADD-PICMENU MENU-SET-ADD-PICMENU)
+ (ADD-COMPONENT MENU-SET-ADD-COMPONENT)
+ (ADD-BARMENU MENU-SET-ADD-BARMENU)
+ (ADD-ITEM MENU-SET-ADD-ITEM) (FIND-ITEM MENU-SET-FIND-ITEM)
+ (DELETE-ITEM MENU-SET-DELETE-ITEM)
+ (REMOVE-ITEMS MENU-SET-REMOVE-ITEMS)
+ (ITEM-POSITION MENU-SET-ITEM-POSITION)
+ (ADJUST MENU-SET-ADJUST) (MOVE MENU-SET-MOVE)
+ (DRAW-CONN MENU-SET-DRAW-CONN))))
+(SETF (GET 'MENU-SET-ITEM 'GLSTRUCTURE)
+ '((LIST (MENU-NAME SYMBOL) (SYM ANYTHING) (MENU MENU-SET-MENU))
+ PROP
+ ((LEFT ((PARENT-OFFSET-X MENU)))
+ (BOTTOM ((PARENT-OFFSET-Y MENU)))
+ (WIDTH ((PICTURE-WIDTH MENU)))
+ (HEIGHT ((PICTURE-HEIGHT MENU))))
+ SUPERS (REGION)))
+(SETF (GET 'MENU-SET-MENU 'GLSTRUCTURE)
+ '((TRANSPARENT MENU) MSG ((DRAW MENU-MDRAW))))
+(SETF (GET 'MENU-PORT 'GLSTRUCTURE)
+ '((LIST (PORT SYMBOL) (MENU-NAME SYMBOL))))
+(SETF (GET 'MENU-SELECTION 'GLSTRUCTURE)
+ '((LIST (PORT SYMBOL) (MENU-NAME SYMBOL) (BUTTON INTEGER))))
+(SETF (GET 'MENU-SET-CONN 'GLSTRUCTURE)
+ '((LIST (FROM MENU-PORT) (TO MENU-PORT))))
+(SETF (GET 'MENU-CONNS 'GLSTRUCTURE)
+ '((LISTOBJECT (MENU-SET MENU-SET)
+ (CONNECTIONS (LISTOF MENU-SET-CONN)))
+ PROP ((WINDOW ((WINDOW (MENU-SET SELF))))) MSG
+ ((DRAW MENU-CONNS-DRAW) (REDRAW MENU-CONNS-REDRAW)
+ (MOVE MENU-CONNS-MOVE) (ADD-CONN MENU-CONNS-ADD-CONN)
+ (ADD-ITEM MENU-CONNS-ADD-ITEM OPEN T)
+ (FIND-CONN MENU-CONNS-FIND-CONN)
+ (FIND-ITEM MENU-CONNS-FIND-ITEM)
+ (DELETE-ITEM MENU-CONNS-DELETE-ITEM)
+ (DELETE-CONN MENU-CONNS-DELETE-CONN)
+ (REMOVE-ITEMS MENU-CONNS-REMOVE-ITEMS)
+ (FIND-CONNS MENU-CONNS-FIND-CONNS)
+ (CONNECTED-PORTS MENU-CONNS-CONNECTED-PORTS)
+ (NEW-CONN MENU-CONNS-NEW-CONN)
+ (NAMED-MENU MENU-CONNS-NAMED-MENU)
+ (NAMED-ITEM MENU-CONNS-NAMED-ITEM))))
+
+
+(DEFUN MENU-SET-CREATE (W &OPTIONAL FN) (LIST 'MENU-SET W NIL FN))
+(SETF (GET 'MENU-SET-CREATE 'GLARGUMENTS)
+ '((W WINDOW) (&OPTIONAL NIL) (FN NIL)))
+(SETF (GET 'MENU-SET-CREATE 'GLFNRESULTTYPE) 'MENU-SET)
+
+
+(DEFUN MENU-SET-SELECT (MS &OPTIONAL REDRAW ENABLED)
+ (LET (RES RESB ITM SEL LASTX LASTY)
+ (IF REDRAW (MENU-SET-DRAW MS))
+ (WHILE (NOT (OR RES RESB))
+ (SETQ ITM
+ (WINDOW-TRACK-MOUSE (CADR MS)
+ #'(LAMBDA (X Y CODE)
+ (OR (AND (PLUSP CODE) (SETQ LASTX X)
+ (SETQ LASTY Y) CODE)
+ (SOME #'(LAMBDA (GLVAR19345)
+ (IF
+ (AND
+ (>= X
+ (FIFTH (CADDR GLVAR19345)))
+ (<= X
+ (+ (FIFTH (CADDR GLVAR19345))
+ (SEVENTH (CADDR GLVAR19345))))
+ (>= Y
+ (SIXTH (CADDR GLVAR19345)))
+ (<= Y
+ (+ (SIXTH (CADDR GLVAR19345))
+ (EIGHTH (CADDR GLVAR19345)))))
+ GLVAR19345))
+ (CADDR MS))))))
+ (IF (NUMBERP ITM)
+ (SETQ RESB (LIST (LIST LASTX LASTY) 'BACKGROUND ITM))
+ (WHEN (OR (ATOM ENABLED) (MEMBER (CAR ITM) ENABLED))
+ (SETQ SEL (MENU-MSELECT (CADDR ITM) (EQ ENABLED T)))
+ (IF SEL
+ (SETQ RES (LIST SEL (CAR ITM) *WINDOW-MENU-CODE*))
+ (IF (AND *WINDOW-MENU-CODE*
+ (NOT (ZEROP *WINDOW-MENU-CODE*)))
+ (SETQ RES
+ (LIST NIL (CAR ITM) *WINDOW-MENU-CODE*)))))))
+ (WINDOW-FORCE-OUTPUT (CADR MS))
+ (OR RES RESB)))
+(SETF (GET 'MENU-SET-SELECT 'GLARGUMENTS)
+ '((MS MENU-SET) (&OPTIONAL NIL) (REDRAW BOOLEAN)
+ (ENABLED (LISTOF SYMBOL))))
+(SETF (GET 'MENU-SET-SELECT 'GLFNRESULTTYPE) 'MENU-SELECTION)
+
+
+(DEFUN MENU-SET-ADD-MENU (MS NAME SYM TITLE ITEMS &OPTIONAL OFFSET)
+ (LET (MENU)
+ (SETQ MENU
+ (MENU-CREATE ITEMS TITLE (CADR MS) (CAR OFFSET) (CADR OFFSET)
+ T T))
+ (MENU-INIT MENU)
+ (IF (NOT OFFSET)
+ (SETQ OFFSET
+ (WINDOW-GET-BOX-POSITION (CADR MS) (SEVENTH MENU)
+ (EIGHTH MENU))))
+ (SETF (FIFTH MENU) (CAR OFFSET))
+ (SETF (SIXTH MENU) (CADR OFFSET))
+ (MENU-SET-ADD-ITEM MS NAME SYM MENU)))
+(SETF (GET 'MENU-SET-ADD-MENU 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (TITLE STRING)
+ (ITEMS NIL) (&OPTIONAL NIL) (OFFSET VECTOR)))
+(SETF (GET 'MENU-SET-ADD-MENU 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM))
+
+
+(DEFUN MENU-SET-ADD-ITEM (MS NAME SYM MENU)
+ (SETF (CADDR MS) (NCONC (CADDR MS) (CONS (LIST NAME SYM MENU) NIL))))
+(SETF (GET 'MENU-SET-ADD-ITEM 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (MENU MENU)))
+(SETF (GET 'MENU-SET-ADD-ITEM 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM))
+
+
+(DEFUN MENU-SET-REMOVE-ITEMS (MS) (SETF (CADDR MS) NIL))
+(SETF (GET 'MENU-SET-REMOVE-ITEMS 'GLARGUMENTS) '((MS MENU-SET)))
+(SETF (GET 'MENU-SET-REMOVE-ITEMS 'GLFNRESULTTYPE)
+ '(LISTOF MENU-SET-ITEM))
+
+
+(DEFUN MENU-SET-ADD-PICMENU
+ (MS NAME SYM TITLE SPEC &OPTIONAL OFFSET NOBOX)
+ (LET (MENU MAXWIDTH MAXHEIGHT)
+ (IF (AND SPEC (SYMBOLP SPEC)) (SETQ SPEC (GET SPEC 'PICMENU-SPEC)))
+ (SETQ MENU
+ (PICMENU-CREATE-FROM-SPEC SPEC TITLE (CADR MS) (CAR OFFSET)
+ (CADR OFFSET) T T (NOT NOBOX)))
+ (SETQ MAXWIDTH
+ (MAX (IF TITLE (+ 6 (* 9 (LENGTH TITLE))) 0) (CADR SPEC)))
+ (SETQ MAXHEIGHT (+ (IF TITLE 15 0) (CADDR SPEC)))
+ (IF (NOT OFFSET)
+ (SETQ OFFSET
+ (WINDOW-GET-BOX-POSITION (CADR MS) MAXWIDTH MAXHEIGHT)))
+ (SETF (FIFTH MENU) (CAR OFFSET))
+ (SETF (SIXTH MENU) (CADR OFFSET))
+ (MENU-SET-ADD-ITEM MS NAME SYM MENU)))
+(SETF (GET 'MENU-SET-ADD-PICMENU 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (TITLE STRING)
+ (SPEC PICMENU-SPEC) (&OPTIONAL NIL) (OFFSET VECTOR)
+ (NOBOX BOOLEAN)))
+(SETF (GET 'MENU-SET-ADD-PICMENU 'GLFNRESULTTYPE)
+ '(LISTOF MENU-SET-ITEM))
+
+
+(DEFUN MENU-SET-ADD-COMPONENT (MS NAME &OPTIONAL OFFSET)
+ (MENU-SET-ADD-PICMENU MS (MENU-SET-NAME NAME) NAME NIL NAME OFFSET T))
+(SETF (GET 'MENU-SET-ADD-COMPONENT 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL) (&OPTIONAL NIL) (OFFSET VECTOR)))
+(SETF (GET 'MENU-SET-ADD-COMPONENT 'GLFNRESULTTYPE)
+ '(LISTOF MENU-SET-ITEM))
+
+
+(DEFUN MENU-SET-ADD-BARMENU (MS NAME SYM MENU TITLE &OPTIONAL OFFSET)
+ (BARMENU-INIT MENU)
+ (IF (NOT OFFSET)
+ (SETQ OFFSET
+ (WINDOW-GET-BOX-POSITION (CADR MS) (SEVENTH MENU)
+ (EIGHTH MENU))))
+ (SETF (FIFTH MENU) (CAR OFFSET))
+ (SETF (SIXTH MENU) (CADR OFFSET))
+ (MENU-SET-ADD-ITEM MS NAME SYM MENU))
+(SETF (GET 'MENU-SET-ADD-BARMENU 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (MENU BARMENU)
+ (TITLE STRING) (&OPTIONAL NIL) (OFFSET VECTOR)))
+(SETF (GET 'MENU-SET-ADD-BARMENU 'GLFNRESULTTYPE)
+ '(LISTOF MENU-SET-ITEM))
+
+
+(DEFUN MENU-SET-NAME (NM)
+ (INTERN (SYMBOL-NAME (GENSYM (SYMBOL-NAME NM)))))
+(SETF (GET 'MENU-SET-NAME 'GLARGUMENTS) '((NM SYMBOL)))
+(SETF (GET 'MENU-SET-NAME 'GLFNRESULTTYPE) 'SYMBOL)
+
+
+(DEFUN MENU-SET-NAMED-ITEM (MS NAME) (ASSOC NAME (CADDR MS)))
+(SETF (GET 'MENU-SET-NAMED-ITEM 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL)))
+(SETF (GET 'MENU-SET-NAMED-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM)
+
+
+(DEFUN MENU-SET-NAMED-MENU (MS NAME)
+ (CADDR (MENU-SET-NAMED-ITEM MS NAME)))
+(SETF (GET 'MENU-SET-NAMED-MENU 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL)))
+(SETF (GET 'MENU-SET-NAMED-MENU 'GLFNRESULTTYPE) 'MENU-SET-MENU)
+
+
+(DEFUN MENU-CONNS-NAMED-ITEM (MC NAME)
+ (MENU-SET-NAMED-ITEM (CADR MC) NAME))
+(SETF (GET 'MENU-CONNS-NAMED-ITEM 'GLARGUMENTS)
+ '((MC MENU-CONNS) (NAME SYMBOL)))
+(SETF (GET 'MENU-CONNS-NAMED-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM)
+
+
+(DEFUN MENU-CONNS-NAMED-MENU (MC NAME)
+ (MENU-SET-NAMED-MENU (CADR MC) NAME))
+(SETF (GET 'MENU-CONNS-NAMED-MENU 'GLARGUMENTS)
+ '((MC MENU-CONNS) (NAME SYMBOL)))
+(SETF (GET 'MENU-CONNS-NAMED-MENU 'GLFNRESULTTYPE) 'MENU-SET-MENU)
+
+
+(DEFUN MENU-SET-FIND-ITEM (MS POS)
+ (LET (MITEM)
+ (DOLIST (MI (CADDR MS))
+ (IF (AND (>= (CAR POS)
+ (LET ((SELF (CADDR MI)))
+ (IF (CADDR SELF) (FIFTH SELF) 0)))
+ (<= (CAR POS)
+ (+ (LET ((SELF (CADDR MI)))
+ (IF (CADDR SELF) (FIFTH SELF) 0))
+ (SEVENTH (CADDR MI))))
+ (>= (CADR POS)
+ (LET ((SELF (CADDR MI)))
+ (IF (CADDR SELF) (SIXTH SELF) 0)))
+ (<= (CADR POS)
+ (+ (LET ((SELF (CADDR MI)))
+ (IF (CADDR SELF) (SIXTH SELF) 0))
+ (EIGHTH (CADDR MI)))))
+ (SETQ MITEM MI)))
+ MITEM))
+(SETF (GET 'MENU-SET-FIND-ITEM 'GLARGUMENTS)
+ '((MS MENU-SET) (POS VECTOR)))
+(SETF (GET 'MENU-SET-FIND-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM)
+
+
+(DEFUN MENU-SET-DELETE-ITEM (MS MI)
+ (SETF (CADDR MS) (REMOVE MI (CADDR MS))))
+(SETF (GET 'MENU-SET-DELETE-ITEM 'GLARGUMENTS)
+ '((MS MENU-SET) (MI MENU-SET-ITEM)))
+(SETF (GET 'MENU-SET-DELETE-ITEM 'GLFNRESULTTYPE)
+ '(LISTOF MENU-SET-ITEM))
+
+
+(DEFUN MENU-SET-MOVE (MS)
+ (LET (SEL M)
+ (SETQ SEL (MENU-SET-SELECT MS NIL T))
+ (SETQ M (MENU-SET-NAMED-MENU MS (CADR SEL)))
+ (MENU-REPOSITION M)))
+
+(DEFUN MENU-MDRAW (M)
+ (CASE (FIRST M)
+ (MENU (MENU-DRAW M))
+ (PICMENU (PICMENU-DRAW M))
+ (BARMENU (BARMENU-DRAW M))
+ (TEXTMENU (TEXTMENU-DRAW M))
+ (EDITMENU (EDITMENU-DRAW M))
+ (T (GLSEND M DRAW))))
+
+(DEFUN MENU-MSELECT (M &OPTIONAL ANYCLICK)
+ (CASE (FIRST M)
+ (MENU (MENU-SELECT M T))
+ (PICMENU (PICMENU-SELECT M T ANYCLICK))
+ (BARMENU (BARMENU-SELECT M))
+ (TEXTMENU (TEXTMENU-SELECT M T))
+ (EDITMENU (EDITMENU-SELECT M T))
+ (T (GLSEND M SELECT))))
+
+(DEFUN MENU-MITEM-POSITION (M NAME LOC)
+ (CASE (FIRST M)
+ (MENU (MENU-ITEM-POSITION M NAME LOC))
+ (PICMENU (PICMENU-ITEM-POSITION M NAME LOC))
+ (T (GLSEND M ITEM-POSITION NAME LOC))))
+
+(DEFUN MENU-SET-DRAW (MS)
+ (WINDOW-OPEN (CADR MS))
+ (DOLIST (ITEM (CADDR MS)) (MENU-MDRAW (CADDR ITEM))))
+
+(DEFUN MENU-SET-ITEM-POSITION (MS DESC &OPTIONAL LOC)
+ (LET (M)
+ (SETQ M (MENU-SET-NAMED-MENU MS (CADR DESC)))
+ (OR (MENU-MITEM-POSITION M (CAR DESC) LOC)
+ (MENU-MITEM-POSITION M NIL LOC))))
+(SETF (GET 'MENU-SET-ITEM-POSITION 'GLARGUMENTS)
+ '((MS MENU-SET) (DESC MENU-PORT) (&OPTIONAL NIL) (LOC SYMBOL)))
+(SETF (GET 'MENU-SET-ITEM-POSITION 'GLFNRESULTTYPE) 'VECTOR)
+
+
+(DEFUN MENU-SET-DRAW-CONN (MS CONN)
+ (LET (PA PB TMP (DESCA (CAR CONN)) (DESCB (CADR CONN)))
+ (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'CENTER))
+ (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'CENTER))
+ (WHEN (> (CAR PA) (CAR PB))
+ (SETQ TMP DESCA)
+ (SETQ DESCA DESCB)
+ (SETQ DESCB TMP))
+ (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'RIGHT))
+ (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'LEFT))
+ (WINDOW-DRAW-CIRCLE (CADR MS) PA 3)
+ (WINDOW-DRAW-LINE (CADR MS) PA PB)
+ (WINDOW-DRAW-CIRCLE (CADR MS) PB 3)
+ (WINDOW-FORCE-OUTPUT (CADR MS))))
+
+(DEFUN MENU-SET-ADJUST (MS NAME EDGE FROM OFFSET)
+ (LET (M FROMM PLACE)
+ (WHEN (SETQ M (MENU-SET-NAMED-ITEM MS NAME))
+ (IF FROM
+ (PROGN
+ (SETQ FROMM (MENU-SET-NAMED-ITEM MS FROM))
+ (SETQ PLACE
+ (CASE EDGE
+ (TOP (SIXTH (CADDR FROMM)))
+ (BOTTOM (+ (SIXTH (CADDR FROMM))
+ (EIGHTH (CADDR FROMM))))
+ (LEFT (+ (FIFTH (CADDR FROMM))
+ (SEVENTH (CADDR FROMM))))
+ (RIGHT (FIFTH (CADDR FROMM))))))
+ (SETQ PLACE
+ (CASE EDGE
+ (TOP (CADDDR (CADR MS)))
+ ((BOTTOM LEFT) 0)
+ (RIGHT (FIFTH (CADR MS))))))
+ (CASE EDGE
+ (TOP (SETF (SIXTH (CADDR M))
+ (- (- PLACE (EIGHTH (CADDR M))) OFFSET)))
+ (BOTTOM (SETF (SIXTH (CADDR M)) (+ PLACE OFFSET)))
+ (LEFT (SETF (FIFTH (CADDR M)) (+ PLACE OFFSET)))
+ (RIGHT (SETF (FIFTH (CADDR M))
+ (- (- PLACE (SEVENTH (CADDR M))) OFFSET)))))))
+(SETF (GET 'MENU-SET-ADJUST 'GLARGUMENTS)
+ '((MS MENU-SET) (NAME SYMBOL) (EDGE SYMBOL) (FROM SYMBOL)
+ (OFFSET INTEGER)))
+(SETF (GET 'MENU-SET-ADJUST 'GLFNRESULTTYPE) 'INTEGER)
+
+
+(DEFUN MENU-CONNS-CREATE (MS) (LIST 'MENU-CONNS MS NIL))
+(SETF (GET 'MENU-CONNS-CREATE 'GLARGUMENTS) '((MS MENU-SET)))
+(SETF (GET 'MENU-CONNS-CREATE 'GLFNRESULTTYPE) 'MENU-CONNS)
+
+
+(DEFUN MENU-CONNS-DRAW (MC)
+ (MENU-SET-DRAW (CADR MC))
+ (DOLIST (C (CADDR MC)) (MENU-SET-DRAW-CONN (CADR MC) C)))
+
+(DEFUN MENU-CONNS-MOVE (MC)
+ (MENU-SET-MOVE (CADR MC))
+ (WINDOW-CLEAR (CADADR MC))
+ (MENU-CONNS-DRAW MC))
+
+(DEFUN MENU-CONNS-REDRAW (MC)
+ (WINDOW-CLEAR (CADADR MC))
+ (MENU-CONNS-DRAW MC))
+
+(DEFUN MENU-CONNS-ADD-CONN (MC)
+ (LET (SEL SELB CONN)
+ (SETQ SEL (MENU-SET-SELECT (CADR MC)))
+ (IF (EQ (CADR SEL) 'BACKGROUND) SEL
+ (PROGN
+ (SETQ SELB (MENU-SET-SELECT (CADR MC)))
+ (WHEN (NOT (EQ (CADR SELB) 'BACKGROUND))
+ (SETQ CONN (LIST SEL SELB))
+ (MENU-SET-DRAW-CONN (CADR MC) CONN)
+ (SETF (CADDR MC) (NCONC (CADDR MC) (CONS CONN NIL))))
+ NIL))))
+(SETF (GET 'MENU-CONNS-ADD-CONN 'GLARGUMENTS) '((MC MENU-CONNS)))
+(SETF (GET 'MENU-CONNS-ADD-CONN 'GLFNRESULTTYPE) 'MENU-SELECTION)
+
+
+(DEFUN MENU-CONNS-NEW-CONN (MC FROMNAME FROMPORT TONAME TOPORT)
+ (LET (CONN)
+ (SETQ CONN (LIST (LIST FROMPORT FROMNAME) (LIST TOPORT TONAME)))
+ (SETF (CADDR MC) (NCONC (CADDR MC) (CONS CONN NIL)))))
+(SETF (GET 'MENU-CONNS-NEW-CONN 'GLARGUMENTS)
+ '((MC MENU-CONNS) (FROMNAME SYMBOL) (FROMPORT SYMBOL)
+ (TONAME SYMBOL) (TOPORT SYMBOL)))
+(SETF (GET 'MENU-CONNS-NEW-CONN 'GLFNRESULTTYPE)
+ '(LISTOF MENU-SET-CONN))
+
+
+(DEFUN MENU-CONNS-ADD-ITEM (MC NAME SYM MENU)
+ (MENU-SET-ADD-ITEM (CADR MC) NAME SYM MENU))
+(SETF (GET 'MENU-CONNS-ADD-ITEM 'GLARGUMENTS)
+ '((MC MENU-CONNS) (NAME SYMBOL) (SYM SYMBOL) (MENU MENU)))
+(SETF (GET 'MENU-CONNS-ADD-ITEM 'GLFNRESULTTYPE)
+ '(LISTOF MENU-SET-ITEM))
+
+
+(DEFUN MENU-CONNS-FIND-CONN (MC PT)
+ (LET (MS LS FOUND RES PA PB TMP DESCA DESCB)
+ (SETQ LS (LIST (COPY-LIST '(0 0)) (COPY-LIST '(0 0))))
+ (SETQ MS (CADR MC))
+ (DOLIST (CONN (CADDR MC))
+ (UNLESS FOUND
+ (SETQ DESCA (CAR CONN))
+ (SETQ DESCB (CADR CONN))
+ (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'CENTER))
+ (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'CENTER))
+ (WHEN (> (CAR PA) (CAR PB))
+ (SETQ TMP DESCA)
+ (SETQ DESCA DESCB)
+ (SETQ DESCB TMP))
+ (SETF (CAR LS) (MENU-SET-ITEM-POSITION MS DESCA 'RIGHT))
+ (SETF (CADR LS) (MENU-SET-ITEM-POSITION MS DESCB 'LEFT))
+ (WHEN (< (ABS (/ (- (* (- (CAADR LS) (CAAR LS))
+ (- (CADR PT) (CADAR LS)))
+ (* (- (CADADR LS) (CADAR LS))
+ (- (CAR PT) (CAAR LS))))
+ (SQRT (+ (EXPT (- (CAADR LS) (CAAR LS)) 2)
+ (EXPT (- (CADADR LS) (CADAR LS)) 2)))))
+ 5)
+ (SETQ FOUND T)
+ (SETQ RES CONN))))
+ RES))
+(SETF (GET 'MENU-CONNS-FIND-CONN 'GLARGUMENTS)
+ '((MC MENU-CONNS) (PT VECTOR)))
+(SETF (GET 'MENU-CONNS-FIND-CONN 'GLFNRESULTTYPE) 'MENU-SET-CONN)
+
+
+(DEFUN MENU-CONNS-FIND-ITEM (MC PT) (MENU-SET-FIND-ITEM (CADR MC) PT))
+(SETF (GET 'MENU-CONNS-FIND-ITEM 'GLARGUMENTS)
+ '((MC MENU-CONNS) (PT VECTOR)))
+(SETF (GET 'MENU-CONNS-FIND-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM)
+
+
+(DEFUN MENU-CONNS-DELETE-CONN (MC CONN)
+ (SETF (CADDR MC) (REMOVE CONN (CADDR MC))))
+(SETF (GET 'MENU-CONNS-DELETE-CONN 'GLARGUMENTS)
+ '((MC MENU-CONNS) (CONN MENU-SET-CONN)))
+(SETF (GET 'MENU-CONNS-DELETE-CONN 'GLFNRESULTTYPE)
+ '(LISTOF MENU-SET-CONN))
+
+
+(DEFUN MENU-CONNS-DELETE-ITEM (MC MI)
+ (LET (MS)
+ (SETQ MS (CADR MC))
+ (MENU-SET-DELETE-ITEM MS MI)
+ (DOLIST (CONN (CADDR MC))
+ (IF (OR (EQ (CADAR CONN) (CAR MI)) (EQ (CADADR CONN) (CAR MI)))
+ (MENU-CONNS-DELETE-CONN MC CONN)))))
+
+(DEFUN MENU-CONNS-REMOVE-ITEMS (MC)
+ (MENU-SET-REMOVE-ITEMS (CADR MC))
+ (SETF (CADDR MC) NIL))
+(SETF (GET 'MENU-CONNS-REMOVE-ITEMS 'GLARGUMENTS) '((MC MENU-CONNS)))
+(SETF (GET 'MENU-CONNS-REMOVE-ITEMS 'GLFNRESULTTYPE)
+ '(LISTOF MENU-SET-CONN))
+
+
+(DEFUN MENU-CONNS-CONNECTED-PORTS (MC BOXNAME)
+ (LET (PORTS)
+ (DOLIST (CONN (CADDR MC))
+ (IF (EQ BOXNAME (CADADR CONN)) (PUSHNEW (CAADR CONN) PORTS)
+ (IF (EQ BOXNAME (CADAR CONN)) (PUSHNEW (CAAR CONN) PORTS))))
+ PORTS))
+
+(DEFUN MENU-CONNS-FIND-CONNS (MC BOXNAME PORT)
+ (LET (RES)
+ (DOLIST (CONN (CADDR MC))
+ (IF (AND (EQ BOXNAME (CADADR CONN)) (EQ PORT (CAADR CONN)))
+ (SETQ RES (NCONC RES (CONS (CAR CONN) NIL))))
+ (IF (AND (EQ BOXNAME (CADAR CONN)) (EQ PORT (CAAR CONN)))
+ (SETQ RES (NCONC RES (CONS (CADR CONN) NIL)))))
+ RES))
+(SETF (GET 'MENU-CONNS-FIND-CONNS 'GLARGUMENTS)
+ '((MC MENU-CONNS) (BOXNAME SYMBOL) (PORT SYMBOL)))
+(SETF (GET 'MENU-CONNS-FIND-CONNS 'GLFNRESULTTYPE) '(LISTOF MENU-PORT))
+
+
+(DEFUN COMPILE-MENU-SET ()
+ (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp")
+ '("glisp/menu-set.lsp") "glisp/menu-settrans.lsp"
+ "glisp/menu-set-header.lsp")
+ (COMPILE-FILE "glisp/menu-settrans.lsp"))
+
+(DEFUN COMPILE-MENU-SETB ()
+ (GLCOMPFILES *DIRECTORY*
+ '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp")
+ '("glisp/menu-set.lsp") "glisp/menu-settrans.lsp"
+ "glisp/menu-set-header.lsp"))
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Gcl-commits] gcl acconfig.h configure configure.in makefile ... [Version_2_6_8pre],
Camm Maguire <=