@_p_Scheme_Env::ISA
= __PACKAGE__;
my
$SIGILS
=
'!?$~+.@^%&'
;
my
@SIGILS
=
split
(//,
$SIGILS
);
sub
new {
my
$env
= S->basic_env;
$env
->_init_perl_wrappers;
return
$env
;
}
sub
lookup {
my
(
$self
,
$name
) =
@_
;
return
$name
if
UNIVERSAL::isa(
$name
, S.
'::Object'
) and
$name
->isa(
'CODE'
);
my
$sym
= S->intern_symbol(
$name
);
my
$obj
= S->lookup_global(
$sym
,
$self
);
$Objects
{S->REFADDR(
$obj
)} ||=
$self
;
return
$obj
;
}
sub
define {
my
(
$self
,
$name
,
$code
,
$sigil
) =
@_
;
$sigil
||=
substr
(
$name
, -1)
if
$name
=~ /[
$SIGILS
]$/o;
if
(!
defined
(
$code
)) {
no
strict
'refs'
;
foreach
my
$sym
(
grep
!/^[^a-z]|\W/,
sort
keys
%{
"$name\::"
}) {
my
$code
= *{${
"$name\::"
}{
$sym
}}{CODE} or
next
;
$sym
=~
tr
/_/-/;
$self
->define(
"$name\::$sym"
,
$code
);
}
$code
=
$name
;
}
elsif
(
ref
(
$code
) eq
'CODE'
) {
foreach
my
$s
(
@SIGILS
) {
my
$obj
=
$self
->lambda(
$code
,
$sigil
);
S->add_global(
$name
.
$s
,
$obj
,
$self
);
}
}
my
$obj
=
$self
->lambda(
$code
,
$sigil
);
S->add_global(
$name
,
$obj
,
$self
);
return
$self
->lookup(
$name
);
}
sub
lambda {
my
(
$self
,
$code
,
$sigil
) =
@_
;
my
$name
=
"$code"
;
$name
.=
":$sigil"
if
$sigil
;
my
$obj
= (
ref
(
$code
) eq
'CODE'
)
? S->make_perl_prim_w_arity(
$code
,
"$name"
, 0, -1,
$sigil
)
: S->make_perl_object_w_arity(
$code
,
"$name"
, 1, -1,
$sigil
);
$Objects
{S->REFADDR(
$obj
)} ||=
$self
;
return
$obj
;
}
sub
eval
{
my
$self
=
shift
;
my
$obj
=
do
{
UNIVERSAL::isa(
$_
[0],
"Language::MzScheme::Object"
)
? Language::MzScheme::mzscheme_do_eval(
$_
[0],
$self
)
: Language::MzScheme::mzscheme_do_eval_string_all(
$_
[0],
$self
, 1);
};
$Objects
{S->REFADDR(
$obj
)} ||=
$self
if
ref
(
$obj
);
return
$obj
;
}
sub
apply {
my
(
$self
,
$name
) =
splice
(
@_
, 0, 2);
@_
=
map
S->from_perl_scalar(
$_
),
@_
;
my
$obj
= S->do_apply(
$self
->lookup(
$name
), 0+
@_
, \
@_
);
$Objects
{S->REFADDR(
$obj
)} ||=
$self
if
ref
(
$obj
);
return
$obj
;
}
sub
val {
my
$self
=
shift
;
my
$obj
= S->from_perl_scalar(
$_
[0]);
$Objects
{S->REFADDR(
$obj
)} ||=
$self
if
ref
(
$obj
);
return
$obj
;
}
sub
sym {
my
$self
=
shift
;
my
$obj
= S->intern_symbol(
"$_[0]"
);
$Objects
{S->REFADDR(
$obj
)} ||=
$self
if
ref
(
$obj
);
return
$obj
;
}
foreach
my
$sym
(
qw(
perl_do perl_eval perl_require perl_use
)
) {
no
strict
'refs'
;
my
$proc
=
$sym
;
$proc
=~
tr
/_/-/;
*$sym
=
sub
{
my
$self
=
shift
;
$self
->apply(
$proc
,
@_
);
};
}
sub
_init_perl_wrappers {
my
$self
=
shift
;
my
$env_pkg
= __PACKAGE__.
'::__eval'
;
no
strict
'refs'
;
*{
"$env_pkg\::mz_eval"
} =
sub
{
$self
->
eval
(
@_
) };
*{
"$env_pkg\::mz_apply"
} =
sub
{
$self
->apply(
@_
) };
*{
"$env_pkg\::mz_lambda"
} =
sub
{
$self
->lambda(
@_
) };
*{
"$env_pkg\::mz_define"
} =
sub
{
$self
->define(
@_
) };
*{
"$env_pkg\::mz_lookup"
} =
sub
{
$self
->lookup(
@_
) };
$self
->define(
'perl-do'
,
$self
->_wrap_do(
$env_pkg
));
$self
->define(
'perl-eval'
,
$self
->_wrap_eval(
$env_pkg
));
$self
->define(
'perl-use'
,
$self
->_wrap_use(
$env_pkg
));
$self
->define(
'perl-require'
,
$self
->_wrap_require(
$env_pkg
));
}
sub
_wrap_require {
my
(
$self
,
$env_pkg
) =
@_
;
return
sub
{
my
$pkg
=
shift
;
$pkg
=~ s{::}{/}g;
$pkg
.=
".pm"
if
index
(
$pkg
,
'.'
) == -1;
local
$@;
eval
"package $env_pkg; require \$pkg;"
;
die
$@
if
$@;
$pkg
=~ s{/}{::}g;
$pkg
=~ s{\.pm$}{}i;
$self
->define(
$pkg
);
return
$pkg
;
};
}
sub
_wrap_use {
my
(
$self
,
$env_pkg
) =
@_
;
return
sub
{
no
strict
'refs'
;
my
$pkg
=
shift
;
my
%seen
=
map
( (
$_
=> 1 ),
keys
%{
"$env_pkg\::"
} );
local
$@;
my
@args
;
my
$eval
=
"package $env_pkg;\nuse $pkg "
.(
@_
?
do
{
@args
=
map
{
$_
->isa(
'ARRAY'
) ?
@$_
:
$_
}
@_
;
'@args;'
;
} :
';'
);
eval
$eval
;
die
$@
if
$@;
foreach
my
$sym
(
grep
!/^[^a-z]|\W/,
sort
keys
%{
"$env_pkg\::"
}) {
next
if
$seen
{
$sym
};
my
$code
= *{${
"$pkg\::"
}{
$sym
}}{CODE} or
next
;
$self
->define(
$sym
,
$code
);
}
$self
->define(
$pkg
);
return
$pkg
;
};
}
sub
_wrap_do {
my
(
$self
,
$env_pkg
) =
@_
;
return
sub
{
my
$file
=
shift
;
local
$@;
return
eval
"package $env_pkg;\ndo \$file;"
;
}
}
sub
_wrap_eval {
my
(
$self
,
$env_pkg
) =
@_
;
return
sub
{
local
$@;
return
eval
"package $env_pkg;\n@_;"
;
}
}
1;