peter
/
Flatrate
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

tokenizer

This commit is contained in:
Peter McGoron 2024-06-19 23:27:14 -04:00
commit c573be476b
4 changed files with 505 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Makefile Normal file
View File

@ -0,0 +1,6 @@
UNIVERSAL_SERVICE_DIR=universalservice
CFLAGS=-I${UNIVERSAL_SERVICE_DIR}/include -g -I${UNIVERSAL_SERVICE_DIR}/examples/string -std=c89 -Wall -pedantic -Werror
LDFLAGS=-L${UNIVERSAL_SERVICE_DIR} -luniversalservice -L${UNIVERSAL_SERVICE_DIR}/examples/string -lunsstring
flatrate: main.c
$(CC) main.c -o flatrate $(CFLAGS) $(LDFLAGS)

8
README.rst Normal file
View File

@ -0,0 +1,8 @@
=============
Flatrate LISP
=============
Flatrate is a minimalistic LISP. It's designed to test out my garbage
collectors.
The default macro system is non-hygenic.

288
main.c Normal file
View File

@ -0,0 +1,288 @@
/* Copyright (c) 2024, Peter McGoron
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1) Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2) Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
* TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include "uns.h"
#include "uns_string.h"
#include "cheney_c89.h"
static struct uns_gc gc;
enum token_type {
T_EOF,
LPAREN,
RPAREN,
QUOTE,
QUASIQUOTE,
UNQUOTE,
UNQUOTE_LIST,
IDENT,
NUMBER,
STRING,
TOKEN_NUM
};
static const char *token2string[TOKEN_NUM] = {
"EOF",
"(",
")",
"'",
"`",
",",
",@",
"IDENT",
"NUMBER",
"STRING"
};
struct token {
enum token_type typ;
struct uns_ctr dat;
long i;
};
static int is_ws(int c)
{
return c == '\n' || c == '\t' || c == '\r' || c == '\v' || c == ' ';
}
static int get_skipws(FILE *input)
{
int c;
for (;;) {
c = getc(input);
if (c == ';') {
do { c = getc(input); } while (c != '\n');
ungetc(c, input);
continue;
}
if (is_ws(c))
continue;
return c;
}
}
static void tok_string(FILE *input, struct token *tok)
{
int c;
tok->typ = STRING;
uns_string_alloc(&gc, &tok->dat, 32);
for (;;) {
c = getc(input);
switch (c) {
case '\\':
c = getc(input);
switch (c) {
case ' ': case '\t': case '\r': case '\n': case '\v':
do {
c = getc(input);
} while (is_ws(c));
ungetc(c, input);
continue;
case 'r':
uns_string_append_char(&gc, &tok->dat, '\r');
continue;
case 'n':
uns_string_append_char(&gc, &tok->dat, '\n');
continue;
case 'v':
uns_string_append_char(&gc, &tok->dat, '\v');
continue;
case 't':
uns_string_append_char(&gc, &tok->dat, '\t');
continue;
case '"':
uns_string_append_char(&gc, &tok->dat, '"');
continue;
default:
uns_string_append_char(&gc, &tok->dat, '\\');
uns_string_append_char(&gc, &tok->dat, c);
}
case '"': /* " */
return;
}
}
}
static int tonum(int c)
{
switch (c) {
case '0': case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9':
return c - '0';
default:
return -1;
}
}
static void tok_num(FILE *input, struct token *tok, int mul)
{
int c = getc(input);
tok->typ = NUMBER;
uns_string_alloc(&gc, &tok->dat, 32);
do {
uns_string_append_char(&gc, &tok->dat, c);
c = getc(input);
} while (tonum(c) >= 0);
ungetc(c, input);
tok->i = mul*strtol(uns_string_cstring(&gc, &tok->dat), NULL, 10);
tok->dat.p = NULL;
}
static int part_of_ident(int c)
{
return !is_ws(c) && c != '(' && c != ')' && c != '`'
&& c != '\'' && c != '\\' && c != '\"' && c != ','
&& c != ';';
}
static void tok_ident(FILE *input, struct token *tok, int c)
{
tok->typ = IDENT;
uns_string_alloc(&gc, &tok->dat, 32);
do {
uns_string_append_char(&gc, &tok->dat, c);
c = getc(input);
} while (part_of_ident(c));
ungetc(c, input);
}
static void tokenize(FILE *input, struct token *tok)
{
int c = get_skipws(input);
int c2;
tok->dat.p = NULL;
switch (c) {
case EOF:
tok->typ = T_EOF;
return;
case '(':
tok->typ = LPAREN;
return;
case ')':
tok->typ = RPAREN;
return;
case '\'':
tok->typ = QUOTE;
return;
case '`':
tok->typ = QUASIQUOTE;
return;
case ',':
c = getc(input);
if (c == '@') {
tok->typ = UNQUOTE_LIST;
} else {
ungetc(c, input);
tok->typ = UNQUOTE;
}
return;
case '"':
tok_string(input, tok);
return;
case '+': case '-':
c2 = getc(input);
ungetc(c2, input);
if (tonum(c2) >= 0) {
tok_num(input, tok, c == '+' ? 1 : -1);
return;
}
default:
if (tonum(c) >= 0)
tok_num(input, tok, 1);
else
tok_ident(input, tok, c);
return;
}
}
static void oom(struct uns_gc *gc_)
{
(void)gc_;
printf("oom\n");
exit(1);
}
static void after_gc(struct uns_gc *gc_)
{
(void)gc_;
if (gc.after_collection >= gc.next_alloc * 7/10)
gc.next_alloc *= 2;
}
int main(void)
{
FILE *input = stdin;
struct token tok;
int indent = 0;
int i;
gc.next_alloc = 512;
gc.oom = oom;
gc.after_gc = after_gc;
gc.ctx = malloc(uns_cheney_c89_ctx_size);
if(!gc.ctx || !uns_cheney_c89_init(&gc))
return 1;
uns_root_add(&gc, &tok.dat);
do {
tokenize(input, &tok);
if (tok.typ == LPAREN)
indent++;
else if (tok.typ == RPAREN)
indent--;
for (i = 0; i < indent; i++)
printf(" ");
printf("%s ", token2string[tok.typ]);
switch (tok.typ) {
case STRING: case IDENT:
printf("[%s] ", uns_string_cstring(&gc, &tok.dat));
break;
case NUMBER:
printf("[%ld] ", tok.i);
break;
default:
break;
}
printf("\n");
} while (tok.typ != T_EOF);
uns_cheney_c89_deinit(&gc);
return 0;
}

