artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mes.c, scm.c: add read-char, peek-char, char=?, char-alphabetic?.

Browse source
This commit is contained in:
Jan Nieuwenhuizen 2016-07-24 17:35:31 +02:00
parent 82a89c680f
commit 8dacd68fe8
4 changed files with 59 additions and 43 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

40
mes.c
View file

@ -913,7 +913,7 @@ ungetchar (int c) //int
}
int
peekchar () //int
peek_char () //int
{
int c = getchar ();
ungetchar (c);
@ -927,9 +927,9 @@ builtin_getchar ()
}
scm*
builtin_peekchar ()
builtin_peek_char ()
{
return make_number (peekchar ());
return make_char (getchar ());
}
scm*
@ -950,7 +950,7 @@ readcomment (int c)
int
readblock (int c)
{
if (c == '!' && peekchar () == '#') return getchar ();
if (c == '!' && peek_char () == '#') return getchar ();
return readblock (getchar ());
}
@ -968,7 +968,7 @@ readword (int c, char* w, scm *a)
if (c == '(') {ungetchar (c); return lookup (w, a);}
if (c == ')' && !w) {ungetchar (c); return &scm_nil;}
if (c == ')') {ungetchar (c); return lookup (w, a);}
if (c == ',' && peekchar () == '@') {getchar (); return cons (lookup (",@", a),
if (c == ',' && peek_char () == '@') {getchar (); return cons (lookup (",@", a),
cons (readword (getchar (), w, a),
&scm_nil));}
if ((c == '\''
@ -977,47 +977,47 @@ readword (int c, char* w, scm *a)
&& !w) {return cons (lookup_char (c, a),
cons (readword (getchar (), w, a),
&scm_nil));}
if (c == '#' && peekchar () == ',' && !w) {
if (c == '#' && peek_char () == ',' && !w) {
getchar ();
if (peekchar () == '@'){getchar (); return cons (lookup ("#,@", a),
if (peek_char () == '@'){getchar (); return cons (lookup ("#,@", a),
cons (readword (getchar (), w, a),
&scm_nil));}
return cons (lookup ("#,", a), cons (readword (getchar (), w, a), &scm_nil));
}
if (c == '#'
&& (peekchar () == '\''
|| peekchar () == '`')
&& (peek_char () == '\''
|| peek_char () == '`')
&& !w) {char buf[3] = "#"; buf[1] = getchar (); return cons (lookup (buf, a),
cons (readword (getchar (), w, a),
&scm_nil));}
if (c == ';') {readcomment (c); return readword ('\n', w, a);}
if (c == '#' && peekchar () == '\\') {getchar (); return readchar ();}
if (c == '#' && !w && peekchar () == '(') {getchar (); return list_to_vector (readlist (a));}
if (c == '#' && peekchar () == '(') {ungetchar (c); return lookup (w, a);}
if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);}
if (c == '#' && peek_char () == '\\') {getchar (); return read_char ();}
if (c == '#' && !w && peek_char () == '(') {getchar (); return list_to_vector (readlist (a));}
if (c == '#' && peek_char () == '(') {ungetchar (c); return lookup (w, a);}
if (c == '#' && peek_char () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);}
char buf[256] = {0};
char ch = c;
return readword (getchar (), strncat (w ? w : buf, &ch, 1), a);
}
scm *
readchar ()
read_char ()
{
int c = getchar ();
if (c >= '0' && c <= '7'
&& peekchar () >= '0' && peekchar () <= '7') {
&& peek_char () >= '0' && peek_char () <= '7') {
c = c - '0';
while (peekchar () >= '0' && peekchar () <= '7') {
while (peek_char () >= '0' && peek_char () <= '7') {
c <<= 3;
c += getchar () - '0';
}
}
else if (c >= 'a' && c <= 'z'
&& peekchar () >= 'a' && peekchar () <= 'z') {
&& peek_char () >= 'a' && peek_char () <= 'z') {
char buf[256];
char *p = buf;
*p++ = c;
while (peekchar () >= 'a' && peekchar () <= 'z') {
while (peek_char () >= 'a' && peek_char () <= 'z') {
*p++ = getchar ();
}
*p = 0;
@ -1041,7 +1041,7 @@ readstring ()
while (true) {
if (c == '"') break;
*p++ = c;
if (c == '\\' && peekchar () == '"') *p++ = getchar ();
if (c == '\\' && peek_char () == '"') *p++ = getchar ();
if (c == EOF) assert (!"EOF in string");
c = getchar ();
}
@ -1054,7 +1054,7 @@ eat_whitespace (int c)
{
while (c == ' ' || c == '\t' || c == '\n') c = getchar ();
if (c == ';') return eat_whitespace (readcomment (c));
if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return eat_whitespace (getchar ());}
if (c == '#' && peek_char () == '!') {getchar (); readblock (getchar ()); return eat_whitespace (getchar ());}
return c;
}

46
mes.mes
View file

@ -164,7 +164,7 @@
;; readenv et al works, but slows down dramatically
(define (DISABLED-readenv a)
(readword (getchar) '() a))
(readword (read-char) '() a))
(define (readword c w a)
;; (display 'mes-readword:)
@ -174,59 +174,59 @@
(cond ((eq? w '()) '())
(#t (lookup w a))))
((eq? c 10) ;; \n
(cond ((eq? w '()) (readword (getchar) w a))
;; DOT ((eq? w '(*dot*)) (car (readword (getchar) '() a)))
(cond ((eq? w '()) (readword (read-char) w a))
;; DOT ((eq? w '(*dot*)) (car (readword (read-char) '() a)))
(#t (lookup w a))))
((eq? c 32) ;; \space
(readword 10 w a))
((eq? c 40) ;; (
(cond ((eq? w '()) (readlist a))
(#t (ungetchar c) (lookup w a))))
(#t (unread-char c) (lookup w a))))
((eq? c 41) ;; )
(cond ((eq? w '()) (ungetchar c) w)
(#t (ungetchar c) (lookup w a))))
(cond ((eq? w '()) (unread-char c) w)
(#t (unread-char c) (lookup w a))))
((eq? c 39) ;; '
(cond ((eq? w '())
(cons (lookup (cons c '()) a)
(cons (readword (getchar) w a) '())))
(#t (ungetchar c) (lookup w a))))
(cons (readword (read-char) w a) '())))
(#t (unread-char c) (lookup w a))))
((eq? c 59) ;; ;
(readcomment c)
(readword 10 w a))
((eq? c 35) ;; #
(cond ((eq? (peekchar) 33) ;; !
(getchar)
(readblock (getchar))
(cond ((eq? (peek-char) 33) ;; !
(read-char)
(readblock (read-char))
(readword 10 w a))
;; TODO: char, vector
(#t (readword (getchar) (append w (cons c '())) a))))
(#t (readword (getchar) (append w (cons c '())) a))))
(#t (readword (read-char) (append w (cons c '())) a))))
(#t (readword (read-char) (append w (cons c '())) a))))
(define (readblock c)
;; (display 'mes-readblock:)
;; (display c)
;; (newline)
(cond ((eq? c 33) (cond ((eq? (peekchar) 35) (getchar))
(#t (readblock (getchar)))))
(#t (readblock (getchar)))))
(cond ((eq? c 33) (cond ((eq? (peek-char) 35) (read-char))
(#t (readblock (read-char)))))
(#t (readblock (read-char)))))
(define (eat-whitespace)
(cond ((eq? (peekchar) 10) (getchar) (eat-whitespace))
((eq? (peekchar) 32) (getchar) (eat-whitespace))
((eq? (peekchar) 35) (getchar) (eat-whitespace))
(cond ((eq? (peek-char) 10) (read-char) (eat-whitespace))
((eq? (peek-char) 32) (read-char) (eat-whitespace))
((eq? (peek-char) 35) (read-char) (eat-whitespace))
(#t #t)))
(define (readlist a)
;; (display 'mes-readlist:)
;; (newline)
(eat-whitespace)
(cond ((eq? (peekchar) 41) ;; )
(getchar)
(cond ((eq? (peek-char) 41) ;; )
(read-char)
'())
;; TODO *dot*
(#t (cons (readword (getchar) '() a) (readlist a)))))
(#t (cons (readword (read-char) '() a) (readlist a)))))
(define (readcomment c)
(cond ((eq? c 10) ;; \n
c)
(#t (readcomment (getchar)))))
(#t (readcomment (read-char)))))

13
scm.mes
View file

@ -260,3 +260,16 @@
(define (reverse lst)
(if (null? lst) '()
(append (reverse (cdr lst)) (cons (car lst) '()))))
(define (eof-object? x)
(and (number? x) (= x -1)))
(define (char=? x y)
(and (char? x) (char? y)
(eq? x y)))
(define (char-alphabetic? x)
(and (char? x)
(let ((i (char->integer x)))
(or (and (>= i (char->integer #\A)) (<= i (char->integer #\Z)))
(and (>= i (char->integer #\a)) (<= i (char->integer #\z)))))))

3
test.mes
View file

@ -294,6 +294,9 @@
(pass-if "do" (sequal? (let ((acc '())) (do ((i 0 (+ i 1))) ((>= i 3)) (set! acc (cons i acc))) acc) '(2 1 0)))
(pass-if "char-alphabetic?" (seq? (char-alphabetic? #\a) #t))
(pass-if "char-alphabetic? 2" (seq? (char-alphabetic? #\[) #f))
(newline)
(display "passed: ") (display (car (result))) (newline)
(display "failed: ") (display (cadr (result))) (newline)