+++ /dev/null
-lib common text automath basic_ag basic_rg complete_rg toplevel
LDDLDIR = /projects/helm/public_html/lambda-delta/static/lddl
DOWNDIR = /projects/helm/public_html/lambda-delta/download
XMLDIR = /projects/helm/public_html/lambda-delta/xml
+SRC = components
-DIRECTORIES = $(shell cat Make)
+DIRECTORIES = $(addprefix $(SRC)/,$(shell cat $(SRC)/Make))
INCLUDES = $(DIRECTORIES:%=-I %)
+++ /dev/null
-aut autProcess autOutput autParser autLexer
+++ /dev/null
-# The lambda-term \Omega
-# This book is not accepted in AUT-QE because [y:'type'] is not allowed
-# This book is accepted in lambda-delta with sort inclusion but Omega is not
-# valid if sort inclusion is allowed on the term backbone only
-# This book is valid in lambda-delta with unrestricted sort inclusion
-
-+l
-@ Delta := [x:[y:'type']'type']<x>x : [x:[y:'type']'type']'type'
- Omega := <Delta>Delta : 'type'
--l
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type id = string (* identifier *)
-
-type qid = id * bool * id list (* qualified identifier: name, local?, path *)
-
-type term = Sort of bool (* sorts: true = TYPE, false = PROP *)
- | GRef of qid * term list (* reference: name, arguments *)
- | Appl of term * term (* application: argument, function *)
- | Abst of id * term * term (* abstraction: name, domain, scope *)
-
-type command = Section of (bool * id) option (* section: Some true = open, Some false = reopen, None = close last *)
- | Context of qid option (* context: Some = last node, None = root *)
- | Block of id * term (* block opener: name, domain *)
- | Decl of id * term (* declaration: name, domain *)
- | Def of id * term * bool * term (* definition: name, domain, transparent?, body *)
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-{
- module L = Log
- module O = Options
- module P = AutParser
-
- let out s = if !O.debug_lexer then L.warn s else ()
-
-(* This turns an Automath identifier into an XML nmtoken *)
- let quote id =
- let l = String.length id in
- let rec aux i =
- if i < l then begin
- if id.[i] = '\'' || id.[i] = '`' then id.[i] <- '_';
- aux (succ i)
- end else
- id
- in
- aux 0
-}
-
-let LC = ['#' '%']
-let OC = "{"
-let CC = "}"
-let SPC = [' ' '\t' '\n']+
-let NL = "\n"
-let ID = ['0'-'9' 'A'-'Z' 'a'-'z' '_' '\'' '`']+
-
-rule line_comment = parse
- | NL { () }
- | OC { block_comment lexbuf; line_comment lexbuf }
- | _ { line_comment lexbuf }
- | eof { () }
-and block_comment = parse
- | CC { () }
- | OC { block_comment lexbuf; block_comment lexbuf }
- | LC { line_comment lexbuf; block_comment lexbuf }
- | _ { block_comment lexbuf }
-and token = parse
- | SPC { token lexbuf }
- | LC { line_comment lexbuf; token lexbuf }
- | OC { block_comment lexbuf; token lexbuf }
- | "_E" { out "E"; P.E }
- | "'_E'" { out "E"; P.E }
- | "---" { out "EB"; P.EB }
- | "'eb'" { out "EB"; P.EB }
- | "EB" { out "EB"; P.EB }
- | "--" { out "EXIT"; P.EXIT }
- | "PN" { out "PN"; P.PN }
- | "'pn'" { out "PN"; P.PN }
- | "PRIM" { out "PN"; P.PN }
- | "'prim'" { out "PN"; P.PN }
- | "???" { out "PN"; P.PN }
- | "PROP" { out "PROP"; P.PROP }
- | "'prop'" { out "PROP"; P.PROP }
- | "TYPE" { out "TYPE"; P.TYPE }
- | "'type'" { out "TYPE"; P.TYPE }
- | ID { out "ID";
- let s = Lexing.lexeme lexbuf in
- if !O.unquote then P.IDENT s else P.IDENT (quote s)
- }
- | ":=" { out "DEF"; P.DEF }
- | "(" { out "OP"; P.OP }
- | ")" { out "CP"; P.CP }
- | "[" { out "OB"; P.OB }
- | "]" { out "CB"; P.CB }
- | "<" { out "OA"; P.OA }
- | ">" { out "CA"; P.CA }
- | "@" { out "AT"; P.AT }
- | "~" { out "TD"; P.TD }
- | "\"" { out "QT"; P.QT }
- | ":" { out "CN"; P.CN }
- | "," { out "CM"; P.CM }
- | ";" { out "SC"; P.SC }
- | "." { out "FS"; P.FS }
- | "+" { out "PLUS"; P.PLUS }
- | "-" { out "MINUS"; P.MINUS }
- | "*" { out "TIMES"; P.TIMES }
- | "=" { out "DEF"; P.DEF }
- | eof { out "EOF"; P.EOF }
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module P = Printf
-module C = Cps
-module L = Log
-module A = Aut
-module R = AutProcess
-
-type counters = {
- sections: int;
- contexts: int;
- blocks: int;
- decls: int;
- defs: int;
- sorts: int;
- grefs: int;
- appls: int;
- absts: int;
- pars: int;
- xnodes: int
-}
-
-let initial_counters = {
- sections = 0; contexts = 0; blocks = 0; decls = 0; defs = 0;
- sorts = 0; grefs = 0; appls = 0; absts = 0; pars = 0; xnodes = 0
-}
-
-let rec count_term f c = function
- | A.Sort _ ->
- f {c with sorts = succ c.sorts; xnodes = succ c.xnodes}
- | A.GRef (_, ts) ->
- let c = {c with grefs = succ c.grefs} in
- let c = {c with pars = c.pars + List.length ts} in
- let c = {c with xnodes = succ c.xnodes + List.length ts} in
- C.list_fold_left f count_term c ts
- | A.Appl (v, t) ->
- let c = {c with appls = succ c.appls; xnodes = succ c.xnodes} in
- let f c = count_term f c t in
- count_term f c v
- | A.Abst (_, w, t) ->
- let c = {c with absts = succ c.absts; xnodes = succ c.xnodes} in
- let f c = count_term f c t in
- count_term f c w
-
-let count_command f c = function
- | A.Section _ ->
- f {c with sections = succ c.sections}
- | A.Context _ ->
- f {c with contexts = succ c.contexts}
- | A.Block (_, w) ->
- let c = {c with blocks = succ c.blocks; xnodes = succ c.xnodes} in
- count_term f c w
- | A.Decl (_, w) ->
- let c = {c with decls = succ c.decls; xnodes = succ c.xnodes} in
- count_term f c w
- | A.Def (_, w, _, t) ->
- let c = {c with defs = succ c.defs; xnodes = succ c.xnodes} in
- let f c = count_term f c t in
- count_term f c w
-
-let print_counters f c =
- let terms = c.sorts + c.grefs + c.appls + c.absts in
- let entities = c.sections + c.contexts + c.blocks + c.decls + c.defs in
- L.warn (P.sprintf " Automath representation summary");
- L.warn (P.sprintf " Total book entities: %7u" entities);
- L.warn (P.sprintf " Section entities: %7u" c.sections);
- L.warn (P.sprintf " Context entities: %7u" c.contexts);
- L.warn (P.sprintf " Block entities: %7u" c.blocks);
- L.warn (P.sprintf " Declaration entities: %7u" c.decls);
- L.warn (P.sprintf " Definition entities: %7u" c.defs);
- L.warn (P.sprintf " Total Parameter items: %7u" c.pars);
- L.warn (P.sprintf " Application items: %7u" c.pars);
- L.warn (P.sprintf " Total term items: %7u" terms);
- L.warn (P.sprintf " Sort items: %7u" c.sorts);
- L.warn (P.sprintf " Reference items: %7u" c.grefs);
- L.warn (P.sprintf " Application items: %7u" c.appls);
- L.warn (P.sprintf " Abstraction items: %7u" c.absts);
- L.warn (P.sprintf " Global Int. Complexity: unknown");
- L.warn (P.sprintf " + Abbreviation nodes: %7u" c.xnodes);
- f ()
-
-let print_process_counters f c =
- let f iao iar iac iag =
- L.warn (P.sprintf " Automath process summary");
- L.warn (P.sprintf " Implicit after opening: %7u" iao);
- L.warn (P.sprintf " Implicit after reopening: %7u" iar);
- L.warn (P.sprintf " Implicit after closing: %7u" iac);
- L.warn (P.sprintf " Implicit after global: %7u" iag);
- f ()
- in
- R.get_counters f c
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type counters
-
-val initial_counters: counters
-
-val count_command: (counters -> 'a) -> counters -> Aut.command -> 'a
-
-val print_counters: (unit -> 'a) -> counters -> 'a
-
-val print_process_counters: (unit -> 'a) -> AutProcess.status -> 'a
+++ /dev/null
-/* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- */
-
-%{
- module O = Options
- module A = Aut
-
- let _ = Parsing.set_trace !O.debug_parser
-%}
- %token <int> NUM
- %token <string> IDENT
- %token EOF MINUS PLUS TIMES AT FS CN CM SC QT TD OP CP OB CB OA CA
- %token TYPE PROP DEF EB E PN EXIT
-
- %start entry
- %type <Aut.command option> entry
-%%
- path: MINUS {} | FS {} ;
- oftype: CN {} | CM {} ;
- star: TIMES {} | AT {} ;
- sc: E {} | SC {} | CN {} ;
- eof: SC {} | EOF {} ;
-
- expand:
- | { true }
- | TD { false }
- ;
- local:
- | { false }
- | path { true }
- ;
-
- idents:
- | IDENT { [$1] }
- | IDENT path idents { $1 :: $3 }
- ;
- qid:
- | IDENT { ($1, true, []) }
- | IDENT QT QT { ($1, true, []) }
- | IDENT QT local idents QT { ($1, $3, $4) }
- ;
- term:
- | TYPE { A.Sort true }
- | PROP { A.Sort false }
- | qid { A.GRef ($1, []) }
- | qid OP CP { A.GRef ($1, []) }
- | qid OP terms CP { A.GRef ($1, $3) }
- | OA term CA term { A.Appl ($2, $4) }
- | OB IDENT oftype term CB term { A.Abst ($2, $4, $6) }
- ;
- terms:
- | term { [$1] }
- | term CM terms { $1 :: $3 }
- ;
-
- start:
- | PLUS {} | MINUS {} | EXIT {} | eof {}
- | star {} | IDENT {} | OB {}
- ;
- entity:
- | PLUS IDENT { A.Section (Some (true, $2)) }
- | PLUS TIMES IDENT { A.Section (Some (false, $3)) }
- | MINUS IDENT { A.Section None }
- | EXIT { A.Section None }
- | star { A.Context None }
- | qid star { A.Context (Some $1) }
- | IDENT DEF EB sc term { A.Block ($1, $5) }
- | IDENT sc term DEF EB { A.Block ($1, $3) }
- | OB IDENT oftype term CB { A.Block ($2, $4) }
- | IDENT DEF PN sc term { A.Decl ($1, $5) }
- | IDENT sc term DEF PN { A.Decl ($1, $3) }
- | IDENT DEF expand term sc term { A.Def ($1, $6, $3, $4) }
- | IDENT sc term DEF expand term { A.Def ($1, $3, $5, $6) }
- ;
- entry:
- | entity start { Some $1 }
- | eof { None }
- ;
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module A = Aut
-
-type status = {
- opening : bool; (* just opened section *)
- reopening: bool; (* just reopened section *)
- closing : bool; (* just closed section *)
- explicit : bool; (* just found explicit context *)
- block : bool; (* just found block opener *)
- iao : int; (* implicit context after opening section *)
- iar : int; (* implicit context after reopening section *)
- iac : int; (* implicit context after closing section *)
- iag : int (* implicit context after global statement *)
-}
-
-(* internal functions *******************************************************)
-
-let orc_reset f st =
- f {st with opening = false; reopening = false; closing = false}
-
-let orc_count f st =
- let st = if st.opening then {st with iao = succ st.iao} else st in
- let st = if st.reopening then {st with iar = succ st.iar} else st in
- let st = if st.closing then {st with iac = succ st.iac} else st in
- f st
-
-let exp_count f st =
- let st =
- if st.explicit || st.block then st else {st with iag = succ st.iag}
- in
- f st
-
-let proc_section f st = function
- | Some (true, _) -> f {st with opening = true}
- | Some (false, _) -> f {st with reopening = true}
- | None -> f {st with closing = true}
-
-let proc_context f st =
- orc_reset f {st with explicit = true}
-
-let proc_block f st =
- orc_count (orc_reset f) {st with explicit = false; block = true}
-
-let proc_global f st =
- let f st =
- orc_count (orc_reset f) {st with explicit = false; block = false}
- in
- exp_count f st
-
-let proc_command f st command = match command with
- | A.Section section -> proc_section f st section command
- | A.Context _ -> proc_context f st command
- | A.Block _ -> proc_block f st command
- | A.Decl _ -> proc_global f st command
- | A.Def _ -> proc_global f st command
-
-(* interface functions ******************************************************)
-
-let initial_status () = {
- opening = false; reopening = false; closing = false;
- explicit = false; block = false;
- iao = 0; iar = 0; iac = 0; iag = 0
-}
-
-let process_command = proc_command
-
-let get_counters f st = f st.iao st.iar st.iac st.iag
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type status
-
-val initial_status: unit -> status
-
-val process_command:
- (status -> Aut.command -> 'a) -> status -> Aut.command -> 'a
-
-val get_counters: (int -> int -> int -> int -> 'a) -> status -> 'a
+++ /dev/null
-bag bagOutput
-bagEnvironment bagSubstitution bagReduction bagType bagUntrusted
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-(* kernel version: basic, absolute, global *)
-(* note : experimental *)
-
-type uri = Entity.uri
-type id = Entity.id
-
-type bind = Void (* exclusion *)
- | Abst of term (* abstraction *)
- | Abbr of term (* abbreviation *)
-
-and term = Sort of int (* hierarchy index *)
- | LRef of int (* location *)
- | GRef of uri (* reference *)
- | Cast of term * term (* domain, element *)
- | Appl of term * term (* argument, function *)
- | Bind of int * id * bind * term (* location, name, binder, scope *)
-
-type entity = term Entity.entity (* attrs, uri, binder *)
-
-type lenv = (int * id * bind) list (* location, name, binder *)
-
-type message = (lenv, term) Log.item list
-
-(* helpers ******************************************************************)
-
-let mk_uri si root s =
- let kernel = if si then "bag-si" else "bag" in
- String.concat "/" ["ld:"; kernel; root; s ^ ".ld"]
-
-(* Currified constructors ***************************************************)
-
-let abst w = Abst w
-
-let abbr v = Abbr v
-
-let lref i = LRef i
-
-let cast u t = Cast (u, t)
-
-let appl u t = Appl (u, t)
-
-let bind l id b t = Bind (l, id, b, t)
-
-let bind_abst l id u t = Bind (l, id, Abst u, t)
-
-let bind_abbr l id v t = Bind (l, id, Abbr v, t)
-
-(* location handling functions **********************************************)
-
-let location = ref 0
-
-let new_location () = let loc = !location in incr location; loc
-
-let locations () = !location
-
-(* local environment handling functions *************************************)
-
-let empty_lenv = []
-
-let push msg f es l id b =
- let rec does_not_occur loc = function
- | [] -> true
- | (l, _, _) :: _ when l = loc -> false
- | _ :: es -> does_not_occur l es
- in
- if not (does_not_occur l es) then failwith msg else
- let c = (l, id, b) :: es in f c
-
-let append f es1 es2 =
- f (List.append es2 es1)
-
-let map f map es =
- Cps.list_map f map es
-
-let contents f es = f es
-
-let get f es i =
- let rec aux = function
- | [] -> f None
- | (l, id, b) :: tl -> if l = i then f (Some (id, b)) else aux tl
- in
- aux es
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module U = NUri
-module L = Log
-module H = U.UriHash
-module Y = Entity
-module B = Bag
-
-exception ObjectNotFound of B.message
-
-let hsize = 7000
-let env = H.create hsize
-
-(* Internal functions *******************************************************)
-
-let get_age =
- let age = ref 0 in
- fun () -> incr age; !age
-
-let error uri = raise (ObjectNotFound (L.items1 (U.string_of_uri uri)))
-
-(* Interface functions ******************************************************)
-
-let set_entity f (a, uri, b) =
- let age = get_age () in
- let entry = (Y.Apix age :: a), uri, b in
- H.add env uri entry; f entry
-
-let get_entity f uri =
- try f (H.find env uri) with Not_found -> error uri
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-exception ObjectNotFound of Bag.message
-
-val set_entity: (Bag.entity -> 'a) -> Bag.entity -> 'a
-
-val get_entity: (Bag.entity -> 'a) -> Bag.uri -> 'a
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module P = Printf
-module F = Format
-module U = NUri
-module L = Log
-module O = Options
-module Y = Entity
-module H = Hierarchy
-module B = Bag
-
-type counters = {
- eabsts: int;
- eabbrs: int;
- tsorts: int;
- tlrefs: int;
- tgrefs: int;
- tcasts: int;
- tappls: int;
- tabsts: int;
- tabbrs: int
-}
-
-let initial_counters = {
- eabsts = 0; eabbrs = 0; tsorts = 0; tlrefs = 0; tgrefs = 0;
- tcasts = 0; tappls = 0; tabsts = 0; tabbrs = 0
-}
-
-let rec count_term_binder f c = function
- | B.Abst w ->
- let c = {c with tabsts = succ c.tabsts} in
- count_term f c w
- | B.Abbr v ->
- let c = {c with tabbrs = succ c.tabbrs} in
- count_term f c v
- | B.Void -> f c
-
-and count_term f c = function
- | B.Sort _ ->
- f {c with tsorts = succ c.tsorts}
- | B.LRef _ ->
- f {c with tlrefs = succ c.tlrefs}
- | B.GRef _ ->
- f {c with tgrefs = succ c.tgrefs}
- | B.Cast (v, t) ->
- let c = {c with tcasts = succ c.tcasts} in
- let f c = count_term f c t in
- count_term f c v
- | B.Appl (v, t) ->
- let c = {c with tappls = succ c.tappls} in
- let f c = count_term f c t in
- count_term f c v
- | B.Bind (_, _, b, t) ->
- let f c = count_term_binder f c b in
- count_term f c t
-
-let count_entity f c = function
- | _, _, Y.Abst w ->
- let c = {c with eabsts = succ c.eabsts} in
- count_term f c w
- | _, _, Y.Abbr v ->
- let c = {c with eabbrs = succ c.eabbrs} in
- count_term f c v
- | _, _, Y.Void -> assert false
-
-let print_counters f c =
- let terms =
- c.tsorts + c.tgrefs + c.tgrefs + c.tcasts + c.tappls + c.tabsts +
- c.tabbrs
- in
- let items = c.eabsts + c.eabbrs in
- let locations = B.locations () in
- L.warn (P.sprintf " Kernel representation summary (basic_ag)");
- L.warn (P.sprintf " Total entry items: %7u" items);
- L.warn (P.sprintf " Declaration items: %7u" c.eabsts);
- L.warn (P.sprintf " Definition items: %7u" c.eabbrs);
- L.warn (P.sprintf " Total term items: %7u" terms);
- L.warn (P.sprintf " Sort items: %7u" c.tsorts);
- L.warn (P.sprintf " Local reference items: %7u" c.tlrefs);
- L.warn (P.sprintf " Global reference items: %7u" c.tgrefs);
- L.warn (P.sprintf " Explicit Cast items: %7u" c.tcasts);
- L.warn (P.sprintf " Application items: %7u" c.tappls);
- L.warn (P.sprintf " Abstraction items: %7u" c.tabsts);
- L.warn (P.sprintf " Abbreviation items: %7u" c.tabbrs);
- L.warn (P.sprintf " Total binder locations: %7u" locations);
- f ()
-
-let res l id =
- if !O.indexes then P.sprintf "#%u" l else id
-
-let rec pp_term c frm = function
- | B.Sort h ->
- let err () = F.fprintf frm "@[*%u@]" h in
- let f s = F.fprintf frm "@[%s@]" s in
- H.string_of_sort err f h
- | B.LRef i ->
- let f = function
- | Some (id, _) -> F.fprintf frm "@[%s@]" id
- | None -> F.fprintf frm "@[#%u@]" i
- in
- if !O.indexes then f None else B.get f c i
- | B.GRef s -> F.fprintf frm "@[$%s@]" (U.string_of_uri s)
- | B.Cast (u, t) ->
- F.fprintf frm "@[{%a}.%a@]" (pp_term c) u (pp_term c) t
- | B.Appl (v, t) ->
- F.fprintf frm "@[(%a).%a@]" (pp_term c) v (pp_term c) t
- | B.Bind (l, id, B.Abst w, t) ->
- let f cc =
- F.fprintf frm "@[[%s:%a].%a@]" (res l id) (pp_term c) w (pp_term cc) t
- in
- B.push "output abst" f c l id (B.Abst w)
- | B.Bind (l, id, B.Abbr v, t) ->
- let f cc =
- F.fprintf frm "@[[%s=%a].%a@]" (res l id) (pp_term c) v (pp_term cc) t
- in
- B.push "output abbr" f c l id (B.Abbr v)
- | B.Bind (l, id, B.Void, t) ->
- let f cc = F.fprintf frm "@[[%s].%a@]" (res l id) (pp_term cc) t in
- B.push "output void" f c l id B.Void
-
-let pp_lenv frm c =
- let pp_entry frm = function
- | l, id, B.Abst w ->
- F.fprintf frm "@,@[%s : %a@]" (res l id) (pp_term c) w
- | l, id, B.Abbr v ->
- F.fprintf frm "@,@[%s = %a@]" (res l id) (pp_term c) v
- | l, id, B.Void ->
- F.fprintf frm "@,%s" (res l id)
- in
- let iter map frm l = List.iter (map frm) l in
- let f es = F.fprintf frm "%a" (iter pp_entry) (List.rev es) in
- B.contents f c
-
-let specs = {
- L.pp_term = pp_term; L.pp_lenv = pp_lenv
-}
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type counters
-
-val initial_counters: counters
-
-val count_entity: (counters -> 'a) -> counters -> Bag.entity -> 'a
-
-val print_counters: (unit -> 'a) -> counters -> 'a
-
-val specs: (Bag.lenv, Bag.term) Log.specs
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module U = NUri
-module C = Cps
-module L = Log
-module Y = Entity
-module B = Bag
-module O = BagOutput
-module E = BagEnvironment
-module S = BagSubstitution
-
-type machine = {
- i: int;
- c: B.lenv;
- s: B.term list
-}
-
-type whd_result =
- | Sort_ of int
- | LRef_ of int * B.term option
- | GRef_ of B.entity
- | Bind_ of int * B.id * B.term * B.term
-
-type ho_whd_result =
- | Sort of int
- | Abst of B.term
-
-(* Internal functions *******************************************************)
-
-let term_of_whdr = function
- | Sort_ h -> B.Sort h
- | LRef_ (i, _) -> B.LRef i
- | GRef_ (_, uri, _) -> B.GRef uri
- | Bind_ (l, id, w, t) -> B.bind_abst l id w t
-
-let level = 5
-
-let log1 s c t =
- let sc, st = s ^ " in the environment", "the term" in
- L.log O.specs level (L.et_items1 sc c st t)
-
-let log2 s cu u ct t =
- let s1, s2, s3 = s ^ " in the environment", "the term", "and in the environment" in
- L.log O.specs level (L.et_items2 s1 cu s2 u ~sc2:s3 ~c2:ct s2 t)
-
-let empty_machine = {i = 0; c = B.empty_lenv; s = []}
-
-let inc m = {m with i = succ m.i}
-
-let unwind_to_term f m t =
- let map f t (l, id, b) = f (B.Bind (l, id, b, t)) in
- let f mc = C.list_fold_left f map t mc in
- B.contents f m.c
-
-let unwind_stack f m =
- let map f v = unwind_to_term f m v in
- C.list_map f map m.s
-
-let get f c m i =
- let f = function
- | Some (_, b) -> f b
- | None -> assert false
- in
- let f c = B.get f c i in
- B.append f c m.c
-
-let push msg f c m l id w =
- assert (m.s = []);
- let f w = B.push msg f c l id (B.Abst w) in
- unwind_to_term f m w
-
-(* to share *)
-let rec whd f c m x =
-(* L.warn "entering R.whd"; *)
- match x with
- | B.Sort h -> f m (Sort_ h)
- | B.GRef uri ->
- let f entry = f m (GRef_ entry) in
- E.get_entity f uri
- | B.LRef i ->
- let f = function
- | B.Void -> f m (LRef_ (i, None))
- | B.Abst t -> f m (LRef_ (i, Some t))
- | B.Abbr t -> whd f c m t
- in
- get f c m i
- | B.Cast (_, t) -> whd f c m t
- | B.Appl (v, t) -> whd f c {m with s = v :: m.s} t
- | B.Bind (l, id, B.Abst w, t) ->
- begin match m.s with
- | [] -> f m (Bind_ (l, id, w, t))
- | v :: tl ->
- let nl = B.new_location () in
- let f mc = S.subst (whd f c {m with c = mc; s = tl}) nl l t in
- B.push "!" f m.c nl id (B.Abbr (B.Cast (w, v)))
- end
- | B.Bind (l, id, b, t) ->
- let nl = B.new_location () in
- let f mc = S.subst (whd f c {m with c = mc}) nl l t in
- B.push "!" f m.c nl id b
-
-(* Interface functions ******************************************************)
-
-let rec ho_whd f c m x =
-(* L.warn "entering R.ho_whd"; *)
- let aux m = function
- | Sort_ h -> f (Sort h)
- | Bind_ (_, _, w, _) ->
- let f w = f (Abst w) in unwind_to_term f m w
- | LRef_ (_, Some w) -> ho_whd f c m w
- | GRef_ (_, _, Y.Abst w) -> ho_whd f c m w
- | GRef_ (_, _, Y.Abbr v) -> ho_whd f c m v
- | LRef_ (_, None) -> assert false
- | GRef_ (_, _, Y.Void) -> assert false
- in
- whd aux c m x
-
-let ho_whd f c t =
- let f r = L.unbox level; f r in
- L.box level; log1 "Now scanning" c t;
- ho_whd f c empty_machine t
-
-let rec are_convertible f ~si a c m1 t1 m2 t2 =
-(* L.warn "entering R.are_convertible"; *)
- let rec aux m1 r1 m2 r2 =
-(* L.warn "entering R.are_convertible_aux"; *)
- let u, t = term_of_whdr r1, term_of_whdr r2 in
- log2 "Now really converting" c u c t;
- match r1, r2 with
- | Sort_ h1, Sort_ h2 ->
- if h1 = h2 then f a else f false
- | LRef_ (i1, _), LRef_ (i2, _) ->
- if i1 = i2 then are_convertible_stacks f ~si a c m1 m2 else f false
- | GRef_ ((Y.Apix a1 :: _), _, Y.Abst _),
- GRef_ ((Y.Apix a2 :: _), _, Y.Abst _) ->
- if a1 = a2 then are_convertible_stacks f ~si a c m1 m2 else f false
- | GRef_ ((Y.Apix a1 :: _), _, Y.Abbr v1),
- GRef_ ((Y.Apix a2 :: _), _, Y.Abbr v2) ->
- if a1 = a2 then
- let f a =
- if a then f a else are_convertible f ~si true c m1 v1 m2 v2
- in
- are_convertible_stacks f ~si a c m1 m2
- else
- if a1 < a2 then whd (aux m1 r1) c m2 v2 else
- whd (aux_rev m2 r2) c m1 v1
- | _, GRef_ (_, _, Y.Abbr v2) ->
- whd (aux m1 r1) c m2 v2
- | GRef_ (_, _, Y.Abbr v1), _ ->
- whd (aux_rev m2 r2) c m1 v1
- | Bind_ (l1, id1, w1, t1), Bind_ (l2, id2, w2, t2) ->
- let l = B.new_location () in
- let h c =
- let m1, m2 = inc m1, inc m2 in
- let f t1 = S.subst (are_convertible f ~si a c m1 t1 m2) l l2 t2 in
- S.subst f l l1 t1
- in
- let f r = if r then push "!" h c m1 l id1 w1 else f false in
- are_convertible f ~si a c m1 w1 m2 w2
-(* we detect the AUT-QE reduction rule for type/prop inclusion *)
- | Sort_ _, Bind_ (l2, id2, w2, t2) when si ->
- let m1, m2 = inc m1, inc m2 in
- let f c = are_convertible f ~si a c m1 (term_of_whdr r1) m2 t2 in
- push "nsi" f c m2 l2 id2 w2
- | _ -> f false
- and aux_rev m2 r2 m1 r1 = aux m1 r1 m2 r2 in
- let g m1 r1 = whd (aux m1 r1) c m2 t2 in
- if a = false then f false else whd g c m1 t1
-
-and are_convertible_stacks f ~si a c m1 m2 =
-(* L.warn "entering R.are_convertible_stacks"; *)
- let mm1, mm2 = {m1 with s = []}, {m2 with s = []} in
- let map f a v1 v2 = are_convertible f ~si a c mm1 v1 mm2 v2 in
- if List.length m1.s <> List.length m2.s then
- begin
-(* L.warn (Printf.sprintf "Different lengths: %u %u"
- (List.length m1.s) (List.length m2.s)
- ); *)
- f false
- end
- else
- C.list_fold_left2 f map a m1.s m2.s
-
-let are_convertible f ?(si=false) c u t =
- let f b = L.unbox level; f b in
- L.box level; log2 "Now converting" c u c t;
- are_convertible f ~si true c empty_machine u empty_machine t
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type ho_whd_result =
- | Sort of int
- | Abst of Bag.term
-
-val ho_whd:
- (ho_whd_result -> 'a) -> Bag.lenv -> Bag.term -> 'a
-
-val are_convertible:
- (bool -> 'a) -> ?si:bool -> Bag.lenv -> Bag.term -> Bag.term -> 'a
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module S = Share
-module B = Bag
-
-(* Internal functions *******************************************************)
-
-let rec lref_map_bind f map b = match b with
- | B.Abbr v ->
- let f v' = f (S.sh1 v v' b B.abbr) in
- lref_map f map v
- | B.Abst w ->
- let f w' = f (S.sh1 w w' b B.abst) in
- lref_map f map w
- | B.Void -> f b
-
-and lref_map f map t = match t with
- | B.LRef i ->
- let ii = map i in f (S.sh1 i ii t B.lref)
- | B.GRef _ -> f t
- | B.Sort _ -> f t
- | B.Cast (w, u) ->
- let f w' u' = f (S.sh2 w w' u u' t B.cast) in
- let f w' = lref_map (f w') map u in
- lref_map f map w
- | B.Appl (w, u) ->
- let f w' u' = f (S.sh2 w w' u u' t B.appl) in
- let f w' = lref_map (f w') map u in
- lref_map f map w
- | B.Bind (l, id, b, u) ->
- let f b' u' = f (S.sh2 b b' u u' t (B.bind l id)) in
- let f b' = lref_map (f b') map u in
- lref_map_bind f map b
-
-(* Interface functions ******************************************************)
-
-let subst f new_l old_l t =
- let map i = if i = old_l then new_l else i in
- if new_l = old_l then f t else lref_map f map t
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-val subst: (Bag.term -> 'a) -> int -> int -> Bag.term -> 'a
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module U = NUri
-module C = Cps
-module S = Share
-module L = Log
-module Y = Entity
-module H = Hierarchy
-module B = Bag
-module O = BagOutput
-module E = BagEnvironment
-module R = BagReduction
-
-exception TypeError of B.message
-
-(* Internal functions *******************************************************)
-
-let level = 4
-
-let log1 s c t =
- let sc, st = s ^ " in the envireonment", "the term" in
- L.log O.specs level (L.et_items1 sc c st t)
-
-let error1 st c t =
- let sc = "In the envireonment" in
- raise (TypeError (L.et_items1 sc c st t))
-
-let error3 c t1 t2 t3 =
- let sc, st1, st2, st3 =
- "In the envireonment", "the term", "is of type", "but must be of type"
- in
- raise (TypeError (L.et_items3 sc c st1 t1 st2 t2 st3 t3))
-
-let mk_gref u l =
- let map t v = B.Appl (v, t) in
- List.fold_left map (B.GRef u) l
-
-(* Interface functions ******************************************************)
-
-let rec b_type_of f st c x =
-(* L.warn "Entering T.b_type_of"; *)
- log1 "Now checking" c x;
- match x with
- | B.Sort h ->
- let h = H.apply h in f x (B.Sort h)
- | B.LRef i ->
- let f = function
- | Some (_, B.Abst w) -> f x w
- | Some (_, B.Abbr (B.Cast (w, v))) -> f x w
- | Some (_, B.Abbr _) -> assert false
- | Some (_, B.Void) ->
- error1 "reference to excluded variable" c x
- | None ->
- error1 "variable not found" c x
- in
- B.get f c i
- | B.GRef uri ->
- let f = function
- | _, _, Y.Abst w -> f x w
- | _, _, Y.Abbr (B.Cast (w, v)) -> f x w
- | _, _, Y.Abbr _ -> assert false
- | _, _, Y.Void -> assert false
- in
- E.get_entity f uri
- | B.Bind (l, id, B.Abbr v, t) ->
- let f xv xt tt =
- f (S.sh2 v xv t xt x (B.bind_abbr l id)) (B.bind_abbr l id xv tt)
- in
- let f xv cc = b_type_of (f xv) st cc t in
- let f xv = B.push "type abbr" (f xv) c l id (B.Abbr xv) in
- let f xv vv = match xv with
- | B.Cast _ -> f xv
- | _ -> f (B.Cast (vv, xv))
- in
- type_of f st c v
- | B.Bind (l, id, B.Abst u, t) ->
- let f xu xt tt =
- f (S.sh2 u xu t xt x (B.bind_abst l id)) (B.bind_abst l id xu tt)
- in
- let f xu cc = b_type_of (f xu) st cc t in
- let f xu _ = B.push "type abst" (f xu) c l id (B.Abst xu) in
- type_of f st c u
- | B.Bind (l, id, B.Void, t) ->
- let f xt tt =
- f (S.sh1 t xt x (B.bind l id B.Void)) (B.bind l id B.Void tt)
- in
- let f cc = b_type_of f st cc t in
- B.push "type void" f c l id B.Void
- | B.Appl (v, t) ->
- let f xv vv xt tt = function
- | R.Abst w ->
- L.box (succ level);
- L.log O.specs (succ level) (L.t_items1 "Just scanned" c w);
- L.unbox (succ level);
- let f a =
-(* L.warn (Printf.sprintf "Convertible: %b" a); *)
- if a then f (S.sh2 v xv t xt x B.appl) (B.appl xv tt)
- else error3 c xv vv w
- in
- R.are_convertible f ~si:st.Y.si c w vv
- | _ ->
- error1 "not a function" c xt
- in
- let f xv vv xt tt = R.ho_whd (f xv vv xt tt) c tt in
- let f xv vv = b_type_of (f xv vv) st c t in
- type_of f st c v
- | B.Cast (u, t) ->
- let f xu xt tt a =
- (* L.warn (Printf.sprintf "Convertible: %b" a); *)
- if a then f (S.sh2 u xu t xt x B.cast) xu else error3 c xt tt xu
- in
- let f xu xt tt = R.are_convertible (f xu xt tt) ~si:st.Y.si c xu tt in
- let f xu _ = b_type_of (f xu) st c t in
- type_of f st c u
-
-and type_of f st c x =
- let f t u = L.unbox level; f t u in
- L.box level; b_type_of f st c x
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-exception TypeError of Bag.message
-
-val type_of:
- (Bag.term -> Bag.term -> 'a) ->
- Entity.status -> Bag.lenv -> Bag.term -> 'a
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module U = NUri
-module L = Log
-module Y = Entity
-module B = Bag
-module E = BagEnvironment
-module T = BagType
-
-(* Interface functions ******************************************************)
-
-(* to share *)
-let type_check f st = function
- | a, uri, Y.Abst t ->
- let f xt tt = E.set_entity (f tt) (a, uri, Y.Abst xt) in
- L.loc := U.string_of_uri uri; T.type_of f st B.empty_lenv t
- | a, uri, Y.Abbr t ->
- let f xt tt = E.set_entity (f tt) (a, uri, Y.Abbr xt) in
- L.loc := U.string_of_uri uri; T.type_of f st B.empty_lenv t
- | _, _, Y.Void -> assert false
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-val type_check:
- (Bag.term -> Bag.entity -> 'a) -> Entity.status -> Bag.entity -> 'a
+++ /dev/null
-brg brgOutput
-brgEnvironment brgSubstitution brgReduction brgType brgUntrusted
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-(* kernel version: basic, relative, global *)
-(* note : ufficial basic lambda-delta *)
-
-type uri = Entity.uri
-type id = Entity.id
-type attrs = Entity.attrs
-
-type bind = Void (* *)
- | Abst of term (* type *)
- | Abbr of term (* body *)
-
-and term = Sort of attrs * int (* attrs, hierarchy index *)
- | LRef of attrs * int (* attrs, position index *)
- | GRef of attrs * uri (* attrs, reference *)
- | Cast of attrs * term * term (* attrs, type, term *)
- | Appl of attrs * term * term (* attrs, argument, function *)
- | Bind of attrs * bind * term (* attrs, binder, scope *)
-
-type entity = term Entity.entity (* attrs, uri, binder *)
-
-type lenv = Null
-(* Cons: tail, relative local environment, attrs, binder *)
- | Cons of lenv * lenv * attrs * bind
-
-(* helpers ******************************************************************)
-
-let mk_uri si root s =
- let kernel = if si then "brg-si" else "brg" in
- String.concat "/" ["ld:"; kernel; root; s ^ ".ld"]
-
-(* Currified constructors ***************************************************)
-
-let abst w = Abst w
-
-let abbr v = Abbr v
-
-let lref a i = LRef (a, i)
-
-let cast a u t = Cast (a, u, t)
-
-let appl a u t = Appl (a, u, t)
-
-let bind a b t = Bind (a, b, t)
-
-let bind_abst a u t = Bind (a, Abst u, t)
-
-let bind_abbr a v t = Bind (a, Abbr v, t)
-
-let bind_void a t = Bind (a, Void, t)
-
-(* local environment handling functions *************************************)
-
-let empty = Null
-
-let push e c a b = Cons (e, c, a, b)
-
-let rec get i = function
- | Null -> Null, Null, [], Void
- | Cons (e, c, a, b) when i = 0 -> e, c, a, b
- | Cons (e, _, _, _) -> get (pred i) e
-
-let get e i = get i e
-
-(* used in BrgOutput.pp_lenv *)
-let rec fold_right f map e x = match e with
- | Null -> f x
- | Cons (e, c, a, b) -> fold_right (map f e c a b) map e x
-
-(* used in MetaBrg.unwind_to_xlate_term *)
-let rec fold_left map x = function
- | Null -> x
- | Cons (e, _, a, b) -> fold_left map (map x a b) e
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module U = NUri
-module H = U.UriHash
-module Y = Entity
-module B = Brg
-
-let hsize = 7000
-let env = H.create hsize
-
-(* Internal functions *******************************************************)
-
-let get_age =
- let age = ref 0 in
- fun () -> incr age; !age
-
-(* Interface functions ******************************************************)
-
-(* decps *)
-let set_entity (a, uri, b) =
- let age = get_age () in
- let entity = (Y.Apix age :: a), uri, b in
- H.add env uri entity; entity
-
-let get_entity uri =
- try H.find env uri with Not_found -> [], uri, Y.Void
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-val set_entity: Brg.entity -> Brg.entity
-
-val get_entity: Brg.uri -> Brg.entity
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module P = Printf
-module F = Format
-module C = Cps
-module U = NUri
-module L = Log
-module O = Options
-module Y = Entity
-module X = Library
-module H = Hierarchy
-module B = Brg
-
-(* nodes count **************************************************************)
-
-type counters = {
- eabsts: int;
- eabbrs: int;
- evoids: int;
- tsorts: int;
- tlrefs: int;
- tgrefs: int;
- tcasts: int;
- tappls: int;
- tabsts: int;
- tabbrs: int;
- tvoids: int;
- uris : B.uri list;
- nodes : int;
- xnodes: int
-}
-
-let initial_counters = {
- eabsts = 0; eabbrs = 0; evoids = 0;
- tsorts = 0; tlrefs = 0; tgrefs = 0; tcasts = 0; tappls = 0;
- tabsts = 0; tabbrs = 0; tvoids = 0;
- uris = []; nodes = 0; xnodes = 0
-}
-
-let rec count_term_binder f c e = function
- | B.Abst w ->
- let c = {c with tabsts = succ c.tabsts; nodes = succ c.nodes} in
- count_term f c e w
- | B.Abbr v ->
- let c = {c with tabbrs = succ c.tabbrs; xnodes = succ c.xnodes} in
- count_term f c e v
- | B.Void ->
- let c = {c with tvoids = succ c.tvoids; xnodes = succ c.xnodes} in
- f c
-
-and count_term f c e = function
- | B.Sort _ ->
- f {c with tsorts = succ c.tsorts; nodes = succ c.nodes}
- | B.LRef (_, i) ->
- begin match B.get e i with
- | _, _, _, B.Abst _
- | _, _, _, B.Void ->
- f {c with tlrefs = succ c.tlrefs; nodes = succ c.nodes}
- | _, _, _, B.Abbr _ ->
- f {c with tlrefs = succ c.tlrefs; xnodes = succ c.xnodes}
- end
- | B.GRef (_, u) ->
- let c =
- if Cps.list_mem ~eq:U.eq u c.uris
- then {c with nodes = succ c.nodes}
- else {c with xnodes = succ c.xnodes}
- in
- f {c with tgrefs = succ c.tgrefs}
- | B.Cast (_, v, t) ->
- let c = {c with tcasts = succ c.tcasts} in
- let f c = count_term f c e t in
- count_term f c e v
- | B.Appl (_, v, t) ->
- let c = {c with tappls = succ c.tappls; nodes = succ c.nodes} in
- let f c = count_term f c e t in
- count_term f c e v
- | B.Bind (a, b, t) ->
- let f c = count_term f c (B.push e B.empty a b) t in
- count_term_binder f c e b
-
-let count_entity f c = function
- | _, u, Y.Abst w ->
- let c = {c with
- eabsts = succ c.eabsts; nodes = succ c.nodes; uris = u :: c.uris
- } in
- count_term f c B.empty w
- | _, _, Y.Abbr v ->
- let c = {c with eabbrs = succ c.eabbrs; xnodes = succ c.xnodes} in
- count_term f c B.empty v
- | _, _, Y.Void -> assert false
-
-let print_counters f c =
- let terms =
- c.tsorts + c.tgrefs + c.tgrefs + c.tcasts + c.tappls + c.tabsts +
- c.tabbrs
- in
- let items = c.eabsts + c.eabbrs in
- let nodes = c.nodes + c.xnodes in
- L.warn (P.sprintf " Kernel representation summary (basic_rg)");
- L.warn (P.sprintf " Total entry items: %7u" items);
- L.warn (P.sprintf " Declaration items: %7u" c.eabsts);
- L.warn (P.sprintf " Definition items: %7u" c.eabbrs);
- L.warn (P.sprintf " Total term items: %7u" terms);
- L.warn (P.sprintf " Sort items: %7u" c.tsorts);
- L.warn (P.sprintf " Local reference items: %7u" c.tlrefs);
- L.warn (P.sprintf " Global reference items: %7u" c.tgrefs);
- L.warn (P.sprintf " Explicit Cast items: %7u" c.tcasts);
- L.warn (P.sprintf " Application items: %7u" c.tappls);
- L.warn (P.sprintf " Abstraction items: %7u" c.tabsts);
- L.warn (P.sprintf " Abbreviation items: %7u" c.tabbrs);
- L.warn (P.sprintf " Global Int. Complexity: %7u" c.nodes);
- L.warn (P.sprintf " + Abbreviation nodes: %7u" nodes);
- f ()
-
-(* supplementary annotation *************************************************)
-
-let rec does_not_occur f n r = function
- | B.Null -> f true
- | B.Cons (e, _, a, _) ->
- let f n1 r1 =
- if n1 = n && r1 = r then f false else does_not_occur f n r e
- in
- Y.name C.err f a
-
-let rename f e a =
- let rec aux f e n r =
- let f = function
- | true -> f n r
- | false -> aux f e (n ^ "_") r
- in
- does_not_occur f n r e
- in
- let f n0 r0 =
- let f n r = if n = n0 && r = r0 then f a else f (Y.Name (n, r) :: a) in
- aux f e n0 r0
- in
- Y.name C.err f a
-
-(* lenv/term pretty printing ************************************************)
-
-let name err frm a =
- let f n = function
- | true -> F.fprintf frm "%s" n
- | false -> F.fprintf frm "^%s" n
- in
- Y.name err f a
-
-let rec pp_term e frm = function
- | B.Sort (_, h) ->
- let err _ = F.fprintf frm "@[*%u@]" h in
- let f s = F.fprintf frm "@[%s@]" s in
- H.string_of_sort err f h
- | B.LRef (_, i) ->
- let err _ = F.fprintf frm "@[#%u@]" i in
- if !O.indexes then err () else
- let _, _, a, b = B.get e i in
- F.fprintf frm "@[%a@]" (name err) a
- | B.GRef (_, s) ->
- F.fprintf frm "@[$%s@]" (U.string_of_uri s)
- | B.Cast (_, u, t) ->
- F.fprintf frm "@[{%a}.%a@]" (pp_term e) u (pp_term e) t
- | B.Appl (_, v, t) ->
- F.fprintf frm "@[(%a).%a@]" (pp_term e) v (pp_term e) t
- | B.Bind (a, B.Abst w, t) ->
- let f a =
- let ee = B.push e B.empty a (B.abst w) in
- F.fprintf frm "@[[%a:%a].%a@]" (name C.err) a (pp_term e) w (pp_term ee) t
- in
- rename f e a
- | B.Bind (a, B.Abbr v, t) ->
- let f a =
- let ee = B.push e B.empty a (B.abbr v) in
- F.fprintf frm "@[[%a=%a].%a@]" (name C.err) a (pp_term e) v (pp_term ee) t
- in
- rename f e a
- | B.Bind (a, B.Void, t) ->
- let f a =
- let ee = B.push e B.empty a B.Void in
- F.fprintf frm "@[[%a].%a@]" (name C.err) a (pp_term ee) t
- in
- rename f e a
-
-let pp_lenv frm e =
- let pp_entry f e c a b x = f x (*match b with
- | B.Abst (a, w) ->
- let f a = F.fprintf frm "@,@[%a : %a@]" (name C.err) a (pp_term e) w; f a in
- rename f x a
- | B.Abbr (a, v) ->
- let f a = F.fprintf frm "@,@[%a = %a@]" (name C.err) a (pp_term e) v; f a in
- rename f c a
- | B.Void a ->
- let f a = F.fprintf frm "@,%a" (name C.err) a; f a in
- rename f c a
-*) in
- B.fold_right ignore pp_entry e B.empty
-
-let specs = {
- L.pp_term = pp_term; L.pp_lenv = pp_lenv
-}
-
-(* term xml printing ********************************************************)
-
-let rec exp_term e t out tab = match t with
- | B.Sort (a, l) ->
- let a =
- let err _ = a in
- let f s = Y.Name (s, true) :: a in
- H.string_of_sort err f l
- in
- let attrs = [X.position l; X.name a] in
- X.tag X.sort attrs out tab
- | B.LRef (a, i) ->
- let a =
- let err _ = a in
- let f n r = Y.Name (n, r) :: a in
- let _, _, a, b = B.get e i in
- Y.name err f a
- in
- let attrs = [X.position i; X.name a] in
- X.tag X.lref attrs out tab
- | B.GRef (a, n) ->
- let a = Y.Name (U.name_of_uri n, true) :: a in
- let attrs = [X.uri n; X.name a] in
- X.tag X.gref attrs out tab
- | B.Cast (a, u, t) ->
- let attrs = [] in
- X.tag X.cast attrs ~contents:(exp_term e u) out tab;
- exp_term e t out tab
- | B.Appl (a, v, t) ->
- let attrs = [] in
- X.tag X.appl attrs ~contents:(exp_term e v) out tab;
- exp_term e t out tab
- | B.Bind (a, b, t) ->
- let a = rename C.start e a in
- exp_bind e a b out tab;
- exp_term (B.push e B.empty a b) t out tab
-
-and exp_bind e a b out tab = match b with
- | B.Abst w ->
- let attrs = [X.name a; X.mark a] in
- X.tag X.abst attrs ~contents:(exp_term e w) out tab
- | B.Abbr v ->
- let attrs = [X.name a; X.mark a] in
- X.tag X.abbr attrs ~contents:(exp_term e v) out tab
- | B.Void ->
- let attrs = [X.name a; X.mark a] in
- X.tag X.void attrs out tab
-
-let export_term = exp_term B.empty
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type counters
-
-val initial_counters: counters
-
-val count_entity: (counters -> 'a) -> counters -> Brg.entity -> 'a
-
-val print_counters: (unit -> 'a) -> counters -> 'a
-
-val specs: (Brg.lenv, Brg.term) Log.specs
-
-val export_term: Brg.term -> Library.pp
-(*
-val export_term: Format.formatter -> Brg.term -> unit
-*)
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module U = NUri
-module C = Cps
-module S = Share
-module L = Log
-module Y = Entity
-module P = Output
-module B = Brg
-module O = BrgOutput
-module E = BrgEnvironment
-
-type kam = {
- e: B.lenv; (* environment *)
- s: (B.lenv * B.term) list; (* stack *)
- d: int (* depth *)
-}
-
-(* Internal functions *******************************************************)
-
-let level = 5
-
-let log1 s c t =
- let sc, st = s ^ " in the environment", "the term" in
- L.log O.specs level (L.et_items1 sc c st t)
-
-let log2 s cu u ct t =
- let s1, s2, s3 = s ^ " in the environment", "the term", "and in the environment" in
- L.log O.specs level (L.et_items2 s1 cu s2 u ~sc2:s3 ~c2:ct s2 t)
-
-let rec list_and map = function
- | hd1 :: tl1, hd2 :: tl2 ->
- if map hd1 hd2 then list_and map (tl1, tl2) else false
- | l1, l2 -> l1 = l2
-
-(* check closure *)
-let are_alpha_convertible err f t1 t2 =
- let rec aux f = function
- | B.Sort (_, p1), B.Sort (_, p2)
- | B.LRef (_, p1), B.LRef (_, p2) ->
- if p1 = p2 then f () else err ()
- | B.GRef (_, u1), B.GRef (_, u2) ->
- if U.eq u1 u2 then f () else err ()
- | B.Cast (_, v1, t1), B.Cast (_, v2, t2)
- | B.Appl (_, v1, t1), B.Appl (_, v2, t2) ->
- let f _ = aux f (t1, t2) in
- aux f (v1, v2)
- | B.Bind (_, b1, t1), B.Bind (_, b2, t2) ->
- let f _ = aux f (t1, t2) in
- aux_bind f (b1, b2)
- | _ -> err ()
- and aux_bind f = function
- | B.Abbr v1, B.Abbr v2
- | B.Abst v1, B.Abst v2 -> aux f (v1, v2)
- | B.Void, B.Void -> f ()
- | _ -> err ()
- in
- if S.eq t1 t2 then f () else aux f (t1, t2)
-
-let get m i =
- let _, c, a, b = B.get m.e i in c, a, b
-
-(* to share *)
-let rec step st m x =
-(* L.warn "entering R.step"; *)
- match x with
- | B.Sort _ -> m, None, x
- | B.GRef (_, uri) ->
- begin match E.get_entity uri with
- | _, _, Y.Abbr v when st.Y.delta ->
- P.add ~gdelta:1 (); step st m v
- | _, _, Y.Abst w when st.Y.rt ->
- P.add ~grt:1 (); step st m w
- | a, _, Y.Abbr v ->
- let e = Y.apix C.err C.start a in
- m, Some (e, a, B.Abbr v), x
- | a, _, Y.Abst w ->
- let e = Y.apix C.err C.start a in
- m, Some (e, a, B.Abst w), x
- | _, _, Y.Void -> assert false
- end
- | B.LRef (_, i) ->
- begin match get m i with
- | c, _, B.Abbr v ->
- P.add ~ldelta:1 ();
- step st {m with e = c} v
- | c, _, B.Abst w when st.Y.rt ->
- P.add ~lrt:1 ();
- step st {m with e = c} w
- | c, _, B.Void ->
- assert false
- | c, a, (B.Abst _ as b) ->
- let e = Y.apix C.err C.start a in
- {m with e = c}, Some (e, a, b), x
- end
- | B.Cast (_, _, t) ->
- P.add ~tau:1 ();
- step st m t
- | B.Appl (_, v, t) ->
- step st {m with s = (m.e, v) :: m.s} t
- | B.Bind (a, B.Abst w, t) ->
- begin match m.s with
- | [] -> m, None, x
- | (c, v) :: s ->
- P.add ~beta:1 ~upsilon:(List.length s) ();
- let e = B.push m.e c a (B.abbr v) (* (B.Cast ([], w, v)) *) in
- step st {m with e = e; s = s} t
- end
- | B.Bind (a, b, t) ->
- P.add ~upsilon:(List.length m.s) ();
- let e = B.push m.e m.e a b in
- step st {m with e = e} t
-
-let push m a b =
- assert (m.s = []);
- let a, d = match b with
- | B.Abst _ -> Y.Apix m.d :: a, succ m.d
- | b -> a, m.d
- in
- let e = B.push m.e m.e a b in
- {m with e = e; d = d}
-
-let rec ac_nfs st (m1, r1, u) (m2, r2, t) =
- log2 "Now converting nfs" m1.e u m2.e t;
- match r1, u, r2, t with
- | _, B.Sort (_, h1), _, B.Sort (_, h2) ->
- h1 = h2
- | Some (e1, _, B.Abst _), _, Some (e2, _, B.Abst _), _ ->
- if e1 = e2 then ac_stacks st m1 m2 else false
- | Some (e1, _, B.Abbr v1), _, Some (e2, _, B.Abbr v2), _ ->
- if e1 = e2 then
- if ac_stacks st m1 m2 then true else begin
- P.add ~gdelta:2 (); ac st m1 v1 m2 v2
- end
- else if e1 < e2 then begin
- P.add ~gdelta:1 ();
- ac_nfs st (m1, r1, u) (step st m2 v2)
- end else begin
- P.add ~gdelta:1 ();
- ac_nfs st (step st m1 v1) (m2, r2, t)
- end
- | _, _, Some (_, _, B.Abbr v2), _ ->
- P.add ~gdelta:1 ();
- ac_nfs st (m1, r1, u) (step st m2 v2)
- | Some (_, _, B.Abbr v1), _, _, _ ->
- P.add ~gdelta:1 ();
- ac_nfs st (step st m1 v1) (m2, r2, t)
- | _, B.Bind (a1, (B.Abst w1 as b1), t1),
- _, B.Bind (a2, (B.Abst w2 as b2), t2) ->
- if ac {st with Y.si = false} m1 w1 m2 w2 then
- ac st (push m1 a1 b1) t1 (push m2 a2 b2) t2
- else false
- | _, B.Sort _, _, B.Bind (a, b, t) when st.Y.si ->
- P.add ~si:1 ();
- ac st (push m1 a b) u (push m2 a b) t
- | _ -> false
-
-and ac st m1 t1 m2 t2 =
-(* L.warn "entering R.are_convertible"; *)
- ac_nfs st (step st m1 t1) (step st m2 t2)
-
-and ac_stacks st m1 m2 =
-(* L.warn "entering R.are_convertible_stacks"; *)
- if List.length m1.s <> List.length m2.s then false else
- let map (c1, v1) (c2, v2) =
- let m1, m2 = {m1 with e = c1; s = []}, {m2 with e = c2; s = []} in
- ac {st with Y.si = false} m1 v1 m2 v2
- in
- list_and map (m1.s, m2.s)
-
-(* Interface functions ******************************************************)
-
-let empty_kam = {
- e = B.empty; s = []; d = 0
-}
-
-let get m i =
- assert (m.s = []);
- let _, _, _, b = B.get m.e i in b
-
-let xwhd st m t =
- L.box level; log1 "Now scanning" m.e t;
- let m, _, t = step {st with Y.delta = true; Y.rt = true} m t in
- L.unbox level; m, t
-
-let are_convertible st mu u mw w =
- L.box level; log2 "Now converting" mu.e u mw.e w;
- let r = ac {st with Y.delta = st.Y.expand; Y.rt = false} mu u mw w in
- L.unbox level; r
-(* let err _ = in
- if S.eq mu mw then are_alpha_convertible err f u w else err () *)
-
-(* error reporting **********************************************************)
-
-let pp_term m frm t = O.specs.L.pp_term m.e frm t
-
-let pp_lenv frm m = O.specs.L.pp_lenv frm m.e
-
-let specs = {
- L.pp_term = pp_term; L.pp_lenv = pp_lenv
-}
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type kam
-
-val empty_kam: kam
-
-val get: kam -> int -> Brg.bind
-
-val push: kam -> Entity.attrs -> Brg.bind -> kam
-
-val xwhd: Entity.status -> kam -> Brg.term -> kam * Brg.term
-
-(* arguments: expected type, inferred type *)
-val are_convertible:
- Entity.status -> kam -> Brg.term -> kam -> Brg.term -> bool
-
-val specs: (kam, Brg.term) Log.specs
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module B = Brg
-(* module O = Output *)
-
-let rec icm a = function
- | B.Sort _
- | B.LRef _
- | B.GRef _ -> succ a
- | B.Bind (_, B.Void, t) -> icm (succ a) t
- | B.Cast (_, u, t) -> icm (icm a u) t
- | B.Appl (_, u, t)
- | B.Bind (_, B.Abst u, t)
- | B.Bind (_, B.Abbr u, t) -> icm (icm (succ a) u) t
-
-let iter map d =
- let rec iter_bind d = function
- | B.Void -> B.Void
- | B.Abst w -> B.Abst (iter_term d w)
- | B.Abbr v -> B.Abbr (iter_term d v)
- and iter_term d = function
- | B.Sort _ as t -> t
- | B.GRef _ as t -> t
- | B.LRef (a, i) as t -> if i < d then t else map d a i
- | B.Cast (a, w, v) -> B.Cast (a, iter_term d w, iter_term d v)
- | B.Appl (a, w, u) -> B.Appl (a, iter_term d w, iter_term d u)
- | B.Bind (a, b, u) -> B.Bind (a, iter_bind d b, iter_term (succ d) u)
- in
- iter_term d
-
-let lift_map h _ a i =
- if i + h >= 0 then B.LRef (a, i + h) else assert false
-
-let lift h d t =
- if h = 0 then t else begin
-(* O.icm := succ (* icm *) !O.icm (*t*); *) iter (lift_map h) d t
- end
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-val lift: int -> int -> Brg.term -> Brg.term
-(*
-val lift_bind: (Brg.bind -> 'a) -> int -> int -> Brg.bind -> 'a
-*)
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module U = NUri
-module C = Cps
-module A = Share
-module L = Log
-module H = Hierarchy
-module Y = Entity
-module B = Brg
-module O = BrgOutput
-module E = BrgEnvironment
-module S = BrgSubstitution
-module R = BrgReduction
-
-type message = (R.kam, B.term) Log.message
-
-(* Internal functions *******************************************************)
-
-let level = 4
-
-let message1 st1 m t1 =
- L.et_items1 "In the environment" m st1 t1
-
-let log1 s m t =
- let s = s ^ " the term" in
- L.log R.specs level (message1 s m t)
-
-let error1 err s m t =
- err (message1 s m t)
-
-let message3 m t1 t2 ?mu t3 =
- let sm, st1, st2 = "In the environment", "the term", "is of type" in
- match mu with
- | Some mu ->
- let smu, st3 = "but in the environment", "it must be of type" in
- L.et_items3 sm m st1 t1 st2 t2 ~sc3:smu ~c3:mu st3 t3
- | None ->
- let st3 = "but it must be of type" in
- L.et_items3 sm m st1 t1 st2 t2 st3 t3
-
-let error3 err m t1 t2 ?mu t3 =
- err (message3 m t1 t2 ?mu t3)
-
-let assert_convertibility err f st m u w v =
- if R.are_convertible st m u m w then f () else
- error3 err m v w u
-
-let assert_applicability err f st m u w v =
- match R.xwhd st m u with
- | _, B.Sort _ -> error1 err "not a function type" m u
- | mu, B.Bind (_, B.Abst u, _) ->
- if R.are_convertible st mu u m w then f () else
- error3 err m v w ~mu u
- | _ -> assert false (**)
-
-let rec b_type_of err f st m x =
- log1 "Now checking" m x;
- match x with
- | B.Sort (a, h) ->
- let h = H.apply h in f x (B.Sort (a, h))
- | B.LRef (_, i) ->
- begin match R.get m i with
- | B.Abst w ->
- f x (S.lift (succ i) (0) w)
- | B.Abbr (B.Cast (_, w, _)) ->
- f x (S.lift (succ i) (0) w)
- | B.Abbr _ -> assert false
- | B.Void ->
- error1 err "reference to excluded variable" m x
- end
- | B.GRef (_, uri) ->
- begin match E.get_entity uri with
- | _, _, Y.Abst w -> f x w
- | _, _, Y.Abbr (B.Cast (_, w, _)) -> f x w
- | _, _, Y.Abbr _ -> assert false
- | _, _, Y.Void ->
- error1 err "reference to unknown entry" m x
- end
- | B.Bind (a, B.Abbr v, t) ->
- let f xv xt tt =
- f (A.sh2 v xv t xt x (B.bind_abbr a)) (B.bind_abbr a xv tt)
- in
- let f xv m = b_type_of err (f xv) st m t in
- let f xv = f xv (R.push m a (B.abbr xv)) in
- let f xv vv = match xv with
- | B.Cast _ -> f xv
- | _ -> f (B.Cast ([], vv, xv))
- in
- type_of err f st m v
- | B.Bind (a, B.Abst u, t) ->
- let f xu xt tt =
- f (A.sh2 u xu t xt x (B.bind_abst a)) (B.bind_abst a xu tt)
- in
- let f xu m = b_type_of err (f xu) st m t in
- let f xu _ = f xu (R.push m a (B.abst xu)) in
- type_of err f st m u
- | B.Bind (a, B.Void, t) ->
- let f xt tt =
- f (A.sh1 t xt x (B.bind_void a)) (B.bind_void a tt)
- in
- b_type_of err f st (R.push m a B.Void) t
-
- | B.Appl (a, v, t) ->
- let f xv vv xt tt =
- let f _ = f (A.sh2 v xv t xt x (B.appl a)) (B.appl a xv tt) in
- assert_applicability err f st m tt vv xv
- in
- let f xv vv = b_type_of err (f xv vv) st m t in
- type_of err f st m v
- | B.Cast (a, u, t) ->
- let f xu xt tt =
- let f _ = f (A.sh2 u xu t xt x (B.cast a)) xu in
- assert_convertibility err f st m xu tt xt
- in
- let f xu _ = b_type_of err (f xu) st m t in
- type_of err f st m u
-
-(* Interface functions ******************************************************)
-
-and type_of err f st m x =
- let f t u = L.unbox level; f t u in
- L.box level; b_type_of err f st m x
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type message = (BrgReduction.kam, Brg.term) Log.message
-
-val type_of:
- (message -> 'a) -> (Brg.term -> Brg.term -> 'a) ->
- Entity.status -> BrgReduction.kam -> Brg.term -> 'a
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module U = NUri
-module L = Log
-module Y = Entity
-module B = Brg
-module E = BrgEnvironment
-module R = BrgReduction
-module T = BrgType
-
-(* Interface functions ******************************************************)
-
-(* to share *)
-let type_check err f st = function
- | a, uri, Y.Abst t ->
- let f xt tt =
- let e = E.set_entity (a, uri, Y.Abst xt) in f tt e
- in
- L.loc := U.string_of_uri uri; T.type_of err f st R.empty_kam t
- | a, uri, Y.Abbr t ->
- let f xt tt =
- let xt = match xt with
- | B.Cast _ -> xt
- | _ -> B.Cast ([], tt, xt)
- in
- let e = E.set_entity (a, uri, Y.Abbr xt) in f tt e
- in
- L.loc := U.string_of_uri uri; T.type_of err f st R.empty_kam t
- | _, _, Y.Void -> assert false
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-val type_check:
- (BrgType.message -> 'a) -> (Brg.term -> Brg.entity -> 'a) ->
- Entity.status -> Brg.entity -> 'a
+++ /dev/null
-options hierarchy output entity marks alpha library
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module Y = Entity
-
-(* internal functions *******************************************************)
-
-let rec rename ns n =
- let token, mode = n in
- let n = token ^ "_", mode in
- if List.mem n ns then rename ns n else n
-
-let alpha_name acc attr =
- let ns, a = acc in
- match attr with
- | Y.Name n ->
- if List.mem n ns then
- let n = rename ns n in
- n :: ns, Y.Name n :: a
- else
- n :: ns, attr :: a
- | _ -> assert false
-
-(* interface functions ******************************************************)
-
-let alpha ns a =
- let f a names =
- let _, names = List.fold_left alpha_name (ns, []) (List.rev names) in
- List.rev_append a names
- in
- Y.get_names f a
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-val alpha: Entity.names -> Entity.attrs -> Entity.attrs
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module O = Options
-
-type uri = NUri.uri
-type id = Aut.id
-type name = id * bool (* token, real? *)
-
-type names = name list
-
-type attr = Name of name (* name *)
- | Apix of int (* additional position index *)
- | Mark of int (* node marker *)
- | Meta of string (* metaliguistic annotation *)
- | Priv (* private global definition *)
-
-type attrs = attr list (* attributes *)
-
-type 'term bind = Abst of 'term (* declaration: domain *)
- | Abbr of 'term (* definition: body *)
- | Void (* exclusion *)
-
-type 'term entity = attrs * uri * 'term bind (* attrs, name, binder *)
-
-type status = {
- delta: bool; (* global delta-expansion *)
- rt: bool; (* reference typing *)
- si: bool; (* sort inclusion *)
- expand: bool (* always expand global definitions *)
-}
-
-(* helpers ******************************************************************)
-
-let common f (a, u, _) = f a u
-
-let rec name err f = function
- | Name (n, r) :: _ -> f n r
- | _ :: tl -> name err f tl
- | [] -> err ()
-
-let names f map l a =
- let rec aux f i a = function
- | [] -> f a
- | Name (n, r) :: tl -> aux (map f i n r) false a tl
- | _ :: tl -> aux f i a tl
- in
- aux f true a l
-
-let rec get_name err f j = function
- | [] -> err ()
- | Name (n, r) :: _ when j = 0 -> f n r
- | Name _ :: tl -> get_name err f (pred j) tl
- | _ :: tl -> get_name err f j tl
-
-let rec get_names f = function
- | [] -> f [] []
- | Name _ as n :: tl ->
- let f a ns = f a (n :: ns) in get_names f tl
- | e :: tl ->
- let f a = f (e :: a) in get_names f tl
-
-let count_names a =
- let rec aux k = function
- | [] -> k
- | Name _ :: tl -> aux (succ k) tl
- | _ :: tl -> aux k tl
- in
- aux 0 a
-
-let rec apix err f = function
- | Apix i :: _ -> f i
- | _ :: tl -> apix err f tl
- | [] -> err ()
-
-let rec mark err f = function
- | Mark i :: _ -> f i
- | _ :: tl -> mark err f tl
- | [] -> err ()
-
-let rec priv err f = function
- | Priv :: _ -> f ()
- | _ :: tl -> priv err f tl
- | [] -> err ()
-
-let rec meta err f = function
- | Meta s :: _ -> f s
- | _ :: tl -> meta err f tl
- | [] -> err ()
-
-let resolve err f name a =
- let rec aux i = function
- | Name (n, true) :: _ when n = name -> f i
- | _ :: tl -> aux (succ i) tl
- | [] -> err i
- in
- aux 0 a
-
-let rec rev_append_names ns = function
- | [] -> ns
- | Name n :: tl -> rev_append_names (n :: ns) tl
- | _ :: tl -> rev_append_names ns tl
-
-let xlate f xlate_term = function
- | a, uri, Abst t ->
- let f t = f (a, uri, Abst t) in xlate_term f t
- | a, uri, Abbr t ->
- let f t = f (a, uri, Abbr t) in xlate_term f t
- | _, _, Void ->
- assert false
-
-let initial_status () = {
- delta = false; rt = false; si = !O.si; expand = !O.expand
-}
-
-let refresh_status st = {st with
- si = !O.si; expand = !O.expand
-}
-
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module H = Hashtbl
-module S = Scanf
-module C = Cps
-
-type graph = string * (int -> int)
-
-let sorts = 3
-let sort = H.create sorts
-
-let default_graph = "Z1"
-
-(* Internal functions *******************************************************)
-
-let set_sort h s =
- H.add sort h s; succ h
-
-let graph_of_string err f s =
- try
- let x = S.sscanf s "Z%u" C.start in
- if x > 0 then f (s, fun h -> x + h) else err ()
- with
- S.Scan_failure _ | Failure _ | End_of_file -> err ()
-
-let graph = ref (graph_of_string C.err C.start default_graph)
-
-(* Interface functions ******************************************************)
-
-let set_sorts i ss =
- List.fold_left set_sort i ss
-
-let string_of_sort err f h =
- try f (H.find sort h) with Not_found -> err ()
-
-let sort_of_string err f s =
- let map h n = function
- | None when n = s -> Some h
- | xh -> xh
- in
- match H.fold map sort None with
- | None -> err ()
- | Some h -> f h
-
-let string_of_graph () = fst !graph
-
-let apply h = snd !graph h
-
-let set_graph s =
- let err () = false in
- let f g = graph := g; true in
- graph_of_string err f s
-
-let clear () =
- H.clear sort; graph := graph_of_string C.err C.start default_graph
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-val set_sorts: int -> string list -> int
-
-val string_of_sort: (unit -> 'a) -> (string -> 'a) -> int -> 'a
-
-val sort_of_string: (unit -> 'a) -> (int -> 'a) -> string -> 'a
-
-val set_graph: string -> bool
-
-val string_of_graph: unit -> string
-
-val apply: int -> int
-
-val clear: unit -> unit
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module F = Filename
-module U = NUri
-module C = Cps
-module H = Hierarchy
-module Y = Entity
-
-(* internal functions *******************************************************)
-
-let base = "xml"
-
-let obj_ext = ".xml"
-
-let root = "ENTITY"
-
-let system = "http://helm.cs.unibo.it/lambda-delta/" ^ base ^ "/ld.dtd"
-
-let path_of_uri xdir uri =
- let base = F.concat xdir base in
- F.concat base (Str.string_after (U.string_of_uri uri) 3)
-
-(* interface functions ******************************************************)
-
-type och = string -> unit
-
-type attr = string * string
-
-type pp = och -> int -> unit
-
-let attribute out (name, contents) =
- if contents <> "" then begin
- out " "; out name; out "=\""; out contents; out "\""
- end
-
-let xml out version encoding =
- out "<?xml";
- attribute out ("version", version);
- attribute out ("encoding", encoding);
- out "?>\n\n"
-
-let doctype out root system =
- out "<!DOCTYPE "; out root; out " SYSTEM \""; out system; out "\">\n\n"
-
-let tag tag attrs ?contents out indent =
- let spc = String.make indent ' ' in
- out spc; out "<"; out tag; List.iter (attribute out) attrs;
- match contents with
- | None -> out "/>\n"
- | Some cont ->
- out ">\n"; cont out (indent + 3); out spc;
- out "</"; out tag; out ">\n"
-
-let sort = "Sort"
-
-let lref = "LRef"
-
-let gref = "GRef"
-
-let cast = "Cast"
-
-let appl = "Appl"
-
-let proj = "Proj"
-
-let abst = "Abst"
-
-let abbr = "Abbr"
-
-let void = "Void"
-
-let position i =
- "position", string_of_int i
-
-let offset j =
- let contents = if j > 0 then string_of_int j else "" in
- "offset", contents
-
-let uri u =
- "uri", U.string_of_uri u
-
-let arity n =
- let contents = if n > 1 then string_of_int n else "" in
- "arity", contents
-
-let name a =
- let map f i n r s =
- let n = if r then n else "^" ^ n in
- let spc = if i then "" else " " in
- f (s ^ n ^ spc)
- in
- let f s = "name", s in
- Y.names f map a ""
-
-let mark a =
- let err () = "mark", "" in
- let f i = "mark", string_of_int i in
- Y.mark err f a
-
-(* TODO: the string s must be quoted *)
-let meta a =
- let err () = "meta", "" in
- let f s = "meta", s in
- Y.meta err f a
-
-let export_entity pp_term si xdir (a, u, b) =
- let path = path_of_uri xdir u in
- let _ = Sys.command (Printf.sprintf "mkdir -p %s" (F.dirname path)) in
- let och = open_out (path ^ obj_ext) in
- let out = output_string och in
- xml out "1.0" "UTF-8"; doctype out root system;
- let a = Y.Name (U.name_of_uri u, true) :: a in
- let attrs = [uri u; name a; mark a; meta a] in
- let contents = match b with
- | Y.Abst w -> tag "ABST" attrs ~contents:(pp_term w)
- | Y.Abbr v -> tag "ABBR" attrs ~contents:(pp_term v)
- | Y.Void -> assert false
- in
- let opts = if si then "si" else "" in
- let shp = H.string_of_graph () in
- let attrs = ["hierarchy", shp; "options", opts] in
- tag root attrs ~contents out 0;
- close_out och
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type och = string -> unit
-
-type attr = string * string
-
-type pp = och -> int -> unit
-
-val export_entity:
- ('term -> pp) -> bool -> string -> 'term Entity.entity -> unit
-
-val tag: string -> attr list -> ?contents:pp -> pp
-
-val sort: string
-
-val lref: string
-
-val gref: string
-
-val cast: string
-
-val appl: string
-
-val proj: string
-
-val abst: string
-
-val abbr: string
-
-val void: string
-
-val position: int -> attr
-
-val offset: int -> attr
-
-val uri: Entity.uri -> attr
-
-val arity: int -> attr
-
-val name: Entity.attrs -> attr
-
-val mark: Entity.attrs -> attr
-
-val meta: Entity.attrs -> attr
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module Y = Entity
-
-(* interface functions ******************************************************)
-
-let new_location =
- let location = ref 0 in
- fun () -> incr location; !location
-
-let new_mark () =
- Y.Mark (new_location ())
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module C = Cps
-
-type uri_generator = string -> string
-
-(* interface functions ******************************************************)
-
-let indexes = ref false (* show de Bruijn indexes *)
-
-let expand = ref false (* always expand global definitions *)
-
-let si = ref false (* use sort inclusion *)
-
-let unquote = ref false (* do not quote identifiers when lexing *)
-
-let icm = ref 0 (* complexity measure of relocated terms *)
-
-let cover = ref "" (* initial uri segment *)
-
-let debug_parser = ref false (* output parser debug information *)
-
-let debug_lexer = ref false (* output lexer debug information *)
-
-let mk_uri = ref (fun _ _ -> C.err : bool -> string -> uri_generator)
-
-let get_mk_uri () =
- !mk_uri !si !cover
-
-let clear () =
- expand := false; si := false; cover := ""; indexes := false; icm := 0;
- debug_parser := false; debug_lexer := false;
- mk_uri := fun _ _ -> C.err
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module P = Printf
-module L = Log
-module O = Options
-
-type reductions = {
- beta : int;
- zeta : int;
- upsilon: int;
- tau : int;
- ldelta : int;
- gdelta : int;
- si : int;
- lrt : int;
- grt : int
-}
-
-let initial_reductions = {
- beta = 0; upsilon = 0; tau = 0; zeta = 0; ldelta = 0; gdelta = 0;
- si = 0; lrt = 0; grt = 0
-}
-
-let reductions = ref initial_reductions
-
-let clear_reductions () = reductions := initial_reductions
-
-let add
- ?(beta=0) ?(upsilon=0) ?(tau=0) ?(ldelta=0) ?(gdelta=0) ?(zeta=0)
- ?(si=0) ?(lrt=0) ?(grt=0) ()
-= reductions := {
- beta = !reductions.beta + beta;
- zeta = !reductions.zeta + zeta;
- upsilon = !reductions.upsilon + upsilon;
- tau = !reductions.tau + tau;
- ldelta = !reductions.ldelta + ldelta;
- gdelta = !reductions.gdelta + gdelta;
- si = !reductions.si + si;
- lrt = !reductions.lrt + lrt;
- grt = !reductions.grt + grt
-}
-
-let print_reductions () =
- let r = !reductions in
- let rs = r.beta + r.ldelta + r.zeta + r.upsilon + r.tau + r.gdelta in
- let prs = r.si + r.lrt + r.grt in
- let delta = r.ldelta + r.gdelta in
- let rt = r.lrt + r.grt in
- L.warn (P.sprintf " Reductions summary");
- L.warn (P.sprintf " Proper reductions: %7u" rs);
- L.warn (P.sprintf " Beta: %7u" r.beta);
- L.warn (P.sprintf " Delta: %7u" delta);
- L.warn (P.sprintf " Local: %7u" r.ldelta);
- L.warn (P.sprintf " Global: %7u" r.gdelta);
- L.warn (P.sprintf " Zeta: %7u" r.zeta);
- L.warn (P.sprintf " Upsilon: %7u" r.upsilon);
- L.warn (P.sprintf " Tau: %7u" r.tau);
- L.warn (P.sprintf " Pseudo reductions: %7u" prs);
- L.warn (P.sprintf " Reference typing: %7u" rt);
- L.warn (P.sprintf " Local: %7u" r.lrt);
- L.warn (P.sprintf " Global: %7u" r.grt);
- L.warn (P.sprintf " Sort inclusion: %7u" r.si);
- L.warn (P.sprintf " Relocated nodes (icm): %7u" !O.icm)
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-val clear_reductions: unit -> unit
-
-val add:
- ?beta:int -> ?upsilon:int -> ?tau:int -> ?ldelta:int -> ?gdelta:int ->
- ?zeta:int -> ?si:int -> ?lrt:int -> ?grt:int ->
- unit -> unit
-
-val print_reductions: unit -> unit
+++ /dev/null
-crg crgOutput crgXml crgTxt crgAut crgBrg
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-(* kernel version: complete, relative, global *)
-(* note : fragment of complete lambda-delta serving as abstract layer *)
-
-module Y = Entity
-
-type uri = Y.uri
-type id = Y.id
-type attrs = Y.attrs
-
-type bind = Abst of term list (* domains *)
- | Abbr of term list (* bodies *)
- | Void of int (* number of exclusions *)
-
-and term = TSort of attrs * int (* attrs, hierarchy index *)
- | TLRef of attrs * int * int (* attrs, position indexes *)
- | TGRef of attrs * uri (* attrs, reference *)
- | TCast of attrs * term * term (* attrs, domain, element *)
- | TAppl of attrs * term list * term (* attrs, arguments, function *)
- | TProj of attrs * lenv * term (* attrs, closure, member *)
- | TBind of attrs * bind * term (* attrs, binder, scope *)
-
-and lenv = ESort (* top *)
- | EProj of lenv * attrs * lenv (* environment, attrs, closure *)
- | EBind of lenv * attrs * bind (* environment, attrs, binder *)
-
-type entity = term Y.entity
-
-(* helpers ******************************************************************)
-
-let mk_uri si root s =
- let kernel = if si then "crg-si" else "crg" in
- String.concat "/" ["ld:"; kernel; root; s ^ ".ld"]
-
-let empty_lenv = ESort
-
-let push_bind f lenv a b = f (EBind (lenv, a, b))
-
-let push_proj f lenv a e = f (EProj (lenv, a, e))
-
-let push2 err f lenv attr ?t () = match lenv, t with
- | EBind (e, a, Abst ws), Some t -> f (EBind (e, (attr :: a), Abst (t :: ws)))
- | EBind (e, a, Abbr vs), Some t -> f (EBind (e, (attr :: a), Abbr (t :: vs)))
- | EBind (e, a, Void n), None -> f (EBind (e, (attr :: a), Void (succ n)))
- | _ -> err ()
-
-(* this id not tail recursive *)
-let resolve_lref err f id lenv =
- let rec aux f i k = function
- | ESort -> err ()
- | EBind (tl, a, _) ->
- let err kk = aux f (succ i) (k + kk) tl in
- let f j = f i j (k + j) in
- Y.resolve err f id a
- | EProj _ -> assert false (* TODO *)
- in
- aux f 0 0 lenv
-
-let rec get_name err f i j = function
- | ESort -> err i
- | EBind (_, a, _) when i = 0 ->
- let err () = err i in
- Y.get_name err f j a
- | EBind (tl, _, _) ->
- get_name err f (pred i) j tl
- | EProj (tl, _, e) ->
- let err i = get_name err f i j tl in
- get_name err f i j e
-
-let get_index err f i j lenv =
- let rec aux f i k = function
- | ESort -> err i
- | EBind (_, a, _) when i = 0 ->
- if Y.count_names a > j then f (k + j) else err i
- | EBind (tl, a, _) ->
- aux f (pred i) (k + Y.count_names a) tl
- | EProj _ -> assert false (* TODO *)
- in
- aux f i 0 lenv
-
-let rec names_of_lenv ns = function
- | ESort -> ns
- | EBind (tl, a, _) -> names_of_lenv (Y.rev_append_names ns a) tl
- | EProj (tl, _, e) -> names_of_lenv (names_of_lenv ns e) tl
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module U = NUri
-module H = U.UriHash
-module C = Cps
-module O = Options
-module Y = Entity
-module A = Aut
-module D = Crg
-
-(* qualified identifier: uri, name, qualifiers *)
-type qid = D.uri * D.id * D.id list
-
-type context = Y.attrs * D.term list
-
-type context_node = qid option (* context node: None = root *)
-
-type status = {
- path: D.id list; (* current section path *)
- node: context_node; (* current context node *)
- nodes: context_node list; (* context node list *)
- line: int; (* line number *)
- mk_uri:O.uri_generator (* uri generator *)
-}
-
-type resolver = Local of int
- | Global of context
-
-let henv_size, hcnt_size = 7000, 4300 (* hash tables initial sizes *)
-
-let henv = H.create henv_size (* optimized global environment *)
-
-let hcnt = H.create hcnt_size (* optimized context *)
-
-(* Internal functions *******************************************************)
-
-let empty_cnt = [], []
-
-let add_abst (a, ws) id w =
- Y.Name (id, true) :: a, w :: ws
-
-let lenv_of_cnt (a, ws) =
- D.push_bind C.start D.empty_lenv a (D.Abst ws)
-
-let mk_lref f i j k = f (D.TLRef ([Y.Apix k], i, j))
-
-let id_of_name (id, _, _) = id
-
-let mk_qid f st id path =
- let str = String.concat "/" path in
- let str = Filename.concat str id in
- let str = st.mk_uri str in
- f (U.uri_of_string str, id, path)
-
-let uri_of_qid (uri, _, _) = uri
-
-let complete_qid f st (id, is_local, qs) =
- let f path = C.list_rev_append (mk_qid f st id) path ~tail:qs in
- let rec skip f = function
- | phd :: ptl, qshd :: _ when phd = qshd -> f ptl
- | _ :: ptl, _ :: _ -> skip f (ptl, qs)
- | _ -> f []
- in
- if is_local then f st.path else skip f (st.path, qs)
-
-let relax_qid f st (_, id, path) =
- let f = function
- | _ :: tl -> C.list_rev (mk_qid f st id) tl
- | [] -> assert false
- in
- C.list_rev f path
-
-let relax_opt_qid f st = function
- | None -> f None
- | Some qid -> let f qid = f (Some qid) in relax_qid f st qid
-
-let resolve_gref err f st qid =
- try let cnt = H.find henv (uri_of_qid qid) in f qid cnt
- with Not_found -> err qid
-
-let resolve_gref_relaxed f st qid =
-(* this is not tail recursive *)
- let rec err qid = relax_qid (resolve_gref err f st) st qid in
- resolve_gref err f st qid
-
-let get_cnt err f st = function
- | None -> f empty_cnt
- | Some qid as node ->
- try let cnt = H.find hcnt (uri_of_qid qid) in f cnt
- with Not_found -> err node
-
-let get_cnt_relaxed f st =
-(* this is not tail recursive *)
- let rec err node = relax_opt_qid (get_cnt err f st) st node in
- get_cnt err f st st.node
-
-(* this is not tail recursive in the GRef branch *)
-let rec xlate_term f st lenv = function
- | A.Sort s ->
- let f h = f (D.TSort ([], h)) in
- if s then f 0 else f 1
- | A.Appl (v, t) ->
- let f vv tt = f (D.TAppl ([], [vv], tt)) in
- let f vv = xlate_term (f vv) st lenv t in
- xlate_term f st lenv v
- | A.Abst (name, w, t) ->
- let f ww =
- let a, b = [Y.Name (name, true)], (D.Abst [ww]) in
- let f tt = f (D.TBind (a, b, tt)) in
- let f lenv = xlate_term f st lenv t in
- D.push_bind f lenv a b
- in
- xlate_term f st lenv w
- | A.GRef (name, args) ->
- let map1 f = function
- | Y.Name (id, _) -> f (A.GRef ((id, true, []), []))
- | _ -> C.err ()
- in
- let map2 f = xlate_term f st lenv in
- let g qid (a, _) =
- let gref = D.TGRef ([], uri_of_qid qid) in
- match args, a with
- | [], [] -> f gref
- | _ ->
- let f args = f (D.TAppl ([], args, gref)) in
- let f args = f (List.rev_map (map2 C.start) args) in
- let f a = C.list_rev_map_append f map1 a ~tail:args in
- C.list_sub_strict f a args
- in
- let g qid = resolve_gref_relaxed g st qid in
- let err () = complete_qid g st name in
- D.resolve_lref err (mk_lref f) (id_of_name name) lenv
-
-let xlate_entity err f st = function
- | A.Section (Some (_, name)) ->
- err {st with path = name :: st.path; nodes = st.node :: st.nodes}
- | A.Section None ->
- begin match st.path, st.nodes with
- | _ :: ptl, nhd :: ntl ->
- err {st with path = ptl; node = nhd; nodes = ntl}
- | _ -> assert false
- end
- | A.Context None ->
- err {st with node = None}
- | A.Context (Some name) ->
- let f name = err {st with node = Some name} in
- complete_qid f st name
- | A.Block (name, w) ->
- let f qid =
- let f cnt =
- let lenv = lenv_of_cnt cnt in
- let ww = xlate_term C.start st lenv w in
- H.add hcnt (uri_of_qid qid) (add_abst cnt name ww);
- err {st with node = Some qid}
- in
- get_cnt_relaxed f st
- in
- complete_qid f st (name, true, [])
- | A.Decl (name, w) ->
- let f cnt =
- let a, ws = cnt in
- let lenv = lenv_of_cnt cnt in
- let f qid =
- let ww = xlate_term C.start st lenv w in
- H.add henv (uri_of_qid qid) cnt;
- let t = match ws with
- | [] -> ww
- | _ -> D.TBind (a, D.Abst ws, ww)
- in
-(*
- print_newline (); CrgOutput.pp_term print_string t;
-*)
- let b = Y.Abst t in
- let entity = [Y.Mark st.line], uri_of_qid qid, b in
- f {st with line = succ st.line} entity
- in
- complete_qid f st (name, true, [])
- in
- get_cnt_relaxed f st
- | A.Def (name, w, trans, v) ->
- let f cnt =
- let a, ws = cnt in
- let lenv = lenv_of_cnt cnt in
- let f qid =
- let ww = xlate_term C.start st lenv w in
- let vv = xlate_term C.start st lenv v in
- H.add henv (uri_of_qid qid) cnt;
- let t = match ws with
- | [] -> D.TCast ([], ww, vv)
- | _ -> D.TBind (a, D.Abst ws, D.TCast ([], ww, vv))
- in
-(*
- print_newline (); CrgOutput.pp_term print_string t;
-*)
- let b = Y.Abbr t in
- let a = Y.Mark st.line :: if trans then [] else [Y.Priv] in
- let entity = a, uri_of_qid qid, b in
- f {st with line = succ st.line} entity
- in
- complete_qid f st (name, true, [])
- in
- get_cnt_relaxed f st
-
-(* Interface functions ******************************************************)
-
-let initial_status () =
- H.clear henv; H.clear hcnt; {
- path = []; node = None; nodes = []; line = 1; mk_uri = O.get_mk_uri ()
-}
-
-let refresh_status st = {st with
- mk_uri = O.get_mk_uri ()
-}
-
-let crg_of_aut = xlate_entity
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type status
-
-val initial_status: unit -> status
-
-val refresh_status: status -> status
-
-val crg_of_aut: (status -> 'a) -> (status -> Crg.entity -> 'a) ->
- status -> Aut.command -> 'a
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module C = Cps
-module Y = Entity
-module M = Marks
-module D = Crg
-module B = Brg
-
-(* internal functions: crg to brg term **************************************)
-
-let rec lenv_fold_left map1 map2 x = function
- | D.ESort -> x
- | D.EBind (tl, a, b) -> lenv_fold_left map1 map2 (map1 x a b) tl
- | D.EProj (tl, a, e) -> lenv_fold_left map1 map2 (map2 x a e) tl
-
-let rec xlate_term f = function
- | D.TSort (a, l) -> f (B.Sort (a, l))
- | D.TGRef (a, n) -> f (B.GRef (a, n))
- | D.TLRef (a, _, _) -> let f i = f (B.LRef (a, i)) in Y.apix C.err f a
- | D.TCast (a, u, t) ->
- let f uu tt = f (B.Cast (a, uu, tt)) in
- let f uu = xlate_term (f uu) t in
- xlate_term f u
- | D.TAppl (a, vs, t) ->
- let map f v tt = let f vv = f (B.Appl (a, vv, tt)) in xlate_term f v in
- let f tt = C.list_fold_right f map vs tt in
- xlate_term f t
- | D.TProj (a, e, t) ->
- let f tt = f (lenv_fold_left xlate_bind xlate_proj tt e) in
- xlate_term f t
- | D.TBind (ab, D.Abst ws, D.TCast (ac, u, t)) ->
- xlate_term f (D.TCast (ac, D.TBind (ab, D.Abst ws, u), D.TBind (ab, D.Abst ws, t)))
- | D.TBind (a, b, t) ->
- let f tt = f (xlate_bind tt a b) in xlate_term f t
-
-and xlate_bind x a b =
- let f a ns = a, ns in
- let a, ns = Y.get_names f a in
- match b with
- | D.Abst ws ->
- let map x n w =
- let f ww = B.Bind (n :: M.new_mark () :: a, B.Abst ww, x) in
- xlate_term f w
- in
- List.fold_left2 map x ns ws
- | D.Abbr vs ->
- let map x n v =
- let f vv = B.Bind (n :: a, B.Abbr vv, x) in
- xlate_term f v
- in
- List.fold_left2 map x ns vs
- | D.Void _ ->
- let map x n = B.Bind (n :: a, B.Void, x) in
- List.fold_left map x ns
-
-and xlate_proj x _ e =
- lenv_fold_left xlate_bind xlate_proj x e
-
-(* internal functions: brg to crg term **************************************)
-
-let rec xlate_bk_term f = function
- | B.Sort (a, l) -> f (D.TSort (a, l))
- | B.GRef (a, n) -> f (D.TGRef (a, n))
- | B.LRef (a, i) -> f (D.TLRef (a, i, 0))
- | B.Cast (a, u, t) ->
- let f uu tt = f (D.TCast (a, uu, tt)) in
- let f uu = xlate_bk_term (f uu) t in
- xlate_bk_term f u
- | B.Appl (a, u, t) ->
- let f uu tt = f (D.TAppl (a, [uu], tt)) in
- let f uu = xlate_bk_term (f uu) t in
- xlate_bk_term f u
- | B.Bind (a, b, t) ->
- let f bb tt = f (D.TBind (a, bb, tt)) in
- let f bb = xlate_bk_term (f bb) t in
- xlate_bk_bind f b
-
-and xlate_bk_bind f = function
- | B.Abst t ->
- let f tt = f (D.Abst [tt]) in
- xlate_bk_term f t
- | B.Abbr t ->
- let f tt = f (D.Abbr [tt]) in
- xlate_bk_term f t
- | B.Void -> f (D.Void 1)
-
-(* interface functions ******************************************************)
-
-let brg_of_crg f t =
- f (xlate_term C.start t)
-
-let crg_of_brg = xlate_bk_term
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-val brg_of_crg: (Brg.term -> 'a) -> Crg.term -> 'a
-
-val crg_of_brg: (Crg.term -> 'a) -> Brg.term -> 'a
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module P = Printf
-module U = NUri
-module C = Cps
-module H = Hierarchy
-module Y = Entity
-module D = Crg
-
-(****************************************************************************)
-
-let pp_attrs out a =
- let map = function
- | Y.Name (s, true) -> out (P.sprintf "%s;" s)
- | Y.Name (s, false) -> out (P.sprintf "~%s;" s)
- | Y.Apix i -> out (P.sprintf "+%i;" i)
- | Y.Mark i -> out (P.sprintf "@%i;" i)
- | Y.Meta s -> out (P.sprintf "\"%s\";" s)
- | Y.Priv -> out (P.sprintf "%s;" "~")
- in
- List.iter map a
-
-let rec pp_term out = function
- | D.TSort (a, l) -> pp_attrs out a; out (P.sprintf "*%u" l)
- | D.TLRef (a, i, j) -> pp_attrs out a; out (P.sprintf "#(%u,%u)" i j)
- | D.TGRef (a, u) -> pp_attrs out a; out (P.sprintf "$")
- | D.TCast (a, x, y) -> pp_attrs out a; out "<"; pp_term out x; out ">."; pp_term out y
- | D.TProj (a, x, y) -> assert false
- | D.TAppl (a, x, y) -> pp_attrs out a; pp_terms "(" ")" out x; pp_term out y
- | D.TBind (a, x, y) -> pp_attrs out a; pp_bind out x; pp_term out y
-
-and pp_terms bg eg out vs =
- let rec aux = function
- | [] -> ()
- | [v] -> pp_term out v
- | v :: vs -> pp_term out v; out ", "; aux vs
- in
- out bg; aux vs; out (eg ^ ".")
-
-and pp_bind out = function
- | D.Abst x -> pp_terms "[:" "]" out x
- | D.Abbr x -> pp_terms "[=" "]" out x
- | D.Void x -> out (P.sprintf "[%u]" x)
-
-let rec pp_lenv out = function
- | D.ESort -> ()
- | D.EProj (x, a, y) -> assert false
- | D.EBind (x, a, y) -> pp_lenv out x; pp_attrs out a; pp_bind out y
-
-(****************************************************************************)
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-val pp_term: (string -> unit) -> Crg.term -> unit
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module U = NUri
-module H = Hierarchy
-module C = Cps
-module O = Options
-module Y = Entity
-module T = Txt
-module TT = TxtTxt
-module D = Crg
-
-type status = {
- path : T.id list; (* current section path *)
- line : int; (* line number *)
- sort : int; (* first default sort index *)
- mk_uri: O.uri_generator (* uri generator *)
-}
-
-let henv_size = 7000 (* hash tables initial size *)
-
-let henv = Hashtbl.create henv_size (* optimized global environment *)
-
-(* Internal functions *******************************************************)
-
-let name_of_id ?(r=true) id = Y.Name (id, r)
-
-let mk_lref f i j k = f (D.TLRef ([Y.Apix k], i, j))
-
-let mk_gref f uri = f (D.TGRef ([], uri))
-
-let uri_of_id st id path =
- let str = String.concat "/" path in
- let str = Filename.concat str id in
- let str = st.mk_uri str in
- U.uri_of_string str
-
-let resolve_gref err f st id =
- try f (Hashtbl.find henv id)
- with Not_found -> err ()
-
-let rec xlate_term f st lenv = function
- | T.Inst _
- | T.Impl _ -> assert false
- | T.Sort h ->
- f (D.TSort ([], h))
- | T.NSrt id ->
- let f h = f (D.TSort ([], h)) in
- H.sort_of_string C.err f id
- | T.LRef (i, j) ->
- D.get_index C.err (mk_lref f i j) i j lenv
- | T.NRef id ->
- let err () = resolve_gref C.err (mk_gref f) st id in
- D.resolve_lref err (mk_lref f) id lenv
- | T.Cast (u, t) ->
- let f uu tt = f (D.TCast ([], uu, tt)) in
- let f uu = xlate_term (f uu) st lenv t in
- xlate_term f st lenv u
- | T.Appl (vs, t) ->
- let map f = xlate_term f st lenv in
- let f vvs tt = f (D.TAppl ([], vvs, tt)) in
- let f vvs = xlate_term (f vvs) st lenv t in
- C.list_map f map vs
- | T.Bind (b, t) ->
- let abst_map (lenv, a, wws) (id, r, w) =
- let attr = name_of_id ~r id in
- let ww = xlate_term C.start st lenv w in
- D.push2 C.err C.start lenv attr ~t:ww (), attr :: a, ww :: wws
- in
- let abbr_map (lenv, a, wws) (id, w) =
- let attr = name_of_id id in
- let ww = xlate_term C.start st lenv w in
- D.push2 C.err C.start lenv attr ~t:ww (), attr :: a, ww :: wws
- in
- let void_map (lenv, a, n) id =
- let attr = name_of_id id in
- D.push2 C.err C.start lenv attr (), attr :: a, succ n
- in
- let lenv, aa, bb = match b with
- | T.Abst xws ->
- let lenv = D.push_bind C.start lenv [] (D.Abst []) in
- let lenv, aa, wws = List.fold_left abst_map (lenv, [], []) xws in
- lenv, aa, D.Abst wws
- | T.Abbr xvs ->
- let lenv = D.push_bind C.start lenv [] (D.Abbr []) in
- let lenv, aa, vvs = List.fold_left abbr_map (lenv, [], []) xvs in
- lenv, aa, D.Abbr vvs
- | T.Void ids ->
- let lenv = D.push_bind C.start lenv [] (D.Void 0) in
- let lenv, aa, n = List.fold_left void_map (lenv, [], 0) ids in
- lenv, aa, D.Void n
- in
- let f tt = f (D.TBind (aa, bb, tt)) in
- xlate_term f st lenv t
-
-let xlate_term f st lenv t =
- TT.contract (xlate_term f st lenv) t
-
-let mk_contents tt = function
- | T.Decl -> [], Y.Abst tt
- | T.Ax -> [], Y.Abst tt
- | T.Def -> [], Y.Abbr tt
- | T.Th -> [], Y.Abbr tt
-
-let xlate_entity err f gen st = function
- | T.Require _ ->
- err st
- | T.Section (Some name) ->
- err {st with path = name :: st.path}
- | T.Section None ->
- begin match st.path with
- | _ :: ptl ->
- err {st with path = ptl}
- | _ -> assert false
- end
- | T.Sorts sorts ->
- let map st (xix, s) =
- let ix = match xix with
- | None -> st.sort
- | Some ix -> ix
- in
- {st with sort = H.set_sorts ix [s]}
- in
- err (List.fold_left map st sorts)
- | T.Graph id ->
- assert (H.set_graph id); err st
- | T.Entity (kind, id, meta, t) ->
- let uri = uri_of_id st id st.path in
- Hashtbl.add henv id uri;
- let tt = xlate_term C.start st D.empty_lenv t in
-(*
- print_newline (); CrgOutput.pp_term print_string tt;
-*)
- let a, b = mk_contents tt kind in
- let a = if meta <> "" then Y.Meta meta :: a else a in
- let entity = Y.Mark st.line :: a, uri, b in
- f {st with line = succ st.line} entity
- | T.Generate _ ->
- err st
-
-(* Interface functions ******************************************************)
-
-let initial_status () =
- Hashtbl.clear henv; {
- path = []; line = 1; sort = 0; mk_uri = O.get_mk_uri ()
-}
-
-let refresh_status st = {st with
- mk_uri = O.get_mk_uri ()
-}
-
-let crg_of_txt = xlate_entity
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type status
-
-val initial_status: unit -> status
-
-val refresh_status: status -> status
-
-val crg_of_txt: (status -> 'a) -> (status -> Crg.entity -> 'a) ->
- (Txt.command -> unit) -> status -> Txt.command -> 'a
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module U = NUri
-module C = Cps
-module H = Hierarchy
-module Y = Entity
-module A = Alpha
-module X = Library
-module D = Crg
-
-(* internal functions *******************************************************)
-
-let rec list_iter map l out tab = match l with
- | [] -> ()
- | hd :: tl -> map hd out tab; list_iter map tl out tab
-
-let list_rev_iter map e ns l out tab =
- let rec aux err f e = function
- | [], [] -> f e
- | n :: ns, hd :: tl ->
- let f e =
-(*
- pp_lenv print_string e; print_string " |- ";
- pp_term print_string hd; print_newline ();
-*)
- map e hd out tab; f (D.push2 C.err C.start e n ~t:hd ())
- in
- aux err f e (ns, tl)
- | _ -> err ()
- in
- ignore (aux C.err C.start e (ns, l))
-
-let lenv_iter map1 map2 l out tab =
- let rec aux f = function
- | D.ESort -> f ()
- | D.EBind (lenv, a, b) -> aux (fun () -> map1 a b out tab; f ()) lenv
- | D.EProj (lenv, a, e) -> aux (fun () -> map2 a e out tab; f ()) lenv
- in
- aux C.start l
-
-let rec exp_term e t out tab = match t with
- | D.TSort (a, l) ->
- let a =
- let err _ = a in
- let f s = Y.Name (s, true) :: a in
- H.string_of_sort err f l
- in
- let attrs = [X.position l; X.name a] in
- X.tag X.sort attrs out tab
- | D.TLRef (a, i, j) ->
- let a =
- let err _ = a in
- let f n r = Y.Name (n, r) :: a in
- D.get_name err f i j e
- in
- let attrs = [X.position i; X.offset j; X.name a] in
- X.tag X.lref attrs out tab
- | D.TGRef (a, n) ->
- let a = Y.Name (U.name_of_uri n, true) :: a in
- let attrs = [X.uri n; X.name a] in
- X.tag X.gref attrs out tab
- | D.TCast (a, u, t) ->
- let attrs = [] in
- X.tag X.cast attrs ~contents:(exp_term e u) out tab;
- exp_term e t out tab
- | D.TAppl (a, vs, t) ->
- let attrs = [X.arity (List.length vs)] in
- X.tag X.appl attrs ~contents:(list_iter (exp_term e) vs) out tab;
- exp_term e t out tab
- | D.TProj (a, lenv, t) ->
- let attrs = [] in
- X.tag X.proj attrs ~contents:(lenv_iter (exp_bind e) (exp_eproj e) lenv) out tab;
- exp_term (D.push_proj C.start e a lenv) t out tab
- | D.TBind (a, b, t) ->
-(* NOTE: the inner binders are alpha-converted first *)
-(* so undesirable renamings might occur *)
-(* EX: we rename [x][x]x to [x][x_]x_ *)
-(* whereas [x_][x]x would be more desirable *)
- let a = A.alpha (D.names_of_lenv [] e) a in
- exp_bind e a b out tab;
- exp_term (D.push_bind C.start e a b) t out tab
-
-and exp_bind e a b out tab =
- let f a ns = a, ns in
- let a, ns = Y.get_names f a in
- match b with
- | D.Abst ws ->
- let e = D.push_bind C.start e a (D.Abst []) in
- let attrs = [X.name ns; X.mark a; X.arity (List.length ws)] in
- X.tag X.abst attrs ~contents:(list_rev_iter exp_term e ns ws) out tab
- | D.Abbr vs ->
- let e = D.push_bind C.start e a (D.Abbr []) in
- let attrs = [X.name ns; X.mark a; X.arity (List.length vs)] in
- X.tag X.abbr attrs ~contents:(list_rev_iter exp_term e ns vs) out tab
- | D.Void n ->
- let attrs = [X.name a; X.mark a; X.arity n] in
- X.tag X.void attrs out tab
-
-and exp_eproj e a lenv out tab =
- let attrs = [] in
- X.tag X.proj attrs ~contents:(lenv_iter (exp_bind e) (exp_eproj e) lenv) out tab
-
-(* interface functions ******************************************************)
-
-let export_term = exp_term D.empty_lenv
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-val export_term: Crg.term -> Library.pp
--- /dev/null
+lib common text automath basic_ag basic_rg complete_rg toplevel
--- /dev/null
+aut autProcess autOutput autParser autLexer
--- /dev/null
+# The lambda-term \Omega
+# This book is not accepted in AUT-QE because [y:'type'] is not allowed
+# This book is accepted in lambda-delta with sort inclusion but Omega is not
+# valid if sort inclusion is allowed on the term backbone only
+# This book is valid in lambda-delta with unrestricted sort inclusion
+
++l
+@ Delta := [x:[y:'type']'type']<x>x : [x:[y:'type']'type']'type'
+ Omega := <Delta>Delta : 'type'
+-l
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type id = string (* identifier *)
+
+type qid = id * bool * id list (* qualified identifier: name, local?, path *)
+
+type term = Sort of bool (* sorts: true = TYPE, false = PROP *)
+ | GRef of qid * term list (* reference: name, arguments *)
+ | Appl of term * term (* application: argument, function *)
+ | Abst of id * term * term (* abstraction: name, domain, scope *)
+
+type command = Section of (bool * id) option (* section: Some true = open, Some false = reopen, None = close last *)
+ | Context of qid option (* context: Some = last node, None = root *)
+ | Block of id * term (* block opener: name, domain *)
+ | Decl of id * term (* declaration: name, domain *)
+ | Def of id * term * bool * term (* definition: name, domain, transparent?, body *)
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+{
+ module L = Log
+ module O = Options
+ module P = AutParser
+
+ let out s = if !O.debug_lexer then L.warn s else ()
+
+(* This turns an Automath identifier into an XML nmtoken *)
+ let quote id =
+ let l = String.length id in
+ let rec aux i =
+ if i < l then begin
+ if id.[i] = '\'' || id.[i] = '`' then id.[i] <- '_';
+ aux (succ i)
+ end else
+ id
+ in
+ aux 0
+}
+
+let LC = ['#' '%']
+let OC = "{"
+let CC = "}"
+let SPC = [' ' '\t' '\n']+
+let NL = "\n"
+let ID = ['0'-'9' 'A'-'Z' 'a'-'z' '_' '\'' '`']+
+
+rule line_comment = parse
+ | NL { () }
+ | OC { block_comment lexbuf; line_comment lexbuf }
+ | _ { line_comment lexbuf }
+ | eof { () }
+and block_comment = parse
+ | CC { () }
+ | OC { block_comment lexbuf; block_comment lexbuf }
+ | LC { line_comment lexbuf; block_comment lexbuf }
+ | _ { block_comment lexbuf }
+and token = parse
+ | SPC { token lexbuf }
+ | LC { line_comment lexbuf; token lexbuf }
+ | OC { block_comment lexbuf; token lexbuf }
+ | "_E" { out "E"; P.E }
+ | "'_E'" { out "E"; P.E }
+ | "---" { out "EB"; P.EB }
+ | "'eb'" { out "EB"; P.EB }
+ | "EB" { out "EB"; P.EB }
+ | "--" { out "EXIT"; P.EXIT }
+ | "PN" { out "PN"; P.PN }
+ | "'pn'" { out "PN"; P.PN }
+ | "PRIM" { out "PN"; P.PN }
+ | "'prim'" { out "PN"; P.PN }
+ | "???" { out "PN"; P.PN }
+ | "PROP" { out "PROP"; P.PROP }
+ | "'prop'" { out "PROP"; P.PROP }
+ | "TYPE" { out "TYPE"; P.TYPE }
+ | "'type'" { out "TYPE"; P.TYPE }
+ | ID { out "ID";
+ let s = Lexing.lexeme lexbuf in
+ if !O.unquote then P.IDENT s else P.IDENT (quote s)
+ }
+ | ":=" { out "DEF"; P.DEF }
+ | "(" { out "OP"; P.OP }
+ | ")" { out "CP"; P.CP }
+ | "[" { out "OB"; P.OB }
+ | "]" { out "CB"; P.CB }
+ | "<" { out "OA"; P.OA }
+ | ">" { out "CA"; P.CA }
+ | "@" { out "AT"; P.AT }
+ | "~" { out "TD"; P.TD }
+ | "\"" { out "QT"; P.QT }
+ | ":" { out "CN"; P.CN }
+ | "," { out "CM"; P.CM }
+ | ";" { out "SC"; P.SC }
+ | "." { out "FS"; P.FS }
+ | "+" { out "PLUS"; P.PLUS }
+ | "-" { out "MINUS"; P.MINUS }
+ | "*" { out "TIMES"; P.TIMES }
+ | "=" { out "DEF"; P.DEF }
+ | eof { out "EOF"; P.EOF }
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module P = Printf
+module C = Cps
+module L = Log
+module A = Aut
+module R = AutProcess
+
+type counters = {
+ sections: int;
+ contexts: int;
+ blocks: int;
+ decls: int;
+ defs: int;
+ sorts: int;
+ grefs: int;
+ appls: int;
+ absts: int;
+ pars: int;
+ xnodes: int
+}
+
+let initial_counters = {
+ sections = 0; contexts = 0; blocks = 0; decls = 0; defs = 0;
+ sorts = 0; grefs = 0; appls = 0; absts = 0; pars = 0; xnodes = 0
+}
+
+let rec count_term f c = function
+ | A.Sort _ ->
+ f {c with sorts = succ c.sorts; xnodes = succ c.xnodes}
+ | A.GRef (_, ts) ->
+ let c = {c with grefs = succ c.grefs} in
+ let c = {c with pars = c.pars + List.length ts} in
+ let c = {c with xnodes = succ c.xnodes + List.length ts} in
+ C.list_fold_left f count_term c ts
+ | A.Appl (v, t) ->
+ let c = {c with appls = succ c.appls; xnodes = succ c.xnodes} in
+ let f c = count_term f c t in
+ count_term f c v
+ | A.Abst (_, w, t) ->
+ let c = {c with absts = succ c.absts; xnodes = succ c.xnodes} in
+ let f c = count_term f c t in
+ count_term f c w
+
+let count_command f c = function
+ | A.Section _ ->
+ f {c with sections = succ c.sections}
+ | A.Context _ ->
+ f {c with contexts = succ c.contexts}
+ | A.Block (_, w) ->
+ let c = {c with blocks = succ c.blocks; xnodes = succ c.xnodes} in
+ count_term f c w
+ | A.Decl (_, w) ->
+ let c = {c with decls = succ c.decls; xnodes = succ c.xnodes} in
+ count_term f c w
+ | A.Def (_, w, _, t) ->
+ let c = {c with defs = succ c.defs; xnodes = succ c.xnodes} in
+ let f c = count_term f c t in
+ count_term f c w
+
+let print_counters f c =
+ let terms = c.sorts + c.grefs + c.appls + c.absts in
+ let entities = c.sections + c.contexts + c.blocks + c.decls + c.defs in
+ L.warn (P.sprintf " Automath representation summary");
+ L.warn (P.sprintf " Total book entities: %7u" entities);
+ L.warn (P.sprintf " Section entities: %7u" c.sections);
+ L.warn (P.sprintf " Context entities: %7u" c.contexts);
+ L.warn (P.sprintf " Block entities: %7u" c.blocks);
+ L.warn (P.sprintf " Declaration entities: %7u" c.decls);
+ L.warn (P.sprintf " Definition entities: %7u" c.defs);
+ L.warn (P.sprintf " Total Parameter items: %7u" c.pars);
+ L.warn (P.sprintf " Application items: %7u" c.pars);
+ L.warn (P.sprintf " Total term items: %7u" terms);
+ L.warn (P.sprintf " Sort items: %7u" c.sorts);
+ L.warn (P.sprintf " Reference items: %7u" c.grefs);
+ L.warn (P.sprintf " Application items: %7u" c.appls);
+ L.warn (P.sprintf " Abstraction items: %7u" c.absts);
+ L.warn (P.sprintf " Global Int. Complexity: unknown");
+ L.warn (P.sprintf " + Abbreviation nodes: %7u" c.xnodes);
+ f ()
+
+let print_process_counters f c =
+ let f iao iar iac iag =
+ L.warn (P.sprintf " Automath process summary");
+ L.warn (P.sprintf " Implicit after opening: %7u" iao);
+ L.warn (P.sprintf " Implicit after reopening: %7u" iar);
+ L.warn (P.sprintf " Implicit after closing: %7u" iac);
+ L.warn (P.sprintf " Implicit after global: %7u" iag);
+ f ()
+ in
+ R.get_counters f c
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type counters
+
+val initial_counters: counters
+
+val count_command: (counters -> 'a) -> counters -> Aut.command -> 'a
+
+val print_counters: (unit -> 'a) -> counters -> 'a
+
+val print_process_counters: (unit -> 'a) -> AutProcess.status -> 'a
--- /dev/null
+/* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ */
+
+%{
+ module O = Options
+ module A = Aut
+
+ let _ = Parsing.set_trace !O.debug_parser
+%}
+ %token <int> NUM
+ %token <string> IDENT
+ %token EOF MINUS PLUS TIMES AT FS CN CM SC QT TD OP CP OB CB OA CA
+ %token TYPE PROP DEF EB E PN EXIT
+
+ %start entry
+ %type <Aut.command option> entry
+%%
+ path: MINUS {} | FS {} ;
+ oftype: CN {} | CM {} ;
+ star: TIMES {} | AT {} ;
+ sc: E {} | SC {} | CN {} ;
+ eof: SC {} | EOF {} ;
+
+ expand:
+ | { true }
+ | TD { false }
+ ;
+ local:
+ | { false }
+ | path { true }
+ ;
+
+ idents:
+ | IDENT { [$1] }
+ | IDENT path idents { $1 :: $3 }
+ ;
+ qid:
+ | IDENT { ($1, true, []) }
+ | IDENT QT QT { ($1, true, []) }
+ | IDENT QT local idents QT { ($1, $3, $4) }
+ ;
+ term:
+ | TYPE { A.Sort true }
+ | PROP { A.Sort false }
+ | qid { A.GRef ($1, []) }
+ | qid OP CP { A.GRef ($1, []) }
+ | qid OP terms CP { A.GRef ($1, $3) }
+ | OA term CA term { A.Appl ($2, $4) }
+ | OB IDENT oftype term CB term { A.Abst ($2, $4, $6) }
+ ;
+ terms:
+ | term { [$1] }
+ | term CM terms { $1 :: $3 }
+ ;
+
+ start:
+ | PLUS {} | MINUS {} | EXIT {} | eof {}
+ | star {} | IDENT {} | OB {}
+ ;
+ entity:
+ | PLUS IDENT { A.Section (Some (true, $2)) }
+ | PLUS TIMES IDENT { A.Section (Some (false, $3)) }
+ | MINUS IDENT { A.Section None }
+ | EXIT { A.Section None }
+ | star { A.Context None }
+ | qid star { A.Context (Some $1) }
+ | IDENT DEF EB sc term { A.Block ($1, $5) }
+ | IDENT sc term DEF EB { A.Block ($1, $3) }
+ | OB IDENT oftype term CB { A.Block ($2, $4) }
+ | IDENT DEF PN sc term { A.Decl ($1, $5) }
+ | IDENT sc term DEF PN { A.Decl ($1, $3) }
+ | IDENT DEF expand term sc term { A.Def ($1, $6, $3, $4) }
+ | IDENT sc term DEF expand term { A.Def ($1, $3, $5, $6) }
+ ;
+ entry:
+ | entity start { Some $1 }
+ | eof { None }
+ ;
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module A = Aut
+
+type status = {
+ opening : bool; (* just opened section *)
+ reopening: bool; (* just reopened section *)
+ closing : bool; (* just closed section *)
+ explicit : bool; (* just found explicit context *)
+ block : bool; (* just found block opener *)
+ iao : int; (* implicit context after opening section *)
+ iar : int; (* implicit context after reopening section *)
+ iac : int; (* implicit context after closing section *)
+ iag : int (* implicit context after global statement *)
+}
+
+(* internal functions *******************************************************)
+
+let orc_reset f st =
+ f {st with opening = false; reopening = false; closing = false}
+
+let orc_count f st =
+ let st = if st.opening then {st with iao = succ st.iao} else st in
+ let st = if st.reopening then {st with iar = succ st.iar} else st in
+ let st = if st.closing then {st with iac = succ st.iac} else st in
+ f st
+
+let exp_count f st =
+ let st =
+ if st.explicit || st.block then st else {st with iag = succ st.iag}
+ in
+ f st
+
+let proc_section f st = function
+ | Some (true, _) -> f {st with opening = true}
+ | Some (false, _) -> f {st with reopening = true}
+ | None -> f {st with closing = true}
+
+let proc_context f st =
+ orc_reset f {st with explicit = true}
+
+let proc_block f st =
+ orc_count (orc_reset f) {st with explicit = false; block = true}
+
+let proc_global f st =
+ let f st =
+ orc_count (orc_reset f) {st with explicit = false; block = false}
+ in
+ exp_count f st
+
+let proc_command f st command = match command with
+ | A.Section section -> proc_section f st section command
+ | A.Context _ -> proc_context f st command
+ | A.Block _ -> proc_block f st command
+ | A.Decl _ -> proc_global f st command
+ | A.Def _ -> proc_global f st command
+
+(* interface functions ******************************************************)
+
+let initial_status () = {
+ opening = false; reopening = false; closing = false;
+ explicit = false; block = false;
+ iao = 0; iar = 0; iac = 0; iag = 0
+}
+
+let process_command = proc_command
+
+let get_counters f st = f st.iao st.iar st.iac st.iag
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type status
+
+val initial_status: unit -> status
+
+val process_command:
+ (status -> Aut.command -> 'a) -> status -> Aut.command -> 'a
+
+val get_counters: (int -> int -> int -> int -> 'a) -> status -> 'a
--- /dev/null
+bag bagOutput
+bagEnvironment bagSubstitution bagReduction bagType bagUntrusted
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+(* kernel version: basic, absolute, global *)
+(* note : experimental *)
+
+type uri = Entity.uri
+type id = Entity.id
+
+type bind = Void (* exclusion *)
+ | Abst of term (* abstraction *)
+ | Abbr of term (* abbreviation *)
+
+and term = Sort of int (* hierarchy index *)
+ | LRef of int (* location *)
+ | GRef of uri (* reference *)
+ | Cast of term * term (* domain, element *)
+ | Appl of term * term (* argument, function *)
+ | Bind of int * id * bind * term (* location, name, binder, scope *)
+
+type entity = term Entity.entity (* attrs, uri, binder *)
+
+type lenv = (int * id * bind) list (* location, name, binder *)
+
+type message = (lenv, term) Log.item list
+
+(* helpers ******************************************************************)
+
+let mk_uri si root s =
+ let kernel = if si then "bag-si" else "bag" in
+ String.concat "/" ["ld:"; kernel; root; s ^ ".ld"]
+
+(* Currified constructors ***************************************************)
+
+let abst w = Abst w
+
+let abbr v = Abbr v
+
+let lref i = LRef i
+
+let cast u t = Cast (u, t)
+
+let appl u t = Appl (u, t)
+
+let bind l id b t = Bind (l, id, b, t)
+
+let bind_abst l id u t = Bind (l, id, Abst u, t)
+
+let bind_abbr l id v t = Bind (l, id, Abbr v, t)
+
+(* location handling functions **********************************************)
+
+let location = ref 0
+
+let new_location () = let loc = !location in incr location; loc
+
+let locations () = !location
+
+(* local environment handling functions *************************************)
+
+let empty_lenv = []
+
+let push msg f es l id b =
+ let rec does_not_occur loc = function
+ | [] -> true
+ | (l, _, _) :: _ when l = loc -> false
+ | _ :: es -> does_not_occur l es
+ in
+ if not (does_not_occur l es) then failwith msg else
+ let c = (l, id, b) :: es in f c
+
+let append f es1 es2 =
+ f (List.append es2 es1)
+
+let map f map es =
+ Cps.list_map f map es
+
+let contents f es = f es
+
+let get f es i =
+ let rec aux = function
+ | [] -> f None
+ | (l, id, b) :: tl -> if l = i then f (Some (id, b)) else aux tl
+ in
+ aux es
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module U = NUri
+module L = Log
+module H = U.UriHash
+module Y = Entity
+module B = Bag
+
+exception ObjectNotFound of B.message
+
+let hsize = 7000
+let env = H.create hsize
+
+(* Internal functions *******************************************************)
+
+let get_age =
+ let age = ref 0 in
+ fun () -> incr age; !age
+
+let error uri = raise (ObjectNotFound (L.items1 (U.string_of_uri uri)))
+
+(* Interface functions ******************************************************)
+
+let set_entity f (a, uri, b) =
+ let age = get_age () in
+ let entry = (Y.Apix age :: a), uri, b in
+ H.add env uri entry; f entry
+
+let get_entity f uri =
+ try f (H.find env uri) with Not_found -> error uri
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+exception ObjectNotFound of Bag.message
+
+val set_entity: (Bag.entity -> 'a) -> Bag.entity -> 'a
+
+val get_entity: (Bag.entity -> 'a) -> Bag.uri -> 'a
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module P = Printf
+module F = Format
+module U = NUri
+module L = Log
+module O = Options
+module Y = Entity
+module H = Hierarchy
+module B = Bag
+
+type counters = {
+ eabsts: int;
+ eabbrs: int;
+ tsorts: int;
+ tlrefs: int;
+ tgrefs: int;
+ tcasts: int;
+ tappls: int;
+ tabsts: int;
+ tabbrs: int
+}
+
+let initial_counters = {
+ eabsts = 0; eabbrs = 0; tsorts = 0; tlrefs = 0; tgrefs = 0;
+ tcasts = 0; tappls = 0; tabsts = 0; tabbrs = 0
+}
+
+let rec count_term_binder f c = function
+ | B.Abst w ->
+ let c = {c with tabsts = succ c.tabsts} in
+ count_term f c w
+ | B.Abbr v ->
+ let c = {c with tabbrs = succ c.tabbrs} in
+ count_term f c v
+ | B.Void -> f c
+
+and count_term f c = function
+ | B.Sort _ ->
+ f {c with tsorts = succ c.tsorts}
+ | B.LRef _ ->
+ f {c with tlrefs = succ c.tlrefs}
+ | B.GRef _ ->
+ f {c with tgrefs = succ c.tgrefs}
+ | B.Cast (v, t) ->
+ let c = {c with tcasts = succ c.tcasts} in
+ let f c = count_term f c t in
+ count_term f c v
+ | B.Appl (v, t) ->
+ let c = {c with tappls = succ c.tappls} in
+ let f c = count_term f c t in
+ count_term f c v
+ | B.Bind (_, _, b, t) ->
+ let f c = count_term_binder f c b in
+ count_term f c t
+
+let count_entity f c = function
+ | _, _, Y.Abst w ->
+ let c = {c with eabsts = succ c.eabsts} in
+ count_term f c w
+ | _, _, Y.Abbr v ->
+ let c = {c with eabbrs = succ c.eabbrs} in
+ count_term f c v
+ | _, _, Y.Void -> assert false
+
+let print_counters f c =
+ let terms =
+ c.tsorts + c.tgrefs + c.tgrefs + c.tcasts + c.tappls + c.tabsts +
+ c.tabbrs
+ in
+ let items = c.eabsts + c.eabbrs in
+ let locations = B.locations () in
+ L.warn (P.sprintf " Kernel representation summary (basic_ag)");
+ L.warn (P.sprintf " Total entry items: %7u" items);
+ L.warn (P.sprintf " Declaration items: %7u" c.eabsts);
+ L.warn (P.sprintf " Definition items: %7u" c.eabbrs);
+ L.warn (P.sprintf " Total term items: %7u" terms);
+ L.warn (P.sprintf " Sort items: %7u" c.tsorts);
+ L.warn (P.sprintf " Local reference items: %7u" c.tlrefs);
+ L.warn (P.sprintf " Global reference items: %7u" c.tgrefs);
+ L.warn (P.sprintf " Explicit Cast items: %7u" c.tcasts);
+ L.warn (P.sprintf " Application items: %7u" c.tappls);
+ L.warn (P.sprintf " Abstraction items: %7u" c.tabsts);
+ L.warn (P.sprintf " Abbreviation items: %7u" c.tabbrs);
+ L.warn (P.sprintf " Total binder locations: %7u" locations);
+ f ()
+
+let res l id =
+ if !O.indexes then P.sprintf "#%u" l else id
+
+let rec pp_term c frm = function
+ | B.Sort h ->
+ let err () = F.fprintf frm "@[*%u@]" h in
+ let f s = F.fprintf frm "@[%s@]" s in
+ H.string_of_sort err f h
+ | B.LRef i ->
+ let f = function
+ | Some (id, _) -> F.fprintf frm "@[%s@]" id
+ | None -> F.fprintf frm "@[#%u@]" i
+ in
+ if !O.indexes then f None else B.get f c i
+ | B.GRef s -> F.fprintf frm "@[$%s@]" (U.string_of_uri s)
+ | B.Cast (u, t) ->
+ F.fprintf frm "@[{%a}.%a@]" (pp_term c) u (pp_term c) t
+ | B.Appl (v, t) ->
+ F.fprintf frm "@[(%a).%a@]" (pp_term c) v (pp_term c) t
+ | B.Bind (l, id, B.Abst w, t) ->
+ let f cc =
+ F.fprintf frm "@[[%s:%a].%a@]" (res l id) (pp_term c) w (pp_term cc) t
+ in
+ B.push "output abst" f c l id (B.Abst w)
+ | B.Bind (l, id, B.Abbr v, t) ->
+ let f cc =
+ F.fprintf frm "@[[%s=%a].%a@]" (res l id) (pp_term c) v (pp_term cc) t
+ in
+ B.push "output abbr" f c l id (B.Abbr v)
+ | B.Bind (l, id, B.Void, t) ->
+ let f cc = F.fprintf frm "@[[%s].%a@]" (res l id) (pp_term cc) t in
+ B.push "output void" f c l id B.Void
+
+let pp_lenv frm c =
+ let pp_entry frm = function
+ | l, id, B.Abst w ->
+ F.fprintf frm "@,@[%s : %a@]" (res l id) (pp_term c) w
+ | l, id, B.Abbr v ->
+ F.fprintf frm "@,@[%s = %a@]" (res l id) (pp_term c) v
+ | l, id, B.Void ->
+ F.fprintf frm "@,%s" (res l id)
+ in
+ let iter map frm l = List.iter (map frm) l in
+ let f es = F.fprintf frm "%a" (iter pp_entry) (List.rev es) in
+ B.contents f c
+
+let specs = {
+ L.pp_term = pp_term; L.pp_lenv = pp_lenv
+}
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type counters
+
+val initial_counters: counters
+
+val count_entity: (counters -> 'a) -> counters -> Bag.entity -> 'a
+
+val print_counters: (unit -> 'a) -> counters -> 'a
+
+val specs: (Bag.lenv, Bag.term) Log.specs
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module U = NUri
+module C = Cps
+module L = Log
+module Y = Entity
+module B = Bag
+module O = BagOutput
+module E = BagEnvironment
+module S = BagSubstitution
+
+type machine = {
+ i: int;
+ c: B.lenv;
+ s: B.term list
+}
+
+type whd_result =
+ | Sort_ of int
+ | LRef_ of int * B.term option
+ | GRef_ of B.entity
+ | Bind_ of int * B.id * B.term * B.term
+
+type ho_whd_result =
+ | Sort of int
+ | Abst of B.term
+
+(* Internal functions *******************************************************)
+
+let term_of_whdr = function
+ | Sort_ h -> B.Sort h
+ | LRef_ (i, _) -> B.LRef i
+ | GRef_ (_, uri, _) -> B.GRef uri
+ | Bind_ (l, id, w, t) -> B.bind_abst l id w t
+
+let level = 5
+
+let log1 s c t =
+ let sc, st = s ^ " in the environment", "the term" in
+ L.log O.specs level (L.et_items1 sc c st t)
+
+let log2 s cu u ct t =
+ let s1, s2, s3 = s ^ " in the environment", "the term", "and in the environment" in
+ L.log O.specs level (L.et_items2 s1 cu s2 u ~sc2:s3 ~c2:ct s2 t)
+
+let empty_machine = {i = 0; c = B.empty_lenv; s = []}
+
+let inc m = {m with i = succ m.i}
+
+let unwind_to_term f m t =
+ let map f t (l, id, b) = f (B.Bind (l, id, b, t)) in
+ let f mc = C.list_fold_left f map t mc in
+ B.contents f m.c
+
+let unwind_stack f m =
+ let map f v = unwind_to_term f m v in
+ C.list_map f map m.s
+
+let get f c m i =
+ let f = function
+ | Some (_, b) -> f b
+ | None -> assert false
+ in
+ let f c = B.get f c i in
+ B.append f c m.c
+
+let push msg f c m l id w =
+ assert (m.s = []);
+ let f w = B.push msg f c l id (B.Abst w) in
+ unwind_to_term f m w
+
+(* to share *)
+let rec whd f c m x =
+(* L.warn "entering R.whd"; *)
+ match x with
+ | B.Sort h -> f m (Sort_ h)
+ | B.GRef uri ->
+ let f entry = f m (GRef_ entry) in
+ E.get_entity f uri
+ | B.LRef i ->
+ let f = function
+ | B.Void -> f m (LRef_ (i, None))
+ | B.Abst t -> f m (LRef_ (i, Some t))
+ | B.Abbr t -> whd f c m t
+ in
+ get f c m i
+ | B.Cast (_, t) -> whd f c m t
+ | B.Appl (v, t) -> whd f c {m with s = v :: m.s} t
+ | B.Bind (l, id, B.Abst w, t) ->
+ begin match m.s with
+ | [] -> f m (Bind_ (l, id, w, t))
+ | v :: tl ->
+ let nl = B.new_location () in
+ let f mc = S.subst (whd f c {m with c = mc; s = tl}) nl l t in
+ B.push "!" f m.c nl id (B.Abbr (B.Cast (w, v)))
+ end
+ | B.Bind (l, id, b, t) ->
+ let nl = B.new_location () in
+ let f mc = S.subst (whd f c {m with c = mc}) nl l t in
+ B.push "!" f m.c nl id b
+
+(* Interface functions ******************************************************)
+
+let rec ho_whd f c m x =
+(* L.warn "entering R.ho_whd"; *)
+ let aux m = function
+ | Sort_ h -> f (Sort h)
+ | Bind_ (_, _, w, _) ->
+ let f w = f (Abst w) in unwind_to_term f m w
+ | LRef_ (_, Some w) -> ho_whd f c m w
+ | GRef_ (_, _, Y.Abst w) -> ho_whd f c m w
+ | GRef_ (_, _, Y.Abbr v) -> ho_whd f c m v
+ | LRef_ (_, None) -> assert false
+ | GRef_ (_, _, Y.Void) -> assert false
+ in
+ whd aux c m x
+
+let ho_whd f c t =
+ let f r = L.unbox level; f r in
+ L.box level; log1 "Now scanning" c t;
+ ho_whd f c empty_machine t
+
+let rec are_convertible f ~si a c m1 t1 m2 t2 =
+(* L.warn "entering R.are_convertible"; *)
+ let rec aux m1 r1 m2 r2 =
+(* L.warn "entering R.are_convertible_aux"; *)
+ let u, t = term_of_whdr r1, term_of_whdr r2 in
+ log2 "Now really converting" c u c t;
+ match r1, r2 with
+ | Sort_ h1, Sort_ h2 ->
+ if h1 = h2 then f a else f false
+ | LRef_ (i1, _), LRef_ (i2, _) ->
+ if i1 = i2 then are_convertible_stacks f ~si a c m1 m2 else f false
+ | GRef_ ((Y.Apix a1 :: _), _, Y.Abst _),
+ GRef_ ((Y.Apix a2 :: _), _, Y.Abst _) ->
+ if a1 = a2 then are_convertible_stacks f ~si a c m1 m2 else f false
+ | GRef_ ((Y.Apix a1 :: _), _, Y.Abbr v1),
+ GRef_ ((Y.Apix a2 :: _), _, Y.Abbr v2) ->
+ if a1 = a2 then
+ let f a =
+ if a then f a else are_convertible f ~si true c m1 v1 m2 v2
+ in
+ are_convertible_stacks f ~si a c m1 m2
+ else
+ if a1 < a2 then whd (aux m1 r1) c m2 v2 else
+ whd (aux_rev m2 r2) c m1 v1
+ | _, GRef_ (_, _, Y.Abbr v2) ->
+ whd (aux m1 r1) c m2 v2
+ | GRef_ (_, _, Y.Abbr v1), _ ->
+ whd (aux_rev m2 r2) c m1 v1
+ | Bind_ (l1, id1, w1, t1), Bind_ (l2, id2, w2, t2) ->
+ let l = B.new_location () in
+ let h c =
+ let m1, m2 = inc m1, inc m2 in
+ let f t1 = S.subst (are_convertible f ~si a c m1 t1 m2) l l2 t2 in
+ S.subst f l l1 t1
+ in
+ let f r = if r then push "!" h c m1 l id1 w1 else f false in
+ are_convertible f ~si a c m1 w1 m2 w2
+(* we detect the AUT-QE reduction rule for type/prop inclusion *)
+ | Sort_ _, Bind_ (l2, id2, w2, t2) when si ->
+ let m1, m2 = inc m1, inc m2 in
+ let f c = are_convertible f ~si a c m1 (term_of_whdr r1) m2 t2 in
+ push "nsi" f c m2 l2 id2 w2
+ | _ -> f false
+ and aux_rev m2 r2 m1 r1 = aux m1 r1 m2 r2 in
+ let g m1 r1 = whd (aux m1 r1) c m2 t2 in
+ if a = false then f false else whd g c m1 t1
+
+and are_convertible_stacks f ~si a c m1 m2 =
+(* L.warn "entering R.are_convertible_stacks"; *)
+ let mm1, mm2 = {m1 with s = []}, {m2 with s = []} in
+ let map f a v1 v2 = are_convertible f ~si a c mm1 v1 mm2 v2 in
+ if List.length m1.s <> List.length m2.s then
+ begin
+(* L.warn (Printf.sprintf "Different lengths: %u %u"
+ (List.length m1.s) (List.length m2.s)
+ ); *)
+ f false
+ end
+ else
+ C.list_fold_left2 f map a m1.s m2.s
+
+let are_convertible f ?(si=false) c u t =
+ let f b = L.unbox level; f b in
+ L.box level; log2 "Now converting" c u c t;
+ are_convertible f ~si true c empty_machine u empty_machine t
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type ho_whd_result =
+ | Sort of int
+ | Abst of Bag.term
+
+val ho_whd:
+ (ho_whd_result -> 'a) -> Bag.lenv -> Bag.term -> 'a
+
+val are_convertible:
+ (bool -> 'a) -> ?si:bool -> Bag.lenv -> Bag.term -> Bag.term -> 'a
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module S = Share
+module B = Bag
+
+(* Internal functions *******************************************************)
+
+let rec lref_map_bind f map b = match b with
+ | B.Abbr v ->
+ let f v' = f (S.sh1 v v' b B.abbr) in
+ lref_map f map v
+ | B.Abst w ->
+ let f w' = f (S.sh1 w w' b B.abst) in
+ lref_map f map w
+ | B.Void -> f b
+
+and lref_map f map t = match t with
+ | B.LRef i ->
+ let ii = map i in f (S.sh1 i ii t B.lref)
+ | B.GRef _ -> f t
+ | B.Sort _ -> f t
+ | B.Cast (w, u) ->
+ let f w' u' = f (S.sh2 w w' u u' t B.cast) in
+ let f w' = lref_map (f w') map u in
+ lref_map f map w
+ | B.Appl (w, u) ->
+ let f w' u' = f (S.sh2 w w' u u' t B.appl) in
+ let f w' = lref_map (f w') map u in
+ lref_map f map w
+ | B.Bind (l, id, b, u) ->
+ let f b' u' = f (S.sh2 b b' u u' t (B.bind l id)) in
+ let f b' = lref_map (f b') map u in
+ lref_map_bind f map b
+
+(* Interface functions ******************************************************)
+
+let subst f new_l old_l t =
+ let map i = if i = old_l then new_l else i in
+ if new_l = old_l then f t else lref_map f map t
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+val subst: (Bag.term -> 'a) -> int -> int -> Bag.term -> 'a
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module U = NUri
+module C = Cps
+module S = Share
+module L = Log
+module Y = Entity
+module H = Hierarchy
+module B = Bag
+module O = BagOutput
+module E = BagEnvironment
+module R = BagReduction
+
+exception TypeError of B.message
+
+(* Internal functions *******************************************************)
+
+let level = 4
+
+let log1 s c t =
+ let sc, st = s ^ " in the envireonment", "the term" in
+ L.log O.specs level (L.et_items1 sc c st t)
+
+let error1 st c t =
+ let sc = "In the envireonment" in
+ raise (TypeError (L.et_items1 sc c st t))
+
+let error3 c t1 t2 t3 =
+ let sc, st1, st2, st3 =
+ "In the envireonment", "the term", "is of type", "but must be of type"
+ in
+ raise (TypeError (L.et_items3 sc c st1 t1 st2 t2 st3 t3))
+
+let mk_gref u l =
+ let map t v = B.Appl (v, t) in
+ List.fold_left map (B.GRef u) l
+
+(* Interface functions ******************************************************)
+
+let rec b_type_of f st c x =
+(* L.warn "Entering T.b_type_of"; *)
+ log1 "Now checking" c x;
+ match x with
+ | B.Sort h ->
+ let h = H.apply h in f x (B.Sort h)
+ | B.LRef i ->
+ let f = function
+ | Some (_, B.Abst w) -> f x w
+ | Some (_, B.Abbr (B.Cast (w, v))) -> f x w
+ | Some (_, B.Abbr _) -> assert false
+ | Some (_, B.Void) ->
+ error1 "reference to excluded variable" c x
+ | None ->
+ error1 "variable not found" c x
+ in
+ B.get f c i
+ | B.GRef uri ->
+ let f = function
+ | _, _, Y.Abst w -> f x w
+ | _, _, Y.Abbr (B.Cast (w, v)) -> f x w
+ | _, _, Y.Abbr _ -> assert false
+ | _, _, Y.Void -> assert false
+ in
+ E.get_entity f uri
+ | B.Bind (l, id, B.Abbr v, t) ->
+ let f xv xt tt =
+ f (S.sh2 v xv t xt x (B.bind_abbr l id)) (B.bind_abbr l id xv tt)
+ in
+ let f xv cc = b_type_of (f xv) st cc t in
+ let f xv = B.push "type abbr" (f xv) c l id (B.Abbr xv) in
+ let f xv vv = match xv with
+ | B.Cast _ -> f xv
+ | _ -> f (B.Cast (vv, xv))
+ in
+ type_of f st c v
+ | B.Bind (l, id, B.Abst u, t) ->
+ let f xu xt tt =
+ f (S.sh2 u xu t xt x (B.bind_abst l id)) (B.bind_abst l id xu tt)
+ in
+ let f xu cc = b_type_of (f xu) st cc t in
+ let f xu _ = B.push "type abst" (f xu) c l id (B.Abst xu) in
+ type_of f st c u
+ | B.Bind (l, id, B.Void, t) ->
+ let f xt tt =
+ f (S.sh1 t xt x (B.bind l id B.Void)) (B.bind l id B.Void tt)
+ in
+ let f cc = b_type_of f st cc t in
+ B.push "type void" f c l id B.Void
+ | B.Appl (v, t) ->
+ let f xv vv xt tt = function
+ | R.Abst w ->
+ L.box (succ level);
+ L.log O.specs (succ level) (L.t_items1 "Just scanned" c w);
+ L.unbox (succ level);
+ let f a =
+(* L.warn (Printf.sprintf "Convertible: %b" a); *)
+ if a then f (S.sh2 v xv t xt x B.appl) (B.appl xv tt)
+ else error3 c xv vv w
+ in
+ R.are_convertible f ~si:st.Y.si c w vv
+ | _ ->
+ error1 "not a function" c xt
+ in
+ let f xv vv xt tt = R.ho_whd (f xv vv xt tt) c tt in
+ let f xv vv = b_type_of (f xv vv) st c t in
+ type_of f st c v
+ | B.Cast (u, t) ->
+ let f xu xt tt a =
+ (* L.warn (Printf.sprintf "Convertible: %b" a); *)
+ if a then f (S.sh2 u xu t xt x B.cast) xu else error3 c xt tt xu
+ in
+ let f xu xt tt = R.are_convertible (f xu xt tt) ~si:st.Y.si c xu tt in
+ let f xu _ = b_type_of (f xu) st c t in
+ type_of f st c u
+
+and type_of f st c x =
+ let f t u = L.unbox level; f t u in
+ L.box level; b_type_of f st c x
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+exception TypeError of Bag.message
+
+val type_of:
+ (Bag.term -> Bag.term -> 'a) ->
+ Entity.status -> Bag.lenv -> Bag.term -> 'a
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module U = NUri
+module L = Log
+module Y = Entity
+module B = Bag
+module E = BagEnvironment
+module T = BagType
+
+(* Interface functions ******************************************************)
+
+(* to share *)
+let type_check f st = function
+ | a, uri, Y.Abst t ->
+ let f xt tt = E.set_entity (f tt) (a, uri, Y.Abst xt) in
+ L.loc := U.string_of_uri uri; T.type_of f st B.empty_lenv t
+ | a, uri, Y.Abbr t ->
+ let f xt tt = E.set_entity (f tt) (a, uri, Y.Abbr xt) in
+ L.loc := U.string_of_uri uri; T.type_of f st B.empty_lenv t
+ | _, _, Y.Void -> assert false
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+val type_check:
+ (Bag.term -> Bag.entity -> 'a) -> Entity.status -> Bag.entity -> 'a
--- /dev/null
+brg brgOutput
+brgEnvironment brgSubstitution brgReduction brgType brgUntrusted
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+(* kernel version: basic, relative, global *)
+(* note : ufficial basic lambda-delta *)
+
+type uri = Entity.uri
+type id = Entity.id
+type attrs = Entity.attrs
+
+type bind = Void (* *)
+ | Abst of term (* type *)
+ | Abbr of term (* body *)
+
+and term = Sort of attrs * int (* attrs, hierarchy index *)
+ | LRef of attrs * int (* attrs, position index *)
+ | GRef of attrs * uri (* attrs, reference *)
+ | Cast of attrs * term * term (* attrs, type, term *)
+ | Appl of attrs * term * term (* attrs, argument, function *)
+ | Bind of attrs * bind * term (* attrs, binder, scope *)
+
+type entity = term Entity.entity (* attrs, uri, binder *)
+
+type lenv = Null
+(* Cons: tail, relative local environment, attrs, binder *)
+ | Cons of lenv * lenv * attrs * bind
+
+(* helpers ******************************************************************)
+
+let mk_uri si root s =
+ let kernel = if si then "brg-si" else "brg" in
+ String.concat "/" ["ld:"; kernel; root; s ^ ".ld"]
+
+(* Currified constructors ***************************************************)
+
+let abst w = Abst w
+
+let abbr v = Abbr v
+
+let lref a i = LRef (a, i)
+
+let cast a u t = Cast (a, u, t)
+
+let appl a u t = Appl (a, u, t)
+
+let bind a b t = Bind (a, b, t)
+
+let bind_abst a u t = Bind (a, Abst u, t)
+
+let bind_abbr a v t = Bind (a, Abbr v, t)
+
+let bind_void a t = Bind (a, Void, t)
+
+(* local environment handling functions *************************************)
+
+let empty = Null
+
+let push e c a b = Cons (e, c, a, b)
+
+let rec get i = function
+ | Null -> Null, Null, [], Void
+ | Cons (e, c, a, b) when i = 0 -> e, c, a, b
+ | Cons (e, _, _, _) -> get (pred i) e
+
+let get e i = get i e
+
+(* used in BrgOutput.pp_lenv *)
+let rec fold_right f map e x = match e with
+ | Null -> f x
+ | Cons (e, c, a, b) -> fold_right (map f e c a b) map e x
+
+(* used in MetaBrg.unwind_to_xlate_term *)
+let rec fold_left map x = function
+ | Null -> x
+ | Cons (e, _, a, b) -> fold_left map (map x a b) e
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module U = NUri
+module H = U.UriHash
+module Y = Entity
+module B = Brg
+
+let hsize = 7000
+let env = H.create hsize
+
+(* Internal functions *******************************************************)
+
+let get_age =
+ let age = ref 0 in
+ fun () -> incr age; !age
+
+(* Interface functions ******************************************************)
+
+(* decps *)
+let set_entity (a, uri, b) =
+ let age = get_age () in
+ let entity = (Y.Apix age :: a), uri, b in
+ H.add env uri entity; entity
+
+let get_entity uri =
+ try H.find env uri with Not_found -> [], uri, Y.Void
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+val set_entity: Brg.entity -> Brg.entity
+
+val get_entity: Brg.uri -> Brg.entity
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module P = Printf
+module F = Format
+module C = Cps
+module U = NUri
+module L = Log
+module O = Options
+module Y = Entity
+module X = Library
+module H = Hierarchy
+module B = Brg
+
+(* nodes count **************************************************************)
+
+type counters = {
+ eabsts: int;
+ eabbrs: int;
+ evoids: int;
+ tsorts: int;
+ tlrefs: int;
+ tgrefs: int;
+ tcasts: int;
+ tappls: int;
+ tabsts: int;
+ tabbrs: int;
+ tvoids: int;
+ uris : B.uri list;
+ nodes : int;
+ xnodes: int
+}
+
+let initial_counters = {
+ eabsts = 0; eabbrs = 0; evoids = 0;
+ tsorts = 0; tlrefs = 0; tgrefs = 0; tcasts = 0; tappls = 0;
+ tabsts = 0; tabbrs = 0; tvoids = 0;
+ uris = []; nodes = 0; xnodes = 0
+}
+
+let rec count_term_binder f c e = function
+ | B.Abst w ->
+ let c = {c with tabsts = succ c.tabsts; nodes = succ c.nodes} in
+ count_term f c e w
+ | B.Abbr v ->
+ let c = {c with tabbrs = succ c.tabbrs; xnodes = succ c.xnodes} in
+ count_term f c e v
+ | B.Void ->
+ let c = {c with tvoids = succ c.tvoids; xnodes = succ c.xnodes} in
+ f c
+
+and count_term f c e = function
+ | B.Sort _ ->
+ f {c with tsorts = succ c.tsorts; nodes = succ c.nodes}
+ | B.LRef (_, i) ->
+ begin match B.get e i with
+ | _, _, _, B.Abst _
+ | _, _, _, B.Void ->
+ f {c with tlrefs = succ c.tlrefs; nodes = succ c.nodes}
+ | _, _, _, B.Abbr _ ->
+ f {c with tlrefs = succ c.tlrefs; xnodes = succ c.xnodes}
+ end
+ | B.GRef (_, u) ->
+ let c =
+ if Cps.list_mem ~eq:U.eq u c.uris
+ then {c with nodes = succ c.nodes}
+ else {c with xnodes = succ c.xnodes}
+ in
+ f {c with tgrefs = succ c.tgrefs}
+ | B.Cast (_, v, t) ->
+ let c = {c with tcasts = succ c.tcasts} in
+ let f c = count_term f c e t in
+ count_term f c e v
+ | B.Appl (_, v, t) ->
+ let c = {c with tappls = succ c.tappls; nodes = succ c.nodes} in
+ let f c = count_term f c e t in
+ count_term f c e v
+ | B.Bind (a, b, t) ->
+ let f c = count_term f c (B.push e B.empty a b) t in
+ count_term_binder f c e b
+
+let count_entity f c = function
+ | _, u, Y.Abst w ->
+ let c = {c with
+ eabsts = succ c.eabsts; nodes = succ c.nodes; uris = u :: c.uris
+ } in
+ count_term f c B.empty w
+ | _, _, Y.Abbr v ->
+ let c = {c with eabbrs = succ c.eabbrs; xnodes = succ c.xnodes} in
+ count_term f c B.empty v
+ | _, _, Y.Void -> assert false
+
+let print_counters f c =
+ let terms =
+ c.tsorts + c.tgrefs + c.tgrefs + c.tcasts + c.tappls + c.tabsts +
+ c.tabbrs
+ in
+ let items = c.eabsts + c.eabbrs in
+ let nodes = c.nodes + c.xnodes in
+ L.warn (P.sprintf " Kernel representation summary (basic_rg)");
+ L.warn (P.sprintf " Total entry items: %7u" items);
+ L.warn (P.sprintf " Declaration items: %7u" c.eabsts);
+ L.warn (P.sprintf " Definition items: %7u" c.eabbrs);
+ L.warn (P.sprintf " Total term items: %7u" terms);
+ L.warn (P.sprintf " Sort items: %7u" c.tsorts);
+ L.warn (P.sprintf " Local reference items: %7u" c.tlrefs);
+ L.warn (P.sprintf " Global reference items: %7u" c.tgrefs);
+ L.warn (P.sprintf " Explicit Cast items: %7u" c.tcasts);
+ L.warn (P.sprintf " Application items: %7u" c.tappls);
+ L.warn (P.sprintf " Abstraction items: %7u" c.tabsts);
+ L.warn (P.sprintf " Abbreviation items: %7u" c.tabbrs);
+ L.warn (P.sprintf " Global Int. Complexity: %7u" c.nodes);
+ L.warn (P.sprintf " + Abbreviation nodes: %7u" nodes);
+ f ()
+
+(* supplementary annotation *************************************************)
+
+let rec does_not_occur f n r = function
+ | B.Null -> f true
+ | B.Cons (e, _, a, _) ->
+ let f n1 r1 =
+ if n1 = n && r1 = r then f false else does_not_occur f n r e
+ in
+ Y.name C.err f a
+
+let rename f e a =
+ let rec aux f e n r =
+ let f = function
+ | true -> f n r
+ | false -> aux f e (n ^ "_") r
+ in
+ does_not_occur f n r e
+ in
+ let f n0 r0 =
+ let f n r = if n = n0 && r = r0 then f a else f (Y.Name (n, r) :: a) in
+ aux f e n0 r0
+ in
+ Y.name C.err f a
+
+(* lenv/term pretty printing ************************************************)
+
+let name err frm a =
+ let f n = function
+ | true -> F.fprintf frm "%s" n
+ | false -> F.fprintf frm "^%s" n
+ in
+ Y.name err f a
+
+let rec pp_term e frm = function
+ | B.Sort (_, h) ->
+ let err _ = F.fprintf frm "@[*%u@]" h in
+ let f s = F.fprintf frm "@[%s@]" s in
+ H.string_of_sort err f h
+ | B.LRef (_, i) ->
+ let err _ = F.fprintf frm "@[#%u@]" i in
+ if !O.indexes then err () else
+ let _, _, a, b = B.get e i in
+ F.fprintf frm "@[%a@]" (name err) a
+ | B.GRef (_, s) ->
+ F.fprintf frm "@[$%s@]" (U.string_of_uri s)
+ | B.Cast (_, u, t) ->
+ F.fprintf frm "@[{%a}.%a@]" (pp_term e) u (pp_term e) t
+ | B.Appl (_, v, t) ->
+ F.fprintf frm "@[(%a).%a@]" (pp_term e) v (pp_term e) t
+ | B.Bind (a, B.Abst w, t) ->
+ let f a =
+ let ee = B.push e B.empty a (B.abst w) in
+ F.fprintf frm "@[[%a:%a].%a@]" (name C.err) a (pp_term e) w (pp_term ee) t
+ in
+ rename f e a
+ | B.Bind (a, B.Abbr v, t) ->
+ let f a =
+ let ee = B.push e B.empty a (B.abbr v) in
+ F.fprintf frm "@[[%a=%a].%a@]" (name C.err) a (pp_term e) v (pp_term ee) t
+ in
+ rename f e a
+ | B.Bind (a, B.Void, t) ->
+ let f a =
+ let ee = B.push e B.empty a B.Void in
+ F.fprintf frm "@[[%a].%a@]" (name C.err) a (pp_term ee) t
+ in
+ rename f e a
+
+let pp_lenv frm e =
+ let pp_entry f e c a b x = f x (*match b with
+ | B.Abst (a, w) ->
+ let f a = F.fprintf frm "@,@[%a : %a@]" (name C.err) a (pp_term e) w; f a in
+ rename f x a
+ | B.Abbr (a, v) ->
+ let f a = F.fprintf frm "@,@[%a = %a@]" (name C.err) a (pp_term e) v; f a in
+ rename f c a
+ | B.Void a ->
+ let f a = F.fprintf frm "@,%a" (name C.err) a; f a in
+ rename f c a
+*) in
+ B.fold_right ignore pp_entry e B.empty
+
+let specs = {
+ L.pp_term = pp_term; L.pp_lenv = pp_lenv
+}
+
+(* term xml printing ********************************************************)
+
+let rec exp_term e t out tab = match t with
+ | B.Sort (a, l) ->
+ let a =
+ let err _ = a in
+ let f s = Y.Name (s, true) :: a in
+ H.string_of_sort err f l
+ in
+ let attrs = [X.position l; X.name a] in
+ X.tag X.sort attrs out tab
+ | B.LRef (a, i) ->
+ let a =
+ let err _ = a in
+ let f n r = Y.Name (n, r) :: a in
+ let _, _, a, b = B.get e i in
+ Y.name err f a
+ in
+ let attrs = [X.position i; X.name a] in
+ X.tag X.lref attrs out tab
+ | B.GRef (a, n) ->
+ let a = Y.Name (U.name_of_uri n, true) :: a in
+ let attrs = [X.uri n; X.name a] in
+ X.tag X.gref attrs out tab
+ | B.Cast (a, u, t) ->
+ let attrs = [] in
+ X.tag X.cast attrs ~contents:(exp_term e u) out tab;
+ exp_term e t out tab
+ | B.Appl (a, v, t) ->
+ let attrs = [] in
+ X.tag X.appl attrs ~contents:(exp_term e v) out tab;
+ exp_term e t out tab
+ | B.Bind (a, b, t) ->
+ let a = rename C.start e a in
+ exp_bind e a b out tab;
+ exp_term (B.push e B.empty a b) t out tab
+
+and exp_bind e a b out tab = match b with
+ | B.Abst w ->
+ let attrs = [X.name a; X.mark a] in
+ X.tag X.abst attrs ~contents:(exp_term e w) out tab
+ | B.Abbr v ->
+ let attrs = [X.name a; X.mark a] in
+ X.tag X.abbr attrs ~contents:(exp_term e v) out tab
+ | B.Void ->
+ let attrs = [X.name a; X.mark a] in
+ X.tag X.void attrs out tab
+
+let export_term = exp_term B.empty
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type counters
+
+val initial_counters: counters
+
+val count_entity: (counters -> 'a) -> counters -> Brg.entity -> 'a
+
+val print_counters: (unit -> 'a) -> counters -> 'a
+
+val specs: (Brg.lenv, Brg.term) Log.specs
+
+val export_term: Brg.term -> Library.pp
+(*
+val export_term: Format.formatter -> Brg.term -> unit
+*)
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module U = NUri
+module C = Cps
+module S = Share
+module L = Log
+module Y = Entity
+module P = Output
+module B = Brg
+module O = BrgOutput
+module E = BrgEnvironment
+
+type kam = {
+ e: B.lenv; (* environment *)
+ s: (B.lenv * B.term) list; (* stack *)
+ d: int (* depth *)
+}
+
+(* Internal functions *******************************************************)
+
+let level = 5
+
+let log1 s c t =
+ let sc, st = s ^ " in the environment", "the term" in
+ L.log O.specs level (L.et_items1 sc c st t)
+
+let log2 s cu u ct t =
+ let s1, s2, s3 = s ^ " in the environment", "the term", "and in the environment" in
+ L.log O.specs level (L.et_items2 s1 cu s2 u ~sc2:s3 ~c2:ct s2 t)
+
+let rec list_and map = function
+ | hd1 :: tl1, hd2 :: tl2 ->
+ if map hd1 hd2 then list_and map (tl1, tl2) else false
+ | l1, l2 -> l1 = l2
+
+(* check closure *)
+let are_alpha_convertible err f t1 t2 =
+ let rec aux f = function
+ | B.Sort (_, p1), B.Sort (_, p2)
+ | B.LRef (_, p1), B.LRef (_, p2) ->
+ if p1 = p2 then f () else err ()
+ | B.GRef (_, u1), B.GRef (_, u2) ->
+ if U.eq u1 u2 then f () else err ()
+ | B.Cast (_, v1, t1), B.Cast (_, v2, t2)
+ | B.Appl (_, v1, t1), B.Appl (_, v2, t2) ->
+ let f _ = aux f (t1, t2) in
+ aux f (v1, v2)
+ | B.Bind (_, b1, t1), B.Bind (_, b2, t2) ->
+ let f _ = aux f (t1, t2) in
+ aux_bind f (b1, b2)
+ | _ -> err ()
+ and aux_bind f = function
+ | B.Abbr v1, B.Abbr v2
+ | B.Abst v1, B.Abst v2 -> aux f (v1, v2)
+ | B.Void, B.Void -> f ()
+ | _ -> err ()
+ in
+ if S.eq t1 t2 then f () else aux f (t1, t2)
+
+let get m i =
+ let _, c, a, b = B.get m.e i in c, a, b
+
+(* to share *)
+let rec step st m x =
+(* L.warn "entering R.step"; *)
+ match x with
+ | B.Sort _ -> m, None, x
+ | B.GRef (_, uri) ->
+ begin match E.get_entity uri with
+ | _, _, Y.Abbr v when st.Y.delta ->
+ P.add ~gdelta:1 (); step st m v
+ | _, _, Y.Abst w when st.Y.rt ->
+ P.add ~grt:1 (); step st m w
+ | a, _, Y.Abbr v ->
+ let e = Y.apix C.err C.start a in
+ m, Some (e, a, B.Abbr v), x
+ | a, _, Y.Abst w ->
+ let e = Y.apix C.err C.start a in
+ m, Some (e, a, B.Abst w), x
+ | _, _, Y.Void -> assert false
+ end
+ | B.LRef (_, i) ->
+ begin match get m i with
+ | c, _, B.Abbr v ->
+ P.add ~ldelta:1 ();
+ step st {m with e = c} v
+ | c, _, B.Abst w when st.Y.rt ->
+ P.add ~lrt:1 ();
+ step st {m with e = c} w
+ | c, _, B.Void ->
+ assert false
+ | c, a, (B.Abst _ as b) ->
+ let e = Y.apix C.err C.start a in
+ {m with e = c}, Some (e, a, b), x
+ end
+ | B.Cast (_, _, t) ->
+ P.add ~tau:1 ();
+ step st m t
+ | B.Appl (_, v, t) ->
+ step st {m with s = (m.e, v) :: m.s} t
+ | B.Bind (a, B.Abst w, t) ->
+ begin match m.s with
+ | [] -> m, None, x
+ | (c, v) :: s ->
+ P.add ~beta:1 ~upsilon:(List.length s) ();
+ let e = B.push m.e c a (B.abbr v) (* (B.Cast ([], w, v)) *) in
+ step st {m with e = e; s = s} t
+ end
+ | B.Bind (a, b, t) ->
+ P.add ~upsilon:(List.length m.s) ();
+ let e = B.push m.e m.e a b in
+ step st {m with e = e} t
+
+let push m a b =
+ assert (m.s = []);
+ let a, d = match b with
+ | B.Abst _ -> Y.Apix m.d :: a, succ m.d
+ | b -> a, m.d
+ in
+ let e = B.push m.e m.e a b in
+ {m with e = e; d = d}
+
+let rec ac_nfs st (m1, r1, u) (m2, r2, t) =
+ log2 "Now converting nfs" m1.e u m2.e t;
+ match r1, u, r2, t with
+ | _, B.Sort (_, h1), _, B.Sort (_, h2) ->
+ h1 = h2
+ | Some (e1, _, B.Abst _), _, Some (e2, _, B.Abst _), _ ->
+ if e1 = e2 then ac_stacks st m1 m2 else false
+ | Some (e1, _, B.Abbr v1), _, Some (e2, _, B.Abbr v2), _ ->
+ if e1 = e2 then
+ if ac_stacks st m1 m2 then true else begin
+ P.add ~gdelta:2 (); ac st m1 v1 m2 v2
+ end
+ else if e1 < e2 then begin
+ P.add ~gdelta:1 ();
+ ac_nfs st (m1, r1, u) (step st m2 v2)
+ end else begin
+ P.add ~gdelta:1 ();
+ ac_nfs st (step st m1 v1) (m2, r2, t)
+ end
+ | _, _, Some (_, _, B.Abbr v2), _ ->
+ P.add ~gdelta:1 ();
+ ac_nfs st (m1, r1, u) (step st m2 v2)
+ | Some (_, _, B.Abbr v1), _, _, _ ->
+ P.add ~gdelta:1 ();
+ ac_nfs st (step st m1 v1) (m2, r2, t)
+ | _, B.Bind (a1, (B.Abst w1 as b1), t1),
+ _, B.Bind (a2, (B.Abst w2 as b2), t2) ->
+ if ac {st with Y.si = false} m1 w1 m2 w2 then
+ ac st (push m1 a1 b1) t1 (push m2 a2 b2) t2
+ else false
+ | _, B.Sort _, _, B.Bind (a, b, t) when st.Y.si ->
+ P.add ~si:1 ();
+ ac st (push m1 a b) u (push m2 a b) t
+ | _ -> false
+
+and ac st m1 t1 m2 t2 =
+(* L.warn "entering R.are_convertible"; *)
+ ac_nfs st (step st m1 t1) (step st m2 t2)
+
+and ac_stacks st m1 m2 =
+(* L.warn "entering R.are_convertible_stacks"; *)
+ if List.length m1.s <> List.length m2.s then false else
+ let map (c1, v1) (c2, v2) =
+ let m1, m2 = {m1 with e = c1; s = []}, {m2 with e = c2; s = []} in
+ ac {st with Y.si = false} m1 v1 m2 v2
+ in
+ list_and map (m1.s, m2.s)
+
+(* Interface functions ******************************************************)
+
+let empty_kam = {
+ e = B.empty; s = []; d = 0
+}
+
+let get m i =
+ assert (m.s = []);
+ let _, _, _, b = B.get m.e i in b
+
+let xwhd st m t =
+ L.box level; log1 "Now scanning" m.e t;
+ let m, _, t = step {st with Y.delta = true; Y.rt = true} m t in
+ L.unbox level; m, t
+
+let are_convertible st mu u mw w =
+ L.box level; log2 "Now converting" mu.e u mw.e w;
+ let r = ac {st with Y.delta = st.Y.expand; Y.rt = false} mu u mw w in
+ L.unbox level; r
+(* let err _ = in
+ if S.eq mu mw then are_alpha_convertible err f u w else err () *)
+
+(* error reporting **********************************************************)
+
+let pp_term m frm t = O.specs.L.pp_term m.e frm t
+
+let pp_lenv frm m = O.specs.L.pp_lenv frm m.e
+
+let specs = {
+ L.pp_term = pp_term; L.pp_lenv = pp_lenv
+}
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type kam
+
+val empty_kam: kam
+
+val get: kam -> int -> Brg.bind
+
+val push: kam -> Entity.attrs -> Brg.bind -> kam
+
+val xwhd: Entity.status -> kam -> Brg.term -> kam * Brg.term
+
+(* arguments: expected type, inferred type *)
+val are_convertible:
+ Entity.status -> kam -> Brg.term -> kam -> Brg.term -> bool
+
+val specs: (kam, Brg.term) Log.specs
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module B = Brg
+(* module O = Output *)
+
+let rec icm a = function
+ | B.Sort _
+ | B.LRef _
+ | B.GRef _ -> succ a
+ | B.Bind (_, B.Void, t) -> icm (succ a) t
+ | B.Cast (_, u, t) -> icm (icm a u) t
+ | B.Appl (_, u, t)
+ | B.Bind (_, B.Abst u, t)
+ | B.Bind (_, B.Abbr u, t) -> icm (icm (succ a) u) t
+
+let iter map d =
+ let rec iter_bind d = function
+ | B.Void -> B.Void
+ | B.Abst w -> B.Abst (iter_term d w)
+ | B.Abbr v -> B.Abbr (iter_term d v)
+ and iter_term d = function
+ | B.Sort _ as t -> t
+ | B.GRef _ as t -> t
+ | B.LRef (a, i) as t -> if i < d then t else map d a i
+ | B.Cast (a, w, v) -> B.Cast (a, iter_term d w, iter_term d v)
+ | B.Appl (a, w, u) -> B.Appl (a, iter_term d w, iter_term d u)
+ | B.Bind (a, b, u) -> B.Bind (a, iter_bind d b, iter_term (succ d) u)
+ in
+ iter_term d
+
+let lift_map h _ a i =
+ if i + h >= 0 then B.LRef (a, i + h) else assert false
+
+let lift h d t =
+ if h = 0 then t else begin
+(* O.icm := succ (* icm *) !O.icm (*t*); *) iter (lift_map h) d t
+ end
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+val lift: int -> int -> Brg.term -> Brg.term
+(*
+val lift_bind: (Brg.bind -> 'a) -> int -> int -> Brg.bind -> 'a
+*)
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module U = NUri
+module C = Cps
+module A = Share
+module L = Log
+module H = Hierarchy
+module Y = Entity
+module B = Brg
+module O = BrgOutput
+module E = BrgEnvironment
+module S = BrgSubstitution
+module R = BrgReduction
+
+type message = (R.kam, B.term) Log.message
+
+(* Internal functions *******************************************************)
+
+let level = 4
+
+let message1 st1 m t1 =
+ L.et_items1 "In the environment" m st1 t1
+
+let log1 s m t =
+ let s = s ^ " the term" in
+ L.log R.specs level (message1 s m t)
+
+let error1 err s m t =
+ err (message1 s m t)
+
+let message3 m t1 t2 ?mu t3 =
+ let sm, st1, st2 = "In the environment", "the term", "is of type" in
+ match mu with
+ | Some mu ->
+ let smu, st3 = "but in the environment", "it must be of type" in
+ L.et_items3 sm m st1 t1 st2 t2 ~sc3:smu ~c3:mu st3 t3
+ | None ->
+ let st3 = "but it must be of type" in
+ L.et_items3 sm m st1 t1 st2 t2 st3 t3
+
+let error3 err m t1 t2 ?mu t3 =
+ err (message3 m t1 t2 ?mu t3)
+
+let assert_convertibility err f st m u w v =
+ if R.are_convertible st m u m w then f () else
+ error3 err m v w u
+
+let assert_applicability err f st m u w v =
+ match R.xwhd st m u with
+ | _, B.Sort _ -> error1 err "not a function type" m u
+ | mu, B.Bind (_, B.Abst u, _) ->
+ if R.are_convertible st mu u m w then f () else
+ error3 err m v w ~mu u
+ | _ -> assert false (**)
+
+let rec b_type_of err f st m x =
+ log1 "Now checking" m x;
+ match x with
+ | B.Sort (a, h) ->
+ let h = H.apply h in f x (B.Sort (a, h))
+ | B.LRef (_, i) ->
+ begin match R.get m i with
+ | B.Abst w ->
+ f x (S.lift (succ i) (0) w)
+ | B.Abbr (B.Cast (_, w, _)) ->
+ f x (S.lift (succ i) (0) w)
+ | B.Abbr _ -> assert false
+ | B.Void ->
+ error1 err "reference to excluded variable" m x
+ end
+ | B.GRef (_, uri) ->
+ begin match E.get_entity uri with
+ | _, _, Y.Abst w -> f x w
+ | _, _, Y.Abbr (B.Cast (_, w, _)) -> f x w
+ | _, _, Y.Abbr _ -> assert false
+ | _, _, Y.Void ->
+ error1 err "reference to unknown entry" m x
+ end
+ | B.Bind (a, B.Abbr v, t) ->
+ let f xv xt tt =
+ f (A.sh2 v xv t xt x (B.bind_abbr a)) (B.bind_abbr a xv tt)
+ in
+ let f xv m = b_type_of err (f xv) st m t in
+ let f xv = f xv (R.push m a (B.abbr xv)) in
+ let f xv vv = match xv with
+ | B.Cast _ -> f xv
+ | _ -> f (B.Cast ([], vv, xv))
+ in
+ type_of err f st m v
+ | B.Bind (a, B.Abst u, t) ->
+ let f xu xt tt =
+ f (A.sh2 u xu t xt x (B.bind_abst a)) (B.bind_abst a xu tt)
+ in
+ let f xu m = b_type_of err (f xu) st m t in
+ let f xu _ = f xu (R.push m a (B.abst xu)) in
+ type_of err f st m u
+ | B.Bind (a, B.Void, t) ->
+ let f xt tt =
+ f (A.sh1 t xt x (B.bind_void a)) (B.bind_void a tt)
+ in
+ b_type_of err f st (R.push m a B.Void) t
+
+ | B.Appl (a, v, t) ->
+ let f xv vv xt tt =
+ let f _ = f (A.sh2 v xv t xt x (B.appl a)) (B.appl a xv tt) in
+ assert_applicability err f st m tt vv xv
+ in
+ let f xv vv = b_type_of err (f xv vv) st m t in
+ type_of err f st m v
+ | B.Cast (a, u, t) ->
+ let f xu xt tt =
+ let f _ = f (A.sh2 u xu t xt x (B.cast a)) xu in
+ assert_convertibility err f st m xu tt xt
+ in
+ let f xu _ = b_type_of err (f xu) st m t in
+ type_of err f st m u
+
+(* Interface functions ******************************************************)
+
+and type_of err f st m x =
+ let f t u = L.unbox level; f t u in
+ L.box level; b_type_of err f st m x
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type message = (BrgReduction.kam, Brg.term) Log.message
+
+val type_of:
+ (message -> 'a) -> (Brg.term -> Brg.term -> 'a) ->
+ Entity.status -> BrgReduction.kam -> Brg.term -> 'a
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module U = NUri
+module L = Log
+module Y = Entity
+module B = Brg
+module E = BrgEnvironment
+module R = BrgReduction
+module T = BrgType
+
+(* Interface functions ******************************************************)
+
+(* to share *)
+let type_check err f st = function
+ | a, uri, Y.Abst t ->
+ let f xt tt =
+ let e = E.set_entity (a, uri, Y.Abst xt) in f tt e
+ in
+ L.loc := U.string_of_uri uri; T.type_of err f st R.empty_kam t
+ | a, uri, Y.Abbr t ->
+ let f xt tt =
+ let xt = match xt with
+ | B.Cast _ -> xt
+ | _ -> B.Cast ([], tt, xt)
+ in
+ let e = E.set_entity (a, uri, Y.Abbr xt) in f tt e
+ in
+ L.loc := U.string_of_uri uri; T.type_of err f st R.empty_kam t
+ | _, _, Y.Void -> assert false
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+val type_check:
+ (BrgType.message -> 'a) -> (Brg.term -> Brg.entity -> 'a) ->
+ Entity.status -> Brg.entity -> 'a
--- /dev/null
+options hierarchy output entity marks alpha library
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module Y = Entity
+
+(* internal functions *******************************************************)
+
+let rec rename ns n =
+ let token, mode = n in
+ let n = token ^ "_", mode in
+ if List.mem n ns then rename ns n else n
+
+let alpha_name acc attr =
+ let ns, a = acc in
+ match attr with
+ | Y.Name n ->
+ if List.mem n ns then
+ let n = rename ns n in
+ n :: ns, Y.Name n :: a
+ else
+ n :: ns, attr :: a
+ | _ -> assert false
+
+(* interface functions ******************************************************)
+
+let alpha ns a =
+ let f a names =
+ let _, names = List.fold_left alpha_name (ns, []) (List.rev names) in
+ List.rev_append a names
+ in
+ Y.get_names f a
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+val alpha: Entity.names -> Entity.attrs -> Entity.attrs
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module O = Options
+
+type uri = NUri.uri
+type id = Aut.id
+type name = id * bool (* token, real? *)
+
+type names = name list
+
+type attr = Name of name (* name *)
+ | Apix of int (* additional position index *)
+ | Mark of int (* node marker *)
+ | Meta of string (* metaliguistic annotation *)
+ | Priv (* private global definition *)
+
+type attrs = attr list (* attributes *)
+
+type 'term bind = Abst of 'term (* declaration: domain *)
+ | Abbr of 'term (* definition: body *)
+ | Void (* exclusion *)
+
+type 'term entity = attrs * uri * 'term bind (* attrs, name, binder *)
+
+type status = {
+ delta: bool; (* global delta-expansion *)
+ rt: bool; (* reference typing *)
+ si: bool; (* sort inclusion *)
+ expand: bool (* always expand global definitions *)
+}
+
+(* helpers ******************************************************************)
+
+let common f (a, u, _) = f a u
+
+let rec name err f = function
+ | Name (n, r) :: _ -> f n r
+ | _ :: tl -> name err f tl
+ | [] -> err ()
+
+let names f map l a =
+ let rec aux f i a = function
+ | [] -> f a
+ | Name (n, r) :: tl -> aux (map f i n r) false a tl
+ | _ :: tl -> aux f i a tl
+ in
+ aux f true a l
+
+let rec get_name err f j = function
+ | [] -> err ()
+ | Name (n, r) :: _ when j = 0 -> f n r
+ | Name _ :: tl -> get_name err f (pred j) tl
+ | _ :: tl -> get_name err f j tl
+
+let rec get_names f = function
+ | [] -> f [] []
+ | Name _ as n :: tl ->
+ let f a ns = f a (n :: ns) in get_names f tl
+ | e :: tl ->
+ let f a = f (e :: a) in get_names f tl
+
+let count_names a =
+ let rec aux k = function
+ | [] -> k
+ | Name _ :: tl -> aux (succ k) tl
+ | _ :: tl -> aux k tl
+ in
+ aux 0 a
+
+let rec apix err f = function
+ | Apix i :: _ -> f i
+ | _ :: tl -> apix err f tl
+ | [] -> err ()
+
+let rec mark err f = function
+ | Mark i :: _ -> f i
+ | _ :: tl -> mark err f tl
+ | [] -> err ()
+
+let rec priv err f = function
+ | Priv :: _ -> f ()
+ | _ :: tl -> priv err f tl
+ | [] -> err ()
+
+let rec meta err f = function
+ | Meta s :: _ -> f s
+ | _ :: tl -> meta err f tl
+ | [] -> err ()
+
+let resolve err f name a =
+ let rec aux i = function
+ | Name (n, true) :: _ when n = name -> f i
+ | _ :: tl -> aux (succ i) tl
+ | [] -> err i
+ in
+ aux 0 a
+
+let rec rev_append_names ns = function
+ | [] -> ns
+ | Name n :: tl -> rev_append_names (n :: ns) tl
+ | _ :: tl -> rev_append_names ns tl
+
+let xlate f xlate_term = function
+ | a, uri, Abst t ->
+ let f t = f (a, uri, Abst t) in xlate_term f t
+ | a, uri, Abbr t ->
+ let f t = f (a, uri, Abbr t) in xlate_term f t
+ | _, _, Void ->
+ assert false
+
+let initial_status () = {
+ delta = false; rt = false; si = !O.si; expand = !O.expand
+}
+
+let refresh_status st = {st with
+ si = !O.si; expand = !O.expand
+}
+
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module H = Hashtbl
+module S = Scanf
+module C = Cps
+
+type graph = string * (int -> int)
+
+let sorts = 3
+let sort = H.create sorts
+
+let default_graph = "Z1"
+
+(* Internal functions *******************************************************)
+
+let set_sort h s =
+ H.add sort h s; succ h
+
+let graph_of_string err f s =
+ try
+ let x = S.sscanf s "Z%u" C.start in
+ if x > 0 then f (s, fun h -> x + h) else err ()
+ with
+ S.Scan_failure _ | Failure _ | End_of_file -> err ()
+
+let graph = ref (graph_of_string C.err C.start default_graph)
+
+(* Interface functions ******************************************************)
+
+let set_sorts i ss =
+ List.fold_left set_sort i ss
+
+let string_of_sort err f h =
+ try f (H.find sort h) with Not_found -> err ()
+
+let sort_of_string err f s =
+ let map h n = function
+ | None when n = s -> Some h
+ | xh -> xh
+ in
+ match H.fold map sort None with
+ | None -> err ()
+ | Some h -> f h
+
+let string_of_graph () = fst !graph
+
+let apply h = snd !graph h
+
+let set_graph s =
+ let err () = false in
+ let f g = graph := g; true in
+ graph_of_string err f s
+
+let clear () =
+ H.clear sort; graph := graph_of_string C.err C.start default_graph
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+val set_sorts: int -> string list -> int
+
+val string_of_sort: (unit -> 'a) -> (string -> 'a) -> int -> 'a
+
+val sort_of_string: (unit -> 'a) -> (int -> 'a) -> string -> 'a
+
+val set_graph: string -> bool
+
+val string_of_graph: unit -> string
+
+val apply: int -> int
+
+val clear: unit -> unit
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module F = Filename
+module U = NUri
+module C = Cps
+module H = Hierarchy
+module Y = Entity
+
+(* internal functions *******************************************************)
+
+let base = "xml"
+
+let obj_ext = ".xml"
+
+let root = "ENTITY"
+
+let system = "http://helm.cs.unibo.it/lambda-delta/" ^ base ^ "/ld.dtd"
+
+let path_of_uri xdir uri =
+ let base = F.concat xdir base in
+ F.concat base (Str.string_after (U.string_of_uri uri) 3)
+
+(* interface functions ******************************************************)
+
+type och = string -> unit
+
+type attr = string * string
+
+type pp = och -> int -> unit
+
+let attribute out (name, contents) =
+ if contents <> "" then begin
+ out " "; out name; out "=\""; out contents; out "\""
+ end
+
+let xml out version encoding =
+ out "<?xml";
+ attribute out ("version", version);
+ attribute out ("encoding", encoding);
+ out "?>\n\n"
+
+let doctype out root system =
+ out "<!DOCTYPE "; out root; out " SYSTEM \""; out system; out "\">\n\n"
+
+let tag tag attrs ?contents out indent =
+ let spc = String.make indent ' ' in
+ out spc; out "<"; out tag; List.iter (attribute out) attrs;
+ match contents with
+ | None -> out "/>\n"
+ | Some cont ->
+ out ">\n"; cont out (indent + 3); out spc;
+ out "</"; out tag; out ">\n"
+
+let sort = "Sort"
+
+let lref = "LRef"
+
+let gref = "GRef"
+
+let cast = "Cast"
+
+let appl = "Appl"
+
+let proj = "Proj"
+
+let abst = "Abst"
+
+let abbr = "Abbr"
+
+let void = "Void"
+
+let position i =
+ "position", string_of_int i
+
+let offset j =
+ let contents = if j > 0 then string_of_int j else "" in
+ "offset", contents
+
+let uri u =
+ "uri", U.string_of_uri u
+
+let arity n =
+ let contents = if n > 1 then string_of_int n else "" in
+ "arity", contents
+
+let name a =
+ let map f i n r s =
+ let n = if r then n else "^" ^ n in
+ let spc = if i then "" else " " in
+ f (s ^ n ^ spc)
+ in
+ let f s = "name", s in
+ Y.names f map a ""
+
+let mark a =
+ let err () = "mark", "" in
+ let f i = "mark", string_of_int i in
+ Y.mark err f a
+
+(* TODO: the string s must be quoted *)
+let meta a =
+ let err () = "meta", "" in
+ let f s = "meta", s in
+ Y.meta err f a
+
+let export_entity pp_term si xdir (a, u, b) =
+ let path = path_of_uri xdir u in
+ let _ = Sys.command (Printf.sprintf "mkdir -p %s" (F.dirname path)) in
+ let och = open_out (path ^ obj_ext) in
+ let out = output_string och in
+ xml out "1.0" "UTF-8"; doctype out root system;
+ let a = Y.Name (U.name_of_uri u, true) :: a in
+ let attrs = [uri u; name a; mark a; meta a] in
+ let contents = match b with
+ | Y.Abst w -> tag "ABST" attrs ~contents:(pp_term w)
+ | Y.Abbr v -> tag "ABBR" attrs ~contents:(pp_term v)
+ | Y.Void -> assert false
+ in
+ let opts = if si then "si" else "" in
+ let shp = H.string_of_graph () in
+ let attrs = ["hierarchy", shp; "options", opts] in
+ tag root attrs ~contents out 0;
+ close_out och
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type och = string -> unit
+
+type attr = string * string
+
+type pp = och -> int -> unit
+
+val export_entity:
+ ('term -> pp) -> bool -> string -> 'term Entity.entity -> unit
+
+val tag: string -> attr list -> ?contents:pp -> pp
+
+val sort: string
+
+val lref: string
+
+val gref: string
+
+val cast: string
+
+val appl: string
+
+val proj: string
+
+val abst: string
+
+val abbr: string
+
+val void: string
+
+val position: int -> attr
+
+val offset: int -> attr
+
+val uri: Entity.uri -> attr
+
+val arity: int -> attr
+
+val name: Entity.attrs -> attr
+
+val mark: Entity.attrs -> attr
+
+val meta: Entity.attrs -> attr
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module Y = Entity
+
+(* interface functions ******************************************************)
+
+let new_location =
+ let location = ref 0 in
+ fun () -> incr location; !location
+
+let new_mark () =
+ Y.Mark (new_location ())
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module C = Cps
+
+type uri_generator = string -> string
+
+(* interface functions ******************************************************)
+
+let indexes = ref false (* show de Bruijn indexes *)
+
+let expand = ref false (* always expand global definitions *)
+
+let si = ref false (* use sort inclusion *)
+
+let unquote = ref false (* do not quote identifiers when lexing *)
+
+let icm = ref 0 (* complexity measure of relocated terms *)
+
+let cover = ref "" (* initial uri segment *)
+
+let debug_parser = ref false (* output parser debug information *)
+
+let debug_lexer = ref false (* output lexer debug information *)
+
+let mk_uri = ref (fun _ _ -> C.err : bool -> string -> uri_generator)
+
+let get_mk_uri () =
+ !mk_uri !si !cover
+
+let clear () =
+ expand := false; si := false; cover := ""; indexes := false; icm := 0;
+ debug_parser := false; debug_lexer := false;
+ mk_uri := fun _ _ -> C.err
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module P = Printf
+module L = Log
+module O = Options
+
+type reductions = {
+ beta : int;
+ zeta : int;
+ upsilon: int;
+ tau : int;
+ ldelta : int;
+ gdelta : int;
+ si : int;
+ lrt : int;
+ grt : int
+}
+
+let initial_reductions = {
+ beta = 0; upsilon = 0; tau = 0; zeta = 0; ldelta = 0; gdelta = 0;
+ si = 0; lrt = 0; grt = 0
+}
+
+let reductions = ref initial_reductions
+
+let clear_reductions () = reductions := initial_reductions
+
+let add
+ ?(beta=0) ?(upsilon=0) ?(tau=0) ?(ldelta=0) ?(gdelta=0) ?(zeta=0)
+ ?(si=0) ?(lrt=0) ?(grt=0) ()
+= reductions := {
+ beta = !reductions.beta + beta;
+ zeta = !reductions.zeta + zeta;
+ upsilon = !reductions.upsilon + upsilon;
+ tau = !reductions.tau + tau;
+ ldelta = !reductions.ldelta + ldelta;
+ gdelta = !reductions.gdelta + gdelta;
+ si = !reductions.si + si;
+ lrt = !reductions.lrt + lrt;
+ grt = !reductions.grt + grt
+}
+
+let print_reductions () =
+ let r = !reductions in
+ let rs = r.beta + r.ldelta + r.zeta + r.upsilon + r.tau + r.gdelta in
+ let prs = r.si + r.lrt + r.grt in
+ let delta = r.ldelta + r.gdelta in
+ let rt = r.lrt + r.grt in
+ L.warn (P.sprintf " Reductions summary");
+ L.warn (P.sprintf " Proper reductions: %7u" rs);
+ L.warn (P.sprintf " Beta: %7u" r.beta);
+ L.warn (P.sprintf " Delta: %7u" delta);
+ L.warn (P.sprintf " Local: %7u" r.ldelta);
+ L.warn (P.sprintf " Global: %7u" r.gdelta);
+ L.warn (P.sprintf " Zeta: %7u" r.zeta);
+ L.warn (P.sprintf " Upsilon: %7u" r.upsilon);
+ L.warn (P.sprintf " Tau: %7u" r.tau);
+ L.warn (P.sprintf " Pseudo reductions: %7u" prs);
+ L.warn (P.sprintf " Reference typing: %7u" rt);
+ L.warn (P.sprintf " Local: %7u" r.lrt);
+ L.warn (P.sprintf " Global: %7u" r.grt);
+ L.warn (P.sprintf " Sort inclusion: %7u" r.si);
+ L.warn (P.sprintf " Relocated nodes (icm): %7u" !O.icm)
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+val clear_reductions: unit -> unit
+
+val add:
+ ?beta:int -> ?upsilon:int -> ?tau:int -> ?ldelta:int -> ?gdelta:int ->
+ ?zeta:int -> ?si:int -> ?lrt:int -> ?grt:int ->
+ unit -> unit
+
+val print_reductions: unit -> unit
--- /dev/null
+crg crgOutput crgXml crgTxt crgAut crgBrg
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+(* kernel version: complete, relative, global *)
+(* note : fragment of complete lambda-delta serving as abstract layer *)
+
+module Y = Entity
+
+type uri = Y.uri
+type id = Y.id
+type attrs = Y.attrs
+
+type bind = Abst of term list (* domains *)
+ | Abbr of term list (* bodies *)
+ | Void of int (* number of exclusions *)
+
+and term = TSort of attrs * int (* attrs, hierarchy index *)
+ | TLRef of attrs * int * int (* attrs, position indexes *)
+ | TGRef of attrs * uri (* attrs, reference *)
+ | TCast of attrs * term * term (* attrs, domain, element *)
+ | TAppl of attrs * term list * term (* attrs, arguments, function *)
+ | TProj of attrs * lenv * term (* attrs, closure, member *)
+ | TBind of attrs * bind * term (* attrs, binder, scope *)
+
+and lenv = ESort (* top *)
+ | EProj of lenv * attrs * lenv (* environment, attrs, closure *)
+ | EBind of lenv * attrs * bind (* environment, attrs, binder *)
+
+type entity = term Y.entity
+
+(* helpers ******************************************************************)
+
+let mk_uri si root s =
+ let kernel = if si then "crg-si" else "crg" in
+ String.concat "/" ["ld:"; kernel; root; s ^ ".ld"]
+
+let empty_lenv = ESort
+
+let push_bind f lenv a b = f (EBind (lenv, a, b))
+
+let push_proj f lenv a e = f (EProj (lenv, a, e))
+
+let push2 err f lenv attr ?t () = match lenv, t with
+ | EBind (e, a, Abst ws), Some t -> f (EBind (e, (attr :: a), Abst (t :: ws)))
+ | EBind (e, a, Abbr vs), Some t -> f (EBind (e, (attr :: a), Abbr (t :: vs)))
+ | EBind (e, a, Void n), None -> f (EBind (e, (attr :: a), Void (succ n)))
+ | _ -> err ()
+
+(* this id not tail recursive *)
+let resolve_lref err f id lenv =
+ let rec aux f i k = function
+ | ESort -> err ()
+ | EBind (tl, a, _) ->
+ let err kk = aux f (succ i) (k + kk) tl in
+ let f j = f i j (k + j) in
+ Y.resolve err f id a
+ | EProj _ -> assert false (* TODO *)
+ in
+ aux f 0 0 lenv
+
+let rec get_name err f i j = function
+ | ESort -> err i
+ | EBind (_, a, _) when i = 0 ->
+ let err () = err i in
+ Y.get_name err f j a
+ | EBind (tl, _, _) ->
+ get_name err f (pred i) j tl
+ | EProj (tl, _, e) ->
+ let err i = get_name err f i j tl in
+ get_name err f i j e
+
+let get_index err f i j lenv =
+ let rec aux f i k = function
+ | ESort -> err i
+ | EBind (_, a, _) when i = 0 ->
+ if Y.count_names a > j then f (k + j) else err i
+ | EBind (tl, a, _) ->
+ aux f (pred i) (k + Y.count_names a) tl
+ | EProj _ -> assert false (* TODO *)
+ in
+ aux f i 0 lenv
+
+let rec names_of_lenv ns = function
+ | ESort -> ns
+ | EBind (tl, a, _) -> names_of_lenv (Y.rev_append_names ns a) tl
+ | EProj (tl, _, e) -> names_of_lenv (names_of_lenv ns e) tl
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module U = NUri
+module H = U.UriHash
+module C = Cps
+module O = Options
+module Y = Entity
+module A = Aut
+module D = Crg
+
+(* qualified identifier: uri, name, qualifiers *)
+type qid = D.uri * D.id * D.id list
+
+type context = Y.attrs * D.term list
+
+type context_node = qid option (* context node: None = root *)
+
+type status = {
+ path: D.id list; (* current section path *)
+ node: context_node; (* current context node *)
+ nodes: context_node list; (* context node list *)
+ line: int; (* line number *)
+ mk_uri:O.uri_generator (* uri generator *)
+}
+
+type resolver = Local of int
+ | Global of context
+
+let henv_size, hcnt_size = 7000, 4300 (* hash tables initial sizes *)
+
+let henv = H.create henv_size (* optimized global environment *)
+
+let hcnt = H.create hcnt_size (* optimized context *)
+
+(* Internal functions *******************************************************)
+
+let empty_cnt = [], []
+
+let add_abst (a, ws) id w =
+ Y.Name (id, true) :: a, w :: ws
+
+let lenv_of_cnt (a, ws) =
+ D.push_bind C.start D.empty_lenv a (D.Abst ws)
+
+let mk_lref f i j k = f (D.TLRef ([Y.Apix k], i, j))
+
+let id_of_name (id, _, _) = id
+
+let mk_qid f st id path =
+ let str = String.concat "/" path in
+ let str = Filename.concat str id in
+ let str = st.mk_uri str in
+ f (U.uri_of_string str, id, path)
+
+let uri_of_qid (uri, _, _) = uri
+
+let complete_qid f st (id, is_local, qs) =
+ let f path = C.list_rev_append (mk_qid f st id) path ~tail:qs in
+ let rec skip f = function
+ | phd :: ptl, qshd :: _ when phd = qshd -> f ptl
+ | _ :: ptl, _ :: _ -> skip f (ptl, qs)
+ | _ -> f []
+ in
+ if is_local then f st.path else skip f (st.path, qs)
+
+let relax_qid f st (_, id, path) =
+ let f = function
+ | _ :: tl -> C.list_rev (mk_qid f st id) tl
+ | [] -> assert false
+ in
+ C.list_rev f path
+
+let relax_opt_qid f st = function
+ | None -> f None
+ | Some qid -> let f qid = f (Some qid) in relax_qid f st qid
+
+let resolve_gref err f st qid =
+ try let cnt = H.find henv (uri_of_qid qid) in f qid cnt
+ with Not_found -> err qid
+
+let resolve_gref_relaxed f st qid =
+(* this is not tail recursive *)
+ let rec err qid = relax_qid (resolve_gref err f st) st qid in
+ resolve_gref err f st qid
+
+let get_cnt err f st = function
+ | None -> f empty_cnt
+ | Some qid as node ->
+ try let cnt = H.find hcnt (uri_of_qid qid) in f cnt
+ with Not_found -> err node
+
+let get_cnt_relaxed f st =
+(* this is not tail recursive *)
+ let rec err node = relax_opt_qid (get_cnt err f st) st node in
+ get_cnt err f st st.node
+
+(* this is not tail recursive in the GRef branch *)
+let rec xlate_term f st lenv = function
+ | A.Sort s ->
+ let f h = f (D.TSort ([], h)) in
+ if s then f 0 else f 1
+ | A.Appl (v, t) ->
+ let f vv tt = f (D.TAppl ([], [vv], tt)) in
+ let f vv = xlate_term (f vv) st lenv t in
+ xlate_term f st lenv v
+ | A.Abst (name, w, t) ->
+ let f ww =
+ let a, b = [Y.Name (name, true)], (D.Abst [ww]) in
+ let f tt = f (D.TBind (a, b, tt)) in
+ let f lenv = xlate_term f st lenv t in
+ D.push_bind f lenv a b
+ in
+ xlate_term f st lenv w
+ | A.GRef (name, args) ->
+ let map1 f = function
+ | Y.Name (id, _) -> f (A.GRef ((id, true, []), []))
+ | _ -> C.err ()
+ in
+ let map2 f = xlate_term f st lenv in
+ let g qid (a, _) =
+ let gref = D.TGRef ([], uri_of_qid qid) in
+ match args, a with
+ | [], [] -> f gref
+ | _ ->
+ let f args = f (D.TAppl ([], args, gref)) in
+ let f args = f (List.rev_map (map2 C.start) args) in
+ let f a = C.list_rev_map_append f map1 a ~tail:args in
+ C.list_sub_strict f a args
+ in
+ let g qid = resolve_gref_relaxed g st qid in
+ let err () = complete_qid g st name in
+ D.resolve_lref err (mk_lref f) (id_of_name name) lenv
+
+let xlate_entity err f st = function
+ | A.Section (Some (_, name)) ->
+ err {st with path = name :: st.path; nodes = st.node :: st.nodes}
+ | A.Section None ->
+ begin match st.path, st.nodes with
+ | _ :: ptl, nhd :: ntl ->
+ err {st with path = ptl; node = nhd; nodes = ntl}
+ | _ -> assert false
+ end
+ | A.Context None ->
+ err {st with node = None}
+ | A.Context (Some name) ->
+ let f name = err {st with node = Some name} in
+ complete_qid f st name
+ | A.Block (name, w) ->
+ let f qid =
+ let f cnt =
+ let lenv = lenv_of_cnt cnt in
+ let ww = xlate_term C.start st lenv w in
+ H.add hcnt (uri_of_qid qid) (add_abst cnt name ww);
+ err {st with node = Some qid}
+ in
+ get_cnt_relaxed f st
+ in
+ complete_qid f st (name, true, [])
+ | A.Decl (name, w) ->
+ let f cnt =
+ let a, ws = cnt in
+ let lenv = lenv_of_cnt cnt in
+ let f qid =
+ let ww = xlate_term C.start st lenv w in
+ H.add henv (uri_of_qid qid) cnt;
+ let t = match ws with
+ | [] -> ww
+ | _ -> D.TBind (a, D.Abst ws, ww)
+ in
+(*
+ print_newline (); CrgOutput.pp_term print_string t;
+*)
+ let b = Y.Abst t in
+ let entity = [Y.Mark st.line], uri_of_qid qid, b in
+ f {st with line = succ st.line} entity
+ in
+ complete_qid f st (name, true, [])
+ in
+ get_cnt_relaxed f st
+ | A.Def (name, w, trans, v) ->
+ let f cnt =
+ let a, ws = cnt in
+ let lenv = lenv_of_cnt cnt in
+ let f qid =
+ let ww = xlate_term C.start st lenv w in
+ let vv = xlate_term C.start st lenv v in
+ H.add henv (uri_of_qid qid) cnt;
+ let t = match ws with
+ | [] -> D.TCast ([], ww, vv)
+ | _ -> D.TBind (a, D.Abst ws, D.TCast ([], ww, vv))
+ in
+(*
+ print_newline (); CrgOutput.pp_term print_string t;
+*)
+ let b = Y.Abbr t in
+ let a = Y.Mark st.line :: if trans then [] else [Y.Priv] in
+ let entity = a, uri_of_qid qid, b in
+ f {st with line = succ st.line} entity
+ in
+ complete_qid f st (name, true, [])
+ in
+ get_cnt_relaxed f st
+
+(* Interface functions ******************************************************)
+
+let initial_status () =
+ H.clear henv; H.clear hcnt; {
+ path = []; node = None; nodes = []; line = 1; mk_uri = O.get_mk_uri ()
+}
+
+let refresh_status st = {st with
+ mk_uri = O.get_mk_uri ()
+}
+
+let crg_of_aut = xlate_entity
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type status
+
+val initial_status: unit -> status
+
+val refresh_status: status -> status
+
+val crg_of_aut: (status -> 'a) -> (status -> Crg.entity -> 'a) ->
+ status -> Aut.command -> 'a
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module C = Cps
+module Y = Entity
+module M = Marks
+module D = Crg
+module B = Brg
+
+(* internal functions: crg to brg term **************************************)
+
+let rec lenv_fold_left map1 map2 x = function
+ | D.ESort -> x
+ | D.EBind (tl, a, b) -> lenv_fold_left map1 map2 (map1 x a b) tl
+ | D.EProj (tl, a, e) -> lenv_fold_left map1 map2 (map2 x a e) tl
+
+let rec xlate_term f = function
+ | D.TSort (a, l) -> f (B.Sort (a, l))
+ | D.TGRef (a, n) -> f (B.GRef (a, n))
+ | D.TLRef (a, _, _) -> let f i = f (B.LRef (a, i)) in Y.apix C.err f a
+ | D.TCast (a, u, t) ->
+ let f uu tt = f (B.Cast (a, uu, tt)) in
+ let f uu = xlate_term (f uu) t in
+ xlate_term f u
+ | D.TAppl (a, vs, t) ->
+ let map f v tt = let f vv = f (B.Appl (a, vv, tt)) in xlate_term f v in
+ let f tt = C.list_fold_right f map vs tt in
+ xlate_term f t
+ | D.TProj (a, e, t) ->
+ let f tt = f (lenv_fold_left xlate_bind xlate_proj tt e) in
+ xlate_term f t
+ | D.TBind (ab, D.Abst ws, D.TCast (ac, u, t)) ->
+ xlate_term f (D.TCast (ac, D.TBind (ab, D.Abst ws, u), D.TBind (ab, D.Abst ws, t)))
+ | D.TBind (a, b, t) ->
+ let f tt = f (xlate_bind tt a b) in xlate_term f t
+
+and xlate_bind x a b =
+ let f a ns = a, ns in
+ let a, ns = Y.get_names f a in
+ match b with
+ | D.Abst ws ->
+ let map x n w =
+ let f ww = B.Bind (n :: M.new_mark () :: a, B.Abst ww, x) in
+ xlate_term f w
+ in
+ List.fold_left2 map x ns ws
+ | D.Abbr vs ->
+ let map x n v =
+ let f vv = B.Bind (n :: a, B.Abbr vv, x) in
+ xlate_term f v
+ in
+ List.fold_left2 map x ns vs
+ | D.Void _ ->
+ let map x n = B.Bind (n :: a, B.Void, x) in
+ List.fold_left map x ns
+
+and xlate_proj x _ e =
+ lenv_fold_left xlate_bind xlate_proj x e
+
+(* internal functions: brg to crg term **************************************)
+
+let rec xlate_bk_term f = function
+ | B.Sort (a, l) -> f (D.TSort (a, l))
+ | B.GRef (a, n) -> f (D.TGRef (a, n))
+ | B.LRef (a, i) -> f (D.TLRef (a, i, 0))
+ | B.Cast (a, u, t) ->
+ let f uu tt = f (D.TCast (a, uu, tt)) in
+ let f uu = xlate_bk_term (f uu) t in
+ xlate_bk_term f u
+ | B.Appl (a, u, t) ->
+ let f uu tt = f (D.TAppl (a, [uu], tt)) in
+ let f uu = xlate_bk_term (f uu) t in
+ xlate_bk_term f u
+ | B.Bind (a, b, t) ->
+ let f bb tt = f (D.TBind (a, bb, tt)) in
+ let f bb = xlate_bk_term (f bb) t in
+ xlate_bk_bind f b
+
+and xlate_bk_bind f = function
+ | B.Abst t ->
+ let f tt = f (D.Abst [tt]) in
+ xlate_bk_term f t
+ | B.Abbr t ->
+ let f tt = f (D.Abbr [tt]) in
+ xlate_bk_term f t
+ | B.Void -> f (D.Void 1)
+
+(* interface functions ******************************************************)
+
+let brg_of_crg f t =
+ f (xlate_term C.start t)
+
+let crg_of_brg = xlate_bk_term
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+val brg_of_crg: (Brg.term -> 'a) -> Crg.term -> 'a
+
+val crg_of_brg: (Crg.term -> 'a) -> Brg.term -> 'a
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module P = Printf
+module U = NUri
+module C = Cps
+module H = Hierarchy
+module Y = Entity
+module D = Crg
+
+(****************************************************************************)
+
+let pp_attrs out a =
+ let map = function
+ | Y.Name (s, true) -> out (P.sprintf "%s;" s)
+ | Y.Name (s, false) -> out (P.sprintf "~%s;" s)
+ | Y.Apix i -> out (P.sprintf "+%i;" i)
+ | Y.Mark i -> out (P.sprintf "@%i;" i)
+ | Y.Meta s -> out (P.sprintf "\"%s\";" s)
+ | Y.Priv -> out (P.sprintf "%s;" "~")
+ in
+ List.iter map a
+
+let rec pp_term out = function
+ | D.TSort (a, l) -> pp_attrs out a; out (P.sprintf "*%u" l)
+ | D.TLRef (a, i, j) -> pp_attrs out a; out (P.sprintf "#(%u,%u)" i j)
+ | D.TGRef (a, u) -> pp_attrs out a; out (P.sprintf "$")
+ | D.TCast (a, x, y) -> pp_attrs out a; out "<"; pp_term out x; out ">."; pp_term out y
+ | D.TProj (a, x, y) -> assert false
+ | D.TAppl (a, x, y) -> pp_attrs out a; pp_terms "(" ")" out x; pp_term out y
+ | D.TBind (a, x, y) -> pp_attrs out a; pp_bind out x; pp_term out y
+
+and pp_terms bg eg out vs =
+ let rec aux = function
+ | [] -> ()
+ | [v] -> pp_term out v
+ | v :: vs -> pp_term out v; out ", "; aux vs
+ in
+ out bg; aux vs; out (eg ^ ".")
+
+and pp_bind out = function
+ | D.Abst x -> pp_terms "[:" "]" out x
+ | D.Abbr x -> pp_terms "[=" "]" out x
+ | D.Void x -> out (P.sprintf "[%u]" x)
+
+let rec pp_lenv out = function
+ | D.ESort -> ()
+ | D.EProj (x, a, y) -> assert false
+ | D.EBind (x, a, y) -> pp_lenv out x; pp_attrs out a; pp_bind out y
+
+(****************************************************************************)
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+val pp_term: (string -> unit) -> Crg.term -> unit
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module U = NUri
+module H = Hierarchy
+module C = Cps
+module O = Options
+module Y = Entity
+module T = Txt
+module TT = TxtTxt
+module D = Crg
+
+type status = {
+ path : T.id list; (* current section path *)
+ line : int; (* line number *)
+ sort : int; (* first default sort index *)
+ mk_uri: O.uri_generator (* uri generator *)
+}
+
+let henv_size = 7000 (* hash tables initial size *)
+
+let henv = Hashtbl.create henv_size (* optimized global environment *)
+
+(* Internal functions *******************************************************)
+
+let name_of_id ?(r=true) id = Y.Name (id, r)
+
+let mk_lref f i j k = f (D.TLRef ([Y.Apix k], i, j))
+
+let mk_gref f uri = f (D.TGRef ([], uri))
+
+let uri_of_id st id path =
+ let str = String.concat "/" path in
+ let str = Filename.concat str id in
+ let str = st.mk_uri str in
+ U.uri_of_string str
+
+let resolve_gref err f st id =
+ try f (Hashtbl.find henv id)
+ with Not_found -> err ()
+
+let rec xlate_term f st lenv = function
+ | T.Inst _
+ | T.Impl _ -> assert false
+ | T.Sort h ->
+ f (D.TSort ([], h))
+ | T.NSrt id ->
+ let f h = f (D.TSort ([], h)) in
+ H.sort_of_string C.err f id
+ | T.LRef (i, j) ->
+ D.get_index C.err (mk_lref f i j) i j lenv
+ | T.NRef id ->
+ let err () = resolve_gref C.err (mk_gref f) st id in
+ D.resolve_lref err (mk_lref f) id lenv
+ | T.Cast (u, t) ->
+ let f uu tt = f (D.TCast ([], uu, tt)) in
+ let f uu = xlate_term (f uu) st lenv t in
+ xlate_term f st lenv u
+ | T.Appl (vs, t) ->
+ let map f = xlate_term f st lenv in
+ let f vvs tt = f (D.TAppl ([], vvs, tt)) in
+ let f vvs = xlate_term (f vvs) st lenv t in
+ C.list_map f map vs
+ | T.Bind (b, t) ->
+ let abst_map (lenv, a, wws) (id, r, w) =
+ let attr = name_of_id ~r id in
+ let ww = xlate_term C.start st lenv w in
+ D.push2 C.err C.start lenv attr ~t:ww (), attr :: a, ww :: wws
+ in
+ let abbr_map (lenv, a, wws) (id, w) =
+ let attr = name_of_id id in
+ let ww = xlate_term C.start st lenv w in
+ D.push2 C.err C.start lenv attr ~t:ww (), attr :: a, ww :: wws
+ in
+ let void_map (lenv, a, n) id =
+ let attr = name_of_id id in
+ D.push2 C.err C.start lenv attr (), attr :: a, succ n
+ in
+ let lenv, aa, bb = match b with
+ | T.Abst xws ->
+ let lenv = D.push_bind C.start lenv [] (D.Abst []) in
+ let lenv, aa, wws = List.fold_left abst_map (lenv, [], []) xws in
+ lenv, aa, D.Abst wws
+ | T.Abbr xvs ->
+ let lenv = D.push_bind C.start lenv [] (D.Abbr []) in
+ let lenv, aa, vvs = List.fold_left abbr_map (lenv, [], []) xvs in
+ lenv, aa, D.Abbr vvs
+ | T.Void ids ->
+ let lenv = D.push_bind C.start lenv [] (D.Void 0) in
+ let lenv, aa, n = List.fold_left void_map (lenv, [], 0) ids in
+ lenv, aa, D.Void n
+ in
+ let f tt = f (D.TBind (aa, bb, tt)) in
+ xlate_term f st lenv t
+
+let xlate_term f st lenv t =
+ TT.contract (xlate_term f st lenv) t
+
+let mk_contents tt = function
+ | T.Decl -> [], Y.Abst tt
+ | T.Ax -> [], Y.Abst tt
+ | T.Def -> [], Y.Abbr tt
+ | T.Th -> [], Y.Abbr tt
+
+let xlate_entity err f gen st = function
+ | T.Require _ ->
+ err st
+ | T.Section (Some name) ->
+ err {st with path = name :: st.path}
+ | T.Section None ->
+ begin match st.path with
+ | _ :: ptl ->
+ err {st with path = ptl}
+ | _ -> assert false
+ end
+ | T.Sorts sorts ->
+ let map st (xix, s) =
+ let ix = match xix with
+ | None -> st.sort
+ | Some ix -> ix
+ in
+ {st with sort = H.set_sorts ix [s]}
+ in
+ err (List.fold_left map st sorts)
+ | T.Graph id ->
+ assert (H.set_graph id); err st
+ | T.Entity (kind, id, meta, t) ->
+ let uri = uri_of_id st id st.path in
+ Hashtbl.add henv id uri;
+ let tt = xlate_term C.start st D.empty_lenv t in
+(*
+ print_newline (); CrgOutput.pp_term print_string tt;
+*)
+ let a, b = mk_contents tt kind in
+ let a = if meta <> "" then Y.Meta meta :: a else a in
+ let entity = Y.Mark st.line :: a, uri, b in
+ f {st with line = succ st.line} entity
+ | T.Generate _ ->
+ err st
+
+(* Interface functions ******************************************************)
+
+let initial_status () =
+ Hashtbl.clear henv; {
+ path = []; line = 1; sort = 0; mk_uri = O.get_mk_uri ()
+}
+
+let refresh_status st = {st with
+ mk_uri = O.get_mk_uri ()
+}
+
+let crg_of_txt = xlate_entity
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type status
+
+val initial_status: unit -> status
+
+val refresh_status: status -> status
+
+val crg_of_txt: (status -> 'a) -> (status -> Crg.entity -> 'a) ->
+ (Txt.command -> unit) -> status -> Txt.command -> 'a
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module U = NUri
+module C = Cps
+module H = Hierarchy
+module Y = Entity
+module A = Alpha
+module X = Library
+module D = Crg
+
+(* internal functions *******************************************************)
+
+let rec list_iter map l out tab = match l with
+ | [] -> ()
+ | hd :: tl -> map hd out tab; list_iter map tl out tab
+
+let list_rev_iter map e ns l out tab =
+ let rec aux err f e = function
+ | [], [] -> f e
+ | n :: ns, hd :: tl ->
+ let f e =
+(*
+ pp_lenv print_string e; print_string " |- ";
+ pp_term print_string hd; print_newline ();
+*)
+ map e hd out tab; f (D.push2 C.err C.start e n ~t:hd ())
+ in
+ aux err f e (ns, tl)
+ | _ -> err ()
+ in
+ ignore (aux C.err C.start e (ns, l))
+
+let lenv_iter map1 map2 l out tab =
+ let rec aux f = function
+ | D.ESort -> f ()
+ | D.EBind (lenv, a, b) -> aux (fun () -> map1 a b out tab; f ()) lenv
+ | D.EProj (lenv, a, e) -> aux (fun () -> map2 a e out tab; f ()) lenv
+ in
+ aux C.start l
+
+let rec exp_term e t out tab = match t with
+ | D.TSort (a, l) ->
+ let a =
+ let err _ = a in
+ let f s = Y.Name (s, true) :: a in
+ H.string_of_sort err f l
+ in
+ let attrs = [X.position l; X.name a] in
+ X.tag X.sort attrs out tab
+ | D.TLRef (a, i, j) ->
+ let a =
+ let err _ = a in
+ let f n r = Y.Name (n, r) :: a in
+ D.get_name err f i j e
+ in
+ let attrs = [X.position i; X.offset j; X.name a] in
+ X.tag X.lref attrs out tab
+ | D.TGRef (a, n) ->
+ let a = Y.Name (U.name_of_uri n, true) :: a in
+ let attrs = [X.uri n; X.name a] in
+ X.tag X.gref attrs out tab
+ | D.TCast (a, u, t) ->
+ let attrs = [] in
+ X.tag X.cast attrs ~contents:(exp_term e u) out tab;
+ exp_term e t out tab
+ | D.TAppl (a, vs, t) ->
+ let attrs = [X.arity (List.length vs)] in
+ X.tag X.appl attrs ~contents:(list_iter (exp_term e) vs) out tab;
+ exp_term e t out tab
+ | D.TProj (a, lenv, t) ->
+ let attrs = [] in
+ X.tag X.proj attrs ~contents:(lenv_iter (exp_bind e) (exp_eproj e) lenv) out tab;
+ exp_term (D.push_proj C.start e a lenv) t out tab
+ | D.TBind (a, b, t) ->
+(* NOTE: the inner binders are alpha-converted first *)
+(* so undesirable renamings might occur *)
+(* EX: we rename [x][x]x to [x][x_]x_ *)
+(* whereas [x_][x]x would be more desirable *)
+ let a = A.alpha (D.names_of_lenv [] e) a in
+ exp_bind e a b out tab;
+ exp_term (D.push_bind C.start e a b) t out tab
+
+and exp_bind e a b out tab =
+ let f a ns = a, ns in
+ let a, ns = Y.get_names f a in
+ match b with
+ | D.Abst ws ->
+ let e = D.push_bind C.start e a (D.Abst []) in
+ let attrs = [X.name ns; X.mark a; X.arity (List.length ws)] in
+ X.tag X.abst attrs ~contents:(list_rev_iter exp_term e ns ws) out tab
+ | D.Abbr vs ->
+ let e = D.push_bind C.start e a (D.Abbr []) in
+ let attrs = [X.name ns; X.mark a; X.arity (List.length vs)] in
+ X.tag X.abbr attrs ~contents:(list_rev_iter exp_term e ns vs) out tab
+ | D.Void n ->
+ let attrs = [X.name a; X.mark a; X.arity n] in
+ X.tag X.void attrs out tab
+
+and exp_eproj e a lenv out tab =
+ let attrs = [] in
+ X.tag X.proj attrs ~contents:(lenv_iter (exp_bind e) (exp_eproj e) lenv) out tab
+
+(* interface functions ******************************************************)
+
+let export_term = exp_term D.empty_lenv
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+val export_term: Crg.term -> Library.pp
--- /dev/null
+nUri cps share log time
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+let err _ = assert false
+
+let start x = x
+
+let id f x = f x
+
+let rec list_sub_strict f l1 l2 = match l1, l2 with
+ | _, [] -> f l1
+ | _ :: tl1, _ :: tl2 -> list_sub_strict f tl1 tl2
+ | _ -> assert false
+
+(* this is not tail recursive *)
+let rec list_fold_left f map a = function
+ | [] -> f a
+ | hd :: tl ->
+ let f a = list_fold_left f map a tl in
+ map f a hd
+
+(* this is not tail recursive *)
+let rec list_rev_map_append f map ~tail = function
+ | [] -> f tail
+ | hd :: tl ->
+ let f hd = list_rev_map_append f map ~tail:(hd :: tail) tl in
+ map f hd
+
+(* this is not tail recursive *)
+let rec list_forall2 f map l1 l2 = match l1, l2 with
+ | [], [] -> f true
+ | hd1 :: tl1, hd2 :: tl2 ->
+ let f b = if b then list_forall2 f map tl1 tl2 else f false in
+ map f hd1 hd2
+ | _ -> f false
+
+let list_rev_append f =
+ list_rev_map_append f (fun f t -> f t)
+
+let list_rev_map =
+ list_rev_map_append ~tail:[]
+
+let list_rev =
+ list_rev_append ~tail:[]
+
+let list_iter f map l =
+ let map f () x = map f x in
+ list_fold_left f map () l
+
+(* this is not tail recursive *)
+let rec list_fold_left2 f map a l1 l2 = match l1, l2 with
+ | [], [] -> f a
+ | hd1 :: tl1, hd2 :: tl2 ->
+ let f a = list_fold_left2 f map a tl1 tl2 in
+ map f a hd1 hd2
+ | _ -> assert false
+
+let list_iter2 f map l1 l2 =
+ let map f () x1 x2 = map f x1 x2 in
+ list_fold_left2 f map () l1 l2
+
+let rec list_fold_right f map l a = match l with
+ | [] -> f a
+ | hd :: tl -> list_fold_right (map f hd) map tl a
+
+let list_map f map l =
+ let map f hd a =
+ let f hd = f (hd :: a) in map f hd
+ in
+ list_fold_right f map l []
+
+let rec list_mem ?(eq=(=)) a = function
+ | [] -> false
+ | hd :: _ when eq a hd -> true
+ | _ :: tl -> list_mem ~eq a tl
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module P = Printf
+module F = Format
+module C = Cps
+
+type ('a, 'b) item = Term of 'a * 'b
+ | LEnv of 'a
+ | Warn of string
+ | String of string
+ | Loc
+
+type ('a, 'b) message = ('a, 'b) item list
+
+type ('a, 'b) specs = {
+ pp_term: 'a -> F.formatter -> 'b -> unit;
+ pp_lenv: F.formatter -> 'a -> unit
+}
+
+let level = ref 0
+
+let loc = ref "unknown location"
+
+(* Internal functions *******************************************************)
+
+let clear () =
+ level := 0; loc := "unknown location"
+
+let std = F.std_formatter
+
+let err = F.err_formatter
+
+let pp_items frm st l items =
+ let pp_item frm = function
+ | Term (c, t) -> F.fprintf frm "@,%a" (st.pp_term c) t
+ | LEnv c -> F.fprintf frm "%a" st.pp_lenv c
+ | Warn s -> F.fprintf frm "@,%s" s
+ | String s -> F.fprintf frm "%s " s
+ | Loc -> F.fprintf frm " <%s>" !loc
+ in
+ let iter map frm l = List.iter (map frm) l in
+ if !level >= l then F.fprintf frm "%a" (iter pp_item) items
+
+(* Interface functions ******************************************************)
+
+let box l =
+ if !level >= l then
+ begin F.fprintf std "@,@[<v 2>%s" " "; F.pp_print_if_newline std () end
+
+let unbox l = if !level >= l then F.fprintf std "@]"
+
+let flush l = if !level >= l then F.fprintf std "@]@."
+
+let box_err () = F.fprintf err "@[<v>"
+
+let flush_err () = F.fprintf err "@]@."
+
+let log st l items = pp_items std st l items
+
+let error st items = pp_items err st 0 items
+
+let items1 s = [Warn s]
+
+let t_items1 st c t =
+ [Warn st; Term (c, t)]
+
+let et_items1 sc c st t =
+ [Warn sc; LEnv c; Warn st; Term (c, t)]
+
+let et_items2 sc1 c1 st1 t1 ?sc2 ?c2 st2 t2 =
+ let tl = match sc2, c2 with
+ | Some sc2, Some c2 -> et_items1 sc2 c2 st2 t2
+ | None, None -> t_items1 st2 c1 t2
+ | _ -> assert false
+ in
+ et_items1 sc1 c1 st1 t1 @ tl
+
+let et_items3 sc1 c1 st1 t1 ?sc2 ?c2 st2 t2 ?sc3 ?c3 st3 t3 =
+ let tl = match sc3, c3 with
+ | Some sc3, Some c3 -> et_items1 sc3 c3 st3 t3
+ | None, None -> t_items1 st3 c1 t3
+ | _ -> assert false
+ in
+ et_items2 sc1 c1 st1 t1 ?sc2 ?c2 st2 t2 @ tl
+
+let warn msg = F.fprintf std "@,%s" msg
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type ('a, 'b) item = Term of 'a * 'b
+ | LEnv of 'a
+ | Warn of string
+ | String of string
+ | Loc
+
+type ('a, 'b) message = ('a, 'b) item list
+
+type ('a, 'b) specs = {
+ pp_term: 'a -> Format.formatter -> 'b -> unit;
+ pp_lenv: Format.formatter -> 'a -> unit
+}
+
+val loc: string ref
+
+val level: int ref
+
+val clear: unit -> unit
+
+val warn: string -> unit
+
+val box: int -> unit
+
+val unbox: int -> unit
+
+val flush: int -> unit
+
+val box_err: unit -> unit
+
+val flush_err: unit -> unit
+
+val log: ('a, 'b) specs -> int -> ('a, 'b) message -> unit
+
+val error: ('a, 'b) specs -> ('a, 'b) message -> unit
+
+val items1: string -> ('a, 'b) message
+
+val t_items1: string -> 'a -> 'b -> ('a, 'b) message
+
+val et_items1:
+ string -> 'a -> string -> 'b -> ('a, 'b) message
+
+val et_items2:
+ string -> 'a -> string -> 'b ->
+ ?sc2:string -> ?c2:'a -> string -> 'b ->
+ ('a, 'b) message
+
+val et_items3:
+ string -> 'a -> string -> 'b ->
+ ?sc2:string -> ?c2:'a -> string -> 'b ->
+ ?sc3:string -> ?c3:'a -> string -> 'b ->
+ ('a, 'b) message
--- /dev/null
+../../components/ng_kernel/nUri.ml
\ No newline at end of file
--- /dev/null
+../../components/ng_kernel/nUri.mli
\ No newline at end of file
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+let sh a b =
+ if a == b then a else b
+
+let sh1 a1 a2 b1 b2 =
+ if a1 == a2 then b1 else b2 (sh a1 a2)
+
+let sh2 a1 a2 b1 b2 c1 c2 =
+ if a1 == a2 && b1 == b2 then c1 else c2 (sh a1 a2) (sh b1 b2)
+
+let eq a b = (a == b) || (a = b)
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module P = Printf
+module L = Log
+
+let utime_stamp =
+ let old = ref 0.0 in
+ fun msg ->
+ let times = Unix.times () in
+ let stamp = times.Unix.tms_utime in
+ let lap = stamp -. !old in
+ L.warn (P.sprintf "USR TIME STAMP (%s): %f (%f)" msg stamp lap);
+ old := stamp
+
+let gmtime msg =
+ let gmt = Unix.gmtime (Unix.time ()) in
+ let yy = gmt.Unix.tm_year + 1900 in
+ let mm = gmt.Unix.tm_mon + 1 in
+ let dd = gmt.Unix.tm_mday in
+ let h = gmt.Unix.tm_hour in
+ let m = gmt.Unix.tm_min in
+ let s = gmt.Unix.tm_sec in
+ L.warn (
+ P.sprintf "UTC TIME STAMP (%s): %u/%u/%u %u:%u:%u" msg yy mm dd h m s
+ )
--- /dev/null
+txt txtParser txtLexer txtTxt
--- /dev/null
+\open pippo
+
+\global a : *Set
+
+\global b : *Prop
+
+\global f = [x:*Set].[y:*Prop].x
+
+\global "commento\"" c = f(a,b) : *Set
+
+\close
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type ix = int (* index *)
+
+type id = string (* identifier *)
+
+type desc = string (* description *)
+
+type kind = Decl (* generic declaration *)
+ | Ax (* axiom *)
+ | Def (* generic definition *)
+ | Th (* theorem *)
+
+type bind = Abst of (id * bool * term) list (* name, real?, domain *)
+ | Abbr of (id * term) list (* name, bodies *)
+ | Void of id list (* names *)
+
+and term = Sort of ix (* level *)
+ | NSrt of id (* named level *)
+ | LRef of ix * ix (* index, offset *)
+ | NRef of id (* name *)
+ | Cast of term * term (* domain, element *)
+ | Appl of term list * term (* arguments, function *)
+ | Bind of bind * term (* binder, scope *)
+ | Inst of term * term list (* function, arguments *)
+ | Impl of bool * id * term * term (* strong?, label, source, target *)
+
+type command = Require of id list (* required files: names *)
+ | Graph of id (* hierarchy graph: name *)
+ | Sorts of (int option * id) list (* sorts: index, name *)
+ | Section of id option (* section: Some id = open, None = close last *)
+ | Entity of kind * id * desc * term (* entity: class, name, description, contents *)
+ | Generate of term list (* predefined generated entity: arguments *)
+
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+{
+ module L = Log
+ module O = Options
+ module P = TxtParser
+
+ let out s = if !O.debug_lexer then L.warn s else ()
+}
+
+let BS = "\\"
+let SPC = [' ' '\t' '\n']+
+let OC = "\\*"
+let CC = "*\\"
+let FIG = ['0'-'9']
+let ALPHA = ['A'-'Z' 'a'-'z' '_']
+let QT = '"'
+let ID = ALPHA+ (ALPHA | FIG)*
+let IX = FIG+
+
+rule block_comment = parse
+ | CC { () }
+ | OC { block_comment lexbuf; block_comment lexbuf }
+ | _ { block_comment lexbuf }
+and qstring = parse
+ | QT { "" }
+ | SPC { " " ^ qstring lexbuf }
+ | BS BS { "\\" ^ qstring lexbuf }
+ | BS QT { "\"" ^ qstring lexbuf }
+ | _ as c { String.make 1 c ^ qstring lexbuf }
+and token = parse
+ | SPC { token lexbuf }
+ | OC { block_comment lexbuf; token lexbuf }
+ | ID as id { out ("ID " ^ id); P.ID id }
+ | IX as ix { out ("IX " ^ ix); P.IX (int_of_string ix) }
+ | QT { let s = qstring lexbuf in out ("STR " ^ s); P.STR s }
+ | "\\graph" { out "GRAPH"; P.GRAPH }
+ | "\\decl" { out "DECL"; P.DECL }
+ | "\\ax" { out "AX"; P.AX }
+ | "\\def" { out "DEF"; P.DEF }
+ | "\\th" { out "TH"; P.TH }
+ | "\\generate" { out "GEN"; P.GEN }
+ | "\\require" { out "REQ"; P.REQ }
+ | "\\open" { out "OPEN"; P.OPEN }
+ | "\\close" { out "CLOSE"; P.CLOSE }
+ | "\\sorts" { out "SORTS"; P.SORTS }
+ | "(" { out "OP"; P.OP }
+ | ")" { out "CP"; P.CP }
+ | "[" { out "OB"; P.OB }
+ | "]" { out "CB"; P.CB }
+ | "<" { out "OA"; P.OA }
+ | ">" { out "CA"; P.CA }
+ | "." { out "FS"; P.FS }
+ | ":" { out "CN"; P.CN }
+ | "," { out "CM"; P.CM }
+ | "=" { out "EQ"; P.EQ }
+ | "*" { out "STAR"; P.STAR }
+ | "#" { out "HASH"; P.HASH }
+ | "+" { out "PLUS"; P.PLUS }
+ | "~" { out "TE"; P.TE }
+ | "->" { out "WTO"; P.WTO }
+ | "=>" { out "STO"; P.STO }
+ | eof { out "EOF"; P.EOF }
--- /dev/null
+/* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ */
+
+%{
+ module O = Options
+ module T = Txt
+
+ let _ = Parsing.set_trace !O.debug_parser
+%}
+ %token <int> IX
+ %token <string> ID STR
+ %token OP CP OB CB OA CA FS CN CM EQ STAR HASH PLUS TE WTO STO
+ %token GRAPH DECL AX DEF TH GEN REQ OPEN CLOSE SORTS EOF
+
+ %start entry
+ %type <Txt.command option> entry
+
+ %nonassoc CP CB CA
+ %right WTO STO
+%%
+ hash:
+ | {}
+ | HASH {}
+ ;
+ fs:
+ | {}
+ | FS {}
+ ;
+ comment:
+ | { "" }
+ | STR { $1 }
+ ;
+ ids:
+ | ID { [$1] }
+ | ID CM ids { $1 :: $3 }
+ ;
+ sort:
+ | ID { None, $1 }
+ | IX ID { Some $1, $2 }
+ ;
+ sorts:
+ | sort { [$1] }
+ | sort CM sorts { $1 :: $3 }
+ ;
+
+ abst:
+ | ID CN term { $1, true, $3 }
+ | TE term { "", false, $2 }
+ | ID TE term { $1, false, $3 }
+ ;
+ abbr:
+ | ID EQ term { $1, $3 }
+ ;
+ absts:
+ | abst { [$1] }
+ | abst CM absts { $1 :: $3 }
+ ;
+ abbrs:
+ | abbr { [$1] }
+ | abbr CM abbrs { $1 :: $3 }
+ ;
+ binder:
+ | absts { T.Abst $1 }
+ | abbrs { T.Abbr $1 }
+ | ids { T.Void $1 }
+ ;
+ atom:
+ | STAR IX { T.Sort $2 }
+ | STAR ID { T.NSrt $2 }
+ | hash IX { T.LRef ($2, 0) }
+ | hash IX PLUS IX { T.LRef ($2, $4) }
+ | ID { T.NRef $1 }
+ | HASH ID { T.NRef $2 }
+ | atom OP term CP { T.Inst ($1, [$3]) }
+ | atom OP terms CP { T.Inst ($1, $3) }
+ ;
+ term:
+ | atom { $1 }
+ | OA term CA fs term { T.Cast ($2, $5) }
+ | OP term CP fs term { T.Appl ([$2], $5) }
+ | OP terms CP fs term { T.Appl ($2, $5) }
+ | OB binder CB fs term { T.Bind ($2, $5) }
+ | term WTO term { T.Impl (false, "", $1, $3) }
+ | ID TE term WTO term { T.Impl (false, $1, $3, $5) }
+ | term STO term { T.Impl (true, "", $1, $3) }
+ | ID TE term STO term { T.Impl (true, $1, $3, $5) }
+ | OP term CP { $2 }
+ ;
+ terms:
+ | term CM term { [$1; $3] }
+ | term CM terms { $1 :: $3 }
+ ;
+
+ decl:
+ | DECL { T.Decl }
+ | AX { T.Ax }
+ ;
+ def:
+ | DEF { T.Def }
+ | TH { T.Th }
+ ;
+ xentity:
+ | GRAPH ID
+ { T.Graph $2 }
+ | decl comment ID CN term
+ { T.Entity ($1, $3, $2, $5) }
+ | def comment ID EQ term
+ { T.Entity ($1, $3, $2, $5) }
+ | def comment ID EQ term CN term
+ { T.Entity ($1, $3, $2, T.Cast ($7, $5)) }
+ | GEN term
+ { T.Generate [$2] }
+ | GEN terms
+ { T.Generate $2 }
+ | REQ ids
+ { T.Require $2 }
+ | OPEN ID
+ { T.Section (Some $2) }
+ | CLOSE
+ { T.Section None }
+ | SORTS sorts
+ { T.Sorts $2 }
+ ;
+ start:
+ | GRAPH {} | decl {} | def {} | GEN {} |
+ | REQ {} | OPEN {} | CLOSE {} | SORTS {} | EOF {}
+ ;
+ entry:
+ | xentity start { Some $1 }
+ | EOF { None }
+ ;
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module C = Cps
+module T = Txt
+
+(* Interface functions ******************************************************)
+
+let rec contract f = function
+ | T.Inst (t, vs) ->
+ let tt = T.Appl (List.rev vs, t) in
+ contract f tt
+ | T.Impl (false, id, w, t) ->
+ let tt = T.Bind (T.Abst [id, false, w], t) in
+ contract f tt
+ | T.Impl (true, id, w, t) ->
+ let f = function
+ | T.Bind (T.Abst [xw], T.Bind (T.Abst xws, tt)) ->
+ f (T.Bind (T.Abst (xw :: xws), tt))
+ | tt -> f tt
+ in
+ let tt = T.Impl (false, id, w, t) in
+ contract f tt
+ | T.Sort _
+ | T.NSrt _
+ | T.LRef _
+ | T.NRef _ as t -> f t
+ | T.Cast (u, t) ->
+ let f tt uu = f (T.Cast (uu, tt)) in
+ let f tt = contract (f tt) u in
+ contract f t
+ | T.Appl (vs, t) ->
+ let f tt vvs = f (T.Appl (vvs, tt)) in
+ let f tt = C.list_map (f tt) contract vs in
+ contract f t
+ | T.Bind (b, t) ->
+ let f tt bb = f (T.Bind (bb, tt)) in
+ let f tt = contract_binder (f tt) b in
+ contract f t
+
+and contract_binder f = function
+ | T.Void n as b -> f b
+ | T.Abbr xvs ->
+ let map f (id, v) =
+ let f vv = f (id, vv) in contract f v
+ in
+ let f xvvs = f (T.Abbr xvvs) in
+ C.list_map f map xvs
+ | T.Abst xws ->
+ let map f (id, real, w) =
+ let f ww = f (id, real, ww) in contract f w
+ in
+ let f xwws = f (T.Abst xwws) in
+ C.list_map f map xws
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+val contract: (Txt.term -> 'a) -> Txt.term -> 'a
--- /dev/null
+meta metaOutput metaLibrary metaAut metaBag metaBrg top
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type uri = Entity.uri
+type id = Entity.id
+
+type term = Sort of bool (* sorts: true = TYPE, false = PROP *)
+ | LRef of int * int (* local reference: local environment length, de bruijn index *)
+ | GRef of int * uri * term list (* global reference: local environment length, name, arguments *)
+ | Appl of term * term (* application: argument, function *)
+ | Abst of id * term * term (* abstraction: name, domain, scope *)
+
+type pars = (id * term) list (* parameter declarations: name, type *)
+
+type entry = pars * term * term option (* parameters, domain, body *)
+
+type entity = entry Entity.entity
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module U = NUri
+module H = U.UriHash
+module C = Cps
+module O = Options
+module Y = Entity
+module M = Meta
+module A = Aut
+
+(* qualified identifier: uri, name, qualifiers *)
+type qid = M.uri * M.id * M.id list
+
+type context_node = qid option (* context node: None = root *)
+
+type status = {
+ path: M.id list; (* current section path *)
+ node: context_node; (* current context node *)
+ nodes: context_node list; (* context node list *)
+ line: int; (* line number *)
+ cover: string (* initial segment of URI hierarchy *)
+}
+
+type resolver = Local of int
+ | Global of M.pars
+
+let henv_size, hcnt_size = 7000, 4300 (* hash tables initial sizes *)
+
+let henv = H.create henv_size (* optimized global environment *)
+
+let hcnt = H.create hcnt_size (* optimized context *)
+
+(* Internal functions *******************************************************)
+
+let id_of_name (id, _, _) = id
+
+let mk_qid st id path =
+ let uripath = if st.cover = "" then path else st.cover :: path in
+ let str = String.concat "/" uripath in
+ let str = Filename.concat str id in
+ U.uri_of_string ("ld:/" ^ str ^ ".ld"), id, path
+
+let uri_of_qid (uri, _, _) = uri
+
+let complete_qid f st (id, is_local, qs) =
+ let f qs = f (mk_qid st id qs) in
+ let f path = C.list_rev_append f path ~tail:qs in
+ let rec skip f = function
+ | phd :: ptl, qshd :: _ when phd = qshd -> f ptl
+ | _ :: ptl, _ :: _ -> skip f (ptl, qs)
+ | _ -> f []
+ in
+ if is_local then f st.path else skip f (st.path, qs)
+
+let relax_qid f st (_, id, path) =
+ let f path = f (mk_qid st id path) in
+ let f = function
+ | _ :: tl -> C.list_rev f tl
+ | [] -> assert false
+ in
+ C.list_rev f path
+
+let relax_opt_qid f st = function
+ | None -> f None
+ | Some qid -> let f qid = f (Some qid) in relax_qid f st qid
+
+let resolve_lref f st l lenv id =
+ let rec aux f i = function
+ | [] -> f None
+ | (name, _) :: _ when name = id -> f (Some (M.LRef (l, i)))
+ | _ :: tl -> aux f (succ i) tl
+ in
+ aux f 0 lenv
+
+let resolve_lref_strict f st l lenv id =
+ let f = function
+ | Some t -> f t
+ | None -> assert false
+ in
+ resolve_lref f st l lenv id
+
+let resolve_gref f st qid =
+ try let args = H.find henv (uri_of_qid qid) in f qid (Some args)
+ with Not_found -> f qid None
+
+let resolve_gref_relaxed f st qid =
+(* this is not tail recursive *)
+ let rec g qid = function
+ | None -> relax_qid (resolve_gref g st) st qid
+ | Some args -> f qid args
+ in
+ resolve_gref g st qid
+
+let get_pars f st = function
+ | None -> f [] None
+ | Some qid as node ->
+ try let pars = H.find hcnt (uri_of_qid qid) in f pars None
+ with Not_found -> f [] (Some node)
+
+let get_pars_relaxed f st =
+(* this is not tail recursive *)
+ let rec g pars = function
+ | None -> f pars
+ | Some node -> relax_opt_qid (get_pars g st) st node
+ in
+ get_pars g st st.node
+
+(* this is not tail recursive on the GRef branch *)
+let rec xlate_term f st lenv = function
+ | A.Sort sort ->
+ f (M.Sort sort)
+ | A.Appl (v, t) ->
+ let f vv tt = f (M.Appl (vv, tt)) in
+ let f vv = xlate_term (f vv) st lenv t in
+ xlate_term f st lenv v
+ | A.Abst (name, w, t) ->
+ let add name w lenv = (name, w) :: lenv in
+ let f ww tt = f (M.Abst (name, ww, tt)) in
+ let f ww = xlate_term (f ww) st (add name ww lenv) t in
+ xlate_term f st lenv w
+ | A.GRef (name, args) ->
+ let l = List.length lenv in
+ let g qid defs =
+ let map1 f = xlate_term f st lenv in
+ let map2 f (id, _) = resolve_lref_strict f st l lenv id in
+ let f tail =
+ let f args = f (M.GRef (l, uri_of_qid qid, args)) in
+ let f defs = C.list_rev_map_append f map2 defs ~tail in
+ C.list_sub_strict f defs args
+ in
+ C.list_map f map1 args
+ in
+ let g qid = resolve_gref_relaxed g st qid in
+ let f = function
+ | Some t -> f t
+ | None -> complete_qid g st name
+ in
+ resolve_lref f st l lenv (id_of_name name)
+
+let xlate_entity err f st = function
+ | A.Section (Some (_, name)) ->
+ err {st with path = name :: st.path; nodes = st.node :: st.nodes}
+ | A.Section None ->
+ begin match st.path, st.nodes with
+ | _ :: ptl, nhd :: ntl ->
+ err {st with path = ptl; node = nhd; nodes = ntl}
+ | _ -> assert false
+ end
+ | A.Context None ->
+ err {st with node = None}
+ | A.Context (Some name) ->
+ let f name = err {st with node = Some name} in
+ complete_qid f st name
+ | A.Block (name, w) ->
+ let f qid =
+ let f pars =
+ let f ww =
+ H.add hcnt (uri_of_qid qid) ((name, ww) :: pars);
+ err {st with node = Some qid}
+ in
+ xlate_term f st pars w
+ in
+ get_pars_relaxed f st
+ in
+ complete_qid f st (name, true, [])
+ | A.Decl (name, w) ->
+ let f pars =
+ let f qid =
+ let f ww =
+ H.add henv (uri_of_qid qid) pars;
+ let a = [Y.Mark st.line] in
+ let entry = pars, ww, None in
+ let entity = a, uri_of_qid qid, Y.Abst entry in
+ f {st with line = succ st.line} entity
+ in
+ xlate_term f st pars w
+ in
+ complete_qid f st (name, true, [])
+ in
+ get_pars_relaxed f st
+ | A.Def (name, w, trans, v) ->
+ let f pars =
+ let f qid =
+ let f ww vv =
+ H.add henv (uri_of_qid qid) pars;
+ let a = Y.Mark st.line :: if trans then [] else [Y.Priv] in
+ let entry = pars, ww, Some vv in
+ let entity = a, uri_of_qid qid, Y.Abbr entry in
+ f {st with line = succ st.line} entity
+ in
+ let f ww = xlate_term (f ww) st pars v in
+ xlate_term f st pars w
+ in
+ complete_qid f st (name, true, [])
+ in
+ get_pars_relaxed f st
+
+(* Interface functions ******************************************************)
+
+let initial_status () =
+ H.clear henv; H.clear hcnt; {
+ path = []; node = None; nodes = []; line = 1; cover = !O.cover
+}
+
+let refresh_status st = {st with
+ cover = !O.cover
+}
+
+let meta_of_aut = xlate_entity
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type status
+
+val initial_status: unit -> status
+
+val refresh_status: status -> status
+
+val meta_of_aut:
+ (status -> 'a) -> (status -> Meta.entity -> 'a) ->
+ status -> Aut.command -> 'a
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module C = Cps
+module B = Bag
+module M = Meta
+
+(* Internal functions *******************************************************)
+
+let rec xlate_term c f = function
+ | M.Sort s ->
+ let f h = f (B.Sort h) in
+ if s then f 0 else f 1
+ | M.LRef (_, i) ->
+ let l, _, _ = List.nth c i in
+ f (B.LRef l)
+ | M.GRef (_, uri, vs) ->
+ let map f t v = f (B.appl v t) in
+ let f vs = C.list_fold_left f map (B.GRef uri) vs in
+ C.list_map f (xlate_term c) vs
+ | M.Appl (v, t) ->
+ let f v t = f (B.Appl (v, t)) in
+ let f v = xlate_term c (f v) t in
+ xlate_term c f v
+ | M.Abst (id, w, t) ->
+ let f w =
+ let l = B.new_location () in
+ let f t = f (B.Bind (l, id, B.Abst w, t)) in
+ let f c = xlate_term c f t in
+ B.push "meta" f c l id (B.Abst w)
+ in
+ xlate_term c f w
+
+let xlate_pars f pars =
+ let map f (id, w) c =
+ let l = B.new_location () in
+ let f w = B.push "meta" f c l id (B.Abst w) in
+ xlate_term c f w
+ in
+ C.list_fold_right f map pars B.empty_lenv
+
+let unwind_to_xlate_term f c t =
+ let map f t (l, id, b) = f (B.bind l id b t) in
+ let f t = C.list_fold_left f map t c in
+ xlate_term c f t
+
+let xlate_entry f = function
+ | pars, u, None ->
+ let f c = unwind_to_xlate_term f c u in
+ xlate_pars f pars
+ | pars, u, Some t ->
+ let f u t = f (B.Cast (u, t)) in
+ let f c u = unwind_to_xlate_term (f u) c t in
+ let f c = unwind_to_xlate_term (f c) c u in
+ xlate_pars f pars
+
+(* Interface functions ******************************************************)
+
+let bag_of_meta = xlate_entry
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+val bag_of_meta: (Bag.term -> 'a) -> Meta.entry -> 'a
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module C = Cps
+module Y = Entity
+module B = Brg
+module M = Meta
+
+(* Internal functions *******************************************************)
+
+let rec xlate_term c f = function
+ | M.Sort s ->
+ let f h = f (B.Sort ([], h)) in
+ if s then f 0 else f 1
+ | M.LRef (_, i) ->
+ f (B.LRef ([], i))
+ | M.GRef (_, uri, vs) ->
+ let map f t v = f (B.appl [] v t) in
+ let f vs = C.list_fold_left f map (B.GRef ([], uri)) vs in
+ C.list_map f (xlate_term c) vs
+ | M.Appl (v, t) ->
+ let f v t = f (B.Appl ([], v, t)) in
+ let f v = xlate_term c (f v) t in
+ xlate_term c f v
+ | M.Abst (id, w, t) ->
+ let f w =
+ let a = [Y.Name (id, true)] in
+ let f t = f (B.Bind (a, B.Abst w, t)) in
+ xlate_term (B.push c B.empty a (B.Abst w)) f t
+ in
+ xlate_term c f w
+
+let xlate_pars f pars =
+ let map f (id, w) c =
+ let a = [Y.Name (id, true)] in
+ let f w = f (B.push c B.empty a (B.Abst w)) in
+ xlate_term c f w
+ in
+ C.list_fold_right f map pars B.empty
+
+let unwind_to_xlate_term f c t =
+ let map t a b = B.bind a b t in
+ let f t = f (B.fold_left map t c) in
+ xlate_term c f t
+
+let xlate_entry f = function
+ | pars, u, None ->
+ let f c = unwind_to_xlate_term f c u in
+ xlate_pars f pars
+ | pars, u, Some t ->
+ let f u t = f (B.Cast ([], u, t)) in
+ let f c u = unwind_to_xlate_term (f u) c t in
+ let f c = unwind_to_xlate_term (f c) c u in
+ xlate_pars f pars
+
+(* Interface functions ******************************************************)
+
+let brg_of_meta = xlate_entry
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+val brg_of_meta: (Brg.term -> 'a) -> Meta.entry -> 'a
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module F = Format
+module O = MetaOutput
+
+type out_channel = Pervasives.out_channel * F.formatter
+
+(* internal functions *******************************************************)
+
+let hal_dir = "hal"
+
+let hal_ext = ".hal"
+
+(* interface functions ******************************************************)
+
+let open_out f name =
+ let _ = Sys.command (Printf.sprintf "mkdir -p %s" hal_dir) in
+ let och = open_out (Filename.concat hal_dir (name ^ hal_ext)) in
+ let frm = F.formatter_of_out_channel och in
+ F.pp_set_margin frm max_int;
+ f (och, frm)
+
+let write_entity f (_, frm) entity =
+ O.pp_entity f frm entity
+
+let close_out f (och, _) =
+ close_out och; f ()
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type out_channel
+
+val open_out: (out_channel -> 'a) -> string -> 'a
+
+val write_entity: (unit -> 'a) -> out_channel -> Meta.entity -> 'a
+
+val close_out: (unit -> 'a) -> out_channel -> 'a
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module P = Printf
+module F = Format
+module U = NUri
+module C = Cps
+module L = Log
+module Y = Entity
+module M = Meta
+
+type counters = {
+ eabsts: int;
+ eabbrs: int;
+ pabsts: int;
+ tsorts: int;
+ tlrefs: int;
+ tgrefs: int;
+ pappls: int;
+ tappls: int;
+ tabsts: int;
+ uris : U.uri list;
+ nodes : int;
+ xnodes: int
+}
+
+let initial_counters = {
+ eabsts = 0; eabbrs = 0; pabsts = 0; pappls = 0;
+ tsorts = 0; tlrefs = 0; tgrefs = 0; tappls = 0; tabsts = 0;
+ uris = []; nodes = 0; xnodes = 0
+}
+
+let rec count_term f c = function
+ | M.Sort _ ->
+ f {c with tsorts = succ c.tsorts; nodes = succ c.nodes}
+ | M.LRef _ ->
+ f {c with tlrefs = succ c.tlrefs; nodes = succ c.nodes}
+ | M.GRef (_, u, ts) ->
+ let c = {c with tgrefs = succ c.tgrefs} in
+ let c = {c with pappls = c.pappls + List.length ts} in
+ let c = {c with nodes = c.nodes + List.length ts} in
+ let c =
+ if Cps.list_mem ~eq:U.eq u c.uris
+ then {c with nodes = succ c.nodes}
+ else {c with xnodes = succ c.xnodes}
+ in
+ Cps.list_fold_left f count_term c ts
+ | M.Appl (v, t) ->
+ let c = {c with tappls = succ c.tappls; nodes = succ c.nodes} in
+ let f c = count_term f c t in
+ count_term f c v
+ | M.Abst (_, w, t) ->
+ let c = {c with tabsts = succ c.tabsts; nodes = succ c.nodes} in
+ let f c = count_term f c t in
+ count_term f c w
+
+let count_par f c (_, w) = count_term f c w
+
+let count_xterm f c = function
+ | None -> f c
+ | Some v -> count_term f c v
+
+let count_entity f c = function
+ | _, u, Y.Abst (pars, w, xv) ->
+ let c = {c with eabsts = succ c.eabsts} in
+ let c = {c with pabsts = c.pabsts + List.length pars} in
+ let c = {c with uris = u :: c.uris; nodes = succ c.nodes + List.length pars} in
+ let f c = count_xterm f c xv in
+ let f c = count_term f c w in
+ Cps.list_fold_left f count_par c pars
+ | _, _, Y.Abbr (pars, w, xv) ->
+ let c = {c with eabbrs = succ c.eabbrs; xnodes = succ c.xnodes} in
+ let c = {c with pabsts = c.pabsts + List.length pars} in
+ let c = {c with nodes = c.nodes + List.length pars} in
+ let f c = count_xterm f c xv in
+ let f c = count_term f c w in
+ Cps.list_fold_left f count_par c pars
+ | _, _, Y.Void -> assert false
+
+let print_counters f c =
+ let terms = c.tsorts + c.tlrefs + c.tgrefs + c.tappls + c.tabsts in
+ let pars = c.pabsts + c.pappls in
+ let entries = c.eabsts + c.eabbrs in
+ let nodes = c.nodes + c.xnodes in
+ L.warn (P.sprintf " Intermediate representation summary");
+ L.warn (P.sprintf " Total entries: %7u" entries);
+ L.warn (P.sprintf " Declaration items: %7u" c.eabsts);
+ L.warn (P.sprintf " Definition items: %7u" c.eabbrs);
+ L.warn (P.sprintf " Total parameter items: %7u" pars);
+ L.warn (P.sprintf " Application items: %7u" c.pappls);
+ L.warn (P.sprintf " Abstraction items: %7u" c.pabsts);
+ L.warn (P.sprintf " Total term items: %7u" terms);
+ L.warn (P.sprintf " Sort items: %7u" c.tsorts);
+ L.warn (P.sprintf " Local reference items: %7u" c.tlrefs);
+ L.warn (P.sprintf " Global reference items: %7u" c.tgrefs);
+ L.warn (P.sprintf " Application items: %7u" c.tappls);
+ L.warn (P.sprintf " Abstraction items: %7u" c.tabsts);
+ L.warn (P.sprintf " Global Int. Complexity: %7u" c.nodes);
+ L.warn (P.sprintf " + Abbreviation nodes: %7u" nodes);
+ f ()
+
+let string_of_sort = function
+ | true -> "Type"
+ | false -> "Prop"
+
+let pp_transparent frm a =
+ let err () = F.fprintf frm "%s" "=" in
+ let f () = F.fprintf frm "%s" "~" in
+ Y.priv err f a
+
+let pp_list pp opend sep closed frm l =
+ let rec aux frm = function
+ | [] -> ()
+ | [hd] -> pp frm hd
+ | hd :: tl -> F.fprintf frm "%a%s%a" pp hd sep aux tl
+ in
+ if l = [] then () else F.fprintf frm "%s%a%s" opend aux l closed
+
+let pp_rev_list pp opend sep closed frm l =
+ pp_list pp opend sep closed frm (List.rev l)
+
+let rec pp_args frm args = pp_list pp_term "(" "," ")" frm args
+
+and pp_term frm = function
+ | M.Sort s ->
+ F.fprintf frm "@[*%s@]" (string_of_sort s)
+ | M.LRef (l, i) ->
+ F.fprintf frm "@[%u@@#%u@]" l i
+ | M.GRef (l, uri, ts) ->
+ F.fprintf frm "@[%u@@$%s%a@]" l (U.string_of_uri uri) pp_args ts
+ | M.Appl (v, t) ->
+ F.fprintf frm "@[(%a).%a@]" pp_term v pp_term t
+ | M.Abst (id, w, t) ->
+ F.fprintf frm "@[[%s:%a].%a@]" id pp_term w pp_term t
+
+let pp_par frm (id, w) =
+ F.fprintf frm "%s:%a" id pp_term w
+
+let pp_pars = pp_rev_list pp_par "[" "," "]"
+
+let pp_body a frm = function
+ | None -> ()
+ | Some t -> F.fprintf frm "%a%a" pp_transparent a pp_term t
+
+let pp_entity frm = function
+ | a, uri, Y.Abst (pars, u, body)
+ | a, uri, Y.Abbr (pars, u, body) ->
+ F.fprintf frm "@[%u@@%s%a%a:%a@]@\n%!"
+ (Y.mark C.err C.start a) (U.string_of_uri uri)
+ pp_pars pars (pp_body a) body pp_term u
+ | _, _, Y.Void -> assert false
+
+let pp_entity f frm entity =
+ pp_entity frm entity; f ()
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+type counters
+
+val initial_counters: counters
+
+val count_entity: (counters -> 'a) -> counters -> Meta.entity -> 'a
+
+val print_counters: (unit -> 'a) -> counters -> 'a
+
+val pp_entity: (unit -> 'a) -> Format.formatter -> Meta.entity -> 'a
--- /dev/null
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+module F = Filename
+module P = Printf
+module U = NUri
+module C = Cps
+module L = Log
+module T = Time
+module O = Options
+module H = Hierarchy
+module Op = Output
+module Y = Entity
+module X = Library
+module AL = AutLexer
+module AP = AutProcess
+module AO = AutOutput
+module DT = CrgTxt
+module DA = CrgAut
+module MA = MetaAut
+module MO = MetaOutput
+module ML = MetaLibrary
+module DX = CrgXml
+module DBrg = CrgBrg
+module MBrg = MetaBrg
+module BrgO = BrgOutput
+module BrgR = BrgReduction
+module BrgU = BrgUntrusted
+module MBag = MetaBag
+module BagO = BagOutput
+module BagT = BagType
+module BagU = BagUntrusted
+
+type status = {
+ ast : AP.status;
+ dst : DA.status;
+ mst : MA.status;
+ tst : DT.status;
+ ac : AO.counters;
+ mc : MO.counters;
+ brgc: BrgO.counters;
+ bagc: BagO.counters;
+ kst : Y.status
+}
+
+let flush_all () = L.flush 0; L.flush_err ()
+
+let bag_error s msg =
+ L.error BagO.specs (L.Warn s :: L.Loc :: msg); flush_all ()
+
+let brg_error s msg =
+ L.error BrgR.specs (L.Warn s :: L.Loc :: msg); flush_all ()
+
+let initial_status () = {
+ ac = AO.initial_counters;
+ mc = MO.initial_counters;
+ brgc = BrgO.initial_counters;
+ bagc = BagO.initial_counters;
+ mst = MA.initial_status ();
+ dst = DA.initial_status ();
+ tst = DT.initial_status ();
+ ast = AP.initial_status ();
+ kst = Y.initial_status ()
+}
+
+let refresh_status st = {st with
+ mst = MA.refresh_status st.mst;
+ dst = DA.refresh_status st.dst;
+ tst = DT.refresh_status st.tst;
+ kst = Y.refresh_status st.kst
+}
+
+(* kernel related ***********************************************************)
+
+type kernel = Brg | Bag
+
+type kernel_entity = BrgEntity of Brg.entity
+ | BagEntity of Bag.entity
+ | CrgEntity of Crg.entity
+ | MetaEntity of Meta.entity
+
+let kernel = ref Brg
+
+let print_counters st = match !kernel with
+ | Brg -> BrgO.print_counters C.start st.brgc
+ | Bag -> BagO.print_counters C.start st.bagc
+
+let xlate_entity entity = match !kernel, entity with
+ | Brg, CrgEntity e ->
+ let f e = (BrgEntity e) in Y.xlate f DBrg.brg_of_crg e
+ | Brg, MetaEntity e ->
+ let f e = (BrgEntity e) in Y.xlate f MBrg.brg_of_meta e
+ | Bag, MetaEntity e ->
+ let f e = (BagEntity e) in Y.xlate f MBag.bag_of_meta e
+ | _, entity -> entity
+
+let pp_progress e =
+ let f a u =
+ let s = U.string_of_uri u in
+ let err () = L.warn (P.sprintf "%s" s) in
+ let f i = L.warn (P.sprintf "[%u] %s" i s) in
+ Y.mark err f a
+ in
+ match e with
+ | CrgEntity e -> Y.common f e
+ | BrgEntity e -> Y.common f e
+ | BagEntity e -> Y.common f e
+ | MetaEntity e -> Y.common f e
+
+let count_entity st = function
+ | MetaEntity e -> {st with mc = MO.count_entity C.start st.mc e}
+ | BrgEntity e -> {st with brgc = BrgO.count_entity C.start st.brgc e}
+ | BagEntity e -> {st with bagc = BagO.count_entity C.start st.bagc e}
+ | _ -> st
+
+let export_entity si xdir moch = function
+ | CrgEntity e -> X.export_entity DX.export_term si xdir e
+ | BrgEntity e -> X.export_entity BrgO.export_term si xdir e
+ | MetaEntity e ->
+ begin match moch with
+ | None -> ()
+ | Some och -> ML.write_entity C.start och e
+ end
+ | BagEntity _ -> ()
+
+let type_check st k =
+ let brg_err msg = brg_error "Type Error" msg; failwith "Interrupted" in
+ let ok _ _ = st in
+ match k with
+ | BrgEntity entity -> BrgU.type_check brg_err ok st.kst entity
+ | BagEntity entity -> BagU.type_check ok st.kst entity
+ | CrgEntity _
+ | MetaEntity _ -> st
+
+(* extended lexer ***********************************************************)
+
+type 'token lexer = {
+ parse : Lexing.lexbuf -> 'token;
+ mutable tokbuf: 'token option;
+ mutable unget : bool
+}
+
+let initial_lexer parse = {
+ parse = parse; tokbuf = None; unget = false
+}
+
+let token xl lexbuf = match xl.tokbuf with
+ | Some token when xl.unget ->
+ xl.unget <- false; token
+ | _ ->
+ let token = xl.parse lexbuf in
+ xl.tokbuf <- Some token; token
+
+(* input related ************************************************************)
+
+type input = Text | Automath
+
+type input_entity = TxtEntity of Txt.command
+ | AutEntity of Aut.command
+ | NoEntity
+
+let type_of_input name =
+ if F.check_suffix name ".hln" then Text
+ else if F.check_suffix name ".aut" then
+ let _ = H.set_sorts 0 ["Set"; "Prop"] in
+ assert (H.set_graph "Z2");
+ Automath
+ else begin
+ L.warn (P.sprintf "Unknown file type: %s" name); exit 2
+ end
+
+let txt_xl = initial_lexer TxtLexer.token
+
+let aut_xl = initial_lexer AutLexer.token
+
+let parbuf = ref [] (* parser buffer *)
+
+let gen_text command =
+ parbuf := TxtEntity command :: !parbuf
+
+let entity_of_input lexbuf i = match i, !parbuf with
+ | Automath, _ ->
+ begin match AutParser.entry (token aut_xl) lexbuf with
+ | Some e -> aut_xl.unget <- true; AutEntity e
+ | None -> NoEntity
+ end
+ | Text, [] ->
+ begin match TxtParser.entry (token txt_xl) lexbuf with
+ | Some e -> txt_xl.unget <- true; TxtEntity e
+ | None -> NoEntity
+ end
+ | Text, hd :: tl ->
+ parbuf := tl; hd
+
+let process_input f st = function
+ | AutEntity e ->
+ let f ast e = f {st with ast = ast} (AutEntity e) in
+ AP.process_command f st.ast e
+ | xe -> f st xe
+
+let count_input st = function
+ | AutEntity e -> {st with ac = AO.count_command C.start st.ac e}
+ | xe -> st
+
+(****************************************************************************)
+
+let stage = ref 3
+let moch = ref None
+let meta = ref false
+let progress = ref false
+let preprocess = ref false
+let root = ref ""
+let cc = ref false
+let export = ref ""
+let old = ref false
+let st = ref (initial_status ())
+let streaming = ref false (* parsing style (temporary) *)
+
+let process_2 st entity =
+ let st = if !L.level > 2 then count_entity st entity else st in
+ if !export <> "" then export_entity !O.si !export !moch entity;
+ if !stage > 2 then type_check st entity else st
+
+let process_1 st entity =
+ if !progress then pp_progress entity;
+ let st = if !L.level > 2 then count_entity st entity else st in
+ if !export <> "" && !stage = 1 then export_entity !O.si !export !moch entity;
+ if !stage > 1 then process_2 st (xlate_entity entity) else st
+
+let process_0 st entity =
+ let f st entity =
+ if !stage = 0 then st else
+ match entity, !old with
+ | AutEntity e, true ->
+ let frr mst = {st with mst = mst} in
+ let h mst e = process_1 {st with mst = mst} (MetaEntity e) in
+ MA.meta_of_aut frr h st.mst e
+ | AutEntity e, false ->
+ let err dst = {st with dst = dst} in
+ let g dst e = process_1 {st with dst = dst} (CrgEntity e) in
+ DA.crg_of_aut err g st.dst e
+ | TxtEntity e, _ ->
+ let crr tst = {st with tst = tst} in
+ let d tst e = process_1 {st with tst = tst} (CrgEntity e) in
+ DT.crg_of_txt crr d gen_text st.tst e
+ | NoEntity, _ -> assert false
+ in
+ let st = if !L.level > 2 then count_input st entity else st in
+ if !preprocess then process_input f st entity else f st entity
+
+let process_nostreaming st lexbuf input =
+ let rec aux1 book = match entity_of_input lexbuf input with
+ | NoEntity -> List.rev book
+ | e -> aux1 (e :: book)
+ in
+ let rec aux2 st = function
+ | [] -> st
+ | entity :: tl -> aux2 (process_0 st entity) tl
+ in
+ aux2 st (aux1 [])
+
+let rec process_streaming st lexbuf input = match entity_of_input lexbuf input with
+ | NoEntity -> st
+ | e -> process_streaming (process_0 st e) lexbuf input
+
+(****************************************************************************)
+
+let process st name =
+ let process = if !streaming then process_streaming else process_nostreaming in
+ let input = type_of_input name in
+ let ich = open_in name in
+ let lexbuf = Lexing.from_channel ich in
+ let st = process st lexbuf input in
+ close_in ich; st, input
+
+let main =
+try
+ let version_string = "Helena 0.8.1 M - August 2010" in
+ let print_version () = L.warn (version_string ^ "\n"); exit 0 in
+ let set_hierarchy s =
+ if H.set_graph s then () else
+ L.warn (P.sprintf "Unknown type hierarchy: %s" s)
+ in
+ let set_kernel = function
+ | "brg" -> kernel := Brg
+ | "bag" -> kernel := Bag
+ | s -> L.warn (P.sprintf "Unknown kernel version: %s" s)
+ in
+ let set_summary i = L.level := i in
+ let set_stage i = stage := i in
+ let set_meta_file name =
+ let f och = moch := Some och in
+ ML.open_out f name
+ in
+ let set_xdir s = export := s in
+ let set_root s = root := s in
+ let close = function
+ | None -> ()
+ | Some och -> ML.close_out C.start och
+ in
+ let clear_options () =
+ stage := 3; moch := None; meta := false; progress := false;
+ preprocess := false; root := ""; cc := false; export := "";
+ old := false; kernel := Brg; st := initial_status ();
+ L.clear (); O.clear (); H.clear (); Op.clear_reductions ();
+ streaming := false;
+ in
+ let process_file name =
+ if !L.level > 0 then T.gmtime version_string;
+ if !L.level > 1 then
+ L.warn (P.sprintf "Processing file: %s" name);
+ if !L.level > 0 then T.utime_stamp "started";
+ let base_name = Filename.chop_extension (Filename.basename name) in
+ if !meta then set_meta_file base_name;
+ let mk_uri =
+ if !stage < 2 then Crg.mk_uri else
+ match !kernel with
+ | Brg -> Brg.mk_uri
+ | Bag -> Bag.mk_uri
+ in
+ let cover = F.concat !root base_name in
+ O.mk_uri := mk_uri; O.cover := cover;
+ let sst, input = process (refresh_status !st) name in
+ st := sst;
+ if !L.level > 0 then T.utime_stamp "processed";
+ if !L.level > 2 then begin
+ AO.print_counters C.start !st.ac;
+ if !preprocess then AO.print_process_counters C.start !st.ast;
+ if !stage > 0 then MO.print_counters C.start !st.mc;
+ if !stage > 1 then print_counters !st;
+ if !stage > 2 then Op.print_reductions ()
+ end
+ in
+ let exit () =
+ close !moch;
+ if !L.level > 0 then T.utime_stamp "at exit";
+ flush_all ()
+ in
+ let help =
+ "Usage: helena [ -LPVXcgijmopqu1 | -Ss <number> | -x <dir> | -hkr <string> ]* [ <file> ]*\n\n" ^
+ "Summary levels: 0 just errors (default), 1 time stamps, 2 processed file names, \
+ 3 data information, 4 typing information, 5 reduction information\n\n" ^
+ "Stages: 0 parsing, 1 to intermediate, 2 to untrusted, 3 to trusted (default)\n"
+ in
+ let help_L = " show lexer debug information" in
+ let help_P = " show parser debug information" in
+ let help_S = "<number> set summary level (see above)" in
+ let help_V = " show version information" in
+ let help_X = " clear options" in
+
+ let help_c = " output conversion constraints" in
+ let help_g = " always expand global definitions" in
+ let help_h = "<string> set type hierarchy (default: Z1)" in
+ let help_i = " show local references by index" in
+ let help_j = " show URI of processed kernel objects" in
+ let help_k = "<string> set kernel version (default: brg)" in
+ let help_m = " output intermediate representation (HAL)" in
+ let help_o = " use old abstract language instead of crg" in
+ let help_p = " preprocess source" in
+ let help_q = " disable quotation of identifiers" in
+ let help_r = "<string> set initial segment of URI hierarchy" in
+ let help_s = "<number> set translation stage (see above)" in
+ let help_u = " activate sort inclusion" in
+ let help_x = "<dir> export kernel entities (XML) to <dir>" in
+
+ let help_1 = " parse files with streaming policy" in
+ L.box 0; L.box_err ();
+ at_exit exit;
+ Arg.parse [
+ ("-L", Arg.Set O.debug_lexer, help_L);
+ ("-P", Arg.Set O.debug_parser, help_P);
+ ("-S", Arg.Int set_summary, help_S);
+ ("-V", Arg.Unit print_version, help_V);
+ ("-X", Arg.Unit clear_options, help_X);
+ ("-c", Arg.Set cc, help_c);
+ ("-g", Arg.Set O.expand, help_g);
+ ("-h", Arg.String set_hierarchy, help_h);
+ ("-i", Arg.Set O.indexes, help_i);
+ ("-j", Arg.Set progress, help_j);
+ ("-k", Arg.String set_kernel, help_k);
+ ("-m", Arg.Set meta, help_m);
+ ("-o", Arg.Set old, help_o);
+ ("-p", Arg.Set preprocess, help_p);
+ ("-q", Arg.Set O.unquote, help_q);
+ ("-r", Arg.String set_root, help_r);
+ ("-s", Arg.Int set_stage, help_s);
+ ("-u", Arg.Set O.si, help_u);
+ ("-x", Arg.String set_xdir, help_x);
+ ("-1", Arg.Set streaming, help_1);
+ ] process_file help;
+with BagT.TypeError msg -> bag_error "Type Error" msg
+++ /dev/null
-nUri cps share log time
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-let err _ = assert false
-
-let start x = x
-
-let id f x = f x
-
-let rec list_sub_strict f l1 l2 = match l1, l2 with
- | _, [] -> f l1
- | _ :: tl1, _ :: tl2 -> list_sub_strict f tl1 tl2
- | _ -> assert false
-
-(* this is not tail recursive *)
-let rec list_fold_left f map a = function
- | [] -> f a
- | hd :: tl ->
- let f a = list_fold_left f map a tl in
- map f a hd
-
-(* this is not tail recursive *)
-let rec list_rev_map_append f map ~tail = function
- | [] -> f tail
- | hd :: tl ->
- let f hd = list_rev_map_append f map ~tail:(hd :: tail) tl in
- map f hd
-
-(* this is not tail recursive *)
-let rec list_forall2 f map l1 l2 = match l1, l2 with
- | [], [] -> f true
- | hd1 :: tl1, hd2 :: tl2 ->
- let f b = if b then list_forall2 f map tl1 tl2 else f false in
- map f hd1 hd2
- | _ -> f false
-
-let list_rev_append f =
- list_rev_map_append f (fun f t -> f t)
-
-let list_rev_map =
- list_rev_map_append ~tail:[]
-
-let list_rev =
- list_rev_append ~tail:[]
-
-let list_iter f map l =
- let map f () x = map f x in
- list_fold_left f map () l
-
-(* this is not tail recursive *)
-let rec list_fold_left2 f map a l1 l2 = match l1, l2 with
- | [], [] -> f a
- | hd1 :: tl1, hd2 :: tl2 ->
- let f a = list_fold_left2 f map a tl1 tl2 in
- map f a hd1 hd2
- | _ -> assert false
-
-let list_iter2 f map l1 l2 =
- let map f () x1 x2 = map f x1 x2 in
- list_fold_left2 f map () l1 l2
-
-let rec list_fold_right f map l a = match l with
- | [] -> f a
- | hd :: tl -> list_fold_right (map f hd) map tl a
-
-let list_map f map l =
- let map f hd a =
- let f hd = f (hd :: a) in map f hd
- in
- list_fold_right f map l []
-
-let rec list_mem ?(eq=(=)) a = function
- | [] -> false
- | hd :: _ when eq a hd -> true
- | _ :: tl -> list_mem ~eq a tl
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module P = Printf
-module F = Format
-module C = Cps
-
-type ('a, 'b) item = Term of 'a * 'b
- | LEnv of 'a
- | Warn of string
- | String of string
- | Loc
-
-type ('a, 'b) message = ('a, 'b) item list
-
-type ('a, 'b) specs = {
- pp_term: 'a -> F.formatter -> 'b -> unit;
- pp_lenv: F.formatter -> 'a -> unit
-}
-
-let level = ref 0
-
-let loc = ref "unknown location"
-
-(* Internal functions *******************************************************)
-
-let clear () =
- level := 0; loc := "unknown location"
-
-let std = F.std_formatter
-
-let err = F.err_formatter
-
-let pp_items frm st l items =
- let pp_item frm = function
- | Term (c, t) -> F.fprintf frm "@,%a" (st.pp_term c) t
- | LEnv c -> F.fprintf frm "%a" st.pp_lenv c
- | Warn s -> F.fprintf frm "@,%s" s
- | String s -> F.fprintf frm "%s " s
- | Loc -> F.fprintf frm " <%s>" !loc
- in
- let iter map frm l = List.iter (map frm) l in
- if !level >= l then F.fprintf frm "%a" (iter pp_item) items
-
-(* Interface functions ******************************************************)
-
-let box l =
- if !level >= l then
- begin F.fprintf std "@,@[<v 2>%s" " "; F.pp_print_if_newline std () end
-
-let unbox l = if !level >= l then F.fprintf std "@]"
-
-let flush l = if !level >= l then F.fprintf std "@]@."
-
-let box_err () = F.fprintf err "@[<v>"
-
-let flush_err () = F.fprintf err "@]@."
-
-let log st l items = pp_items std st l items
-
-let error st items = pp_items err st 0 items
-
-let items1 s = [Warn s]
-
-let t_items1 st c t =
- [Warn st; Term (c, t)]
-
-let et_items1 sc c st t =
- [Warn sc; LEnv c; Warn st; Term (c, t)]
-
-let et_items2 sc1 c1 st1 t1 ?sc2 ?c2 st2 t2 =
- let tl = match sc2, c2 with
- | Some sc2, Some c2 -> et_items1 sc2 c2 st2 t2
- | None, None -> t_items1 st2 c1 t2
- | _ -> assert false
- in
- et_items1 sc1 c1 st1 t1 @ tl
-
-let et_items3 sc1 c1 st1 t1 ?sc2 ?c2 st2 t2 ?sc3 ?c3 st3 t3 =
- let tl = match sc3, c3 with
- | Some sc3, Some c3 -> et_items1 sc3 c3 st3 t3
- | None, None -> t_items1 st3 c1 t3
- | _ -> assert false
- in
- et_items2 sc1 c1 st1 t1 ?sc2 ?c2 st2 t2 @ tl
-
-let warn msg = F.fprintf std "@,%s" msg
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type ('a, 'b) item = Term of 'a * 'b
- | LEnv of 'a
- | Warn of string
- | String of string
- | Loc
-
-type ('a, 'b) message = ('a, 'b) item list
-
-type ('a, 'b) specs = {
- pp_term: 'a -> Format.formatter -> 'b -> unit;
- pp_lenv: Format.formatter -> 'a -> unit
-}
-
-val loc: string ref
-
-val level: int ref
-
-val clear: unit -> unit
-
-val warn: string -> unit
-
-val box: int -> unit
-
-val unbox: int -> unit
-
-val flush: int -> unit
-
-val box_err: unit -> unit
-
-val flush_err: unit -> unit
-
-val log: ('a, 'b) specs -> int -> ('a, 'b) message -> unit
-
-val error: ('a, 'b) specs -> ('a, 'b) message -> unit
-
-val items1: string -> ('a, 'b) message
-
-val t_items1: string -> 'a -> 'b -> ('a, 'b) message
-
-val et_items1:
- string -> 'a -> string -> 'b -> ('a, 'b) message
-
-val et_items2:
- string -> 'a -> string -> 'b ->
- ?sc2:string -> ?c2:'a -> string -> 'b ->
- ('a, 'b) message
-
-val et_items3:
- string -> 'a -> string -> 'b ->
- ?sc2:string -> ?c2:'a -> string -> 'b ->
- ?sc3:string -> ?c3:'a -> string -> 'b ->
- ('a, 'b) message
+++ /dev/null
-../../components/ng_kernel/nUri.ml
\ No newline at end of file
+++ /dev/null
-../../components/ng_kernel/nUri.mli
\ No newline at end of file
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-let sh a b =
- if a == b then a else b
-
-let sh1 a1 a2 b1 b2 =
- if a1 == a2 then b1 else b2 (sh a1 a2)
-
-let sh2 a1 a2 b1 b2 c1 c2 =
- if a1 == a2 && b1 == b2 then c1 else c2 (sh a1 a2) (sh b1 b2)
-
-let eq a b = (a == b) || (a = b)
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module P = Printf
-module L = Log
-
-let utime_stamp =
- let old = ref 0.0 in
- fun msg ->
- let times = Unix.times () in
- let stamp = times.Unix.tms_utime in
- let lap = stamp -. !old in
- L.warn (P.sprintf "USR TIME STAMP (%s): %f (%f)" msg stamp lap);
- old := stamp
-
-let gmtime msg =
- let gmt = Unix.gmtime (Unix.time ()) in
- let yy = gmt.Unix.tm_year + 1900 in
- let mm = gmt.Unix.tm_mon + 1 in
- let dd = gmt.Unix.tm_mday in
- let h = gmt.Unix.tm_hour in
- let m = gmt.Unix.tm_min in
- let s = gmt.Unix.tm_sec in
- L.warn (
- P.sprintf "UTC TIME STAMP (%s): %u/%u/%u %u:%u:%u" msg yy mm dd h m s
- )
+++ /dev/null
-txt txtParser txtLexer txtTxt
+++ /dev/null
-\open pippo
-
-\global a : *Set
-
-\global b : *Prop
-
-\global f = [x:*Set].[y:*Prop].x
-
-\global "commento\"" c = f(a,b) : *Set
-
-\close
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type ix = int (* index *)
-
-type id = string (* identifier *)
-
-type desc = string (* description *)
-
-type kind = Decl (* generic declaration *)
- | Ax (* axiom *)
- | Def (* generic definition *)
- | Th (* theorem *)
-
-type bind = Abst of (id * bool * term) list (* name, real?, domain *)
- | Abbr of (id * term) list (* name, bodies *)
- | Void of id list (* names *)
-
-and term = Sort of ix (* level *)
- | NSrt of id (* named level *)
- | LRef of ix * ix (* index, offset *)
- | NRef of id (* name *)
- | Cast of term * term (* domain, element *)
- | Appl of term list * term (* arguments, function *)
- | Bind of bind * term (* binder, scope *)
- | Inst of term * term list (* function, arguments *)
- | Impl of bool * id * term * term (* strong?, label, source, target *)
-
-type command = Require of id list (* required files: names *)
- | Graph of id (* hierarchy graph: name *)
- | Sorts of (int option * id) list (* sorts: index, name *)
- | Section of id option (* section: Some id = open, None = close last *)
- | Entity of kind * id * desc * term (* entity: class, name, description, contents *)
- | Generate of term list (* predefined generated entity: arguments *)
-
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-{
- module L = Log
- module O = Options
- module P = TxtParser
-
- let out s = if !O.debug_lexer then L.warn s else ()
-}
-
-let BS = "\\"
-let SPC = [' ' '\t' '\n']+
-let OC = "\\*"
-let CC = "*\\"
-let FIG = ['0'-'9']
-let ALPHA = ['A'-'Z' 'a'-'z' '_']
-let QT = '"'
-let ID = ALPHA+ (ALPHA | FIG)*
-let IX = FIG+
-
-rule block_comment = parse
- | CC { () }
- | OC { block_comment lexbuf; block_comment lexbuf }
- | _ { block_comment lexbuf }
-and qstring = parse
- | QT { "" }
- | SPC { " " ^ qstring lexbuf }
- | BS BS { "\\" ^ qstring lexbuf }
- | BS QT { "\"" ^ qstring lexbuf }
- | _ as c { String.make 1 c ^ qstring lexbuf }
-and token = parse
- | SPC { token lexbuf }
- | OC { block_comment lexbuf; token lexbuf }
- | ID as id { out ("ID " ^ id); P.ID id }
- | IX as ix { out ("IX " ^ ix); P.IX (int_of_string ix) }
- | QT { let s = qstring lexbuf in out ("STR " ^ s); P.STR s }
- | "\\graph" { out "GRAPH"; P.GRAPH }
- | "\\decl" { out "DECL"; P.DECL }
- | "\\ax" { out "AX"; P.AX }
- | "\\def" { out "DEF"; P.DEF }
- | "\\th" { out "TH"; P.TH }
- | "\\generate" { out "GEN"; P.GEN }
- | "\\require" { out "REQ"; P.REQ }
- | "\\open" { out "OPEN"; P.OPEN }
- | "\\close" { out "CLOSE"; P.CLOSE }
- | "\\sorts" { out "SORTS"; P.SORTS }
- | "(" { out "OP"; P.OP }
- | ")" { out "CP"; P.CP }
- | "[" { out "OB"; P.OB }
- | "]" { out "CB"; P.CB }
- | "<" { out "OA"; P.OA }
- | ">" { out "CA"; P.CA }
- | "." { out "FS"; P.FS }
- | ":" { out "CN"; P.CN }
- | "," { out "CM"; P.CM }
- | "=" { out "EQ"; P.EQ }
- | "*" { out "STAR"; P.STAR }
- | "#" { out "HASH"; P.HASH }
- | "+" { out "PLUS"; P.PLUS }
- | "~" { out "TE"; P.TE }
- | "->" { out "WTO"; P.WTO }
- | "=>" { out "STO"; P.STO }
- | eof { out "EOF"; P.EOF }
+++ /dev/null
-/* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- */
-
-%{
- module O = Options
- module T = Txt
-
- let _ = Parsing.set_trace !O.debug_parser
-%}
- %token <int> IX
- %token <string> ID STR
- %token OP CP OB CB OA CA FS CN CM EQ STAR HASH PLUS TE WTO STO
- %token GRAPH DECL AX DEF TH GEN REQ OPEN CLOSE SORTS EOF
-
- %start entry
- %type <Txt.command option> entry
-
- %nonassoc CP CB CA
- %right WTO STO
-%%
- hash:
- | {}
- | HASH {}
- ;
- fs:
- | {}
- | FS {}
- ;
- comment:
- | { "" }
- | STR { $1 }
- ;
- ids:
- | ID { [$1] }
- | ID CM ids { $1 :: $3 }
- ;
- sort:
- | ID { None, $1 }
- | IX ID { Some $1, $2 }
- ;
- sorts:
- | sort { [$1] }
- | sort CM sorts { $1 :: $3 }
- ;
-
- abst:
- | ID CN term { $1, true, $3 }
- | TE term { "", false, $2 }
- | ID TE term { $1, false, $3 }
- ;
- abbr:
- | ID EQ term { $1, $3 }
- ;
- absts:
- | abst { [$1] }
- | abst CM absts { $1 :: $3 }
- ;
- abbrs:
- | abbr { [$1] }
- | abbr CM abbrs { $1 :: $3 }
- ;
- binder:
- | absts { T.Abst $1 }
- | abbrs { T.Abbr $1 }
- | ids { T.Void $1 }
- ;
- atom:
- | STAR IX { T.Sort $2 }
- | STAR ID { T.NSrt $2 }
- | hash IX { T.LRef ($2, 0) }
- | hash IX PLUS IX { T.LRef ($2, $4) }
- | ID { T.NRef $1 }
- | HASH ID { T.NRef $2 }
- | atom OP term CP { T.Inst ($1, [$3]) }
- | atom OP terms CP { T.Inst ($1, $3) }
- ;
- term:
- | atom { $1 }
- | OA term CA fs term { T.Cast ($2, $5) }
- | OP term CP fs term { T.Appl ([$2], $5) }
- | OP terms CP fs term { T.Appl ($2, $5) }
- | OB binder CB fs term { T.Bind ($2, $5) }
- | term WTO term { T.Impl (false, "", $1, $3) }
- | ID TE term WTO term { T.Impl (false, $1, $3, $5) }
- | term STO term { T.Impl (true, "", $1, $3) }
- | ID TE term STO term { T.Impl (true, $1, $3, $5) }
- | OP term CP { $2 }
- ;
- terms:
- | term CM term { [$1; $3] }
- | term CM terms { $1 :: $3 }
- ;
-
- decl:
- | DECL { T.Decl }
- | AX { T.Ax }
- ;
- def:
- | DEF { T.Def }
- | TH { T.Th }
- ;
- xentity:
- | GRAPH ID
- { T.Graph $2 }
- | decl comment ID CN term
- { T.Entity ($1, $3, $2, $5) }
- | def comment ID EQ term
- { T.Entity ($1, $3, $2, $5) }
- | def comment ID EQ term CN term
- { T.Entity ($1, $3, $2, T.Cast ($7, $5)) }
- | GEN term
- { T.Generate [$2] }
- | GEN terms
- { T.Generate $2 }
- | REQ ids
- { T.Require $2 }
- | OPEN ID
- { T.Section (Some $2) }
- | CLOSE
- { T.Section None }
- | SORTS sorts
- { T.Sorts $2 }
- ;
- start:
- | GRAPH {} | decl {} | def {} | GEN {} |
- | REQ {} | OPEN {} | CLOSE {} | SORTS {} | EOF {}
- ;
- entry:
- | xentity start { Some $1 }
- | EOF { None }
- ;
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module C = Cps
-module T = Txt
-
-(* Interface functions ******************************************************)
-
-let rec contract f = function
- | T.Inst (t, vs) ->
- let tt = T.Appl (List.rev vs, t) in
- contract f tt
- | T.Impl (false, id, w, t) ->
- let tt = T.Bind (T.Abst [id, false, w], t) in
- contract f tt
- | T.Impl (true, id, w, t) ->
- let f = function
- | T.Bind (T.Abst [xw], T.Bind (T.Abst xws, tt)) ->
- f (T.Bind (T.Abst (xw :: xws), tt))
- | tt -> f tt
- in
- let tt = T.Impl (false, id, w, t) in
- contract f tt
- | T.Sort _
- | T.NSrt _
- | T.LRef _
- | T.NRef _ as t -> f t
- | T.Cast (u, t) ->
- let f tt uu = f (T.Cast (uu, tt)) in
- let f tt = contract (f tt) u in
- contract f t
- | T.Appl (vs, t) ->
- let f tt vvs = f (T.Appl (vvs, tt)) in
- let f tt = C.list_map (f tt) contract vs in
- contract f t
- | T.Bind (b, t) ->
- let f tt bb = f (T.Bind (bb, tt)) in
- let f tt = contract_binder (f tt) b in
- contract f t
-
-and contract_binder f = function
- | T.Void n as b -> f b
- | T.Abbr xvs ->
- let map f (id, v) =
- let f vv = f (id, vv) in contract f v
- in
- let f xvvs = f (T.Abbr xvvs) in
- C.list_map f map xvs
- | T.Abst xws ->
- let map f (id, real, w) =
- let f ww = f (id, real, ww) in contract f w
- in
- let f xwws = f (T.Abst xwws) in
- C.list_map f map xws
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-val contract: (Txt.term -> 'a) -> Txt.term -> 'a
+++ /dev/null
-meta metaOutput metaLibrary metaAut metaBag metaBrg top
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type uri = Entity.uri
-type id = Entity.id
-
-type term = Sort of bool (* sorts: true = TYPE, false = PROP *)
- | LRef of int * int (* local reference: local environment length, de bruijn index *)
- | GRef of int * uri * term list (* global reference: local environment length, name, arguments *)
- | Appl of term * term (* application: argument, function *)
- | Abst of id * term * term (* abstraction: name, domain, scope *)
-
-type pars = (id * term) list (* parameter declarations: name, type *)
-
-type entry = pars * term * term option (* parameters, domain, body *)
-
-type entity = entry Entity.entity
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module U = NUri
-module H = U.UriHash
-module C = Cps
-module O = Options
-module Y = Entity
-module M = Meta
-module A = Aut
-
-(* qualified identifier: uri, name, qualifiers *)
-type qid = M.uri * M.id * M.id list
-
-type context_node = qid option (* context node: None = root *)
-
-type status = {
- path: M.id list; (* current section path *)
- node: context_node; (* current context node *)
- nodes: context_node list; (* context node list *)
- line: int; (* line number *)
- cover: string (* initial segment of URI hierarchy *)
-}
-
-type resolver = Local of int
- | Global of M.pars
-
-let henv_size, hcnt_size = 7000, 4300 (* hash tables initial sizes *)
-
-let henv = H.create henv_size (* optimized global environment *)
-
-let hcnt = H.create hcnt_size (* optimized context *)
-
-(* Internal functions *******************************************************)
-
-let id_of_name (id, _, _) = id
-
-let mk_qid st id path =
- let uripath = if st.cover = "" then path else st.cover :: path in
- let str = String.concat "/" uripath in
- let str = Filename.concat str id in
- U.uri_of_string ("ld:/" ^ str ^ ".ld"), id, path
-
-let uri_of_qid (uri, _, _) = uri
-
-let complete_qid f st (id, is_local, qs) =
- let f qs = f (mk_qid st id qs) in
- let f path = C.list_rev_append f path ~tail:qs in
- let rec skip f = function
- | phd :: ptl, qshd :: _ when phd = qshd -> f ptl
- | _ :: ptl, _ :: _ -> skip f (ptl, qs)
- | _ -> f []
- in
- if is_local then f st.path else skip f (st.path, qs)
-
-let relax_qid f st (_, id, path) =
- let f path = f (mk_qid st id path) in
- let f = function
- | _ :: tl -> C.list_rev f tl
- | [] -> assert false
- in
- C.list_rev f path
-
-let relax_opt_qid f st = function
- | None -> f None
- | Some qid -> let f qid = f (Some qid) in relax_qid f st qid
-
-let resolve_lref f st l lenv id =
- let rec aux f i = function
- | [] -> f None
- | (name, _) :: _ when name = id -> f (Some (M.LRef (l, i)))
- | _ :: tl -> aux f (succ i) tl
- in
- aux f 0 lenv
-
-let resolve_lref_strict f st l lenv id =
- let f = function
- | Some t -> f t
- | None -> assert false
- in
- resolve_lref f st l lenv id
-
-let resolve_gref f st qid =
- try let args = H.find henv (uri_of_qid qid) in f qid (Some args)
- with Not_found -> f qid None
-
-let resolve_gref_relaxed f st qid =
-(* this is not tail recursive *)
- let rec g qid = function
- | None -> relax_qid (resolve_gref g st) st qid
- | Some args -> f qid args
- in
- resolve_gref g st qid
-
-let get_pars f st = function
- | None -> f [] None
- | Some qid as node ->
- try let pars = H.find hcnt (uri_of_qid qid) in f pars None
- with Not_found -> f [] (Some node)
-
-let get_pars_relaxed f st =
-(* this is not tail recursive *)
- let rec g pars = function
- | None -> f pars
- | Some node -> relax_opt_qid (get_pars g st) st node
- in
- get_pars g st st.node
-
-(* this is not tail recursive on the GRef branch *)
-let rec xlate_term f st lenv = function
- | A.Sort sort ->
- f (M.Sort sort)
- | A.Appl (v, t) ->
- let f vv tt = f (M.Appl (vv, tt)) in
- let f vv = xlate_term (f vv) st lenv t in
- xlate_term f st lenv v
- | A.Abst (name, w, t) ->
- let add name w lenv = (name, w) :: lenv in
- let f ww tt = f (M.Abst (name, ww, tt)) in
- let f ww = xlate_term (f ww) st (add name ww lenv) t in
- xlate_term f st lenv w
- | A.GRef (name, args) ->
- let l = List.length lenv in
- let g qid defs =
- let map1 f = xlate_term f st lenv in
- let map2 f (id, _) = resolve_lref_strict f st l lenv id in
- let f tail =
- let f args = f (M.GRef (l, uri_of_qid qid, args)) in
- let f defs = C.list_rev_map_append f map2 defs ~tail in
- C.list_sub_strict f defs args
- in
- C.list_map f map1 args
- in
- let g qid = resolve_gref_relaxed g st qid in
- let f = function
- | Some t -> f t
- | None -> complete_qid g st name
- in
- resolve_lref f st l lenv (id_of_name name)
-
-let xlate_entity err f st = function
- | A.Section (Some (_, name)) ->
- err {st with path = name :: st.path; nodes = st.node :: st.nodes}
- | A.Section None ->
- begin match st.path, st.nodes with
- | _ :: ptl, nhd :: ntl ->
- err {st with path = ptl; node = nhd; nodes = ntl}
- | _ -> assert false
- end
- | A.Context None ->
- err {st with node = None}
- | A.Context (Some name) ->
- let f name = err {st with node = Some name} in
- complete_qid f st name
- | A.Block (name, w) ->
- let f qid =
- let f pars =
- let f ww =
- H.add hcnt (uri_of_qid qid) ((name, ww) :: pars);
- err {st with node = Some qid}
- in
- xlate_term f st pars w
- in
- get_pars_relaxed f st
- in
- complete_qid f st (name, true, [])
- | A.Decl (name, w) ->
- let f pars =
- let f qid =
- let f ww =
- H.add henv (uri_of_qid qid) pars;
- let a = [Y.Mark st.line] in
- let entry = pars, ww, None in
- let entity = a, uri_of_qid qid, Y.Abst entry in
- f {st with line = succ st.line} entity
- in
- xlate_term f st pars w
- in
- complete_qid f st (name, true, [])
- in
- get_pars_relaxed f st
- | A.Def (name, w, trans, v) ->
- let f pars =
- let f qid =
- let f ww vv =
- H.add henv (uri_of_qid qid) pars;
- let a = Y.Mark st.line :: if trans then [] else [Y.Priv] in
- let entry = pars, ww, Some vv in
- let entity = a, uri_of_qid qid, Y.Abbr entry in
- f {st with line = succ st.line} entity
- in
- let f ww = xlate_term (f ww) st pars v in
- xlate_term f st pars w
- in
- complete_qid f st (name, true, [])
- in
- get_pars_relaxed f st
-
-(* Interface functions ******************************************************)
-
-let initial_status () =
- H.clear henv; H.clear hcnt; {
- path = []; node = None; nodes = []; line = 1; cover = !O.cover
-}
-
-let refresh_status st = {st with
- cover = !O.cover
-}
-
-let meta_of_aut = xlate_entity
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type status
-
-val initial_status: unit -> status
-
-val refresh_status: status -> status
-
-val meta_of_aut:
- (status -> 'a) -> (status -> Meta.entity -> 'a) ->
- status -> Aut.command -> 'a
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module C = Cps
-module B = Bag
-module M = Meta
-
-(* Internal functions *******************************************************)
-
-let rec xlate_term c f = function
- | M.Sort s ->
- let f h = f (B.Sort h) in
- if s then f 0 else f 1
- | M.LRef (_, i) ->
- let l, _, _ = List.nth c i in
- f (B.LRef l)
- | M.GRef (_, uri, vs) ->
- let map f t v = f (B.appl v t) in
- let f vs = C.list_fold_left f map (B.GRef uri) vs in
- C.list_map f (xlate_term c) vs
- | M.Appl (v, t) ->
- let f v t = f (B.Appl (v, t)) in
- let f v = xlate_term c (f v) t in
- xlate_term c f v
- | M.Abst (id, w, t) ->
- let f w =
- let l = B.new_location () in
- let f t = f (B.Bind (l, id, B.Abst w, t)) in
- let f c = xlate_term c f t in
- B.push "meta" f c l id (B.Abst w)
- in
- xlate_term c f w
-
-let xlate_pars f pars =
- let map f (id, w) c =
- let l = B.new_location () in
- let f w = B.push "meta" f c l id (B.Abst w) in
- xlate_term c f w
- in
- C.list_fold_right f map pars B.empty_lenv
-
-let unwind_to_xlate_term f c t =
- let map f t (l, id, b) = f (B.bind l id b t) in
- let f t = C.list_fold_left f map t c in
- xlate_term c f t
-
-let xlate_entry f = function
- | pars, u, None ->
- let f c = unwind_to_xlate_term f c u in
- xlate_pars f pars
- | pars, u, Some t ->
- let f u t = f (B.Cast (u, t)) in
- let f c u = unwind_to_xlate_term (f u) c t in
- let f c = unwind_to_xlate_term (f c) c u in
- xlate_pars f pars
-
-(* Interface functions ******************************************************)
-
-let bag_of_meta = xlate_entry
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-val bag_of_meta: (Bag.term -> 'a) -> Meta.entry -> 'a
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module C = Cps
-module Y = Entity
-module B = Brg
-module M = Meta
-
-(* Internal functions *******************************************************)
-
-let rec xlate_term c f = function
- | M.Sort s ->
- let f h = f (B.Sort ([], h)) in
- if s then f 0 else f 1
- | M.LRef (_, i) ->
- f (B.LRef ([], i))
- | M.GRef (_, uri, vs) ->
- let map f t v = f (B.appl [] v t) in
- let f vs = C.list_fold_left f map (B.GRef ([], uri)) vs in
- C.list_map f (xlate_term c) vs
- | M.Appl (v, t) ->
- let f v t = f (B.Appl ([], v, t)) in
- let f v = xlate_term c (f v) t in
- xlate_term c f v
- | M.Abst (id, w, t) ->
- let f w =
- let a = [Y.Name (id, true)] in
- let f t = f (B.Bind (a, B.Abst w, t)) in
- xlate_term (B.push c B.empty a (B.Abst w)) f t
- in
- xlate_term c f w
-
-let xlate_pars f pars =
- let map f (id, w) c =
- let a = [Y.Name (id, true)] in
- let f w = f (B.push c B.empty a (B.Abst w)) in
- xlate_term c f w
- in
- C.list_fold_right f map pars B.empty
-
-let unwind_to_xlate_term f c t =
- let map t a b = B.bind a b t in
- let f t = f (B.fold_left map t c) in
- xlate_term c f t
-
-let xlate_entry f = function
- | pars, u, None ->
- let f c = unwind_to_xlate_term f c u in
- xlate_pars f pars
- | pars, u, Some t ->
- let f u t = f (B.Cast ([], u, t)) in
- let f c u = unwind_to_xlate_term (f u) c t in
- let f c = unwind_to_xlate_term (f c) c u in
- xlate_pars f pars
-
-(* Interface functions ******************************************************)
-
-let brg_of_meta = xlate_entry
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-val brg_of_meta: (Brg.term -> 'a) -> Meta.entry -> 'a
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module F = Format
-module O = MetaOutput
-
-type out_channel = Pervasives.out_channel * F.formatter
-
-(* internal functions *******************************************************)
-
-let hal_dir = "hal"
-
-let hal_ext = ".hal"
-
-(* interface functions ******************************************************)
-
-let open_out f name =
- let _ = Sys.command (Printf.sprintf "mkdir -p %s" hal_dir) in
- let och = open_out (Filename.concat hal_dir (name ^ hal_ext)) in
- let frm = F.formatter_of_out_channel och in
- F.pp_set_margin frm max_int;
- f (och, frm)
-
-let write_entity f (_, frm) entity =
- O.pp_entity f frm entity
-
-let close_out f (och, _) =
- close_out och; f ()
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type out_channel
-
-val open_out: (out_channel -> 'a) -> string -> 'a
-
-val write_entity: (unit -> 'a) -> out_channel -> Meta.entity -> 'a
-
-val close_out: (unit -> 'a) -> out_channel -> 'a
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module P = Printf
-module F = Format
-module U = NUri
-module C = Cps
-module L = Log
-module Y = Entity
-module M = Meta
-
-type counters = {
- eabsts: int;
- eabbrs: int;
- pabsts: int;
- tsorts: int;
- tlrefs: int;
- tgrefs: int;
- pappls: int;
- tappls: int;
- tabsts: int;
- uris : U.uri list;
- nodes : int;
- xnodes: int
-}
-
-let initial_counters = {
- eabsts = 0; eabbrs = 0; pabsts = 0; pappls = 0;
- tsorts = 0; tlrefs = 0; tgrefs = 0; tappls = 0; tabsts = 0;
- uris = []; nodes = 0; xnodes = 0
-}
-
-let rec count_term f c = function
- | M.Sort _ ->
- f {c with tsorts = succ c.tsorts; nodes = succ c.nodes}
- | M.LRef _ ->
- f {c with tlrefs = succ c.tlrefs; nodes = succ c.nodes}
- | M.GRef (_, u, ts) ->
- let c = {c with tgrefs = succ c.tgrefs} in
- let c = {c with pappls = c.pappls + List.length ts} in
- let c = {c with nodes = c.nodes + List.length ts} in
- let c =
- if Cps.list_mem ~eq:U.eq u c.uris
- then {c with nodes = succ c.nodes}
- else {c with xnodes = succ c.xnodes}
- in
- Cps.list_fold_left f count_term c ts
- | M.Appl (v, t) ->
- let c = {c with tappls = succ c.tappls; nodes = succ c.nodes} in
- let f c = count_term f c t in
- count_term f c v
- | M.Abst (_, w, t) ->
- let c = {c with tabsts = succ c.tabsts; nodes = succ c.nodes} in
- let f c = count_term f c t in
- count_term f c w
-
-let count_par f c (_, w) = count_term f c w
-
-let count_xterm f c = function
- | None -> f c
- | Some v -> count_term f c v
-
-let count_entity f c = function
- | _, u, Y.Abst (pars, w, xv) ->
- let c = {c with eabsts = succ c.eabsts} in
- let c = {c with pabsts = c.pabsts + List.length pars} in
- let c = {c with uris = u :: c.uris; nodes = succ c.nodes + List.length pars} in
- let f c = count_xterm f c xv in
- let f c = count_term f c w in
- Cps.list_fold_left f count_par c pars
- | _, _, Y.Abbr (pars, w, xv) ->
- let c = {c with eabbrs = succ c.eabbrs; xnodes = succ c.xnodes} in
- let c = {c with pabsts = c.pabsts + List.length pars} in
- let c = {c with nodes = c.nodes + List.length pars} in
- let f c = count_xterm f c xv in
- let f c = count_term f c w in
- Cps.list_fold_left f count_par c pars
- | _, _, Y.Void -> assert false
-
-let print_counters f c =
- let terms = c.tsorts + c.tlrefs + c.tgrefs + c.tappls + c.tabsts in
- let pars = c.pabsts + c.pappls in
- let entries = c.eabsts + c.eabbrs in
- let nodes = c.nodes + c.xnodes in
- L.warn (P.sprintf " Intermediate representation summary");
- L.warn (P.sprintf " Total entries: %7u" entries);
- L.warn (P.sprintf " Declaration items: %7u" c.eabsts);
- L.warn (P.sprintf " Definition items: %7u" c.eabbrs);
- L.warn (P.sprintf " Total parameter items: %7u" pars);
- L.warn (P.sprintf " Application items: %7u" c.pappls);
- L.warn (P.sprintf " Abstraction items: %7u" c.pabsts);
- L.warn (P.sprintf " Total term items: %7u" terms);
- L.warn (P.sprintf " Sort items: %7u" c.tsorts);
- L.warn (P.sprintf " Local reference items: %7u" c.tlrefs);
- L.warn (P.sprintf " Global reference items: %7u" c.tgrefs);
- L.warn (P.sprintf " Application items: %7u" c.tappls);
- L.warn (P.sprintf " Abstraction items: %7u" c.tabsts);
- L.warn (P.sprintf " Global Int. Complexity: %7u" c.nodes);
- L.warn (P.sprintf " + Abbreviation nodes: %7u" nodes);
- f ()
-
-let string_of_sort = function
- | true -> "Type"
- | false -> "Prop"
-
-let pp_transparent frm a =
- let err () = F.fprintf frm "%s" "=" in
- let f () = F.fprintf frm "%s" "~" in
- Y.priv err f a
-
-let pp_list pp opend sep closed frm l =
- let rec aux frm = function
- | [] -> ()
- | [hd] -> pp frm hd
- | hd :: tl -> F.fprintf frm "%a%s%a" pp hd sep aux tl
- in
- if l = [] then () else F.fprintf frm "%s%a%s" opend aux l closed
-
-let pp_rev_list pp opend sep closed frm l =
- pp_list pp opend sep closed frm (List.rev l)
-
-let rec pp_args frm args = pp_list pp_term "(" "," ")" frm args
-
-and pp_term frm = function
- | M.Sort s ->
- F.fprintf frm "@[*%s@]" (string_of_sort s)
- | M.LRef (l, i) ->
- F.fprintf frm "@[%u@@#%u@]" l i
- | M.GRef (l, uri, ts) ->
- F.fprintf frm "@[%u@@$%s%a@]" l (U.string_of_uri uri) pp_args ts
- | M.Appl (v, t) ->
- F.fprintf frm "@[(%a).%a@]" pp_term v pp_term t
- | M.Abst (id, w, t) ->
- F.fprintf frm "@[[%s:%a].%a@]" id pp_term w pp_term t
-
-let pp_par frm (id, w) =
- F.fprintf frm "%s:%a" id pp_term w
-
-let pp_pars = pp_rev_list pp_par "[" "," "]"
-
-let pp_body a frm = function
- | None -> ()
- | Some t -> F.fprintf frm "%a%a" pp_transparent a pp_term t
-
-let pp_entity frm = function
- | a, uri, Y.Abst (pars, u, body)
- | a, uri, Y.Abbr (pars, u, body) ->
- F.fprintf frm "@[%u@@%s%a%a:%a@]@\n%!"
- (Y.mark C.err C.start a) (U.string_of_uri uri)
- pp_pars pars (pp_body a) body pp_term u
- | _, _, Y.Void -> assert false
-
-let pp_entity f frm entity =
- pp_entity frm entity; f ()
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-type counters
-
-val initial_counters: counters
-
-val count_entity: (counters -> 'a) -> counters -> Meta.entity -> 'a
-
-val print_counters: (unit -> 'a) -> counters -> 'a
-
-val pp_entity: (unit -> 'a) -> Format.formatter -> Meta.entity -> 'a
+++ /dev/null
-(*
- ||M|| This file is part of HELM, an Hypertextual, Electronic
- ||A|| Library of Mathematics, developed at the Computer Science
- ||T|| Department, University of Bologna, Italy.
- ||I||
- ||T|| HELM is free software; you can redistribute it and/or
- ||A|| modify it under the terms of the GNU General Public License
- \ / version 2 or (at your option) any later version.
- \ / This software is distributed as is, NO WARRANTY.
- V_______________________________________________________________ *)
-
-module F = Filename
-module P = Printf
-module U = NUri
-module C = Cps
-module L = Log
-module T = Time
-module O = Options
-module H = Hierarchy
-module Op = Output
-module Y = Entity
-module X = Library
-module AL = AutLexer
-module AP = AutProcess
-module AO = AutOutput
-module DT = CrgTxt
-module DA = CrgAut
-module MA = MetaAut
-module MO = MetaOutput
-module ML = MetaLibrary
-module DX = CrgXml
-module DBrg = CrgBrg
-module MBrg = MetaBrg
-module BrgO = BrgOutput
-module BrgR = BrgReduction
-module BrgU = BrgUntrusted
-module MBag = MetaBag
-module BagO = BagOutput
-module BagT = BagType
-module BagU = BagUntrusted
-
-type status = {
- ast : AP.status;
- dst : DA.status;
- mst : MA.status;
- tst : DT.status;
- ac : AO.counters;
- mc : MO.counters;
- brgc: BrgO.counters;
- bagc: BagO.counters;
- kst : Y.status
-}
-
-let flush_all () = L.flush 0; L.flush_err ()
-
-let bag_error s msg =
- L.error BagO.specs (L.Warn s :: L.Loc :: msg); flush_all ()
-
-let brg_error s msg =
- L.error BrgR.specs (L.Warn s :: L.Loc :: msg); flush_all ()
-
-let initial_status () = {
- ac = AO.initial_counters;
- mc = MO.initial_counters;
- brgc = BrgO.initial_counters;
- bagc = BagO.initial_counters;
- mst = MA.initial_status ();
- dst = DA.initial_status ();
- tst = DT.initial_status ();
- ast = AP.initial_status ();
- kst = Y.initial_status ()
-}
-
-let refresh_status st = {st with
- mst = MA.refresh_status st.mst;
- dst = DA.refresh_status st.dst;
- tst = DT.refresh_status st.tst;
- kst = Y.refresh_status st.kst
-}
-
-(* kernel related ***********************************************************)
-
-type kernel = Brg | Bag
-
-type kernel_entity = BrgEntity of Brg.entity
- | BagEntity of Bag.entity
- | CrgEntity of Crg.entity
- | MetaEntity of Meta.entity
-
-let kernel = ref Brg
-
-let print_counters st = match !kernel with
- | Brg -> BrgO.print_counters C.start st.brgc
- | Bag -> BagO.print_counters C.start st.bagc
-
-let xlate_entity entity = match !kernel, entity with
- | Brg, CrgEntity e ->
- let f e = (BrgEntity e) in Y.xlate f DBrg.brg_of_crg e
- | Brg, MetaEntity e ->
- let f e = (BrgEntity e) in Y.xlate f MBrg.brg_of_meta e
- | Bag, MetaEntity e ->
- let f e = (BagEntity e) in Y.xlate f MBag.bag_of_meta e
- | _, entity -> entity
-
-let pp_progress e =
- let f a u =
- let s = U.string_of_uri u in
- let err () = L.warn (P.sprintf "%s" s) in
- let f i = L.warn (P.sprintf "[%u] %s" i s) in
- Y.mark err f a
- in
- match e with
- | CrgEntity e -> Y.common f e
- | BrgEntity e -> Y.common f e
- | BagEntity e -> Y.common f e
- | MetaEntity e -> Y.common f e
-
-let count_entity st = function
- | MetaEntity e -> {st with mc = MO.count_entity C.start st.mc e}
- | BrgEntity e -> {st with brgc = BrgO.count_entity C.start st.brgc e}
- | BagEntity e -> {st with bagc = BagO.count_entity C.start st.bagc e}
- | _ -> st
-
-let export_entity si xdir moch = function
- | CrgEntity e -> X.export_entity DX.export_term si xdir e
- | BrgEntity e -> X.export_entity BrgO.export_term si xdir e
- | MetaEntity e ->
- begin match moch with
- | None -> ()
- | Some och -> ML.write_entity C.start och e
- end
- | BagEntity _ -> ()
-
-let type_check st k =
- let brg_err msg = brg_error "Type Error" msg; failwith "Interrupted" in
- let ok _ _ = st in
- match k with
- | BrgEntity entity -> BrgU.type_check brg_err ok st.kst entity
- | BagEntity entity -> BagU.type_check ok st.kst entity
- | CrgEntity _
- | MetaEntity _ -> st
-
-(* extended lexer ***********************************************************)
-
-type 'token lexer = {
- parse : Lexing.lexbuf -> 'token;
- mutable tokbuf: 'token option;
- mutable unget : bool
-}
-
-let initial_lexer parse = {
- parse = parse; tokbuf = None; unget = false
-}
-
-let token xl lexbuf = match xl.tokbuf with
- | Some token when xl.unget ->
- xl.unget <- false; token
- | _ ->
- let token = xl.parse lexbuf in
- xl.tokbuf <- Some token; token
-
-(* input related ************************************************************)
-
-type input = Text | Automath
-
-type input_entity = TxtEntity of Txt.command
- | AutEntity of Aut.command
- | NoEntity
-
-let type_of_input name =
- if F.check_suffix name ".hln" then Text
- else if F.check_suffix name ".aut" then
- let _ = H.set_sorts 0 ["Set"; "Prop"] in
- assert (H.set_graph "Z2");
- Automath
- else begin
- L.warn (P.sprintf "Unknown file type: %s" name); exit 2
- end
-
-let txt_xl = initial_lexer TxtLexer.token
-
-let aut_xl = initial_lexer AutLexer.token
-
-let parbuf = ref [] (* parser buffer *)
-
-let gen_text command =
- parbuf := TxtEntity command :: !parbuf
-
-let entity_of_input lexbuf i = match i, !parbuf with
- | Automath, _ ->
- begin match AutParser.entry (token aut_xl) lexbuf with
- | Some e -> aut_xl.unget <- true; AutEntity e
- | None -> NoEntity
- end
- | Text, [] ->
- begin match TxtParser.entry (token txt_xl) lexbuf with
- | Some e -> txt_xl.unget <- true; TxtEntity e
- | None -> NoEntity
- end
- | Text, hd :: tl ->
- parbuf := tl; hd
-
-let process_input f st = function
- | AutEntity e ->
- let f ast e = f {st with ast = ast} (AutEntity e) in
- AP.process_command f st.ast e
- | xe -> f st xe
-
-let count_input st = function
- | AutEntity e -> {st with ac = AO.count_command C.start st.ac e}
- | xe -> st
-
-(****************************************************************************)
-
-let stage = ref 3
-let moch = ref None
-let meta = ref false
-let progress = ref false
-let preprocess = ref false
-let root = ref ""
-let cc = ref false
-let export = ref ""
-let old = ref false
-let st = ref (initial_status ())
-let streaming = ref false (* parsing style (temporary) *)
-
-let process_2 st entity =
- let st = if !L.level > 2 then count_entity st entity else st in
- if !export <> "" then export_entity !O.si !export !moch entity;
- if !stage > 2 then type_check st entity else st
-
-let process_1 st entity =
- if !progress then pp_progress entity;
- let st = if !L.level > 2 then count_entity st entity else st in
- if !export <> "" && !stage = 1 then export_entity !O.si !export !moch entity;
- if !stage > 1 then process_2 st (xlate_entity entity) else st
-
-let process_0 st entity =
- let f st entity =
- if !stage = 0 then st else
- match entity, !old with
- | AutEntity e, true ->
- let frr mst = {st with mst = mst} in
- let h mst e = process_1 {st with mst = mst} (MetaEntity e) in
- MA.meta_of_aut frr h st.mst e
- | AutEntity e, false ->
- let err dst = {st with dst = dst} in
- let g dst e = process_1 {st with dst = dst} (CrgEntity e) in
- DA.crg_of_aut err g st.dst e
- | TxtEntity e, _ ->
- let crr tst = {st with tst = tst} in
- let d tst e = process_1 {st with tst = tst} (CrgEntity e) in
- DT.crg_of_txt crr d gen_text st.tst e
- | NoEntity, _ -> assert false
- in
- let st = if !L.level > 2 then count_input st entity else st in
- if !preprocess then process_input f st entity else f st entity
-
-let process_nostreaming st lexbuf input =
- let rec aux1 book = match entity_of_input lexbuf input with
- | NoEntity -> List.rev book
- | e -> aux1 (e :: book)
- in
- let rec aux2 st = function
- | [] -> st
- | entity :: tl -> aux2 (process_0 st entity) tl
- in
- aux2 st (aux1 [])
-
-let rec process_streaming st lexbuf input = match entity_of_input lexbuf input with
- | NoEntity -> st
- | e -> process_streaming (process_0 st e) lexbuf input
-
-(****************************************************************************)
-
-let process st name =
- let process = if !streaming then process_streaming else process_nostreaming in
- let input = type_of_input name in
- let ich = open_in name in
- let lexbuf = Lexing.from_channel ich in
- let st = process st lexbuf input in
- close_in ich; st, input
-
-let main =
-try
- let version_string = "Helena 0.8.1 M - August 2010" in
- let print_version () = L.warn (version_string ^ "\n"); exit 0 in
- let set_hierarchy s =
- if H.set_graph s then () else
- L.warn (P.sprintf "Unknown type hierarchy: %s" s)
- in
- let set_kernel = function
- | "brg" -> kernel := Brg
- | "bag" -> kernel := Bag
- | s -> L.warn (P.sprintf "Unknown kernel version: %s" s)
- in
- let set_summary i = L.level := i in
- let set_stage i = stage := i in
- let set_meta_file name =
- let f och = moch := Some och in
- ML.open_out f name
- in
- let set_xdir s = export := s in
- let set_root s = root := s in
- let close = function
- | None -> ()
- | Some och -> ML.close_out C.start och
- in
- let clear_options () =
- stage := 3; moch := None; meta := false; progress := false;
- preprocess := false; root := ""; cc := false; export := "";
- old := false; kernel := Brg; st := initial_status ();
- L.clear (); O.clear (); H.clear (); Op.clear_reductions ();
- streaming := false;
- in
- let process_file name =
- if !L.level > 0 then T.gmtime version_string;
- if !L.level > 1 then
- L.warn (P.sprintf "Processing file: %s" name);
- if !L.level > 0 then T.utime_stamp "started";
- let base_name = Filename.chop_extension (Filename.basename name) in
- if !meta then set_meta_file base_name;
- let mk_uri =
- if !stage < 2 then Crg.mk_uri else
- match !kernel with
- | Brg -> Brg.mk_uri
- | Bag -> Bag.mk_uri
- in
- let cover = F.concat !root base_name in
- O.mk_uri := mk_uri; O.cover := cover;
- let sst, input = process (refresh_status !st) name in
- st := sst;
- if !L.level > 0 then T.utime_stamp "processed";
- if !L.level > 2 then begin
- AO.print_counters C.start !st.ac;
- if !preprocess then AO.print_process_counters C.start !st.ast;
- if !stage > 0 then MO.print_counters C.start !st.mc;
- if !stage > 1 then print_counters !st;
- if !stage > 2 then Op.print_reductions ()
- end
- in
- let exit () =
- close !moch;
- if !L.level > 0 then T.utime_stamp "at exit";
- flush_all ()
- in
- let help =
- "Usage: helena [ -LPVXcgijmopqu1 | -Ss <number> | -x <dir> | -hkr <string> ]* [ <file> ]*\n\n" ^
- "Summary levels: 0 just errors (default), 1 time stamps, 2 processed file names, \
- 3 data information, 4 typing information, 5 reduction information\n\n" ^
- "Stages: 0 parsing, 1 to intermediate, 2 to untrusted, 3 to trusted (default)\n"
- in
- let help_L = " show lexer debug information" in
- let help_P = " show parser debug information" in
- let help_S = "<number> set summary level (see above)" in
- let help_V = " show version information" in
- let help_X = " clear options" in
-
- let help_c = " output conversion constraints" in
- let help_g = " always expand global definitions" in
- let help_h = "<string> set type hierarchy (default: Z1)" in
- let help_i = " show local references by index" in
- let help_j = " show URI of processed kernel objects" in
- let help_k = "<string> set kernel version (default: brg)" in
- let help_m = " output intermediate representation (HAL)" in
- let help_o = " use old abstract language instead of crg" in
- let help_p = " preprocess source" in
- let help_q = " disable quotation of identifiers" in
- let help_r = "<string> set initial segment of URI hierarchy" in
- let help_s = "<number> set translation stage (see above)" in
- let help_u = " activate sort inclusion" in
- let help_x = "<dir> export kernel entities (XML) to <dir>" in
-
- let help_1 = " parse files with streaming policy" in
- L.box 0; L.box_err ();
- at_exit exit;
- Arg.parse [
- ("-L", Arg.Set O.debug_lexer, help_L);
- ("-P", Arg.Set O.debug_parser, help_P);
- ("-S", Arg.Int set_summary, help_S);
- ("-V", Arg.Unit print_version, help_V);
- ("-X", Arg.Unit clear_options, help_X);
- ("-c", Arg.Set cc, help_c);
- ("-g", Arg.Set O.expand, help_g);
- ("-h", Arg.String set_hierarchy, help_h);
- ("-i", Arg.Set O.indexes, help_i);
- ("-j", Arg.Set progress, help_j);
- ("-k", Arg.String set_kernel, help_k);
- ("-m", Arg.Set meta, help_m);
- ("-o", Arg.Set old, help_o);
- ("-p", Arg.Set preprocess, help_p);
- ("-q", Arg.Set O.unquote, help_q);
- ("-r", Arg.String set_root, help_r);
- ("-s", Arg.Int set_stage, help_s);
- ("-u", Arg.Set O.si, help_u);
- ("-x", Arg.String set_xdir, help_x);
- ("-1", Arg.Set streaming, help_1);
- ] process_file help;
-with BagT.TypeError msg -> bag_error "Type Error" msg
projects / helm.git / commitdiff