commit 66534051fd2ca953cb3e5fe3f63302b25f450276
parent 2740797a4b72a9ddcca5e9696366a81bcc2b96df
Author: Andres Navarro <canavarro82@gmail.com>
Date: Fri, 18 Mar 2011 16:04:09 -0300
Bugfix + Added char-alphabetic?, char-numeric?, char-whitespace?, char-upper-case? & char-lower-case? to the ground environment.
Bugfix: added p2tv wrapper around kis_input_port & kis_ouput_port in use of ftypep. The error wasn't detected in the compiler because of the use of VAR_ARGS.
Diffstat:
5 files changed, 135 insertions(+), 8 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -14,7 +14,7 @@ CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kground.o kghelpers.o kgbooleans.o kgeqp.o kgequalp.o \
kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o kgenvironments.o \
kgenv_mut.o kgcombiners.o kgcontinuations.o kgencapsulations.o \
- kgpromises.o kgkd_vars.o kgks_vars.o kgports.o
+ kgpromises.o kgkd_vars.o kgks_vars.o kgports.o kgchars.o
KRN_T= klisp
KRN_O= klisp.o
@@ -54,7 +54,7 @@ kwrite.o: kwrite.c kwrite.h kobject.h kpair.h kstring.h kstate.h kerror.h \
klisp.h kport.h
kstate.o: kstate.c kstate.h klisp.h kobject.h kmem.h kstring.h klisp.h \
kground.h kenvironment.h kpair.h keval.h koperative.h kground.h \
- krepl.h kcontinuation.h kapplicative.h kport.h ksymbol.h kport.h
+ krepl.h kcontinuation.h kapplicative.h kport.h ksymbol.h kport.h
kmem.o: kmem.c kmem.h klisp.h kerror.h klisp.h kstate.h
kerror.o: kerror.c kerror.h klisp.h kstate.h klisp.h kmem.h kstring.h
kauxlib.o: kauxlib.c kauxlib.h klisp.h kstate.h klisp.h
@@ -80,7 +80,7 @@ kground.o: kground.c kground.h kstate.h kobject.h klisp.h kenvironment.h \
kgbooleans.h kgeqp.h kgequalp.h kgsymbols.h kgpairs_lists.h \
kgpair_mut.h kgenvironments.h kgenv_mut.h kgcombiners.h \
kgcontinuations.h kgencapsulations.h kgpromises.h kgkd_vars.h \
- kgks_vars.h kgports.h
+ kgks_vars.h kgports.h kgchars.h
kghelpers.o: kghelpers.c kghelpers.h kstate.h kstate.h klisp.h kpair.h \
kapplicative.h koperative.h kerror.h kobject.h ksymbol.h
kgbooleans.o: kgbooleans.c kgbooleans.c kghelpers.h kstate.h klisp.h \
@@ -125,3 +125,5 @@ kgports.o: kgports.c kgports.h kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kapplicative.h koperative.h kcontinuation.h \
kport.h ksymbol.h kread.h kwrite.h ktoken.h kgcontinuations.h \
kpair.h kenvironment.h
+kgchars.o: kgchars.c kgchars.h kghelpers.h kstate.h klisp.h \
+ kobject.h kerror.h kapplicative.h koperative.h kcontinuation.h
diff --git a/src/kgchars.c b/src/kgchars.c
@@ -0,0 +1,57 @@
+/*
+** kgchars.c
+** Characters features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+#include <ctype.h>
+
+#include "kstate.h"
+#include "kobject.h"
+#include "kapplicative.h"
+#include "koperative.h"
+#include "kcontinuation.h"
+#include "kerror.h"
+
+#include "kghelpers.h"
+#include "kgchars.h"
+
+/* 14.1.1? char? */
+/* uses typep */
+
+/* 14.1.2? char-alphabetic?, char-numeric?, char-whitespace? */
+/* use ftyped_predp */
+
+/* 14.1.3? char-upper-case?, char-lower-case? */
+/* use ftyped_predp */
+
+/* Helpers for typed predicates */
+bool kcharp(TValue tv) { return ttischar(tv); }
+bool kchar_alphabeticp(TValue ch) { return isalpha(chvalue(ch)) != 0; }
+bool kchar_numericp(TValue ch) { return isdigit(chvalue(ch)) != 0; }
+bool kchar_whitespacep(TValue ch) { return isspace(chvalue(ch)) != 0; }
+bool kchar_upper_casep(TValue ch) { return isupper(chvalue(ch)) != 0; }
+bool kchar_lower_casep(TValue ch) { return islower(chvalue(ch)) != 0; }
+
+/* 14.1.4? char->integer, integer->char */
+/* TODO */
+
+/* 14.1.4? char-upcase, char-downcase */
+/* TODO */
+
+/* 14.2.1? char=? */
+/* TODO */
+
+/* 14.2.2? char<?, char<=?, char>?, char>=? */
+/* TODO */
+
+/* 14.2.3? char-ci=? */
+/* TODO */
+
+/* 14.2.4? char-ci<?, char-ci<=?, char-ci>?, char-ci>=? */
+/* TODO */
diff --git a/src/kgchars.h b/src/kgchars.h
@@ -0,0 +1,58 @@
+/*
+** kgchars.c
+** Characters features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgchars_h
+#define kgchars_h
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kobject.h"
+#include "klisp.h"
+#include "kstate.h"
+#include "kghelpers.h"
+
+/* 14.1.1? char? */
+/* uses typep */
+
+/* 14.1.2? char-alphabetic?, char-numeric?, char-whitespace? */
+/* use ftyped_predp */
+
+/* 14.1.3? char-upper-case?, char-lower-case? */
+/* use ftyped_predp */
+
+/* Helpers for typed predicates */
+/* XXX: this should probably be in a file kchar.h but there is no real need for
+ that file yet */
+bool kcharp(TValue tv);
+bool kchar_alphabeticp(TValue ch);
+bool kchar_numericp(TValue ch);
+bool kchar_whitespacep(TValue ch);
+bool kchar_upper_casep(TValue ch);
+bool kchar_lower_casep(TValue ch);
+
+/* 14.1.4? char->integer, integer->char */
+/* TODO */
+
+/* 14.1.4? char-upcase, char-downcase */
+/* TODO */
+
+/* 14.2.1? char=? */
+/* TODO */
+
+/* 14.2.2? char<?, char<=?, char>?, char>=? */
+/* TODO */
+
+/* 14.2.3? char-ci=? */
+/* TODO */
+
+/* 14.2.4? char-ci<?, char-ci<=?, char-ci>?, char-ci>=? */
+/* TODO */
+
+#endif
diff --git a/src/kground.c b/src/kground.c
@@ -36,6 +36,7 @@
#include "kgkd_vars.h"
#include "kgks_vars.h"
#include "kgports.h"
+#include "kgchars.h"
/*
** BEWARE: this is highly unhygienic, it assumes variables "symbol" and
@@ -493,12 +494,21 @@ void kinit_ground_env(klisp_State *K)
/* 14.1.2? char-alphabetic?, char-numeric?, char-whitespace? */
/* unlike in r5rs these take an arbitrary number of chars
(even cyclical list) */
- /* TODO */
+ add_applicative(K, ground_env, "char-alphabetic?", ftyped_predp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_alphabeticp));
+ add_applicative(K, ground_env, "char-numeric?", ftyped_predp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_numericp));
+ add_applicative(K, ground_env, "char-whitespace?", ftyped_predp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_whitespacep));
/* 14.1.3? char-upper-case?, char-lower-case? */
/* unlike in r5rs these take an arbitrary number of chars
(even cyclical list) */
- /* TODO */
+ add_applicative(K, ground_env, "char-upper-case?", ftyped_predp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_upper_casep));
+ add_applicative(K, ground_env, "char-lower-case?", ftyped_predp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_lower_casep));
+
/* 14.1.4? char->integer, integer->char */
/* TODO */
@@ -538,10 +548,10 @@ void kinit_ground_env(klisp_State *K)
/* 15.1.2 input-port?, output-port? */
add_applicative(K, ground_env, "input-port?", ftypep, 2, symbol,
- kis_input_port);
+ p2tv(kis_input_port));
add_applicative(K, ground_env, "output-port?", ftypep, 2, symbol,
- kis_output_port);
+ p2tv(kis_output_port));
/* 15.1.3 with-input-from-file, with-ouput-to-file */
/* TODO */
diff --git a/src/kobject.h b/src/kobject.h
@@ -405,7 +405,7 @@ const TValue keminf;
#define ch2tv(ch_) ((TValue) ch2tv_(ch_))
#define i2tv(i_) ((TValue) i2tv_(i_))
#define b2tv(b_) ((TValue) b2tv_(b_))
-#define p2tv(p_) ((TValue) b2tv_(p_))
+#define p2tv(p_) ((TValue) p2tv_(p_))
/* Macros to convert a GCObject * into a tagged value */
/* TODO: add assertions */
