Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Chris Müller
cherry
Commits
d2625b25
Commit
d2625b25
authored
Jul 24, 2013
by
Chris Müller
Browse files
implement bootstrap-cherry with runtime environment
parent
15de1954
Changes
2
Hide whitespace changes
Inline
Side-by-side
source/bootstrap.c
View file @
d2625b25
...
...
@@ -35,6 +35,7 @@ struct value* Define = NULL;
struct
value
*
Let
=
NULL
;
struct
value
*
Lambda
=
NULL
;
struct
value
*
If
=
NULL
;
struct
value
*
Begin
=
NULL
;
static
void
failure
(
const
byte_t
*
format
,
...)
...
...
@@ -149,13 +150,23 @@ primitive(const primitive_t fun_value)
return
v
;
}
struct
value
*
foreign
(
pointer_t
value
)
{
struct
value
*
v
=
alloc_value
();
v
->
tag
=
FOREIGN
;
v
->
foreign_value
=
value
;
return
v
;
}
struct
value
*
lambda
(
struct
value
*
param
,
struct
value
*
body
)
procedure
(
struct
value
*
env
,
struct
value
*
param
,
struct
value
*
body
)
{
struct
value
*
v
=
alloc_value
();
v
->
tag
=
LAMBDA
;
v
->
lambda
.
param
=
param
;
v
->
lambda
.
body
=
body
;
v
->
tag
=
PROCEDURE
;
v
->
procedure
.
env
=
env
;
v
->
procedure
.
param
=
param
;
v
->
procedure
.
body
=
body
;
return
v
;
}
...
...
@@ -239,11 +250,70 @@ initialize(void)
global_symbollist
=
Emptylist
;
Quote
=
symbol
(
"quote"
);
Define
=
symbol
(
"define"
);
Quote
=
symbol
(
"quote"
);
Let
=
symbol
(
"let"
);
Lambda
=
symbol
(
"lambda"
);
If
=
symbol
(
"If"
);
If
=
symbol
(
"if"
);
Define
=
symbol
(
"define"
);
Begin
=
symbol
(
"begin"
);
}
static
struct
value
*
core_environment
(
void
)
{
struct
value
*
env
=
INITIAL_ENV
;
#define proc_to_env(ENV, STR, FUN) \
env_let(ENV, symbol(STR), primitive(FUN))
proc_to_env
(
env
,
"println"
,
core_println
);
return
env
;
}
// ----------------------------------------------------------------------------
// Primitives
// ----------------------------------------------------------------------------
struct
value
*
core_println
(
struct
value
*
env
,
struct
value
*
args
)
{
struct
value
*
v
;
while
(
!
IS_NULL
(
args
))
{
v
=
HEAD
(
args
);
switch
(
v
->
tag
)
{
case
BOOLEAN
:
if
(
IS_TRUE
(
v
))
printf
(
"true"
);
else
printf
(
"false"
);
break
;
case
STRING
:
printf
(
"%s"
,
v
->
string_value
);
break
;
case
SYMBOL
:
printf
(
"%s"
,
v
->
symbol_value
);
break
;
case
FIXNUM
:
printf
(
"%ld"
,
v
->
fixnum_value
);
break
;
case
FLOAT
:
printf
(
"%lf"
,
v
->
float_value
);
break
;
default:
failure
(
"cherry.core.println: Argument not accepted"
);
break
;
}
args
=
TAIL
(
args
);
}
printf
(
"
\n
"
);
return
True
;
}
// ----------------------------------------------------------------------------
...
...
@@ -437,7 +507,7 @@ lex_char(byte_t** begin, byte_t* buffer, size_t buffer_size)
buffer
++
;
p
++
;
}
else
failure
(
"Bufferoverflow in character
literal
"
);
failure
(
"
Read:
Bufferoverflow in character
scanning
"
);
}
*
buffer
=
'\0'
;
...
...
@@ -457,6 +527,9 @@ lex_raw_string(byte_t** begin, byte_t* buffer, size_t buffer_size)
p
++
;
// remove beginning delimeter
while
(
*
p
!=
'\0'
&&
*
p
!=
'~'
)
{
printf
(
"STREAM %s
\n
"
,
p
);
fflush
(
stdout
);
if
(
*
p
==
'\r'
||
*
p
==
'\n'
)
failure
(
"Unexpected newline/carriage return found in raw string"
);
...
...
@@ -466,15 +539,11 @@ lex_raw_string(byte_t** begin, byte_t* buffer, size_t buffer_size)
buffer
++
;
p
++
;
}
else
failure
(
"Bufferoverflow in raw string literal"
);
buffer
++
;
p
++
;
failure
(
"Read: Bufferoverflow in raw string scanning"
);
}
*
buffer
=
'\0'
;
*
begin
=
(
*
p
!=
'\0'
)
?
p
:
p
+
1
;
*
begin
=
(
*
p
!=
'\0'
)
?
p
+
1
:
p
;
return
TOK_STRING
;
}
...
...
@@ -564,13 +633,13 @@ lex_string(byte_t** begin, byte_t* buffer, size_t buffer_size)
}
*
buffer
=
*
p
;
if
(
buffer
<
buf_end
)
buffer
++
;
else
failure
(
"Read: Bufferoverflow in string scanning"
);
NO_BUFFER_APPEND:
if
(
buffer
<
buf_end
)
{
buffer
++
;
p
++
;
}
else
failure
(
"Bufferoverflow in string scanning"
);
p
++
;
}
RETURN_TOKEN:
...
...
@@ -821,9 +890,10 @@ env_set(struct value* env, struct value* var, struct value* val)
vals
=
FRAME_VALUES
(
frame
);
while
(
!
IS_NULL
(
vars
))
{
if
(
var
==
HEAD
(
vars
))
if
(
var
==
HEAD
(
vars
))
{
HEAD
(
vals
)
=
val
;
return
True
;
}
vars
=
TAIL
(
vars
);
vals
=
TAIL
(
vals
);
...
...
@@ -836,16 +906,9 @@ env_set(struct value* env, struct value* var, struct value* val)
}
struct
value
*
env_add_binding_to_frame
(
struct
value
*
frame
,
struct
value
*
var
,
struct
value
*
val
)
{
HEAD
(
frame
)
=
cons
(
var
,
HEAD
(
frame
));
TAIL
(
frame
)
=
cons
(
val
,
TAIL
(
frame
));
}
struct
value
*
env_
define
(
struct
value
*
env
,
struct
value
*
var
,
struct
value
*
val
)
env_
let
(
struct
value
*
env
,
struct
value
*
var
,
struct
value
*
val
)
{
struct
value
*
frame
=
FIRST_FRAME
(
env
);
struct
value
*
vars
=
FRAME_VARIABLES
(
frame
);
...
...
@@ -861,7 +924,9 @@ env_define(struct value* env, struct value* var, struct value* val)
vals
=
TAIL
(
vals
);
}
env_add_binding_to_frame
(
var
,
val
,
frame
);
HEAD
(
frame
)
=
cons
(
var
,
HEAD
(
frame
));
TAIL
(
frame
)
=
cons
(
val
,
TAIL
(
frame
));
return
True
;
}
...
...
@@ -871,19 +936,69 @@ env_define(struct value* env, struct value* var, struct value* val)
// compile
// ----------------------------------------------------------------------------
struct
closure
*
cherry_compile
(
struct
value
*
ast
,
struct
value
*
env
)
static
struct
value
*
eval_values
(
struct
value
*
env
,
struct
value
*
args
)
{
struct
value
*
last
=
Emptylist
;
struct
value
*
begin
=
last
;
return
NULL
;
}
while
(
!
IS_NULL
(
args
))
{
last
=
TAIL
(
last
)
=
cons
(
cherry_eval
(
env
,
HEAD
(
args
)),
Emptylist
);
args
=
TAIL
(
args
);
}
return
TAIL
(
begin
);
}
struct
value
*
cherry_eval
(
struct
closure
*
cod
e
)
cherry_eval
(
struct
value
*
env
,
struct
value
*
valu
e
)
{
return
EXECUTE
(
code
);
while
(
TRUE
)
{
if
(
IS_SELF_EVALUATING
(
value
))
return
value
;
else
if
(
IS_VARIABLE
(
value
))
return
env_lookup
(
env
,
value
);
struct
value
*
fn
=
HEAD
(
value
);
struct
value
*
args
=
TAIL
(
value
);
if
(
fn
==
Let
)
{
return
env_let
(
env
,
HEAD
(
args
),
cherry_eval
(
env
,
HEAD
(
TAIL
(
args
))));
}
else
if
(
fn
==
Quote
)
{
return
HEAD
(
args
);
}
else
if
(
fn
==
Lambda
)
{
return
procedure
(
env
,
HEAD
(
args
),
TAIL
(
args
));
}
else
if
(
fn
==
Begin
)
{
while
(
!
IS_NULL
(
TAIL
(
args
)))
{
cherry_eval
(
env
,
HEAD
(
args
));
args
=
TAIL
(
args
);
}
value
=
HEAD
(
args
);
}
else
if
(
fn
==
If
)
{
value
=
IS_TRUE
(
cherry_eval
(
env
,
HEAD
(
args
)))
?
HEAD
(
TAIL
(
args
))
:
HEAD
(
TAIL
(
TAIL
(
args
)));
}
else
if
(
IS_SYMBOL
(
fn
))
{
fn
=
cherry_eval
(
env
,
fn
);
args
=
eval_values
(
env
,
args
);
if
(
IS_PRIMITIVE
(
fn
))
value
=
(
fn
->
fun_value
)(
env
,
args
);
else
if
(
IS_PROCEDURE
(
fn
))
{
env
=
EXTEND_ENV
(
fn
->
procedure
.
env
,
fn
->
procedure
.
param
,
args
);
value
=
cons
(
Begin
,
fn
->
procedure
.
body
);
}
else
failure
(
"Eval: Unknown procedure type found"
);
}
else
failure
(
"Eval: no proper cherry operation found"
);
}
}
// ----------------------------------------------------------------------------
...
...
@@ -926,6 +1041,14 @@ cherry_write_pair(FILE* out, struct value* value)
}
void
cherry_writeln
(
FILE
*
out
,
struct
value
*
value
)
{
cherry_write
(
out
,
value
);
fprintf
(
out
,
"
\n
"
);
fflush
(
out
);
}
void
cherry_write
(
FILE
*
out
,
struct
value
*
value
)
{
...
...
@@ -1030,12 +1153,16 @@ cherry_write(FILE* out, struct value* value)
fprintf
(
out
,
"
\"
"
);
break
;
case
FOREIGN
:
fprintf
(
out
,
"#foreign"
);
break
;
case
PRIMITIVE
:
fprintf
(
out
,
"#primitive
-procedure
"
);
fprintf
(
out
,
"#primitive"
);
break
;
case
LAMBDA
:
fprintf
(
out
,
"#
lambda-
procedure"
);
case
PROCEDURE
:
fprintf
(
out
,
"#procedure"
);
break
;
case
PAIR
:
...
...
@@ -1053,6 +1180,9 @@ cherry_write(FILE* out, struct value* value)
default:
failure
(
"cannot write an unknown value type"
);
}
fprintf
(
out
,
"
\n
"
);
fflush
(
out
);
}
...
...
@@ -1072,10 +1202,10 @@ void cherry_main(const char* filename, const byte_t* method, struct value* args)
byte_t
*
p
=
text
(
port
);
struct
value
*
exp
=
cherry_read
(
&
p
,
buffer
,
SCANNER_BUFFERSIZE
);
struct
value
*
env
=
core_environment
();
while
(
exp
!=
0
)
{
cherry_write
(
stdout
,
exp
);
fprintf
(
stdout
,
"
\n
"
);
cherry_eval
(
env
,
exp
);
exp
=
cherry_read
(
&
p
,
buffer
,
SCANNER_BUFFERSIZE
);
}
...
...
@@ -1136,7 +1266,6 @@ int main(int argc, char** argv)
last
=
TAIL
(
last
)
=
cons
(
string
(
argv
[
optind
++
]),
Emptylist
);
}
if
(
filename
)
cherry_main
(
filename
,
method
,
TAIL
(
arguments
));
else
...
...
source/bootstrap.h
View file @
d2625b25
...
...
@@ -40,7 +40,8 @@ typedef uint32_t unicode_t;
typedef
struct
value
*
(
*
primitive_t
)(
struct
value
*
env
,
struct
value
*
args
);
enum
tag
{
EMPTYLIST
,
BOOLEAN
,
DOT
,
FIXNUM
,
FLOAT
,
STRING
,
CHARACTER
,
PAIR
,
TUPLE
,
SYMBOL
,
PRIMITIVE
,
LAMBDA
EMPTYLIST
,
BOOLEAN
,
DOT
,
FIXNUM
,
FLOAT
,
STRING
,
CHARACTER
,
PAIR
,
TUPLE
,
SYMBOL
,
PRIMITIVE
,
PROCEDURE
,
FOREIGN
};
struct
value
{
...
...
@@ -53,6 +54,7 @@ struct value {
primitive_t
fun_value
;
const
byte_t
*
string_value
;
const
byte_t
*
symbol_value
;
pointer_t
foreign_value
;
struct
{
struct
value
*
head
;
...
...
@@ -65,9 +67,10 @@ struct value {
}
tuple
;
struct
{
struct
value
*
env
;
struct
value
*
param
;
struct
value
*
body
;
}
lambda
;
}
procedure
;
};
};
...
...
@@ -83,7 +86,7 @@ struct value {
#define IS_CHARACTER(value) (value->tag == CHARACTER)
#define IS_PAIR(value) (value->tag == PAIR)
#define IS_PRIMITIVE(value) (value->tag == PRIMITIVE)
#define IS_
LAMBDA
(value) (value->tag ==
LAMBDA
)
#define IS_
PROCEDURE
(value) (value->tag ==
PROCEDURE
)
#define HEAD(obj) (obj->pair.head)
#define TAIL(obj) (obj->pair.tail)
...
...
@@ -91,8 +94,8 @@ struct value {
#define TUPLE_DATA(obj) (obj->tuple.data)
#define TUPLE_SIZE(obj) (obj->tuple.size)
#define
LAMBDA
_PARAM(obj) (obj->
lambda
.param)
#define
LAMBDA
_BODY(obj) (obj->
lambda
.body)
#define
PROC
_PARAM(obj) (obj->
procedure
.param)
#define
PROC
_BODY(obj) (obj->
procedure
.body)
extern
struct
value
*
True
;
extern
struct
value
*
False
;
...
...
@@ -101,7 +104,9 @@ extern struct value* Dot;
extern
struct
value
*
Let
;
extern
struct
value
*
Lambda
;
extern
struct
value
*
If
;
extern
struct
value
*
Begin
;
struct
value
*
dup
(
struct
value
*
value
);
struct
value
*
alloc_value
(
void
);
struct
value
*
symbol
(
const
byte_t
*
symbol_value
);
...
...
@@ -110,12 +115,12 @@ struct value* floatpoint(float_t float_value);
struct
value
*
character
(
unicode_t
character_value
);
struct
value
*
string
(
const
byte_t
*
string_value
);
struct
value
*
primitive
(
const
primitive_t
fun_value
);
struct
value
*
lambda
(
struct
value
*
param
,
struct
value
*
body
);
struct
value
*
procedure
(
struct
value
*
env
,
struct
value
*
param
,
struct
value
*
body
);
struct
value
*
foreign
(
pointer_t
value
);
struct
value
*
tuple
(
size_t
size
,
...);
struct
value
*
cons
(
struct
value
*
head
,
struct
value
*
tail
);
struct
value
*
dup
(
struct
value
*
value
);
struct
value
*
cons
(
struct
value
*
head
,
struct
value
*
tail
);
#define list2(A, B) cons(A cons(B, emptylist))
#define list3(A, B, C) cons(A, cons(B, cons(C, emptylist)))
...
...
@@ -126,7 +131,7 @@ struct value* cons(struct value* head, struct value* tail);
#define SYMBOL_RIGHT(node) TAIL(TAIL(node))
#define EXTEND_ENV(env, vars, vals) cons(cons(vars,vals), env)
#define INTIAL_ENV EXTEND_ENV(Emptylist, Emptylist, Emptylist)
#define IN
I
TIAL_ENV EXTEND_ENV(Emptylist, Emptylist, Emptylist)
#define FIRST_FRAME(env) HEAD(env)
#define PARENT_FRAMES(env) TAIL(env)
#define FRAME_VARIABLES(frame) HEAD(frame)
...
...
@@ -134,22 +139,20 @@ struct value* cons(struct value* head, struct value* tail);
struct
value
*
env_lookup
(
struct
value
*
env
,
struct
value
*
var
);
struct
value
*
env_set
(
struct
value
*
env
,
struct
value
*
var
,
struct
value
*
val
);
struct
value
*
env_define
(
struct
value
*
env
,
struct
value
*
var
,
struct
value
*
val
);
struct
value
*
env_add_binding_to_frame
(
struct
value
*
frame
,
struct
value
*
var
,
struct
value
*
val
);
struct
value
*
env_let
(
struct
value
*
env
,
struct
value
*
var
,
struct
value
*
val
);
#define IS_FALSE(val) (IS_BOOLEAN(val) && !val->fixnum_value)
#define IS_TRUE(val) (!IS_FALSE(val))
struct
closure
{
struct
value
*
(
*
execute
)(
struct
closure
*
self
);
struct
value
*
args
;
};
#define IS_SELF_EVALUATING(val) \
(IS_BOOLEAN(val) || IS_FIXNUM(val) || IS_CHARACTER(val) || IS_STRING(val) || IS_FLOAT(val))
#define IS_CONTINUATION(closure) (((struct closure*) closure)->execute != NULL)
#define EXECUTE(obj) (((struct closure*) obj)->execute((struct closure*)obj))
#define IS_VARIABLE(val) IS_SYMBOL(val)
void
cherry_initialize
(
void
);
struct
value
*
cherry_read
(
byte_t
**
begin
,
byte_t
*
buffer
,
size_t
buffer_size
);
struct
closure
*
cherry_compile
(
struct
value
*
ast
,
struct
value
*
env
);
struct
value
*
cherry_eval
(
struct
closure
*
code
);
struct
value
*
cherry_eval
(
struct
value
*
env
,
struct
value
*
code
);
void
cherry_write
(
FILE
*
out
,
struct
value
*
v
);
void
cherry_writeln
(
FILE
*
out
,
struct
value
*
v
);
struct
value
*
core_println
(
struct
value
*
env
,
struct
value
*
args
);
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment