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
79e1b5f4
Commit
79e1b5f4
authored
Jul 20, 2013
by
Chris Müller
Browse files
Add more basic functions to runtime environment
Add tuple, nth, string->fixnum and string->tuple
parent
9f8a8b50
Changes
3
Hide whitespace changes
Inline
Side-by-side
bootstrap/bootstrap.h
View file @
79e1b5f4
...
...
@@ -201,8 +201,11 @@ struct cherry_value* cherry_core_list(struct cherry_environment* env, struct
struct
cherry_value
*
cherry_core_head
(
struct
cherry_environment
*
env
,
struct
cherry_value
*
args
);
struct
cherry_value
*
cherry_core_tail
(
struct
cherry_environment
*
env
,
struct
cherry_value
*
args
);
struct
cherry_value
*
cherry_core_length
(
struct
cherry_environment
*
env
,
struct
cherry_value
*
args
);
struct
cherry_value
*
cherry_core_nth
(
struct
cherry_environment
*
env
,
struct
cherry_value
*
args
);
struct
cherry_value
*
cherry_core_string_to_list
(
struct
cherry_environment
*
env
,
struct
cherry_value
*
args
);
struct
cherry_value
*
cherry_core_string_to_tuple
(
struct
cherry_environment
*
env
,
struct
cherry_value
*
args
);
struct
cherry_value
*
cherry_core_string_to_fixnum
(
struct
cherry_environment
*
env
,
struct
cherry_value
*
args
);
struct
cherry_value
*
cherry_core_tuple
(
struct
cherry_environment
*
env
,
struct
cherry_value
*
args
);
...
...
bootstrap/primitives.c
View file @
79e1b5f4
...
...
@@ -290,20 +290,78 @@ cherry_core_tail(struct cherry_environment* env, struct cherry_value* args)
struct
cherry_value
*
cherry_core_length
(
struct
cherry_environment
*
env
,
struct
cherry_value
*
args
)
{
if
(
IS_NULL
(
args
)
||
!
IS_LIST
(
HEAD
(
args
)))
cherry_env_raise
(
env
,
cherry_string
(
"no list is given for the first operand"
));
if
(
IS_NULL
(
args
))
return
cherry_fixnum
(
0
);
struct
cherry_value
*
value
=
HEAD
(
args
);
fixnum_t
length
=
0
;
switch
(
value
->
tag
)
{
case
PAIR
:
while
(
!
IS_NULL
(
args
))
{
length
++
;
args
=
TAIL
(
args
);
}
break
;
case
STRING
:
return
cherry_fixnum
(
cherry_utf8_len
(
value
->
string_value
));
case
TUPLE
:
return
cherry_fixnum
(
TUPLE_SIZE
(
value
));
default:
cherry_env_raise
(
env
,
cherry_string
(
"length expects a string, tuple or a pair for the first operand"
));
}
return
cherry_fixnum
(
length
);
}
struct
cherry_value
*
cherry_core_nth
(
struct
cherry_environment
*
env
,
struct
cherry_value
*
args
)
{
if
(
IS_NULL
(
args
)
||
IS_NULL
(
TAIL
(
args
))
||
!
IS_FIXNUM
(
HEAD
(
TAIL
(
args
))))
cherry_env_raise
(
env
,
cherry_string
(
"nth expects a value and a following fixnum as index"
));
struct
cherry_value
*
value
=
HEAD
(
args
);
fixnum_t
index
=
HEAD
(
TAIL
(
args
))
->
fixnum_value
;
switch
(
value
->
tag
)
{
case
PAIR
:
if
(
index
>=
0
)
{
struct
cherry_value
*
p
=
value
;
while
(
index
--
>
0
&&
!
IS_NULL
(
p
))
p
=
TAIL
(
p
);
return
IS_NULL
(
p
)
?
p
:
HEAD
(
p
);
}
break
;
case
STRING
:
if
(
index
>=
0
&&
index
<
cherry_utf8_len
(
value
->
string_value
))
{
const
byte_t
*
p
=
value
->
string_value
;
struct
cherry_value
*
lst
=
HEAD
(
args
);
fixnum_t
length
=
0
;
while
(
index
--
>
0
)
p
=
cherry_utf8_next
(
p
)
;
while
(
!
IS_NULL
(
lst
))
{
length
++
;
lst
=
TAIL
(
lst
);
return
cherry_char
(
cherry_utf8_get
(
p
));
}
break
;
case
TUPLE
:
if
(
index
>=
0
&&
index
<
TUPLE_SIZE
(
value
))
return
TUPLE_DATA
(
value
)[
index
];
break
;
default:
cherry_env_raise
(
env
,
cherry_string
(
"length expects a string, tuple or a pair for the first operand"
));
}
return
cherry_fixnum
(
length
);
}
cherry_env_raise
(
env
,
cherry_string
(
"Out of Bounds Error"
));
return
cherry_false
;
}
struct
cherry_value
*
...
...
@@ -326,6 +384,42 @@ cherry_core_string_to_list(struct cherry_environment* env, struct cherry_value*
}
struct
cherry_value
*
cherry_core_string_to_tuple
(
struct
cherry_environment
*
env
,
struct
cherry_value
*
args
)
{
if
(
IS_NULL
(
args
)
||
!
IS_STRING
(
HEAD
(
args
)))
cherry_env_raise
(
env
,
cherry_string
(
"string->list accepts only one string as argument"
));
const
byte_t
*
p
=
HEAD
(
args
)
->
string_value
;
size_t
size
=
cherry_utf8_len
(
p
);
struct
cherry_value
*
tuple
=
cherry_tuple_new
(
size
);
size_t
i
;
for
(
i
=
0
;
i
<
size
;
i
++
)
{
TUPLE_DATA
(
tuple
)[
i
]
=
cherry_char
(
cherry_utf8_get
(
p
));
p
=
cherry_utf8_next
(
p
);
}
return
tuple
;
}
struct
cherry_value
*
cherry_core_string_to_fixnum
(
struct
cherry_environment
*
env
,
struct
cherry_value
*
args
)
{
if
(
IS_NULL
(
args
)
||
!
IS_STRING
(
HEAD
(
args
)))
cherry_env_raise
(
env
,
cherry_string
(
"string->fixnum accepts only one string as argument"
));
const
byte_t
*
p
=
HEAD
(
args
)
->
string_value
;
if
(
*
p
!=
'\0'
&&
*
(
p
+
1
)
==
'b'
)
return
cherry_fixnum
(
strtol
(
p
+
2
,
0
,
2
));
else
return
cherry_fixnum
(
strtol
(
p
,
0
,
0
));
}
struct
cherry_value
*
cherry_core_not
(
struct
cherry_environment
*
env
,
struct
cherry_value
*
args
)
{
...
...
@@ -480,11 +574,11 @@ cherry_core_greater_equal(struct cherry_environment* env, struct cherry_value* a
struct
cherry_value
*
next
=
HEAD
(
args
);
switch
(
next
->
tag
)
{
case
FIXNUM
:
if
(
next
->
fixnum_value
<
val
->
fixnum_value
)
if
(
next
->
fixnum_value
>
val
->
fixnum_value
)
return
cherry_false
;
break
;
case
FLOAT
:
if
(
next
->
float_value
<
(
val
->
fixnum_value
))
if
(
next
->
float_value
>
(
val
->
fixnum_value
))
return
cherry_false
;
break
;
...
...
@@ -498,11 +592,11 @@ cherry_core_greater_equal(struct cherry_environment* env, struct cherry_value* a
struct
cherry_value
*
next
=
HEAD
(
args
);
switch
(
next
->
tag
)
{
case
FIXNUM
:
if
(
next
->
fixnum_value
<
val
->
float_value
)
if
(
next
->
fixnum_value
>
val
->
float_value
)
return
cherry_false
;
break
;
case
FLOAT
:
if
(
next
->
float_value
<
val
->
float_value
)
if
(
next
->
float_value
>
val
->
float_value
)
return
cherry_false
;
break
;
...
...
@@ -533,11 +627,11 @@ cherry_core_less_equal(struct cherry_environment* env, struct cherry_value* args
struct
cherry_value
*
next
=
HEAD
(
args
);
switch
(
next
->
tag
)
{
case
FIXNUM
:
if
(
next
->
fixnum_value
>
val
->
fixnum_value
)
if
(
next
->
fixnum_value
<
val
->
fixnum_value
)
return
cherry_false
;
break
;
case
FLOAT
:
if
(
next
->
float_value
>
(
val
->
fixnum_value
))
if
(
next
->
float_value
<
(
val
->
fixnum_value
))
return
cherry_false
;
break
;
...
...
@@ -551,11 +645,11 @@ cherry_core_less_equal(struct cherry_environment* env, struct cherry_value* args
struct
cherry_value
*
next
=
HEAD
(
args
);
switch
(
next
->
tag
)
{
case
FIXNUM
:
if
(
next
->
fixnum_value
>
val
->
float_value
)
if
(
next
->
fixnum_value
<
val
->
float_value
)
return
cherry_false
;
break
;
case
FLOAT
:
if
(
next
->
float_value
>
val
->
float_value
)
if
(
next
->
float_value
<
val
->
float_value
)
return
cherry_false
;
break
;
...
...
bootstrap/runtime.c
View file @
79e1b5f4
...
...
@@ -103,11 +103,16 @@ cherry_environment(void)
proc_to_env
(
env
,
"cons"
,
cherry_core_cons
);
proc_to_env
(
env
,
"list"
,
cherry_core_list
);
proc_to_env
(
env
,
"tuple"
,
cherry_core_tuple
);
proc_to_env
(
env
,
"head"
,
cherry_core_head
);
proc_to_env
(
env
,
"tail"
,
cherry_core_tail
);
proc_to_env
(
env
,
"length"
,
cherry_core_length
);
proc_to_env
(
env
,
"tuple"
,
cherry_core_tuple
);
proc_to_env
(
env
,
"nth"
,
cherry_core_nth
);
proc_to_env
(
env
,
"string->fixnum"
,
cherry_core_string_to_fixnum
);
proc_to_env
(
env
,
"string->list"
,
cherry_core_string_to_list
);
proc_to_env
(
env
,
"string->tuple"
,
cherry_core_string_to_tuple
);
proc_to_env
(
env
,
"exit"
,
cherry_system_exit
);
return
env
;
...
...
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