writing reading and printing functions

qse/ac/ltmain.sh

@@ -65,7 +65,7 @@
 #       compiler:		$LTCC
 #       compiler flags:		$LTCFLAGS
 #       linker:		$LD (gnu? $with_gnu_ld)
-#       $progname:		(GNU libtool) 2.2.6b Debian-2.2.6b-2
+#       $progname:		(GNU libtool) 2.2.6b Debian-2.2.6b-2ubuntu1
 #       automake:		$automake_version
 #       autoconf:		$autoconf_version
 #
@@ -73,7 +73,7 @@
 
 PROGRAM=ltmain.sh
 PACKAGE=libtool
-VERSION="2.2.6b Debian-2.2.6b-2"
+VERSION="2.2.6b Debian-2.2.6b-2ubuntu1"
 TIMESTAMP=""
 package_revision=1.3017
 

qse/cmd/scm/scm.c

@@ -164,6 +164,8 @@ int scm_main (int argc, qse_char_t* argv[])
 		qse_scm_attachio (scm, &io);
 	}
 
+qse_scm_read (scm);
+
 #if 0
 	while (1)
 	{

qse/configure

@@ -15004,37 +15004,26 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
 
 
 
-#dnl overrides the default CFLAGS setting
+if test "$ac_test_CFLAGS" != "set"
-#if test "$ac_test_CFLAGS" = "set"
+then
-#then
+	if test "$GCC" = "yes"
-#	CFLAGS=$ac_save_CFLAGS
+	then
-#else
+		CFLAGS="$CFLAGS -Wall"
-#	if test "$GCC" = "yes"
+	fi
-#	then
+fi
-#		CFLAGS="-O2"
-#	else
-#		CFLAGS=
-#	fi
-#fi
 
-#if test "$ac_test_CXXFLAGS" = "set"
+if test "$ac_test_CXXFLAGS" != "set"
-#then
+then
-#	CXXFLAGS=$ac_save_CXXFLAGS
+	if test "$GCC" = "yes"
-#else
+	then
-#	if test "$GCC" = "yes"
+		CXXFLAGS="$CXXFLAGS -Wall"
-#	then
+	fi
-#		CXXFLAGS="-O2"
+fi
-#	else
-#		CXXFLAGS=
-#	fi
-#fi
 
 CFLAGS="$CFLAGS -DQSE_HAVE_CONFIG_H"
-OBJCFLAGS="$OBJCFLAGS -DQSE_HAVE_CONFIG_H"
 CXXFLAGS="$CXXFLAGS -DQSE_HAVE_CONFIG_H"
 
 CFLAGS="$CFLAGS -D_LARGEFILE64_SOURCE"
-OBJCFLAGS="$OBJCFLAGS -D_LARGEFILE64_SOURCE"
 CXXFLAGS="$CXXFLAGS -D_LARGEFILE64_SOURCE"
 
 case "$host" in
@@ -16624,13 +16613,11 @@ fi
 if test "$enable_debug_is" = "yes"
 then
 	CFLAGS="$CFLAGS -g -D_DEBUG -UNDEBUG -DQSE_BUILD_DEBUG"
-	OBJCFLAGS="$OBJCFLAGS -g -D_DEBUG -UNDEBUG -DQSE_BUILD_DEBUG"
 	CXXFLAGS="$CXXFLAGS -g -D_DEBUG -UNDEBUG -DQSE_BUILD_DEBUG"
 	BUILD_MODE="debug"
 
 else
 	CFLAGS="$CFLAGS -DNDEBUG -U_DEBUG -DQSE_BUILD_RELEASE"
-	OBJCFLAGS="$OBJCFLAGS -DNDEBUG -U_DEBUG -DQSE_BUILD_RELEASE"
 	CXXFLAGS="$CXXFLAGS -DNDEBUG -U_DEBUG -DQSE_BUILD_RELEASE"
 	BUILD_MODE="release"
 
@@ -16664,7 +16651,6 @@ fi
 if test "$enable_reentrant_is" = "yes"
 then
 	CFLAGS="$CFLAGS -D_REENTRANT -D_THREAD_SAFE"
-	OBJCFLAGS="$OBJCFLAGS -D_REENTRANT -D_THREAD_SAFE"
 	CXXFLAGS="$CXXFLAGS -D_REENTRANT -D_THREAD_SAFE"
 fi
 

qse/configure.ac

@@ -39,39 +39,29 @@ dnl initialize libtool
 AC_PROG_LIBTOOL
 AC_SUBST(LIBTOOL_DEPS)
 
-#dnl overrides the default CFLAGS setting
+dnl overrides the default CFLAGS setting
-#if test "$ac_test_CFLAGS" = "set"
+if test "$ac_test_CFLAGS" != "set"
-#then
+then
-#	CFLAGS=$ac_save_CFLAGS
+	if test "$GCC" = "yes"
-#else
+	then
-#	if test "$GCC" = "yes"
+		CFLAGS="$CFLAGS -Wall"
-#	then
+	fi
-#		CFLAGS="-O2"
+fi
-#	else
-#		CFLAGS=
-#	fi
-#fi
 
-#if test "$ac_test_CXXFLAGS" = "set"
+if test "$ac_test_CXXFLAGS" != "set"
-#then
+then
-#	CXXFLAGS=$ac_save_CXXFLAGS
+	if test "$GCC" = "yes"
-#else
+	then
-#	if test "$GCC" = "yes"
+		CXXFLAGS="$CXXFLAGS -Wall"
-#	then
+	fi
-#		CXXFLAGS="-O2"
+fi
-#	else
-#		CXXFLAGS=
-#	fi
-#fi
 
 dnl indicate the existence of config.h
 CFLAGS="$CFLAGS -DQSE_HAVE_CONFIG_H"
-OBJCFLAGS="$OBJCFLAGS -DQSE_HAVE_CONFIG_H"
 CXXFLAGS="$CXXFLAGS -DQSE_HAVE_CONFIG_H"
 
 dnl make visible the 64-bit interface to the file system
 CFLAGS="$CFLAGS -D_LARGEFILE64_SOURCE"
-OBJCFLAGS="$OBJCFLAGS -D_LARGEFILE64_SOURCE"
 CXXFLAGS="$CXXFLAGS -D_LARGEFILE64_SOURCE"
 
 dnl define the WIN32 conditional if necessary
@@ -203,12 +193,10 @@ AC_ARG_ENABLE([debug], [AC_HELP_STRING([--enable-debug],
 if test "$enable_debug_is" = "yes"
 then
 	[CFLAGS="$CFLAGS -g -D_DEBUG -UNDEBUG -DQSE_BUILD_DEBUG"]
-	[OBJCFLAGS="$OBJCFLAGS -g -D_DEBUG -UNDEBUG -DQSE_BUILD_DEBUG"]
 	[CXXFLAGS="$CXXFLAGS -g -D_DEBUG -UNDEBUG -DQSE_BUILD_DEBUG"]
 	AC_SUBST(BUILD_MODE, "debug")
 else
 	[CFLAGS="$CFLAGS -DNDEBUG -U_DEBUG -DQSE_BUILD_RELEASE"]
-	[OBJCFLAGS="$OBJCFLAGS -DNDEBUG -U_DEBUG -DQSE_BUILD_RELEASE"]
 	[CXXFLAGS="$CXXFLAGS -DNDEBUG -U_DEBUG -DQSE_BUILD_RELEASE"]
 	AC_SUBST(BUILD_MODE, "release")
 fi
@@ -226,7 +214,6 @@ AC_ARG_ENABLE([reentrant], [AC_HELP_STRING([--enable-reentrant],
 if test "$enable_reentrant_is" = "yes"
 then
 	[CFLAGS="$CFLAGS -D_REENTRANT -D_THREAD_SAFE"]
-	[OBJCFLAGS="$OBJCFLAGS -D_REENTRANT -D_THREAD_SAFE"]
 	[CXXFLAGS="$CXXFLAGS -D_REENTRANT -D_THREAD_SAFE"]
 fi
 

qse/include/qse/scm/scm.h

@@ -98,10 +98,12 @@ enum qse_scm_errnum_t
 
 	QSE_SCM_EIO,
 	QSE_SCM_EENDSTR,
+	QSE_SCM_ESHARP,
+	QSE_SCM_EDOT,
 
 	QSE_SCM_EINTERN,
-	QSE_SCM_ESYNTAX,
 	QSE_SCM_ELSTDEEP,
+	QSE_SCM_ELPAREN,
 	QSE_SCM_ERPAREN,
 	QSE_SCM_EARGBAD,
 	QSE_SCM_EARGFEW,

qse/include/qse/types.h

@@ -1,5 +1,5 @@
 /*
- * $Id: types.h 384 2011-02-04 15:47:53Z hyunghwan.chung $
+ * $Id: types.h 389 2011-02-25 15:26:16Z hyunghwan.chung $
  *
     Copyright 2006-2009 Chung, Hyung-Hwan.
     This file is part of QSE.
@@ -288,6 +288,18 @@ typedef qse_int_t qse_ssize_t;
  */
 typedef qse_uint_t qse_word_t;
 
+/**
+ * The qse_uintptr_t redefines qse_uint_t to indicate that you are dealing
+ * with a pointer.
+ */
+typedef qse_uint_t qse_uintptr_t;
+
+/**
+ * The qse_untptr_t redefines qse_int_t to indicate that you are dealing
+ * with a pointer.
+ */
+typedef qse_int_t qse_intptr_t;
+
 /** @typedef qse_real_t
  * The qse_real_t type defines the largest floating-pointer number type
  * supported.

qse/lib/scm/Makefile.am

@@ -8,6 +8,6 @@ AM_CPPFLAGS = \
 
 lib_LTLIBRARIES = libqsescm.la 
 
-libqsescm_la_SOURCES = scm.h scm.c err.c 
+libqsescm_la_SOURCES = scm.h scm.c print.c err.c
 libqsescm_la_LDFLAGS = -L../cmn -L$(libdir) -version-info 1:0:0 -no-undefined
 libqsescm_la_LIBADD = -lqsecmn

qse/lib/scm/Makefile.in

@@ -71,7 +71,7 @@ am__base_list = \
 am__installdirs = "$(DESTDIR)$(libdir)"
 LTLIBRARIES = $(lib_LTLIBRARIES)
 libqsescm_la_DEPENDENCIES =
-am_libqsescm_la_OBJECTS = scm.lo err.lo
+am_libqsescm_la_OBJECTS = scm.lo print.lo err.lo
 libqsescm_la_OBJECTS = $(am_libqsescm_la_OBJECTS)
 libqsescm_la_LINK = $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) \
 	$(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \
@@ -238,7 +238,7 @@ AM_CPPFLAGS = \
 	-I$(includedir)
 
 lib_LTLIBRARIES = libqsescm.la 
-libqsescm_la_SOURCES = scm.h scm.c err.c 
+libqsescm_la_SOURCES = scm.h scm.c print.c err.c
 libqsescm_la_LDFLAGS = -L../cmn -L$(libdir) -version-info 1:0:0 -no-undefined
 libqsescm_la_LIBADD = -lqsecmn
 all: all-am
@@ -316,6 +316,7 @@ distclean-compile:
 	-rm -f *.tab.c
 
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/err.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/print.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/scm.Plo@am__quote@
 
 .c.o:

qse/lib/scm/err.c

@@ -32,10 +32,12 @@ const qse_char_t* qse_scm_dflerrstr (qse_scm_t* scm, qse_scm_errnum_t errnum)
 
 		QSE_T("I/O error"),
 		QSE_T("unexpected end of string"),
+		QSE_T("bad sharp expression"),
+		QSE_T("wrong use of dot"),
 
 		QSE_T("internal error"),
-		QSE_T("syntax"),
 		QSE_T("list too deep"),
+		QSE_T("left parenthesis expected"),
 		QSE_T("right parenthesis expected"),
 		QSE_T("bad arguments"),
 		QSE_T("too few arguments"),

qse/lib/scm/print.c

@@ -0,0 +1,180 @@
+/*
+ * $Id$
+ *
+    Copyright 2006-2009 Chung, Hyung-Hwan.
+    This file is part of QSE.
+
+    QSE is free software: you can redistribute it and/or modify
+    it under the terms of the GNU Lesser General Public License as 
+    published by the Free Software Foundation, either version 3 of 
+    the License, or (at your option) any later version.
+
+    QSE 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 Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public 
+    License along with QSE. If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "scm.h"
+
+#define OUTPUT_STR(scm,str) QSE_BLOCK (\
+	if (scm->io.fns.out(scm, QSE_SCM_IO_WRITE, &scm->io.arg.out, (qse_char_t*)str, qse_strlen(str)) == -1) \
+	{ \
+		qse_scm_seterror (scm, QSE_SCM_EIO, QSE_NULL, 0); \
+		return -1; \
+	} \
+)
+
+#define OUTPUT_STRX(scm,str,len) QSE_BLOCK ( \
+	if (scm->io.fns.out(scm, QSE_SCM_IO_WRITE, &scm->io.arg.out, (qse_char_t*)str, qse_strlen(str)) == -1) \
+	{ \
+		qse_scm_seterror (scm, QSE_SCM_EIO, QSE_NULL, 0); \
+		return -1; \
+	} \
+)
+
+static int print_entity (
+	qse_scm_t* scm, const qse_scm_ent_t* obj, int prt_cons_par)
+{
+	qse_char_t buf[256];
+
+	if (IS_SMALLINT(obj))
+	{
+	}
+
+	switch (TYPE(obj)) 
+	{
+		case QSE_SCM_ENT_NIL:
+			OUTPUT_STR (scm, QSE_T("()"));
+			break;
+
+		case QSE_SCM_ENT_T:
+			OUTPUT_STR (scm, QSE_T("#t"));
+			break;
+
+		case QSE_SCM_ENT_F:
+			OUTPUT_STR (scm, QSE_T("#f"));
+			break;
+
+		case QSE_SCM_ENT_NUM:
+		#if QSE_SIZEOF_LONG_LONG > 0
+			scm->prm.sprintf (
+				scm->prm.udd,
+				buf, QSE_COUNTOF(buf), 
+				QSE_T("%lld"), (long long)NUM_VALUE(obj));
+		#elif QSE_SIZEOF___INT64 > 0
+			scm->prm.sprintf (
+				scm->prm.udd,
+				buf, QSE_COUNTOF(buf), 
+				QSE_T("%I64d"), (__int64)NUM_VALUE(obj));
+		#elif QSE_SIZEOF_LONG > 0
+			scm->prm.sprintf (
+				scm->prm.udd,
+				buf, QSE_COUNTOF(buf), 
+				QSE_T("%ld"), (long)NUM_VALUE(obj));
+		#elif QSE_SIZEOF_INT > 0
+			scm->prm.sprintf (
+				scm->prm.udd,
+				buf, QSE_COUNTOF(buf), 
+				QSE_T("%d"), (int)NUM_VALUE(obj));
+		#else
+			#error unsupported size		
+		#endif
+			OUTPUT_STR (scm, buf);
+			break;
+
+#if 0
+		case QSE_SCM_ENT_REAL:
+			scm->prm.sprintf (
+				scm->prm.udd,
+				buf, QSE_COUNTOF(buf), 
+				QSE_T("%Lf"), 
+			#ifdef __MINGW32__
+				(double)QSE_SCM_RVAL(obj)
+			#else
+				(long double)QSE_SCM_RVAL(obj)
+			#endif
+			);
+
+			OUTPUT_STR (scm, buf);
+			break;
+#endif
+
+		case QSE_SCM_ENT_SYM:
+			OUTPUT_STR (scm, LAB_PTR(SYM_NAME(obj)));
+			break;
+
+		case QSE_SCM_ENT_STR:
+			OUTPUT_STR (scm, QSE_T("\""));
+			/* TODO: deescaping */
+			OUTPUT_STRX (scm, STR_PTR(obj), STR_LEN(obj));
+			OUTPUT_STR (scm, QSE_T("\""));
+			break;
+
+		case QSE_SCM_ENT_PAIR:
+		{
+			const qse_scm_ent_t* p = obj;
+			if (prt_cons_par) OUTPUT_STR (scm, QSE_T("("));
+			do 
+			{
+				qse_scm_print (scm, PAIR_CAR(p));
+				p = PAIR_CDR(p);
+				if (!IS_NIL(p))
+				{
+					OUTPUT_STR (scm, QSE_T(" "));
+					if (TYPE(p) != QSE_SCM_ENT_PAIR) 
+					{
+						OUTPUT_STR (scm, QSE_T(". "));
+						qse_scm_print (scm, p);
+					}
+				}
+			} 
+			while (p != scm->nil && TYPE(p) == QSE_SCM_ENT_PAIR);
+			if (prt_cons_par) OUTPUT_STR (scm, QSE_T(")"));
+
+			break;
+		}
+
+#if 0
+		case QSE_SCM_ENT_FUNC:
+			/*OUTPUT_STR (scm, QSE_T("func"));*/
+			OUTPUT_STR (scm, QSE_T("(lambda "));
+			if (print_entity (scm, QSE_SCM_FFORMAL(obj), 1) == -1) return -1;
+			OUTPUT_STR (scm, QSE_T(" "));
+			if (print_entity (scm, QSE_SCM_FBODY(obj), 0) == -1) return -1;
+			OUTPUT_STR (scm, QSE_T(")"));
+			break;
+
+		case QSE_SCM_ENT_MACRO:
+			OUTPUT_STR (scm, QSE_T("(macro "));
+			if (print_entity (scm, QSE_SCM_FFORMAL(obj), 1) == -1) return -1;
+			OUTPUT_STR (scm, QSE_T(" "));
+			if (print_entity (scm, QSE_SCM_FBODY(obj), 0) == -1) return -1;
+			OUTPUT_STR (scm, QSE_T(")"));
+			break;
+		case QSE_SCM_ENT_PRIM:
+			OUTPUT_STR (scm, QSE_T("prim"));
+			break;
+#endif
+
+		default:
+			QSE_ASSERT (!"should never happen - unknown entity type");
+			qse_scm_seterror (scm, QSE_SCM_EINTERN, QSE_NULL, QSE_NULL);
+			return -1;
+	}
+
+	return 0;
+}
+
+int qse_scm_print (qse_scm_t* scm, const qse_scm_ent_t* obj)
+{
+	QSE_ASSERTX (
+		scm->io.fns.out != QSE_NULL, 
+		"Specify output function before calling qse_scm_print()"
+	);	
+
+	return print_entity (scm, obj, 1);
+}

qse/lib/scm/scm.h

@@ -26,36 +26,27 @@
 #include <qse/cmn/str.h>
 #include <qse/scm/scm.h>
 
-#define QSE_SCM_ISUPPER(scm,c)  QSE_ISUPPER(c)
-#define QSE_SCM_ISLOWER(scm,c)  QSE_ISLOWER(c)
-#define QSE_SCM_ISALPHA(scm,c)  QSE_ISALPHA(c)
-#define QSE_SCM_ISDIGIT(scm,c)  QSE_ISDIGIT(c)
-#define QSE_SCM_ISXDIGIT(scm,c) QSE_ISXDIGIT(c)
-#define QSE_SCM_ISALNUM(scm,c)  QSE_ISALNUM(c)
-#define QSE_SCM_ISSPACE(scm,c)  QSE_ISSPACE(c)
-#define QSE_SCM_ISPRINT(scm,c)  QSE_ISPRINT(c)
-#define QSE_SCM_ISGRAPH(scm,c)  QSE_ISGRAPH(c)
-#define QSE_SCM_ISCNTRL(scm,c)  QSE_ISCNTRL(c)
-#define QSE_SCM_ISPUNCT(scm,c)  QSE_ISPUNCT(c)
-#define QSE_SCM_TOUPPER(scm,c)  QSE_TOUPPER(c)
-#define QSE_SCM_TOLOWER(scm,c)  QSE_TOLOWER(c)
-
 /* Note that not all these values can be ORed with each other.
- * each value represents its own type except that QSE_SCM_ENT_SYNT
+ * each value represents its own type except the following combinations.
- * can be ORed with QSE_SCM_ENT_SYM.
+ *
+ *   QSE_SCM_ENT_T | QSE_SCM_ENT_BOOL
+ *   QSE_SCM_ENT_F | QSE_SCM_ENT_BOOL
+ *   QSE_SCM_ENT_SYM | QSE_SCM_ENT_SYNT
  */
 enum qse_scm_ent_type_t
 {
 	QSE_SCM_ENT_NIL     = (1 << 0),
 	QSE_SCM_ENT_T       = (1 << 1),
 	QSE_SCM_ENT_F       = (1 << 2),
-	QSE_SCM_ENT_NUM     = (1 << 3),
+	QSE_SCM_ENT_BOOL    = (1 << 3),
-	QSE_SCM_ENT_STR     = (1 << 4), 
+	QSE_SCM_ENT_NUM     = (1 << 4),
-	QSE_SCM_ENT_NAM     = (1 << 5),
+	QSE_SCM_ENT_REAL    = (1 << 5),
-	QSE_SCM_ENT_SYM     = (1 << 6),
+	QSE_SCM_ENT_STR     = (1 << 6), 
-	QSE_SCM_ENT_PAIR    = (1 << 7),
+	QSE_SCM_ENT_NAM     = (1 << 7),
-	QSE_SCM_ENT_PROC    = (1 << 8),
+	QSE_SCM_ENT_SYM     = (1 << 8),
-	QSE_SCM_ENT_SYNT    = (1 << 9)
+	QSE_SCM_ENT_PAIR    = (1 << 9),
+	QSE_SCM_ENT_PROC    = (1 << 10),
+	QSE_SCM_ENT_SYNT    = (1 << 11)
 
 };
 
@@ -72,10 +63,10 @@ enum qse_scm_ent_type_t
  */
 struct qse_scm_ent_t
 {
-	qse_uint16_t dswcount: 2;
+	qse_uint32_t dswcount: 2;
-	qse_uint16_t mark:     1;
+	qse_uint32_t mark:     1;
-	qse_uint16_t atom:     1;
+	qse_uint32_t atom:     1;
-	qse_uint16_t type:     12;
+	qse_uint32_t type:     28;
 
 	union
 	{
@@ -84,6 +75,11 @@ struct qse_scm_ent_t
 			qse_long_t val;
 		} num; /* number */
 
+		struct
+		{
+			qse_real_t val;
+		} real;
+
 		struct
 		{
 			/* a string doesn't need to be null-terminated 
@@ -115,6 +111,7 @@ struct qse_scm_ent_t
 #define TYPE(v)           ((v)->type)
 #define ATOM(v)           ((v)->atom)
 #define NUM_VALUE(v)      ((v)->u.num.val)
+#define REAL_VALUE(v)     ((v)->u.real.val)
 #define STR_PTR(v)        ((v)->u.str.ptr)
 #define STR_LEN(v)        ((v)->u.str.len)
 #define LAB_PTR(v)        ((v)->u.lab.ptr)
@@ -178,6 +175,9 @@ struct qse_scm_t
 			qse_real_t    rval;
 			qse_str_t     name;
 		} t;
+
+		qse_scm_ent_t* s; /* stack for reading */
+		qse_scm_ent_t* e; /* last entity read */
 	} r;
 
 	/* common values */
@@ -189,7 +189,6 @@ struct qse_scm_t
 
 	qse_scm_ent_t* gloenv; /* global environment */
 	qse_scm_ent_t* symtab; /* symbol table */
-	qse_scm_ent_t* rstack; /* stack for reading */
 
 	/* registers */
 	struct