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
cduce
cduce
Commits
7088b4f3
Commit
7088b4f3
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2003-10-13 20:03:05 by cvscast] Remove -o; add -I --obj-dir; error messages
Original author: cvscast Date: 2003-10-13 20:03:06+00:00
parent
1a1ea967
Changes
7
Hide whitespace changes
Inline
Side-by-side
Makefile.distrib
View file @
7088b4f3
...
...
@@ -173,13 +173,13 @@ driver/examples.ml: cduce web/examples/build.cd web/examples/examples.xml
(
cd
web/examples
;
../../cduce
--quiet
build.cd
--arg
examples.xml
)
webpages
:
cduce web/site.cdo
(
cd
web
;
../cduce
--run
site
--arg
site.xml
)
(
cd
web
;
../cduce
--run
site
.cdo
--arg
site.xml
)
web/site.cdo
:
cduce web/xhtml.cdo web/site.cd
(
cd
web
;
.
./cduce
--compile
site
)
./cduce
-I
web/
--compile
web/
site
.cd
web/xhtml.cdo
:
cduce web/xhtml.cd
(
cd
web
;
.
./cduce
--compile
xhtml
)
./cduce
-I
web/
--compile
web/
xhtml
.cd
website
:
webpages webiface
...
...
driver/cduce.ml
View file @
7088b4f3
open
Location
open
Ident
exception
InvalidInputFilename
of
string
exception
InvalidObjectFilename
of
string
(* retuns a filename without the suffix suff if any *)
let
prefix
filename
suff
=
if
Filename
.
check_suffix
filename
suff
then
...
...
@@ -122,6 +125,31 @@ let rec print_exn ppf = function
Format
.
fprintf
ppf
"%a%s"
Location
.
html_hilight
loc
s
|
Parser
.
Error
s
|
Stream
.
Error
s
->
Format
.
fprintf
ppf
"Parsing error: %a@."
print_protect
s
|
Librarian
.
InconsistentCrc
id
->
Format
.
fprintf
ppf
"Link error:@."
;
let
name
=
Encodings
.
Utf8
.
to_string
(
Types
.
CompUnit
.
value
id
)
in
Format
.
fprintf
ppf
"Inconsistent checksum (compilation unit: %s)@."
name
|
Librarian
.
NoImplementation
id
->
Format
.
fprintf
ppf
"Link error:@."
;
let
name
=
Encodings
.
Utf8
.
to_string
(
Types
.
CompUnit
.
value
id
)
in
Format
.
fprintf
ppf
"No implementation found for compilation unit: %s@."
name
|
Librarian
.
Loop
id
->
Format
.
fprintf
ppf
"Compilation error:@."
;
let
name
=
Encodings
.
Utf8
.
to_string
(
Types
.
CompUnit
.
value
id
)
in
Format
.
fprintf
ppf
"Loop between compilation unit (compilation unit: %s)@."
name
|
InvalidInputFilename
f
->
Format
.
fprintf
ppf
"Compilation error:@."
;
Format
.
fprintf
ppf
"Source filename must have extension .cd@."
;
|
InvalidObjectFilename
f
->
Format
.
fprintf
ppf
"Compilation error:@."
;
Format
.
fprintf
ppf
"Object filename must have extension .cdo@."
;
|
Librarian
.
InvalidObject
f
->
Format
.
fprintf
ppf
"Invalid object file %s@."
f
|
Librarian
.
CannotOpen
f
->
Format
.
fprintf
ppf
"Cannot open file %s@."
f
|
Location
.
Generic
s
->
Format
.
fprintf
ppf
"%a@."
print_protect
s
|
exn
->
...
...
@@ -304,24 +332,38 @@ let run rule ppf ppf_err input =
let
script
=
run
Parser
.
prog
let
topinput
=
run
Parser
.
top_phrases
let
compile
src
out
=
let
compile
src
out
_dir
=
try
let
id
=
Types
.
CompUnit
.
mk
(
U
.
mk_latin1
src
)
in
Librarian
.
compile
id
;
Librarian
.
save
id
out
;
if
not
(
Filename
.
check_suffix
src
".cd"
)
then
raise
(
InvalidInputFilename
src
);
let
cu
=
Filename
.
chop_suffix
(
Filename
.
basename
src
)
".cd"
in
let
out_dir
=
match
out_dir
with
|
None
->
Filename
.
dirname
src
|
Some
x
->
x
in
let
out
=
Filename
.
concat
out_dir
(
cu
^
".cdo"
)
in
let
id
=
Types
.
CompUnit
.
mk
(
U
.
mk_latin1
cu
)
in
Librarian
.
compile
id
src
;
Librarian
.
save
id
out
;
exit
0
with
exn
->
catch_exn
Format
.
err_formatter
exn
;
exit
1
let
compile_run
src
argv
=
try
let
id
=
Types
.
CompUnit
.
mk
(
U
.
mk_latin1
src
)
in
Librarian
.
compile
id
;
if
not
(
Filename
.
check_suffix
src
".cd"
)
then
raise
(
InvalidInputFilename
src
);
let
cu
=
Filename
.
chop_suffix
(
Filename
.
basename
src
)
".cd"
in
let
id
=
Types
.
CompUnit
.
mk
(
U
.
mk_latin1
cu
)
in
Librarian
.
compile
id
src
;
Librarian
.
run
argv
id
with
exn
->
catch_exn
Format
.
err_formatter
exn
;
exit
1
let
run
obj
argv
=
try
let
id
=
Types
.
CompUnit
.
mk
(
U
.
mk_latin1
obj
)
in
if
not
(
Filename
.
check_suffix
obj
".cdo"
)
then
raise
(
InvalidObjectFilename
obj
);
let
cu
=
Filename
.
chop_suffix
(
Filename
.
basename
obj
)
".cdo"
in
let
id
=
Types
.
CompUnit
.
mk
(
U
.
mk_latin1
cu
)
in
Librarian
.
import
id
;
Librarian
.
run
argv
id
with
exn
->
catch_exn
Format
.
err_formatter
exn
;
exit
1
...
...
driver/cduce.mli
View file @
7088b4f3
...
...
@@ -8,6 +8,6 @@ val topinput : Format.formatter -> Format.formatter -> char Stream.t -> bool
val
dump_env
:
Format
.
formatter
->
unit
val
compile
:
string
->
string
->
unit
val
compile
:
string
->
string
option
->
unit
val
compile_run
:
string
->
Value
.
t
->
unit
val
run
:
string
->
Value
.
t
->
unit
driver/librarian.ml
View file @
7088b4f3
open
Location
open
Ident
module
C
=
Types
.
CompUnit
exception
InconsistentCrc
of
C
.
t
exception
Loop
of
C
.
t
exception
InvalidObject
of
string
exception
CannotOpen
of
string
exception
NoImplementation
of
C
.
t
type
t
=
{
typing
:
Typer
.
t
;
compile
:
Compile
.
env
;
...
...
@@ -24,6 +29,8 @@ let mk (typing,compile,code) =
let
magic
=
"CDUCE:compunit:00001"
let
obj_path
=
ref
[
""
]
let
tbl
=
C
.
Tbl
.
create
()
let
find
id
=
...
...
@@ -52,21 +59,14 @@ let deserialize_dep =
(
Serialize
.
Get
.
pair
Encodings
.
Utf8
.
deserialize
Serialize
.
Get
.
string
)
let
source_filename
id
=
let
filename
=
Encodings
.
Utf8
.
to_string
(
C
.
value
id
)
in
if
(
Filename
.
check_suffix
filename
"cd"
)
then
filename
else
filename
^
".cd"
let
object_filename
id
obj
=
match
obj
with
|
""
->
let
filename
=
Encodings
.
Utf8
.
to_string
(
C
.
value
id
)
in
(
if
(
Filename
.
check_suffix
filename
".cd"
)
then
Filename
.
chop_suffix
filename
".cd"
else
filename
)
^
".cdo"
|
_
->
obj
let
find_obj
id
=
let
base
=
Encodings
.
Utf8
.
to_string
(
C
.
value
id
)
^
".cdo"
in
let
p
=
List
.
find
(
fun
p
->
Sys
.
file_exists
(
Filename
.
concat
p
base
))
!
obj_path
in
Filename
.
concat
p
base
let
save
id
out
=
let
save
id
out
=
protect_op
"Save compilation unit"
;
let
cu
=
find
id
in
C
.
enter
id
;
let
raw
=
Serialize
.
Put
.
run
serialize
cu
in
...
...
@@ -89,15 +89,16 @@ let save id out=
let
depend
=
Serialize
.
Put
.
run
serialize_dep
depend
in
let
digest
=
Digest
.
string
raw
in
let
oc
=
open_out
(
object_filename
id
out
)
in
output_value
oc
(
digest
,
depend
,
raw
);
let
oc
=
open_out
out
in
Marshal
.
to_channel
oc
(
digest
,
depend
,
raw
)
[]
;
close_out
oc
let
check_digest
exp
digest
=
let
check_digest
id
exp
digest
=
match
digest
with
|
Some
x
->
if
exp
<>
x
then
failwith
"Inconsistent checksum"
if
exp
<>
x
then
raise
(
InconsistentCrc
id
)
|
None
->
assert
false
...
...
@@ -105,17 +106,19 @@ let loop = C.Tbl.create ()
let
check_loop
id
=
try
C
.
Tbl
.
find
loop
id
;
f
ai
lwith
"Loop between compilation units"
r
ai
se
(
Loop
id
)
with
Not_found
->
C
.
Tbl
.
add
loop
id
()
let
depends
=
ref
[]
let
during_compile
=
ref
false
let
rec
compile
id
=
let
rec
compile
id
src
=
check_loop
id
;
let
src
=
source_filename
id
in
let
ic
=
open_in
src
in
protect_op
"Compile external file"
;
let
ic
=
try
open_in
src
with
Sys_error
_
->
raise
(
CannotOpen
src
)
in
Location
.
push_source
(
`File
src
);
let
input
=
Stream
.
of_channel
ic
in
let
p
=
...
...
@@ -143,22 +146,28 @@ let rec compile id =
depends
:=
[]
let
rec
load
id
=
protect_op
"Load compiled compilation unit"
;
try
C
.
Tbl
.
find
tbl
id
with
Not_found
->
check_loop
id
;
if
!
during_compile
then
depends
:=
id
::
!
depends
;
(* Printf.eprintf "load %s: start\n" (object_filename id);
flush stderr; *)
let
filename
=
Encodings
.
Utf8
.
to_string
(
C
.
value
id
)
in
let
obj
=
try
find_obj
id
with
Not_found
->
raise
(
NoImplementation
id
)
in
let
ic
=
if
Filename
.
check_suffix
filename
".cdo"
then
open_in
filename
else
try
open_in
(
object_filename
id
""
)
with
Sys_error
_
->
open_in
(
filename
)
in
let
(
dig
,
depend
,
raw
)
=
input_value
ic
in
try
open_in
obj
with
Sys_error
_
->
raise
(
CannotOpen
obj
)
in
let
(
dig
,
depend
,
raw
)
=
try
Marshal
.
from_channel
ic
with
Failure
_
|
End_of_file
->
raise
(
InvalidObject
obj
)
in
close_in
ic
;
let
depend
=
Serialize
.
Get
.
run
deserialize_dep
depend
in
check_loop
id
;
if
!
during_compile
then
depends
:=
id
::
!
depends
;
List
.
iter
(
fun
(
id
,
dig
)
->
load_check
(
C
.
mk
id
)
dig
)
depend
;
C
.
enter
id
;
let
cu
=
Serialize
.
Get
.
run
deserialize
raw
in
...
...
@@ -170,7 +179,7 @@ let rec load id =
and
load_check
id
exp
=
let
cu
=
load
id
in
check_digest
exp
cu
.
digest
check_digest
id
exp
cu
.
digest
let
rec
run
argv
id
=
let
cu
=
find
id
in
...
...
driver/librarian.mli
View file @
7088b4f3
val
compile
:
Types
.
CompUnit
.
t
->
unit
exception
InconsistentCrc
of
Types
.
CompUnit
.
t
exception
Loop
of
Types
.
CompUnit
.
t
exception
InvalidObject
of
string
exception
CannotOpen
of
string
exception
NoImplementation
of
Types
.
CompUnit
.
t
val
obj_path
:
string
list
ref
val
compile
:
Types
.
CompUnit
.
t
->
string
->
unit
val
run
:
Value
.
t
->
Types
.
CompUnit
.
t
->
unit
val
import
:
Types
.
CompUnit
.
t
->
unit
val
save
:
Types
.
CompUnit
.
t
->
string
->
unit
...
...
driver/run.ml
View file @
7088b4f3
...
...
@@ -5,7 +5,7 @@ let () = State.close ();;
let
load_dump
=
ref
None
let
save_dump
=
ref
None
let
out_
file
=
ref
[]
(*
stores the name
of the output file *)
let
out_
dir
=
ref
[]
(*
directory
of the output file *)
let
src
=
ref
[]
let
args
=
ref
[]
...
...
@@ -37,11 +37,13 @@ let specs =
"--quiet"
,
Arg
.
Set
Cduce
.
quiet
,
" suppress normal output (typing, results)"
;
"--compile"
,
Arg
.
Set
compile
,
"compile the given CDuce file"
;
"-o"
,
Arg
.
String
(
fun
s
->
out_file
:=
s
::
!
out_file
)
,
" output file for compilation"
;
"compile the given CDuce file"
;
"--obj-dir"
,
Arg
.
String
(
fun
s
->
out_dir
:=
s
::
!
out_dir
)
,
"directory for the compiled .cdo file"
;
"-I"
,
Arg
.
String
(
fun
s
->
Librarian
.
obj_path
:=
s
::!
Librarian
.
obj_path
)
,
" add one directory to the lookup path for .cdo files"
;
"--run"
,
Arg
.
Set
run
,
" execute the given
CDuce object
file"
;
" execute the given
.cdo
file"
;
"--stdin"
,
Arg
.
Unit
(
fun
()
->
src
:=
""
::
!
src
)
,
" read CDuce script on standard input"
;
"--verbose"
,
Arg
.
Unit
(
fun
()
->
Stats
.
set_verbosity
Stats
.
Summary
)
,
...
...
@@ -85,21 +87,21 @@ let err s =
let
mode
=
Arg
.
parse
specs
(
fun
s
->
src
:=
s
::
!
src
)
"Usage:
\n
cduce [OPTIONS ...] [FILE ...] [--arg argument ...]
\n\n
Options:"
;
match
(
!
compile
,!
out_
file
,!
run
,!
src
,!
args
)
with
|
false
,
[
_
]
,
_
,
_
,
_
->
err
"-
o
option can be used only with
the
--compile
one
"
|
false
,
_
,
false
,
[]
,
args
->
`Toplevel
args
|
false
,
_
,
false
,
[
x
]
,
args
->
`Script
(
x
,
args
)
|
false
,
_
,
false
,
_
,
_
->
match
(
!
compile
,!
out_
dir
,!
run
,!
src
,!
args
)
with
|
false
,
_
::_
,
_
,
_
,
_
->
err
"-
-obj-dir
option can be used only with --compile"
|
false
,
[]
,
false
,
[]
,
args
->
`Toplevel
args
|
false
,
[]
,
false
,
[
x
]
,
args
->
`Script
(
x
,
args
)
|
false
,
[]
,
false
,
_
,
_
->
err
"Only one CDuce program can be executed at a time"
|
true
,
[
o
]
,
false
,
[
x
]
,
[]
->
`Compile
(
x
,
o
)
|
true
,
[]
,
false
,
[
x
]
,
[]
->
`Compile
(
x
,
""
)
|
true
,
[
o
]
,
false
,
[
x
]
,
[]
->
`Compile
(
x
,
Some
o
)
|
true
,
[]
,
false
,
[
x
]
,
[]
->
`Compile
(
x
,
None
)
|
true
,
[]
,
false
,
[]
,
[]
->
err
"Please specif
i
y the CDuce program to be compiled"
err
"Please specify the CDuce program to be compiled"
|
true
,
[]
,
false
,
_
,
[]
->
err
"Only one CDuce program can be compiled at a time"
|
true
,
_
,
false
,
_
,
[]
->
err
"Please specify
just
one output
file
"
err
"Please specify
only
one output
directory
"
|
true
,
_
,
false
,
_
,
_
->
err
"No argument can be passed to programs at compile time"
|
false
,
_
,
true
,
[
x
]
,
args
->
`Run
(
x
,
args
)
...
...
typing/typer.ml
View file @
7088b4f3
...
...
@@ -59,6 +59,16 @@ let empty_env = {
let
from_comp_unit
=
ref
(
fun
cu
->
assert
false
)
let
enter_cu
x
cu
env
=
{
env
with
cu
=
Env
.
add
(
ident
x
)
cu
env
.
cu
}
let
find_cu
loc
x
env
=
try
Env
.
find
x
env
.
cu
with
Not_found
->
raise_loc_generic
loc
(
"Unbound compunit prefix "
^
(
Ident
.
to_string
x
))
let
enter_type
id
t
env
=
{
env
with
ids
=
Env
.
add
id
(
Type
t
)
env
.
ids
}
let
enter_types
l
env
=
...
...
@@ -69,8 +79,8 @@ let find_type id env =
|
Type
t
->
t
|
Val
_
->
raise
Not_found
let
find_type_global
cu
id
env
=
let
cu
=
Env
.
find
cu
env
.
cu
in
let
find_type_global
loc
cu
id
env
=
let
cu
=
find
_cu
loc
cu
env
in
let
env
=
!
from_comp_unit
cu
in
find_type
id
env
...
...
@@ -99,12 +109,6 @@ let iter_values env f =
|
_
->
()
)
env
.
ids
let
enter_cu
x
cu
env
=
{
env
with
cu
=
Env
.
add
(
ident
x
)
cu
env
.
cu
}
let
find_cu
x
env
=
try
Env
.
find
x
env
.
cu
with
Not_found
->
failwith
(
"Unbound compunit prefix "
^
(
Ident
.
to_string
x
))
(* Namespaces *)
...
...
@@ -445,9 +449,10 @@ let rec derecurs env p = match p.descr with
|
cu
,
v
->
try
let
cu
=
ident
(
U
.
mk
cu
)
in
PType
(
find_type_global
cu
(
ident
v
)
env
.
penv_tenv
)
PType
(
find_type_global
p
.
loc
cu
(
ident
v
)
env
.
penv_tenv
)
with
Not_found
->
failwith
(
"Unbound external type "
^
cu
^
":"
^
(
U
.
to_string
v
)))
raise_loc_generic
p
.
loc
(
"Unbound external type "
^
cu
^
":"
^
(
U
.
to_string
v
)))
|
SchemaVar
(
kind
,
schema
,
item
)
->
PType
(
derecurs_schema
env
kind
schema
item
)
|
Recurs
(
p
,
b
)
->
derecurs
(
derecurs_def
env
b
)
p
...
...
@@ -796,7 +801,7 @@ let rec expr env loc = function
|
""
,
id
->
let
id
=
ident
id
in
exp
loc
(
Fv
.
singleton
id
)
(
Typed
.
Var
id
)
|
cu
,
id
->
let
cu
=
find_cu
(
ident
(
U
.
mk
cu
))
env
in
let
cu
=
find_cu
loc
(
ident
(
U
.
mk
cu
))
env
in
exp
loc
Fv
.
empty
(
Typed
.
ExtVar
(
cu
,
ident
id
)))
|
Apply
(
e1
,
e2
)
->
let
(
fv1
,
e1
)
=
expr
env
loc
e1
and
(
fv2
,
e2
)
=
expr
env
loc
e2
in
...
...
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