--- /dev/null
+experiment.cmo: cicCache.cmi cicPp.cmi configuration.cmo getter.cmi \
+ uriManager.cmi
+experiment.cmx: cicCache.cmx cicPp.cmx configuration.cmx getter.cmx \
+ uriManager.cmx
+cicCache.cmo: annotationParser.cmo cic.cmo cicParser.cmi cicSubstitution.cmi \
+ deannotate.cmo getter.cmi uriManager.cmi cicCache.cmi
+cicCache.cmx: annotationParser.cmx cic.cmx cicParser.cmx cicSubstitution.cmx \
+ deannotate.cmx getter.cmx uriManager.cmx cicCache.cmi
+cicCache.cmi: cic.cmo uriManager.cmi
+cicPp.cmo: cic.cmo cicCache.cmi uriManager.cmi cicPp.cmi
+cicPp.cmx: cic.cmx cicCache.cmx uriManager.cmx cicPp.cmi
+cicPp.cmi: cic.cmo
+cicParser.cmo: cicParser2.cmi cicParser3.cmi pxpUriResolver.cmo \
+ uriManager.cmi cicParser.cmi
+cicParser.cmx: cicParser2.cmx cicParser3.cmx pxpUriResolver.cmx \
+ uriManager.cmx cicParser.cmi
+cicParser.cmi: cic.cmo uriManager.cmi
+cicParser2.cmo: cic.cmo cicParser3.cmi uriManager.cmi cicParser2.cmi
+cicParser2.cmx: cic.cmx cicParser3.cmx uriManager.cmx cicParser2.cmi
+cicParser2.cmi: cic.cmo cicParser3.cmi
+cicParser3.cmo: cic.cmo uriManager.cmi cicParser3.cmi
+cicParser3.cmx: cic.cmx uriManager.cmx cicParser3.cmi
+cicParser3.cmi: cic.cmo uriManager.cmi
+cic.cmo: uriManager.cmi
+cic.cmx: uriManager.cmx
+getter.cmo: configuration.cmo uriManager.cmi getter.cmi
+getter.cmx: configuration.cmx uriManager.cmx getter.cmi
+getter.cmi: uriManager.cmi
+cicReduction.cmo: cic.cmo cicCache.cmi cicPp.cmi cicSubstitution.cmi \
+ uriManager.cmi cicReduction.cmi
+cicReduction.cmx: cic.cmx cicCache.cmx cicPp.cmx cicSubstitution.cmx \
+ uriManager.cmx cicReduction.cmi
+cicReduction.cmi: cic.cmo
+cicTypeChecker.cmo: cic.cmo cicCache.cmi cicPp.cmi cicReduction.cmi \
+ cicSubstitution.cmi uriManager.cmi cicTypeChecker.cmi
+cicTypeChecker.cmx: cic.cmx cicCache.cmx cicPp.cmx cicReduction.cmx \
+ cicSubstitution.cmx uriManager.cmx cicTypeChecker.cmi
+cicTypeChecker.cmi: uriManager.cmi
+reduction.cmo: cic.cmo cicCache.cmi cicPp.cmi cicReduction.cmi \
+ cicTypeChecker.cmi configuration.cmo getter.cmi uriManager.cmi
+reduction.cmx: cic.cmx cicCache.cmx cicPp.cmx cicReduction.cmx \
+ cicTypeChecker.cmx configuration.cmx getter.cmx uriManager.cmx
+theoryParser.cmo: pxpUriResolver.cmo theoryParser2.cmo
+theoryParser.cmx: pxpUriResolver.cmx theoryParser2.cmx
+theoryParser2.cmo: theory.cmo
+theoryParser2.cmx: theory.cmx
+theoryTypeChecker.cmo: cicCache.cmi cicTypeChecker.cmi theory.cmo \
+ theoryCache.cmo uriManager.cmi
+theoryTypeChecker.cmx: cicCache.cmx cicTypeChecker.cmx theory.cmx \
+ theoryCache.cmx uriManager.cmx
+cicCooking.cmo: cic.cmo cicCache.cmi uriManager.cmi cicCooking.cmi
+cicCooking.cmx: cic.cmx cicCache.cmx uriManager.cmx cicCooking.cmi
+cicCooking.cmi: cic.cmo uriManager.cmi
+cicFindParameters.cmo: cic.cmo cic2Xml.cmo cicCache.cmi configuration.cmo \
+ uriManager.cmi xml.cmi
+cicFindParameters.cmx: cic.cmx cic2Xml.cmx cicCache.cmx configuration.cmx \
+ uriManager.cmx xml.cmx
+theoryCache.cmo: getter.cmi theoryParser.cmo
+theoryCache.cmx: getter.cmx theoryParser.cmx
+fix_params.cmo: cicFindParameters.cmo configuration.cmo deannotate.cmo \
+ getter.cmi uriManager.cmi
+fix_params.cmx: cicFindParameters.cmx configuration.cmx deannotate.cmx \
+ getter.cmx uriManager.cmx
+cic2Xml.cmo: cic.cmo uriManager.cmi xml.cmi
+cic2Xml.cmx: cic.cmx uriManager.cmx xml.cmx
+xml.cmo: xml.cmi
+xml.cmx: xml.cmi
+uriManager.cmo: uriManager.cmi
+uriManager.cmx: uriManager.cmi
+cicSubstitution.cmo: cic.cmo cicSubstitution.cmi
+cicSubstitution.cmx: cic.cmx cicSubstitution.cmi
+cicSubstitution.cmi: cic.cmo uriManager.cmi
+mmlinterface.cmo: annotation2Xml.cmo cicAnnotationHinter.cmo cicCache.cmi \
+ cicTypeChecker.cmi cicXPath.cmo configuration.cmo getter.cmi \
+ theoryTypeChecker.cmo uriManager.cmi xml.cmi xsltProcessor.cmo
+mmlinterface.cmx: annotation2Xml.cmx cicAnnotationHinter.cmx cicCache.cmx \
+ cicTypeChecker.cmx cicXPath.cmx configuration.cmx getter.cmx \
+ theoryTypeChecker.cmx uriManager.cmx xml.cmx xsltProcessor.cmx
+xsltProcessor.cmo: configuration.cmo uriManager.cmi
+xsltProcessor.cmx: configuration.cmx uriManager.cmx
+deannotate.cmo: cic.cmo
+deannotate.cmx: cic.cmx
+cicXPath.cmo: cic.cmo
+cicXPath.cmx: cic.cmx
+annotationParser.cmo: annotationParser2.cmo pxpUriResolver.cmo
+annotationParser.cmx: annotationParser2.cmx pxpUriResolver.cmx
+annotationParser2.cmo: cic.cmo
+annotationParser2.cmx: cic.cmx
+annotation2Xml.cmo: cic.cmo uriManager.cmi xml.cmi
+annotation2Xml.cmx: cic.cmx uriManager.cmx xml.cmx
+cicAnnotationHinter.cmo: cic.cmo
+cicAnnotationHinter.cmx: cic.cmx
--- /dev/null
+==============================
+ISTRUZIONI PER CHI USA LA TCSH
+==============================
+
+Lanciare:
+
+ source PER_FARLO_ANDARE_TCSH
+
+Poi far partire altri due xterm.
+Nel primo lanciare:
+
+ make start-xaland3
+
+Nel secondo lanciare:
+
+ make start-http-getter
+
+Se non funziona significa che ce ne e' gia' uno attivo.
+
+Infini lanciare, dall'ultima shell,
+
+ ./mmlinterface.opt.saved
--- /dev/null
+LABLGTK_DIR = /usr/lib/ocaml/lablgtk
+LABLGTK_MATHVIEW_DIR = /usr/lib/ocaml/lablgtk/mathview
+PXP_DIR = /usr/lib/ocaml/site-lib/pxp
+NETSTRING_DIR = /usr/lib/ocaml/site-lib/netstring
+OCAMLC = ocamlc -I $(LABLGTK_DIR) -I $(LABLGTK_MATHVIEW_DIR) -I $(PXP_DIR) -I $(NETSTRING_DIR) -I mlmathview
+OCAMLOPT = ocamlopt -I $(LABLGTK_DIR) -I $(LABLGTK_MATHVIEW_DIR) -I mlgtk_devel -I $(PXP_DIR) -I $(NETSTRING_DIR) -I mlmathview
+OCAMLDEP = ocamldep
+
+all: experiment reduction fix_params mmlinterface
+opt: experiment.opt reduction.opt fix_params.opt mmlinterface.opt
+
+PXPLIBS = netstring.cma netmappings_iso.cmo netmappings_other.cmo \
+ pxp_types.cma \
+ pxp_lex_iso88591.cma pxp_lex_utf8.cma pxp_engine.cma \
+ pxp_utf8.cmo
+
+PXPLIBSOPT = netstring.cmxa netmappings_iso.cmx netmappings_other.cmx \
+ pxp_types.cmxa \
+ pxp_lex_iso88591.cmxa pxp_lex_utf8.cmxa pxp_engine.cmxa \
+ pxp_utf8.cmx
+
+
+DEPOBJS = experiment.ml cicCache.ml cicCache.mli cicPp.ml cicPp.mli \
+ cicParser.ml cicParser.mli cicParser2.ml cicParser2.mli \
+ cicParser3.ml cicParser3.mli cic.ml getter.ml getter.mli \
+ gtkInterface.ml cicReduction.ml cicReduction.mli cicTypeChecker.ml \
+ cicTypeChecker.mli reduction.ml tgtkInterface.ml theory.ml \
+ theoryParser.ml theoryParser2.ml theoryPp.ml theoryTypeChecker.ml \
+ cicCooking.ml cicCooking.mli cicFindParameters.ml theoryCache.ml \
+ fix_params.ml cic2Xml.ml xml.ml uriManager.ml uriManager.mli \
+ cicSubstitution.ml cicSubstitution.mli mml.ml \
+ mmlinterface.ml configuration.ml \
+ xsltProcessor.ml deannotate.ml cicXPath.ml pxpUriResolver.ml \
+ annotationParser.ml annotationParser2.ml annotation2Xml.ml \
+ cicAnnotationHinter.ml
+
+MMLINTERFACEOBJS = configuration.cmo uriManager.cmo getter.cmo cic.cmo \
+ pxpUriResolver.cmo \
+ cicParser3.cmo cicParser2.cmo cicParser.cmo deannotate.cmo \
+ cicSubstitution.cmo annotationParser2.cmo \
+ annotationParser.cmo cicCache.cmo cicCooking.cmo cicPp.cmo \
+ cicReduction.cmo cicTypeChecker.cmo mml.cmo \
+ xml.cmo \
+ xsltProcessor.cmo cic2Xml.cmo annotation2Xml.cmo \
+ cicXPath.cmo theory.cmo theoryParser2.cmo theoryParser.cmo \
+ theoryCache.cmo theoryTypeChecker.cmo \
+ cicAnnotationHinter.cmo mmlinterface.cmo
+
+MMLINTERFACEOPTOBJS = configuration.cmx uriManager.cmx getter.cmx cic.cmx \
+ pxpUriResolver.cmx \
+ cicParser3.cmx cicParser2.cmx cicParser.cmx \
+ deannotate.cmx cicSubstitution.cmx annotationParser2.cmx \
+ annotationParser.cmx cicCache.cmx \
+ cicCooking.cmx cicPp.cmx cicReduction.cmx \
+ cicTypeChecker.cmx mml.cmx \
+ xml.cmx xsltProcessor.cmx \
+ cic2Xml.cmx annotation2Xml.cmx cicXPath.cmx \
+ theory.cmx theoryParser2.cmx theoryParser.cmx \
+ theoryCache.cmx theoryTypeChecker.cmx \
+ cicAnnotationHinter.cmx mmlinterface.cmx
+
+FIX_PARAMSOBJS = configuration.cmo uriManager.cmo getter.cmo cic.cmo \
+ pxpUriResolver.cmo \
+ cicParser3.cmo cicParser2.cmo cicParser.cmo deannotate.cmo \
+ cicSubstitution.cmo annotationParser2.cmo \
+ annotationParser.cmo cicCache.cmo cicPp.cmo xml.cmo \
+ cic2Xml.cmo cicFindParameters.cmo fix_params.cmo
+
+FIX_PARAMSOPTOBJS = configuration.cmx uriManager.cmx getter.cmx cic.cmx \
+ pxpUriResolver.cmx \
+ cicParser3.cmx cicParser2.cmx cicParser.cmx deannotate.cmx \
+ cicSubstitution.cmx annotationParser2.cmx \
+ annotationParser.cmx cicCache.cmx cicPp.cmx xml.cmx \
+ cic2Xml.cmx cicFindParameters.cmx fix_params.cmx
+
+REDUCTIONOBJS = configuration.cmo uriManager.cmo getter.cmo cic.cmo \
+ pxpUriResolver.cmo \
+ cicParser3.cmo cicParser2.cmo cicParser.cmo deannotate.cmo \
+ cicSubstitution.cmo annotationParser2.cmo annotationParser.cmo \
+ cicCache.cmo cicPp.cmo cicCooking.cmo \
+ cicReduction.cmo cicTypeChecker.cmo reduction.cmo
+
+REDUCTIONOPTOBJS = configuration.cmx uriManager.cmx getter.cmx cic.cmx \
+ pxpUriResolver.cmx \
+ cicParser3.cmx cicParser2.cmx cicParser.cmx deannotate.cmx \
+ cicSubstitution.cmx annotationParser2.cmx \
+ annotationParser.cmx cicCache.cmx cicPp.cmx cicCooking.cmx \
+ cicReduction.cmx cicTypeChecker.cmx reduction.cmx
+
+EXPERIMENTOBJS = configuration.cmo uriManager.cmo getter.cmo cic.cmo \
+ pxpUriResolver.cmo \
+ cicParser3.cmo cicParser2.cmo cicParser.cmo deannotate.cmo \
+ cicSubstitution.cmo annotationParser2.cmo \
+ annotationParser.cmo cicCache.cmo cicPp.cmo experiment.cmo
+
+EXPERIMENTOPTOBJS = configuration.cmx uriManager.cmx getter.cmx cic.cmx \
+ pxpUriResolver.cmx \
+ cicParser3.cmx cicParser2.cmx cicParser.cmx deannotate.cmx \
+ cicSubstitution.cmx annotationParser2.cmx \
+ annotationParser.cmx cicCache.cmx cicPp.cmx experiment.cmx
+
+depend:
+ $(OCAMLDEP) $(DEPOBJS) > .depend
+
+mmlinterface: $(MMLINTERFACEOBJS)
+ $(OCAMLC) -custom -o mmlinterface str.cma unix.cma $(PXPLIBS) dbm.cma \
+ lablgtk.cma gtkInit.cmo \
+ $(LABLGTK_MATHVIEW_DIR)/lablgtkmathview.cma \
+ $(MMLINTERFACEOBJS) \
+ -cclib "-lstr -L/usr/lib -L/usr/X11R6/lib -lgtk -lgdk \
+ -rdynamic -lgmodule -lglib -ldl -lXi -lXext -lX11 -lm \
+ -lunix -L/usr/local/lib/gtkmathview -lgtkmathview \
+ $(LABLGTK_MATHVIEW_DIR)/ml_gtk_mathview.o" \
+ -cclib -lmldbm -cclib -lndbm
+
+mmlinterface.opt: $(MMLINTERFACEOPTOBJS)
+ $(OCAMLOPT) -o mmlinterface.opt str.cmxa $(PXPLIBSOPT) unix.cmxa \
+ dbm.cmxa lablgtk.cmxa gtkInit.cmx \
+ $(LABLGTK_MATHVIEW_DIR)/lablgtkmathview.cmxa \
+ $(MMLINTERFACEOPTOBJS) \
+ -cclib "-lstr -L/usr/lib -L/usr/X11R6/lib -lgtk -lgdk \
+ -rdynamic -lgmodule -lglib -ldl -lXi -lXext -lX11 -lm \
+ -lunix -L/usr/local/lib/gtkmathview -lgtkmathview \
+ $(LABLGTK_MATHVIEW_DIR)/ml_gtk_mathview.o" \
+ -cclib -lmldbm -cclib -lndbm
+
+fix_params: $(FIX_PARAMSOBJS)
+ $(OCAMLC) -custom -o fix_params str.cma $(PXPLIBS) dbm.cma \
+ $(FIX_PARAMSOBJS) -cclib -lstr -cclib -lmldbm -cclib -lndbm
+
+fix_params.opt: $(FIX_PARAMSOPTOBJS)
+ $(OCAMLOPT) -o fix_params.opt str.cmxa $(PXPLIBSOPT) dbm.cmxa \
+ $(FIX_PARAMSOPTOBJS) -cclib -lstr -cclib -lmldbm \
+ -cclib -lndbm
+
+reduction: $(REDUCTIONOBJS)
+ $(OCAMLC) -custom -o reduction str.cma $(PXPLIBS) dbm.cma \
+ $(REDUCTIONOBJS) -cclib -lstr -cclib -lmldbm -cclib -lndbm
+
+reduction.opt: $(REDUCTIONOPTOBJS)
+ $(OCAMLOPT) -o reduction.opt str.cmxa $(PXPLIBSOPT) dbm.cmxa \
+ $(REDUCTIONOPTOBJS) -cclib -lstr -cclib -lmldbm \
+ -cclib -lndbm
+
+experiment: $(EXPERIMENTOBJS)
+ $(OCAMLC) -custom -o experiment str.cma $(PXPLIBS) dbm.cma \
+ $(EXPERIMENTOBJS) -cclib -lstr -cclib -lmldbm -cclib -lndbm
+
+experiment.opt: $(EXPERIMENTOPTOBJS)
+ $(OCAMLOPT) -o experiment.opt str.cmxa $(PXPLIBSOPT) dbm.cmxa \
+ $(EXPERIMENTOPTOBJS) -cclib -lstr -cclib -lmldbm \
+ -cclib -lndbm
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx
+.ml.cmo:
+ $(OCAMLC) -c $<
+.mli.cmi:
+ $(OCAMLC) -c $<
+.ml.cmx:
+ $(OCAMLOPT) -c $<
+
+clean:
+ rm -f *.cm[iox] *.o experiment experiment.opt reduction \
+ reduction.opt fix_params fix_params.opt mmlinterface \
+ mmlinterface.opt mmlinterface2 mmlinterface2.opt
+
+start-xaland:
+ java xaland 12345 12346 examples/style/rootcontent.xsl \
+ examples/style/annotatedpres.xsl examples/style/theory_content.xsl \
+ examples/style/theory_pres.xsl
+
+start-xaland3:
+ java xaland 12347 12348 examples/style/rootcontent.xsl \
+ examples/style/annotatedpres.xsl examples/style/theory_content.xsl \
+ examples/style/theory_pres.xsl
+
+start-http-getter:
+ http_getter/http_getter.pl
+
+include .depend
--- /dev/null
+
+ ***********************************************************************
+
+ A T T E N Z I O N E ! ! !
+
+ Quando si usa fix_params.opt, scrivere
+
+ find /really_very_local/helm/PARSER/examples
+
+ invece di examples
+
+ ***********************************************************************
+
+ PROBLEMA NON FIXATO CON fix_params
+
+ LA SOLUZIONE E'
+
+
+
+Correggere:
+
+ examples/coq/SETS/Powerset_facts/Sets_as_an_algebra/setcover_intro.con.xml
+
+aggiungendo paramMode="POSSIBLE"
+
+Un esempio che altrimenti non funziona e':
+
+examples/coq/SETS/Powerset_Classical_facts/Sets_as_an_algebra/Add_covers.con.xml
+
--- /dev/null
+export LD_LIBRARY_PATH=.:/really_very_local/helm/proveluca/mml-browser/
+export no_proxy=cs.unibo.it
--- /dev/null
+setenv PATH "/home/projects/java/jdk1.2.2/bin:$PATH"
+setenv CLASSPATH "/really_very_local/helm/java/xalan_1_1/xalan.jar:/really_very_local/helm/java/xalan_1_1/xerces.jar:."
+setenv CLASSPATH "/really_very_local/helm/java/saxon-5.3.2/saxon.jar:$CLASSPATH"
+setenv LD_LIBRARY_PATH ".:/really_very_local/helm/proveluca/mml-browser/"
--- /dev/null
+setenv PATH "/home/projects/java/jdk1.2.2/bin:$PATH"
+setenv CLASSPATH "/really_very_local/helm/java/xalan_1_2_D01/xalan.jar:/really_very_local/helm/java/xalan_1_2_D01/xerces.jar:."
+setenv CLASSPATH "/really_very_local/helm/java/saxon-5.3.2/saxon.jar:$CLASSPATH"
+setenv LD_LIBRARY_PATH ".:/really_very_local/helm/proveluca/mml-browser/"
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* A tactic to print Coq objects in XML *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 22/11/1999 *)
+(******************************************************************************)
+
+This is the main directory of the coq-like pretty printer for cic terms exported
+in xml from Coq. Once compiled four different executables are made:
+
+ experiment a command-line pretty-printer (interpreted)
+ experiment.opt same as experiment (compiled)
+ gtkInterface a gtk-based pretty-printer (interpreted)
+ gtkInterface.opt a gtk-based pretty-printer (compiled)
+
+To use one of the previous pretty-printer the syntax is
+
+ pretty_printer_name file1 ... filen
+
+where filei is an xml cic object
+
+Code files:
+
+ cic.ml the internal definition of cic objects and terms
+ getter.ml converts uris to filenames retrieving the correspondent file
+ cache.ml a cache for cic objects (actually a simple hash-table)
+ cicParser.ml a parser from xml to internal definition: top level
+ cicParser2.ml a parser from xml to internal definition: objects level
+ cicParser3.ml a parser from xml to internal definition: terms level
+ cicPp.ml a pretty-printer for the internal definition of cic objects
+ experiment.ml a textual interface to cicPp
+ gtkInterface.ml a gtk interface to cicPp
+
+Interface files:
+ cache.mli getter.mli cicPp.mli cicParser.mli cicParser2.mli cicParser3.mli
+
+Other files:
+
+ Makefile the targets are "all" "opt" "depend" "clean"
+ .depend dependencies file used by make
+ examples symbolic link to the root of the exported library
--- /dev/null
+prima di UriManager.ml:
+
+ [ABCI]* (terza passata, uguale alla seconda):
+
+ real 0m50.266s
+ user 0m44.160s
+ sys 0m0.700s
+
+dopo UriManager.ml, ma prima di passare da = a ==:
+
+ [ABCI]* (terza passata, uguale alla seconda):
+
+ real 0m51.388s
+ user 0m45.430s
+ sys 0m0.530s
+
+dopo UriManager.ml e popo il passaggio (parziale?) da = a ==:
+
+ [ABCI]* (terza passata, uguale alla seconda):
+
+ real 0m50.767s
+ user 0m44.750s
+ sys 0m0.510s
+
+dopo il passaggio alla cache che usa ancora =:
+
+ [ABCI]* (terza passata, uguale alla seconda):
+
+ real 0m50.646s
+ user 0m44.680s
+ sys 0m0.530s
+
+dopo il passaggio alla cache con utilizzo di ==:
+
+ [ABCI]* (terza passata, uguale alla seconda):
+
+ real 0m50.861s
+ user 0m45.030s
+ sys 0m0.500s
+
+con funzione di hashing costante ;-(
+
+ [ABCI]* (terza passata, uguale alla seconda):
+
+ real 0m51.442s
+ user 0m45.440s
+ sys 0m0.530s
+
+con implementazione isomorfa all'albero delle uri:
+
+ [ABCI]* (terza passata, uguale alla seconda):
+
+ real 0m54.081s
+ user 0m47.590s
+ sys 0m0.780s
+
+con implementazione con doppio RB-albero:
+
+ [ABCI]* (terza passata, uguale alla seconda):
+
+ real 0m52.504s
+ user 0m46.120s
+ sys 0m0.720s
+
+con implementazione semplice, gestite anche le uri delle var:
+
+ [ABCI]* (terza passata, uguale alla seconda):
+
+ real 0m51.850s
+ user 0m46.060s
+ sys 0m0.530s
+
+con implementazione con doppio RB-albero, gestite anche le uri delle var:
+
+ [ABCI]* (terza passata, uguale alla seconda):
+
+ real 0m51.495s
+ user 0m45.660s
+ sys 0m0.540s
+
+=========================================================
+
+con implementazione con doppio RB-albero, gestite anche le uri delle var
+e spostata nell'uri-manager is_prefix:
+
+ [ABCI]* (terza passata, uguale alla seconda):
+
+ real 0m50.465s
+ user 0m45.710s
+ sys 0m0.590s
+
+con implementazione semplice (e tutto il resto):
+
+ [ABCI]* (terza passata, uguale alla seconda):
+
+ real 0m49.710s
+ user 0m43.850s
+ sys 0m0.500s
+
+con implementazione banale (e tutto il resto):
+
+ [ABCI]* (terza passata, uguale alla seconda):
+
+ real 0m49.289s
+ user 0m44.840s
+ sys 0m0.570s
+
+con implementazione banale SOLO PARSING ;-)
+
+ [ABCI]* (terza passata, uguale alla seconda):
+
+ real 0m48.395s
+ user 0m42.830s
+ sys 0m0.850s
+
+=========================================================
+
+con implementazione con doppio RB-albero, gestite anche le uri delle var
+e spostata nell'uri-manager is_prefix:
+
+ REAL (prima passata, dopo un sync):
+
+ real 10m58.033s
+ user 10m37.690s
+ sys 0m2.570s
+
+con implementazione semplice (e tutto il resto):
+
+ REAL (prima passata, dopo un sync):
+
+ real 10m31.035s
+ user 10m9.350s
+ sys 0m3.230s
+
+con implementazione banale (e tutto il resto):
+
+ REAL (prima passata, dopo un sync):
+
+ real 11m4.026s
+ user 10m43.930s
+ sys 0m3.070s
+
+=================================================
+
+con implementazione banale, SOLO PARSING di tutto:
+
+ real 6m54.336s
+ user 6m13.850s
+ sys 0m6.580s
+
+con implementazione banale, anche typechecking di tutto:
+
+ real 20m17.739s
+ user 19m14.740s
+ sys 0m8.550s
+
+con implementazione semplice, anche typechecking di tutto:
+
+ real 19m36.079s
+ user 18m36.480s
+ sys 0m7.760s
+
+con implementazione con doppio RB-albero, anche typechecking di tutto:
+
+ real 17m30.423s
+ user 16m30.840s
+ sys 0m6.170s
+
+***************************************************************************
+ APPLICATA EURISTICA
+***************************************************************************
+
+con implementazione con doppio RB-albero, anche typechecking di tutto
+(universita') ????????:
+
+real 5m37.805s
+user 5m1.640s
+sys 0m5.010s
+
+tutto (ma a casa):
+
+real 7m36.663s
+user 6m52.220s
+sys 0m5.860s
+
+
+solo REAL:
+
+real 2m52.860s
+user 2m41.050s
+sys 0m2.820s
+
+==========================================================================
+
+tutto (ma a casa) dopo eliminazione buri:
+
+real 7m52.773s
+user 6m52.110s
+sys 0m7.130s
+
+"solo parsing" di tutto dopo eliminazione buri:
+
+real 7m8.379s
+user 6m15.250s
+sys 0m6.700s
+
+===========================================================================
+
+TUTTO ALL'UNIVERSITA' CON EURISTICA MA SENZA UNIVERSI:
+
+real 5m47.920s
+user 5m14.600s
+sys 0m5.010s
+
--- /dev/null
+-P directory di destinazione
+-q no output (quiet mode)
+-c continue retrieving (no uri.1, uri.2, ...)
--- /dev/null
+(*CSC codice cut & paste da cicPp e xmlcommand *)
+
+exception ImpossiblePossible;;
+exception NotImplemented;;
+exception BinderNotSpecified;;
+
+let dtdname = "http://localhost:8081/getdtd?url=annotations.dtd";;
+
+(*CSC ottimizzazione: al posto di curi cdepth (vedi codice) *)
+let print_term =
+ let rec aux =
+ let module C = Cic in
+ let module X = Xml in
+ let module U = UriManager in
+ function
+ C.ARel (id,ann,_,_) ->
+ (match !ann with
+ None -> [<>]
+ | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann))
+ )
+ | C.AVar (id,ann,_) ->
+ (match !ann with
+ None -> [<>]
+ | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann))
+ )
+ | C.AMeta (id,ann,_) ->
+ (match !ann with
+ None -> [<>]
+ | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann))
+ )
+ | C.ASort (id,ann,_) ->
+ (match !ann with
+ None -> [<>]
+ | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann))
+ )
+ | C.AImplicit _ -> raise NotImplemented
+ | C.AProd (id,ann,_,s,t) ->
+ [< (match !ann with
+ None -> [<>]
+ | Some ann ->
+ (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann))
+ ) ;
+ aux s ;
+ aux t
+ >]
+ | C.ACast (id,ann,v,t) ->
+ [< (match !ann with
+ None -> [<>]
+ | Some ann ->
+ (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann))
+ ) ;
+ aux v ;
+ aux t
+ >]
+ | C.ALambda (id,ann,_,s,t) ->
+ [< (match !ann with
+ None -> [<>]
+ | Some ann ->
+ (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann))
+ ) ;
+ aux s ;
+ aux t
+ >]
+ | C.AAppl (id,ann,li) ->
+ [< (match !ann with
+ None -> [<>]
+ | Some ann ->
+ (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann))
+ ) ;
+ List.fold_right (fun x i -> [< (aux x) ; i >]) li [<>]
+ >]
+ | C.AConst (id,ann,_,_) ->
+ (match !ann with
+ None -> [<>]
+ | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann))
+ )
+ | C.AAbst (id,ann,_) -> raise NotImplemented
+ | C.AMutInd (id,ann,_,_,_) ->
+ (match !ann with
+ None -> [<>]
+ | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann))
+ )
+ | C.AMutConstruct (id,ann,_,_,_,_) ->
+ (match !ann with
+ None -> [<>]
+ | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann))
+ )
+ | C.AMutCase (id,ann,_,_,_,ty,te,patterns) ->
+ [< (match !ann with
+ None -> [<>]
+ | Some ann ->
+ (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann))
+ ) ;
+ aux ty ;
+ aux te ;
+ List.fold_right
+ (fun x i -> [< aux x ; i>])
+ patterns [<>]
+ >]
+ | C.AFix (id, ann, _, funs) ->
+ [< (match !ann with
+ None -> [<>]
+ | Some ann ->
+ (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann))
+ ) ;
+ List.fold_right
+ (fun (_,_,ti,bi) i -> [< aux ti ; aux bi ; i >]) funs [<>]
+ >]
+ | C.ACoFix (id, ann,no,funs) ->
+ [< (match !ann with
+ None -> [<>]
+ | Some ann ->
+ (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann))
+ ) ;
+ List.fold_right
+ (fun (_,ti,bi) i -> [< aux ti ; aux bi ; i >]) funs [<>]
+ >]
+ in
+ aux
+;;
+
+let print_mutual_inductive_type (_,_,arity,constructors) =
+ [< print_term arity ;
+ List.fold_right
+ (fun (name,ty,_) i -> [< print_term ty ; i >]) constructors [<>]
+ >]
+;;
+
+let target_uri_of_annotation_uri uri =
+ Str.replace_first (Str.regexp "\.ann$") "" (UriManager.string_of_uri uri)
+;;
+
+let pp_annotation obj curi =
+ let module C = Cic in
+ let module X = Xml in
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE Annotations SYSTEM \"" ^ dtdname ^ "\">\n\n") ;
+ X.xml_nempty "Annotations" ["of", target_uri_of_annotation_uri curi]
+ begin
+ match obj with
+ C.ADefinition (xid, ann, _, te, ty, _) ->
+ [< (match !ann with
+ None -> [<>]
+ | Some ann ->
+ X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann)
+ ) ;
+ print_term te ;
+ print_term ty
+ >]
+ | C.AAxiom (xid, ann, _, ty, _) ->
+ [< (match !ann with
+ None -> [<>]
+ | Some ann ->
+ X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann)
+ ) ;
+ print_term ty
+ >]
+ | C.AVariable (xid, ann, _, ty) ->
+ [< (match !ann with
+ None -> [<>]
+ | Some ann ->
+ X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann)
+ ) ;
+ print_term ty
+ >]
+ | C.ACurrentProof (xid, ann, _, conjs, bo, ty) ->
+ [< (match !ann with
+ None -> [<>]
+ | Some ann ->
+ X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann)
+ ) ;
+ List.fold_right
+ (fun (_,t) i -> [< print_term t ; i >])
+ conjs [<>] ;
+ print_term bo ;
+ print_term ty
+ >]
+ | C.AInductiveDefinition (xid, ann, tys, params, paramsno) ->
+ [< (match !ann with
+ None -> [<>]
+ | Some ann ->
+ X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann)
+ ) ;
+ List.fold_right
+ (fun x i -> [< print_mutual_inductive_type x ; i >])
+ tys [< >]
+ >]
+ end
+ >]
+;;
--- /dev/null
+exception Warnings;;
+
+class warner =
+ object
+ method warn w =
+ print_endline ("WARNING: " ^ w) ;
+ (raise Warnings : unit)
+ end
+;;
+
+exception EmptyUri;;
+
+let annotate filename ids_to_targets =
+ let module Y = Pxp_yacc in
+ try
+ let d =
+ let config = {Y.default_config with Y.warner = new warner} in
+ Y.parse_document_entity config
+(*PXP (Y.ExtID (Pxp_types.System filename,
+ new Pxp_reader.resolve_as_file ~url_of_id ()))
+*) (PxpUriResolver.from_file filename)
+ Y.default_spec
+
+ in
+ AnnotationParser2.annotate ids_to_targets d#root
+ with
+ e ->
+ print_endline (Pxp_types.string_of_exn e) ;
+ raise e
+;;
--- /dev/null
+exception IllFormedXml of int;;
+
+(* Utility functions that transform a Pxp attribute into something useful *)
+
+let string_of_attr a =
+ let module T = Pxp_types in
+ match a with
+ T.Value s -> s
+ | _ -> raise (IllFormedXml 0)
+;;
+
+exception DontKnowWhatToDo;;
+
+let rec string_of_annotations n =
+ let module D = Pxp_document in
+ let module T = Pxp_types in
+ match n#node_type with
+ D.T_element s ->
+ "<" ^ s ^
+ List.fold_right
+ (fun att i ->
+ match n#attribute att with
+ T.Value s -> " " ^ att ^ "=\"" ^ s ^ "\"" ^ i
+ | T.Implied_value -> i
+ | T.Valuelist l -> " " ^ att ^ "=\"" ^ String.concat " " l ^ "\"" ^ i
+ ) (n#attribute_names) "" ^
+ (match n#sub_nodes with
+ [] -> "/>"
+ | l ->
+ ">" ^
+ String.concat "" (List.map string_of_annotations l) ^
+ "</" ^ s ^ ">"
+ )
+ | D.T_data -> n#data
+ | _ -> raise DontKnowWhatToDo
+;;
+
+let get_annotation n =
+ String.concat "" (List.map string_of_annotations (n#sub_nodes))
+;;
+
+let annotate_object ann obj =
+ let module C = Cic in
+ let rann =
+ match obj with
+ C.ADefinition (_, rann, _, _, _, _) -> rann
+ | C.AAxiom (_, rann, _, _, _) -> rann
+ | C.AVariable (_, rann, _, _) -> rann
+ | C.ACurrentProof (_, rann, _, _, _, _) -> rann
+ | C.AInductiveDefinition (_, rann, _, _, _) -> rann
+ in
+ rann := Some ann
+;;
+
+let annotate_term ann term =
+ let module C = Cic in
+ let rann =
+ match term with
+ C.ARel (_, rann, _, _) -> rann
+ | C.AVar (_, rann, _) -> rann
+ | C.AMeta (_, rann, _) -> rann
+ | C.ASort (_, rann, _) -> rann
+ | C.AImplicit (_, rann) -> rann
+ | C.ACast (_, rann, _, _) -> rann
+ | C.AProd (_, rann, _, _, _) -> rann
+ | C.ALambda (_, rann, _, _, _) -> rann
+ | C.AAppl (_, rann, _) -> rann
+ | C.AConst (_, rann, _, _) -> rann
+ | C.AAbst (_, rann, _) -> rann
+ | C.AMutInd (_, rann, _, _, _) -> rann
+ | C.AMutConstruct (_, rann, _, _, _, _) -> rann
+ | C.AMutCase (_, rann, _, _, _, _, _, _) -> rann
+ | C.AFix (_, rann, _, _) -> rann
+ | C.ACoFix (_, rann, _, _) -> rann
+ in
+ rann := Some ann
+;;
+
+let annotate ids_to_targets n =
+ let module D = Pxp_document in
+ let module C = Cic in
+ let annotate_elem n =
+ let ntype = n # node_type in
+ match ntype with
+ D.T_element "Annotation" ->
+ let of_uri = string_of_attr (n # attribute "of") in
+ begin
+ try
+ match Hashtbl.find ids_to_targets of_uri with
+ C.Object o -> annotate_object (get_annotation n) o
+ | C.Term t -> annotate_term (get_annotation n) t
+ with
+ Not_found -> assert false
+ end
+ | D.T_element _ | D.T_data ->
+ raise (IllFormedXml 1)
+ | _ -> raise DontKnowWhatToDo
+ in
+ match n # node_type with
+ D.T_element "Annotations" ->
+ List.iter annotate_elem (n # sub_nodes)
+ | _ -> raise (IllFormedXml 2)
+;;
--- /dev/null
+#! /bin/sh
+
+export PATH=/home/cadet/sacerdot/jdk118/bin:$PATH
+
+export CLASSPATH=/home/cadet/sacerdot/xalan-j_1_2/xalan.jar:/home/cadet/sacerdot/xalan-j_1_2/xerces.jar:.
+
+#export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/xalan_1_1/xalan.jar
+#export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/xalan_1_1/xerces.jar
+#export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/saxon-5.3.2/saxon.jar
+
+# Per (my)Coq 6.3.0
+#export LD_LIBRARY_PATH=/home/lpadovan/helm/usr/lib/:$LD_LIBRARY_PATH
+export LD_LIBRARY_PATH=/usr/local/lib/gtkmathview:$LD_LIBRARY_PATH
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 14/06/2000 *)
+(* *)
+(* This module defines the internal representation of the objects (variables, *)
+(* blocks of (co)inductive definitions and constants) and the terms of cic *)
+(* *)
+(******************************************************************************)
+
+(* STUFF TO MANAGE IDENTIFIERS *)
+type id = string (* the abstract type of the (annotated) node identifiers *)
+type anntarget =
+ Object of annobj
+ | Term of annterm
+
+(* INTERNAL REPRESENTATION OF CIC OBJECTS AND TERMS *)
+and sort =
+ Prop
+ | Set
+ | Type
+and name =
+ Name of string
+ | Anonimous
+and term =
+ Rel of int (* DeBrujin index *)
+ | Var of UriManager.uri (* uri *)
+ | Meta of int (* numeric id *)
+ | Sort of sort (* sort *)
+ | Implicit (* *)
+ | Cast of term * term (* value, type *)
+ | Prod of name * term * term (* binder, source, target *)
+ | Lambda of name * term * term (* binder, source, target *)
+ | Appl of term list (* arguments *)
+ | Const of UriManager.uri * int (* uri, number of cookings*)
+ | Abst of UriManager.uri (* uri *)
+ | MutInd of UriManager.uri * int * int (* uri, cookingsno, typeno*)
+ | MutConstruct of UriManager.uri * int * (* uri, cookingsno, *)
+ int * int (* typeno, consno *)
+ (*CSC: serve cookingsno?*)
+ | MutCase of UriManager.uri * int * (* ind. uri, cookingsno, *)
+ int * (* ind. typeno, *)
+ term * term * (* outtype, ind. term *)
+ term list (* patterns *)
+ | Fix of int * inductiveFun list (* funno, functions *)
+ | CoFix of int * coInductiveFun list (* funno, functions *)
+and obj =
+ Definition of string * term * term * (* id, value, type, *)
+ (int * UriManager.uri list) list (* parameters *)
+ | Axiom of string * term *
+ (int * UriManager.uri list) list (* id, type, parameters *)
+ | Variable of string * term (* name, type *)
+ | CurrentProof of string * (int * term) list * (* name, conjectures, *)
+ term * term (* value, type *)
+ | InductiveDefinition of inductiveType list * (* inductive types, *)
+ (int * UriManager.uri list) list * int (* parameters, n ind. pars *)
+and inductiveType =
+ string * bool * term * (* typename, inductive, arity *)
+ constructor list (* constructors *)
+and constructor =
+ string * term * bool list option ref (* id, type, really recursive *)
+and inductiveFun =
+ string * int * term * term (* name, ind. index, type, body *)
+and coInductiveFun =
+ string * term * term (* name, type, body *)
+
+and annterm =
+ ARel of id * annotation option ref *
+ int * string option (* DeBrujin index, binder *)
+ | AVar of id * annotation option ref *
+ UriManager.uri (* uri *)
+ | AMeta of id * annotation option ref * int (* numeric id *)
+ | ASort of id * annotation option ref * sort (* sort *)
+ | AImplicit of id * annotation option ref (* *)
+ | ACast of id * annotation option ref *
+ annterm * annterm (* value, type *)
+ | AProd of id * annotation option ref *
+ name * annterm * annterm (* binder, source, target *)
+ | ALambda of id * annotation option ref *
+ name * annterm * annterm (* binder, source, target *)
+ | AAppl of id * annotation option ref *
+ annterm list (* arguments *)
+ | AConst of id * annotation option ref *
+ UriManager.uri * int (* uri, number of cookings*)
+ | AAbst of id * annotation option ref *
+ UriManager.uri (* uri *)
+ | AMutInd of id * annotation option ref *
+ UriManager.uri * int * int (* uri, cookingsno, typeno*)
+ | AMutConstruct of id * annotation option ref *
+ UriManager.uri * int * (* uri, cookingsno, *)
+ int * int (* typeno, consno *)
+ (*CSC: serve cookingsno?*)
+ | AMutCase of id * annotation option ref *
+ UriManager.uri * int * (* ind. uri, cookingsno *)
+ int * (* ind. typeno, *)
+ annterm * annterm * (* outtype, ind. term *)
+ annterm list (* patterns *)
+ | AFix of id * annotation option ref *
+ int * anninductiveFun list (* funno, functions *)
+ | ACoFix of id * annotation option ref *
+ int * anncoInductiveFun list (* funno, functions *)
+and annobj =
+ ADefinition of id * annotation option ref *
+ string * (* id, *)
+ annterm * annterm * (* value, type, *)
+ (int * UriManager.uri list) list exactness (* parameters *)
+ | AAxiom of id * annotation option ref *
+ string * annterm * (* id, type *)
+ (int * UriManager.uri list) list (* parameters *)
+ | AVariable of id * annotation option ref *
+ string * annterm (* name, type *)
+ | ACurrentProof of id * annotation option ref *
+ string * (int * annterm) list * (* name, conjectures, *)
+ annterm * annterm (* value, type *)
+ | AInductiveDefinition of id *
+ annotation option ref * anninductiveType list * (* inductive types , *)
+ (int * UriManager.uri list) list * int (* parameters,n ind. pars*)
+and anninductiveType =
+ string * bool * annterm * (* typename, inductive, arity *)
+ annconstructor list (* constructors *)
+and annconstructor =
+ string * annterm * bool list option ref (* id, type, really recursive *)
+and anninductiveFun =
+ string * int * annterm * annterm (* name, ind. index, type, body *)
+and anncoInductiveFun =
+ string * annterm * annterm (* name, type, body *)
+and annotation =
+ string
+and 'a exactness =
+ Possible of 'a (* an approximation to something *)
+ | Actual of 'a (* something *)
+;;
--- /dev/null
+(*CSC codice cut & paste da cicPp e xmlcommand *)
+
+exception ImpossiblePossible;;
+exception NotImplemented;;
+exception BinderNotSpecified;;
+
+let dtdname = "http://localhost:8081/getdtd?url=cic.dtd";;
+
+(*CSC ottimizzazione: al posto di curi cdepth (vedi codice) *)
+let print_term curi =
+ let rec aux =
+ let module C = Cic in
+ let module X = Xml in
+ let module U = UriManager in
+ function
+ C.ARel (id,_,n,Some b) ->
+ X.xml_empty "REL" ["value",(string_of_int n);"binder",b;"id",id]
+ | C.ARel _ -> raise BinderNotSpecified
+ | C.AVar (id,_,uri) ->
+ let vdepth = U.depth_of_uri uri
+ and cdepth = U.depth_of_uri curi in
+ X.xml_empty "VAR"
+ ["relUri",(string_of_int (cdepth - vdepth)) ^ "," ^
+ (U.name_of_uri uri) ;
+ "id",id]
+ | C.AMeta (id,_,n) ->
+ X.xml_empty "META" ["no",(string_of_int n) ; "id",id]
+ | C.ASort (id,_,s) ->
+ let string_of_sort =
+ function
+ C.Prop -> "Prop"
+ | C.Set -> "Set"
+ | C.Type -> "Type"
+ in
+ X.xml_empty "SORT" ["value",(string_of_sort s) ; "id",id]
+ | C.AImplicit _ -> raise NotImplemented
+ | C.AProd (id,_,C.Anonimous,s,t) ->
+ X.xml_nempty "PROD" ["id",id]
+ [< X.xml_nempty "source" [] (aux s) ;
+ X.xml_nempty "target" [] (aux t)
+ >]
+ | C.AProd (xid,_,C.Name id,s,t) ->
+ X.xml_nempty "PROD" ["id",xid]
+ [< X.xml_nempty "source" [] (aux s) ;
+ X.xml_nempty "target" ["binder",id] (aux t)
+ >]
+ | C.ACast (id,_,v,t) ->
+ X.xml_nempty "CAST" ["id",id]
+ [< X.xml_nempty "term" [] (aux v) ;
+ X.xml_nempty "type" [] (aux t)
+ >]
+ | C.ALambda (id,_,C.Anonimous,s,t) ->
+ X.xml_nempty "LAMBDA" ["id",id]
+ [< X.xml_nempty "source" [] (aux s) ;
+ X.xml_nempty "target" [] (aux t)
+ >]
+ | C.ALambda (xid,_,C.Name id,s,t) ->
+ X.xml_nempty "LAMBDA" ["id",xid]
+ [< X.xml_nempty "source" [] (aux s) ;
+ X.xml_nempty "target" ["binder",id] (aux t)
+ >]
+ | C.AAppl (id,_,li) ->
+ X.xml_nempty "APPLY" ["id",id]
+ [< (List.fold_right (fun x i -> [< (aux x) ; i >]) li [<>])
+ >]
+ | C.AConst (id,_,uri,_) ->
+ X.xml_empty "CONST" ["uri", (U.string_of_uri uri) ; "id",id]
+ | C.AAbst (id,_,uri) -> raise NotImplemented
+ | C.AMutInd (id,_,uri,_,i) ->
+ X.xml_empty "MUTIND"
+ ["uri", (U.string_of_uri uri) ;
+ "noType",(string_of_int i) ;
+ "id",id]
+ | C.AMutConstruct (id,_,uri,_,i,j) ->
+ X.xml_empty "MUTCONSTRUCT"
+ ["uri", (U.string_of_uri uri) ;
+ "noType",(string_of_int i) ; "noConstr",(string_of_int j) ;
+ "id",id]
+ | C.AMutCase (id,_,uri,_,typeno,ty,te,patterns) ->
+ X.xml_nempty "MUTCASE"
+ ["uriType",(U.string_of_uri uri) ;
+ "noType", (string_of_int typeno) ;
+ "id", id]
+ [< X.xml_nempty "patternsType" [] [< (aux ty) >] ;
+ X.xml_nempty "inductiveTerm" [] [< (aux te) >] ;
+ List.fold_right
+ (fun x i -> [< X.xml_nempty "pattern" [] [< aux x >] ; i>])
+ patterns [<>]
+ >]
+ | C.AFix (id, _, no, funs) ->
+ X.xml_nempty "FIX" ["noFun", (string_of_int no) ; "id",id]
+ [< List.fold_right
+ (fun (fi,ai,ti,bi) i ->
+ [< X.xml_nempty "FixFunction"
+ ["name", fi; "recIndex", (string_of_int ai)]
+ [< X.xml_nempty "type" [] [< aux ti >] ;
+ X.xml_nempty "body" [] [< aux bi >]
+ >] ;
+ i
+ >]
+ ) funs [<>]
+ >]
+ | C.ACoFix (id,_,no,funs) ->
+ X.xml_nempty "COFIX" ["noFun", (string_of_int no) ; "id",id]
+ [< List.fold_right
+ (fun (fi,ti,bi) i ->
+ [< X.xml_nempty "CofixFunction" ["name", fi]
+ [< X.xml_nempty "type" [] [< aux ti >] ;
+ X.xml_nempty "body" [] [< aux bi >]
+ >] ;
+ i
+ >]
+ ) funs [<>]
+ >]
+ in
+ aux
+;;
+
+let encode params =
+ List.fold_right
+ (fun (n,l) i ->
+ match l with
+ [] -> i
+ | _ ->
+ string_of_int n ^ ": " ^
+ String.concat " " (List.map UriManager.name_of_uri l) ^
+ i
+ ) params ""
+;;
+
+let print_mutual_inductive_type curi (typename,inductive,arity,constructors) =
+ let module C = Cic in
+ let module X = Xml in
+ [< X.xml_nempty "InductiveType"
+ ["name",typename ;
+ "inductive",(string_of_bool inductive)
+ ]
+ [< X.xml_nempty "arity" [] (print_term curi arity) ;
+ (List.fold_right
+ (fun (name,ty,_) i ->
+ [< X.xml_nempty "Constructor" ["name",name]
+ (print_term curi ty) ;
+ i
+ >])
+ constructors
+ [<>]
+ )
+ >]
+ >]
+;;
+
+let pp obj curi =
+ let module C = Cic in
+ let module X = Xml in
+ match obj with
+ C.ADefinition (xid, _, id, te, ty, params) ->
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE Definition SYSTEM \"" ^ dtdname ^ "\">\n\n") ;
+ X.xml_nempty "Definition"
+ (["name", id ; "id",xid] @
+ match params with
+ C.Possible _ -> raise ImpossiblePossible
+ (*CSC params are kept in inverted order in the internal *)
+ (* representation (the order of application) *)
+ | C.Actual fv' -> ["params",(encode (List.rev fv'))])
+ [< X.xml_nempty "body" [] (print_term curi te) ;
+ X.xml_nempty "type" [] (print_term curi ty) >]
+ >]
+ | C.AAxiom (xid, _, id, ty, params) ->
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE Axiom SYSTEM \"" ^ dtdname ^ "\">\n\n") ;
+ X.xml_nempty "Axiom"
+ (*CSC params are kept in inverted order in the internal *)
+ (* representation (the order of application) *)
+ ["name",id ; "params",(encode (List.rev params)) ; "id",xid]
+ [< X.xml_nempty "type" [] (print_term curi ty) >]
+ >]
+ | C.AVariable (xid, _, name, ty) ->
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE Variable SYSTEM \"" ^ dtdname ^ "\">\n\n") ;
+ X.xml_nempty "Variable" ["name",name ; "id",xid]
+ [< X.xml_nempty "type" [] (print_term curi ty) >]
+ >]
+ | C.ACurrentProof (xid, _, name, conjs, bo, ty) ->
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE CurrentProof SYSTEM \"" ^ dtdname ^ "\">\n\n");
+ X.xml_nempty "CurrentProof" ["name",name ; "id",xid]
+ [< List.fold_right
+ (fun (j,t) i ->
+ [< X.xml_nempty "Conjecture" ["no",(string_of_int j)]
+ [< print_term curi t >] ; i >])
+ conjs [<>] ;
+ X.xml_nempty "body" [] [< print_term curi bo >] ;
+ X.xml_nempty "type" [] [< print_term curi ty >]
+ >]
+ >]
+ | C.AInductiveDefinition (xid, _, tys, params, paramsno) ->
+ let names =
+ List.map
+ (fun (typename,_,_,_) -> typename)
+ tys
+ in
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE InductiveDefinition SYSTEM \"" ^
+ dtdname ^ "\">\n\n") ;
+ X.xml_nempty "InductiveDefinition"
+ (*CSC params are kept in inverted order in the internal *)
+ (* representation (the order of application) *)
+ ["noParams",string_of_int paramsno ;
+ "params",(encode (List.rev params)) ;
+ "id",xid]
+ [< List.fold_right
+ (fun x i -> [< print_mutual_inductive_type curi x ; i >])
+ tys [< >]
+ >]
+ >]
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 14/06/2000 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+let deactivate_hints_from annotation_window n =
+ let annotation_hints = annotation_window#annotation_hints in
+ for i = n to Array.length annotation_hints - 1 do
+ annotation_hints.(i)#misc#hide ()
+ done
+;;
+
+(* CSC: orripilante *)
+(* the list of the signal ids *)
+let sig_ids = ref ([] : GtkSignal.id list);;
+
+let disconnect_hint annotation_window buttonno =
+ match !sig_ids with
+ id::ids ->
+ annotation_window#annotation_hints.(buttonno)#misc#disconnect id ;
+ sig_ids := ids
+ | _ -> assert false
+;;
+
+(* link_hint annotation_window n label hint *)
+(* set the label of the nth hint button of annotation_window to label *)
+(* and the correspondent hint to hint *)
+let link_hint annotation_window buttonno label hint =
+ let button = annotation_window#annotation_hints.(buttonno) in
+ sig_ids :=
+ (button#connect#clicked
+ (fun () -> (annotation_window#annotation : GEdit.text)#insert hint)
+ ) :: !sig_ids ;
+ button#misc#show () ;
+ match button#children with
+ [labelw] -> (GMisc.label_cast labelw)#set_text label
+ | _ -> assert false
+;;
+
+exception TooManyHints;;
+
+let link_hints annotation_window a =
+ if Array.length a > Array.length annotation_window#annotation_hints then
+ raise TooManyHints ;
+ for i = List.length !sig_ids - 1 downto 0 do
+ disconnect_hint annotation_window i
+ done ;
+ Array.iteri
+ (fun i (label,hint) -> link_hint annotation_window i label hint) a ;
+ deactivate_hints_from annotation_window (Array.length a)
+;;
+
+let list_mapi f =
+ let rec aux n =
+ function
+ [] -> []
+ | he::tl -> (f n he)::(aux (n + 1) tl)
+ in
+ aux 0
+;;
+
+let get_id annterm =
+ let module C = Cic in
+ match annterm with
+ C.ARel (id,_,_,_) -> id
+ | C.AVar (id,_,_) -> id
+ | C.AMeta (id,_,_) -> id
+ | C.ASort (id,_,_) -> id
+ | C.AImplicit (id,_) -> id
+ | C.ACast (id,_,_,_) -> id
+ | C.AProd (id,_,_,_,_) -> id
+ | C.ALambda (id,_,_,_,_) -> id
+ | C.AAppl (id,_,_) -> id
+ | C.AConst (id,_,_,_) -> id
+ | C.AAbst (id,_,_) -> id
+ | C.AMutInd (id,_,_,_,_) -> id
+ | C.AMutConstruct (id,_,_,_,_,_)-> id
+ | C.AMutCase (id,_,_,_,_,_,_,_) -> id
+ | C.AFix (id,_,_,_) -> id
+ | C.ACoFix (id,_,_,_) -> id
+;;
+
+let create_hint_from_term annotation_window annterm =
+ let module C = Cic in
+ match annterm with
+ C.ARel (id,_,_,_) ->
+ link_hints annotation_window
+ [| "Binder", "<attribute name = 'binder' id = '" ^ id ^ "'/>" |]
+ | C.AVar (id,_,_) ->
+ link_hints annotation_window
+ [| "relURI???", "<attribute name = 'relUri' id = '" ^ id ^ "'/>" |]
+ | C.AMeta (id,_,_) ->
+ link_hints annotation_window
+ [| "Number", "<attribute name = 'no' id = '" ^ id ^ "'/>" |]
+ | C.ASort (id,_,_) ->
+ link_hints annotation_window
+ [| "Value", "<attribute name = 'value' id = '" ^ id ^ "'/>" |]
+ | C.AImplicit (id,_) ->
+ link_hints annotation_window [| |]
+ | C.ACast (id,_,bo,ty) ->
+ let boid = get_id bo
+ and tyid = get_id ty in
+ link_hints annotation_window
+ [| "Body", "<node id = '" ^ boid ^ "'/>" ;
+ "Type", "<node id = '" ^ tyid ^ "'/>"
+ |]
+ | C.AProd (id,_,_,ty,bo) ->
+ let boid = get_id bo
+ and tyid = get_id ty in
+ link_hints annotation_window
+ [| "Binder",
+ "<attribute child = '2' name = 'binder' id = '" ^ id ^ "'/>" ;
+ "Body", "<node id = '" ^ boid ^ "'/>" ;
+ "Type", "<node id = '" ^ tyid ^ "'/>"
+ |]
+ | C.ALambda (id,_,_,ty,bo) ->
+ let boid = get_id bo
+ and tyid = get_id ty in
+ link_hints annotation_window
+ [| "Binder",
+ "<attribute child = '2' name = 'binder' id = '" ^ id ^ "'/>" ;
+ "Body", "<node id = '" ^ boid ^ "'/>" ;
+ "Type", "<node id = '" ^ tyid ^ "'/>"
+ |]
+ | C.AAppl (id,_,args) ->
+ let argsid =
+ Array.mapi
+ (fun i te -> "Argument " ^ string_of_int i, "<node id ='" ^
+ get_id te ^ "'/>")
+ (Array.of_list args)
+ in
+ link_hints annotation_window argsid
+ | C.AConst (id,_,_,_) ->
+ link_hints annotation_window
+ [| "Uri???", "<attribute name = 'uri' id = '" ^ id ^ "'/>" |]
+ | C.AAbst (id,_,_) ->
+ link_hints annotation_window
+ [| "Uri???", "<attribute name = 'uri' id = '" ^ id ^ "'/>" |]
+ | C.AMutInd (id,_,_,_,_) ->
+ link_hints annotation_window
+ [| "Uri???", "<attribute name = 'uri' id = '" ^ id ^ "'/>" |]
+ | C.AMutConstruct (id,_,_,_,_,_) ->
+ link_hints annotation_window
+ [| "Uri???", "<attribute name = 'uri' id = '" ^ id ^ "'/>" |]
+ | C.AMutCase (id,_,_,_,_,outty,te,pl) ->
+ let outtyid = get_id outty
+ and teid = get_id te
+ and plid =
+ Array.mapi
+ (fun i te -> "Pattern " ^ string_of_int i, "<node id ='" ^
+ get_id te ^ "'/>")
+ (Array.of_list pl)
+ in
+ link_hints annotation_window
+ (Array.append
+ [| "Uri???", "<attribute name = 'uri' id = '" ^ id ^ "'/>" ;
+ "Case Type", "<node id = '" ^ outtyid ^ "'/>" ;
+ "Term", "<node id = '" ^ teid ^ "'/>" ;
+ |]
+ plid)
+ | C.AFix (id,_,_,funl) ->
+ let funtylid =
+ Array.mapi
+ (fun i (_,_,ty,_) ->
+ "Type " ^ string_of_int i, "<node id ='" ^
+ get_id ty ^ "'/>")
+ (Array.of_list funl)
+ and funbolid =
+ Array.mapi
+ (fun i (_,_,_,bo) ->
+ "Body " ^ string_of_int i, "<node id ='" ^
+ get_id bo ^ "'/>")
+ (Array.of_list funl)
+ and funnamel =
+ Array.mapi
+ (fun i (_,_,_,_) ->
+ "Name " ^ string_of_int i, "<attribute id ='" ^ id ^
+ "' name = 'name' child='" ^ string_of_int i ^ "'/>")
+ (Array.of_list funl)
+ and funrecindexl =
+ Array.mapi
+ (fun i (_,_,_,_) ->
+ "Recursive Index??? " ^ string_of_int i, "<attribute id = '" ^ id ^
+ "' name = 'recIndex' child='" ^ string_of_int i ^ "'/>")
+ (Array.of_list funl)
+ in
+ link_hints annotation_window
+ (Array.concat
+ [ funtylid ;
+ funbolid ;
+ funnamel ;
+ funrecindexl ;
+ [| "NoFun???", "<attribute name = 'noFun' id = '" ^ id ^ "'/>" |]
+ ]
+ )
+ | C.ACoFix (id,_,_,funl) ->
+ let funtylid =
+ Array.mapi
+ (fun i (_,ty,_) ->
+ "Type " ^ string_of_int i, "<node id ='" ^
+ get_id ty ^ "'/>")
+ (Array.of_list funl)
+ and funbolid =
+ Array.mapi
+ (fun i (_,_,bo) ->
+ "Body " ^ string_of_int i, "<node id ='" ^
+ get_id bo ^ "'/>")
+ (Array.of_list funl)
+ and funnamel =
+ Array.mapi
+ (fun i (_,_,_) ->
+ "Name " ^ string_of_int i, "<attribute id ='" ^ id ^
+ "' name = 'name' child='" ^ string_of_int i ^ "'/>")
+ (Array.of_list funl)
+ in
+ link_hints annotation_window
+ (Array.concat
+ [ funtylid ;
+ funbolid ;
+ funnamel ;
+ [| "NoFun???", "<attribute name = 'noFun' id = '" ^ id ^ "'/>" |]
+ ]
+ )
+;;
+
+(*CSC: da riscrivere completamente eliminando il paciugo degli array - liste *)
+let create_hint_from_obj annotation_window annobj =
+ let module C = Cic in
+ match annobj with
+ C.ADefinition (id,_,_,bo,ty,_) ->
+ let boid = get_id bo
+ and tyid = get_id ty in
+ link_hints annotation_window
+ [| "Name", "<attribute name = 'name' id = '" ^ id ^ "'/>" ;
+ "Ingredients", "<attribute name = 'params' id = '" ^ id ^ "'/>" ;
+ "Body", "<node id = '" ^ boid ^ "'/>" ;
+ "Type", "<node id = '" ^ tyid ^ "'/>"
+ |]
+ | C.AAxiom (id,_,_,ty,_) ->
+ let tyid = get_id ty in
+ link_hints annotation_window
+ [| "Name", "<attribute name = 'name' id = '" ^ id ^ "'/>" ;
+ "Ingredients", "<attribute name = 'params' id = '" ^ id ^ "'/>" ;
+ "Type", "<node id = '" ^ tyid ^ "'/>"
+ |]
+ | C.AVariable (id,_,_,ty) ->
+ let tyid = get_id ty in
+ link_hints annotation_window
+ [| "Name", "<attribute name = 'name' id = '" ^ id ^ "'/>" ;
+ "Type", "<node id = '" ^ tyid ^ "'/>"
+ |]
+ | C.ACurrentProof (id,_,_,conjs,bo,ty) ->
+ let boid = get_id bo
+ and tyid = get_id ty
+ and conjsid = List.map (fun (_,te) -> get_id te) conjs in
+ link_hints annotation_window
+ (Array.append
+ [| "Name", "<attribute name = 'name' id = '" ^ id ^ "'/>" ;
+ "Ingredients", "<attribute name = 'params' id = '" ^ id ^ "'/>" ;
+ "Body", "<node id = '" ^ boid ^ "'/>" ;
+ "Type", "<node id = '" ^ tyid ^ "'/>"
+ |]
+ (Array.mapi
+ (fun i id ->
+ "Conjecture " ^ string_of_int i, "<node id = '" ^ id ^ "'/>"
+ ) (Array.of_list conjsid)
+ )
+ )
+ | C.AInductiveDefinition (id,_,itl,_,_) ->
+ let itlids =
+ List.map
+ (fun (_,_,arity,cons) ->
+ get_id arity,
+ List.map (fun (_,ty,_) -> get_id ty) cons
+ ) itl
+ in
+ link_hints annotation_window
+ (Array.concat
+ [
+ [| "Ingredients","<attribute name = 'params' id = '" ^ id ^ "'/>" |];
+ (Array.mapi
+ (fun i _ ->
+ "Type Name " ^ string_of_int i,
+ "<attribute name = 'name' child = '" ^ string_of_int i ^
+ "' id = '" ^ id ^ "'/>"
+ ) (Array.of_list itlids)
+ ) ;
+ (Array.mapi
+ (fun i (id,_) ->
+ "Type " ^ string_of_int i, "<node id = '" ^ id ^ "'/>"
+ ) (Array.of_list itlids)
+ ) ;
+ (Array.concat
+ (list_mapi
+ (fun i (_,consid) ->
+ (Array.mapi
+ (fun j _ ->
+ "Constructor Name " ^ string_of_int i ^ " " ^ string_of_int j,
+ "<attribute name = 'name' id = '" ^ id ^
+ "' child = '" ^ string_of_int i ^ "' grandchild = '" ^
+ string_of_int j ^ "'/>"
+ ) (Array.of_list consid)
+ ) ;
+ ) itlids
+ )
+ ) ;
+ (Array.concat
+ (list_mapi
+ (fun i (_,consid) ->
+ (Array.mapi
+ (fun j id ->
+ "Constructor " ^ string_of_int i ^ " " ^ string_of_int j,
+ "<node id = '" ^ id ^ "'/>"
+ ) (Array.of_list consid)
+ ) ;
+ ) itlids
+ )
+ )
+ ]
+ )
+;;
+
+exception IdUnknown of string;;
+
+let create_hints annotation_window (annobj,ids_to_targets) xpath =
+ try
+ match Hashtbl.find ids_to_targets xpath with
+ Cic.Object annobj -> create_hint_from_obj annotation_window annobj
+ | Cic.Term annterm -> create_hint_from_term annotation_window annterm
+ with
+ Not_found -> raise (IdUnknown xpath)
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 24/01/2000 *)
+(* *)
+(* This module implements a trival cache system (an hash-table) for cic *)
+(* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *)
+(* *)
+(******************************************************************************)
+
+let raise e = print_endline "***" ; flush stdout ; print_endline (Printexc.to_string e) ; flush stdout ; raise e;;
+
+(*CSC: forse i due seguenti tipi sono da unificare? *)
+type cooked_obj =
+ Cooked of Cic.obj
+ | Frozen of Cic.obj
+ | Unchecked of Cic.obj
+type type_checked_obj =
+ CheckedObj of Cic.obj (* cooked obj *)
+ | UncheckedObj of Cic.obj (* uncooked obj *)
+;;
+
+exception NoFunctionProvided;;
+
+(* CSC: da sostituire con un (...) option ref *)
+let cook_obj = ref (fun obj uri -> raise NoFunctionProvided);;
+
+exception CircularDependency of string;;
+exception CouldNotUnfreeze of string;;
+exception Impossible;;
+exception UncookedObj;;
+
+module HashedType =
+ struct
+ type t = UriManager.uri * int (* uri, livello di cottura *)
+ let equal (u1,n1) (u2,n2) = UriManager.eq u1 u2 && n1 = n2
+ let hash = Hashtbl.hash
+ end
+;;
+
+(* Hashtable that uses == instead of = for testing equality *)
+module HashTable = Hashtbl.Make(HashedType);;
+
+let hashtable = HashTable.create 271;;
+
+(* n is the number of time that the object must be cooked *)
+let get_obj_and_type_checking_info uri n =
+ try
+ HashTable.find hashtable (uri,n)
+ with
+ Not_found ->
+ try
+ match HashTable.find hashtable (uri,0) with
+ Cooked _
+ | Frozen _ -> raise Impossible
+ | Unchecked _ as t -> t
+ with
+ Not_found ->
+ let filename = Getter.get uri in
+ let (annobj,_) = CicParser.term_of_xml filename uri false in
+ let obj = Deannotate.deannotate_obj annobj in
+ let output = Unchecked obj in
+ HashTable.add hashtable (uri,0) output ;
+ output
+;;
+
+(* DANGEROUS!!! *)
+(* USEFUL ONLY DURING THE FIXING OF THE FILES *)
+(* change_obj uri (Some newobj) *)
+(* maps uri to newobj in cache. *)
+(* change_obj uri None *)
+(* maps uri to a freeze dummy-object. *)
+let change_obj uri newobj =
+ let newobj =
+ match newobj with
+ Some newobj' -> Unchecked newobj'
+ | None -> Frozen (Cic.Variable ("frozen-dummy", Cic.Implicit))
+ in
+ HashTable.remove hashtable (uri,0) ;
+ HashTable.add hashtable (uri,0) newobj
+;;
+
+let is_annotation_uri uri =
+ Str.string_match (Str.regexp ".*\.ann$") (UriManager.string_of_uri uri) 0
+;;
+
+(* returns both the annotated and deannotated uncooked forms (plus the *)
+(* map from ids to annotation targets) *)
+let get_annobj_and_type_checking_info uri =
+ let filename = Getter.get uri in
+ match CicParser.term_of_xml filename uri true with
+ (_, None) -> raise Impossible
+ | (annobj, Some ids_to_targets) ->
+ (* If uri is the uri of an annotation, let's use the annotation file *)
+ if is_annotation_uri uri then
+ AnnotationParser.annotate (Getter.get_ann uri) ids_to_targets ;
+ try
+ (annobj, ids_to_targets, HashTable.find hashtable (uri,0))
+ with
+ Not_found ->
+ let obj = Deannotate.deannotate_obj annobj in
+ let output = Unchecked obj in
+ HashTable.add hashtable (uri,0) output ;
+ (annobj, ids_to_targets, output)
+;;
+
+
+(* get_obj uri *)
+(* returns the cic object whose uri is uri. If the term is not just in cache, *)
+(* then it is parsed via CicParser.term_of_xml from the file whose name is *)
+(* the result of Getter.get uri *)
+let get_obj uri =
+ match get_obj_and_type_checking_info uri 0 with
+ Unchecked obj -> obj
+ | Frozen obj -> obj
+ | Cooked obj -> obj
+;;
+
+(* get_annobj uri *)
+(* returns the cic object whose uri is uri either in annotated and *)
+(* deannotated form. The term is put into the cache if it's not there yet. *)
+let get_annobj uri =
+ let (ann, ids_to_targets, deann) = get_annobj_and_type_checking_info uri in
+ let deannobj =
+ match deann with
+ Unchecked obj -> obj
+ | Frozen _ -> raise (CircularDependency (UriManager.string_of_uri uri))
+ | Cooked obj -> obj
+ in
+ (ann, ids_to_targets, deannobj)
+;;
+
+(*CSC Commento falso *)
+(* get_obj uri *)
+(* returns the cooked cic object whose uri is uri. The term must be present *)
+(* and cooked in cache *)
+let rec get_cooked_obj uri cookingsno =
+ match get_obj_and_type_checking_info uri cookingsno with
+ Unchecked _
+ | Frozen _ -> raise UncookedObj
+ | Cooked obj -> obj
+;;
+
+(* is_type_checked uri *)
+(* CSC: commento falso ed obsoleto *)
+(* returns true if the term has been type-checked *)
+(* otherwise it returns false and freeze the term for type-checking *)
+(* set_type_checking_info must be called to unfreeze the term *)
+let is_type_checked uri cookingsno =
+ match get_obj_and_type_checking_info uri cookingsno with
+ Cooked obj -> CheckedObj obj
+ | Unchecked obj ->
+ HashTable.remove hashtable (uri,0) ;
+ HashTable.add hashtable (uri,0) (Frozen obj) ;
+ UncheckedObj obj
+ | Frozen _ -> raise (CircularDependency (UriManager.string_of_uri uri))
+;;
+
+(* set_type_checking_info uri *)
+(* must be called once the type-checking of uri is finished *)
+(* The object whose uri is uri is unfreezed *)
+let set_type_checking_info uri =
+ match HashTable.find hashtable (uri,0) with
+ Frozen obj ->
+ (* let's cook the object at every level *)
+ HashTable.remove hashtable (uri,0) ;
+ let obj' = CicSubstitution.undebrujin_inductive_def uri obj in
+ HashTable.add hashtable (uri,0) (Cooked obj') ;
+ let cooked_objs = !cook_obj obj' uri in
+ let last_cooked_level = ref 0 in
+ let last_cooked_obj = ref obj' in
+ List.iter
+ (fun (n,cobj) ->
+ for i = !last_cooked_level + 1 to n do
+ HashTable.add hashtable (uri,i) (Cooked !last_cooked_obj)
+ done ;
+ HashTable.add hashtable (uri,n + 1) (Cooked cobj) ;
+ last_cooked_level := n + 1 ;
+ last_cooked_obj := cobj
+ ) cooked_objs ;
+ for i = !last_cooked_level + 1 to UriManager.depth_of_uri uri + 1 do
+ HashTable.add hashtable (uri,i) (Cooked !last_cooked_obj)
+ done
+ | _ -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri))
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 24/01/2000 *)
+(* *)
+(* This module implements a trival cache system (an hash-table) for cic *)(* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *)(* *)
+(******************************************************************************)
+
+exception CircularDependency of string;;
+
+(* get_obj uri *)
+(* returns the cic object whose uri is uri. If the term is not just in cache, *)
+(* then it is parsed via CicParser.term_of_xml from the file whose name is *)
+(* the result of Getter.get uri *)
+val get_obj : UriManager.uri -> Cic.obj
+
+(* get_annobj uri *)
+(* returns the cic object whose uri is uri either in annotated and in *)
+(* deannotated form. It returns also the map from ids to annotation targets. *)
+(* The term is put in cache if it's not there yet. *)
+(* The functions raise CircularDependency if asked to retrieve a Frozen object*)
+val get_annobj :
+ UriManager.uri -> Cic.annobj * (Cic.id, Cic.anntarget) Hashtbl.t * Cic.obj
+
+(* DANGEROUS!!! *)
+(* USEFUL ONLY DURING THE FIXING OF THE FILES *)
+(* change_obj uri (Some newobj) *)
+(* maps uri to newobj in cache. *)
+(* change_obj uri None *)
+(* maps uri to a freeze dummy-object. *)
+val change_obj : UriManager.uri -> Cic.obj option -> unit
+
+type type_checked_obj =
+ CheckedObj of Cic.obj (* cooked obj *)
+ | UncheckedObj of Cic.obj (* uncooked obj *)
+
+(* is_type_checked uri cookingsno *)
+(*CSC commento falso ed obsoleto *)
+(* returns (true,object) if the object has been type-checked *)
+(* otherwise it returns (false,object) and freeze the object for *)
+(* type-checking *)
+(* set_type_checking_info must be called to unfreeze the object *)
+val is_type_checked : UriManager.uri -> int -> type_checked_obj
+
+(* set_type_checking_info uri *)
+(* must be called once the type-checking of uri is finished *)
+(* The object whose uri is uri is unfreezed and won't be type-checked *)
+(* again in the future (is_type_checked will return true) *)
+val set_type_checking_info : UriManager.uri -> unit
+
+(* get_cooked_obj uri cookingsno *)
+val get_cooked_obj : UriManager.uri -> int -> Cic.obj
+
+val cook_obj : (Cic.obj -> UriManager.uri -> (int * Cic.obj) list) ref
--- /dev/null
+exception Impossible;;
+exception NotImplemented of int * string;;
+exception WrongUriToConstant;;
+exception WrongUriToVariable of string;;
+exception WrongUriToInductiveDefinition;;
+
+(* mem x lol is true if x is a member of one *)
+(* of the lists of the list of (int * list) lol *)
+let mem x lol =
+ List.fold_right (fun (_,l) i -> i || List.mem x l) lol false
+;;
+
+(* cook var term *)
+let cook curi cookingsno var =
+ let rec aux k =
+ let module C = Cic in
+ function
+ C.Rel n as t ->
+ (match n with
+ n when n >= k -> C.Rel (n + 1)
+ | _ -> C.Rel n
+ )
+ | C.Var uri as t ->
+ if UriManager.eq uri var then
+ C.Rel k
+ else
+ t
+ | C.Meta _ as t -> t
+ | C.Sort _ as t -> t
+ | C.Implicit as t -> t
+ | C.Cast (te, ty) -> C.Cast (aux k te, aux k ty)
+ | C.Prod (n,s,t) -> C.Prod (n, aux k s, aux (k + 1) t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, aux k s, aux (k + 1) t)
+ | C.Appl (he::tl) ->
+ (* Get rid of C.Appl (C.Appl l1) l2 *)
+ let newtl = List.map (aux k) tl in
+ (match aux k he with
+ C.Appl (he'::tl') -> C.Appl (he'::(tl'@newtl))
+ | t -> C.Appl (t::newtl)
+ )
+ | C.Appl [] -> raise Impossible
+ | C.Const (uri,_) ->
+ if match CicCache.get_obj uri with
+ C.Definition (_,_,_,params) when mem var params -> true
+ | C.Definition _ -> false
+ | C.Axiom (_,_,params) when mem var params -> true
+ | C.Axiom _ -> false
+ | C.CurrentProof _ ->
+ raise (NotImplemented (2,(UriManager.string_of_uri uri)))
+ | _ -> raise WrongUriToConstant
+ then
+ C.Appl
+ ((C.Const (uri,UriManager.relative_depth curi uri cookingsno))::
+ [C.Rel k])
+ else
+ C.Const (uri,UriManager.relative_depth curi uri cookingsno)
+ | C.Abst _ as t -> t
+ | C.MutInd (uri,_,i) ->
+ if match CicCache.get_obj uri with
+ C.InductiveDefinition (_,params,_) when mem var params -> true
+ | C.InductiveDefinition _ -> false
+ | _ -> raise WrongUriToInductiveDefinition
+ then
+ C.Appl ((C.MutInd (uri,UriManager.relative_depth curi uri cookingsno,i))::[C.Rel k])
+ else
+ C.MutInd (uri,UriManager.relative_depth curi uri cookingsno,i)
+ | C.MutConstruct (uri,_,i,j) ->
+ if match CicCache.get_obj uri with
+ C.InductiveDefinition (_,params,_) when mem var params -> true
+ | C.InductiveDefinition _ -> false
+ | _ -> raise WrongUriToInductiveDefinition
+ then
+ C.Appl ((C.MutConstruct (uri,UriManager.relative_depth curi uri cookingsno,i,j))::[C.Rel k])
+ else
+ C.MutConstruct (uri,UriManager.relative_depth curi uri cookingsno,i,j)
+ | C.MutCase (uri,_,i,outt,term,pl) ->
+ let substitutedfl =
+ List.map (aux k) pl
+ in
+ C.MutCase (uri,UriManager.relative_depth curi uri cookingsno,i,
+ aux k outt,aux k term, substitutedfl)
+ | C.Fix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) -> (name,i,aux k ty, aux (k+len) bo))
+ fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) -> (name,aux k ty, aux (k+len) bo))
+ fl
+ in
+ C.CoFix (i, substitutedfl)
+ in
+ aux 1
+;;
+
+let cook_gen add_binder curi cookingsno ty vars =
+ let module C = Cic in
+ let module U = UriManager in
+ let rec cookrec ty =
+ function
+ var::tl ->
+ let (varname, vartype) =
+ match CicCache.get_obj var with
+ C.Variable (varname, vartype) -> (varname, vartype)
+ | _ -> raise (WrongUriToVariable (U.string_of_uri var))
+ in
+ cookrec (add_binder (C.Name varname) vartype (cook curi cookingsno var ty)) tl
+ | _ -> ty
+ in
+ cookrec ty vars
+;;
+
+let cook_prod =
+ cook_gen (fun n s t -> Cic.Prod (n,s,t))
+and cook_lambda =
+ cook_gen (fun n s t -> Cic.Lambda (n,s,t))
+;;
+
+(*CSC: sbagliato da rifare e completare *)
+let cook_one_level obj curi cookingsno vars =
+ let module C = Cic in
+ match obj with
+ C.Definition (id,te,ty,params) ->
+ let ty' = cook_prod curi cookingsno ty vars in
+ let te' = cook_lambda curi cookingsno te vars in
+ C.Definition (id,te',ty',params)
+ | C.Axiom (id,ty,parameters) ->
+ let ty' = cook_prod curi cookingsno ty vars in
+ C.Axiom (id,ty',parameters)
+ | C.Variable _ as obj -> obj
+ | C.CurrentProof (id,conjs,te,ty) ->
+ let ty' = cook_prod curi cookingsno ty vars in
+ let te' = cook_lambda curi cookingsno te vars in
+ C.CurrentProof (id,conjs,te',ty')
+ | C.InductiveDefinition (dl, params, n_ind_params) ->
+ let dl' =
+ List.map
+ (fun (name,inductive,arity,constructors) ->
+ let constructors' =
+ List.map
+ (fun (name,ty,r) ->
+ let r' =
+ match !r with
+ None -> raise Impossible
+ | Some r -> List.map (fun _ -> false) vars @ r
+ in
+ (name,cook_prod curi cookingsno ty vars,ref (Some r'))
+ ) constructors
+ in
+ (name,inductive,cook_prod curi cookingsno arity vars,constructors')
+ ) dl
+ in
+ C.InductiveDefinition (dl', params, n_ind_params + List.length vars)
+;;
+
+let cook_obj obj uri =
+ let module C = Cic in
+ let params =
+ match obj with
+ C.Definition (_,_,_,params) -> params
+ | C.Axiom (_,_,params) -> params
+ | C.Variable _ -> []
+ | C.CurrentProof _ -> []
+ | C.InductiveDefinition (_,params,_) -> params
+ in
+ let rec cook_all_levels obj =
+ function
+ [] -> []
+ | (n,vars)::tl ->
+ let cooked_obj = cook_one_level obj uri (n + 1) (List.rev vars) in
+ (n,cooked_obj)::(cook_all_levels cooked_obj tl)
+ in
+ cook_all_levels obj (List.rev params)
+;;
+
+CicCache.cook_obj := cook_obj;;
--- /dev/null
+exception Impossible
+exception NotImplemented of int * string
+exception WrongUriToConstant
+exception WrongUriToVariable of string
+exception WrongUriToInductiveDefinition
+val cook_obj : Cic.obj -> UriManager.uri -> (int * Cic.obj) list
--- /dev/null
+exception WrongUriToConstant;;
+exception WrongUriToInductiveDefinition;;
+exception CircularDependency of string;;
+
+module OrderedUris =
+ struct
+ type t = UriManager.uri
+ let compare (s1 : t) (s2 : t) =
+ (* library function for = *)
+ compare s1 s2
+ (*if s1 = s2 then 0 else if s1 < s2 then (-1) else 1*)
+ end
+;;
+
+let filename_of_uri uri =
+ let uri' = UriManager.string_of_uri uri in
+ let fn = Str.replace_first (Str.regexp "cic:") Configuration.helm_dir uri' in
+ fn ^ ".xml"
+;;
+
+(* quite inefficient coding of a set of strings: the only operations *)
+(* performed are mem O(log n), and union O(n * log n?) *)
+(* Perhaps a better implementation would be an array of bits or a map *)
+(* from uri to booleans *)
+module SetOfUris = Set.Make(OrderedUris);;
+
+let (@@) = SetOfUris.union;;
+
+let rec parameters_of te ty pparams=
+ let module S = SetOfUris in
+ let module C = Cic in
+ let rec aux =
+ function
+ C.Rel _ -> S.empty
+ | C.Var uri -> S.singleton uri
+ | C.Meta _ -> S.empty
+ | C.Sort _ -> S.empty
+ | C.Implicit -> S.empty
+ | C.Cast (te, ty) -> aux te @@ aux ty
+ | C.Prod (_, s, t) -> aux s @@ aux t
+ | C.Lambda (_, s, t) -> aux s @@ aux t
+ | C.Appl l -> List.fold_right (fun x i -> aux x @@ i) l S.empty
+ | C.Const (uri,_) ->
+ (* the parameters could be not exact but only possible *)
+ fix_params uri (Some (filename_of_uri uri)) ;
+ (* now the parameters are surely possible *)
+ (match CicCache.get_obj uri with
+ C.Definition (_, _, _, params) ->
+ List.fold_right
+ (fun (_,l) i ->
+ List.fold_right
+ (fun x i -> S.singleton x @@ i) l i
+ ) params S.empty
+ | C.Axiom (_, _, params) ->
+ List.fold_right
+ (fun (_,l) i ->
+ List.fold_right
+ (fun x i -> S.singleton x @@ i) l i
+ ) params S.empty
+ | C.CurrentProof _ -> S.empty (*CSC wrong *)
+ | _ -> raise WrongUriToConstant
+ )
+ | C.Abst _ -> S.empty
+ | C.MutInd (uri,_,_) ->
+ (match CicCache.get_obj uri with
+ C.InductiveDefinition (_, params, _) ->
+ List.fold_right
+ (fun (_,l) i ->
+ List.fold_right
+ (fun x i -> S.singleton x @@ i) l i
+ ) params S.empty
+ | _ -> raise WrongUriToInductiveDefinition
+ )
+ | C.MutConstruct (uri,_,_,_) ->
+ (match CicCache.get_obj uri with
+ C.InductiveDefinition (_, params, _) ->
+ List.fold_right
+ (fun (_,l) i ->
+ List.fold_right
+ (fun x i -> S.singleton x @@ i) l i
+ ) params S.empty
+ | _ -> raise WrongUriToInductiveDefinition
+ )
+ | C.MutCase (uri,_,_,outtype,term,patterns) ->
+ (*CSC cosa basta? Ci vuole anche uri? *)
+ (match CicCache.get_obj uri with
+ C.InductiveDefinition (_, params, _) ->
+ List.fold_right
+ (fun (_,l) i ->
+ List.fold_right
+ (fun x i -> S.singleton x @@ i) l i
+ ) params S.empty
+ | _ -> raise WrongUriToInductiveDefinition
+ ) @@ aux outtype @@ aux term @@
+ List.fold_right (fun x i -> aux x @@ i) patterns S.empty
+ | C.Fix (_,fl) ->
+ List.fold_right
+ (fun (_,_,ty,bo) i -> aux ty @@ aux bo @@ i)
+ fl S.empty
+ | C.CoFix (_,fl) ->
+ List.fold_right
+ (fun (_,ty,bo) i -> aux ty @@ aux bo @@ i)
+ fl S.empty
+ in
+ let actual_params = aux te @@ aux ty in
+ (* sort_actual_params wants in input the ordered list of possible params *)
+ let rec sort_actual_params2 =
+ function
+ [] -> []
+ | he::tl when S.mem he actual_params -> he::(sort_actual_params2 tl)
+ | _::tl -> sort_actual_params2 tl
+ in
+ let rec sort_actual_params =
+ function
+ [] -> []
+ | (n,l)::tl -> (n, sort_actual_params2 l)::(sort_actual_params tl)
+ in
+ sort_actual_params pparams
+
+and fix_params uri filename =
+ let module C = Cic in
+ let (ann, _, deann) = CicCache.get_annobj uri in
+ match ann, deann with
+ (C.ADefinition (xid, ann, id, te, ty, C.Possible pparams),
+ C.Definition (id', te', ty', _)) ->
+ (* let's freeze the object to avoid circular dependencies *)
+ CicCache.change_obj uri None ;
+ let real_params = parameters_of te' ty' pparams in
+ let fixed =
+ C.ADefinition (xid,ann,id,te,ty,C.Actual real_params)
+ in
+ Xml.pp (Cic2Xml.pp fixed uri) filename ;
+ (* unfreeze and fix the object *)
+ CicCache.change_obj uri
+ (Some (C.Definition (id', te', ty', real_params)))
+ | _ -> ()
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 24/01/2000 *)
+(* *)
+(* This is the main (top level) module of a parser for cic objects from xml *)
+(* files to the internal representation. It uses the modules cicParser2 *)
+(* (objects level) and cicParser3 (terms level) *)
+(* *)
+(******************************************************************************)
+
+exception Warnings;;
+
+class warner =
+ object
+ method warn w =
+ print_endline ("WARNING: " ^ w) ;
+ (raise Warnings : unit)
+ end
+;;
+
+exception EmptyUri;;
+
+(* given an uri u it returns the list of tokens of the base uri of u *)
+(* e.g.: token_of_uri "cic:/a/b/c/d.xml" returns ["a" ; "b" ; "c"] *)
+let tokens_of_uri uri =
+ let uri' = UriManager.string_of_uri uri in
+ let rec chop_list =
+ function
+ [] -> raise EmptyUri
+ | he::[fn] -> [he]
+ | he::tl -> he::(chop_list tl)
+ in
+ let trimmed_uri = Str.replace_first (Str.regexp "cic:") "" uri' in
+ let list_of_tokens = Str.split (Str.regexp "/") trimmed_uri in
+ chop_list list_of_tokens
+;;
+
+(* given the filename of an xml file of a cic object it returns its internal *)
+(* representation. process_annotations is true if the annotations do really *)
+(* matter *)
+let term_of_xml filename uri process_annotations =
+ let module Y = Pxp_yacc in
+ try
+ let d =
+ (* sets the current base uri to resolve relative URIs *)
+ CicParser3.current_sp := tokens_of_uri uri ;
+ CicParser3.current_uri := uri ;
+ CicParser3.process_annotations := process_annotations ;
+ CicParser3.ids_to_targets :=
+ if process_annotations then Some (Hashtbl.create 500) else None ;
+ let config = {Y.default_config with Y.warner = new warner} in
+ Y.parse_document_entity config
+(*PXP (Y.ExtID (Pxp_types.System filename,
+ new Pxp_reader.resolve_as_file ~url_of_id ()))
+*) (PxpUriResolver.from_file filename)
+ CicParser3.domspec
+ in
+ let ids_to_targets = !CicParser3.ids_to_targets in
+ let res = (CicParser2.get_term d#root, ids_to_targets) in
+ CicParser3.ids_to_targets := None ; (* let's help the GC *)
+ res
+ with
+ e ->
+ print_endline (Pxp_types.string_of_exn e) ;
+ raise e
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 22/03/2000 *)
+(* *)
+(* This is the main (top level) module of a parser for cic objects from xml *)
+(* files to the internal representation. It uses the modules cicParser2 *)
+(* (objects level) and cicParser3 (terms level) *)
+(* *)
+(******************************************************************************)
+
+(* given the filename of an xml file of a cic object and it's uri, it returns *)
+(* its internal annotated representation. The boolean is set to true if the *)
+(* annotations do really matter *)
+val term_of_xml :
+ string -> UriManager.uri -> bool ->
+ Cic.annobj * (Cic.id, Cic.anntarget) Hashtbl.t option
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@@cs.unibo.it> *)
+(* 24/01/2000 *)
+(* *)
+(* This module is the objects level of a parser for cic objects from xml *)
+(* files to the internal representation. It uses the module cicParser3 *)
+(* cicParser3 (terms level) and it is used only through cicParser2 (top *)
+(* level). *)
+(* *)
+(******************************************************************************)
+
+exception IllFormedXml of int;;
+exception NotImplemented;;
+
+(* Utility functions that transform a Pxp attribute into something useful *)
+
+(* mk_absolute_uris "n1: v1 ... vn n2 : u1 ... un ...." *)
+(* returns [(n1,[absolute_uri_for_v1 ; ... ; absolute_uri_for_vn]) ; (n2,...) *)
+let mk_absolute_uris s =
+ let l = (Str.split (Str.regexp ":") s) in
+ let absolute_of_relative n v =
+ let module P3 = CicParser3 in
+ let rec mkburi =
+ function
+ (0,_) -> "/"
+ | (n,he::tl) when n > 0 ->
+ "/" ^ he ^ mkburi (n - 1, tl)
+ | _ -> raise (IllFormedXml 12)
+ in
+ let m = List.length !P3.current_sp - (int_of_string n) in
+ let buri = mkburi (m, !P3.current_sp) in
+ UriManager.uri_of_string ("cic:" ^ buri ^ v ^ ".var")
+ in
+ let rec absolutize =
+ function
+ [] -> []
+ | [no ; vs] ->
+ let vars = (Str.split (Str.regexp " ") vs) in
+ [(int_of_string no, List.map (absolute_of_relative no) vars)]
+ | no::vs::tl ->
+ let vars = (Str.split (Str.regexp " ") vs) in
+ let rec add_prefix =
+ function
+ [no2] -> ([], no2)
+ | he::tl ->
+ let (pvars, no2) = add_prefix tl in
+ ((absolute_of_relative no he)::pvars, no2)
+ | _ -> raise (IllFormedXml 11)
+ in
+ let (pvars, no2) = add_prefix vars in
+ (int_of_string no, pvars)::(absolutize (no2::tl))
+ | _ -> raise (IllFormedXml 10)
+ in
+ (* last parameter must be applied first *)
+ absolutize l
+;;
+
+let option_uri_list_of_attr a1 a2 =
+ let module T = Pxp_types in
+ let parameters =
+ match a1 with
+ T.Value s -> mk_absolute_uris s
+ | _ -> raise (IllFormedXml 0)
+ in
+ match a2 with
+ T.Value "POSSIBLE" -> Cic.Possible parameters
+ | T.Implied_value -> Cic.Actual parameters
+ | _ -> raise (IllFormedXml 0)
+;;
+
+let uri_list_of_attr a =
+ let module T = Pxp_types in
+ match a with
+ T.Value s -> mk_absolute_uris s
+ | _ -> raise (IllFormedXml 0)
+;;
+
+let string_of_attr a =
+ let module T = Pxp_types in
+ match a with
+ T.Value s -> s
+ | _ -> raise (IllFormedXml 0)
+;;
+
+let int_of_attr a =
+ int_of_string (string_of_attr a)
+;;
+
+let bool_of_attr a =
+ bool_of_string (string_of_attr a)
+;;
+
+(* Other utility functions *)
+
+let get_content n =
+ match n#sub_nodes with
+ [ t ] -> t
+ | _ -> raise (IllFormedXml 1)
+;;
+
+let register_id id node =
+ if !CicParser3.process_annotations then
+ match !CicParser3.ids_to_targets with
+ None -> assert false
+ | Some ids_to_targets ->
+ Hashtbl.add ids_to_targets id (Cic.Object node)
+;;
+
+(* Functions that, given the list of sons of a node of the cic dom (objects *)
+(* level), retrieve the internal representation associated to the node. *)
+(* Everytime a cic term subtree is found, it is translated to the internal *)
+(* representation using the method to_cic_term defined in cicParser3. *)
+(* Each function raise IllFormedXml if something goes wrong, but this should *)
+(* be impossible due to the presence of the dtd *)
+(* The functions should really be obvious looking at their name and the cic *)
+(* dtd *)
+
+(* called when a CurrentProof is found *)
+let get_conjs_value_type l =
+ let rec rget (c, v, t) l =
+ let module D = Pxp_document in
+ match l with
+ [] -> (c, v, t)
+ | conj::tl when conj#node_type = D.T_element "Conjecture" ->
+ let no = int_of_attr (conj#attribute "no")
+ and typ = (get_content conj)#extension#to_cic_term in
+ rget ((no, typ)::c, v, t) tl
+ | value::tl when value#node_type = D.T_element "body" ->
+ let v' = (get_content value)#extension#to_cic_term in
+ (match v with
+ None -> rget (c, Some v', t) tl
+ | _ -> raise (IllFormedXml 2)
+ )
+ | typ::tl when typ#node_type = D.T_element "type" ->
+ let t' = (get_content typ)#extension#to_cic_term in
+ (match t with
+ None -> rget (c, v, Some t') tl
+ | _ -> raise (IllFormedXml 3)
+ )
+ | _ -> raise (IllFormedXml 4)
+ in
+ match rget ([], None, None) l with
+ (c, Some v, Some t) -> (c, v, t)
+ | _ -> raise (IllFormedXml 5)
+;;
+
+(* used only by get_inductive_types; called one time for each inductive *)
+(* definitions in a block of inductive definitions *)
+let get_names_arity_constructors l =
+ let rec rget (a,c) l =
+ let module D = Pxp_document in
+ match l with
+ [] -> (a, c)
+ | arity::tl when arity#node_type = D.T_element "arity" ->
+ let a' = (get_content arity)#extension#to_cic_term in
+ rget (Some a',c) tl
+ | con::tl when con#node_type = D.T_element "Constructor" ->
+ let id = string_of_attr (con#attribute "name")
+ and ty = (get_content con)#extension#to_cic_term in
+ rget (a,(id,ty,ref None)::c) tl
+ | _ -> raise (IllFormedXml 9)
+ in
+ match rget (None,[]) l with
+ (Some a, c) -> (a, List.rev c)
+ | _ -> raise (IllFormedXml 8)
+;;
+
+(* called when an InductiveDefinition is found *)
+let rec get_inductive_types =
+ function
+ [] -> []
+ | he::tl ->
+ let tyname = string_of_attr (he#attribute "name")
+ and inductive = bool_of_attr (he#attribute "inductive")
+ and (arity,cons) =
+ get_names_arity_constructors (he#sub_nodes)
+ in
+ (tyname,inductive,arity,cons)::(get_inductive_types tl) (*CSC 0 a caso *)
+;;
+
+(* This is the main function and also the only one used directly from *)
+(* cicParser. Given the root of the dom tree, it returns the internal *)
+(* representation of the cic object described in the tree *)
+(* It uses the previous functions and the to_cic_term method defined *)
+(* in cicParser3 (used for subtrees that encode cic terms) *)
+let rec get_term n =
+ let module D = Pxp_document in
+ let module C = Cic in
+ let ntype = n # node_type in
+ match ntype with
+ D.T_element "Definition" ->
+ let id = string_of_attr (n # attribute "name")
+ and params =
+ option_uri_list_of_attr (n#attribute "params") (n#attribute "paramMode")
+ and (value, typ) =
+ let sons = n#sub_nodes in
+ match sons with
+ [v ; t] when
+ v#node_type = D.T_element "body" &&
+ t#node_type = D.T_element "type" ->
+ let v' = get_content v
+ and t' = get_content t in
+ (v'#extension#to_cic_term, t'#extension#to_cic_term)
+ | _ -> raise (IllFormedXml 6)
+ and xid = string_of_attr (n#attribute "id") in
+ let res = C.ADefinition (xid, ref None, id, value, typ, params) in
+ register_id xid res ;
+ res
+ | D.T_element "Axiom" ->
+ let id = string_of_attr (n # attribute "name")
+ and params = uri_list_of_attr (n # attribute "params")
+ and typ =
+ (get_content (get_content n))#extension#to_cic_term
+ and xid = string_of_attr (n#attribute "id") in
+ let res = C.AAxiom (xid, ref None, id, typ, params) in
+ register_id xid res ;
+ res
+ | D.T_element "CurrentProof" ->
+ let name = string_of_attr (n#attribute "name")
+ and xid = string_of_attr (n#attribute "id") in
+ let sons = n#sub_nodes in
+ let (conjs, value, typ) = get_conjs_value_type sons in
+ let res = C.ACurrentProof (xid, ref None, name, conjs, value, typ) in
+ register_id xid res ;
+ res
+ | D.T_element "InductiveDefinition" ->
+ let sons = n#sub_nodes
+ and xid = string_of_attr (n#attribute "id") in
+ let inductiveTypes = get_inductive_types sons
+ and params = uri_list_of_attr (n#attribute "params")
+ and nparams = int_of_attr (n#attribute "noParams") in
+ let res =
+ C.AInductiveDefinition (xid, ref None, inductiveTypes, params, nparams)
+ in
+ register_id xid res ;
+ res
+ | D.T_element "Variable" ->
+ let name = string_of_attr (n#attribute "name")
+ and xid = string_of_attr (n#attribute "id") in
+ let typ = (get_content (get_content n))#extension#to_cic_term in
+ let res = C.AVariable (xid,ref None,name,typ) in
+ register_id xid res ;
+ res
+ | D.T_element _
+ | D.T_data ->
+ raise (IllFormedXml 7)
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 24/01/2000 *)
+(* *)
+(* This module is the objects level of a parser for cic objects from xml *)
+(* files to the internal representation. It uses the module cicParser3 *)
+(* cicParser3 (terms level) and it is used only through cicParser2 (top *)
+(* level). *)
+(* *)
+(******************************************************************************)
+
+exception IllFormedXml of int
+exception NotImplemented
+
+(* This is the main function and also the only one used directly from *)
+(* cicParser. Given the root of the dom tree, it returns the internal *)
+(* representation of the cic object described in the tree *)
+(* It uses the previous functions and the to_cic_term method defined *)
+(* in cicParser3 (used for subtrees that encode cic terms) *)
+val get_term :
+ < attribute : string -> Pxp_types.att_value;
+ node_type : Pxp_document.node_type;
+ sub_nodes : < attribute : string -> Pxp_types.att_value;
+ node_type : Pxp_document.node_type;
+ sub_nodes : CicParser3.cic_term Pxp_document.node list;
+ .. >
+ list;
+ .. > ->
+ Cic.annobj
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 24/01/2000 *)
+(* *)
+(* This module is the terms level of a parser for cic objects from xml *)
+(* files to the internal representation. It is used by the module cicParser2 *)
+(* (objects level). It defines an extension of the standard dom using the *)
+(* object-oriented extension machinery of markup: an object with a method *)
+(* to_cic_term that returns the internal representation of the subtree is *)
+(* added to each node of the dom tree *)
+(* *)
+(******************************************************************************)
+
+exception IllFormedXml of int;;
+
+(* The hashtable from the current identifiers to the object or the terms *)
+let ids_to_targets = ref None;;
+
+(* The list of tokens of the current section path. *)
+(* Used to resolve relative URIs *)
+let current_sp = ref [];;
+
+(* The uri of the object been parsed *)
+let current_uri = ref (UriManager.uri_of_string "cic:/.xml");;
+
+(* True if annotation really matter *)
+let process_annotations = ref false;;
+
+(* Utility functions to map a markup attribute to something useful *)
+
+let cic_attr_of_xml_attr =
+ function
+ Pxp_types.Value s -> Cic.Name s
+ | Pxp_types.Implied_value -> Cic.Anonimous
+ | _ -> raise (IllFormedXml 1)
+
+let cic_sort_of_xml_attr =
+ function
+ Pxp_types.Value "Prop" -> Cic.Prop
+ | Pxp_types.Value "Set" -> Cic.Set
+ | Pxp_types.Value "Type" -> Cic.Type
+ | _ -> raise (IllFormedXml 2)
+
+let int_of_xml_attr =
+ function
+ Pxp_types.Value n -> int_of_string n
+ | _ -> raise (IllFormedXml 3)
+
+let uri_of_xml_attr =
+ function
+ Pxp_types.Value s -> UriManager.uri_of_string s
+ | _ -> raise (IllFormedXml 4)
+
+let string_of_xml_attr =
+ function
+ Pxp_types.Value s -> s
+ | _ -> raise (IllFormedXml 5)
+
+let binder_of_xml_attr =
+ function
+ Pxp_types.Value s -> if !process_annotations then Some s else None
+ | _ -> raise (IllFormedXml 17)
+;;
+
+let register_id id node =
+ if !process_annotations then
+ match !ids_to_targets with
+ None -> assert false
+ | Some ids_to_targets ->
+ Hashtbl.add ids_to_targets id (Cic.Term node)
+;;
+
+(* the "interface" of the class linked to each node of the dom tree *)
+
+class virtual cic_term =
+ object (self)
+
+ (* fields and methods ever required by markup *)
+ val mutable node = (None : cic_term Pxp_document.node option)
+
+ method clone = {< >}
+ method node =
+ match node with
+ None ->
+ assert false
+ | Some n -> n
+ method set_node n =
+ node <- Some n
+
+ (* a method that returns the internal representation of the tree (term) *)
+ (* rooted in this node *)
+ method virtual to_cic_term : Cic.annterm
+ end
+;;
+
+(* the class of the objects linked to nodes that are not roots of cic terms *)
+class eltype_not_of_cic =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term = raise (IllFormedXml 6)
+ end
+;;
+
+(* the class of the objects linked to nodes whose content is a cic term *)
+(* (syntactic sugar xml entities) e.g. <type> ... </type> *)
+class eltype_transparent =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let n = self#node in
+ match n#sub_nodes with
+ [ t ] -> t#extension#to_cic_term
+ | _ -> raise (IllFormedXml 7)
+ end
+;;
+
+(* A class for each cic node type *)
+
+class eltype_fix =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let n = self#node in
+ let nofun = int_of_xml_attr (n#attribute "noFun")
+ and id = string_of_xml_attr (n#attribute "id")
+ and functions =
+ let sons = n#sub_nodes in
+ List.map
+ (function
+ f when f#node_type = Pxp_document.T_element "FixFunction" ->
+ let name = string_of_xml_attr (f#attribute "name")
+ and recindex = int_of_xml_attr (f#attribute "recIndex")
+ and (ty, body) =
+ match f#sub_nodes with
+ [t ; b] when
+ t#node_type = Pxp_document.T_element "type" &&
+ b#node_type = Pxp_document.T_element "body" ->
+ (t#extension#to_cic_term, b#extension#to_cic_term)
+ | _ -> raise (IllFormedXml 14)
+ in
+ (name, recindex, ty, body)
+ | _ -> raise (IllFormedXml 13)
+ ) sons
+ in
+ let res = Cic.AFix (id, ref None, nofun, functions) in
+ register_id id res ;
+ res
+ end
+;;
+
+class eltype_cofix =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let n = self#node in
+ let nofun = int_of_xml_attr (n#attribute "noFun")
+ and id = string_of_xml_attr (n#attribute "id")
+ and functions =
+ let sons = n#sub_nodes in
+ List.map
+ (function
+ f when f#node_type = Pxp_document.T_element "CofixFunction" ->
+ let name = string_of_xml_attr (f#attribute "name")
+ and (ty, body) =
+ match f#sub_nodes with
+ [t ; b] when
+ t#node_type = Pxp_document.T_element "type" &&
+ b#node_type = Pxp_document.T_element "body" ->
+ (t#extension#to_cic_term, b#extension#to_cic_term)
+ | _ -> raise (IllFormedXml 16)
+ in
+ (name, ty, body)
+ | _ -> raise (IllFormedXml 15)
+ ) sons
+ in
+ let res = Cic.ACoFix (id, ref None, nofun, functions) in
+ register_id id res ;
+ res
+ end
+;;
+
+class eltype_implicit =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let n = self#node in
+ let id = string_of_xml_attr (n#attribute "id") in
+ let res = Cic.AImplicit (id, ref None) in
+ register_id id res ;
+ res
+ end
+;;
+
+class eltype_rel =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let n = self#node in
+ let value = int_of_xml_attr (n#attribute "value")
+ and binder = binder_of_xml_attr (n#attribute "binder")
+ and id = string_of_xml_attr (n#attribute "id") in
+ let res = Cic.ARel (id,ref None,value,binder) in
+ register_id id res ;
+ res
+ end
+;;
+
+class eltype_meta =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let n = self#node in
+ let value = int_of_xml_attr (n#attribute "no")
+ and id = string_of_xml_attr (n#attribute "id") in
+ let res = Cic.AMeta (id,ref None,value) in
+ register_id id res ;
+ res
+ end
+;;
+
+class eltype_var =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let n = self#node in
+ let name = string_of_xml_attr (n#attribute "relUri")
+ and xid = string_of_xml_attr (n#attribute "id") in
+ match Str.split (Str.regexp ",") name with
+ [index; id] ->
+ let get_prefix n =
+ let rec aux =
+ function
+ (0,_) -> "/"
+ | (n,he::tl) when n > 0 -> "/" ^ he ^ aux (n - 1, tl)
+ | _ -> raise (IllFormedXml 19)
+ in
+ aux (List.length !current_sp - n,!current_sp)
+ in
+ let res =
+ Cic.AVar
+ (xid,ref None,
+ (UriManager.uri_of_string
+ ("cic:" ^ get_prefix (int_of_string index) ^ id ^ ".var"))
+ )
+ in
+ register_id id res ;
+ res
+ | _ -> raise (IllFormedXml 18)
+ end
+;;
+
+class eltype_apply =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let n = self#node in
+ let children = n#sub_nodes
+ and id = string_of_xml_attr (n#attribute "id") in
+ if List.length children < 2 then raise (IllFormedXml 8)
+ else
+ let res =
+ Cic.AAppl
+ (id,ref None,List.map (fun x -> x#extension#to_cic_term) children)
+ in
+ register_id id res ;
+ res
+ end
+;;
+
+class eltype_cast =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let n = self#node in
+ let sons = n#sub_nodes
+ and id = string_of_xml_attr (n#attribute "id") in
+ match sons with
+ [te ; ty] when
+ te#node_type = Pxp_document.T_element "term" &&
+ ty#node_type = Pxp_document.T_element "type" ->
+ let term = te#extension#to_cic_term
+ and typ = ty#extension#to_cic_term in
+ let res = Cic.ACast (id,ref None,term,typ) in
+ register_id id res ;
+ res
+ | _ -> raise (IllFormedXml 9)
+ end
+;;
+
+class eltype_sort =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let n = self#node in
+ let sort = cic_sort_of_xml_attr (n#attribute "value")
+ and id = string_of_xml_attr (n#attribute "id") in
+ let res = Cic.ASort (id,ref None,sort) in
+ register_id id res ;
+ res
+ end
+;;
+
+class eltype_abst =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let n = self#node in
+ let value = uri_of_xml_attr (n#attribute "uri")
+ and id = string_of_xml_attr (n#attribute "id") in
+ let res = Cic.AAbst (id,ref None,value) in
+ register_id id res ;
+ res
+ end
+;;
+
+class eltype_const =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let module U = UriManager in
+ let n = self#node in
+ let value = uri_of_xml_attr (n#attribute "uri")
+ and id = string_of_xml_attr (n#attribute "id") in
+ let res =
+ Cic.AConst (id,ref None,value, U.relative_depth !current_uri value 0)
+ in
+ register_id id res ;
+ res
+ end
+;;
+
+class eltype_mutind =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let module U = UriManager in
+ let n = self#node in
+ let name = uri_of_xml_attr (n#attribute "uri")
+ and noType = int_of_xml_attr (n#attribute "noType")
+ and id = string_of_xml_attr (n#attribute "id") in
+ let res =
+ Cic.AMutInd
+ (id,ref None,name, U.relative_depth !current_uri name 0, noType)
+ in
+ register_id id res ;
+ res
+ end
+;;
+
+class eltype_mutconstruct =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let module U = UriManager in
+ let n = self#node in
+ let name = uri_of_xml_attr (n#attribute "uri")
+ and noType = int_of_xml_attr (n#attribute "noType")
+ and noConstr = int_of_xml_attr (n#attribute "noConstr")
+ and id = string_of_xml_attr (n#attribute "id") in
+ let res =
+ Cic.AMutConstruct
+ (id, ref None, name, U.relative_depth !current_uri name 0,
+ noType, noConstr)
+ in
+ register_id id res ;
+ res
+ end
+;;
+
+class eltype_prod =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let n = self#node in
+ let sons = n#sub_nodes
+ and id = string_of_xml_attr (n#attribute "id") in
+ match sons with
+ [s ; t] when
+ s#node_type = Pxp_document.T_element "source" &&
+ t#node_type = Pxp_document.T_element "target" ->
+ let name = cic_attr_of_xml_attr (t#attribute "binder")
+ and source = s#extension#to_cic_term
+ and target = t#extension#to_cic_term in
+ let res = Cic.AProd (id,ref None,name,source,target) in
+ register_id id res ;
+ res
+ | _ -> raise (IllFormedXml 10)
+ end
+;;
+
+class eltype_mutcase =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let module U = UriManager in
+ let n = self#node in
+ let sons = n#sub_nodes
+ and id = string_of_xml_attr (n#attribute "id") in
+ match sons with
+ ty::te::patterns when
+ ty#node_type = Pxp_document.T_element "patternsType" &&
+ te#node_type = Pxp_document.T_element "inductiveTerm" ->
+ let ci = uri_of_xml_attr (n#attribute "uriType")
+ and typeno = int_of_xml_attr (n#attribute "noType")
+ and inductiveType = ty#extension#to_cic_term
+ and inductiveTerm = te#extension#to_cic_term
+ and lpattern= List.map (fun x -> x#extension#to_cic_term) patterns
+ in
+ let res =
+ Cic.AMutCase (id,ref None,ci,U.relative_depth !current_uri ci 0,
+ typeno,inductiveType,inductiveTerm,lpattern)
+ in
+ register_id id res ;
+ res
+ | _ -> raise (IllFormedXml 11)
+ end
+;;
+
+class eltype_lambda =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term =
+ let n = self#node in
+ let sons = n#sub_nodes
+ and id = string_of_xml_attr (n#attribute "id") in
+ match sons with
+ [s ; t] when
+ s#node_type = Pxp_document.T_element "source" &&
+ t#node_type = Pxp_document.T_element "target" ->
+ let name = cic_attr_of_xml_attr (t#attribute "binder")
+ and source = s#extension#to_cic_term
+ and target = t#extension#to_cic_term in
+ let res = Cic.ALambda (id,ref None,name,source,target) in
+ register_id id res ;
+ res
+ | _ -> raise (IllFormedXml 12)
+ end
+;;
+
+(* The definition of domspec, an hashtable that maps each node type to the *)
+(* object that must be linked to it. Used by markup. *)
+
+let domspec =
+ let module D = Pxp_document in
+ D.make_spec_from_alist
+ ~data_exemplar: (new D.data_impl (new eltype_not_of_cic))
+ ~default_element_exemplar: (new D.element_impl (new eltype_not_of_cic))
+ ~element_alist:
+ [ "REL", (new D.element_impl (new eltype_rel)) ;
+ "VAR", (new D.element_impl (new eltype_var)) ;
+ "META", (new D.element_impl (new eltype_meta)) ;
+ "SORT", (new D.element_impl (new eltype_sort)) ;
+ "IMPLICIT", (new D.element_impl (new eltype_implicit)) ;
+ "CAST", (new D.element_impl (new eltype_cast)) ;
+ "PROD", (new D.element_impl (new eltype_prod)) ;
+ "LAMBDA", (new D.element_impl (new eltype_lambda)) ;
+ "APPLY", (new D.element_impl (new eltype_apply)) ;
+ "CONST", (new D.element_impl (new eltype_const)) ;
+ "ABST", (new D.element_impl (new eltype_abst)) ;
+ "MUTIND", (new D.element_impl (new eltype_mutind)) ;
+ "MUTCONSTRUCT", (new D.element_impl (new eltype_mutconstruct)) ;
+ "MUTCASE", (new D.element_impl (new eltype_mutcase)) ;
+ "FIX", (new D.element_impl (new eltype_fix)) ;
+ "COFIX", (new D.element_impl (new eltype_cofix)) ;
+ "arity", (new D.element_impl (new eltype_transparent)) ;
+ "term", (new D.element_impl (new eltype_transparent)) ;
+ "type", (new D.element_impl (new eltype_transparent)) ;
+ "body", (new D.element_impl (new eltype_transparent)) ;
+ "source", (new D.element_impl (new eltype_transparent)) ;
+ "target", (new D.element_impl (new eltype_transparent)) ;
+ "patternsType", (new D.element_impl (new eltype_transparent)) ;
+ "inductiveTerm", (new D.element_impl (new eltype_transparent)) ;
+ "pattern", (new D.element_impl (new eltype_transparent))
+ ]
+ ()
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 24/01/2000 *)
+(* *)
+(* This module is the terms level of a parser for cic objects from xml *)
+(* files to the internal representation. It is used by the module cicParser2 *)
+(* (objects level). It defines an extension of the standard dom using the *)
+(* object-oriented extension machinery of markup: an object with a method *)
+(* to_cic_term that returns the internal representation of the subtree is *)
+(* added to each node of the dom tree *)
+(* *)
+(******************************************************************************)
+
+exception IllFormedXml of int
+
+val ids_to_targets : (Cic.id, Cic.anntarget) Hashtbl.t option ref
+val current_sp : string list ref
+val current_uri : UriManager.uri ref
+val process_annotations : bool ref
+
+(* the "interface" of the class linked to each node of the dom tree *)
+class virtual cic_term :
+ object ('a)
+
+ (* fields and methods ever required by markup *)
+ val mutable node : cic_term Pxp_document.node option
+ method clone : 'a
+ method node : cic_term Pxp_document.node
+ method set_node : cic_term Pxp_document.node -> unit
+
+ (* a method that returns the internal representation of the tree (term) *)
+ (* rooted in this node *)
+ method virtual to_cic_term : Cic.annterm
+
+ end
+
+(* The definition of domspec, an hashtable that maps each node type to the *)
+(* object that must be linked to it. Used by markup. *)
+val domspec : cic_term Pxp_document.spec
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 24/01/2000 *)
+(* *)
+(* This module implements a very simple Coq-like pretty printer that, given *)
+(* an object of cic (internal representation) returns a string describing the *)
+(* object in a syntax similar to that of coq *)
+(* *)
+(******************************************************************************)
+
+exception CicPpInternalError;;
+
+(* Utility functions *)
+
+let string_of_name =
+ function
+ Cic.Name s -> s
+ | Cic.Anonimous -> "_"
+;;
+
+(* get_nth l n returns the nth element of the list l if it exists or raise *)
+(* a CicPpInternalError if l has less than n elements or n < 1 *)
+let rec get_nth l n =
+ match (n,l) with
+ (1, he::_) -> he
+ | (n, he::tail) when n > 1 -> get_nth tail (n-1)
+ | (_,_) -> raise CicPpInternalError
+;;
+
+(* pp t l *)
+(* pretty-prints a term t of cic in an environment l where l is a list of *)
+(* identifier names used to resolve DeBrujin indexes. The head of l is the *)
+(* name associated to the greatest DeBrujin index in t *)
+let rec pp t l =
+ let module C = Cic in
+ match t with
+ C.Rel n ->
+ (match get_nth l n with
+ C.Name s -> s
+ | _ -> raise CicPpInternalError
+ )
+ | C.Var uri -> UriManager.name_of_uri uri
+ | C.Meta n -> "?" ^ (string_of_int n)
+ | C.Sort s ->
+ (match s with
+ C.Prop -> "Prop"
+ | C.Set -> "Set"
+ | C.Type -> "Type"
+ )
+ | C.Implicit -> "?"
+ | C.Prod (b,s,t) ->
+ (match b with
+ C.Name n -> "(" ^ n ^ ":" ^ pp s l ^ ")" ^ pp t (b::l)
+ | C.Anonimous -> "(" ^ pp s l ^ "->" ^ pp t (b::l) ^ ")"
+ )
+ | C.Cast (v,t) -> pp v l
+ | C.Lambda (b,s,t) ->
+ "[" ^ string_of_name b ^ ":" ^ pp s l ^ "]" ^ pp t (b::l)
+ | C.Appl li ->
+ "(" ^
+ (List.fold_right
+ (fun x i -> pp x l ^ (match i with "" -> "" | _ -> " ") ^ i)
+ li ""
+ ) ^ ")"
+ | C.Const (uri,_) -> UriManager.name_of_uri uri
+ | C.Abst uri -> UriManager.name_of_uri uri
+ | C.MutInd (uri,_,n) ->
+ (match CicCache.get_obj uri with
+ C.InductiveDefinition (dl,_,_) ->
+ let (name,_,_,_) = get_nth dl (n+1) in
+ name
+ | _ -> raise CicPpInternalError
+ )
+ | C.MutConstruct (uri,_,n1,n2) ->
+ (match CicCache.get_obj uri with
+ C.InductiveDefinition (dl,_,_) ->
+ let (_,_,_,cons) = get_nth dl (n1+1) in
+ let (id,_,_) = get_nth cons n2 in
+ id
+ | _ -> raise CicPpInternalError
+ )
+ | C.MutCase (uri,_,n1,ty,te,patterns) ->
+ let connames =
+ (match CicCache.get_obj uri with
+ C.InductiveDefinition (dl,_,_) ->
+ let (_,_,_,cons) = get_nth dl (n1+1) in
+ List.map (fun (id,_,_) -> id) cons
+ | _ -> raise CicPpInternalError
+ )
+ in
+ "\n<" ^ pp ty l ^ ">Cases " ^ pp te l ^ " of " ^
+ List.fold_right (fun (x,y) i -> "\n " ^ x ^ " => " ^ pp y l ^ i)
+ (List.combine connames patterns) "" ^
+ "\nend"
+ | C.Fix (no, funs) ->
+ let snames = List.map (fun (name,_,_,_) -> name) funs in
+ let names = List.rev (List.map (function name -> C.Name name) snames) in
+ "\nFix " ^ get_nth snames (no + 1) ^ " {" ^
+ List.fold_right
+ (fun (name,ind,ty,bo) i -> "\n" ^ name ^ " / " ^ string_of_int ind ^
+ " : " ^ pp ty l ^ " := \n" ^
+ pp bo (names@l) ^ i)
+ funs "" ^
+ "}\n"
+ | C.CoFix (no,funs) ->
+ let snames = List.map (fun (name,_,_) -> name) funs in
+ let names = List.rev (List.map (function name -> C.Name name) snames) in
+ "\nCoFix " ^ get_nth snames (no + 1) ^ " {" ^
+ List.fold_right
+ (fun (name,ty,bo) i -> "\n" ^ name ^
+ " : " ^ pp ty l ^ " := \n" ^
+ pp bo (names@l) ^ i)
+ funs "" ^
+ "}\n"
+;;
+
+(* ppinductiveType (typename, inductive, arity, cons) names *)
+(* pretty-prints a single inductive definition (typename, inductive, arity, *)
+(* cons) where the cic terms in the inductive definition need to be *)
+(* evaluated in the environment names that is the list of typenames of the *)
+(* mutual inductive definitions defined in the block of mutual inductive *)
+(* definitions to which this one belongs to *)
+let ppinductiveType (typename, inductive, arity, cons) names =
+ (if inductive then "\nInductive " else "\nCoInductive ") ^ typename ^ ": " ^
+ (*CSC: bug found: was pp arity names ^ " =\n " ^*)
+ pp arity [] ^ " =\n " ^
+ List.fold_right
+ (fun (id,ty,_) i -> id ^ " : " ^ pp ty names ^
+ (if i = "" then "\n" else "\n | ") ^ i)
+ cons ""
+;;
+
+(* ppobj obj returns a string with describing the cic object obj in a syntax *)
+(* similar to the one used by Coq *)
+let ppobj obj =
+ let module C = Cic in
+ let module U = UriManager in
+ match obj with
+ C.Definition (id, t1, t2, params) ->
+ "Definition of " ^ id ^
+ "(" ^
+ List.fold_right
+ (fun (_,x) i ->
+ List.fold_right
+ (fun x i ->
+ U.string_of_uri x ^ match i with "" -> "" | i' -> " " ^ i'
+ ) x "" ^ match i with "" -> "" | i' -> " " ^ i'
+ ) params "" ^ ")" ^
+ ":\n" ^ pp t1 [] ^ " : " ^ pp t2 []
+ | C.Axiom (id, ty, params) ->
+ "Axiom " ^ id ^ "(" ^
+ List.fold_right
+ (fun (_,x) i ->
+ List.fold_right
+ (fun x i ->
+ U.string_of_uri x ^ match i with "" -> "" | i' -> " " ^ i'
+ ) x "" ^ match i with "" -> "" | i' -> " " ^ i'
+ ) params "" ^
+ "):\n" ^ pp ty []
+ | C.Variable (name, ty) ->
+ "Variable " ^ name ^ ":\n" ^ pp ty []
+ | C.CurrentProof (name, conjectures, value, ty) ->
+ "Current Proof:\n" ^
+ List.fold_right
+ (fun (n, t) i -> "?" ^ (string_of_int n) ^ ": " ^ pp t [] ^ "\n" ^ i)
+ conjectures "" ^
+ "\n" ^ pp value [] ^ " : " ^ pp ty []
+ | C.InductiveDefinition (l, params, nparams) ->
+ "Parameters = " ^
+ List.fold_right
+ (fun (_,x) i ->
+ List.fold_right
+ (fun x i ->
+ U.string_of_uri x ^ match i with "" -> "" | i' -> " " ^ i'
+ ) x "" ^ match i with "" -> "" | i' -> " " ^ i'
+ ) params "" ^ "\n" ^
+ "NParams = " ^ string_of_int nparams ^ "\n" ^
+ let names = List.rev (List.map (fun (n,_,_,_) -> C.Name n) l) in
+ List.fold_right (fun x i -> ppinductiveType x names ^ i) l ""
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 24/01/2000 *)
+(* *)
+(* This module implements a very simple Coq-like pretty printer that, given *)
+(* an object of cic (internal representation) returns a string describing the *)
+(* object in a syntax similar to that of coq *)
+(* *)
+(******************************************************************************)
+
+(* ppobj obj returns a string with describing the cic object obj in a syntax *)
+(* similar to the one used by Coq *)
+val ppobj : Cic.obj -> string
--- /dev/null
+exception CicReductionInternalError;;
+exception WrongUriToInductiveDefinition;;
+
+let fdebug = ref 1;;
+let debug t env s =
+ let rec debug_aux t i =
+ let module C = Cic in
+ let module U = UriManager in
+ CicPp.ppobj (C.Variable ("DEBUG",
+ C.Prod (C.Name "-9", C.Const (U.uri_of_string "cic:/dummy-9",0),
+ C.Prod (C.Name "-8", C.Const (U.uri_of_string "cic:/dummy-8",0),
+ C.Prod (C.Name "-7", C.Const (U.uri_of_string "cic:/dummy-7",0),
+ C.Prod (C.Name "-6", C.Const (U.uri_of_string "cic:/dummy-6",0),
+ C.Prod (C.Name "-5", C.Const (U.uri_of_string "cic:/dummy-5",0),
+ C.Prod (C.Name "-4", C.Const (U.uri_of_string "cic:/dummy-4",0),
+ C.Prod (C.Name "-3", C.Const (U.uri_of_string "cic:/dummy-3",0),
+ C.Prod (C.Name "-2", C.Const (U.uri_of_string "cic:/dummy-2",0),
+ C.Prod (C.Name "-1", C.Const (U.uri_of_string "cic:/dummy-1",0),
+ t
+ )
+ )
+ )
+ )
+ )
+ )
+ )
+ )
+ )
+ )) ^ "\n" ^ i
+ in
+ if !fdebug = 0 then
+ begin
+ print_endline (s ^ "\n" ^ List.fold_right debug_aux (t::env) "") ;
+ flush stdout
+ end
+;;
+
+exception Impossible of int;;
+exception ReferenceToDefinition;;
+exception ReferenceToAxiom;;
+exception ReferenceToVariable;;
+exception ReferenceToCurrentProof;;
+exception ReferenceToInductiveDefinition;;
+
+(* takes a well-typed term *)
+let whd =
+ let rec whdaux l =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ function
+ C.Rel _ as t -> if l = [] then t else C.Appl (t::l)
+ | C.Var _ as t -> if l = [] then t else C.Appl (t::l)
+ | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
+ | C.Sort _ as t -> t (* l should be empty *)
+ | C.Implicit as t -> t
+ | C.Cast (te,ty) -> whdaux l te (*CSC E' GIUSTO BUTTARE IL CAST? *)
+ | C.Prod _ as t -> t (* l should be empty *)
+ | C.Lambda (name,s,t) as t' ->
+ (match l with
+ [] -> t'
+ | he::tl -> whdaux tl (S.subst he t)
+ (* when name is Anonimous the substitution should be superfluous *)
+ )
+ | C.Appl (he::tl) -> whdaux (tl@l) he
+ | C.Appl [] -> raise (Impossible 1)
+ | C.Const (uri,cookingsno) as t ->
+ (match CicCache.get_cooked_obj uri cookingsno with
+ C.Definition (_,body,_,_) -> whdaux l body
+ | C.Axiom _ -> if l = [] then t else C.Appl (t::l)
+ (*CSC: Prossima riga sbagliata: Var punta alle variabili, non Const *)
+ | C.Variable _ -> if l = [] then t else C.Appl (t::l)
+ | C.CurrentProof (_,_,body,_) -> whdaux l body
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ | C.Abst _ as t -> t (*CSC l should be empty ????? *)
+ | C.MutInd (uri,_,_) as t -> if l = [] then t else C.Appl (t::l)
+ | C.MutConstruct (uri,_,_,_) as t -> if l = [] then t else C.Appl (t::l)
+ | C.MutCase (mutind,cookingsno,i,_,term,pl) as t ->
+ let decofix =
+ function
+ C.CoFix (i,fl) as t ->
+ let (_,_,body) = List.nth fl i in
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
+ fl
+ body
+ in
+ whdaux [] body'
+ | C.Appl (C.CoFix (i,fl) :: tl) ->
+ let (_,_,body) = List.nth fl i in
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
+ fl
+ body
+ in
+ whdaux tl body'
+ | t -> t
+ in
+ (match decofix (whdaux [] term) with
+ C.MutConstruct (_,_,_,j) -> whdaux l (List.nth pl (j-1))
+ | C.Appl (C.MutConstruct (_,_,_,j) :: tl) ->
+ let (arity, r, num_ingredients) =
+ match CicCache.get_obj mutind with
+ C.InductiveDefinition (tl,ingredients,r) ->
+ let (_,_,arity,_) = List.nth tl i
+ and num_ingredients =
+ List.fold_right
+ (fun (k,l) i ->
+ if k < cookingsno then i + List.length l else i
+ ) ingredients 0
+ in
+ (arity,r,num_ingredients)
+ | _ -> raise WrongUriToInductiveDefinition
+ in
+ let ts =
+ let num_to_eat = r + num_ingredients in
+ let rec eat_first =
+ function
+ (0,l) -> l
+ | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
+ | _ -> raise (Impossible 5)
+ in
+ eat_first (num_to_eat,tl)
+ in
+ whdaux (ts@l) (List.nth pl (j-1))
+ | C.Abst _| C.Cast _ | C.Implicit ->
+ raise (Impossible 2) (* we don't trust our whd ;-) *)
+ | _ -> t
+ )
+ | C.Fix (i,fl) as t ->
+ let (_,recindex,_,body) = List.nth fl i in
+ let recparam =
+ try
+ Some (List.nth l recindex)
+ with
+ _ -> None
+ in
+ (match recparam with
+ Some recparam ->
+ (match whdaux [] recparam with
+ C.MutConstruct _
+ | C.Appl ((C.MutConstruct _)::_) ->
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
+ fl
+ body
+ in
+ (* Possible optimization: substituting whd recparam in l *)
+ whdaux l body'
+ | _ -> if l = [] then t else C.Appl (t::l)
+ )
+ | None -> if l = [] then t else C.Appl (t::l)
+ )
+ | C.CoFix (i,fl) as t ->
+ (*CSC vecchio codice
+ let (_,_,body) = List.nth fl i in
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
+ fl
+ body
+ in
+ whdaux l body'
+ *)
+ if l = [] then t else C.Appl (t::l)
+ in
+ whdaux []
+;;
+
+(* t1, t2 must be well-typed *)
+let are_convertible t1 t2 =
+ let module U = UriManager in
+ let rec aux t1 t2 =
+ debug t1 [t2] "PREWHD";
+ (* this trivial euristic cuts down the total time of about five times ;-) *)
+ (* this because most of the time t1 and t2 are "sintactically" the same *)
+ if t1 = t2 then
+ true
+ else
+ begin
+ let module C = Cic in
+ let t1' = whd t1
+ and t2' = whd t2 in
+ debug t1' [t2'] "POSTWHD";
+ (*if !fdebug = 0 then ignore(Unix.system "read" );*)
+ match (t1',t2') with
+ (C.Rel n1, C.Rel n2) -> n1 = n2
+ | (C.Var uri1, C.Var uri2) -> U.eq uri1 uri2
+ | (C.Meta n1, C.Meta n2) -> n1 = n2
+ | (C.Sort s1, C.Sort s2) -> true (*CSC da finire con gli universi *)
+ | (C.Prod (_,s1,t1), C.Prod(_,s2,t2)) ->
+ aux s1 s2 && aux t1 t2
+ | (C.Lambda (_,s1,t1), C.Lambda(_,s2,t2)) ->
+ aux s1 s2 && aux t1 t2
+ | (C.Appl l1, C.Appl l2) ->
+ (try
+ List.fold_right2 (fun x y b -> aux x y && b) l1 l2 true
+ with
+ Invalid_argument _ -> false
+ )
+ | (C.Const (uri1,_), C.Const (uri2,_)) ->
+ (*CSC: questo commento e' chiaro o delirante? Io lo sto scrivendo *)
+ (*CSC: mentre sono delirante, quindi ... *)
+ (* WARNING: it is really important that the two cookingsno are not *)
+ (* checked for equality. This allows not to cook an object with no *)
+ (* ingredients only to update the cookingsno. E.g: if a term t has *)
+ (* a reference to a term t1 which does not depend on any variable *)
+ (* and t1 depends on a term t2 (that can't depend on any variable *)
+ (* because of t1), then t1 cooked at every level could be the same *)
+ (* as t1 cooked at level 0. Doing so, t2 will be extended in t *)
+ (* with cookingsno 0 and not 2. But this will not cause any trouble*)
+ (* if here we don't check that the two cookingsno are equal. *)
+ U.eq uri1 uri2
+ | (C.MutInd (uri1,k1,i1), C.MutInd (uri2,k2,i2)) ->
+ (* WARNIG: see the previous warning *)
+ U.eq uri1 uri2 && i1 = i2
+ | (C.MutConstruct (uri1,_,i1,j1), C.MutConstruct (uri2,_,i2,j2)) ->
+ (* WARNIG: see the previous warning *)
+ U.eq uri1 uri2 && i1 = i2 && j1 = j2
+ | (C.MutCase (uri1,_,i1,outtype1,term1,pl1),
+ C.MutCase (uri2,_,i2,outtype2,term2,pl2)) ->
+ (* WARNIG: see the previous warning *)
+ (* aux outtype1 outtype2 should be true if aux pl1 pl2 *)
+ U.eq uri1 uri2 && i1 = i2 && aux outtype1 outtype2 &&
+ aux term1 term2 &&
+ List.fold_right2 (fun x y b -> b && aux x y) pl1 pl2 true
+ | (C.Fix (i1,fl1), C.Fix (i2,fl2)) ->
+ i1 = i2 &&
+ List.fold_right2
+ (fun (_,recindex1,ty1,bo1) (_,recindex2,ty2,bo2) b ->
+ b && recindex1 = recindex2 && aux ty1 ty2 && aux bo1 bo2)
+ fl1 fl2 true
+ | (C.CoFix (i1,fl1), C.CoFix (i2,fl2)) ->
+ i1 = i2 &&
+ List.fold_right2
+ (fun (_,ty1,bo1) (_,ty2,bo2) b ->
+ b && aux ty1 ty2 && aux bo1 bo2)
+ fl1 fl2 true
+ | (C.Abst _, _) | (_, C.Abst _) | (C.Cast _, _) | (_, C.Cast _)
+ | (C.Implicit, _) | (_, C.Implicit) ->
+ raise (Impossible 3) (* we don't trust our whd ;-) *)
+ | (_,_) -> false
+ end
+ in
+ aux t1 t2
+;;
--- /dev/null
+exception WrongUriToInductiveDefinition
+exception ReferenceToDefinition
+exception ReferenceToAxiom
+exception ReferenceToVariable
+exception ReferenceToCurrentProof
+exception ReferenceToInductiveDefinition
+val fdebug : int ref
+val whd : Cic.term -> Cic.term
+val are_convertible : Cic.term -> Cic.term -> bool
--- /dev/null
+let lift n =
+ let rec liftaux k =
+ let module C = Cic in
+ function
+ C.Rel m ->
+ if m < k then
+ C.Rel m
+ else
+ C.Rel (m + n)
+ | C.Var _ as t -> t
+ | C.Meta _ as t -> t
+ | C.Sort _ as t -> t
+ | C.Implicit as t -> t
+ | C.Cast (te,ty) -> C.Cast (liftaux k te, liftaux k ty)
+ | C.Prod (n,s,t) -> C.Prod (n, liftaux k s, liftaux (k+1) t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, liftaux k s, liftaux (k+1) t)
+ | C.Appl l -> C.Appl (List.map (liftaux k) l)
+ | C.Const _ as t -> t
+ | C.Abst _ as t -> t
+ | C.MutInd _ as t -> t
+ | C.MutConstruct _ as t -> t
+ | C.MutCase (sp,cookingsno,i,outty,t,pl) ->
+ C.MutCase (sp, cookingsno, i, liftaux k outty, liftaux k t,
+ List.map (liftaux k) pl)
+ | C.Fix (i, fl) ->
+ let len = List.length fl in
+ let liftedfl =
+ List.map
+ (fun (name, i, ty, bo) -> (name, i, liftaux k ty, liftaux (k+len) bo))
+ fl
+ in
+ C.Fix (i, liftedfl)
+ | C.CoFix (i, fl) ->
+ let len = List.length fl in
+ let liftedfl =
+ List.map
+ (fun (name, ty, bo) -> (name, liftaux k ty, liftaux (k+len) bo))
+ fl
+ in
+ C.CoFix (i, liftedfl)
+ in
+ liftaux 1
+;;
+
+let subst arg =
+ let rec substaux k =
+ let module C = Cic in
+ function
+ C.Rel n as t ->
+ (match n with
+ n when n = k -> lift (k - 1) arg
+ | n when n < k -> t
+ | _ -> C.Rel (n - 1)
+ )
+ | C.Var _ as t -> t
+ | C.Meta _ as t -> t
+ | C.Sort _ as t -> t
+ | C.Implicit as t -> t
+ | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty) (*CSC ??? *)
+ | C.Prod (n,s,t) -> C.Prod (n, substaux k s, substaux (k + 1) t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, substaux k s, substaux (k + 1) t)
+ | C.Appl l -> C.Appl (List.map (substaux k) l)
+ | C.Const _ as t -> t
+ | C.Abst _ as t -> t
+ | C.MutInd _ as t -> t
+ | C.MutConstruct _ as t -> t
+ | C.MutCase (sp,cookingsno,i,outt,t,pl) ->
+ C.MutCase (sp,cookingsno,i,substaux k outt, substaux k t,
+ List.map (substaux k) pl)
+ | C.Fix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) -> (name, i, substaux k ty, substaux (k+len) bo))
+ fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) -> (name, substaux k ty, substaux (k+len) bo))
+ fl
+ in
+ C.CoFix (i, substitutedfl)
+ in
+ substaux 1
+;;
+
+let undebrujin_inductive_def uri =
+ function
+ Cic.InductiveDefinition (dl,params,n_ind_params) ->
+ let dl' =
+ List.map
+ (fun (name,inductive,arity,constructors) ->
+ let constructors' =
+ List.map
+ (fun (name,ty,r) ->
+ let ty' =
+ let counter = ref (List.length dl) in
+ List.fold_right
+ (fun _ ->
+ decr counter ;
+ subst (Cic.MutInd (uri,0,!counter))
+ ) dl ty
+ in
+ (name,ty',r)
+ ) constructors
+ in
+ (name,inductive,arity,constructors')
+ ) dl
+ in
+ Cic.InductiveDefinition (dl', params, n_ind_params)
+ | obj -> obj
+;;
--- /dev/null
+val lift : int -> Cic.term -> Cic.term
+val subst : Cic.term -> Cic.term -> Cic.term
+val undebrujin_inductive_def : UriManager.uri -> Cic.obj -> Cic.obj
--- /dev/null
+exception NotImplemented;;
+exception Impossible;;
+exception NotWellTyped of string;;
+exception WrongUriToConstant of string;;
+exception WrongUriToVariable of string;;
+exception WrongUriToMutualInductiveDefinitions of string;;
+exception ListTooShort;;
+exception NotPositiveOccurrences of string;;
+exception NotWellFormedTypeOfInductiveConstructor of string;;
+exception WrongRequiredArgument of string;;
+
+let fdebug = ref 0;;
+let debug t env =
+ let rec debug_aux t i =
+ let module C = Cic in
+ let module U = UriManager in
+ CicPp.ppobj (C.Variable ("DEBUG",
+ C.Prod (C.Name "-15", C.Const (U.uri_of_string "cic:/dummy-15",0),
+ C.Prod (C.Name "-14", C.Const (U.uri_of_string "cic:/dummy-14",0),
+ C.Prod (C.Name "-13", C.Const (U.uri_of_string "cic:/dummy-13",0),
+ C.Prod (C.Name "-12", C.Const (U.uri_of_string "cic:/dummy-12",0),
+ C.Prod (C.Name "-11", C.Const (U.uri_of_string "cic:/dummy-11",0),
+ C.Prod (C.Name "-10", C.Const (U.uri_of_string "cic:/dummy-10",0),
+ C.Prod (C.Name "-9", C.Const (U.uri_of_string "cic:/dummy-9",0),
+ C.Prod (C.Name "-8", C.Const (U.uri_of_string "cic:/dummy-8",0),
+ C.Prod (C.Name "-7", C.Const (U.uri_of_string "cic:/dummy-7",0),
+ C.Prod (C.Name "-6", C.Const (U.uri_of_string "cic:/dummy-6",0),
+ C.Prod (C.Name "-5", C.Const (U.uri_of_string "cic:/dummy-5",0),
+ C.Prod (C.Name "-4", C.Const (U.uri_of_string "cic:/dummy-4",0),
+ C.Prod (C.Name "-3", C.Const (U.uri_of_string "cic:/dummy-3",0),
+ C.Prod (C.Name "-2", C.Const (U.uri_of_string "cic:/dummy-2",0),
+ C.Prod (C.Name "-1", C.Const (U.uri_of_string "cic:/dummy-1",0),
+ t
+ )
+ )
+ )
+ )
+ )
+ )
+ )
+ )
+ )))))))
+ )) ^ "\n" ^ i
+ in
+ if !fdebug = 0 then
+ raise (NotWellTyped ("\n" ^ List.fold_right debug_aux (t::env) ""))
+ (*print_endline ("\n" ^ List.fold_right debug_aux (t::env) "") ; flush stdout*)
+;;
+
+let rec split l n =
+ match (l,n) with
+ (l,0) -> ([], l)
+ | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2)
+ | (_,_) -> raise ListTooShort
+;;
+
+exception CicCacheError;;
+
+let rec cooked_type_of_constant uri cookingsno =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let cobj =
+ match CicCache.is_type_checked uri cookingsno with
+ CicCache.CheckedObj cobj -> cobj
+ | CicCache.UncheckedObj uobj ->
+ (* let's typecheck the uncooked obj *)
+ (match uobj with
+ C.Definition (_,te,ty,_) ->
+ let _ = type_of ty in
+ if not (R.are_convertible (type_of te) ty) then
+ raise (NotWellTyped ("Constant " ^ (U.string_of_uri uri)))
+ | C.Axiom (_,ty,_) ->
+ (* only to check that ty is well-typed *)
+ let _ = type_of ty in ()
+ | C.CurrentProof (_,_,te,ty) ->
+ let _ = type_of ty in
+ if not (R.are_convertible (type_of te) ty) then
+ raise (NotWellTyped ("CurrentProof" ^ (U.string_of_uri uri)))
+ | _ -> raise (WrongUriToConstant (U.string_of_uri uri))
+ ) ;
+ CicCache.set_type_checking_info uri ;
+ match CicCache.is_type_checked uri cookingsno with
+ CicCache.CheckedObj cobj -> cobj
+ | CicCache.UncheckedObj _ -> raise CicCacheError
+ in
+ match cobj with
+ C.Definition (_,_,ty,_) -> ty
+ | C.Axiom (_,ty,_) -> ty
+ | C.CurrentProof (_,_,_,ty) -> ty
+ | _ -> raise (WrongUriToConstant (U.string_of_uri uri))
+
+and type_of_variable uri =
+ let module C = Cic in
+ let module R = CicReduction in
+ (* 0 because a variable is never cooked => no partial cooking at one level *)
+ match CicCache.is_type_checked uri 0 with
+ CicCache.CheckedObj (C.Variable (_,ty)) -> ty
+ | CicCache.UncheckedObj (C.Variable (_,ty)) ->
+ (* only to check that ty is well-typed *)
+ let _ = type_of ty in
+ CicCache.set_type_checking_info uri ;
+ ty
+ | _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri))
+
+and does_not_occur n nn te =
+ let module C = Cic in
+ (*CSC: whd sembra essere superflua perche' un caso in cui l'occorrenza *)
+ (*CSC: venga mangiata durante la whd sembra presentare problemi di *)
+ (*CSC: universi *)
+ match CicReduction.whd te with
+ C.Rel m when m > n && m <= nn -> false
+ | C.Rel _
+ | C.Var _
+ | C.Meta _
+ | C.Sort _
+ | C.Implicit -> true
+ | C.Cast (te,ty) -> does_not_occur n nn te && does_not_occur n nn ty
+ | C.Prod (_,so,dest) ->
+ does_not_occur n nn so && does_not_occur (n + 1) (nn + 1) dest
+ | C.Lambda (_,so,dest) ->
+ does_not_occur n nn so && does_not_occur (n + 1) (nn + 1) dest
+ | C.Appl l ->
+ List.fold_right (fun x i -> i && does_not_occur n nn x) l true
+ | C.Const _
+ | C.Abst _
+ | C.MutInd _
+ | C.MutConstruct _ -> true
+ | C.MutCase (_,_,_,out,te,pl) ->
+ does_not_occur n nn out && does_not_occur n nn te &&
+ List.fold_right (fun x i -> i && does_not_occur n nn x) pl true
+ | C.Fix (_,fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len in
+ let nn_plus_len = nn + len in
+ List.fold_right
+ (fun (_,_,ty,bo) i ->
+ i && does_not_occur n_plus_len nn_plus_len ty &&
+ does_not_occur n_plus_len nn_plus_len bo
+ ) fl true
+ | C.CoFix (_,fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len in
+ let nn_plus_len = nn + len in
+ List.fold_right
+ (fun (_,ty,bo) i ->
+ i && does_not_occur n_plus_len nn_plus_len ty &&
+ does_not_occur n_plus_len nn_plus_len bo
+ ) fl true
+
+(*CSC l'indice x dei tipi induttivi e' t.c. n < x <= nn *)
+(*CSC questa funzione e' simile alla are_all_occurrences_positive, ma fa *)
+(*CSC dei controlli leggermente diversi. Viene invocata solamente dalla *)
+(*CSC strictly_positive *)
+(*CSC definizione (giusta???) tratta dalla mail di Hugo ;-) *)
+and weakly_positive n nn uri te =
+ let module C = Cic in
+ (*CSC mettere in cicSubstitution *)
+ let rec subst_inductive_type_with_dummy_rel =
+ function
+ C.MutInd (uri',_,0) when UriManager.eq uri' uri ->
+ C.Rel 0 (* dummy rel *)
+ | C.Appl ((C.MutInd (uri',_,0))::tl) when UriManager.eq uri' uri ->
+ C.Rel 0 (* dummy rel *)
+ | C.Cast (te,ty) -> subst_inductive_type_with_dummy_rel te
+ | C.Prod (name,so,ta) ->
+ C.Prod (name, subst_inductive_type_with_dummy_rel so,
+ subst_inductive_type_with_dummy_rel ta)
+ | C.Lambda (name,so,ta) ->
+ C.Lambda (name, subst_inductive_type_with_dummy_rel so,
+ subst_inductive_type_with_dummy_rel ta)
+ | C.Appl tl ->
+ C.Appl (List.map subst_inductive_type_with_dummy_rel tl)
+ | C.MutCase (uri,cookingsno,i,outtype,term,pl) ->
+ C.MutCase (uri,cookingsno,i,
+ subst_inductive_type_with_dummy_rel outtype,
+ subst_inductive_type_with_dummy_rel term,
+ List.map subst_inductive_type_with_dummy_rel pl)
+ | C.Fix (i,fl) ->
+ C.Fix (i,List.map (fun (name,i,ty,bo) -> (name,i,
+ subst_inductive_type_with_dummy_rel ty,
+ subst_inductive_type_with_dummy_rel bo)) fl)
+ | C.CoFix (i,fl) ->
+ C.CoFix (i,List.map (fun (name,ty,bo) -> (name,
+ subst_inductive_type_with_dummy_rel ty,
+ subst_inductive_type_with_dummy_rel bo)) fl)
+ | t -> t
+ in
+ match CicReduction.whd te with
+ C.Appl ((C.MutInd (uri',_,0))::tl) when UriManager.eq uri' uri -> true
+ | C.MutInd (uri',_,0) when UriManager.eq uri' uri -> true
+ | C.Prod (C.Anonimous,source,dest) ->
+ strictly_positive n nn (subst_inductive_type_with_dummy_rel source) &&
+ weakly_positive (n + 1) (nn + 1) uri dest
+ | C.Prod (name,source,dest) when does_not_occur 0 n dest ->
+ (* dummy abstraction, so we behave as in the anonimous case *)
+ strictly_positive n nn (subst_inductive_type_with_dummy_rel source) &&
+ weakly_positive (n + 1) (nn + 1) uri dest
+ | C.Prod (_,source,dest) ->
+ does_not_occur n nn (subst_inductive_type_with_dummy_rel source) &&
+ weakly_positive (n + 1) (nn + 1) uri dest
+ | _ -> raise (NotWellFormedTypeOfInductiveConstructor ("Guess where the error is ;-)"))
+
+(* instantiate_parameters ps (x1:T1)...(xn:Tn)C *)
+(* returns ((x_|ps|:T_|ps|)...(xn:Tn)C){ps_1 / x1 ; ... ; ps_|ps| / x_|ps|} *)
+and instantiate_parameters params c =
+ let module C = Cic in
+ match (c,params) with
+ (c,[]) -> c
+ | (C.Prod (_,_,ta), he::tl) ->
+ instantiate_parameters tl
+ (CicSubstitution.subst he ta)
+ | (C.Cast (te,_), _) -> instantiate_parameters params te
+ | (t,l) -> raise Impossible
+
+and strictly_positive n nn te =
+ let module C = Cic in
+ let module U = UriManager in
+ match CicReduction.whd te with
+ C.Rel _ -> true
+ | C.Cast (te,ty) ->
+ (*CSC: bisogna controllare ty????*)
+ strictly_positive n nn te
+ | C.Prod (_,so,ta) ->
+ does_not_occur n nn so &&
+ strictly_positive (n+1) (nn+1) ta
+ | C.Appl ((C.Rel m)::tl) when m > n && m <= nn ->
+ List.fold_right (fun x i -> i && does_not_occur n nn x) tl true
+ | C.Appl ((C.MutInd (uri,_,i))::tl) ->
+ let (ok,paramsno,cl) =
+ match CicCache.get_obj uri with
+ C.InductiveDefinition (tl,_,paramsno) ->
+ let (_,_,_,cl) = List.nth tl i in
+ (List.length tl = 1, paramsno, cl)
+ | _ -> raise(WrongUriToMutualInductiveDefinitions(U.string_of_uri uri))
+ in
+ let (params,arguments) = split tl paramsno in
+ let lifted_params = List.map (CicSubstitution.lift 1) params in
+ let cl' =
+ List.map (fun (_,te,_) -> instantiate_parameters lifted_params te) cl
+ in
+ ok &&
+ List.fold_right
+ (fun x i -> i && does_not_occur n nn x)
+ arguments true &&
+ (*CSC: MEGAPATCH3 (sara' quella giusta?)*)
+ List.fold_right
+ (fun x i ->
+ i &&
+ weakly_positive (n+1) (nn+1) uri x
+ ) cl' true
+ | C.MutInd (uri,_,i) ->
+ (match CicCache.get_obj uri with
+ C.InductiveDefinition (tl,_,_) ->
+ List.length tl = 1
+ | _ -> raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri))
+ )
+ | t -> does_not_occur n nn t
+
+(*CSC l'indice x dei tipi induttivi e' t.c. n < x <= nn *)
+and are_all_occurrences_positive uri indparamsno i n nn te =
+ let module C = Cic in
+ match CicReduction.whd te with
+ C.Appl ((C.Rel m)::tl) when m = i ->
+ (*CSC: riscrivere fermandosi a 0 *)
+ (* let's check if the inductive type is applied at least to *)
+ (* indparamsno parameters *)
+ let last =
+ List.fold_left
+ (fun k x ->
+ if k = 0 then 0
+ else
+ match CicReduction.whd x with
+ C.Rel m when m = n - (indparamsno - k) -> k - 1
+ | _ -> raise (WrongRequiredArgument (UriManager.string_of_uri uri))
+ ) indparamsno tl
+ in
+ if last = 0 then
+ List.fold_right (fun x i -> i && does_not_occur n nn x) tl true
+ else
+ raise (WrongRequiredArgument (UriManager.string_of_uri uri))
+ | C.Rel m when m = i ->
+ if indparamsno = 0 then
+ true
+ else
+ raise (WrongRequiredArgument (UriManager.string_of_uri uri))
+ | C.Prod (C.Anonimous,source,dest) ->
+ strictly_positive n nn source &&
+ are_all_occurrences_positive uri indparamsno (i+1) (n + 1) (nn + 1) dest
+ | C.Prod (name,source,dest) when does_not_occur 0 n dest ->
+ (* dummy abstraction, so we behave as in the anonimous case *)
+ strictly_positive n nn source &&
+ are_all_occurrences_positive uri indparamsno (i+1) (n + 1) (nn + 1) dest
+ | C.Prod (_,source,dest) ->
+ does_not_occur n nn source &&
+ are_all_occurrences_positive uri indparamsno (i+1) (n + 1) (nn + 1) dest
+ | _ -> raise (NotWellFormedTypeOfInductiveConstructor (UriManager.string_of_uri uri))
+
+(*CSC: cambiare il nome, torna unit! *)
+and cooked_mutual_inductive_defs uri =
+ let module U = UriManager in
+ function
+ Cic.InductiveDefinition (itl, _, indparamsno) ->
+ (* let's check if the arity of the inductive types are well *)
+ (* formed *)
+ List.iter (fun (_,_,x,_) -> let _ = type_of x in ()) itl ;
+
+ (* let's check if the types of the inductive constructors *)
+ (* are well formed. *)
+ (* In order not to use type_of_aux we put the types of the *)
+ (* mutual inductive types at the head of the types of the *)
+ (* constructors using Prods *)
+ (*CSC: piccola??? inefficienza *)
+ let len = List.length itl in
+ let _ =
+ List.fold_right
+ (fun (_,_,_,cl) i ->
+ List.iter
+ (fun (name,te,r) ->
+ let augmented_term =
+ List.fold_right
+ (fun (name,_,ty,_) i -> Cic.Prod (Cic.Name name, ty, i))
+ itl te
+ in
+ let _ = type_of augmented_term in
+ (* let's check also the positivity conditions *)
+ if not (are_all_occurrences_positive uri indparamsno i 0 len te)
+ then
+ raise (NotPositiveOccurrences (U.string_of_uri uri))
+ else
+ match !r with
+ Some _ -> raise Impossible
+ | None -> r := Some (recursive_args 0 len te)
+ ) cl ;
+ (i + 1)
+ ) itl 1
+ in
+ ()
+ | _ ->
+ raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+
+and cooked_type_of_mutual_inductive_defs uri cookingsno i =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let cobj =
+ match CicCache.is_type_checked uri cookingsno with
+ CicCache.CheckedObj cobj -> cobj
+ | CicCache.UncheckedObj uobj ->
+ cooked_mutual_inductive_defs uri uobj ;
+ CicCache.set_type_checking_info uri ;
+ (match CicCache.is_type_checked uri cookingsno with
+ CicCache.CheckedObj cobj -> cobj
+ | CicCache.UncheckedObj _ -> raise CicCacheError
+ )
+ in
+ match cobj with
+ C.InductiveDefinition (dl,_,_) ->
+ let (_,_,arity,_) = List.nth dl i in
+ arity
+ | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+
+and cooked_type_of_mutual_inductive_constr uri cookingsno i j =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let cobj =
+ match CicCache.is_type_checked uri cookingsno with
+ CicCache.CheckedObj cobj -> cobj
+ | CicCache.UncheckedObj uobj ->
+ cooked_mutual_inductive_defs uri uobj ;
+ CicCache.set_type_checking_info uri ;
+ (match CicCache.is_type_checked uri cookingsno with
+ CicCache.CheckedObj cobj -> cobj
+ | CicCache.UncheckedObj _ -> raise CicCacheError
+ )
+ in
+ match cobj with
+ C.InductiveDefinition (dl,_,_) ->
+ let (_,_,_,cl) = List.nth dl i in
+ let (_,ty,_) = List.nth cl (j-1) in
+ ty
+ | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+
+and recursive_args n nn te =
+ let module C = Cic in
+ match CicReduction.whd te with
+ C.Rel _ -> []
+ | C.Var _
+ | C.Meta _
+ | C.Sort _
+ | C.Implicit
+ | C.Cast _ (*CSC ??? *) -> raise Impossible (* due to type-checking *)
+ | C.Prod (_,so,de) ->
+ (not (does_not_occur n nn so))::(recursive_args (n+1) (nn + 1) de)
+ | C.Lambda _ -> raise Impossible (* due to type-checking *)
+ | C.Appl _ -> []
+ | C.Const _
+ | C.Abst _ -> raise Impossible
+ | C.MutInd _
+ | C.MutConstruct _
+ | C.MutCase _
+ | C.Fix _
+ | C.CoFix _ -> raise Impossible (* due to type-checking *)
+
+and get_new_safes p c rl safes n nn x =
+ let module C = Cic in
+ let module U = UriManager in
+ let module R = CicReduction in
+ match (R.whd c, R.whd p, rl) with
+ (C.Prod (_,_,ta1), C.Lambda (_,_,ta2), b::tl) ->
+ (* we are sure that the two sources are convertible because we *)
+ (* have just checked this. So let's go along ... *)
+ let safes' =
+ List.map (fun x -> x + 1) safes
+ in
+ let safes'' =
+ if b then 1::safes' else safes'
+ in
+ get_new_safes ta2 ta1 tl safes'' (n+1) (nn+1) (x+1)
+ | (C.MutInd _, e, []) -> (e,safes,n,nn,x)
+ | (C.Appl _, e, []) -> (e,safes,n,nn,x)
+ | (_,_,_) -> raise Impossible
+
+and eat_prods n te =
+ let module C = Cic in
+ let module R = CicReduction in
+ match (n, R.whd te) with
+ (0, _) -> te
+ | (n, C.Prod (_,_,ta)) when n > 0 -> eat_prods (n - 1) ta
+ | (_, _) -> raise Impossible
+
+and eat_lambdas n te =
+ let module C = Cic in
+ let module R = CicReduction in
+ match (n, R.whd te) with
+ (0, _) -> (te, 0)
+ | (n, C.Lambda (_,_,ta)) when n > 0 ->
+ let (te, k) = eat_lambdas (n - 1) ta in
+ (te, k + 1)
+ | (_, _) -> raise Impossible
+
+(*CSC: Tutto quello che segue e' l'intuzione di luca ;-) *)
+and check_is_really_smaller_arg n nn kl x safes te =
+ (*CSC: forse la whd si puo' fare solo quando serve veramente. *)
+ (*CSC: cfr guarded_by_destructors *)
+ let module C = Cic in
+ let module U = UriManager in
+ match CicReduction.whd te with
+ C.Rel m when List.mem m safes -> true
+ | C.Rel _ -> false
+ | C.Var _
+ | C.Meta _
+ | C.Sort _
+ | C.Implicit
+ | C.Cast _
+(* | C.Cast (te,ty) ->
+ check_is_really_smaller_arg n nn kl x safes te &&
+ check_is_really_smaller_arg n nn kl x safes ty*)
+(* | C.Prod (_,so,ta) ->
+ check_is_really_smaller_arg n nn kl x safes so &&
+ check_is_really_smaller_arg (n+1) (nn+1) kl (x+1)
+ (List.map (fun x -> x + 1) safes) ta*)
+ | C.Prod _ -> raise Impossible
+ | C.Lambda (_,so,ta) ->
+ check_is_really_smaller_arg n nn kl x safes so &&
+ check_is_really_smaller_arg (n+1) (nn+1) kl (x+1)
+ (List.map (fun x -> x + 1) safes) ta
+ | C.Appl (he::_) ->
+ (*CSC: sulla coda ci vogliono dei controlli? secondo noi no, ma *)
+ (*CSC: solo perche' non abbiamo trovato controesempi *)
+ check_is_really_smaller_arg n nn kl x safes he
+ | C.Appl [] -> raise Impossible
+ | C.Const _
+ | C.Abst _
+ | C.MutInd _ -> raise Impossible
+ | C.MutConstruct _ -> false
+ | C.MutCase (uri,_,i,outtype,term,pl) ->
+ (match term with
+ C.Rel m when List.mem m safes || m = x ->
+ let (isinductive,paramsno,cl) =
+ match CicCache.get_obj uri with
+ C.InductiveDefinition (tl,_,paramsno) ->
+ let (_,isinductive,_,cl) = List.nth tl i in
+ let cl' =
+ List.map (fun (id,ty,r) -> (id, eat_prods paramsno ty, r)) cl
+ in
+ (isinductive,paramsno,cl')
+ | _ ->
+ raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri))
+ in
+ if not isinductive then
+ List.fold_right
+ (fun p i -> i && check_is_really_smaller_arg n nn kl x safes p)
+ pl true
+ else
+ List.fold_right
+ (fun (p,(_,c,rl)) i ->
+ let rl' =
+ match !rl with
+ Some rl' ->
+ let (_,rl'') = split rl' paramsno in
+ rl''
+ | None -> raise Impossible
+ in
+ let (e,safes',n',nn',x') =
+ get_new_safes p c rl' safes n nn x
+ in
+ i &&
+ check_is_really_smaller_arg n' nn' kl x' safes' e
+ ) (List.combine pl cl) true
+ | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x ->
+ let (isinductive,paramsno,cl) =
+ match CicCache.get_obj uri with
+ C.InductiveDefinition (tl,_,paramsno) ->
+ let (_,isinductive,_,cl) = List.nth tl i in
+ let cl' =
+ List.map (fun (id,ty,r) -> (id, eat_prods paramsno ty, r)) cl
+ in
+ (isinductive,paramsno,cl')
+ | _ ->
+ raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri))
+ in
+ if not isinductive then
+ List.fold_right
+ (fun p i -> i && check_is_really_smaller_arg n nn kl x safes p)
+ pl true
+ else
+ (*CSC: supponiamo come prima che nessun controllo sia necessario*)
+ (*CSC: sugli argomenti di una applicazione *)
+ List.fold_right
+ (fun (p,(_,c,rl)) i ->
+ let rl' =
+ match !rl with
+ Some rl' ->
+ let (_,rl'') = split rl' paramsno in
+ rl''
+ | None -> raise Impossible
+ in
+ let (e, safes',n',nn',x') =
+ get_new_safes p c rl' safes n nn x
+ in
+ i &&
+ check_is_really_smaller_arg n' nn' kl x' safes' e
+ ) (List.combine pl cl) true
+ | _ ->
+ List.fold_right
+ (fun p i -> i && check_is_really_smaller_arg n nn kl x safes p)
+ pl true
+ )
+ | C.Fix (_, fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len
+ and nn_plus_len = nn + len
+ and x_plus_len = x + len
+ and safes' = List.map (fun x -> x + len) safes in
+ List.fold_right
+ (fun (_,_,ty,bo) i ->
+ i &&
+ check_is_really_smaller_arg n_plus_len nn_plus_len kl x_plus_len
+ safes' bo
+ ) fl true
+ | C.CoFix (_, fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len
+ and nn_plus_len = nn + len
+ and x_plus_len = x + len
+ and safes' = List.map (fun x -> x + len) safes in
+ List.fold_right
+ (fun (_,ty,bo) i ->
+ i &&
+ check_is_really_smaller_arg n_plus_len nn_plus_len kl x_plus_len
+ safes' bo
+ ) fl true
+
+and guarded_by_destructors n nn kl x safes =
+ let module C = Cic in
+ let module U = UriManager in
+ function
+ C.Rel m when m > n && m <= nn -> false
+ | C.Rel _
+ | C.Var _
+ | C.Meta _
+ | C.Sort _
+ | C.Implicit -> true
+ | C.Cast (te,ty) ->
+ guarded_by_destructors n nn kl x safes te &&
+ guarded_by_destructors n nn kl x safes ty
+ | C.Prod (_,so,ta) ->
+ guarded_by_destructors n nn kl x safes so &&
+ guarded_by_destructors (n+1) (nn+1) kl (x+1)
+ (List.map (fun x -> x + 1) safes) ta
+ | C.Lambda (_,so,ta) ->
+ guarded_by_destructors n nn kl x safes so &&
+ guarded_by_destructors (n+1) (nn+1) kl (x+1)
+ (List.map (fun x -> x + 1) safes) ta
+ | C.Appl ((C.Rel m)::tl) when m > n && m <= nn ->
+ let k = List.nth kl (m - n - 1) in
+ if not (List.length tl > k) then false
+ else
+ List.fold_right
+ (fun param i ->
+ i && guarded_by_destructors n nn kl x safes param
+ ) tl true &&
+ check_is_really_smaller_arg n nn kl x safes (List.nth tl k)
+ | C.Appl tl ->
+ List.fold_right (fun t i -> i && guarded_by_destructors n nn kl x safes t)
+ tl true
+ | C.Const _
+ | C.Abst _
+ | C.MutInd _
+ | C.MutConstruct _ -> true
+ | C.MutCase (uri,_,i,outtype,term,pl) ->
+ (match term with
+ C.Rel m when List.mem m safes || m = x ->
+ let (isinductive,paramsno,cl) =
+ match CicCache.get_obj uri with
+ C.InductiveDefinition (tl,_,paramsno) ->
+ let (_,isinductive,_,cl) = List.nth tl i in
+ let cl' =
+ List.map (fun (id,ty,r) -> (id, eat_prods paramsno ty, r)) cl
+ in
+ (isinductive,paramsno,cl')
+ | _ ->
+ raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri))
+ in
+ if not isinductive then
+ guarded_by_destructors n nn kl x safes outtype &&
+ guarded_by_destructors n nn kl x safes term &&
+ (*CSC: manca ??? il controllo sul tipo di term? *)
+ List.fold_right
+ (fun p i -> i && guarded_by_destructors n nn kl x safes p)
+ pl true
+ else
+ guarded_by_destructors n nn kl x safes outtype &&
+ (*CSC: manca ??? il controllo sul tipo di term? *)
+ List.fold_right
+ (fun (p,(_,c,rl)) i ->
+ let rl' =
+ match !rl with
+ Some rl' ->
+ let (_,rl'') = split rl' paramsno in
+ rl''
+ | None -> raise Impossible
+ in
+ let (e,safes',n',nn',x') =
+ get_new_safes p c rl' safes n nn x
+ in
+ i &&
+ guarded_by_destructors n' nn' kl x' safes' e
+ ) (List.combine pl cl) true
+ | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x ->
+ let (isinductive,paramsno,cl) =
+ match CicCache.get_obj uri with
+ C.InductiveDefinition (tl,_,paramsno) ->
+ let (_,isinductive,_,cl) = List.nth tl i in
+ let cl' =
+ List.map (fun (id,ty,r) -> (id, eat_prods paramsno ty, r)) cl
+ in
+ (isinductive,paramsno,cl')
+ | _ ->
+ raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri))
+ in
+ if not isinductive then
+ guarded_by_destructors n nn kl x safes outtype &&
+ guarded_by_destructors n nn kl x safes term &&
+ (*CSC: manca ??? il controllo sul tipo di term? *)
+ List.fold_right
+ (fun p i -> i && guarded_by_destructors n nn kl x safes p)
+ pl true
+ else
+ guarded_by_destructors n nn kl x safes outtype &&
+ (*CSC: manca ??? il controllo sul tipo di term? *)
+ List.fold_right
+ (fun t i -> i && guarded_by_destructors n nn kl x safes t)
+ tl true &&
+ List.fold_right
+ (fun (p,(_,c,rl)) i ->
+ let rl' =
+ match !rl with
+ Some rl' ->
+ let (_,rl'') = split rl' paramsno in
+ rl''
+ | None -> raise Impossible
+ in
+ let (e, safes',n',nn',x') =
+ get_new_safes p c rl' safes n nn x
+ in
+ i &&
+ guarded_by_destructors n' nn' kl x' safes' e
+ ) (List.combine pl cl) true
+ | _ ->
+ guarded_by_destructors n nn kl x safes outtype &&
+ guarded_by_destructors n nn kl x safes term &&
+ (*CSC: manca ??? il controllo sul tipo di term? *)
+ List.fold_right
+ (fun p i -> i && guarded_by_destructors n nn kl x safes p)
+ pl true
+ )
+ | C.Fix (_, fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len
+ and nn_plus_len = nn + len
+ and x_plus_len = x + len
+ and safes' = List.map (fun x -> x + len) safes in
+ List.fold_right
+ (fun (_,_,ty,bo) i ->
+ i && guarded_by_destructors n_plus_len nn_plus_len kl x_plus_len
+ safes' ty &&
+ guarded_by_destructors n_plus_len nn_plus_len kl x_plus_len
+ safes' bo
+ ) fl true
+ | C.CoFix (_, fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len
+ and nn_plus_len = nn + len
+ and x_plus_len = x + len
+ and safes' = List.map (fun x -> x + len) safes in
+ List.fold_right
+ (fun (_,ty,bo) i ->
+ i && guarded_by_destructors n_plus_len nn_plus_len kl x_plus_len
+ safes' ty &&
+ guarded_by_destructors n_plus_len nn_plus_len kl x_plus_len safes'
+ bo
+ ) fl true
+
+(*CSC h = 0 significa non ancora protetto *)
+and guarded_by_constructors n nn h =
+ let module C = Cic in
+ function
+ C.Rel m when m > n && m <= nn -> h = 1
+ | C.Rel _
+ | C.Var _
+ | C.Meta _
+ | C.Sort _
+ | C.Implicit -> true (*CSC: ma alcuni sono impossibili!!!! vedi Prod *)
+ | C.Cast (te,ty) ->
+ guarded_by_constructors n nn h te &&
+ guarded_by_constructors n nn h ty
+ | C.Prod (_,so,de) ->
+ raise Impossible (* the term has just been type-checked *)
+ | C.Lambda (_,so,de) ->
+ does_not_occur n nn so &&
+ guarded_by_constructors (n + 1) (nn + 1) h de
+ | C.Appl ((C.Rel m)::tl) when m > n && m <= nn ->
+ h = 1 &&
+ List.fold_right (fun x i -> i && does_not_occur n nn x) tl true
+ | C.Appl ((C.MutConstruct (uri,cookingsno,i,j))::tl) ->
+ let (is_coinductive, rl) =
+ match CicCache.get_cooked_obj uri cookingsno with
+ C.InductiveDefinition (itl,_,_) ->
+ let (_,is_inductive,_,cl) = List.nth itl i in
+ let (_,cons,rrec_args) = List.nth cl (j - 1) in
+ (match !rrec_args with
+ None -> raise Impossible
+ | Some rec_args -> (not is_inductive, rec_args)
+ )
+ | _ ->
+ raise (WrongUriToMutualInductiveDefinitions
+ (UriManager.string_of_uri uri))
+ in
+ is_coinductive &&
+ List.fold_right
+ (fun (x,r) i ->
+ i &&
+ if r then
+ guarded_by_constructors n nn 1 x
+ else
+ does_not_occur n nn x
+ ) (List.combine tl rl) true
+ | C.Appl l ->
+ List.fold_right (fun x i -> i && does_not_occur n nn x) l true
+ | C.Const _
+ | C.Abst _
+ | C.MutInd _
+ | C.MutConstruct _ -> true (*CSC: ma alcuni sono impossibili!!!! vedi Prod *)
+ | C.MutCase (_,_,_,out,te,pl) ->
+ let rec returns_a_coinductive =
+ function
+ (*CSC: per le regole di tipaggio, la chiamata ricorsiva verra' *)
+ (*CSC: effettata solo una volta, per mangiarsi l'astrazione *)
+ (*CSC: non dummy *)
+ C.Lambda (_,_,de) -> returns_a_coinductive de
+ | C.MutInd (uri,_,i) ->
+ (*CSC: definire una funzioncina per questo codice sempre replicato *)
+ (match CicCache.get_obj uri with
+ C.InductiveDefinition (itl,_,_) ->
+ let (_,is_inductive,_,_) = List.nth itl i in
+ not is_inductive
+ | _ ->
+ raise (WrongUriToMutualInductiveDefinitions
+ (UriManager.string_of_uri uri))
+ )
+ (*CSC: bug nella prossima riga (manca la whd) *)
+ | C.Appl ((C.MutInd (uri,_,i))::_) ->
+ (match CicCache.get_obj uri with
+ C.InductiveDefinition (itl,_,_) ->
+ let (_,is_inductive,_,_) = List.nth itl i in
+ not is_inductive
+ | _ ->
+ raise (WrongUriToMutualInductiveDefinitions
+ (UriManager.string_of_uri uri))
+ )
+ | _ -> false
+ in
+ does_not_occur n nn out &&
+ does_not_occur n nn te &&
+ if returns_a_coinductive out then
+ List.fold_right
+ (fun x i -> i && guarded_by_constructors n nn h x) pl true
+ else
+ List.fold_right (fun x i -> i && does_not_occur n nn x) pl true
+ | C.Fix (_,fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len
+ and nn_plus_len = nn + len in
+ List.fold_right
+ (fun (_,_,ty,bo) i ->
+ i && does_not_occur n_plus_len nn_plus_len ty &&
+ does_not_occur n_plus_len nn_plus_len bo
+ ) fl true
+ | C.CoFix (_,fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len
+ and nn_plus_len = nn + len in
+ List.fold_right
+ (fun (_,ty,bo) i ->
+ i && does_not_occur n_plus_len nn_plus_len ty &&
+ does_not_occur n_plus_len nn_plus_len bo
+ ) fl true
+
+and check_allowed_sort_elimination uri i need_dummy ind arity1 arity2 =
+ let module C = Cic in
+ let module U = UriManager in
+ match (CicReduction.whd arity1, CicReduction.whd arity2) with
+ (C.Prod (_,so1,de1), C.Prod (_,so2,de2))
+ when CicReduction.are_convertible so1 so2 ->
+ check_allowed_sort_elimination uri i need_dummy
+ (C.Appl [CicSubstitution.lift 1 ind ; C.Rel 1]) de1 de2
+ | (C.Sort C.Prop, C.Sort C.Prop) when need_dummy -> true
+ | (C.Sort C.Prop, C.Sort C.Set) when need_dummy ->
+ (match CicCache.get_obj uri with
+ C.InductiveDefinition (itl,_,_) ->
+ let (_,_,_,cl) = List.nth itl i in
+ (* is a singleton definition? *)
+ List.length cl = 1
+ | _ ->
+ raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+ )
+ | (C.Sort C.Set, C.Sort C.Prop) when need_dummy -> true
+ | (C.Sort C.Set, C.Sort C.Set) when need_dummy -> true
+ | (C.Sort C.Set, C.Sort C.Type) when need_dummy ->
+ (match CicCache.get_obj uri with
+ C.InductiveDefinition (itl,_,_) ->
+ let (_,_,_,cl) = List.nth itl i in
+ (* is a small inductive type? *)
+ (*CSC: ottimizzare calcolando staticamente *)
+ let rec is_small =
+ function
+ C.Prod (_,so,de) ->
+ let s = type_of so in
+ (s = C.Sort C.Prop || s = C.Sort C.Set) &&
+ is_small de
+ | _ -> true (*CSC: we trust the type-checker *)
+ in
+ List.fold_right (fun (_,x,_) i -> i && is_small x) cl true
+ | _ ->
+ raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+ )
+ | (C.Sort C.Type, C.Sort _) when need_dummy -> true
+ | (C.Sort C.Prop, C.Prod (_,so,ta)) when not need_dummy ->
+ let res = CicReduction.are_convertible so ind
+ in
+ res &&
+ (match CicReduction.whd ta with
+ C.Sort C.Prop -> true
+ | C.Sort C.Set ->
+ (match CicCache.get_obj uri with
+ C.InductiveDefinition (itl,_,_) ->
+ let (_,_,_,cl) = List.nth itl i in
+ (* is a singleton definition? *)
+ List.length cl = 1
+ | _ ->
+ raise (WrongUriToMutualInductiveDefinitions
+ (U.string_of_uri uri))
+ )
+ | _ -> false
+ )
+ | (C.Sort C.Set, C.Prod (_,so,ta)) when not need_dummy ->
+ let res = CicReduction.are_convertible so ind
+ in
+ res &&
+ (match CicReduction.whd ta with
+ C.Sort C.Prop
+ | C.Sort C.Set -> true
+ | C.Sort C.Type ->
+ (match CicCache.get_obj uri with
+ C.InductiveDefinition (itl,_,_) ->
+ let (_,_,_,cl) = List.nth itl i in
+ (* is a small inductive type? *)
+ let rec is_small =
+ function
+ C.Prod (_,so,de) ->
+ let s = type_of so in
+ (s = C.Sort C.Prop || s = C.Sort C.Set) &&
+ is_small de
+ | _ -> true (*CSC: we trust the type-checker *)
+ in
+ List.fold_right (fun (_,x,_) i -> i && is_small x) cl true
+ | _ ->
+ raise (WrongUriToMutualInductiveDefinitions
+ (U.string_of_uri uri))
+ )
+ | _ -> raise Impossible
+ )
+ | (C.Sort C.Type, C.Prod (_,so,_)) when not need_dummy ->
+ CicReduction.are_convertible so ind
+ | (_,_) -> false
+
+and type_of_branch argsno need_dummy outtype term constype =
+ let module C = Cic in
+ let module R = CicReduction in
+ match R.whd constype with
+ C.MutInd (_,_,_) ->
+ if need_dummy then
+ outtype
+ else
+ C.Appl [outtype ; term]
+ | C.Appl (C.MutInd (_,_,_)::tl) ->
+ let (_,arguments) = split tl argsno
+ in
+ if need_dummy && arguments = [] then
+ outtype
+ else
+ C.Appl (outtype::arguments@(if need_dummy then [] else [term]))
+ | C.Prod (name,so,de) ->
+ C.Prod (C.Name "pippo",so,type_of_branch argsno need_dummy
+ (CicSubstitution.lift 1 outtype)
+ (C.Appl [CicSubstitution.lift 1 term ; C.Rel 1]) de)
+ | _ -> raise Impossible
+
+
+and type_of t =
+ let rec type_of_aux env =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module S = CicSubstitution in
+ let module U = UriManager in
+ function
+ C.Rel n -> S.lift n (List.nth env (n - 1))
+ | C.Var uri ->
+ incr fdebug ;
+ let ty = type_of_variable uri in
+ decr fdebug ;
+ ty
+ | C.Meta n -> raise NotImplemented
+ | C.Sort s -> C.Sort C.Type (*CSC manca la gestione degli universi!!! *)
+ | C.Implicit -> raise Impossible
+ | C.Cast (te,ty) ->
+ let _ = type_of ty in
+ if R.are_convertible (type_of_aux env te) ty then ty
+ else raise (NotWellTyped "Cast")
+ | C.Prod (_,s,t) ->
+ let sort1 = type_of_aux env s
+ and sort2 = type_of_aux (s::env) t in
+ sort_of_prod (sort1,sort2)
+ | C.Lambda (n,s,t) ->
+ let sort1 = type_of_aux env s
+ and type2 = type_of_aux (s::env) t in
+ let sort2 = type_of_aux (s::env) type2 in
+ (* only to check if the product is well-typed *)
+ let _ = sort_of_prod (sort1,sort2) in
+ C.Prod (n,s,type2)
+ | C.Appl (he::tl) when List.length tl > 0 ->
+ let hetype = type_of_aux env he
+ and tlbody_and_type = List.map (fun x -> (x, type_of_aux env x)) tl in
+ (try
+ eat_prods hetype tlbody_and_type
+ with _ -> debug (C.Appl (he::tl)) env ; C.Implicit)
+ | C.Appl _ -> raise (NotWellTyped "Appl: no arguments")
+ | C.Const (uri,cookingsno) ->
+ incr fdebug ;
+ let cty = cooked_type_of_constant uri cookingsno in
+ decr fdebug ;
+ cty
+ | C.Abst _ -> raise Impossible
+ | C.MutInd (uri,cookingsno,i) ->
+ incr fdebug ;
+ let cty = cooked_type_of_mutual_inductive_defs uri cookingsno i in
+ decr fdebug ;
+ cty
+ | C.MutConstruct (uri,cookingsno,i,j) ->
+ let cty = cooked_type_of_mutual_inductive_constr uri cookingsno i j
+ in
+ cty
+ | C.MutCase (uri,cookingsno,i,outtype,term,pl) ->
+ let outsort = type_of_aux env outtype in
+ let (need_dummy, k) =
+ let rec guess_args t =
+ match decast t with
+ C.Sort _ -> (true, 0)
+ | C.Prod (_, s, t) ->
+ let (b, n) = guess_args t in
+ if n = 0 then
+ (* last prod before sort *)
+ match CicReduction.whd s with
+ (*CSC vedi nota delirante su cookingsno in cicReduction.ml *)
+ C.MutInd (uri',_,i') when U.eq uri' uri && i' = i -> (false, 1)
+ | C.Appl ((C.MutInd (uri',_,i')) :: _)
+ when U.eq uri' uri && i' = i -> (false, 1)
+ | _ -> (true, 1)
+ else
+ (b, n + 1)
+ | _ -> raise (NotWellTyped "MutCase: outtype ill-formed")
+ in
+ (*CSC whd non serve dopo type_of_aux ? *)
+ let (b, k) = guess_args outsort in
+ if not b then (b, k - 1) else (b, k)
+ in
+ let (parameters, arguments) =
+ match R.whd (type_of_aux env term) with
+ (*CSC manca il caso dei CAST *)
+ C.MutInd (uri',_,i') ->
+ (*CSC vedi nota delirante sui cookingsno in cicReduction.ml*)
+ if U.eq uri uri' && i = i' then ([],[])
+ else raise (NotWellTyped ("MutCase: the term is of type " ^
+ (U.string_of_uri uri') ^ "," ^ string_of_int i' ^
+ " instead of type " ^ (U.string_of_uri uri') ^ "," ^
+ string_of_int i))
+ | C.Appl (C.MutInd (uri',_,i') :: tl) ->
+ if U.eq uri uri' && i = i' then split tl (List.length tl - k)
+ else raise (NotWellTyped ("MutCase: the term is of type " ^
+ (U.string_of_uri uri') ^ "," ^ string_of_int i' ^
+ " instead of type " ^ (U.string_of_uri uri) ^ "," ^
+ string_of_int i))
+ | _ -> raise (NotWellTyped "MutCase: the term is not an inductive one")
+ in
+ (* let's control if the sort elimination is allowed: [(I q1 ... qr)|B] *)
+ let sort_of_ind_type =
+ if parameters = [] then
+ C.MutInd (uri,cookingsno,i)
+ else
+ C.Appl ((C.MutInd (uri,cookingsno,i))::parameters)
+ in
+ if not (check_allowed_sort_elimination uri i need_dummy
+ sort_of_ind_type (type_of_aux env sort_of_ind_type) outsort)
+ then
+ raise (NotWellTyped "MutCase: not allowed sort elimination") ;
+
+ (* let's check if the type of branches are right *)
+ let (cl,parsno) =
+ match CicCache.get_cooked_obj uri cookingsno with
+ C.InductiveDefinition (tl,_,parsno) ->
+ let (_,_,_,cl) = List.nth tl i in (cl,parsno)
+ | _ ->
+ raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+ in
+ let (_,branches_ok) =
+ List.fold_left
+ (fun (j,b) (p,(_,c,_)) ->
+ let cons =
+ if parameters = [] then
+ (C.MutConstruct (uri,cookingsno,i,j))
+ else
+ (C.Appl (C.MutConstruct (uri,cookingsno,i,j)::parameters))
+ in
+ (j + 1, b &&
+ R.are_convertible (type_of_aux env p)
+ (type_of_branch parsno need_dummy outtype cons
+ (type_of_aux env cons))
+ )
+ ) (1,true) (List.combine pl cl)
+ in
+ if not branches_ok then
+ raise (NotWellTyped "MutCase: wrong type of a branch") ;
+
+ if not need_dummy then
+ C.Appl ((outtype::arguments)@[term])
+ else if arguments = [] then
+ outtype
+ else
+ C.Appl (outtype::arguments)
+ | C.Fix (i,fl) ->
+ let types_times_kl =
+ List.rev
+ (List.map (fun (_,k,ty,_) -> let _ = type_of_aux env ty in (ty,k)) fl)
+ in
+ let (types,kl) = List.split types_times_kl in
+ let len = List.length types in
+ List.iter
+ (fun (name,x,ty,bo) ->
+ if (R.are_convertible (type_of_aux (types @ env) bo)
+ (CicSubstitution.lift len ty))
+ then
+ begin
+ let (m, eaten) = eat_lambdas (x + 1) bo in
+ (*let's control the guarded by destructors conditions D{f,k,x,M}*)
+ if not (guarded_by_destructors eaten (len + eaten) kl 1 [] m) then
+ raise (NotWellTyped "Fix: not guarded by destructors")
+ end
+ else
+ raise (NotWellTyped "Fix: ill-typed bodies")
+ ) fl ;
+
+ (*CSC: controlli mancanti solo su D{f,k,x,M} *)
+ let (_,_,ty,_) = List.nth fl i in
+ ty
+ | C.CoFix (i,fl) ->
+ let types =
+ List.rev (List.map (fun (_,ty,_) -> let _ = type_of_aux env ty in ty) fl)
+ in
+ let len = List.length types in
+ List.iter
+ (fun (_,ty,bo) ->
+ if (R.are_convertible (type_of_aux (types @ env) bo)
+ (CicSubstitution.lift len ty))
+ then
+ begin
+ (* let's control the guarded by constructors conditions C{f,M} *)
+ if not (guarded_by_constructors 0 len 0 bo) then
+ raise (NotWellTyped "CoFix: not guarded by constructors")
+ end
+ else
+ raise (NotWellTyped "CoFix: ill-typed bodies")
+ ) fl ;
+
+ let (_,ty,_) = List.nth fl i in
+ ty
+
+ and decast =
+ let module C = Cic in
+ function
+ C.Cast (t,_) -> t
+ | t -> t
+
+ and sort_of_prod (t1, t2) =
+ let module C = Cic in
+ match (decast t1, decast t2) with
+ (C.Sort s1, C.Sort s2)
+ when (s2 = C.Prop or s2 = C.Set) -> (* different from Coq manual!!! *)
+ C.Sort s2
+ | (C.Sort s1, C.Sort s2) -> C.Sort C.Type (*CSC manca la gestione degli universi!!! *)
+ | (_,_) -> raise (NotWellTyped "Prod")
+
+ and eat_prods hetype =
+ (*CSC: siamo sicuri che le are_convertible non lavorino con termini non *)
+ (*CSC: cucinati *)
+ function
+ [] -> hetype
+ | (hete, hety)::tl ->
+ (match (CicReduction.whd hetype) with
+ Cic.Prod (n,s,t) ->
+ if CicReduction.are_convertible s hety then
+ (CicReduction.fdebug := -1 ;
+ eat_prods (CicSubstitution.subst hete t) tl
+ )
+ else
+ (
+ CicReduction.fdebug := 0 ;
+ let _ = CicReduction.are_convertible s hety in
+ debug hete [hety ; s] ;
+ raise (NotWellTyped "Appl: wrong parameter-type")
+)
+ | _ -> raise (NotWellTyped "Appl: wrong Prod-type")
+ )
+ in
+ type_of_aux [] t
+;;
+
+let typecheck uri =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ match CicCache.is_type_checked uri 0 with
+ CicCache.CheckedObj _ -> ()
+ | CicCache.UncheckedObj uobj ->
+ (* let's typecheck the uncooked object *)
+ (match uobj with
+ C.Definition (_,te,ty,_) ->
+ let _ = type_of ty in
+ if not (R.are_convertible (type_of te ) ty) then
+ raise (NotWellTyped ("Constant " ^ (U.string_of_uri uri)))
+ | C.Axiom (_,ty,_) ->
+ (* only to check that ty is well-typed *)
+ let _ = type_of ty in ()
+ | C.CurrentProof (_,_,te,ty) ->
+ (*CSC [] wrong *)
+ let _ = type_of ty in
+ debug (type_of te) [] ;
+ if not (R.are_convertible (type_of te) ty) then
+ raise (NotWellTyped ("CurrentProof" ^ (U.string_of_uri uri)))
+ | C.Variable (_,ty) ->
+ (* only to check that ty is well-typed *)
+ (*CSC [] wrong *)
+ let _ = type_of ty in ()
+ | C.InductiveDefinition _ ->
+ cooked_mutual_inductive_defs uri uobj
+ ) ;
+ CicCache.set_type_checking_info uri
+;;
--- /dev/null
+exception NotWellTyped of string
+exception WrongUriToConstant of string
+exception WrongUriToVariable of string
+exception WrongUriToMutualInductiveDefinitions of string
+exception ListTooShort
+exception NotPositiveOccurrences of string
+exception NotWellFormedTypeOfInductiveConstructor of string
+exception WrongRequiredArgument of string
+val typecheck : UriManager.uri -> unit
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 14/06/2000 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+let get_annotation_from_term annterm =
+ let module C = Cic in
+ match annterm with
+ C.ARel (_,ann,_,_) -> ann
+ | C.AVar (_,ann,_) -> ann
+ | C.AMeta (_,ann,_) -> ann
+ | C.ASort (_,ann,_) -> ann
+ | C.AImplicit (_,ann) -> ann
+ | C.ACast (_,ann,_,_) -> ann
+ | C.AProd (_,ann,_,_,_) -> ann
+ | C.ALambda (_,ann,_,_,_) -> ann
+ | C.AAppl (_,ann,_) -> ann
+ | C.AConst (_,ann,_,_) -> ann
+ | C.AAbst (_,ann,_) -> ann
+ | C.AMutInd (_,ann,_,_,_) -> ann
+ | C.AMutConstruct (_,ann,_,_,_,_)-> ann
+ | C.AMutCase (_,ann,_,_,_,_,_,_) -> ann
+ | C.AFix (_,ann,_,_) -> ann
+ | C.ACoFix (_,ann,_,_) -> ann
+;;
+
+let get_annotation_from_obj annobj =
+ let module C = Cic in
+ match annobj with
+ C.ADefinition (_,ann,_,_,_,_) -> ann
+ | C.AAxiom (_,ann,_,_,_) -> ann
+ | C.AVariable (_,ann,_,_) -> ann
+ | C.ACurrentProof (_,ann,_,_,_,_) -> ann
+ | C.AInductiveDefinition (_,ann,_,_,_) -> ann
+;;
+
+exception IdUnknown of string;;
+
+let get_annotation (annobj,ids_to_targets) xpath =
+ try
+ match Hashtbl.find ids_to_targets xpath with
+ Cic.Object annobj -> get_annotation_from_obj annobj
+ | Cic.Term annterm -> get_annotation_from_term annterm
+ with
+ Not_found -> raise (IdUnknown xpath)
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 11/04/2000 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+(* functions to parse an XPath to retrieve the annotation *)
+
+exception WrongXPath of string;;
+
+let rec get_annotation_of_inductiveFun f xpath =
+ let module C = Cic in
+ match (xpath,f) with
+ 1::tl,(_,_,ty,_) -> get_annotation_of_term ty tl
+ | 2::tl,(_,_,_,te) -> get_annotation_of_term te tl
+ | l,_ ->
+ raise (WrongXPath (List.fold_right (fun n i -> string_of_int n ^ i) l ""))
+
+and get_annotation_of_coinductiveFun f xpath =
+ let module C = Cic in
+ match (xpath,f) with
+ 1::tl,(_,ty,_) -> get_annotation_of_term ty tl
+ | 2::tl,(_,_,te) -> get_annotation_of_term te tl
+ | l,_ ->
+ raise (WrongXPath (List.fold_right (fun n i -> string_of_int n ^ i) l ""))
+
+and get_annotation_of_inductiveType ty xpath =
+ let module C = Cic in
+ match (xpath,ty) with
+ 1::tl,(_,_,arity,_) -> get_annotation_of_term arity tl
+ | n::tl,(_,_,_,cons) when n <= List.length cons + 1 ->
+ let (_,ty,_) = List.nth cons (n-2) in
+ get_annotation_of_term ty tl
+ | l,_ ->
+ raise (WrongXPath (List.fold_right (fun n i -> string_of_int n ^ i) l ""))
+
+and get_annotation_of_term term xpath =
+ let module C = Cic in
+ match (xpath,term) with
+ [],C.ARel (_,ann,_,_) -> ann
+ | [],C.AVar (_,ann,_) -> ann
+ | [],C.AMeta (_,ann,_) -> ann
+ | [],C.ASort (_,ann,_) -> ann
+ | [],C.AImplicit (_,ann) -> ann
+ | [],C.ACast (_,ann,_,_) -> ann
+ | 1::tl,C.ACast (_,_,te,_) -> get_annotation_of_term te tl
+ | 2::tl,C.ACast (_,_,_,ty) -> get_annotation_of_term ty tl
+ | [],C.AProd (_,ann,_,_,_) -> ann
+ | 1::tl,C.AProd (_,_,_,so,_) -> get_annotation_of_term so tl
+ | 2::tl,C.AProd (_,_,_,_,ta) -> get_annotation_of_term ta tl
+ | [],C.ALambda (_,ann,_,_,_) -> ann
+ | 1::tl,C.ALambda (_,_,_,so,_) -> get_annotation_of_term so tl
+ | 2::tl,C.ALambda (_,_,_,_,ta) -> get_annotation_of_term ta tl
+ | [],C.AAppl (_,ann,_) -> ann
+ | n::tl,C.AAppl (_,_,l) when n <= List.length l ->
+ get_annotation_of_term (List.nth l (n-1)) tl
+ | [],C.AConst (_,ann,_,_) -> ann
+ | [],C.AAbst (_,ann,_) -> ann
+ | [],C.AMutInd (_,ann,_,_,_) -> ann
+ | [],C.AMutConstruct (_,ann,_,_,_,_) -> ann
+ | [],C.AMutCase (_,ann,_,_,_,_,_,_) -> ann
+ | 1::tl,C.AMutCase (_,_,_,_,_,outt,_,_) -> get_annotation_of_term outt tl
+ | 2::tl,C.AMutCase (_,_,_,_,_,_,te,_) -> get_annotation_of_term te tl
+ | n::tl,C.AMutCase (_,_,_,_,_,_,_,pl) when n <= List.length pl ->
+ get_annotation_of_term (List.nth pl (n-1)) tl
+ | [],C.AFix (_,ann,_,_) -> ann
+ | n::tl,C.AFix (_,_,_,fl) when n <= List.length fl ->
+ get_annotation_of_inductiveFun (List.nth fl (n-1)) tl
+ | [],C.ACoFix (_,ann,_,_) -> ann
+ | n::tl,C.ACoFix (_,_,_,fl) when n <= List.length fl ->
+ get_annotation_of_coinductiveFun (List.nth fl (n-1)) tl
+ | l,_ ->
+ raise (WrongXPath (List.fold_right (fun n i -> string_of_int n ^ i) l ""))
+;;
+
+let get_annotation (annobj,_) xpath =
+ let module C = Cic in
+ match (xpath,annobj) with
+ [],C.ADefinition (_,ann,_,_,_,_) -> ann
+ | 1::tl,C.ADefinition (_,_,_,bo,_,_) -> get_annotation_of_term bo tl
+ | 2::tl,C.ADefinition (_,_,_,_,ty,_) -> get_annotation_of_term ty tl
+ | [],C.AAxiom (_,ann,_,_,_) -> ann
+ | 1::tl,C.AAxiom (_,_,_,ty,_) -> get_annotation_of_term ty tl
+ | [],C.AVariable (_,ann,_,_) -> ann
+ | 1::tl,C.AVariable (_,_,_,ty) -> get_annotation_of_term ty tl
+ | [],C.ACurrentProof (_,ann,_,_,_,_) -> ann
+ | n::tl,C.ACurrentProof (_,ann,_,conjs,_,_) when n <= List.length conjs ->
+ get_annotation_of_term (snd (List.nth conjs (n-1))) tl
+ | n::tl,C.ACurrentProof (_,ann,_,conjs,bo,_) when n = List.length conjs + 1 ->
+ get_annotation_of_term bo tl
+ | n::tl,C.ACurrentProof (_,ann,_,conjs,_,ty) when n = List.length conjs + 2 ->
+ get_annotation_of_term ty tl
+ | [],C.AInductiveDefinition (_,ann,_,_,_) -> ann
+ | n::tl,C.AInductiveDefinition (_,_,tys,_,_) when n <= List.length tys ->
+ get_annotation_of_inductiveType (List.nth tys (n-1)) tl
+ | l,_ ->
+ raise (WrongXPath (List.fold_right (fun n i -> string_of_int n ^ i) l ""))
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 06/05/2000 *)
+(* *)
+(* This is the parser that reads the configuration file of helm *)
+(* *)
+(******************************************************************************)
+
+(* this should be the only hard coded constant *)
+let filename = "/home/cadet/sacerdot/local/etc/helm/configuration.xml";;
+
+exception Warnings;;
+
+class warner =
+ object
+ method warn w =
+ print_endline ("WARNING: " ^ w) ;
+ (raise Warnings : unit)
+ end
+;;
+
+let xml_document () =
+ let module Y = Pxp_yacc in
+ try
+ let config = {Y.default_config with Y.warner = new warner} in
+ Y.parse_document_entity config (Y.from_file filename) Y.default_spec
+ with
+ e ->
+ print_endline (Pxp_types.string_of_exn e) ;
+ raise e
+;;
+
+exception Impossible;;
+
+let vars = Hashtbl.create 14;;
+
+(* resolve <value-of> tags and returns the string values of the variable tags *)
+let rec resolve =
+ let module D = Pxp_document in
+ function
+ [] -> ""
+ | he::tl when he#node_type = D.T_element "value-of" ->
+ (match he#attribute "var" with
+ Pxp_types.Value var -> Hashtbl.find vars var
+ | _ -> raise Impossible
+ ) ^ resolve tl
+ | he::tl when he#node_type = D.T_data ->
+ he#data ^ resolve tl
+ | _ -> raise Impossible
+;;
+
+(* we trust the xml file to be valid because of the validating xml parser *)
+let _ =
+ List.iter
+ (function
+ n ->
+ match n#node_type with
+ Pxp_document.T_element var ->
+ Hashtbl.add vars var (resolve (n#sub_nodes))
+ | _ -> raise Impossible
+ )
+ ((xml_document ())#root#sub_nodes)
+;;
+
+let helm_dir = Hashtbl.find vars "helm_dir";;
+let dtd_dir = Hashtbl.find vars "dtd_dir";;
+let servers_file = Hashtbl.find vars "servers_file";;
+let uris_dbm = Hashtbl.find vars "uris_dbm";;
+let dest = Hashtbl.find vars "dest";;
+let indexname = Hashtbl.find vars "indexname";;
+let tmpdir = Hashtbl.find vars "tmpdir";;
+let helm_dir = Hashtbl.find vars "helm_dir";;
+let getter_url = Hashtbl.find vars "getter_url";;
+
+let _ = Hashtbl.clear vars;;
--- /dev/null
+let expect_possible_parameters = ref false;;
+
+exception NotExpectingPossibleParameters;;
+
+let rec deannotate_term =
+ let module C = Cic in
+ function
+ C.ARel (_,_,n,_) -> C.Rel n
+ | C.AVar (_,_,uri) -> C.Var uri
+ | C.AMeta (_,_,n) -> C.Meta n
+ | C.ASort (_,_,s) -> C.Sort s
+ | C.AImplicit _ -> C.Implicit
+ | C.ACast (_,_,va,ty) -> C.Cast (deannotate_term va, deannotate_term ty)
+ | C.AProd (_,_,name,so,ta) ->
+ C.Prod (name, deannotate_term so, deannotate_term ta)
+ | C.ALambda (_,_,name,so,ta) ->
+ C.Lambda (name, deannotate_term so, deannotate_term ta)
+ | C.AAppl (_,_,l) -> C.Appl (List.map deannotate_term l)
+ | C.AConst (_,_,uri, cookingsno) -> C.Const (uri, cookingsno)
+ | C.AAbst (_,_,uri) -> C.Abst uri
+ | C.AMutInd (_,_,uri,cookingsno,i) -> C.MutInd (uri,cookingsno,i)
+ | C.AMutConstruct (_,_,uri,cookingsno,i,j) ->
+ C.MutConstruct (uri,cookingsno,i,j)
+ | C.AMutCase (_,_,uri,cookingsno,i,outtype,te,pl) ->
+ C.MutCase (uri,cookingsno,i,deannotate_term outtype,
+ deannotate_term te, List.map deannotate_term pl)
+ | C.AFix (_,_,funno,ifl) ->
+ C.Fix (funno, List.map deannotate_inductiveFun ifl)
+ | C.ACoFix (_,_,funno,ifl) ->
+ C.CoFix (funno, List.map deannotate_coinductiveFun ifl)
+
+and deannotate_inductiveFun (name,index,ty,bo) =
+ (name, index, deannotate_term ty, deannotate_term bo)
+
+and deannotate_coinductiveFun (name,ty,bo) =
+ (name, deannotate_term ty, deannotate_term bo)
+;;
+
+let deannotate_inductiveType (name, isinductive, arity, cons) =
+ (name, isinductive, deannotate_term arity,
+ List.map (fun (id,ty,recs) -> (id,deannotate_term ty, recs)) cons)
+;;
+
+let deannotate_obj =
+ let module C = Cic in
+ function
+ C.ADefinition (_, _, id, bo, ty, params) ->
+ (match params with
+ C.Possible params ->
+ if !expect_possible_parameters then
+ C.Definition (id, deannotate_term bo, deannotate_term ty, params)
+ else
+ raise NotExpectingPossibleParameters
+ | C.Actual params ->
+ C.Definition (id, deannotate_term bo, deannotate_term ty, params)
+ )
+ | C.AAxiom (_, _, id, ty, params) ->
+ C.Axiom (id, deannotate_term ty, params)
+ | C.AVariable (_, _, name, ty) ->
+ C.Variable (name, deannotate_term ty)
+ | C.ACurrentProof (_, _, name, conjs, bo, ty) ->
+ C.CurrentProof (
+ name, List.map (fun (id,con) -> (id,deannotate_term con)) conjs,
+ deannotate_term bo, deannotate_term ty
+ )
+ | C.AInductiveDefinition (_, _, tys, params, parno) ->
+ C.InductiveDefinition ( List.map deannotate_inductiveType tys,
+ params, parno)
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 24/01/2000 *)
+(* *)
+(* This is a textual interface to the Coq-like pretty printer cicPp for cic *)
+(* terms exported in xml. It uses directly the modules cicPp and cache and *)
+(* indirectly all the other modules (cicParser, cicParser2, cicParser3, *)
+(* getter). The syntax is "experiment[.opt] filename1 ... filenamen" where *)
+(* filenamei is the path-name of an xml file describing a cic term. On stdout *)
+(* are pretty-printed all the n terms *)
+(* *)
+(******************************************************************************)
+
+let pretty_print = ref true;;
+let read_from_stdin = ref false;;
+let uris_in_input = ref false;;
+
+let parse uri =
+ if !pretty_print then
+ begin
+ print_endline ("^^^" ^ uri ^ "^^^") ;
+ print_string (CicPp.ppobj (CicCache.get_obj (UriManager.uri_of_string uri)));
+ print_endline ("\n$$$" ^ uri ^ "$$$\n")
+ end
+ else
+ begin
+ print_string uri ;
+ let _ = CicCache.get_obj (UriManager.uri_of_string uri) in
+ print_endline " OK!" ;
+ flush stdout
+ end
+;;
+
+let uri_of_filename fn =
+ if !uris_in_input then fn
+ else
+ let uri =
+ Str.replace_first (Str.regexp (Str.quote Configuration.helm_dir)) "cic:" fn
+ in
+ let uri' = Str.replace_first (Str.regexp "\.xml$") "" uri in
+ uri'
+;;
+
+let read_filenames_from_stdin () =
+ let files = ref [] in
+ try
+ while true do
+ let l = Str.split (Str.regexp " ") (read_line ()) in
+ List.iter (fun x -> files := (uri_of_filename x) :: !files) l
+ done
+ with
+ End_of_file ->
+ files := List.rev !files ;
+ List.iter parse !files
+;;
+
+(* filenames are read from command line and converted to uris via *)
+(* uri_of_filenames; then the cic terms are load in cache via *)
+(* CicCache.get_obj and then pretty printed via CicPp.ppobj *)
+
+let main() =
+ let files = ref [] in
+ Arg.parse
+ ["-nopp", Arg.Clear pretty_print, "Do not pretty print, parse only" ;
+ "-stdin", Arg.Set read_from_stdin, "Read from stdin" ;
+ "-uris", Arg.Set uris_in_input, "Read uris, not filenames" ;
+ "-update", Arg.Unit Getter.update, "Update the getter view of the world"]
+ (fun x -> files := (uri_of_filename x) :: !files)
+ "
+usage: experiment file ...
+
+List of options:";
+ if !read_from_stdin then read_filenames_from_stdin ()
+ else
+ begin
+ files := List.rev !files;
+ List.iter parse !files
+ end
+;;
+
+main();;
--- /dev/null
+let read_from_stdin = ref false;;
+
+let uri_of_filename fn =
+ let uri =
+ Str.replace_first (Str.regexp (Str.quote Configuration.helm_dir)) "cic:" fn
+ in
+ let uri' = Str.replace_first (Str.regexp "\.xml$") "" uri in
+ UriManager.uri_of_string uri'
+;;
+
+let main() =
+ Deannotate.expect_possible_parameters := true ;
+ let files = ref [] in
+ Arg.parse
+ ["-stdin", Arg.Set read_from_stdin, "Read from stdin"]
+ (fun x -> files := (x, uri_of_filename x) :: !files)
+ "
+usage: experiment file ...
+
+List of options:";
+ if !read_from_stdin then
+ begin
+ try
+ while true do
+ let l = Str.split (Str.regexp " ") (read_line ()) in
+ List.iter (fun x -> files := (x, uri_of_filename x) :: !files) l
+ done
+ with
+ End_of_file -> ()
+ end ;
+ files := List.rev !files;
+ Getter.update () ;
+ print_endline "ATTENTION: have you changed servers.txt so that you'll try \
+ to repair your own objs instead of others'?" ;
+ flush stdout ;
+ List.iter
+ (function (fn, uri) ->
+ print_string (UriManager.string_of_uri uri) ;
+ flush stdout ;
+ (try
+ CicFindParameters.fix_params uri (Some fn)
+ with
+ e -> print_newline () ; flush stdout ; raise e ) ;
+ print_endline " OK!" ;
+ flush stdout
+ ) !files
+;;
+
+main();;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 24/01/2000 *)
+(* *)
+(******************************************************************************)
+
+exception ErrorGetting of string;;
+
+module OrderedStrings =
+ struct
+ type t = string
+ let compare (s1 : t) (s2 : t) = compare s1 s2
+ end
+;;
+
+module MapOfStrings = Map.Make(OrderedStrings);;
+
+let read_index url =
+ let module C = Configuration in
+ if Sys.command ("wget -c -P " ^ C.tmpdir ^ " " ^ url ^ "/\"" ^
+ C.indexname ^ "\"") <> 0
+ then
+ raise (ErrorGetting url) ;
+ let tmpfilename = C.tmpdir ^ "/" ^ C.indexname in
+ let fd = open_in tmpfilename in
+ let uris = ref [] in
+ try
+ while true do
+ uris := (input_line fd) :: !uris
+ done ;
+ [] (* only to make the compiler happy *)
+ with
+ End_of_file ->
+ Sys.remove tmpfilename ;
+ !uris
+;;
+
+(* mk_urls_of_uris list_of_servers_base_urls *)
+let rec mk_urls_of_uris =
+ function
+ [] -> MapOfStrings.empty
+ | he::tl ->
+ let map = mk_urls_of_uris tl in
+ let uris = read_index he in
+ let url_of_uri uri =
+ let url = uri ^ ".xml" in
+ let url' = Str.replace_first (Str.regexp "cic:") he url in
+ let url'' = Str.replace_first (Str.regexp "theory:") he url' in
+ url''
+ in
+ List.fold_right
+ (fun uri m -> MapOfStrings.add uri (url_of_uri uri) m)
+ uris map
+;;
+
+let update () =
+ let module C = Configuration in
+ let fd = open_in C.servers_file in
+ let servers = ref [] in
+ try
+ while true do
+ servers := (input_line fd) :: !servers
+ done
+ with
+ End_of_file ->
+ let urls_of_uris = mk_urls_of_uris (List.rev !servers) in
+ (try Sys.remove (C.uris_dbm ^ ".db") with _ -> ()) ;
+ let dbm =
+ Dbm.opendbm C.uris_dbm [Dbm.Dbm_wronly ; Dbm.Dbm_create] 0o660
+ in
+ MapOfStrings.iter (fun uri url -> Dbm.add dbm uri url) urls_of_uris ;
+ Dbm.close dbm
+;;
+
+(* url_of_uri : uri -> url *)
+let url_of_uri uri =
+ let dbm = Dbm.opendbm Configuration.uris_dbm [Dbm.Dbm_rdonly] 0o660 in
+ let url = Dbm.find dbm (UriManager.string_of_uri uri) in
+ Dbm.close dbm ;
+ url
+;;
+
+let filedir_of_uri uri =
+ let fn = UriManager.buri_of_uri uri in
+ let fn' = Str.replace_first (Str.regexp ".*:") Configuration.dest fn in
+ fn'
+;;
+
+let name_and_ext_of_uri uri =
+ let str = UriManager.string_of_uri uri in
+ Str.replace_first (Str.regexp ".*/") "" str
+;;
+
+(* get_file : uri -> filename *)
+let get_file uri =
+ let dir = filedir_of_uri uri in
+ let fn = dir ^ "/" ^ name_and_ext_of_uri uri ^ ".xml" in
+ if not (Sys.file_exists fn) then
+ begin
+ let url = url_of_uri uri in
+ (*CSC: use -q for quiet mode *)
+ if Sys.command ("wget -c -P " ^ dir ^ " \"" ^ url ^"\"") <> 0
+ then
+ raise (ErrorGetting url) ;
+ end ;
+ fn
+;;
+
+(* get : uri -> filename *)
+(* If uri is the URI of an annotation, the annotated object is processed *)
+let get uri =
+ let module U = UriManager in
+ get_file
+ (U.uri_of_string
+ (Str.replace_first (Str.regexp "\.ann$") ""
+ (Str.replace_first (Str.regexp "\.types$") "" (U.string_of_uri uri))))
+;;
+
+(* get_ann : uri -> filename *)
+(* If uri is the URI of an annotation, the annotation file is processed *)
+let get_ann = get_file;;
+
+(* get_ann_file_name_and_uri : uri -> filename * annuri *)
+(* If given an URI, it returns the name of the corresponding *)
+(* annotation file and the annotation uri *)
+let get_ann_file_name_and_uri uri =
+ let module U = UriManager in
+ let uri = U.string_of_uri uri in
+ let annuri =
+ U.uri_of_string (
+ if Str.string_match (Str.regexp ".*\.ann$") uri 0 then
+ uri
+ else
+ uri ^ ".ann"
+ )
+ in
+ let dir = filedir_of_uri annuri in
+ let fn = dir ^ "/" ^ name_and_ext_of_uri annuri ^ ".xml" in
+ (fn, annuri)
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 24/01/2000 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+(* get : uri -> filename *)
+(* If uri is the URI of an annotation, the annotated object is processed *)
+val get : UriManager.uri -> string
+
+(* get_ann : uri -> filename *)
+(* If uri is the URI of an annotation, the annotation file is processed *)
+val get_ann : UriManager.uri -> string
+
+(* get_ann_file_name_and_uri : uri -> filename * annuri *)
+(* If given an URI, it returns the name of the corresponding *)
+(* annotation file and the annotation uri *)
+val get_ann_file_name_and_uri : UriManager.uri -> string * UriManager.uri
+
+(* synchronize with the servers *)
+val update : unit -> unit
--- /dev/null
+#!/usr/bin/perl
+
+# next require defines: $helm_dir, $html_link
+# LUCA - 12 sep 2000
+# require "/usr/lib/helm/configuration.pl";
+require "/home/cadet/sacerdot/local/lib/helm/configuration.pl";
+use HTTP::Daemon;
+use HTTP::Status;
+use HTTP::Request;
+use LWP::UserAgent;
+use DB_File;
+
+my $cont = "";
+my $d = new HTTP::Daemon LocalPort => 8081;
+tie(%map, 'DB_File', 'urls_of_uris.db', O_RDONLY, 0664);
+print "Please contact me at: <URL:", $d->url, ">\n";
+print "helm_dir: $helm_dir\n";
+$SIG{CHLD} = "IGNORE"; # do not accumulate defunct processes
+while (my $c = $d->accept) {
+ if (fork() == 0) {
+ while (my $r = $c->get_request) {
+ #CSC: mancano i controlli di sicurezza
+
+ $cont = "";
+ my $cicuri = $r->url;
+ $cicuri =~ s/^[^?]*\?url=(.*)/$1/;
+ print "*".$r->url."\n";
+ my $http_method = $r->method;
+ my $http_path = $r->url->path;
+ if ($http_method eq 'GET' and $http_path eq "/get") {
+ my $filename = $cicuri;
+ $filename =~ s/cic:(.*)/$1/;
+ $filename =~ s/theory:(.*)/$1/;
+ $filename = $helm_dir.$filename.".xml";
+ my $resolved = $map{$cicuri};
+ print "$cicuri ==> $resolved ($filename)\n";
+ if (stat($filename)) {
+ print "Using local copy\n";
+ open(FD, $filename);
+ while(<FD>) { $cont .= $_; }
+ close(FD);
+ my $res = new HTTP::Response;
+ $res->content($cont);
+ $c->send_response($res);
+ } else {
+ print "Downloading\n";
+ $ua = LWP::UserAgent->new;
+ $request = HTTP::Request->new(GET => "$resolved");
+ $response = $ua->request($request, \&callback);
+
+ print "Storing file\n";
+ open(FD, $filename);
+ print FD $cont;
+ close(FD);
+
+ my $res = new HTTP::Response;
+ $res->content($cont);
+ $c->send_response($res);
+ }
+ } elsif ($http_method eq 'GET' and $http_path eq "/annotate") {
+ my $do_annotate = ($cicuri =~ /\.ann$/);
+ my $target_to_annotate = $cicuri;
+ $target_to_annotate =~ s/(.*)\.ann$/$1/ if $do_annotate;
+ my $filename = $cicuri;
+ $filename =~ s/cic:(.*)/$1/;
+ $filename =~ s/theory:(.*)/$1/;
+ my $filename_target = $helm_dir.$filename if $do_annotate;
+ $filename = $helm_dir.$filename.".xml";
+ $filename_target =~ s/(.*)\.ann$/$1.xml/ if $do_annotate;
+ my $resolved = $map{$cicuri};
+ my $resolved_target = $map{$target_to_annotate} if $do_annotate;
+ if ($do_annotate) {
+ print "($cicuri, $target_to_annotate) ==> ($resolved + $resolved_target) ($filename)\n";
+ } else {
+ print "$cicuri ==> $resolved ($filename)\n";
+ }
+
+ # Retrieves the annotation
+
+ if (stat($filename)) {
+ print "Using local copy for the annotation\n";
+ open(FD, $filename);
+ while(<FD>) { $cont .= $_; }
+ close(FD);
+ } else {
+ print "Downloading the annotation\n";
+ $ua = LWP::UserAgent->new;
+ $request = HTTP::Request->new(GET => "$resolved");
+ $response = $ua->request($request, \&callback);
+
+ print "Storing file for the annotation\n";
+ open(FD, $filename);
+ print FD $cont;
+ close(FD);
+ }
+ my $annotation = $cont;
+
+ # Retrieves the target to annotate
+
+ $cont = "";
+ if ($do_annotate) {
+ if (stat($filename_target)) {
+ print "Using local copy for the file to annotate\n";
+ open(FD, $filename_target);
+ while(<FD>) { $cont .= $_; }
+ close(FD);
+ } else {
+ print "Downloading the file to annotate\n";
+ $ua = LWP::UserAgent->new;
+ $request = HTTP::Request->new(GET => "$resolved_target");
+ $response = $ua->request($request, \&callback);
+
+ print "Storing file for the file to annotate\n";
+ open(FD, $filename_target);
+ print FD $cont;
+ close(FD);
+ }
+ }
+ my $target = $cont;
+
+ # Merging the annotation and the target
+
+ $target =~ s/<\?xml [^?]*\?>//sg;
+ $target =~ s/<!DOCTYPE [^>]*>//sg;
+ $annotation =~ s/<\?xml [^?]*\?>//sg;
+ $annotation =~ s/<!DOCTYPE [^>]*>//sg;
+ my $merged = <<EOT;
+<?xml version="1.0" encoding="UTF-8"?>
+<cicxml uri="$target_to_annotate">
+$target
+$annotation
+</cicxml>
+EOT
+
+ # Answering the client
+
+ my $res = new HTTP::Response;
+ $res->content($merged);
+ $c->send_response($res);
+ } elsif ($http_method eq 'GET' and $http_path eq "/getwithtypes") {
+ my $do_annotate = ($cicuri =~ /\.types$/);
+ my $target_to_annotate = $cicuri;
+ $target_to_annotate =~ s/(.*)\.types$/$1/ if $do_annotate;
+ my $filename = $cicuri;
+ $filename =~ s/cic:(.*)/$1/;
+ $filename =~ s/theory:(.*)/$1/;
+ my $filename_target = $helm_dir.$filename if $do_annotate;
+ $filename = $helm_dir.$filename.".xml";
+ $filename_target =~ s/(.*)\.types$/$1.xml/ if $do_annotate;
+ my $resolved = $map{$cicuri};
+ my $resolved_target = $map{$target_to_annotate} if $do_annotate;
+ if ($do_annotate) {
+ print "GETWITHTYPES!!\n";
+ print "($cicuri, $target_to_annotate) ==> ($resolved + $resolved_target) ($filename)\n";
+ } else {
+ print "$cicuri ==> $resolved ($filename)\n";
+ }
+
+ # Retrieves the annotation
+
+ if (stat($filename)) {
+ print "Using local copy for the types\n";
+ open(FD, $filename);
+ while(<FD>) { $cont .= $_; }
+ close(FD);
+ } else {
+ print "Downloading the types\n";
+ $ua = LWP::UserAgent->new;
+ $request = HTTP::Request->new(GET => "$resolved");
+ $response = $ua->request($request, \&callback);
+
+ print "Storing file for the types\n";
+ open(FD, $filename);
+ print FD $cont;
+ close(FD);
+ }
+ my $annotation = $cont;
+
+ # Retrieves the target to annotate
+
+ $cont = "";
+ my $target;
+ if ($do_annotate) {
+ if (stat($filename_target)) {
+ print "Using local copy for the file to type\n";
+ open(FD, $filename_target);
+ while(<FD>) { $cont .= $_; }
+ close(FD);
+ } else {
+ print "Downloading the file to type\n";
+ $ua = LWP::UserAgent->new;
+ $request = HTTP::Request->new(GET => "$resolved_target");
+ $response = $ua->request($request, \&callback);
+
+ print "Storing file for the file to type\n";
+ open(FD, $filename_target);
+ print FD $cont;
+ close(FD);
+ }
+ $target = $cont;
+ } else {
+ $target = $annotation;
+ $annotation = "";
+ }
+
+ # Merging the annotation and the target
+
+ $target =~ s/<\?xml [^?]*\?>//sg;
+ $target =~ s/<!DOCTYPE [^>]*>//sg;
+ $annotation =~ s/<\?xml [^?]*\?>//sg;
+ $annotation =~ s/<!DOCTYPE [^>]*>//sg;
+ my $merged = <<EOT;
+<?xml version="1.0" encoding="UTF-8"?>
+<cicxml uri="$target_to_annotate">
+$target
+<ALLTYPES>
+$annotation
+</ALLTYPES>
+</cicxml>
+EOT
+
+ # Answering the client
+
+ my $res = new HTTP::Response;
+ $res->content($merged);
+ $c->send_response($res);
+ } elsif ($http_method eq 'GET' and $http_path eq "/getdtd") {
+ my $filename = $cicuri;
+ $filename = $helm_dir."/dtd/".$filename;
+ print "DTD: $cicuri ==> ($filename)\n";
+ if (stat($filename)) {
+ print "Using local copy\n";
+ open(FD, $filename);
+ while(<FD>) { $cont .= $_; }
+ close(FD);
+ my $res = new HTTP::Response;
+ $res->content($cont);
+ $c->send_response($res);
+ } else {
+ die "Could not find DTD!";
+ }
+ } elsif ($http_method eq 'GET' and $http_path eq "/conf") {
+ my $quoted_html_link = $html_link;
+ $quoted_html_link =~ s/&/&/g;
+ $quoted_html_link =~ s/</</g;
+ $quoted_html_link =~ s/>/>/g;
+ $quoted_html_link =~ s/'/'/g;
+ $quoted_html_link =~ s/"/"/g;
+ print "Configuration requested, returned #$quoted_html_link#\n";
+ $cont = "<?xml version=\"1.0\"?><html_link>$quoted_html_link</html_link>";
+ my $res = new HTTP::Response;
+ $res->content($cont);
+ $c->send_response($res);
+ } else {
+ print "INVALID REQUEST!!!!!\n";
+ $c->send_error(RC_FORBIDDEN)
+ }
+ }
+ $c->close;
+ undef($c);
+ print "\nCONNECTION CLOSED\n\n";
+ exit;
+ } # fork
+}
+
+#================================
+
+sub callback
+{
+ my ($data) = @_;
+ $cont .= $data;
+}
--- /dev/null
+#!/usr/bin/perl
+
+# next require defines: $helm_dir, $html_link
+require "/usr/lib/helm/configuration.pl";
+use HTTP::Daemon;
+use HTTP::Status;
+use HTTP::Request;
+use LWP::UserAgent;
+use DB_File;
+
+my $cont = "";
+my $d = new HTTP::Daemon LocalPort => 8081;
+tie(%map, 'DB_File', 'urls_of_uris.db', O_RDONLY, 0664);
+print "Please contact me at: <URL:", $d->url, ">\n";
+print "helm_dir: $helm_dir\n";
+$SIG{CHLD} = "IGNORE"; # do not accumulate defunct processes
+while (my $c = $d->accept) {
+ if (fork() == 0) {
+ while (my $r = $c->get_request) {
+ #CSC: mancano i controlli di sicurezza
+
+ $cont = "";
+ my $cicuri = $r->url;
+ $cicuri =~ s/^[^?]*\?url=(.*)/$1/;
+ print "*".$r->url."\n";
+ my $http_method = $r->method;
+ my $http_path = $r->url->path;
+ if ($http_method eq 'GET' and $http_path eq "/get") {
+ my $filename = $cicuri;
+ $filename =~ s/cic:(.*)/$1/;
+ $filename =~ s/theory:(.*)/$1/;
+ $filename = $helm_dir.$filename.".xml";
+ my $resolved = $map{$cicuri};
+ print "$cicuri ==> $resolved ($filename)\n";
+ if (stat($filename)) {
+ print "Using local copy\n";
+ open(FD, $filename);
+ while(<FD>) { $cont .= $_; }
+ close(FD);
+ my $res = new HTTP::Response;
+ $res->content($cont);
+ $c->send_response($res);
+ } else {
+ print "Downloading\n";
+ $ua = LWP::UserAgent->new;
+ $request = HTTP::Request->new(GET => "$resolved");
+ $response = $ua->request($request, \&callback);
+
+ print "Storing file\n";
+ open(FD, $filename);
+ print FD $cont;
+ close(FD);
+
+ my $res = new HTTP::Response;
+ $res->content($cont);
+ $c->send_response($res);
+ }
+ } elsif ($http_method eq 'GET' and $http_path eq "/annotate") {
+ my $do_annotate = ($cicuri =~ /\.ann$/);
+ my $target_to_annotate = $cicuri;
+ $target_to_annotate =~ s/(.*)\.ann$/$1/ if $do_annotate;
+ my $filename = $cicuri;
+ $filename =~ s/cic:(.*)/$1/;
+ $filename =~ s/theory:(.*)/$1/;
+ my $filename_target = $helm_dir.$filename if $do_annotate;
+ $filename = $helm_dir.$filename.".xml";
+ $filename_target =~ s/(.*)\.ann$/$1.xml/ if $do_annotate;
+ my $resolved = $map{$cicuri};
+ my $resolved_target = $map{$target_to_annotate} if $do_annotate;
+ if ($do_annotate) {
+ print "($cicuri, $target_to_annotate) ==> ($resolved + $resolved_target) ($filename)\n";
+ } elsif ($http_method eq 'GET' and $http_path eq "/getwithtypes") {
+ my $do_annotate = ($cicuri =~ /\.types$/);
+ my $target_to_annotate = $cicuri;
+ $target_to_annotate =~ s/(.*)\.types$/$1/ if $do_annotate;
+ my $filename = $cicuri;
+ $filename =~ s/cic:(.*)/$1/;
+ $filename =~ s/theory:(.*)/$1/;
+ my $filename_target = $helm_dir.$filename if $do_annotate;
+ $filename = $helm_dir.$filename.".xml";
+ $filename_target =~ s/(.*)\.types$/$1.xml/ if $do_annotate;
+ my $resolved = $map{$cicuri};
+ my $resolved_target = $map{$target_to_annotate} if $do_annotate;
+ if ($do_annotate) {
+ print "($cicuri, $target_to_annotate) ==> ($resolved + $resolved_target) ($filename)\n";
+ } else {
+ print "$cicuri ==> $resolved ($filename)\n";
+ }
+
+ # Retrieves the annotation
+
+ if (stat($filename)) {
+ print "Using local copy for the types\n";
+ open(FD, $filename);
+ while(<FD>) { $cont .= $_; }
+ close(FD);
+ } else {
+ print "Downloading the types\n";
+ $ua = LWP::UserAgent->new;
+ $request = HTTP::Request->new(GET => "$resolved");
+ $response = $ua->request($request, \&callback);
+
+ print "Storing file for the types\n";
+ open(FD, $filename);
+ print FD $cont;
+ close(FD);
+ }
+ my $annotation = $cont;
+
+ # Retrieves the target to annotate
+
+ $cont = "";
+ if ($do_annotate) {
+ if (stat($filename_target)) {
+ print "Using local copy for the file to type\n";
+ open(FD, $filename_target);
+ while(<FD>) { $cont .= $_; }
+ close(FD);
+ } else {
+ print "Downloading the file to type\n";
+ $ua = LWP::UserAgent->new;
+ $request = HTTP::Request->new(GET => "$resolved_target");
+ $response = $ua->request($request, \&callback);
+
+ print "Storing file for the file to type\n";
+ open(FD, $filename_target);
+ print FD $cont;
+ close(FD);
+ }
+ }
+ my $target = $cont;
+
+ # Merging the annotation and the target
+
+ $target =~ s/<\?xml [^?]*\?>//sg;
+ $target =~ s/<!DOCTYPE [^>]*>//sg;
+ $annotation =~ s/<\?xml [^?]*\?>//sg;
+ $annotation =~ s/<!DOCTYPE [^>]*>//sg;
+ my $merged = <<EOT;
+<?xml version="1.0" encoding="UTF-8"?>
+<cicxml uri="$target_to_annotate">
+$target
+<ALLTYPES>
+$annotation
+</ALLTYPES>
+</cicxml>
+EOT
+
+ # Answering the client
+
+ my $res = new HTTP::Response;
+ $res->content($merged);
+ $c->send_response($res);
+ } elsif ($http_method eq 'GET' and $http_path eq "/getdtd") {
+ my $filename = $cicuri;
+ $filename = $helm_dir."/dtd/".$filename;
+ print "DTD: $cicuri ==> ($filename)\n";
+ if (stat($filename)) {
+ print "Using local copy\n";
+ open(FD, $filename);
+ while(<FD>) { $cont .= $_; }
+ close(FD);
+ my $res = new HTTP::Response;
+ $res->content($cont);
+ $c->send_response($res);
+ } else {
+ die "Could not find DTD!";
+ }
+ } elsif ($http_method eq 'GET' and $http_path eq "/conf") {
+ my $quoted_html_link = $html_link;
+ $quoted_html_link =~ s/&/&/g;
+ $quoted_html_link =~ s/</</g;
+ $quoted_html_link =~ s/>/>/g;
+ $quoted_html_link =~ s/'/'/g;
+ $quoted_html_link =~ s/"/"/g;
+ print "Configuration requested, returned #$quoted_html_link#\n";
+ $cont = "<?xml version=\"1.0\"?><html_link>$quoted_html_link</html_link>";
+ my $res = new HTTP::Response;
+ $res->content($cont);
+ $c->send_response($res);
+ } else {
+ print "INVALID REQUEST!!!!!\n";
+ $c->send_error(RC_FORBIDDEN)
+ }
+ }
+ $c->close;
+ undef($c);
+ print "\nCONNECTION CLOSED\n\n";
+ exit;
+ } # fork
+}
+
+#================================
+
+sub callback
+{
+ my ($data) = @_;
+ $cont .= $data;
+}
--- /dev/null
+#! /bin/sh
+
+export PATH=$PATH:/opt/java/jdk118/bin/
+
+export CLASSPATH=.
+export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/xalan_1_1/xalan.jar
+export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/xalan_1_1/xerces.jar
+export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/saxon-5.3.2/saxon.jar
+
+# Per (my)Coq 6.3.0
+export LD_LIBRARY_PATH=/home/lpadovan/helm/usr/lib/:$LD_LIBRARY_PATH
+export LD_LIBRARY_PATH=/usr/local/lib/gtkmathview:$LD_LIBRARY_PATH
--- /dev/null
+SIGSEGV received at bfffeacc in /home/cadet/sacerdot/jdk118/lib/linux/native_threads/libjitc.so. Processing terminated
+java full version "JDK 1.1.8 IBM build l118-19991013 (JIT enabled: jitc)"
+args: /home/cadet/sacerdot/jdk118/bin/linux/native_threads/java xaland 12345 12346 examples/style/annotatedcont.xsl examples/style/annotatedpres.xsl examples/style/theory_content.xsl examples/style/theory_pres.xsl
+
+Operating Environment
+---------------------
+Host : cadet.
+OS Level : 2.2.14-5.0smp.#1 SMP Tue Mar 7 21:01:40 EST 2000
+glibc Version : 2.1.3
+No. of Procs : 1
+Memory Info:
+ total: used: free: shared: buffers: cached:
+Mem: 64503808 55078912 9424896 36126720 1527808 18075648
+Swap: 133885952 7442432 126443520
+MemTotal: 62992 kB
+MemFree: 9204 kB
+MemShared: 35280 kB
+Buffers: 1492 kB
+Cached: 17652 kB
+BigTotal: 0 kB
+BigFree: 0 kB
+SwapTotal: 130748 kB
+SwapFree: 123480 kB
+
+Application Environment
+-----------------------
+Signal Handlers -
+ SIGQUIT : ignored
+ SIGILL : sysThreadIDump (libjava.so)
+ SIGABRT : sysThreadIDump (libjava.so)
+ SIGFPE : sysThreadIDump (libjava.so)
+ SIGBUS : sysThreadIDump (libjava.so)
+ SIGSEGV : sysThreadIDump (libjava.so)
+ SIGPIPE : ignored
+ SIGUSR1 : doSuspendLoop (libjava.so)
+
+Environment Variables -
+ LESSOPEN=|/usr/bin/lesspipe.sh %s
+ SAL_DO_NOT_USE_INVERT50=true
+ HISTSIZE=1000
+ HOSTNAME=cadet
+ LOGNAME=sacerdot
+ VISUAL=/usr/bin/emacs
+ LD_LIBRARY_PATH=/home/cadet/sacerdot/jdk118/lib/linux/native_threads:/usr/local/lib/gtkmathview:/home/pauillac/coq3/sacerdot/rvplayer5.0
+ MAIL=/var/spool/mail/sacerdot
+ PAGER=less
+ CLASSPATH=.:/usr/share/java/bsf.jar:/usr/share/java/xalan.jar:/usr/share/java/xerces.jar:/home/cadet/sacerdot/jdk118/classes:/home/cadet/sacerdot/jdk118/lib/classes.jar:/home/cadet/sacerdot/jdk118/lib/rt.jar:/home/cadet/sacerdot/jdk118/lib/i18n.jar:/home/cadet/sacerdot/jdk118/lib/classes.zip
+ LESSCHARDEF=8bcccbcc18b95.33b.
+ ARCH=i586
+ PROMPT=cad:
+ TERM=xterm
+ HOSTTYPE=i386
+ PATH=/home/cadet/sacerdot/jdk118/bin:/home/pauillac/coq3/sacerdot/bin/i586:/home/pauillac/coq3/sacerdot/bin:/usr/bin/X11:/usr/bin:/usr/local/bin:/usr/ucb:/usr/bin:/bin:/usr/sbin:/sbin:/usr/games:.
+ PRINTER=hp11rv
+ HOME=/home/pauillac/coq3/sacerdot
+ SHELL=/bin/sh
+ ELANLIB=/home/pauillac/coq3/sacerdot/elan-dist.3.00/elanlib
+ PILOTPORT=/dev/ttyS1
+ TEXINPUTS=:.:/home/pauillac/coq3/sacerdot/lib/latex/inputs:/usr/local/lib/tex/inputs3
+ USER=sacerdot
+ ENSCRIPT=-Php11rvl -2 -r -B -L66 -k -h
+ MANPATH=/usr/man/preformat:/usr/man:/usr/X11/man:/usr/local/man:/home/pauillac/coq3/sacerdot/man
+ LESS=-m -e -q -d
+ JAVA_HOME=/home/cadet/sacerdot/jdk118
+ DISPLAY=:0.0
+ MAKEFLAGS=
+ HOST=cadet
+ OSTYPE=Linux
+ NNTPSERVER=news-rocq.inria.fr
+ WINDOWID=54525966
+ SHLVL=4
+ MAKELEVEL=1
+ LS_COLORS=no=00:fi=00:di=01;34:ln=01;36:pi=40;33:so=01;35:bd=40;33;01:cd=40;33;01:or=01;05;37;41:mi=01;05;37;41:ex=01;32:*.cmd=01;32:*.exe=01;32:*.com=01;32:*.btm=01;32:*.bat=01;32:*.sh=01;32:*.csh=01;32:*.tar=01;31:*.tgz=01;31:*.arj=01;31:*.taz=01;31:*.lzh=01;31:*.zip=01;31:*.z=01;31:*.Z=01;31:*.gz=01;31:*.bz2=01;31:*.bz=01;31:*.tz=01;31:*.rpm=01;31:*.cpio=01;31:*.jpg=01;35:*.gif=01;35:*.bmp=01;35:*.xbm=01;35:*.xpm=01;35:*.png=01;35:*.tif=01;35:
+ EDITOR=/usr/bin/emacs
+ MFLAGS=
+ CVSROOT=/net/pauillac/constr/ARCHIVE
+
+
+Current Thread Details
+----------------------
+ "main" (TID:0x402e62d8, sys_thread_t:0x804abe0)
+ Native Thread State: ThreadID: 00000400 Reuse: 1 USER PRIMORDIAL RUNNING
+ Native Stack Data : base: bffff47c pointer bffbf96c used(260880) free(-13072)
+ ----- Monitors held -----
+ ----- Native stack -----
+
+
+
+
+
+
+
+
+ ??
+ ??
+ ??
+
+ java_lang_Compiler_start
+
+ __irem_trap6
+ ------ Java stack ------ () prio=5 *current thread*
+ org.apache.xalan.xslt.XSLTEngineImpl.createStylesheetRoot(XSLTEngineImpl.java:715)
+ org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code)
+ org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code)
+ xaland.main(Compiled Code)
+----------------------------------------------------------------------
+
+
+Total Thread Count: 3
+Active Thread Count: 3
+JNI Thread Count: 0
+
+Full thread dump:
+ "Async Garbage Collector" (TID:0x402e6238, sys_thread_t:0x8091f50)
+ Native Thread State: ThreadID: 00000803 Reuse: 1 DAEMON MONITOR WAIT
+ Native Stack Data : base: bf5ffd84 pointer bf5ffb78 used(524) free(247284)
+ ----- Monitors held -----
+ ----- Native stack -----
+ sysMonitorWait
+ sysThreadSleep
+ threadSleep
+ SetOrigArgs
+ sysThread_shell
+ pthread_detach
+ __clone
+ ------ Java stack ------ () prio=1
+----------------------------------------------------------------------
+
+ "Finalizer thread" (TID:0x402e6288, sys_thread_t:0x8091cd0)
+ Native Thread State: ThreadID: 00000402 Reuse: 1 DAEMON MONITOR WAIT
+ Native Stack Data : base: bf7ffd84 pointer bf7ffbec used(408) free(247400)
+ ----- Monitors held -----
+ ----- Native stack -----
+ sysMonitorWait - waiting on Finalize me queue lock
+ finalizeOnExit
+ sysThread_shell
+ pthread_detach
+ __clone
+ ------ Java stack ------ () prio=1
+----------------------------------------------------------------------
+
+ "main" (TID:0x402e62d8, sys_thread_t:0x804abe0)
+ Native Thread State: ThreadID: 00000400 Reuse: 1 USER PRIMORDIAL RUNNING
+ Native Stack Data : base: bffff47c pointer bffbf960 used(260892) free(-13084)
+ ----- Monitors held -----
+ ----- Native stack -----
+
+
+
+
+
+
+
+
+ ??
+ ??
+ ??
+
+ java_lang_Compiler_start
+
+ __irem_trap6
+ ------ Java stack ------ () prio=5 *current thread*
+ org.apache.xalan.xslt.XSLTEngineImpl.createStylesheetRoot(XSLTEngineImpl.java:715)
+ org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code)
+ org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code)
+ xaland.main(Compiled Code)
+----------------------------------------------------------------------
+
+
+System Monitor Status
+---------------------
+ JIT monitor: unowned.
+ JIT monitor: unowned.
+ JIT monitor: unowned.
+ JIT monitor: unowned.
+ JIT monitor: unowned.
+ Thread queue lock: unowned.
+ Name and type hash table lock: unowned.
+ String intern lock: unowned.
+ JNI pinning lock: unowned.
+ JNI global reference lock: unowned.
+ Zip lock: unowned.
+ BinClass lock: unowned.
+ Class loading lock: unowned.
+ Java stack lock: unowned.
+ Code rewrite lock: unowned.
+ Heap Lock: unowned.
+ Has finalization queue lock: unowned.
+ Finalize me queue lock: unowned.
+ Integer lock access-lock: unowned.
+ Monitor cache lock: unowned.
+ Monitor registry: unowned.
+
+Object Monitor Status
+---------------------
--- /dev/null
+SIGSEGV received at bfffeacc in /home/cadet/sacerdot/jdk118/lib/linux/native_threads/libjitc.so. Processing terminated
+java full version "JDK 1.1.8 IBM build l118-19991013 (JIT enabled: jitc)"
+args: /home/cadet/sacerdot/jdk118/bin/linux/native_threads/java xaland 12345 12346 examples/style/annotatedcont.xsl examples/style/annotatedpres.xsl examples/style/theory_content.xsl examples/style/theory_pres.xsl
+
+Operating Environment
+---------------------
+Host : cadet.
+OS Level : 2.2.14-5.0smp.#1 SMP Tue Mar 7 21:01:40 EST 2000
+glibc Version : 2.1.3
+No. of Procs : 1
+Memory Info:
+ total: used: free: shared: buffers: cached:
+Mem: 64503808 55672832 8830976 36130816 1536000 18612224
+Swap: 133885952 7442432 126443520
+MemTotal: 62992 kB
+MemFree: 8624 kB
+MemShared: 35284 kB
+Buffers: 1500 kB
+Cached: 18176 kB
+BigTotal: 0 kB
+BigFree: 0 kB
+SwapTotal: 130748 kB
+SwapFree: 123480 kB
+
+Application Environment
+-----------------------
+Signal Handlers -
+ SIGQUIT : ignored
+ SIGILL : sysThreadIDump (libjava.so)
+ SIGABRT : sysThreadIDump (libjava.so)
+ SIGFPE : sysThreadIDump (libjava.so)
+ SIGBUS : sysThreadIDump (libjava.so)
+ SIGSEGV : sysThreadIDump (libjava.so)
+ SIGPIPE : ignored
+ SIGUSR1 : doSuspendLoop (libjava.so)
+
+Environment Variables -
+ LESSOPEN=|/usr/bin/lesspipe.sh %s
+ SAL_DO_NOT_USE_INVERT50=true
+ HISTSIZE=1000
+ HOSTNAME=cadet
+ LOGNAME=sacerdot
+ VISUAL=/usr/bin/emacs
+ LD_LIBRARY_PATH=/home/cadet/sacerdot/jdk118/lib/linux/native_threads:/usr/local/lib/gtkmathview:/home/pauillac/coq3/sacerdot/rvplayer5.0
+ MAIL=/var/spool/mail/sacerdot
+ PAGER=less
+ CLASSPATH=.:/usr/share/java/bsf.jar:/usr/share/java/xalan.jar:/usr/share/java/xerces.jar:/home/cadet/sacerdot/jdk118/classes:/home/cadet/sacerdot/jdk118/lib/classes.jar:/home/cadet/sacerdot/jdk118/lib/rt.jar:/home/cadet/sacerdot/jdk118/lib/i18n.jar:/home/cadet/sacerdot/jdk118/lib/classes.zip
+ LESSCHARDEF=8bcccbcc18b95.33b.
+ ARCH=i586
+ PROMPT=cad:
+ TERM=xterm
+ HOSTTYPE=i386
+ PATH=/home/cadet/sacerdot/jdk118/bin:/home/pauillac/coq3/sacerdot/bin/i586:/home/pauillac/coq3/sacerdot/bin:/usr/bin/X11:/usr/bin:/usr/local/bin:/usr/ucb:/usr/bin:/bin:/usr/sbin:/sbin:/usr/games:.
+ PRINTER=hp11rv
+ HOME=/home/pauillac/coq3/sacerdot
+ SHELL=/bin/sh
+ ELANLIB=/home/pauillac/coq3/sacerdot/elan-dist.3.00/elanlib
+ PILOTPORT=/dev/ttyS1
+ TEXINPUTS=:.:/home/pauillac/coq3/sacerdot/lib/latex/inputs:/usr/local/lib/tex/inputs3
+ USER=sacerdot
+ ENSCRIPT=-Php11rvl -2 -r -B -L66 -k -h
+ MANPATH=/usr/man/preformat:/usr/man:/usr/X11/man:/usr/local/man:/home/pauillac/coq3/sacerdot/man
+ LESS=-m -e -q -d
+ JAVA_HOME=/home/cadet/sacerdot/jdk118
+ DISPLAY=:0.0
+ MAKEFLAGS=
+ HOST=cadet
+ OSTYPE=Linux
+ NNTPSERVER=news-rocq.inria.fr
+ WINDOWID=54525966
+ SHLVL=4
+ MAKELEVEL=1
+ LS_COLORS=no=00:fi=00:di=01;34:ln=01;36:pi=40;33:so=01;35:bd=40;33;01:cd=40;33;01:or=01;05;37;41:mi=01;05;37;41:ex=01;32:*.cmd=01;32:*.exe=01;32:*.com=01;32:*.btm=01;32:*.bat=01;32:*.sh=01;32:*.csh=01;32:*.tar=01;31:*.tgz=01;31:*.arj=01;31:*.taz=01;31:*.lzh=01;31:*.zip=01;31:*.z=01;31:*.Z=01;31:*.gz=01;31:*.bz2=01;31:*.bz=01;31:*.tz=01;31:*.rpm=01;31:*.cpio=01;31:*.jpg=01;35:*.gif=01;35:*.bmp=01;35:*.xbm=01;35:*.xpm=01;35:*.png=01;35:*.tif=01;35:
+ EDITOR=/usr/bin/emacs
+ MFLAGS=
+ CVSROOT=/net/pauillac/constr/ARCHIVE
+
+
+Current Thread Details
+----------------------
+ "main" (TID:0x402e62d8, sys_thread_t:0x804abe0)
+ Native Thread State: ThreadID: 00000400 Reuse: 1 USER PRIMORDIAL RUNNING
+ Native Stack Data : base: bffff47c pointer bffbf96c used(260880) free(-13072)
+ ----- Monitors held -----
+ ----- Native stack -----
+
+
+
+
+
+
+
+
+ ??
+ ??
+ ??
+
+ java_lang_Compiler_start
+
+ __irem_trap6
+ ------ Java stack ------ () prio=5 *current thread*
+ org.apache.xalan.xslt.XSLTEngineImpl.createStylesheetRoot(XSLTEngineImpl.java:715)
+ org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code)
+ org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code)
+ xaland.main(Compiled Code)
+----------------------------------------------------------------------
+
+
+Total Thread Count: 3
+Active Thread Count: 3
+JNI Thread Count: 0
+
+Full thread dump:
+ "Async Garbage Collector" (TID:0x402e6238, sys_thread_t:0x8091f50)
+ Native Thread State: ThreadID: 00000803 Reuse: 1 DAEMON MONITOR WAIT
+ Native Stack Data : base: bf5ffd84 pointer bf5ffb78 used(524) free(247284)
+ ----- Monitors held -----
+ ----- Native stack -----
+ sysMonitorWait
+ sysThreadSleep
+ threadSleep
+ SetOrigArgs
+ sysThread_shell
+ pthread_detach
+ __clone
+ ------ Java stack ------ () prio=1
+----------------------------------------------------------------------
+
+ "Finalizer thread" (TID:0x402e6288, sys_thread_t:0x8091cd0)
+ Native Thread State: ThreadID: 00000402 Reuse: 1 DAEMON MONITOR WAIT
+ Native Stack Data : base: bf7ffd84 pointer bf7ffbec used(408) free(247400)
+ ----- Monitors held -----
+ ----- Native stack -----
+ sysMonitorWait - waiting on Finalize me queue lock
+ finalizeOnExit
+ sysThread_shell
+ pthread_detach
+ __clone
+ ------ Java stack ------ () prio=1
+----------------------------------------------------------------------
+
+ "main" (TID:0x402e62d8, sys_thread_t:0x804abe0)
+ Native Thread State: ThreadID: 00000400 Reuse: 1 USER PRIMORDIAL RUNNING
+ Native Stack Data : base: bffff47c pointer bffbf960 used(260892) free(-13084)
+ ----- Monitors held -----
+ ----- Native stack -----
+
+
+
+
+
+
+
+
+ ??
+ ??
+ ??
+
+ java_lang_Compiler_start
+
+ __irem_trap6
+ ------ Java stack ------ () prio=5 *current thread*
+ org.apache.xalan.xslt.XSLTEngineImpl.createStylesheetRoot(XSLTEngineImpl.java:715)
+ org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code)
+ org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code)
+ xaland.main(Compiled Code)
+----------------------------------------------------------------------
+
+
+System Monitor Status
+---------------------
+ JIT monitor: unowned.
+ JIT monitor: unowned.
+ JIT monitor: unowned.
+ JIT monitor: unowned.
+ JIT monitor: unowned.
+ Thread queue lock: unowned.
+ Name and type hash table lock: unowned.
+ String intern lock: unowned.
+ JNI pinning lock: unowned.
+ JNI global reference lock: unowned.
+ Zip lock: unowned.
+ BinClass lock: unowned.
+ Class loading lock: unowned.
+ Java stack lock: unowned.
+ Code rewrite lock: unowned.
+ Heap Lock: unowned.
+ Has finalization queue lock: unowned.
+ Finalize me queue lock: unowned.
+ Integer lock access-lock: unowned.
+ Monitor cache lock: unowned.
+ Monitor registry: unowned.
+
+Object Monitor Status
+---------------------
--- /dev/null
+#!/usr/bin/perl
+
+while(<STDIN>)
+{
+ s/→/->/g;
+ s/⇒/=>/g;
+ s/λ/\\/g;
+ s/Π/||/g;
+ print;
+}
--- /dev/null
+#!/bin/bash
+
+echo `find . -name "*.xml"` | /really_very_local/helm/PARSER/coq_like_pretty_printer/uris_of_filenames.pl > index.txt
--- /dev/null
+<?xml encoding="ISO-8859-1"?>
+
+<!-- CSC: mio DTD semplificatissimo per la parte presentation di MML -->
+
+<!-- I seguenti presentation elements sono stati tralasciati ;-)
+mspace
+ms
+<mchar>
+<ms>
+mfrac
+msqrt
+mroot
+mstyle
+merror
+mpadded
+mphantom
+msub
+msup
+msubsup
+munder
+mover
+munderover
+mmultiscripts
+mtable
+mtr
+mtd
+maligngroup
+malignmark
+maction
+-->
+
+<!-- Dei seguenti elementi, invece, vengono tralasciati quasi tutti gli
+ attributi
+⁡
+-->
+
+<!ENTITY % Presentation '(mi|mo|mn|mtext|mrow|mfenced)*'>
+
+<!ELEMENT math %Presentation;>
+
+<!ELEMENT mi (#PCDATA)>
+
+<!ELEMENT mo (#PCDATA)>
+
+<!ELEMENT mn (#PCDATA)>
+
+<!ELEMENT mtext (#PCDATA)>
+
+<!ELEMENT mrow %Presentation;>
+
+<!ELEMENT mfenced %Presentation;>
+<!ATTLIST mfenced
+ open CDATA #IMPLIED
+ close CDATA #IMPLIED
+ separators CDATA #IMPLIED>
--- /dev/null
+type expr =
+ Null
+ | Mi of string
+ | Mo of string
+ | Mn of string
+ | Mtext of string
+ | Mrow of expr list
+ | Mfenced of string * string * string * expr list (* open, close, separators *)
+type fragment =
+ Math of expr list
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 24/01/2000 *)
+(* *)
+(* This is a simple gtk interface to the Coq-like pretty printer cicPp for *)
+(* cic terms exported in xml. It uses directly the modules cicPp and *)
+(* cicCcache and indirectly all the other modules (cicParser, cicParser2, *)
+(* cicParser3, getter). *)
+(* The syntax is "gtkInterface[.opt] filename1 ... filenamen" where *)
+(* filenamei is the path-name of an xml file describing a cic term. *)
+(* The terms are loaded in cache and then pretty-printed one at a time and *)
+(* only once, when the user wants to look at it: if the user wants to look at *)
+(* a term again, then the pretty-printed term is showed again, but not *)
+(* recomputed *)
+(* *)
+(******************************************************************************)
+
+(* DEFINITION OF THE URI TREE AND USEFUL FUNCTIONS ON IT *)
+
+type item =
+ Dir of string * item list ref
+ | File of string * UriManager.uri
+;;
+
+let uritree = ref []
+let theoryuritree = ref []
+
+let get_name =
+ function
+ Dir (name,_) -> name
+ | File (name,_) -> name
+;;
+
+let get_uri =
+ function
+ Dir _ -> None
+ | File (_,uri) -> Some uri
+;;
+
+(* STUFF TO BUILD THE URI TREE *)
+
+exception EmptyUri
+exception DuplicatedUri
+exception ConflictingUris
+
+let insert_in_uri_tree uri =
+ let rec aux l =
+ function
+ [name] ->
+ (try
+ let _ = List.find (fun item -> name = get_name item) !l in
+ raise DuplicatedUri
+ with
+ Not_found -> l := (File (name,uri))::!l
+ )
+ | name::tl ->
+ (try
+ match List.find (fun item -> name = get_name item) !l with
+ Dir (_,children) -> aux children tl
+ | File _ -> raise ConflictingUris
+ with
+ Not_found ->
+ let children = ref [] in
+ l := (Dir (name,children))::!l ;
+ aux children tl
+ )
+ | [] -> raise EmptyUri
+ in
+ aux
+;;
+
+(* Imperative procedure that builds the two uri trees *)
+let build_uri_tree () =
+ let dbh = Dbm.opendbm Configuration.uris_dbm [Dbm.Dbm_rdonly] 0 in
+ Dbm.iter
+ (fun uri _ ->
+ let cicregexp = Str.regexp "cic:"
+ and theoryregexp = Str.regexp "theory:" in
+ if Str.string_match cicregexp uri 0 then
+ let s = Str.replace_first cicregexp "" uri in
+ let l = Str.split (Str.regexp "/") s in
+ insert_in_uri_tree (UriManager.uri_of_string uri) uritree l
+ else if Str.string_match theoryregexp uri 0 then
+ let s = Str.replace_first theoryregexp "" uri in
+ let l = Str.split (Str.regexp "/") s in
+ insert_in_uri_tree (UriManager.uri_of_string uri) theoryuritree l
+ ) dbh ;
+ Dbm.close dbh
+;;
+
+(* GLOBAL REFERENCES (USED BY CALLBACKS) *)
+
+let annotated_obj = ref None;; (* reference to a couple option where *)
+ (* the first component is the current *)
+ (* annotated object and the second is *)
+ (* the map from ids to annotated targets *)
+let ann = ref (ref None);; (* current annotation *)
+let radio_some_status = ref false;; (* is the radio_some button selected? *)
+
+let theory_visited_uris = ref [];;
+let theory_to_visit_uris = ref [];;
+let visited_uris = ref [];;
+let to_visit_uris = ref [];;
+
+(* CALLBACKS *)
+
+exception NoCurrentUri;;
+exception NoNextOrPrevUri;;
+exception GtkInterfaceInternalError;;
+
+let theory_get_current_uri () =
+ match !theory_visited_uris with
+ [] -> raise NoCurrentUri
+ | uri::_ -> uri
+;;
+
+let get_current_uri () =
+ match !visited_uris with
+ [] -> raise NoCurrentUri
+ | uri::_ -> uri
+;;
+
+let get_annotated_obj () =
+ match !annotated_obj with
+ None ->
+ let (annobj, ids_to_targets,_) =
+ (CicCache.get_annobj (get_current_uri ()))
+ in
+ annotated_obj := Some (annobj, ids_to_targets) ;
+ (annobj, ids_to_targets)
+ | Some annobj -> annobj
+;;
+
+let filename_of_uri uri =
+ Getter.get uri
+;;
+
+let theory_update_output rendering_window uri =
+ rendering_window#label#set_text (UriManager.string_of_uri uri) ;
+ ignore (rendering_window#errors#delete_text 0 rendering_window#errors#length) ;
+ let mmlfile = XsltProcessor.process uri true "theory" in
+ rendering_window#output#load mmlfile
+;;
+
+let update_output rendering_window uri =
+ rendering_window#label#set_text (UriManager.string_of_uri uri) ;
+ ignore (rendering_window#errors#delete_text 0 rendering_window#errors#length) ;
+ let mmlfile = XsltProcessor.process uri true "cic" in
+ rendering_window#output#load mmlfile
+;;
+
+let theory_next rendering_window () =
+ match !theory_to_visit_uris with
+ [] -> raise NoNextOrPrevUri
+ | uri::tl ->
+ theory_to_visit_uris := tl ;
+ theory_visited_uris := uri::!theory_visited_uris ;
+ theory_update_output rendering_window uri ;
+ rendering_window#prevb#misc#set_sensitive true ;
+ if tl = [] then
+ rendering_window#nextb#misc#set_sensitive false
+;;
+
+let next rendering_window () =
+ match !to_visit_uris with
+ [] -> raise NoNextOrPrevUri
+ | uri::tl ->
+ to_visit_uris := tl ;
+ visited_uris := uri::!visited_uris ;
+ annotated_obj := None ;
+ update_output rendering_window uri ;
+ rendering_window#prevb#misc#set_sensitive true ;
+ if tl = [] then
+ rendering_window#nextb#misc#set_sensitive false
+;;
+
+let theory_prev rendering_window () =
+ match !theory_visited_uris with
+ [] -> raise NoCurrentUri
+ | [_] -> raise NoNextOrPrevUri
+ | uri::(uri'::tl as newvu) ->
+ theory_visited_uris := newvu ;
+ theory_to_visit_uris := uri::!theory_to_visit_uris ;
+ theory_update_output rendering_window uri' ;
+ rendering_window#nextb#misc#set_sensitive true ;
+ if tl = [] then
+ rendering_window#prevb#misc#set_sensitive false
+;;
+
+let prev rendering_window () =
+ match !visited_uris with
+ [] -> raise NoCurrentUri
+ | [_] -> raise NoNextOrPrevUri
+ | uri::(uri'::tl as newvu) ->
+ visited_uris := newvu ;
+ to_visit_uris := uri::!to_visit_uris ;
+ annotated_obj := None ;
+ update_output rendering_window uri' ;
+ rendering_window#nextb#misc#set_sensitive true ;
+ if tl = [] then
+ rendering_window#prevb#misc#set_sensitive false
+;;
+
+(* called when an hyperlink is clicked *)
+let jump rendering_window s =
+ let uri = UriManager.uri_of_string s in
+ rendering_window#show () ;
+ rendering_window#prevb#misc#set_sensitive true ;
+ rendering_window#nextb#misc#set_sensitive false ;
+ visited_uris := uri::!visited_uris ;
+ to_visit_uris := [] ;
+ annotated_obj := None ;
+ update_output rendering_window uri
+;;
+
+let changefont rendering_window () =
+ rendering_window#output#set_font_size rendering_window#spinb#value_as_int
+;;
+
+
+let theory_selection_changed rendering_window uri () =
+ match uri with
+ None -> ()
+ | Some uri' ->
+ if !theory_visited_uris <> [] then
+ rendering_window#prevb#misc#set_sensitive true ;
+ rendering_window#nextb#misc#set_sensitive false ;
+ theory_visited_uris := uri'::!theory_visited_uris ;
+ theory_to_visit_uris := [] ;
+ rendering_window#show () ;
+ theory_update_output rendering_window uri'
+;;
+
+let selection_changed rendering_window uri () =
+ match uri with
+ None -> ()
+ | Some uri' ->
+ if !visited_uris <> [] then
+ rendering_window#prevb#misc#set_sensitive true ;
+ rendering_window#nextb#misc#set_sensitive false ;
+ visited_uris := uri'::!visited_uris ;
+ to_visit_uris := [] ;
+ annotated_obj := None ;
+ rendering_window#show () ;
+ update_output rendering_window uri'
+;;
+
+(* CSC: unificare con la creazione la prima volta *)
+let rec updateb_pressed theory_rendering_window rendering_window
+ (sw1, sw ,(hbox : GPack.box)) mktree ()
+=
+ Getter.update () ;
+ (* let's empty the uri trees and rebuild them *)
+ uritree := [] ;
+ theoryuritree := [] ;
+ build_uri_tree () ;
+ hbox#remove !sw1#coerce ;
+ hbox#remove !sw#coerce ;
+
+ let sw3 =
+ GBin.scrolled_window ~width:250 ~height:600
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let tree1 =
+ GTree.tree ~selection_mode:`BROWSE ~packing:sw3#add_with_viewport () in
+ let tree_item1 = GTree.tree_item ~label:"theory:/" ~packing:tree1#append () in
+ sw1 := sw3 ;
+ ignore(tree_item1#connect#select
+ (theory_selection_changed theory_rendering_window None)) ;
+ mktree theory_selection_changed theory_rendering_window tree_item1
+ (Dir ("theory:/",theoryuritree)) ;
+
+ let sw2 =
+ GBin.scrolled_window ~width:250 ~height:600
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let tree =
+ GTree.tree ~selection_mode:`BROWSE ~packing:sw2#add_with_viewport () in
+ let tree_item = GTree.tree_item ~label:"cic:/" ~packing:tree#append () in
+ sw := sw2 ;
+ ignore(tree_item#connect#select (selection_changed rendering_window None)) ;
+ mktree selection_changed rendering_window tree_item (Dir ("cic:/",uritree))
+;;
+
+let theory_check rendering_window () =
+ let output =
+ try
+ TheoryTypeChecker.typecheck (theory_get_current_uri ());
+ "Type Checking was successful"
+ with
+ TheoryTypeChecker.NotWellTyped s ->
+ "Type Checking was NOT successful:\n\t" ^ s
+ in
+ (* next "cast" can't got rid of, but I don't know why *)
+ let errors = (rendering_window#errors : GEdit.text) in
+ let _ = errors#delete_text 0 errors#length in
+ errors#insert output
+;;
+
+let check rendering_window () =
+ let output =
+ try
+ CicTypeChecker.typecheck (get_current_uri ());
+ "Type Checking was successful"
+ with
+ CicTypeChecker.NotWellTyped s -> "Type Checking was NOT successful:\n\t" ^ s
+ in
+ (* next "cast" can't got rid of, but I don't know why *)
+ let errors = (rendering_window#errors : GEdit.text) in
+ let _ = errors#delete_text 0 errors#length in
+ errors#insert output
+;;
+
+let annotateb_pressed rendering_window annotation_window () =
+ let xpath = (rendering_window#output#get_selection : string option) in
+ match xpath with
+ None -> (rendering_window#errors : GEdit.text)#insert "\nNo selection!\n"
+ | Some xpath ->
+ try
+ let annobj = get_annotated_obj ()
+ (* next "cast" can't got rid of, but I don't know why *)
+ and annotation = (annotation_window#annotation : GEdit.text) in
+ ann := CicXPath.get_annotation annobj xpath ;
+ CicAnnotationHinter.create_hints annotation_window annobj xpath ;
+ annotation#delete_text 0 annotation#length ;
+ begin
+ match !(!ann) with
+ None ->
+ annotation#misc#set_sensitive false ;
+ annotation_window#radio_none#set_active true ;
+ radio_some_status := false
+ | Some ann' ->
+ annotation#insert ann' ;
+ annotation#misc#set_sensitive true ;
+ annotation_window#radio_some#set_active true ;
+ radio_some_status := true
+ end ;
+ GMain.Grab.add (annotation_window#window_to_annotate#coerce) ;
+ annotation_window#show () ;
+ with
+ e ->
+ (* next "cast" can't got rid of, but I don't know why *)
+ let errors = (rendering_window#errors : GEdit.text) in
+ errors#insert ("\n" ^ Printexc.to_string e ^ "\n")
+;;
+
+(* called when the annotation is confirmed *)
+let save_annotation annotation =
+ if !radio_some_status then
+ !ann := Some (annotation#get_chars 0 annotation#length)
+ else
+ !ann := None ;
+ match !annotated_obj with
+ None -> raise GtkInterfaceInternalError
+ | Some (annobj,_) ->
+ let uri = get_current_uri () in
+ let annxml = Annotation2Xml.pp_annotation annobj uri in
+ Xml.pp annxml (Some (fst (Getter.get_ann_file_name_and_uri uri)))
+;;
+
+let parse_no_cache uri =
+ let module U = UriManager in
+ XsltProcessor.process uri false "cic"
+;;
+
+
+(* STUFF TO BUILD THE GTK INTERFACE *)
+
+(* Stuff to build the tree window *)
+
+(* selection_changed is actually selection_changed or theory_selection_changed*)
+let mktree selection_changed rendering_window =
+ let rec aux treeitem =
+ function
+ Dir (dirname, content) ->
+ let subtree = GTree.tree () in
+ treeitem#set_subtree subtree ;
+ List.iter
+ (fun ti ->
+ let label = get_name ti
+ and uri = get_uri ti in
+ let treeitem2 = GTree.tree_item ~label:label () in
+ subtree#append treeitem2 ;
+ ignore(treeitem2#connect#select
+ (selection_changed rendering_window uri)) ;
+ aux treeitem2 ti
+ ) !content
+ | _ -> ()
+ in
+ aux
+;;
+
+class annotation_window output label =
+ let window_to_annotate =
+ GWindow.window ~title:"Annotating environment" ~border_width:2 () in
+ let hbox1 =
+ GPack.hbox ~packing:window_to_annotate#add () in
+ let vbox1 =
+ GPack.vbox ~packing:(hbox1#pack ~padding:5) () in
+ let hbox2 =
+ GPack.hbox ~packing:(vbox1#pack ~expand:false ~fill:false ~padding:5) () in
+ let radio_some = GButton.radio_button ~label:"Annotation below"
+ ~packing:(hbox2#pack ~expand:false ~fill:false ~padding:5) () in
+ let radio_none = GButton.radio_button ~label:"No annotation"
+ ~group:radio_some#group
+ ~packing:(hbox2#pack ~expand:false ~fill:false ~padding:5)
+ ~active:true () in
+ let annotation = GEdit.text ~editable:true ~width:400 ~height:180
+ ~packing:(vbox1#pack ~padding:5) () in
+ let table =
+ GPack.table ~rows:3 ~columns:3 ~packing:(vbox1#pack ~padding:5) () in
+ let annotation_hints =
+ Array.init 9
+ (function i ->
+ GButton.button ~label:("Hint " ^ string_of_int i)
+ ~packing:(table#attach ~left:(i mod 3) ~top:(i / 3)) ()
+ ) in
+ let vbox2 =
+ GPack.vbox ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in
+ let confirmb =
+ GButton.button ~label:"O.K."
+ ~packing:(vbox2#pack ~expand:false ~fill:false ~padding:5) () in
+ let abortb =
+ GButton.button ~label:"Abort"
+ ~packing:(vbox2#pack ~expand:false ~fill:false ~padding:5) () in
+object (self)
+ method window_to_annotate = window_to_annotate
+ method annotation = annotation
+ method radio_some = radio_some
+ method radio_none = radio_none
+ method annotation_hints = annotation_hints
+ method output = (output : GMathView.math_view)
+ method show () = window_to_annotate#show ()
+ initializer
+ (* signal handlers here *)
+ ignore (window_to_annotate#event#connect#delete
+ (fun _ ->
+ window_to_annotate#misc#hide () ;
+ GMain.Grab.remove (window_to_annotate#coerce) ;
+ true
+ )) ;
+ ignore (confirmb#connect#clicked
+ (fun () ->
+ window_to_annotate#misc#hide () ;
+ save_annotation annotation ;
+ GMain.Grab.remove (window_to_annotate#coerce) ;
+ let new_current_uri =
+ (snd (Getter.get_ann_file_name_and_uri (get_current_uri ())))
+ in
+ visited_uris := new_current_uri::(List.tl !visited_uris) ;
+ label#set_text (UriManager.string_of_uri new_current_uri) ;
+ output#load (parse_no_cache new_current_uri)
+ )) ;
+ ignore (abortb#connect#clicked
+ (fun () ->
+ window_to_annotate#misc#hide () ;
+ GMain.Grab.remove (window_to_annotate#coerce)
+ ));
+ ignore (radio_some#connect#clicked
+ (fun () -> annotation#misc#set_sensitive true ; radio_some_status := true)) ;
+ ignore (radio_none #connect#clicked
+ (fun () ->
+ annotation#misc#set_sensitive false;
+ radio_some_status := false)
+ )
+end;;
+
+class rendering_window annotation_window output (label : GMisc.label) =
+ let window =
+ GWindow.window ~title:"MathML viewer" ~border_width:2 () in
+ let vbox =
+ GPack.vbox ~packing:window#add () in
+ let _ = vbox#pack ~expand:false ~fill:false ~padding:5 label#coerce in
+ let paned =
+ GPack.paned `HORIZONTAL ~packing:(vbox#pack ~padding:5) () in
+ let scrolled_window0 =
+ GBin.scrolled_window ~border_width:10 ~packing:paned#add1 () in
+ let _ = scrolled_window0#add output#coerce in
+ let scrolled_window =
+ GBin.scrolled_window
+ ~border_width:10 ~packing:paned#add2 ~width:240 ~height:100 () in
+ let errors = GEdit.text ~packing:scrolled_window#add_with_viewport () in
+ let hbox =
+ GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let prevb =
+ GButton.button ~label:"Prev"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let nextb =
+ GButton.button ~label:"Next"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let checkb =
+ GButton.button ~label:"Check"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let annotateb =
+ GButton.button ~label:"Annotate"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let spinb =
+ let sadj =
+ GData.adjustment ~value:14.0 ~lower:5.0 ~upper:50.0 ~step_incr:1.0 ()
+ in
+ GEdit.spin_button
+ ~adjustment:sadj ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5)
+ () in
+ let closeb =
+ GButton.button ~label:"Close"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+object(self)
+ method nextb = nextb
+ method prevb = prevb
+ method label = label
+ method spinb = spinb
+ method output = (output : GMathView.math_view)
+ method errors = errors
+ method show () = window#show ()
+ initializer
+ nextb#misc#set_sensitive false ;
+ prevb#misc#set_sensitive false ;
+
+ (* signal handlers here *)
+ ignore(output#connect#jump (jump self)) ;
+ ignore(nextb#connect#clicked (next self)) ;
+ ignore(prevb#connect#clicked (prev self)) ;
+ ignore(checkb#connect#clicked (check self)) ;
+ ignore(spinb#connect#changed (changefont self)) ;
+ ignore(closeb#connect#clicked window#misc#hide) ;
+ ignore(annotateb#connect#clicked (annotateb_pressed self annotation_window)) ;
+ ignore(window#event#connect#delete (fun _ -> window#misc#hide () ; true ))
+end;;
+
+class theory_rendering_window rendering_window =
+ let window =
+ GWindow.window ~title:"MathML theory viewer" ~border_width:2 () in
+ let vbox =
+ GPack.vbox ~packing:window#add () in
+ let label =
+ GMisc.label ~text:"???"
+ ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let paned =
+ GPack.paned `HORIZONTAL ~packing:(vbox#pack ~padding:5) () in
+ let scrolled_window0 =
+ GBin.scrolled_window ~border_width:10 ~packing:paned#add1 () in
+ let output =
+ GMathView.math_view ~width:400 ~height:380 ~packing:scrolled_window0#add () in
+ let scrolled_window =
+ GBin.scrolled_window
+ ~border_width:10 ~packing:paned#add2 ~width:240 ~height:100 () in
+ let errors = GEdit.text ~packing:scrolled_window#add_with_viewport () in
+ let hbox =
+ GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let prevb =
+ GButton.button ~label:"Prev"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let nextb =
+ GButton.button ~label:"Next"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let checkb =
+ GButton.button ~label:"Check"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let spinb =
+ let sadj =
+ GData.adjustment ~value:14.0 ~lower:5.0 ~upper:50.0 ~step_incr:1.0 ()
+ in
+ GEdit.spin_button
+ ~adjustment:sadj ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5)
+ () in
+ let closeb =
+ GButton.button ~label:"Close"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+object(self)
+ method nextb = nextb
+ method prevb = prevb
+ method label = label
+ method output = (output : GMathView.math_view)
+ method errors = errors
+ method spinb = spinb
+ method show () = window#show ()
+ initializer
+ nextb#misc#set_sensitive false ;
+ prevb#misc#set_sensitive false ;
+
+ (* signal handlers here *)
+ ignore(output#connect#jump (jump rendering_window)) ;
+ ignore(nextb#connect#clicked (theory_next self)) ;
+ ignore(prevb#connect#clicked (theory_prev self)) ;
+ ignore(checkb#connect#clicked (theory_check self)) ;
+ ignore(spinb#connect#changed (changefont self)) ;
+ ignore(closeb#connect#clicked window#misc#hide) ;
+ ignore(window#event#connect#delete (fun _ -> window#misc#hide () ; true ))
+end;;
+
+(* CSC: fare in modo che i due alberi vengano svuotati invece che distrutti *)
+class selection_window theory_rendering_window rendering_window =
+ let label = "cic:/" in
+ let theorylabel = "theory:/" in
+ let win = GWindow.window ~title:"Known uris" ~border_width:2 () in
+ let vbox = GPack.vbox ~packing:win#add () in
+ let hbox1 = GPack.hbox ~packing:(vbox#pack ~padding:5) () in
+ let sw1 = GBin.scrolled_window ~width:250 ~height:600
+ ~packing:(hbox1#pack ~padding:5) () in
+ let tree1 =
+ GTree.tree ~selection_mode:`BROWSE ~packing:sw1#add_with_viewport () in
+ let tree_item1 =
+ GTree.tree_item ~label:theorylabel ~packing:tree1#append () in
+ let sw = GBin.scrolled_window ~width:250 ~height:600
+ ~packing:(hbox1#pack ~padding:5) () in
+ let tree =
+ GTree.tree ~selection_mode:`BROWSE ~packing:sw#add_with_viewport () in
+ let tree_item =
+ GTree.tree_item ~label:label ~packing:tree#append () in
+ let hbox =
+ GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let updateb =
+ GButton.button ~label:"Update"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let quitb =
+ GButton.button ~label:"Quit"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+object (self)
+ method show () = win#show ()
+ initializer
+ mktree theory_selection_changed theory_rendering_window tree_item1
+ (Dir ("theory:/",theoryuritree));
+ mktree selection_changed rendering_window tree_item
+ (Dir ("cic:/",uritree));
+
+ (* signal handlers here *)
+ ignore (tree_item1#connect#select
+ ~callback:(theory_selection_changed theory_rendering_window None)) ;
+ ignore (tree_item#connect#select
+ ~callback:(selection_changed rendering_window None)) ;
+ ignore (win#connect#destroy ~callback:GMain.Main.quit) ;
+ ignore (quitb#connect#clicked GMain.Main.quit) ;
+ ignore(updateb#connect#clicked (updateb_pressed
+ theory_rendering_window rendering_window (ref sw1, ref sw, hbox1) mktree))
+end;;
+
+
+(* MAIN *)
+
+let _ =
+ build_uri_tree () ;
+ let output = GMathView.math_view ~width:400 ~height:380 ()
+ and label = GMisc.label ~text:"???" () in
+ let annotation_window = new annotation_window output label in
+ let rendering_window = new rendering_window annotation_window output label in
+ let theory_rendering_window = new theory_rendering_window rendering_window in
+ let selection_window =
+ new selection_window theory_rendering_window rendering_window
+ in
+ selection_window#show () ;
+ GMain.Main.main ()
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 11/10/2000 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+let resolve =
+ function
+ "http://localhost:8081/getdtd?url=cic.dtd" ->
+ "/home/pauillac/coq3/sacerdot/HELM/INTERFACE/examples/dtd/cic.dtd"
+ | "http://localhost:8081/getdtd?url=maththeory.dtd" ->
+ "/home/pauillac/coq3/sacerdot/HELM/INTERFACE/examples/dtd/maththeory.dtd"
+ | "http://localhost:8081/getdtd?url=annotations.dtd" ->
+ "/home/pauillac/coq3/sacerdot/HELM/INTERFACE/examples/dtd/annotations.dtd"
+ | s -> s
+;;
+
+let url_syntax =
+ let enable_if =
+ function
+ `Not_recognized -> Neturl.Url_part_not_recognized
+ | `Allowed -> Neturl.Url_part_allowed
+ | `Required -> Neturl.Url_part_required
+ in
+ { Neturl.null_url_syntax with
+ Neturl.url_enable_scheme = enable_if `Allowed;
+ Neturl.url_enable_host = enable_if `Allowed;
+ Neturl.url_enable_path = Neturl.Url_part_required;
+ Neturl.url_accepts_8bits = true;
+ }
+;;
+
+let file_url_of_id xid =
+ let file_url_of_sysname sysname =
+ (* By convention, we can assume that sysname is a URL conforming
+ * to RFC 1738 with the exception that it may contain non-ASCII
+ * UTF-8 characters.
+ *)
+ try
+ Neturl.url_of_string url_syntax sysname
+ (* may raise Malformed_URL *)
+ with
+ Neturl.Malformed_URL -> raise Pxp_reader.Not_competent
+ in
+ let url =
+ match xid with
+ Pxp_types.Anonymous -> raise Pxp_reader.Not_competent
+ | Pxp_types.Public (_,sysname) ->
+ let sysname = resolve sysname in
+ if sysname <> "" then file_url_of_sysname sysname
+ else raise Pxp_reader.Not_competent
+ | Pxp_types.System sysname ->
+ let sysname = resolve sysname in
+ file_url_of_sysname sysname
+ in
+ let scheme =
+ try Neturl.url_scheme url with Not_found -> "file" in
+ let host =
+ try Neturl.url_host url with Not_found -> "" in
+
+ if scheme <> "file" then raise Pxp_reader.Not_competent;
+ if host <> "" && host <> "localhost" then raise Pxp_reader.Not_competent;
+
+ url
+;;
+
+let from_file ?system_encoding utf8_filename =
+
+ let r =
+ new Pxp_reader.resolve_as_file
+ ?system_encoding:system_encoding
+ ~url_of_id:file_url_of_id
+ ()
+ in
+
+ let utf8_abs_filename =
+ if utf8_filename <> "" && utf8_filename.[0] = '/' then
+ utf8_filename
+ else
+ Sys.getcwd() ^ "/" ^ utf8_filename
+ in
+
+ let syntax = { Neturl.ip_url_syntax with Neturl.url_accepts_8bits = true } in
+ let url = Neturl.make_url
+ ~scheme:"file"
+ ~host:"localhost"
+ ~path:(Neturl.split_path utf8_abs_filename)
+ syntax
+ in
+
+ let xid = Pxp_types.System (Neturl.string_of_url url) in
+
+
+ Pxp_yacc.ExtID(xid, r)
+;;
+
+
--- /dev/null
+let read_from_stdin = ref false;;
+let uris_in_input = ref false;;
+let reduction_only = ref false;;
+
+let parse uri =
+ print_endline ("^^^" ^ uri ^ "^^^") ;
+ print_string (CicPp.ppobj (CicCache.get_obj (UriManager.uri_of_string uri))) ;
+ print_endline ("\n$$$" ^ uri ^ "$$$\n")
+;;
+
+let uri_of_filename fn =
+ if !uris_in_input then fn
+ else
+ let uri =
+ Str.replace_first (Str.regexp (Str.quote Configuration.helm_dir)) "cic:" fn
+ in
+ let uri' = Str.replace_first (Str.regexp "\.xml$") "" uri in
+ uri'
+;;
+
+(* filenames are read from command line and converted to uris via *)
+(* uri_of_filenames; then the cic terms are load in cache via *)
+(* CicCache.get_obj and then pretty printed via CicPp.ppobj *)
+
+exception NotADefinition;;
+
+let main () =
+ let files = ref [] in
+ Arg.parse
+ ["-stdin", Arg.Set read_from_stdin, "Read from stdin" ;
+ "-uris", Arg.Set uris_in_input, "Read uris, not filenames" ;
+ "-update", Arg.Unit Getter.update, "Update the getter view of the world" ;
+ "-reduction", Arg.Set reduction_only, "Do reduction instead of tyepchecking"]
+ (fun x -> files := (uri_of_filename x) :: !files)
+ "
+usage: experiment file ...
+
+List of options:";
+ if !read_from_stdin then
+ begin
+ try
+ while true do
+ let l = Str.split (Str.regexp " ") (read_line ()) in
+ List.iter (fun x -> files := (uri_of_filename x) :: !files) l
+ done
+ with
+ End_of_file -> ()
+ end ;
+ files := List.rev !files;
+ List.iter
+ (function x ->
+ print_string x ;
+ flush stdout ;
+ (try
+ if !reduction_only then
+ match CicCache.get_obj (UriManager.uri_of_string x) with
+ Cic.Definition (_,bo,_,_) ->
+ CicTypeChecker.typecheck (UriManager.uri_of_string x) ;
+ ignore (CicReduction.whd bo)
+ | _ -> raise NotADefinition
+ else
+ CicTypeChecker.typecheck (UriManager.uri_of_string x)
+ with
+ e -> print_newline () ; flush stdout ; raise e ) ;
+ print_endline " OK!" ;
+ flush stdout
+ ) !files
+;;
+
+main ();;
--- /dev/null
+http://caristudenti.students.cs.unibo.it/~sacerdot/helm
+http://pagadebit.students.cs.unibo.it/really_very_local/helm/PARSER/examples
--- /dev/null
+http://rigoletto.casamia.csc/helm1/coq
+http://rigoletto.casamia.csc/helm2/coq
--- /dev/null
+http://phd.cs.unibo.it/helm/PARSER/examples
+http://caristudenti.students.cs.unibo.it/~sacerdot/helm
--- /dev/null
+type theory_elem =
+ Theorem of string (* uri *)
+ | Definition of string (* uri *)
+ | Axiom of string (* uri *)
+ | Variable of string (* uri *)
+ | Section of string * theory_elem list (* uri, subtheory *)
+and theory =
+ string * theory_elem list (* uri, subtheory *)
+;;
--- /dev/null
+type check_status = Checked | Unchecked;;
+
+let hashtable = Hashtbl.create 17;;
+
+let get_term_and_type_checking_info uri =
+ try
+ Hashtbl.find hashtable uri
+ with
+ Not_found ->
+ let filename = Getter.get uri in
+ let term = TheoryParser.theory_of_xml filename in
+ Hashtbl.add hashtable uri (term, Unchecked) ;
+ (term, Unchecked)
+;;
+
+
+let get_theory uri =
+ fst (get_term_and_type_checking_info uri)
+;;
+
+let is_type_checked uri =
+ match snd (get_term_and_type_checking_info uri) with
+ Checked -> true
+ | Unchecked -> false
+;;
+
+let set_type_checking_info uri =
+ match Hashtbl.find hashtable uri with
+ (term, _) ->
+ Hashtbl.remove hashtable uri ;
+ Hashtbl.add hashtable uri (term, Checked)
+;;
--- /dev/null
+exception Warnings;;
+
+class warner =
+ object
+ method warn w =
+ print_endline ("WARNING: " ^ w) ;
+ (raise Warnings : unit)
+ end
+;;
+
+exception EmptyUri;;
+
+let theory_of_xml filename =
+ let module Y = Pxp_yacc in
+ try
+ let d =
+ let config = {Y.default_config with Y.warner = new warner} in
+ Y.parse_document_entity config
+(*PXP (Y.ExtID (Pxp_types.System filename,
+ new Pxp_reader.resolve_as_file ~url_of_id ()))
+*) (PxpUriResolver.from_file filename)
+ Y.default_spec
+ in
+ TheoryParser2.get_theory d#root
+ with
+ e ->
+ print_endline (Pxp_types.string_of_exn e) ;
+ raise e
+;;
--- /dev/null
+exception IllFormedXml of int;;
+
+(* Utility functions that transform a Pxp attribute into something useful *)
+
+let string_of_attr a =
+ let module T = Pxp_types in
+ match a with
+ T.Value s -> s
+ | _ -> raise (IllFormedXml 0)
+
+let get_theory n =
+ let module D = Pxp_document in
+ let module T = Theory in
+ let rec get_theory_elem n =
+ let ntype = n # node_type in
+ match ntype with
+ D.T_element "THEOREM" ->
+ let uri = string_of_attr (n # attribute "uri") in
+ T.Theorem uri
+ | D.T_element "DEFINITION" ->
+ let uri = string_of_attr (n # attribute "uri") in
+ T.Definition uri
+ | D.T_element "AXIOM" ->
+ let uri = string_of_attr (n # attribute "uri") in
+ T.Axiom uri
+ | D.T_element "VARIABLE" ->
+ let uri = string_of_attr (n # attribute "uri") in
+ T.Variable uri
+ | D.T_element "SECTION" ->
+ let uri = string_of_attr (n # attribute "uri")
+ and subtheory = List.map get_theory_elem (n # sub_nodes) in
+ T.Section (uri, subtheory)
+ | D.T_element _ | D.T_data | _ ->
+ raise (IllFormedXml 1)
+ in
+ match n # node_type with
+ D.T_element "Theory" ->
+ let uri = string_of_attr (n # attribute "uri") in
+ (uri, List.map get_theory_elem (n # sub_nodes))
+ | _ -> raise (IllFormedXml 2)
+;;
--- /dev/null
+exception NotWellTyped of string;;
+
+let typecheck uri =
+ let rec typecheck_term curi t =
+ let module T = Theory in
+ let module P = CicTypeChecker in
+ let module C = CicCache in
+ let module U = UriManager in
+ let obj_typecheck uri =
+ try
+ P.typecheck (U.uri_of_string uri)
+ with
+ P.NotWellTyped s ->
+ raise (NotWellTyped
+ ("Type Checking was NOT successfull due to an error during " ^
+ "type-checking of term " ^ uri ^ ":\n\n" ^ s))
+ in
+ match t with
+ T.Theorem uri -> obj_typecheck (curi ^ "/" ^ uri)
+ | T.Definition uri -> obj_typecheck (curi ^ "/" ^ uri)
+ | T.Axiom uri -> obj_typecheck (curi ^ "/" ^ uri)
+ | T.Variable uri -> obj_typecheck (curi ^ "/" ^ uri)
+ | T.Section (uri,l) -> typecheck_theory l (curi ^ "/" ^ uri)
+ and typecheck_theory l curi =
+ List.iter (typecheck_term curi) l
+ in
+ let (uri, l) = TheoryCache.get_theory uri in
+ typecheck_theory l uri
+;;
--- /dev/null
+#!/usr/bin/perl
+
+while(<STDIN>)
+{
+ s/helm:xref="[^"]*"//g;
+ s/helm:xref='[^']*'//g;
+ print;
+}
--- /dev/null
+#!/bin/bash
+
+echo "****" $1
+cp $1 /tmp/pippo
+cat /tmp/pippo | ./toglie_helm_xref.pl > $1
--- /dev/null
+(* "cic:/a/b/c.con" => [| "cic:/a" ; "cic:/a/b" ; "cic:/a/b/c.con" ; "c" |] *)
+type uri = string array;;
+
+let eq uri1 uri2 =
+ uri1 == uri2
+;;
+
+let string_of_uri uri = uri.(Array.length uri - 2);;
+let name_of_uri uri = uri.(Array.length uri - 1);;
+let buri_of_uri uri = uri.(Array.length uri - 3);;
+let depth_of_uri uri = Array.length uri - 2;;
+
+(*CSC: ora e' diventato poco efficiente, migliorare *)
+let relative_depth curi uri cookingsno =
+ let rec length_of_current_prefix l1 l2 =
+ match (l1, l2) with
+ (he1::tl1, he2::tl2) when he1 == he2 ->
+ 1 + length_of_current_prefix tl1 tl2
+ | (_,_) -> 0
+ in
+ depth_of_uri uri -
+ length_of_current_prefix
+ (Array.to_list (Array.sub curi 0 (Array.length curi - (2 + cookingsno))))
+ (Array.to_list (Array.sub uri 0 (Array.length uri - 2)))
+ (*CSC: vecchio codice da eliminare
+ if eq curi uri then 0
+ else
+ depth_of_uri uri -
+ length_of_current_prefix (Array.to_list curi) (Array.to_list uri)
+ *)
+;;
+
+module OrderedStrings =
+ struct
+ type t = string
+ let compare (s1 : t) (s2 : t) = compare s1 s2
+ end
+;;
+
+module SetOfStrings = Map.Make(OrderedStrings);;
+
+(*CSC: commento obsoleto ed errato *)
+(* Invariant: the map is the identity function, *)
+(* i.e. (SetOfStrings.find str !set_of_uri) == str *)
+let set_of_uri = ref SetOfStrings.empty;;
+let set_of_prefixes = ref SetOfStrings.empty;;
+
+(* similar to uri_of_string, but used for prefixes of uris *)
+let normalize prefix =
+ try
+ SetOfStrings.find prefix !set_of_prefixes
+ with
+ Not_found ->
+ set_of_prefixes := SetOfStrings.add prefix prefix !set_of_prefixes ;
+ prefix
+;;
+
+exception IllFormedUri of string;;
+
+let mk_prefixes str =
+ let rec aux curi =
+ function
+ [he] ->
+ let prefix_uri = curi ^ "/" ^ he
+ and name = List.hd (Str.split (Str.regexp "\.") he) in
+ [ normalize prefix_uri ; name ]
+ | he::tl ->
+ let prefix_uri = curi ^ "/" ^ he in
+ (normalize prefix_uri)::(aux prefix_uri tl)
+ | _ -> raise (IllFormedUri str)
+ in
+ let tokens = (Str.split (Str.regexp "/") str) in
+ (* ty = "cic:" *)
+ let (ty, sp) = (List.hd tokens, List.tl tokens) in
+ aux ty sp
+;;
+
+let uri_of_string str =
+ try
+ SetOfStrings.find str !set_of_uri
+ with
+ Not_found ->
+ let uri = Array.of_list (mk_prefixes str) in
+ set_of_uri := SetOfStrings.add str uri !set_of_uri ;
+ uri
+;;
--- /dev/null
+type uri = string;;
+
+let eq uri1 uri2 =
+ uri1 = uri2
+;;
+
+let string_of_uri uri = uri;;
+let uri_of_string str = str;;
+
+let name_of_uri uri =
+ let l = Str.split (Str.regexp "/") uri in
+ let name_suf = List.nth l (List.length l - 1) in
+ List.hd (Str.split (Str.regexp "\.") name_suf)
+;;
+
+let depth_of_uri uri =
+ List.length (Str.split (Str.regexp "/") uri) - 2
+;;
--- /dev/null
+(* "cic:/a/b/c.con" => [| "cic:/a" ; "cic:/a/b" ; "cic:/a/b/c.con" ; "c" |] *)
+type uri = string array;;
+
+let eq uri1 uri2 =
+ uri1 == uri2
+;;
+
+let string_of_uri uri = uri.(Array.length uri - 2);;
+let name_of_uri uri = uri.(Array.length uri - 1);;
+let buri_of_uri uri = uri.(Array.length uri - 3);;
+let depth_of_uri uri = Array.length uri - 2;;
+
+(*CSC: ora e' diventato poco efficiente, migliorare *)
+let relative_depth curi uri cookingsno =
+ let rec length_of_current_prefix l1 l2 =
+ match (l1, l2) with
+ (he1::tl1, he2::tl2) when he1 == he2 ->
+ 1 + length_of_current_prefix tl1 tl2
+ | (_,_) -> 0
+ in
+ depth_of_uri uri -
+ length_of_current_prefix
+ (Array.to_list (Array.sub curi 0 (Array.length curi - (2 + cookingsno))))
+ (Array.to_list (Array.sub uri 0 (Array.length uri - 2)))
+ (*CSC: vecchio codice da eliminare
+ if eq curi uri then 0
+ else
+ depth_of_uri uri -
+ length_of_current_prefix (Array.to_list curi) (Array.to_list uri)
+ *)
+;;
+
+module OrderedStrings =
+ struct
+ type t = string
+ let compare (s1 : t) (s2 : t) = compare s1 s2
+ end
+;;
+
+module SetOfStrings = Map.Make(OrderedStrings);;
+
+(*CSC: commento obsoleto ed errato *)
+(* Invariant: the map is the identity function, *)
+(* i.e. (SetOfStrings.find str !set_of_uri) == str *)
+let set_of_uri = ref SetOfStrings.empty;;
+let set_of_prefixes = ref SetOfStrings.empty;;
+
+(* similar to uri_of_string, but used for prefixes of uris *)
+let normalize prefix =
+ try
+ SetOfStrings.find prefix !set_of_prefixes
+ with
+ Not_found ->
+ set_of_prefixes := SetOfStrings.add prefix prefix !set_of_prefixes ;
+ prefix
+;;
+
+exception IllFormedUri of string;;
+
+let mk_prefixes str =
+ let rec aux curi =
+ function
+ [he] ->
+ let prefix_uri = curi ^ "/" ^ he
+ and name = List.hd (Str.split (Str.regexp "\.") he) in
+ [ normalize prefix_uri ; name ]
+ | he::tl ->
+ let prefix_uri = curi ^ "/" ^ he in
+ (normalize prefix_uri)::(aux prefix_uri tl)
+ | _ -> raise (IllFormedUri str)
+ in
+ let tokens = (Str.split (Str.regexp "/") str) in
+ (* ty = "cic:" *)
+ let (ty, sp) = (List.hd tokens, List.tl tokens) in
+ aux ty sp
+;;
+
+let uri_of_string str =
+ try
+ SetOfStrings.find str !set_of_uri
+ with
+ Not_found ->
+ let uri = Array.of_list (mk_prefixes str) in
+ set_of_uri := SetOfStrings.add str uri !set_of_uri ;
+ uri
+;;
--- /dev/null
+type uri = string;;
+
+let eq uri1 uri2 =
+ uri1 == uri2
+;;
+
+let string_of_uri uri = uri;;
+
+let name_of_uri uri =
+ let l = Str.split (Str.regexp "/") uri in
+ let name_suf = List.nth l (List.length l - 1) in
+ List.hd (Str.split (Str.regexp "\.") name_suf)
+;;
+
+let depth_of_uri uri =
+ List.length (Str.split (Str.regexp "/") uri) - 2
+;;
+
+module OrderedStrings =
+ struct
+ type t = string
+ let compare (s1 : t) (s2 : t) = compare s1 s2
+ end
+;;
+
+module SetOfStrings = Map.Make(OrderedStrings);;
+
+(* Invariant: the map is the identity function, *)
+(* i.e. (SetOfStrings.find str !set_of_uri) == str *)
+let set_of_uri = ref SetOfStrings.empty;;
+
+let uri_of_string str =
+ try
+ SetOfStrings.find str !set_of_uri
+ with
+ Not_found ->
+ set_of_uri := SetOfStrings.add str str !set_of_uri ;
+ str
+;;
--- /dev/null
+type uri
+
+val eq : uri -> uri -> bool
+
+val uri_of_string : string -> uri
+
+val string_of_uri : uri -> string (* complete uri *)
+val name_of_uri : uri -> string (* name only (without extension)*)
+val buri_of_uri : uri -> string (* base uri only *)
+val depth_of_uri : uri -> int (* length of the path *)
+
+(* relative_depth curi uri cookingsno *)
+(* is the number of times to cook uri to use it when the current uri is curi *)
+(* cooked cookingsno times *)
+val relative_depth : uri -> uri -> int -> int
--- /dev/null
+#!/usr/bin/perl
+
+while(<STDIN>) {
+ chomp;
+ split / /;
+ for (@_) {
+ if (/.*\.(con|var|ind)\.xml/)
+ { s/\./cic:/; }
+ elsif (/.*\.theory\.xml/)
+ { s/\./theory:/; }
+ s/\.xml//;
+ print;
+ print "\n";
+ }
+}
--- /dev/null
+// Base header file. Must be first.
+#include <Include/PlatformDefinitions.hpp>
+
+#include <iostream>
+#include <fstream>
+
+#include <util/PlatformUtils.hpp>
+
+#include <PlatformSupport/DOMStringHelper.hpp>
+
+#include <DOMSupport/DOMSupportDefault.hpp>
+
+#include <XPath/XObjectFactoryDefault.hpp>
+#include <XPath/XPathSupportDefault.hpp>
+#include <XPath/XPathFactoryDefault.hpp>
+
+#include <XSLT/StylesheetConstructionContextDefault.hpp>
+#include <XSLT/StylesheetExecutionContextDefault.hpp>
+#include <XSLT/XSLTEngineImpl.hpp>
+#include <XSLT/XSLTInit.hpp>
+#include <XSLT/XSLTInputSource.hpp>
+#include <XSLT/XSLTProcessorEnvSupportDefault.hpp>
+#include <XSLT/XSLTResultTarget.hpp>
+
+#include <XercesParserLiaison/XercesDOMSupport.hpp>
+#include <XercesParserLiaison/XercesParserLiaison.hpp>
+
+int main(int argc, const char* [])
+{
+#if !defined(XALAN_NO_NAMESPACES)
+ using std::cerr;
+ using std::endl;
+ using std::ofstream;
+#endif
+
+ if (argc != 1) {
+ cerr << "Usage: SimpleTransform"
+ << endl
+ << endl;
+ } else {
+ try {
+ // Call the static initializer for Xerces...
+ XMLPlatformUtils::Initialize();
+
+ {
+ // Initialize the Xalan XSLT subsystem...
+ XSLTInit theInit;
+
+ // Create the support objects that are necessary for
+ // running the processor...
+ XercesDOMSupport theDOMSupport;
+ XercesParserLiaison theParserLiaison(theDOMSupport);
+ XPathSupportDefault theXPathSupport(theDOMSupport);
+ XSLTProcessorEnvSupportDefault theXSLTProcessorEnvSupport;
+ XObjectFactoryDefault theXObjectFactory;
+ XPathFactoryDefault theXPathFactory;
+
+ // Create a processor...
+ XSLTEngineImpl theProcessor(
+ theParserLiaison,
+ theXPathSupport,
+ theXSLTProcessorEnvSupport,
+ theDOMSupport,
+ theXObjectFactory,
+ theXPathFactory);
+
+ // Connect the processor to the support object...
+ theXSLTProcessorEnvSupport.setProcessor(&theProcessor);
+
+ // Create a stylesheet construction context, and a stylesheet
+ // execution context...
+ StylesheetConstructionContextDefault theConstructionContext(
+ theProcessor,
+ theXSLTProcessorEnvSupport,
+ theXPathFactory);
+
+ StylesheetExecutionContextDefault theExecutionContext(
+ theProcessor,
+ theXSLTProcessorEnvSupport,
+ theXPathSupport,
+ theXObjectFactory);
+
+ // Our input files...The assumption is that the executable will be
+ // run from same directory as the input files.
+ const XalanDOMString theXMLFileName("foo.xml");
+ const XalanDOMString theXSLFileName("foo.xsl");
+
+ // Our input sources...
+ XSLTInputSource theInputSource(c_wstr(theXMLFileName));
+ XSLTInputSource theStylesheetSource(c_wstr(theXSLFileName));
+
+ // Our output target...
+ const XalanDOMString theOutputFileName("foo.out");
+ XSLTResultTarget theResultTarget(theOutputFileName);
+
+ theProcessor.process(
+ theInputSource,
+ theStylesheetSource,
+ theResultTarget,
+ theConstructionContext,
+ theExecutionContext);
+
+ }
+
+ // Call the static terminator for Xerces...
+ XMLPlatformUtils::Terminate();
+ }
+ catch(...) {
+ cerr << "Exception caught!!!"
+ << endl
+ << endl;
+ }
+ }
+
+ return 0;
+}
+
+/**************************************************/
+/*
+
+public class xaland {
+ public static void Transform(StylesheetRoot style, String xmlSourceURL, String OutputURL) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException
+ {
+ XSLTInputSource xmlSource = new XSLTInputSource (xmlSourceURL);
+ XSLTResultTarget xmlResult = new XSLTResultTarget (OutputURL);
+ style.process(xmlSource, xmlResult);
+ }
+
+ public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException
+ {
+ int port = Integer.parseInt(argv[0]);
+ int port2 = Integer.parseInt(argv[1]);
+ String xsl1 = argv[2];
+ String xsl2 = argv[3];
+ String theory_xsl1 = argv[4];
+ String theory_xsl2 = argv[5];
+
+ XSLTProcessor theory_processor =
+ XSLTProcessorFactory.getProcessor(new org.apache.xalan.xpath.xdom.XercesLiaison());
+ StylesheetRoot theory_style1 =
+ theory_processor.processStylesheet(theory_xsl1);
+ theory_processor.reset();
+ StylesheetRoot theory_style2 =
+ theory_processor.processStylesheet(theory_xsl2);
+ theory_processor.setStylesheet(theory_style2);
+
+ XSLTProcessor processor =
+ XSLTProcessorFactory.getProcessor(new org.apache.xalan.xpath.xdom.XercesLiaison());
+ StylesheetRoot style1 = processor.processStylesheet(xsl1);
+ processor.reset();
+ StylesheetRoot style2 = processor.processStylesheet(xsl2);
+ processor.setStylesheet(style2);
+
+ DatagramSocket socket = new DatagramSocket(port);
+
+ System.out.println("Demon activated on input port " + port +
+ " and output port " + port2);
+ while(true) {
+ System.out.print("Ready...");
+
+ /* Warning: the packet must be a fresh one! * /
+ DatagramPacket packet = new DatagramPacket(new byte[1024],1024);
+ socket.receive(packet);
+ byte data[] = packet.getData();
+ int datalen = packet.getLength();
+ String received = new String(data,0,datalen);
+
+ int first = received.indexOf(' ');
+ int last = received.lastIndexOf(' ');
+ String mode = received.substring(0,first);
+ String input = received.substring(first+1,last);
+ String output = received.substring(last+1);
+
+ System.out.println("request received! Parameters are");
+ System.out.println("Mode: " + mode + " ");
+ System.out.println("Input file: \"" + input + "\"");
+ System.out.println("Output file: \"" + output + "\"\n");
+
+ if ((new File(output)).exists()) {
+ System.out.println("Using cached version\n");
+ } else {
+ FileOutputStream fout = new FileOutputStream(output);
+ if (mode.equals("cic")) {
+ processor.setDocumentHandler(style2.getSAXSerializer(fout));
+ XSLTResultTarget content = new XSLTResultTarget(processor);
+ style1.process(new XSLTInputSource(input), content);
+ } else if (mode.equals("theory")) {
+ theory_processor.setDocumentHandler(
+ theory_style2.getSAXSerializer(fout));
+ XSLTResultTarget content =
+ new XSLTResultTarget(theory_processor);
+ theory_style1.process(new XSLTInputSource(input), content);
+ }
+ }
+
+ InetAddress address = InetAddress.getLocalHost();
+ DatagramSocket socket2 = new DatagramSocket();
+
+ byte buf[] = new byte[0];
+ DatagramPacket packet2 = new DatagramPacket(buf,0,address,port2);
+
+ socket2.send(packet2);
+ }
+ }
+}
+
+*/
--- /dev/null
+import java.net.*;
+
+public class rompi {
+ public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException
+ {
+ /* Wait forever ;-) */
+ DatagramSocket socket2 = new DatagramSocket(12346);
+ DatagramPacket packet2 = new DatagramPacket(new byte[1],1);
+ System.out.println("Ho preso il socket e non lo lascio piu', caro pu, caro pu");
+ socket2.receive(packet2);
+ }
+}
--- /dev/null
+import java.net.*;
+
+public class sped {
+ public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException
+ {
+ String input = argv[0];
+ String out1 = argv[1];
+ String out2 = argv[2];
+
+ String sent = input + " " + out1 + " " + out2;
+
+ InetAddress address = InetAddress.getLocalHost();
+ DatagramSocket socket = new DatagramSocket();
+
+ int strlen = sent.length();
+ byte buf[] = new byte[strlen];
+ sent.getBytes(0,strlen,buf,0);
+ DatagramPacket packet = new DatagramPacket(buf,strlen,address,12345);
+
+ socket.send(packet);
+
+
+ /* Wait for answer (or forever ;-) */
+ DatagramSocket socket2 = new DatagramSocket(12346);
+ DatagramPacket packet2 = new DatagramPacket(new byte[1],1);
+ socket2.receive(packet2);
+ }
+}
--- /dev/null
+import org.apache.xalan.xslt.*;
+import java.net.*;
+import java.io.*;
+
+public class xaland {
+ public static void Transform(StylesheetRoot style, String xmlSourceURL, String OutputURL) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException
+ {
+ XSLTInputSource xmlSource = new XSLTInputSource (xmlSourceURL);
+ XSLTResultTarget xmlResult = new XSLTResultTarget (OutputURL);
+ style.process(xmlSource, xmlResult);
+ }
+
+ public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException
+ {
+ int port = Integer.parseInt(argv[0]);
+ int port2 = Integer.parseInt(argv[1]);
+ String xsl1 = argv[2];
+ String xsl2 = argv[3];
+ String theory_xsl1 = argv[4];
+ String theory_xsl2 = argv[5];
+
+ XSLTProcessor theory_processor =
+ XSLTProcessorFactory.getProcessor(new org.apache.xalan.xpath.xdom.XercesLiaison());
+ StylesheetRoot theory_style1 =
+ theory_processor.processStylesheet(theory_xsl1);
+ theory_processor.reset();
+ StylesheetRoot theory_style2 =
+ theory_processor.processStylesheet(theory_xsl2);
+ theory_processor.setStylesheet(theory_style2);
+
+ XSLTProcessor processor =
+ XSLTProcessorFactory.getProcessor(new org.apache.xalan.xpath.xdom.XercesLiaison());
+ StylesheetRoot style1 = processor.processStylesheet(xsl1);
+ processor.reset();
+ StylesheetRoot style2 = processor.processStylesheet(xsl2);
+ processor.setStylesheet(style2);
+
+ DatagramSocket socket = new DatagramSocket(port);
+
+ System.out.println("Demon activated on input port " + port +
+ " and output port " + port2);
+ while(true) {
+ System.out.print("Ready...");
+
+ /* Warning: the packet must be a fresh one! */
+ DatagramPacket packet = new DatagramPacket(new byte[1024],1024);
+ socket.receive(packet);
+ byte data[] = packet.getData();
+ int datalen = packet.getLength();
+ String received = new String(data,0,datalen);
+
+ int first = received.indexOf(' ');
+ int last = received.lastIndexOf(' ');
+ String mode = received.substring(0,first);
+ String input = received.substring(first+1,last);
+ String output = received.substring(last+1);
+
+ System.out.println("request received! Parameters are");
+ System.out.println("Mode: " + mode + " ");
+ System.out.println("Input file: \"" + input + "\"");
+ System.out.println("Output file: \"" + output + "\"\n");
+
+ if ((new File(output)).exists()) {
+ System.out.println("Using cached version\n");
+ } else {
+ FileOutputStream fout = new FileOutputStream(output);
+ if (mode.equals("cic")) {
+ processor.setDocumentHandler(style2.getSAXSerializer(fout));
+ XSLTResultTarget content = new XSLTResultTarget(processor);
+ style1.process(new XSLTInputSource(input), content);
+ } else if (mode.equals("theory")) {
+ theory_processor.setDocumentHandler(
+ theory_style2.getSAXSerializer(fout));
+ XSLTResultTarget content =
+ new XSLTResultTarget(theory_processor);
+ theory_style1.process(new XSLTInputSource(input), content);
+ }
+ }
+
+ InetAddress address = InetAddress.getLocalHost();
+ DatagramSocket socket2 = new DatagramSocket();
+
+ byte buf[] = new byte[0];
+ DatagramPacket packet2 = new DatagramPacket(buf,0,address,port2);
+
+ socket2.send(packet2);
+ }
+ }
+}
--- /dev/null
+import org.apache.xalan.xslt.*;
+import java.net.*;
+import java.io.*;
+
+public class xaland {
+ public static void Transform(StylesheetRoot style, String xmlSourceURL, String OutputURL) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException
+ {
+ XSLTInputSource xmlSource = new XSLTInputSource (xmlSourceURL);
+ XSLTResultTarget xmlResult = new XSLTResultTarget (OutputURL);
+ style.process(xmlSource, xmlResult);
+ }
+
+ public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException
+ {
+ int port = Integer.parseInt(argv[0]);
+ int port2 = Integer.parseInt(argv[1]);
+ String xsl1 = argv[2];
+ String xsl2 = argv[3];
+ String theory_xsl1 = argv[4];
+ String theory_xsl2 = argv[5];
+
+ XSLTProcessor theory_processor = XSLTProcessorFactory.getProcessor();
+ StylesheetRoot theory_style1 =
+ theory_processor.processStylesheet(theory_xsl1);
+ StylesheetRoot theory_style2 =
+ theory_processor.processStylesheet(theory_xsl2);
+ theory_processor.setStylesheet(theory_style2);
+
+ XSLTProcessor processor = XSLTProcessorFactory.getProcessor();
+ StylesheetRoot style1 = processor.processStylesheet(xsl1);
+ StylesheetRoot style2 = processor.processStylesheet(xsl2);
+ processor.setStylesheet(style2);
+
+ DatagramSocket socket = new DatagramSocket(port);
+
+ System.out.println("Demon activated on input port " + port +
+ " and output port " + port2);
+ while(true) {
+ System.out.print("Ready...");
+
+ /* Warning: the packet must be a fresh one! */
+ DatagramPacket packet = new DatagramPacket(new byte[1024],1024);
+ socket.receive(packet);
+ byte data[] = packet.getData();
+ int datalen = packet.getLength();
+ String received = new String(data,0,datalen);
+
+ int first = received.indexOf(' ');
+ int last = received.lastIndexOf(' ');
+ String mode = received.substring(0,first);
+ String input = received.substring(first+1,last);
+ String output = received.substring(last+1);
+
+ System.out.println("request received! Parameters are");
+ System.out.println("Mode: " + mode + " ");
+ System.out.println("Input file: \"" + input + "\"");
+ System.out.println("Output file: \"" + output + "\"\n");
+
+ if ((new File(output)).exists()) {
+ System.out.println("Using cached version\n");
+ } else {
+ FileOutputStream fout = new FileOutputStream(output);
+ if (mode.equals("cic")) {
+ processor.setDocumentHandler(style2.getSAXSerializer(fout));
+ XSLTResultTarget content = new XSLTResultTarget(processor);
+ style1.process(new XSLTInputSource(input), content);
+ } else if (mode.equals("theory")) {
+ theory_processor.setDocumentHandler(
+ theory_style2.getSAXSerializer(fout));
+ XSLTResultTarget content =
+ new XSLTResultTarget(theory_processor);
+ theory_style1.process(new XSLTInputSource(input), content);
+ }
+ }
+
+ InetAddress address = InetAddress.getLocalHost();
+ DatagramSocket socket2 = new DatagramSocket();
+
+ byte buf[] = new byte[0];
+ DatagramPacket packet2 = new DatagramPacket(buf,0,address,port2);
+
+ socket2.send(packet2);
+ }
+ }
+}
--- /dev/null
+import org.apache.xalan.xslt.*;
+import java.net.*;
+import java.io.*;
+
+public class xaland {
+ public static void Transform(StylesheetRoot style, String xmlSourceURL, String OutputURL) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException
+ {
+ XSLTInputSource xmlSource = new XSLTInputSource (xmlSourceURL);
+ XSLTResultTarget xmlResult = new XSLTResultTarget (OutputURL);
+ style.process(xmlSource, xmlResult);
+ }
+
+ public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException
+ {
+ int port = Integer.parseInt(argv[0]);
+ int port2 = Integer.parseInt(argv[1]);
+ String xsl1 = argv[2];
+ String xsl2 = argv[3];
+ String theory_xsl1 = argv[4];
+ String theory_xsl2 = argv[5];
+
+ XSLTProcessor theory_processor = XSLTProcessorFactory.getProcessor();
+ StylesheetRoot theory_style1 =
+ theory_processor.processStylesheet(theory_xsl1);
+ theory_processor.reset();
+ StylesheetRoot theory_style2 =
+ theory_processor.processStylesheet(theory_xsl2);
+ theory_processor.setStylesheet(theory_style2);
+
+ XSLTProcessor processor = XSLTProcessorFactory.getProcessor();
+ StylesheetRoot style1 = processor.processStylesheet(xsl1);
+ processor.reset();
+ StylesheetRoot style2 = processor.processStylesheet(xsl2);
+ processor.setStylesheet(style2);
+
+ DatagramSocket socket = new DatagramSocket(port);
+
+ System.out.println("Demon activated on input port " + port +
+ " and output port " + port2);
+ while(true) {
+ System.out.print("Ready...");
+
+ /* Warning: the packet must be a fresh one! */
+ DatagramPacket packet = new DatagramPacket(new byte[1024],1024);
+ socket.receive(packet);
+ byte data[] = packet.getData();
+ int datalen = packet.getLength();
+ String received = new String(data,0,datalen);
+
+ int first = received.indexOf(' ');
+ int last = received.lastIndexOf(' ');
+ String mode = received.substring(0,first);
+ String input = received.substring(first+1,last);
+ String output = received.substring(last+1);
+
+ System.out.println("request received! Parameters are");
+ System.out.println("Mode: " + mode + " ");
+ System.out.println("Input file: \"" + input + "\"");
+ System.out.println("Output file: \"" + output + "\"\n");
+
+ if ((new File(output)).exists()) {
+ System.out.println("Using cached version\n");
+ } else {
+ FileOutputStream fout = new FileOutputStream(output);
+ if (mode.equals("cic")) {
+ processor.setDocumentHandler(style2.getSAXSerializer(fout));
+ XSLTResultTarget content = new XSLTResultTarget(processor);
+ style1.process(new XSLTInputSource(input), content);
+ } else if (mode.equals("theory")) {
+ theory_processor.setDocumentHandler(
+ theory_style2.getSAXSerializer(fout));
+ XSLTResultTarget content =
+ new XSLTResultTarget(theory_processor);
+ theory_style1.process(new XSLTInputSource(input), content);
+ }
+ }
+
+ InetAddress address = InetAddress.getLocalHost();
+ DatagramSocket socket2 = new DatagramSocket();
+
+ byte buf[] = new byte[0];
+ DatagramPacket packet2 = new DatagramPacket(buf,0,address,port2);
+
+ socket2.send(packet2);
+ }
+ }
+}
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* A tactic to print Coq objects in XML *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 18/10/2000 *)
+(* *)
+(* This module defines a pretty-printer and the stream of commands to the pp *)
+(* *)
+(******************************************************************************)
+
+
+(* the type token for XML cdata, empty elements and not-empty elements *)
+(* Usage: *)
+(* Str cdata *)
+(* Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen] *)
+(* NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *)
+(* content *)
+type token = Str of string
+ | Empty of string * (string * string) list
+ | NEmpty of string * (string * string) list * token Stream.t
+;;
+
+(* currified versions of the constructors make the code more readable *)
+let xml_empty name attrs = [< 'Empty(name,attrs) >]
+let xml_nempty name attrs content = [< 'NEmpty(name,attrs,content) >]
+let xml_cdata str = [< 'Str str >]
+
+(* Usage: *)
+(* pp tokens None pretty prints the output on stdout *)
+(* pp tokens (Some filename) pretty prints the output on the file filename *)
+let pp strm fn =
+ let channel = ref stdout in
+ let rec pp_r m =
+ parser
+ [< 'Str a ; s >] ->
+ print_spaces m ;
+ fprint_string (a ^ "\n") ;
+ pp_r m s
+ | [< 'Empty(n,l) ; s >] ->
+ print_spaces m ;
+ fprint_string ("<" ^ n) ;
+ List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
+ fprint_string "/>\n" ;
+ pp_r m s
+ | [< 'NEmpty(n,l,c) ; s >] ->
+ print_spaces m ;
+ fprint_string ("<" ^ n) ;
+ List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
+ fprint_string ">\n" ;
+ pp_r (m+1) c ;
+ print_spaces m ;
+ fprint_string ("</" ^ n ^ ">\n") ;
+ pp_r m s
+ | [< >] -> ()
+ and print_spaces m =
+ for i = 1 to m do fprint_string " " done
+ and fprint_string str =
+ output_string !channel str
+ in
+ match fn with
+ Some filename ->
+ channel := open_out filename ;
+ pp_r 0 strm ;
+ close_out !channel ;
+ print_string ("\nWriting on file \"" ^ filename ^ "\" was succesfull\n");
+ flush stdout
+ | None ->
+ pp_r 0 strm
+;;
--- /dev/null
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* A tactic to print Coq objects in XML *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 18/10/2000 *)
+(* *)
+(* This module defines a pretty-printer and the stream of commands to the pp *)
+(* *)
+(******************************************************************************)
+
+(* Tokens for XML cdata, empty elements and not-empty elements *)
+(* Usage: *)
+(* Str cdata *)
+(* Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen] *)
+(* NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *)
+(* content *)
+type token =
+ | Str of string
+ | Empty of string * (string * string) list
+ | NEmpty of string * (string * string) list * token Stream.t
+
+(* currified versions of the token constructors make the code more readable *)
+val xml_empty : string -> (string * string) list -> token Stream.t
+val xml_nempty :
+ string -> (string * string) list -> token Stream.t -> token Stream.t
+val xml_cdata : string -> token Stream.t
+
+(* The pretty printer for streams of token *)
+(* Usage: *)
+(* pp tokens None pretty prints the output on stdout *)
+(* pp tokens (Some filename) pretty prints the output on the file filename *)
+val pp : token Stream.t -> string option -> unit
--- /dev/null
+exception XsltProcessorCouldNotSend;;
+exception XsltProcessorCouldNotReceive;;
+
+let portserver = 12345;;
+let portclient = 12346;;
+let time_to_wait = 10;;
+
+let rec process uri usecache mode =
+ let module U = Unix in
+ let uri = UriManager.string_of_uri uri in
+ let pid = string_of_int (U.getpid ())
+ and filename' =
+ let uri' = Str.replace_first (Str.regexp ".*:") "" uri in
+ Str.global_replace (Str.regexp "/") "_"
+ (Str.global_replace (Str.regexp "_") "__" uri')
+ in let tmpfile = "/tmp/helm_" ^ filename' ^ "_" ^ pid in
+ (* test if the cache can be used *)
+ let tmp_file_exists = Sys.file_exists tmpfile in
+ if usecache && tmp_file_exists then
+ tmpfile
+ else
+ let url = Configuration.getter_url ^ uri in
+ (* purge the cache if asked to *)
+ if not usecache && tmp_file_exists then
+ Sys.remove tmpfile ;
+ let string_to_send = mode ^ " " ^ url ^ " " ^ tmpfile in
+ (* next function is for looping in case the server is not responding *)
+ let rec contact_server () =
+ let socketclient = U.socket U.PF_INET U.SOCK_DGRAM 0
+ and socketserver = U.socket U.PF_INET U.SOCK_DGRAM 0 in
+ let bounded = ref false in
+ while not !bounded do
+ try
+ U.bind socketclient (U.ADDR_INET(U.inet_addr_any,portclient)) ;
+ bounded := true
+ with _ ->
+ print_endline "Port unavailable. Retrying..." ; flush stdout ;
+ U.sleep 5 (* wait hoping the inetaddr is released *)
+ done ;
+ let n =
+ U.sendto socketserver string_to_send 0 (String.length string_to_send)
+ [] (U.ADDR_INET(U.inet_addr_any,portserver))
+ in
+ if n = -1 then raise XsltProcessorCouldNotSend ;
+ U.close socketserver ;
+ let process_signal _ = U.close socketclient in
+ Sys.set_signal Sys.sigalrm (Sys.Signal_handle process_signal) ;
+ (* if the server does not respond, repeat the query *)
+ ignore (U.alarm time_to_wait) ;
+ try
+ if U.recv socketclient "" 0 0 [] = -1 then
+ raise XsltProcessorCouldNotReceive ;
+ ignore (U.alarm 0) ; (* stop the bomb *)
+ Sys.set_signal Sys.sigalrm Sys.Signal_default ;
+ U.close socketclient ;
+ tmpfile
+ with
+ U.Unix_error(_,"recv",_) ->
+ print_endline "Xaland server not responding. Retrying..." ;
+ flush stdout;
+ contact_server ()
+ in
+ contact_server ()
+;;
projects / helm.git / commitdiff