203
prelude.scm Normal file
View File

@ -0,0 +1,203 @@
; Copyright (c) 2024, Peter McGoron
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
;
; 1) Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
; 2) Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer in the
; documentation and/or other materials provided with the distribution.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
; Primitives are special syntatic forms. They differ from built-in
; functions.
;
; primitives:
; __unilambda: lambda of one argument
; __define: define in the environment
; __define-macro: Like __define but for macros
; set!
; if
;
; Others:
; __uniapply: Apply function to single argument
; __null: A value that can only be passed to __unilambda. It cannot be
; bound to a top-level, or "set!", or added to a list.
;
; Macros are functions that return an sexpr.
(__define-macro let
(__unilambda l ; car = args, cdr = body
(if (null? (car args))
(cdr args)
; (car args) = ((A a) (B b) ...)
; (car (car args)) = (A a)
; (cdr (car (car args))) = (a)
`((__unilambda ,(car (car (car args)))
(let ,(cdr (car args)) ,@body))
,(car (cdr (car (car args))))
)
)
)
)
(__define-macro let* let)
(__define-macro __bindlambda
(__unilambda l
(let ((larg (car l))
(args (car (cdr l)))
(body (cdr (cdr l)))
)
(if (null? args)
`(__unilambda larg
(if (not (null? larg))
(raise "incorrect number of arguments")
,body
)
)
(let* ((argval (cons args))
(rest (cdr args))
(arg (cons argval))
(val (cons (cdr argval)))
)
`(__unilambda ,larg
(let ((,arg ,val)) __bindlambda ,larg ,rest ,@body)
)
)
)
)
)
)
(__define-macro lambda
(__unilambda l
(let ((args (car l))
(body (cdr l))
)
(if (symbol? args)
`(__unilambda ,args ,@body)
(let ((larg (gensym)))
(if (null? args)
`(__unilambda ,larg ,@body)
`(__bindlambda ,larg . body)
)
)
)
)
)
)
(__define-macro define-macro
(__unilambda l
(let* ((name-and-args (car l))
(name (car name-and-args))
(args (cdr name-and-args))
(body (cdr l))
(tmpname (gensym))
)
`(__define-macro ,name
(lambda ,args ,body)
)
)
)
)
(define-macro (define name . body)
(if (symbol? name)
`(__define ,name ,@body)
`(__define ,(car name) (lambda ,(cdr name) ,@body))
)
)
(define-macro (begin . body)
`((lambda () ,@body))
)
(define-macro (and . body)
(if (null? body)
1
(let ((first (car body))
(rest (cdr body))
)
`(if ,first (and ,@rest) 0)
)
)
)
(define-macro (or . body)
(if (null? body)
0
(let ((first (car body))
(rest (cdr body))
)
`(if ,first 1 (or ,@rest))
)
)
)
(define-macro (letrec args . body)
(if (null? args)
body
(let* ((argval (car args))
(arg (car argval))
(val (car (cdr argval)))
(rest (cdr args))
)
`(let ((,arg __null))
(letrec ,rest (set! ,arg ,val) ,@body)
)
)
)
)
;; for a list of (v1 v2 ... vn)
;; runs (f vn (... (f v2 (f v1 start))))
(define (foldl f start l)
(letrec
((loop
(lambda (ret-list cur-list)
(if (eqv? value '())
value
(loop (f (car cur-list) value)
(cdr cur-list))
)
)
))
(loop start l)
)
)
(define (reverse l) (foldl cons '() l))
;; for a list of (v1 v2 ... vn)
;; runs (f v1 (f v2 (... (f vn start))))
(define (foldr f start l) (foldl f start (reverse l)))
(define (append . l)
(foldr (lambda (to-prepend collected)
(foldr cons collected to-prepend)
)
'()
l
)
)
(define (apply f . l) (__uniapply f (__uniapply append l)))
(define (list . l) l)
;; (define (+ . l) (foldl __bin+ 0 l))
;; (define (* . l) (foldl __bin* 1 l))