Skip to content
GitLab
Menu
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Chris Müller
cherry
Commits
406c9e49
Commit
406c9e49
authored
Jul 24, 2013
by
Chris Müller
Browse files
Add variable list for lambda expressions
parent
d2625b25
Changes
2
Hide whitespace changes
Inline
Side-by-side
source/bootstrap.c
View file @
406c9e49
...
...
@@ -247,6 +247,8 @@ initialize(void)
Emptylist
=
alloc_value
();
Emptylist
->
tag
=
EMPTYLIST
;
Emptylist
->
pair
.
head
=
Emptylist
;
Emptylist
->
pair
.
tail
=
Emptylist
;
global_symbollist
=
Emptylist
;
...
...
@@ -266,6 +268,7 @@ core_environment(void)
#define proc_to_env(ENV, STR, FUN) \
env_let(ENV, symbol(STR), primitive(FUN))
proc_to_env
(
env
,
"write"
,
core_write
);
proc_to_env
(
env
,
"println"
,
core_println
);
return
env
;
...
...
@@ -312,10 +315,17 @@ core_println(struct value* env, struct value* args)
}
printf
(
"
\n
"
);
return
True
;
}
struct
value
*
core_write
(
struct
value
*
env
,
struct
value
*
args
)
{
cherry_write
(
stdout
,
args
);
return
True
;
}
// ----------------------------------------------------------------------------
// Reading
// ----------------------------------------------------------------------------
...
...
@@ -527,9 +537,6 @@ 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"
);
...
...
@@ -621,11 +628,16 @@ lex_string(byte_t** begin, byte_t* buffer, size_t buffer_size)
case
'0'
:
*
buffer
=
'0'
;
break
;
case
'"'
:
*
buffer
=
'"'
;
break
;
case
'\\'
:
*
buffer
=
'\\'
;
break
;
state
=
STR_EAT
;
goto
NO_BUFFER_APPEND
;
default:
failure
(
"Unknown escape sequence found in this string literal"
);
}
state
=
STR_EAT
;
if
(
buffer
<
buf_end
)
buffer
++
;
else
failure
(
"Read: Bufferoverflow in string scanning"
);
goto
NO_BUFFER_APPEND
;
break
;
case
STR_FINAL
:
...
...
@@ -798,6 +810,10 @@ cherry_read(byte_t** src, byte_t* buffer, size_t buffer_size)
val
=
False
;
break
;
case
TOK_DOT
:
val
=
Dot
;
break
;
case
TOK_TRUE
:
val
=
True
;
break
;
...
...
@@ -939,15 +955,10 @@ env_let(struct value* env, struct value* var, struct value* val)
static
struct
value
*
eval_values
(
struct
value
*
env
,
struct
value
*
args
)
{
struct
value
*
last
=
Emptylist
;
struct
value
*
begin
=
last
;
while
(
!
IS_NULL
(
args
))
{
last
=
TAIL
(
last
)
=
cons
(
cherry_eval
(
env
,
HEAD
(
args
)),
Emptylist
);
args
=
TAIL
(
args
);
}
return
TAIL
(
begin
);
if
(
IS_NULL
(
args
))
return
args
;
else
return
cons
(
cherry_eval
(
env
,
HEAD
(
args
)),
eval_values
(
env
,
TAIL
(
args
)));
}
struct
value
*
...
...
@@ -958,10 +969,10 @@ cherry_eval(struct value* env, struct value* 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
))));
...
...
@@ -983,15 +994,38 @@ cherry_eval(struct value* env, struct value* value)
?
HEAD
(
TAIL
(
args
))
:
HEAD
(
TAIL
(
TAIL
(
args
)));
}
else
if
(
IS_SYMBOL
(
fn
))
{
}
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
);
return
(
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
);
struct
value
*
params
=
fn
->
procedure
.
param
;
env
=
EXTEND_ENV
(
env
);
if
(
IS_VARIABLE
(
params
))
env_let
(
env
,
params
,
args
);
else
{
while
(
!
IS_NULL
(
params
))
{
if
(
IS_DOT
(
HEAD
(
params
))
&&
!
IS_NULL
(
TAIL
(
params
)))
{
env_let
(
env
,
HEAD
(
TAIL
(
params
)),
args
);
args
=
params
=
Emptylist
;
}
else
if
(
!
IS_DOT
(
HEAD
(
params
)))
{
if
(
!
IS_NULL
(
args
))
{
env_let
(
env
,
HEAD
(
params
),
HEAD
(
args
));
params
=
TAIL
(
params
);
args
=
TAIL
(
args
);
}
}
else
{
failure
(
"Eval: Dot operator given without a variable"
);
}
}
}
value
=
cons
(
Begin
,
fn
->
procedure
.
body
);
}
else
failure
(
"Eval: Unknown procedure type found"
);
...
...
@@ -1041,14 +1075,6 @@ 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
)
{
...
...
@@ -1180,9 +1206,6 @@ cherry_write(FILE* out, struct value* value)
default:
failure
(
"cannot write an unknown value type"
);
}
fprintf
(
out
,
"
\n
"
);
fflush
(
out
);
}
...
...
@@ -1200,6 +1223,7 @@ void cherry_main(const char* filename, const byte_t* method, struct value* args)
if
(
!
port
)
failure
(
"could not load file %s"
,
filename
);
byte_t
*
p
=
text
(
port
);
struct
value
*
exp
=
cherry_read
(
&
p
,
buffer
,
SCANNER_BUFFERSIZE
);
struct
value
*
env
=
core_environment
();
...
...
@@ -1209,6 +1233,9 @@ void cherry_main(const char* filename, const byte_t* method, struct value* args)
exp
=
cherry_read
(
&
p
,
buffer
,
SCANNER_BUFFERSIZE
);
}
if
(
method
)
cherry_eval
(
env
,
cons
(
symbol
(
method
),
args
));
exit
(
EXIT_SUCCESS
);
}
...
...
source/bootstrap.h
View file @
406c9e49
...
...
@@ -130,8 +130,8 @@ struct value* cons(struct value* head, struct value* tail);
#define SYMBOL_LEFT(node) HEAD(TAIL(node))
#define SYMBOL_RIGHT(node) TAIL(TAIL(node))
#define EXTEND_ENV(env
, vars, vals) cons(cons(vars,vals
), env)
#define INITIAL_ENV EXTEND_ENV(
Emptylist, Emptylist,
Emptylist)
#define EXTEND_ENV(env
) cons(cons(Emptylist,Emptylist
), env)
#define INITIAL_ENV EXTEND_ENV(Emptylist)
#define FIRST_FRAME(env) HEAD(env)
#define PARENT_FRAMES(env) TAIL(env)
#define FRAME_VARIABLES(frame) HEAD(frame)
...
...
@@ -156,3 +156,4 @@ 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
);
struct
value
*
core_write
(
struct
value
*
env
,
struct
value
*
args
);
Write
Preview
Supports
Markdown
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