Skip to content
GitLab
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
bd9892a7
Commit
bd9892a7
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2002-11-09 18:11:18 by cvscast] Empty log message
Original author: cvscast Date: 2002-11-09 18:11:19+00:00
parent
5ed31ef4
Changes
9
Hide whitespace changes
Inline
Side-by-side
depend
View file @
bd9892a7
...
...
@@ -66,10 +66,10 @@ runtime/eval.cmo: runtime/load_xml.cmi runtime/print_xml.cmo \
runtime/eval.cmx: runtime/load_xml.cmx runtime/print_xml.cmx \
runtime/run_dispatch.cmx typing/typed.cmx types/types.cmx \
runtime/value.cmx runtime/eval.cmi
runtime/load_xml.cmo: types/sortedMap.cmi types/types.cmi
runtime/value.cmi
\
runtime/load_xml.cmi
runtime/load_xml.cmx: types/sortedMap.cmx types/types.cmx
runtime/value.cmx
\
runtime/load_xml.cmi
runtime/load_xml.cmo:
parser/location.cmi
types/sortedMap.cmi types/types.cmi \
runtime/value.cmi
runtime/load_xml.cmi
runtime/load_xml.cmx:
parser/location.cmx
types/sortedMap.cmx types/types.cmx \
runtime/value.cmx
runtime/load_xml.cmi
runtime/print_xml.cmo: types/chars.cmi types/sequence.cmi types/types.cmi \
runtime/value.cmi
runtime/print_xml.cmx: types/chars.cmx types/sequence.cmx types/types.cmx \
...
...
@@ -83,13 +83,19 @@ runtime/value.cmo: types/chars.cmi types/sequence.cmi types/sortedMap.cmi \
runtime/value.cmx: types/chars.cmx types/sequence.cmx types/sortedMap.cmx \
types/types.cmx runtime/value.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
parser/location.cmi parser/parser.cmi types/patterns.cmi typing/typer.cmi \
types/types.cmi runtime/value.cmi parser/wlexer.cmo driver/cduce.cmi
parser/location.cmi parser/parser.cmi types/patterns.cmi typing/typed.cmo \
typing/typer.cmi types/types.cmi runtime/value.cmi parser/wlexer.cmo \
driver/cduce.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx runtime/eval.cmx \
parser/location.cmx parser/parser.cmx types/patterns.cmx typing/typer.cmx \
types/types.cmx runtime/value.cmx parser/wlexer.cmx driver/cduce.cmi
parser/location.cmx parser/parser.cmx types/patterns.cmx typing/typed.cmx \
typing/typer.cmx types/types.cmx runtime/value.cmx parser/wlexer.cmx \
driver/cduce.cmi
driver/run.cmo: driver/cduce.cmi parser/location.cmi
driver/run.cmx: driver/cduce.cmx parser/location.cmx
driver/webiface.cmo: driver/cduce.cmi runtime/load_xml.cmi \
parser/location.cmi
driver/webiface.cmx: driver/cduce.cmx runtime/load_xml.cmx \
parser/location.cmx
parser/parser.cmi: parser/ast.cmo
typing/typer.cmi: parser/ast.cmo typing/typed.cmo types/types.cmi
types/boolean.cmi: types/sortedList.cmi
...
...
driver/cduce.ml
View file @
bd9892a7
...
...
@@ -5,7 +5,10 @@ let print_norm ppf d =
let
rec
print_exn
ppf
=
function
|
Location
(
loc
,
exn
)
->
Format
.
fprintf
ppf
"Error %a:@
\n
%a"
Location
.
print_loc
loc
print_exn
exn
Format
.
fprintf
ppf
"Error %a:@
\n
"
Location
.
print_loc
loc
;
Format
.
pp_print_flush
ppf
()
;
Format
.
fprintf
(
Location
.
output
()
)
"%a"
Location
.
html_hilight
loc
;
print_exn
ppf
exn
|
Value
.
CDuceExn
v
->
Format
.
fprintf
ppf
"Uncaught CDuce exception: @[%a@]@
\n
"
Value
.
print
v
...
...
@@ -47,6 +50,8 @@ let rec print_exn ppf = function
Format
.
fprintf
ppf
"This comment contains an unterminated string literal@
\n
"
|
Parser
.
Error
s
|
Stream
.
Error
s
->
Format
.
fprintf
ppf
"Parsing error: %s@
\n
"
s
|
Location
.
Generic
s
->
Format
.
fprintf
ppf
"%s@
\n
"
s
|
exn
->
Format
.
fprintf
ppf
"%s@
\n
"
(
Printexc
.
to_string
exn
)
...
...
@@ -153,6 +158,7 @@ let run ppf input =
|
Ast
.
EvalStatement
e
->
let
(
fv
,
e
)
=
Typer
.
expr
e
in
let
t
=
Typer
.
type_check
!
typing_env
e
Types
.
any
true
in
Location
.
dump_loc
(
Location
.
output
()
)
e
.
Typed
.
exp_loc
;
Format
.
fprintf
ppf
"|- %a@
\n
@."
print_norm
t
;
let
v
=
Eval
.
eval
!
eval_env
e
in
Format
.
fprintf
ppf
"=> @[%a@]@
\n
@."
Value
.
print
v
...
...
driver/webiface.ml
View file @
bd9892a7
...
...
@@ -4,12 +4,16 @@ open Netcgi
let
main
(
cgi
:
Netcgi
.
std_activation
)
=
try
cgi
#
set_header
()
;
let
cmd
=
cgi
#
argument_value
"
cmd
"
in
let
src
=
cgi
#
argument_value
"
prog
"
in
Location
.
set_source
(
`String
cmd
);
let
ppf
=
Format
.
str_formatter
and
input
=
Stream
.
of_string
cmd
in
Cduce
.
run
ppf
input
;
and
input
=
Stream
.
of_string
src
in
Location
.
set_source
(
`String
src
);
Location
.
set_viewport
`Html
;
Location
.
set_output
ppf
;
Load_xml
.
set_auth
false
;
Cduce
.
run
(
Location
.
protect
ppf
)
input
;
let
res
=
Format
.
flush_str_formatter
()
in
cgi
#
output
#
output_string
(
"\
...
...
@@ -19,11 +23,11 @@ let main (cgi : Netcgi.std_activation) =
</head>
<body>
<h1>CDuce online prototype</h1>
Command == ["
^
cmd
^
"]<br>
Result:<pre>"
^
res
^
"</pre>
<pre>"
^
res
^
"</pre>
<form method=get>
<input type=text name=cmd length=30>
<textarea name=prog cols=80 rows=25></textarea>
<input type=submit>
</form>
</body>
</html>
...
...
@@ -34,6 +38,7 @@ let main (cgi : Netcgi.std_activation) =
cgi
#
output
#
rollback_work
()
;
cgi
#
set_header
~
status
:
`Internal_server_error
()
;
cgi
#
output
#
output_string
"<h1>Internal software error!</h1>"
;
cgi
#
output
#
output_string
(
Printexc
.
to_string
exn
);
cgi
#
output
#
commit_work
()
let
()
=
...
...
parser/location.ml
View file @
bd9892a7
type
loc
=
int
*
int
type
source
=
[
`None
|
`File
of
string
|
`Stream
|
`String
of
string
]
type
viewport
=
[
`Html
|
`Text
]
exception
Location
of
loc
*
exn
exception
Generic
of
string
let
noloc
=
(
-
1
,-
1
)
let
source
=
ref
`None
let
set_source
s
=
source
:=
s
let
viewport
=
ref
`Text
let
set_viewport
v
=
viewport
:=
v
let
get_line_number
src
i
=
let
ic
=
open_in_bin
src
in
let
rec
aux
pos
line
start
=
...
...
@@ -38,10 +43,53 @@ let print_loc ppf (i,j) =
Format
.
fprintf
ppf
"at lines %i (char %i) - %i (char %i)"
l1
c1
l2
c2
let
extr
s
i
j
=
Netencoding
.
Html
.
encode_from_latin1
(
String
.
sub
s
i
(
j
-
i
))
let
dump_loc
ppf
(
i
,
j
)
=
match
(
!
source
,
!
viewport
)
with
|
(
`String
s
,
`Html
)
->
if
(
i
<
0
)
then
Format
.
fprintf
ppf
"<b>DUMMY</b>@
\n
"
else
Format
.
fprintf
ppf
"<i>%s</i>@
\n
"
(
extr
s
i
j
)
|
_
->
()
let
rec
beg_of_line
s
i
=
if
(
i
=
0
)
||
(
s
.
[
i
-
1
]
=
'\n'
)
then
i
else
beg_of_line
s
(
i
-
1
)
let
rec
end_of_line
s
i
=
if
(
i
=
String
.
length
s
)
||
(
s
.
[
i
]
=
'\n'
)
then
i
else
end_of_line
s
(
i
+
1
)
let
html_hilight
ppf
(
i
,
j
)
=
match
(
!
source
,
!
viewport
)
with
|
`String
s
,
`Html
->
let
i0
=
beg_of_line
s
i
in
let
j0
=
end_of_line
s
j
in
Format
.
fprintf
ppf
"<i>%s<font color=red><b>%s</b></font>%s</div></i>@
\n
"
(
extr
s
i0
i
)
(
extr
s
i
j
)
(
extr
s
j
j0
)
|
_
->
()
type
'
a
located
=
{
loc
:
loc
;
descr
:
'
a
}
type
expr
=
A
|
B
of
expr
located
let
rec
recurs
f
x
=
f
(
recurs
f
)
x
.
loc
x
.
descr
let
mk
loc
x
=
{
loc
=
loc
;
descr
=
x
}
let
protect
ppf
=
match
!
viewport
with
|
`Html
->
Format
.
make_formatter
(
fun
s
i
j
->
Format
.
pp_print_string
ppf
(
extr
s
i
(
i
+
j
)))
(
fun
()
->
Format
.
pp_print_flush
ppf
()
)
|
_
->
ppf
let
outputr
=
ref
Format
.
std_formatter
let
output
()
=
!
outputr
let
set_output
f
=
outputr
:=
f
parser/location.mli
View file @
bd9892a7
type
loc
=
int
*
int
type
source
=
[
`None
|
`File
of
string
|
`Stream
|
`String
of
string
]
(* Locations in source file,
and presentation of results and errors *)
type
loc
=
int
*
int
exception
Location
of
loc
*
exn
exception
Generic
of
string
val
noloc
:
loc
type
source
=
[
`None
|
`File
of
string
|
`Stream
|
`String
of
string
]
val
set_source
:
source
->
unit
val
noloc
:
loc
val
get_line_number
:
string
->
int
->
int
*
int
type
viewport
=
[
`Html
|
`Text
]
val
set_viewport
:
viewport
->
unit
val
set_output
:
Format
.
formatter
->
unit
val
output
:
unit
->
Format
.
formatter
val
protect
:
Format
.
formatter
->
Format
.
formatter
val
print_loc
:
Format
.
formatter
->
loc
->
unit
val
dump_loc
:
Format
.
formatter
->
loc
->
unit
val
html_hilight
:
Format
.
formatter
->
loc
->
unit
type
'
a
located
=
{
loc
:
loc
;
descr
:
'
a
}
val
recurs
:
((
'
a
located
->
'
b
)
->
loc
->
'
a
->
'
b
)
->
(
'
a
located
->
'
b
)
val
mk
:
loc
->
'
a
->
'
a
located
parser/parser.ml
View file @
bd9892a7
...
...
@@ -21,7 +21,7 @@ let rec multi_prod loc = function
let
rec
tuple
loc
=
function
|
[
x
]
->
x
|
x
::
l
->
mk
(
x
.
loc
)
(
Pair
(
x
,
tuple
loc
l
))
|
x
::
l
->
mk
loc
(
Pair
(
x
,
tuple
loc
l
))
|
[]
->
assert
false
let
tuple_queue
=
...
...
runtime/load_xml.ml
View file @
bd9892a7
...
...
@@ -2,6 +2,9 @@
(*TODO: close the file ! *)
let
auth
=
ref
true
let
set_auth
b
=
auth
:=
b
open
Pxp_yacc
open
Pxp_lexer_types
open
Pxp_types
...
...
@@ -70,3 +73,15 @@ let run s =
get
()
;
parse_doc
()
let
run
s
=
if
not
!
auth
then
raise
(
Location
.
Generic
"load_xml: operation not authorized in the web prototype"
);
try
run
s
with
exn
->
raise
(
Location
.
Generic
(
Pxp_types
.
string_of_exn
exn
))
runtime/load_xml.mli
View file @
bd9892a7
val
set_auth
:
bool
->
unit
val
run
:
string
->
Value
.
t
tests/biblio.cd
View file @
bd9892a7
...
...
@@ -19,22 +19,22 @@ type Mix = <h1>[Mix*]
let fun do_authors ([Author+] -> [Mix*])
| [
<author>
a ] -> a
| [
<author>
a
<author>
b ] -> a " and, " b
| [
<author>
a; x] -> a ", " (do_authors x)
in
| [
<author>
a; x] -> a ", " (do_authors x)
;;
let fun do_paper (Paper ->
<li>
[Mix*])
<paper>
[ x::(_* )
<title>
t
<conference>
c
<file>
f ] ->
(* Here, type inference says: x : [Author+] ... *)
let authors = do_authors x in
<li>
([
<a
href=
f
>
t ] authors "; in " [
<em>
c ] "." )
in
<li>
([
<a
href=
f
>
t ] authors "; in " [
<em>
c ] "." )
;;
let fun do_biblio (Biblio -> Html)
<bibliography>
[
<heading>
h; p ] ->
let body = match p with
| [] -> "Empty bibliography"
| l -> [
<h1>
h
<ul>
(map l with x -> do_paper x) ]
in
<html>
[
<head>
[
<title>
h ]
<body>
body ]
in
<html>
[
<head>
[
<title>
h ]
<body>
body ]
;;
let bib : Biblio =
<bibliography>
[
<heading>
"Alain Frisch's bibliography"
...
...
@@ -63,7 +63,7 @@ let bib : Biblio =
<conference>
"PLANX-02"
<file>
"planx.ps.gz"
]
]
in
]
;;
do_biblio bib
;;
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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