From: Ferruccio Guidi Date: Fri, 6 Aug 2010 11:29:40 +0000 (+0000) Subject: the refactoring continues .... X-Git-Tag: make_still_working~2849 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=ab13cfa248f0ee58d239ceeddfb50ec49a6b5c6d;p=helm.git the refactoring continues .... --- diff --git a/helm/software/lambda-delta/components/Make b/helm/software/lambda-delta/components/Make deleted file mode 100644 index 8e332c33b..000000000 --- a/helm/software/lambda-delta/components/Make +++ /dev/null @@ -1 +0,0 @@ -lib common text automath basic_ag basic_rg complete_rg toplevel diff --git a/helm/software/lambda-delta/components/automath/Make b/helm/software/lambda-delta/components/automath/Make deleted file mode 100644 index 29d237864..000000000 --- a/helm/software/lambda-delta/components/automath/Make +++ /dev/null @@ -1 +0,0 @@ -aut autProcess autOutput autParser autLexer diff --git a/helm/software/lambda-delta/components/automath/Omega.aut b/helm/software/lambda-delta/components/automath/Omega.aut deleted file mode 100644 index 2466a606e..000000000 --- a/helm/software/lambda-delta/components/automath/Omega.aut +++ /dev/null @@ -1,10 +0,0 @@ -# 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:[y:'type']'type']'type' - Omega := Delta : 'type' --l diff --git a/helm/software/lambda-delta/components/automath/aut.ml b/helm/software/lambda-delta/components/automath/aut.ml deleted file mode 100644 index 00213b4b3..000000000 --- a/helm/software/lambda-delta/components/automath/aut.ml +++ /dev/null @@ -1,25 +0,0 @@ -(* - ||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 *) diff --git a/helm/software/lambda-delta/components/automath/autLexer.mll b/helm/software/lambda-delta/components/automath/autLexer.mll deleted file mode 100644 index cb33d0c3f..000000000 --- a/helm/software/lambda-delta/components/automath/autLexer.mll +++ /dev/null @@ -1,90 +0,0 @@ -(* - ||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 } diff --git a/helm/software/lambda-delta/components/automath/autOutput.ml b/helm/software/lambda-delta/components/automath/autOutput.ml deleted file mode 100644 index d692005bd..000000000 --- a/helm/software/lambda-delta/components/automath/autOutput.ml +++ /dev/null @@ -1,100 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/automath/autOutput.mli b/helm/software/lambda-delta/components/automath/autOutput.mli deleted file mode 100644 index 1a5f56104..000000000 --- a/helm/software/lambda-delta/components/automath/autOutput.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/automath/autParser.mly b/helm/software/lambda-delta/components/automath/autParser.mly deleted file mode 100644 index e90ba3b7c..000000000 --- a/helm/software/lambda-delta/components/automath/autParser.mly +++ /dev/null @@ -1,100 +0,0 @@ -/* 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 NUM - %token 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 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 } - ; diff --git a/helm/software/lambda-delta/components/automath/autProcess.ml b/helm/software/lambda-delta/components/automath/autProcess.ml deleted file mode 100644 index 405952ff5..000000000 --- a/helm/software/lambda-delta/components/automath/autProcess.ml +++ /dev/null @@ -1,77 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/automath/autProcess.mli b/helm/software/lambda-delta/components/automath/autProcess.mli deleted file mode 100644 index 4145ff946..000000000 --- a/helm/software/lambda-delta/components/automath/autProcess.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_ag/Make b/helm/software/lambda-delta/components/basic_ag/Make deleted file mode 100644 index 1d2286b52..000000000 --- a/helm/software/lambda-delta/components/basic_ag/Make +++ /dev/null @@ -1,2 +0,0 @@ -bag bagOutput -bagEnvironment bagSubstitution bagReduction bagType bagUntrusted diff --git a/helm/software/lambda-delta/components/basic_ag/bag.ml b/helm/software/lambda-delta/components/basic_ag/bag.ml deleted file mode 100644 index 1aa9b62e7..000000000 --- a/helm/software/lambda-delta/components/basic_ag/bag.ml +++ /dev/null @@ -1,93 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_ag/bagEnvironment.ml b/helm/software/lambda-delta/components/basic_ag/bagEnvironment.ml deleted file mode 100644 index 04681cfee..000000000 --- a/helm/software/lambda-delta/components/basic_ag/bagEnvironment.ml +++ /dev/null @@ -1,39 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_ag/bagEnvironment.mli b/helm/software/lambda-delta/components/basic_ag/bagEnvironment.mli deleted file mode 100644 index 4a44c05fe..000000000 --- a/helm/software/lambda-delta/components/basic_ag/bagEnvironment.mli +++ /dev/null @@ -1,16 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_ag/bagOutput.ml b/helm/software/lambda-delta/components/basic_ag/bagOutput.ml deleted file mode 100644 index 0bfc13ee6..000000000 --- a/helm/software/lambda-delta/components/basic_ag/bagOutput.ml +++ /dev/null @@ -1,145 +0,0 @@ -(* - ||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 -} diff --git a/helm/software/lambda-delta/components/basic_ag/bagOutput.mli b/helm/software/lambda-delta/components/basic_ag/bagOutput.mli deleted file mode 100644 index daa07a6d1..000000000 --- a/helm/software/lambda-delta/components/basic_ag/bagOutput.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_ag/bagReduction.ml b/helm/software/lambda-delta/components/basic_ag/bagReduction.ml deleted file mode 100644 index b7eb88f63..000000000 --- a/helm/software/lambda-delta/components/basic_ag/bagReduction.ml +++ /dev/null @@ -1,196 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_ag/bagReduction.mli b/helm/software/lambda-delta/components/basic_ag/bagReduction.mli deleted file mode 100644 index 8f32faa0e..000000000 --- a/helm/software/lambda-delta/components/basic_ag/bagReduction.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_ag/bagSubstitution.ml b/helm/software/lambda-delta/components/basic_ag/bagSubstitution.ml deleted file mode 100644 index ad75d63b8..000000000 --- a/helm/software/lambda-delta/components/basic_ag/bagSubstitution.ml +++ /dev/null @@ -1,48 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_ag/bagSubstitution.mli b/helm/software/lambda-delta/components/basic_ag/bagSubstitution.mli deleted file mode 100644 index b48c056df..000000000 --- a/helm/software/lambda-delta/components/basic_ag/bagSubstitution.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_ag/bagType.ml b/helm/software/lambda-delta/components/basic_ag/bagType.ml deleted file mode 100644 index bb4ee83d4..000000000 --- a/helm/software/lambda-delta/components/basic_ag/bagType.ml +++ /dev/null @@ -1,127 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_ag/bagType.mli b/helm/software/lambda-delta/components/basic_ag/bagType.mli deleted file mode 100644 index 31a421bda..000000000 --- a/helm/software/lambda-delta/components/basic_ag/bagType.mli +++ /dev/null @@ -1,16 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_ag/bagUntrusted.ml b/helm/software/lambda-delta/components/basic_ag/bagUntrusted.ml deleted file mode 100644 index 33d6a5fbd..000000000 --- a/helm/software/lambda-delta/components/basic_ag/bagUntrusted.ml +++ /dev/null @@ -1,29 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_ag/bagUntrusted.mli b/helm/software/lambda-delta/components/basic_ag/bagUntrusted.mli deleted file mode 100644 index af967408e..000000000 --- a/helm/software/lambda-delta/components/basic_ag/bagUntrusted.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_rg/Make b/helm/software/lambda-delta/components/basic_rg/Make deleted file mode 100644 index ee53ca212..000000000 --- a/helm/software/lambda-delta/components/basic_rg/Make +++ /dev/null @@ -1,2 +0,0 @@ -brg brgOutput -brgEnvironment brgSubstitution brgReduction brgType brgUntrusted diff --git a/helm/software/lambda-delta/components/basic_rg/brg.ml b/helm/software/lambda-delta/components/basic_rg/brg.ml deleted file mode 100644 index efc5d7556..000000000 --- a/helm/software/lambda-delta/components/basic_rg/brg.ml +++ /dev/null @@ -1,83 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_rg/brgEnvironment.ml b/helm/software/lambda-delta/components/basic_rg/brgEnvironment.ml deleted file mode 100644 index 121da88da..000000000 --- a/helm/software/lambda-delta/components/basic_rg/brgEnvironment.ml +++ /dev/null @@ -1,35 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_rg/brgEnvironment.mli b/helm/software/lambda-delta/components/basic_rg/brgEnvironment.mli deleted file mode 100644 index 1f51f1e61..000000000 --- a/helm/software/lambda-delta/components/basic_rg/brgEnvironment.mli +++ /dev/null @@ -1,14 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_rg/brgOutput.ml b/helm/software/lambda-delta/components/basic_rg/brgOutput.ml deleted file mode 100644 index 186349a1c..000000000 --- a/helm/software/lambda-delta/components/basic_rg/brgOutput.ml +++ /dev/null @@ -1,258 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_rg/brgOutput.mli b/helm/software/lambda-delta/components/basic_rg/brgOutput.mli deleted file mode 100644 index 772f43cad..000000000 --- a/helm/software/lambda-delta/components/basic_rg/brgOutput.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* - ||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 -*) diff --git a/helm/software/lambda-delta/components/basic_rg/brgReduction.ml b/helm/software/lambda-delta/components/basic_rg/brgReduction.ml deleted file mode 100644 index 03ed05b05..000000000 --- a/helm/software/lambda-delta/components/basic_rg/brgReduction.ml +++ /dev/null @@ -1,210 +0,0 @@ -(* - ||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 -} diff --git a/helm/software/lambda-delta/components/basic_rg/brgReduction.mli b/helm/software/lambda-delta/components/basic_rg/brgReduction.mli deleted file mode 100644 index eebb15725..000000000 --- a/helm/software/lambda-delta/components/basic_rg/brgReduction.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_rg/brgSubstitution.ml b/helm/software/lambda-delta/components/basic_rg/brgSubstitution.ml deleted file mode 100644 index 5c9d91a8b..000000000 --- a/helm/software/lambda-delta/components/basic_rg/brgSubstitution.ml +++ /dev/null @@ -1,46 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_rg/brgSubstitution.mli b/helm/software/lambda-delta/components/basic_rg/brgSubstitution.mli deleted file mode 100644 index a1717666f..000000000 --- a/helm/software/lambda-delta/components/basic_rg/brgSubstitution.mli +++ /dev/null @@ -1,15 +0,0 @@ -(* - ||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 -*) diff --git a/helm/software/lambda-delta/components/basic_rg/brgType.ml b/helm/software/lambda-delta/components/basic_rg/brgType.ml deleted file mode 100644 index 8b119e5e2..000000000 --- a/helm/software/lambda-delta/components/basic_rg/brgType.ml +++ /dev/null @@ -1,131 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_rg/brgType.mli b/helm/software/lambda-delta/components/basic_rg/brgType.mli deleted file mode 100644 index 5d9350b49..000000000 --- a/helm/software/lambda-delta/components/basic_rg/brgType.mli +++ /dev/null @@ -1,16 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_rg/brgUntrusted.ml b/helm/software/lambda-delta/components/basic_rg/brgUntrusted.ml deleted file mode 100644 index 4c1ae61db..000000000 --- a/helm/software/lambda-delta/components/basic_rg/brgUntrusted.ml +++ /dev/null @@ -1,38 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/basic_rg/brgUntrusted.mli b/helm/software/lambda-delta/components/basic_rg/brgUntrusted.mli deleted file mode 100644 index d395eb535..000000000 --- a/helm/software/lambda-delta/components/basic_rg/brgUntrusted.mli +++ /dev/null @@ -1,14 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/common/Make b/helm/software/lambda-delta/components/common/Make deleted file mode 100644 index de13dd4c9..000000000 --- a/helm/software/lambda-delta/components/common/Make +++ /dev/null @@ -1 +0,0 @@ -options hierarchy output entity marks alpha library diff --git a/helm/software/lambda-delta/components/common/alpha.ml b/helm/software/lambda-delta/components/common/alpha.ml deleted file mode 100644 index 01c2aafe8..000000000 --- a/helm/software/lambda-delta/components/common/alpha.ml +++ /dev/null @@ -1,39 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/common/alpha.mli b/helm/software/lambda-delta/components/common/alpha.mli deleted file mode 100644 index a08e98e59..000000000 --- a/helm/software/lambda-delta/components/common/alpha.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/common/entity.ml b/helm/software/lambda-delta/components/common/entity.ml deleted file mode 100644 index e32b347a8..000000000 --- a/helm/software/lambda-delta/components/common/entity.ml +++ /dev/null @@ -1,127 +0,0 @@ -(* - ||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 -} - diff --git a/helm/software/lambda-delta/components/common/hierarchy.ml b/helm/software/lambda-delta/components/common/hierarchy.ml deleted file mode 100644 index b7d428353..000000000 --- a/helm/software/lambda-delta/components/common/hierarchy.ml +++ /dev/null @@ -1,64 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/common/hierarchy.mli b/helm/software/lambda-delta/components/common/hierarchy.mli deleted file mode 100644 index 04feaf929..000000000 --- a/helm/software/lambda-delta/components/common/hierarchy.mli +++ /dev/null @@ -1,24 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/common/library.ml b/helm/software/lambda-delta/components/common/library.ml deleted file mode 100644 index 8a6801159..000000000 --- a/helm/software/lambda-delta/components/common/library.ml +++ /dev/null @@ -1,132 +0,0 @@ -(* - ||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 "\n\n" - -let doctype out root 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 "\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 diff --git a/helm/software/lambda-delta/components/common/library.mli b/helm/software/lambda-delta/components/common/library.mli deleted file mode 100644 index ed3f7bb8f..000000000 --- a/helm/software/lambda-delta/components/common/library.mli +++ /dev/null @@ -1,53 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/common/marks.ml b/helm/software/lambda-delta/components/common/marks.ml deleted file mode 100644 index 026414e2a..000000000 --- a/helm/software/lambda-delta/components/common/marks.ml +++ /dev/null @@ -1,21 +0,0 @@ -(* - ||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 ()) diff --git a/helm/software/lambda-delta/components/common/options.ml b/helm/software/lambda-delta/components/common/options.ml deleted file mode 100644 index d9783c766..000000000 --- a/helm/software/lambda-delta/components/common/options.ml +++ /dev/null @@ -1,42 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/common/output.ml b/helm/software/lambda-delta/components/common/output.ml deleted file mode 100644 index 8270c5d97..000000000 --- a/helm/software/lambda-delta/components/common/output.ml +++ /dev/null @@ -1,72 +0,0 @@ -(* - ||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) diff --git a/helm/software/lambda-delta/components/common/output.mli b/helm/software/lambda-delta/components/common/output.mli deleted file mode 100644 index 20b83f0fc..000000000 --- a/helm/software/lambda-delta/components/common/output.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/complete_rg/Make b/helm/software/lambda-delta/components/complete_rg/Make deleted file mode 100644 index d7a45f9d2..000000000 --- a/helm/software/lambda-delta/components/complete_rg/Make +++ /dev/null @@ -1 +0,0 @@ -crg crgOutput crgXml crgTxt crgAut crgBrg diff --git a/helm/software/lambda-delta/components/complete_rg/crg.ml b/helm/software/lambda-delta/components/complete_rg/crg.ml deleted file mode 100644 index 07a4cb3ee..000000000 --- a/helm/software/lambda-delta/components/complete_rg/crg.ml +++ /dev/null @@ -1,94 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/complete_rg/crgAut.ml b/helm/software/lambda-delta/components/complete_rg/crgAut.ml deleted file mode 100644 index 0b95adf41..000000000 --- a/helm/software/lambda-delta/components/complete_rg/crgAut.ml +++ /dev/null @@ -1,224 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/complete_rg/crgAut.mli b/helm/software/lambda-delta/components/complete_rg/crgAut.mli deleted file mode 100644 index c7d93d3ce..000000000 --- a/helm/software/lambda-delta/components/complete_rg/crgAut.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/complete_rg/crgBrg.ml b/helm/software/lambda-delta/components/complete_rg/crgBrg.ml deleted file mode 100644 index 2b3129339..000000000 --- a/helm/software/lambda-delta/components/complete_rg/crgBrg.ml +++ /dev/null @@ -1,101 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/complete_rg/crgBrg.mli b/helm/software/lambda-delta/components/complete_rg/crgBrg.mli deleted file mode 100644 index 84c7f2368..000000000 --- a/helm/software/lambda-delta/components/complete_rg/crgBrg.mli +++ /dev/null @@ -1,14 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/complete_rg/crgOutput.ml b/helm/software/lambda-delta/components/complete_rg/crgOutput.ml deleted file mode 100644 index 6da54cbc3..000000000 --- a/helm/software/lambda-delta/components/complete_rg/crgOutput.ml +++ /dev/null @@ -1,59 +0,0 @@ -(* - ||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 - -(****************************************************************************) diff --git a/helm/software/lambda-delta/components/complete_rg/crgOutput.mli b/helm/software/lambda-delta/components/complete_rg/crgOutput.mli deleted file mode 100644 index d804937f8..000000000 --- a/helm/software/lambda-delta/components/complete_rg/crgOutput.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/complete_rg/crgTxt.ml b/helm/software/lambda-delta/components/complete_rg/crgTxt.ml deleted file mode 100644 index 34727aff9..000000000 --- a/helm/software/lambda-delta/components/complete_rg/crgTxt.ml +++ /dev/null @@ -1,160 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/complete_rg/crgTxt.mli b/helm/software/lambda-delta/components/complete_rg/crgTxt.mli deleted file mode 100644 index 150268a55..000000000 --- a/helm/software/lambda-delta/components/complete_rg/crgTxt.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/complete_rg/crgXml.ml b/helm/software/lambda-delta/components/complete_rg/crgXml.ml deleted file mode 100644 index 111cfed06..000000000 --- a/helm/software/lambda-delta/components/complete_rg/crgXml.ml +++ /dev/null @@ -1,114 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/complete_rg/crgXml.mli b/helm/software/lambda-delta/components/complete_rg/crgXml.mli deleted file mode 100644 index c326a9822..000000000 --- a/helm/software/lambda-delta/components/complete_rg/crgXml.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/lib/Make b/helm/software/lambda-delta/components/lib/Make deleted file mode 100644 index 45d5eac3b..000000000 --- a/helm/software/lambda-delta/components/lib/Make +++ /dev/null @@ -1 +0,0 @@ -cps share log time diff --git a/helm/software/lambda-delta/components/lib/cps.ml b/helm/software/lambda-delta/components/lib/cps.ml deleted file mode 100644 index 10ec62376..000000000 --- a/helm/software/lambda-delta/components/lib/cps.ml +++ /dev/null @@ -1,83 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/lib/log.ml b/helm/software/lambda-delta/components/lib/log.ml deleted file mode 100644 index 03e7b5b95..000000000 --- a/helm/software/lambda-delta/components/lib/log.ml +++ /dev/null @@ -1,95 +0,0 @@ -(* - ||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 "@,@[%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 "@[" - -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 diff --git a/helm/software/lambda-delta/components/lib/log.mli b/helm/software/lambda-delta/components/lib/log.mli deleted file mode 100644 index 9e0f054e1..000000000 --- a/helm/software/lambda-delta/components/lib/log.mli +++ /dev/null @@ -1,63 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/lib/share.ml b/helm/software/lambda-delta/components/lib/share.ml deleted file mode 100644 index 600ae9d85..000000000 --- a/helm/software/lambda-delta/components/lib/share.ml +++ /dev/null @@ -1,21 +0,0 @@ -(* - ||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) diff --git a/helm/software/lambda-delta/components/lib/time.ml b/helm/software/lambda-delta/components/lib/time.ml deleted file mode 100644 index 42d7d39a7..000000000 --- a/helm/software/lambda-delta/components/lib/time.ml +++ /dev/null @@ -1,34 +0,0 @@ -(* - ||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 - ) diff --git a/helm/software/lambda-delta/components/text/Make b/helm/software/lambda-delta/components/text/Make deleted file mode 100644 index f1c0ffe26..000000000 --- a/helm/software/lambda-delta/components/text/Make +++ /dev/null @@ -1 +0,0 @@ -txt txtParser txtLexer txtTxt diff --git a/helm/software/lambda-delta/components/text/prova.hln b/helm/software/lambda-delta/components/text/prova.hln deleted file mode 100644 index a782fda1c..000000000 --- a/helm/software/lambda-delta/components/text/prova.hln +++ /dev/null @@ -1,11 +0,0 @@ -\open pippo - -\global a : *Set - -\global b : *Prop - -\global f = [x:*Set].[y:*Prop].x - -\global "commento\"" c = f(a,b) : *Set - -\close diff --git a/helm/software/lambda-delta/components/text/txt.ml b/helm/software/lambda-delta/components/text/txt.ml deleted file mode 100644 index dbcc0675c..000000000 --- a/helm/software/lambda-delta/components/text/txt.ml +++ /dev/null @@ -1,43 +0,0 @@ -(* - ||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 *) - diff --git a/helm/software/lambda-delta/components/text/txtLexer.mll b/helm/software/lambda-delta/components/text/txtLexer.mll deleted file mode 100644 index dc293bdcf..000000000 --- a/helm/software/lambda-delta/components/text/txtLexer.mll +++ /dev/null @@ -1,72 +0,0 @@ -(* - ||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 } diff --git a/helm/software/lambda-delta/components/text/txtParser.mly b/helm/software/lambda-delta/components/text/txtParser.mly deleted file mode 100644 index 694e30891..000000000 --- a/helm/software/lambda-delta/components/text/txtParser.mly +++ /dev/null @@ -1,153 +0,0 @@ -/* 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 IX - %token 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 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 } - ; diff --git a/helm/software/lambda-delta/components/text/txtTxt.ml b/helm/software/lambda-delta/components/text/txtTxt.ml deleted file mode 100644 index 1d501fe0d..000000000 --- a/helm/software/lambda-delta/components/text/txtTxt.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/text/txtTxt.mli b/helm/software/lambda-delta/components/text/txtTxt.mli deleted file mode 100644 index 357487625..000000000 --- a/helm/software/lambda-delta/components/text/txtTxt.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/toplevel/Make b/helm/software/lambda-delta/components/toplevel/Make deleted file mode 100644 index a8a72e17f..000000000 --- a/helm/software/lambda-delta/components/toplevel/Make +++ /dev/null @@ -1 +0,0 @@ -meta metaOutput metaLibrary metaAut metaBag metaBrg top diff --git a/helm/software/lambda-delta/components/toplevel/meta.ml b/helm/software/lambda-delta/components/toplevel/meta.ml deleted file mode 100644 index 553977251..000000000 --- a/helm/software/lambda-delta/components/toplevel/meta.ml +++ /dev/null @@ -1,25 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/toplevel/metaAut.ml b/helm/software/lambda-delta/components/toplevel/metaAut.ml deleted file mode 100644 index dd6c4a6f6..000000000 --- a/helm/software/lambda-delta/components/toplevel/metaAut.ml +++ /dev/null @@ -1,218 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/toplevel/metaAut.mli b/helm/software/lambda-delta/components/toplevel/metaAut.mli deleted file mode 100644 index a1210c527..000000000 --- a/helm/software/lambda-delta/components/toplevel/metaAut.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/toplevel/metaBag.ml b/helm/software/lambda-delta/components/toplevel/metaBag.ml deleted file mode 100644 index 991d7e8c2..000000000 --- a/helm/software/lambda-delta/components/toplevel/metaBag.ml +++ /dev/null @@ -1,67 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/toplevel/metaBag.mli b/helm/software/lambda-delta/components/toplevel/metaBag.mli deleted file mode 100644 index 62ce68f4e..000000000 --- a/helm/software/lambda-delta/components/toplevel/metaBag.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/toplevel/metaBrg.ml b/helm/software/lambda-delta/components/toplevel/metaBrg.ml deleted file mode 100644 index cde4daa13..000000000 --- a/helm/software/lambda-delta/components/toplevel/metaBrg.ml +++ /dev/null @@ -1,66 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/toplevel/metaBrg.mli b/helm/software/lambda-delta/components/toplevel/metaBrg.mli deleted file mode 100644 index 4ce275fb8..000000000 --- a/helm/software/lambda-delta/components/toplevel/metaBrg.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/toplevel/metaLibrary.ml b/helm/software/lambda-delta/components/toplevel/metaLibrary.ml deleted file mode 100644 index 3ae116d96..000000000 --- a/helm/software/lambda-delta/components/toplevel/metaLibrary.ml +++ /dev/null @@ -1,36 +0,0 @@ -(* - ||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 () diff --git a/helm/software/lambda-delta/components/toplevel/metaLibrary.mli b/helm/software/lambda-delta/components/toplevel/metaLibrary.mli deleted file mode 100644 index 2f6e41b80..000000000 --- a/helm/software/lambda-delta/components/toplevel/metaLibrary.mli +++ /dev/null @@ -1,18 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/toplevel/metaOutput.ml b/helm/software/lambda-delta/components/toplevel/metaOutput.ml deleted file mode 100644 index 21d735d0e..000000000 --- a/helm/software/lambda-delta/components/toplevel/metaOutput.ml +++ /dev/null @@ -1,162 +0,0 @@ -(* - ||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 () diff --git a/helm/software/lambda-delta/components/toplevel/metaOutput.mli b/helm/software/lambda-delta/components/toplevel/metaOutput.mli deleted file mode 100644 index 1a7b119ce..000000000 --- a/helm/software/lambda-delta/components/toplevel/metaOutput.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* - ||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 diff --git a/helm/software/lambda-delta/components/toplevel/top.ml b/helm/software/lambda-delta/components/toplevel/top.ml deleted file mode 100644 index 40fcda5e1..000000000 --- a/helm/software/lambda-delta/components/toplevel/top.ml +++ /dev/null @@ -1,399 +0,0 @@ -(* - ||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 | -x | -hkr ]* [ ]*\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 = " 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 = " 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 = " 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 = " set initial segment of URI hierarchy" in - let help_s = " set translation stage (see above)" in - let help_u = " activate sort inclusion" in - let help_x = " export kernel entities (XML) to " 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 diff --git a/helm/software/lambda-delta/src/Make b/helm/software/lambda-delta/src/Make new file mode 100644 index 000000000..8e332c33b --- /dev/null +++ b/helm/software/lambda-delta/src/Make @@ -0,0 +1 @@ +lib common text automath basic_ag basic_rg complete_rg toplevel diff --git a/helm/software/lambda-delta/src/automath/Make b/helm/software/lambda-delta/src/automath/Make new file mode 100644 index 000000000..29d237864 --- /dev/null +++ b/helm/software/lambda-delta/src/automath/Make @@ -0,0 +1 @@ +aut autProcess autOutput autParser autLexer diff --git a/helm/software/lambda-delta/src/automath/Omega.aut b/helm/software/lambda-delta/src/automath/Omega.aut new file mode 100644 index 000000000..2466a606e --- /dev/null +++ b/helm/software/lambda-delta/src/automath/Omega.aut @@ -0,0 +1,10 @@ +# 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:[y:'type']'type']'type' + Omega := Delta : 'type' +-l diff --git a/helm/software/lambda-delta/src/automath/aut.ml b/helm/software/lambda-delta/src/automath/aut.ml new file mode 100644 index 000000000..00213b4b3 --- /dev/null +++ b/helm/software/lambda-delta/src/automath/aut.ml @@ -0,0 +1,25 @@ +(* + ||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 *) diff --git a/helm/software/lambda-delta/src/automath/autLexer.mll b/helm/software/lambda-delta/src/automath/autLexer.mll new file mode 100644 index 000000000..cb33d0c3f --- /dev/null +++ b/helm/software/lambda-delta/src/automath/autLexer.mll @@ -0,0 +1,90 @@ +(* + ||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 } diff --git a/helm/software/lambda-delta/src/automath/autOutput.ml b/helm/software/lambda-delta/src/automath/autOutput.ml new file mode 100644 index 000000000..d692005bd --- /dev/null +++ b/helm/software/lambda-delta/src/automath/autOutput.ml @@ -0,0 +1,100 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/automath/autOutput.mli b/helm/software/lambda-delta/src/automath/autOutput.mli new file mode 100644 index 000000000..1a5f56104 --- /dev/null +++ b/helm/software/lambda-delta/src/automath/autOutput.mli @@ -0,0 +1,20 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/automath/autParser.mly b/helm/software/lambda-delta/src/automath/autParser.mly new file mode 100644 index 000000000..e90ba3b7c --- /dev/null +++ b/helm/software/lambda-delta/src/automath/autParser.mly @@ -0,0 +1,100 @@ +/* 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 NUM + %token 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 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 } + ; diff --git a/helm/software/lambda-delta/src/automath/autProcess.ml b/helm/software/lambda-delta/src/automath/autProcess.ml new file mode 100644 index 000000000..405952ff5 --- /dev/null +++ b/helm/software/lambda-delta/src/automath/autProcess.ml @@ -0,0 +1,77 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/automath/autProcess.mli b/helm/software/lambda-delta/src/automath/autProcess.mli new file mode 100644 index 000000000..4145ff946 --- /dev/null +++ b/helm/software/lambda-delta/src/automath/autProcess.mli @@ -0,0 +1,19 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_ag/Make b/helm/software/lambda-delta/src/basic_ag/Make new file mode 100644 index 000000000..1d2286b52 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_ag/Make @@ -0,0 +1,2 @@ +bag bagOutput +bagEnvironment bagSubstitution bagReduction bagType bagUntrusted diff --git a/helm/software/lambda-delta/src/basic_ag/bag.ml b/helm/software/lambda-delta/src/basic_ag/bag.ml new file mode 100644 index 000000000..1aa9b62e7 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_ag/bag.ml @@ -0,0 +1,93 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_ag/bagEnvironment.ml b/helm/software/lambda-delta/src/basic_ag/bagEnvironment.ml new file mode 100644 index 000000000..04681cfee --- /dev/null +++ b/helm/software/lambda-delta/src/basic_ag/bagEnvironment.ml @@ -0,0 +1,39 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_ag/bagEnvironment.mli b/helm/software/lambda-delta/src/basic_ag/bagEnvironment.mli new file mode 100644 index 000000000..4a44c05fe --- /dev/null +++ b/helm/software/lambda-delta/src/basic_ag/bagEnvironment.mli @@ -0,0 +1,16 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_ag/bagOutput.ml b/helm/software/lambda-delta/src/basic_ag/bagOutput.ml new file mode 100644 index 000000000..0bfc13ee6 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_ag/bagOutput.ml @@ -0,0 +1,145 @@ +(* + ||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 +} diff --git a/helm/software/lambda-delta/src/basic_ag/bagOutput.mli b/helm/software/lambda-delta/src/basic_ag/bagOutput.mli new file mode 100644 index 000000000..daa07a6d1 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_ag/bagOutput.mli @@ -0,0 +1,20 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_ag/bagReduction.ml b/helm/software/lambda-delta/src/basic_ag/bagReduction.ml new file mode 100644 index 000000000..b7eb88f63 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_ag/bagReduction.ml @@ -0,0 +1,196 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_ag/bagReduction.mli b/helm/software/lambda-delta/src/basic_ag/bagReduction.mli new file mode 100644 index 000000000..8f32faa0e --- /dev/null +++ b/helm/software/lambda-delta/src/basic_ag/bagReduction.mli @@ -0,0 +1,20 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_ag/bagSubstitution.ml b/helm/software/lambda-delta/src/basic_ag/bagSubstitution.ml new file mode 100644 index 000000000..ad75d63b8 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_ag/bagSubstitution.ml @@ -0,0 +1,48 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_ag/bagSubstitution.mli b/helm/software/lambda-delta/src/basic_ag/bagSubstitution.mli new file mode 100644 index 000000000..b48c056df --- /dev/null +++ b/helm/software/lambda-delta/src/basic_ag/bagSubstitution.mli @@ -0,0 +1,12 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_ag/bagType.ml b/helm/software/lambda-delta/src/basic_ag/bagType.ml new file mode 100644 index 000000000..bb4ee83d4 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_ag/bagType.ml @@ -0,0 +1,127 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_ag/bagType.mli b/helm/software/lambda-delta/src/basic_ag/bagType.mli new file mode 100644 index 000000000..31a421bda --- /dev/null +++ b/helm/software/lambda-delta/src/basic_ag/bagType.mli @@ -0,0 +1,16 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_ag/bagUntrusted.ml b/helm/software/lambda-delta/src/basic_ag/bagUntrusted.ml new file mode 100644 index 000000000..33d6a5fbd --- /dev/null +++ b/helm/software/lambda-delta/src/basic_ag/bagUntrusted.ml @@ -0,0 +1,29 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_ag/bagUntrusted.mli b/helm/software/lambda-delta/src/basic_ag/bagUntrusted.mli new file mode 100644 index 000000000..af967408e --- /dev/null +++ b/helm/software/lambda-delta/src/basic_ag/bagUntrusted.mli @@ -0,0 +1,13 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_rg/Make b/helm/software/lambda-delta/src/basic_rg/Make new file mode 100644 index 000000000..ee53ca212 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_rg/Make @@ -0,0 +1,2 @@ +brg brgOutput +brgEnvironment brgSubstitution brgReduction brgType brgUntrusted diff --git a/helm/software/lambda-delta/src/basic_rg/brg.ml b/helm/software/lambda-delta/src/basic_rg/brg.ml new file mode 100644 index 000000000..efc5d7556 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_rg/brg.ml @@ -0,0 +1,83 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_rg/brgEnvironment.ml b/helm/software/lambda-delta/src/basic_rg/brgEnvironment.ml new file mode 100644 index 000000000..121da88da --- /dev/null +++ b/helm/software/lambda-delta/src/basic_rg/brgEnvironment.ml @@ -0,0 +1,35 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_rg/brgEnvironment.mli b/helm/software/lambda-delta/src/basic_rg/brgEnvironment.mli new file mode 100644 index 000000000..1f51f1e61 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_rg/brgEnvironment.mli @@ -0,0 +1,14 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_rg/brgOutput.ml b/helm/software/lambda-delta/src/basic_rg/brgOutput.ml new file mode 100644 index 000000000..186349a1c --- /dev/null +++ b/helm/software/lambda-delta/src/basic_rg/brgOutput.ml @@ -0,0 +1,258 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_rg/brgOutput.mli b/helm/software/lambda-delta/src/basic_rg/brgOutput.mli new file mode 100644 index 000000000..772f43cad --- /dev/null +++ b/helm/software/lambda-delta/src/basic_rg/brgOutput.mli @@ -0,0 +1,25 @@ +(* + ||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 +*) diff --git a/helm/software/lambda-delta/src/basic_rg/brgReduction.ml b/helm/software/lambda-delta/src/basic_rg/brgReduction.ml new file mode 100644 index 000000000..03ed05b05 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_rg/brgReduction.ml @@ -0,0 +1,210 @@ +(* + ||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 +} diff --git a/helm/software/lambda-delta/src/basic_rg/brgReduction.mli b/helm/software/lambda-delta/src/basic_rg/brgReduction.mli new file mode 100644 index 000000000..eebb15725 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_rg/brgReduction.mli @@ -0,0 +1,26 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_rg/brgSubstitution.ml b/helm/software/lambda-delta/src/basic_rg/brgSubstitution.ml new file mode 100644 index 000000000..5c9d91a8b --- /dev/null +++ b/helm/software/lambda-delta/src/basic_rg/brgSubstitution.ml @@ -0,0 +1,46 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_rg/brgSubstitution.mli b/helm/software/lambda-delta/src/basic_rg/brgSubstitution.mli new file mode 100644 index 000000000..a1717666f --- /dev/null +++ b/helm/software/lambda-delta/src/basic_rg/brgSubstitution.mli @@ -0,0 +1,15 @@ +(* + ||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 +*) diff --git a/helm/software/lambda-delta/src/basic_rg/brgType.ml b/helm/software/lambda-delta/src/basic_rg/brgType.ml new file mode 100644 index 000000000..8b119e5e2 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_rg/brgType.ml @@ -0,0 +1,131 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_rg/brgType.mli b/helm/software/lambda-delta/src/basic_rg/brgType.mli new file mode 100644 index 000000000..5d9350b49 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_rg/brgType.mli @@ -0,0 +1,16 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_rg/brgUntrusted.ml b/helm/software/lambda-delta/src/basic_rg/brgUntrusted.ml new file mode 100644 index 000000000..4c1ae61db --- /dev/null +++ b/helm/software/lambda-delta/src/basic_rg/brgUntrusted.ml @@ -0,0 +1,38 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/basic_rg/brgUntrusted.mli b/helm/software/lambda-delta/src/basic_rg/brgUntrusted.mli new file mode 100644 index 000000000..d395eb535 --- /dev/null +++ b/helm/software/lambda-delta/src/basic_rg/brgUntrusted.mli @@ -0,0 +1,14 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/common/Make b/helm/software/lambda-delta/src/common/Make new file mode 100644 index 000000000..de13dd4c9 --- /dev/null +++ b/helm/software/lambda-delta/src/common/Make @@ -0,0 +1 @@ +options hierarchy output entity marks alpha library diff --git a/helm/software/lambda-delta/src/common/alpha.ml b/helm/software/lambda-delta/src/common/alpha.ml new file mode 100644 index 000000000..01c2aafe8 --- /dev/null +++ b/helm/software/lambda-delta/src/common/alpha.ml @@ -0,0 +1,39 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/common/alpha.mli b/helm/software/lambda-delta/src/common/alpha.mli new file mode 100644 index 000000000..a08e98e59 --- /dev/null +++ b/helm/software/lambda-delta/src/common/alpha.mli @@ -0,0 +1,12 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/common/entity.ml b/helm/software/lambda-delta/src/common/entity.ml new file mode 100644 index 000000000..e32b347a8 --- /dev/null +++ b/helm/software/lambda-delta/src/common/entity.ml @@ -0,0 +1,127 @@ +(* + ||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 +} + diff --git a/helm/software/lambda-delta/src/common/hierarchy.ml b/helm/software/lambda-delta/src/common/hierarchy.ml new file mode 100644 index 000000000..b7d428353 --- /dev/null +++ b/helm/software/lambda-delta/src/common/hierarchy.ml @@ -0,0 +1,64 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/common/hierarchy.mli b/helm/software/lambda-delta/src/common/hierarchy.mli new file mode 100644 index 000000000..04feaf929 --- /dev/null +++ b/helm/software/lambda-delta/src/common/hierarchy.mli @@ -0,0 +1,24 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/common/library.ml b/helm/software/lambda-delta/src/common/library.ml new file mode 100644 index 000000000..8a6801159 --- /dev/null +++ b/helm/software/lambda-delta/src/common/library.ml @@ -0,0 +1,132 @@ +(* + ||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 "\n\n" + +let doctype out root 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 "\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 diff --git a/helm/software/lambda-delta/src/common/library.mli b/helm/software/lambda-delta/src/common/library.mli new file mode 100644 index 000000000..ed3f7bb8f --- /dev/null +++ b/helm/software/lambda-delta/src/common/library.mli @@ -0,0 +1,53 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/common/marks.ml b/helm/software/lambda-delta/src/common/marks.ml new file mode 100644 index 000000000..026414e2a --- /dev/null +++ b/helm/software/lambda-delta/src/common/marks.ml @@ -0,0 +1,21 @@ +(* + ||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 ()) diff --git a/helm/software/lambda-delta/src/common/options.ml b/helm/software/lambda-delta/src/common/options.ml new file mode 100644 index 000000000..d9783c766 --- /dev/null +++ b/helm/software/lambda-delta/src/common/options.ml @@ -0,0 +1,42 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/common/output.ml b/helm/software/lambda-delta/src/common/output.ml new file mode 100644 index 000000000..8270c5d97 --- /dev/null +++ b/helm/software/lambda-delta/src/common/output.ml @@ -0,0 +1,72 @@ +(* + ||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) diff --git a/helm/software/lambda-delta/src/common/output.mli b/helm/software/lambda-delta/src/common/output.mli new file mode 100644 index 000000000..20b83f0fc --- /dev/null +++ b/helm/software/lambda-delta/src/common/output.mli @@ -0,0 +1,19 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/complete_rg/Make b/helm/software/lambda-delta/src/complete_rg/Make new file mode 100644 index 000000000..d7a45f9d2 --- /dev/null +++ b/helm/software/lambda-delta/src/complete_rg/Make @@ -0,0 +1 @@ +crg crgOutput crgXml crgTxt crgAut crgBrg diff --git a/helm/software/lambda-delta/src/complete_rg/crg.ml b/helm/software/lambda-delta/src/complete_rg/crg.ml new file mode 100644 index 000000000..07a4cb3ee --- /dev/null +++ b/helm/software/lambda-delta/src/complete_rg/crg.ml @@ -0,0 +1,94 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/complete_rg/crgAut.ml b/helm/software/lambda-delta/src/complete_rg/crgAut.ml new file mode 100644 index 000000000..0b95adf41 --- /dev/null +++ b/helm/software/lambda-delta/src/complete_rg/crgAut.ml @@ -0,0 +1,224 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/complete_rg/crgAut.mli b/helm/software/lambda-delta/src/complete_rg/crgAut.mli new file mode 100644 index 000000000..c7d93d3ce --- /dev/null +++ b/helm/software/lambda-delta/src/complete_rg/crgAut.mli @@ -0,0 +1,19 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/complete_rg/crgBrg.ml b/helm/software/lambda-delta/src/complete_rg/crgBrg.ml new file mode 100644 index 000000000..2b3129339 --- /dev/null +++ b/helm/software/lambda-delta/src/complete_rg/crgBrg.ml @@ -0,0 +1,101 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/complete_rg/crgBrg.mli b/helm/software/lambda-delta/src/complete_rg/crgBrg.mli new file mode 100644 index 000000000..84c7f2368 --- /dev/null +++ b/helm/software/lambda-delta/src/complete_rg/crgBrg.mli @@ -0,0 +1,14 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/complete_rg/crgOutput.ml b/helm/software/lambda-delta/src/complete_rg/crgOutput.ml new file mode 100644 index 000000000..6da54cbc3 --- /dev/null +++ b/helm/software/lambda-delta/src/complete_rg/crgOutput.ml @@ -0,0 +1,59 @@ +(* + ||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 + +(****************************************************************************) diff --git a/helm/software/lambda-delta/src/complete_rg/crgOutput.mli b/helm/software/lambda-delta/src/complete_rg/crgOutput.mli new file mode 100644 index 000000000..d804937f8 --- /dev/null +++ b/helm/software/lambda-delta/src/complete_rg/crgOutput.mli @@ -0,0 +1,12 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/complete_rg/crgTxt.ml b/helm/software/lambda-delta/src/complete_rg/crgTxt.ml new file mode 100644 index 000000000..34727aff9 --- /dev/null +++ b/helm/software/lambda-delta/src/complete_rg/crgTxt.ml @@ -0,0 +1,160 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/complete_rg/crgTxt.mli b/helm/software/lambda-delta/src/complete_rg/crgTxt.mli new file mode 100644 index 000000000..150268a55 --- /dev/null +++ b/helm/software/lambda-delta/src/complete_rg/crgTxt.mli @@ -0,0 +1,19 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/complete_rg/crgXml.ml b/helm/software/lambda-delta/src/complete_rg/crgXml.ml new file mode 100644 index 000000000..111cfed06 --- /dev/null +++ b/helm/software/lambda-delta/src/complete_rg/crgXml.ml @@ -0,0 +1,114 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/complete_rg/crgXml.mli b/helm/software/lambda-delta/src/complete_rg/crgXml.mli new file mode 100644 index 000000000..c326a9822 --- /dev/null +++ b/helm/software/lambda-delta/src/complete_rg/crgXml.mli @@ -0,0 +1,12 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/lib/Make b/helm/software/lambda-delta/src/lib/Make new file mode 100644 index 000000000..45d5eac3b --- /dev/null +++ b/helm/software/lambda-delta/src/lib/Make @@ -0,0 +1 @@ +cps share log time diff --git a/helm/software/lambda-delta/src/lib/cps.ml b/helm/software/lambda-delta/src/lib/cps.ml new file mode 100644 index 000000000..10ec62376 --- /dev/null +++ b/helm/software/lambda-delta/src/lib/cps.ml @@ -0,0 +1,83 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/lib/log.ml b/helm/software/lambda-delta/src/lib/log.ml new file mode 100644 index 000000000..03e7b5b95 --- /dev/null +++ b/helm/software/lambda-delta/src/lib/log.ml @@ -0,0 +1,95 @@ +(* + ||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 "@,@[%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 "@[" + +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 diff --git a/helm/software/lambda-delta/src/lib/log.mli b/helm/software/lambda-delta/src/lib/log.mli new file mode 100644 index 000000000..9e0f054e1 --- /dev/null +++ b/helm/software/lambda-delta/src/lib/log.mli @@ -0,0 +1,63 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/lib/share.ml b/helm/software/lambda-delta/src/lib/share.ml new file mode 100644 index 000000000..600ae9d85 --- /dev/null +++ b/helm/software/lambda-delta/src/lib/share.ml @@ -0,0 +1,21 @@ +(* + ||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) diff --git a/helm/software/lambda-delta/src/lib/time.ml b/helm/software/lambda-delta/src/lib/time.ml new file mode 100644 index 000000000..42d7d39a7 --- /dev/null +++ b/helm/software/lambda-delta/src/lib/time.ml @@ -0,0 +1,34 @@ +(* + ||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 + ) diff --git a/helm/software/lambda-delta/src/text/Make b/helm/software/lambda-delta/src/text/Make new file mode 100644 index 000000000..f1c0ffe26 --- /dev/null +++ b/helm/software/lambda-delta/src/text/Make @@ -0,0 +1 @@ +txt txtParser txtLexer txtTxt diff --git a/helm/software/lambda-delta/src/text/prova.hln b/helm/software/lambda-delta/src/text/prova.hln new file mode 100644 index 000000000..a782fda1c --- /dev/null +++ b/helm/software/lambda-delta/src/text/prova.hln @@ -0,0 +1,11 @@ +\open pippo + +\global a : *Set + +\global b : *Prop + +\global f = [x:*Set].[y:*Prop].x + +\global "commento\"" c = f(a,b) : *Set + +\close diff --git a/helm/software/lambda-delta/src/text/txt.ml b/helm/software/lambda-delta/src/text/txt.ml new file mode 100644 index 000000000..dbcc0675c --- /dev/null +++ b/helm/software/lambda-delta/src/text/txt.ml @@ -0,0 +1,43 @@ +(* + ||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 *) + diff --git a/helm/software/lambda-delta/src/text/txtLexer.mll b/helm/software/lambda-delta/src/text/txtLexer.mll new file mode 100644 index 000000000..dc293bdcf --- /dev/null +++ b/helm/software/lambda-delta/src/text/txtLexer.mll @@ -0,0 +1,72 @@ +(* + ||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 } diff --git a/helm/software/lambda-delta/src/text/txtParser.mly b/helm/software/lambda-delta/src/text/txtParser.mly new file mode 100644 index 000000000..694e30891 --- /dev/null +++ b/helm/software/lambda-delta/src/text/txtParser.mly @@ -0,0 +1,153 @@ +/* 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 IX + %token 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 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 } + ; diff --git a/helm/software/lambda-delta/src/text/txtTxt.ml b/helm/software/lambda-delta/src/text/txtTxt.ml new file mode 100644 index 000000000..1d501fe0d --- /dev/null +++ b/helm/software/lambda-delta/src/text/txtTxt.ml @@ -0,0 +1,62 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/text/txtTxt.mli b/helm/software/lambda-delta/src/text/txtTxt.mli new file mode 100644 index 000000000..357487625 --- /dev/null +++ b/helm/software/lambda-delta/src/text/txtTxt.mli @@ -0,0 +1,12 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/toplevel/Make b/helm/software/lambda-delta/src/toplevel/Make new file mode 100644 index 000000000..a8a72e17f --- /dev/null +++ b/helm/software/lambda-delta/src/toplevel/Make @@ -0,0 +1 @@ +meta metaOutput metaLibrary metaAut metaBag metaBrg top diff --git a/helm/software/lambda-delta/src/toplevel/meta.ml b/helm/software/lambda-delta/src/toplevel/meta.ml new file mode 100644 index 000000000..553977251 --- /dev/null +++ b/helm/software/lambda-delta/src/toplevel/meta.ml @@ -0,0 +1,25 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/toplevel/metaAut.ml b/helm/software/lambda-delta/src/toplevel/metaAut.ml new file mode 100644 index 000000000..dd6c4a6f6 --- /dev/null +++ b/helm/software/lambda-delta/src/toplevel/metaAut.ml @@ -0,0 +1,218 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/toplevel/metaAut.mli b/helm/software/lambda-delta/src/toplevel/metaAut.mli new file mode 100644 index 000000000..a1210c527 --- /dev/null +++ b/helm/software/lambda-delta/src/toplevel/metaAut.mli @@ -0,0 +1,20 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/toplevel/metaBag.ml b/helm/software/lambda-delta/src/toplevel/metaBag.ml new file mode 100644 index 000000000..991d7e8c2 --- /dev/null +++ b/helm/software/lambda-delta/src/toplevel/metaBag.ml @@ -0,0 +1,67 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/toplevel/metaBag.mli b/helm/software/lambda-delta/src/toplevel/metaBag.mli new file mode 100644 index 000000000..62ce68f4e --- /dev/null +++ b/helm/software/lambda-delta/src/toplevel/metaBag.mli @@ -0,0 +1,12 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/toplevel/metaBrg.ml b/helm/software/lambda-delta/src/toplevel/metaBrg.ml new file mode 100644 index 000000000..cde4daa13 --- /dev/null +++ b/helm/software/lambda-delta/src/toplevel/metaBrg.ml @@ -0,0 +1,66 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/toplevel/metaBrg.mli b/helm/software/lambda-delta/src/toplevel/metaBrg.mli new file mode 100644 index 000000000..4ce275fb8 --- /dev/null +++ b/helm/software/lambda-delta/src/toplevel/metaBrg.mli @@ -0,0 +1,12 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/toplevel/metaLibrary.ml b/helm/software/lambda-delta/src/toplevel/metaLibrary.ml new file mode 100644 index 000000000..3ae116d96 --- /dev/null +++ b/helm/software/lambda-delta/src/toplevel/metaLibrary.ml @@ -0,0 +1,36 @@ +(* + ||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 () diff --git a/helm/software/lambda-delta/src/toplevel/metaLibrary.mli b/helm/software/lambda-delta/src/toplevel/metaLibrary.mli new file mode 100644 index 000000000..2f6e41b80 --- /dev/null +++ b/helm/software/lambda-delta/src/toplevel/metaLibrary.mli @@ -0,0 +1,18 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/toplevel/metaOutput.ml b/helm/software/lambda-delta/src/toplevel/metaOutput.ml new file mode 100644 index 000000000..21d735d0e --- /dev/null +++ b/helm/software/lambda-delta/src/toplevel/metaOutput.ml @@ -0,0 +1,162 @@ +(* + ||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 () diff --git a/helm/software/lambda-delta/src/toplevel/metaOutput.mli b/helm/software/lambda-delta/src/toplevel/metaOutput.mli new file mode 100644 index 000000000..1a7b119ce --- /dev/null +++ b/helm/software/lambda-delta/src/toplevel/metaOutput.mli @@ -0,0 +1,20 @@ +(* + ||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 diff --git a/helm/software/lambda-delta/src/toplevel/top.ml b/helm/software/lambda-delta/src/toplevel/top.ml new file mode 100644 index 000000000..40fcda5e1 --- /dev/null +++ b/helm/software/lambda-delta/src/toplevel/top.ml @@ -0,0 +1,399 @@ +(* + ||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 | -x | -hkr ]* [ ]*\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 = " 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 = " 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 = " 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 = " set initial segment of URI hierarchy" in + let help_s = " set translation stage (see above)" in + let help_u = " activate sort inclusion" in + let help_x = " export kernel entities (XML) to " 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