diff options
44 files changed, 352 insertions, 341 deletions
diff --git a/Makefile.ide b/Makefile.ide index 908f5f6648..8f9088a04a 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -66,7 +66,7 @@ IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_ GTKSHARE=$(shell pkg-config --variable=prefix gtk+-3.0)/share GTKBIN=$(shell pkg-config --variable=prefix gtk+-3.0)/bin GTKLIBS=$(shell pkg-config --variable=libdir gtk+-3.0) -PIXBUFBIN=$(shell pkg-config --variable=prefix gdk-pixbuf-3.0)/bin +PIXBUFBIN=$(shell pkg-config --variable=prefix gdk-pixbuf-2.0)/bin SOURCEVIEWSHARE=$(shell pkg-config --variable=prefix gtksourceview-3.0)/share ########################################################################### @@ -244,15 +244,15 @@ $(COQIDEAPP)/Contents: $(COQIDEINAPP): ide/macos_prehook.cmx $(LINKIDEOPT) | $(COQIDEAPP)/Contents $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk3.sourceview3 $(IDEFLAGS:.cma=.cmxa) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 $(IDEFLAGS:.cma=.cmxa) $^ $(STRIP_HIDE) $@ $(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents $(MKDIR) $@/coq/ $(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $(IDEBINDINGS) $@/coq/ - $(MKDIR) $@/gtksourceview-2.0/{language-specs,styles} - $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-2.0/language-specs/{def.lang,language2.rng} $@/gtksourceview-2.0/language-specs/ - $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-2.0/styles/{styles.rng,classic.xml} $@/gtksourceview-2.0/styles/ + $(MKDIR) $@/gtksourceview-3.0/{language-specs,styles} + $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-3.0/language-specs/{def.lang,language2.rng} $@/gtksourceview-3.0/language-specs/ + $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-3.0/styles/{styles.rng,classic.xml} $@/gtksourceview-3.0/styles/ cp -R "$(GTKSHARE)/"locale $@ cp -R "$(GTKSHARE)/"themes $@ @@ -262,20 +262,20 @@ $(COQIDEAPP)/Contents/Resources/loaders: $(COQIDEAPP)/Contents $(COQIDEAPP)/Contents/Resources/immodules: $(COQIDEAPP)/Contents $(MKDIR) $@ - $(INSTALLLIB) "$(GTKLIBS)/gtk-2.0/2.10.0/immodules/"*.so $@ + $(INSTALLLIB) "$(GTKLIBS)/gtk-3.0/3.0.0/immodules/"*.so $@ $(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib $(MKDIR) $@/xdg/coq $(INSTALLLIB) ide/MacOS/default_accel_map $@/xdg/coq/coqide.keys - $(MKDIR) $@/gtk-2.0 + $(MKDIR) $@/gtk-3.0 { "$(PIXBUFBIN)/gdk-pixbuf-query-loaders" $@/../loaders/*.so |\ sed -e "s!/.*\(/loaders/.*.so\)!@executable_path/../Resources/\1!"; } \ - > $@/gtk-2.0/gdk-pixbuf.loaders - { "$(GTKBIN)/gtk-query-immodules-2.0" $@/../immodules/*.so |\ + > $@/gtk-3.0/gdk-pixbuf.loaders + { "$(GTKBIN)/gtk-query-immodules-3.0" $@/../immodules/*.so |\ sed -e "s!/.*\(/immodules/.*.so\)!@executable_path/../Resources/\1!" |\ sed -e "s!/.*\(/share/locale\)!@executable_path/../Resources/\1!"; } \ - > $@/gtk-2.0/gtk-immodules.loaders + > $@/gtk-3.0/gtk-immodules.loaders $(MKDIR) $@/pango echo "[Pango]" > $@/pango/pangorc diff --git a/azure-pipelines.yml b/azure-pipelines.yml index a8b42cc722..6fcc64f77e 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -42,6 +42,9 @@ jobs: pool: vmImage: 'macOS-10.13' + variables: + MACOSX_DEPLOYMENT_TARGET: '10.12' + steps: - checkout: self fetchDepth: 10 @@ -49,16 +52,20 @@ jobs: - script: | set -e brew update - brew unlink python - brew install gnu-time opam + brew install gnu-time opam pkg-config gtksourceview3 + pip3 install macpack + displayName: 'Install system dependencies' + - script: | + set -e + export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig opam init -a -j "$NJOBS" --compiler=$COMPILER opam switch set $COMPILER eval $(opam env) opam update - opam install -j "$NJOBS" num ocamlfind${FINDLIB_VER} ounit + opam install -j "$NJOBS" num ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 opam list - displayName: 'Install dependencies' + displayName: 'Install OCaml dependencies' env: COMPILER: "4.07.1" FINDLIB_VER: ".1.8.0" @@ -68,11 +75,30 @@ jobs: set -e eval $(opam env) - ./configure -local -warn-error yes -native-compiler no + ./configure -prefix '$(Build.BinariesDirectory)' -warn-error yes -native-compiler no -coqide opt make -j "$NJOBS" displayName: 'Build Coq' - script: | eval $(opam env) - make -j "$NJOBS" test-suite + make -j "$NJOBS" test-suite PRINT_LOGS=1 displayName: 'Run Coq Test Suite' + + - script: | + make install + displayName: 'Install Coq' + + - script: | + set -e + eval $(opam env) + export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig + ./dev/build/osx/make-macos-dmg.sh + mv _build/*.dmg "$(Build.ArtifactStagingDirectory)/" + displayName: 'Create the dmg bundle' + env: + OUTDIR: '$(Build.BinariesDirectory)' + + - task: PublishBuildArtifacts@1 + inputs: + pathtoPublish: '$(Build.ArtifactStagingDirectory)' + artifactName: coq-macOS-installer @@ -21,6 +21,7 @@ license: "LGPL-2.1" depends: [ "ocaml" { >= "4.05.0" } "dune" { build & >= "1.4.0" } + "ocamlfind" { build } "num" ] diff --git a/dev/build/osx/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh index c450e8157a..3a096fec06 100755 --- a/dev/build/osx/make-macos-dmg.sh +++ b/dev/build/osx/make-macos-dmg.sh @@ -4,7 +4,6 @@ set -e # Configuration setup -OUTDIR=$PWD/_install DMGDIR=$PWD/_dmg VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml) APP=bin/CoqIDE_${VERSION}.app @@ -13,7 +12,7 @@ APP=bin/CoqIDE_${VERSION}.app make PRIVATEBINARIES="$APP" -j "$NJOBS" -l2 "$APP" # Add Coq to the .app file -make OLDROOT="$OUTDIR" COQINSTALLPREFIX="$APP/Contents/Resources/" install-coq install-ide-toploop +make OLDROOT="$OUTDIR" COQINSTALLPREFIX="$APP/Contents/Resources" install-coq install-ide-toploop # Create the dmg bundle mkdir -p "$DMGDIR" diff --git a/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh b/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh new file mode 100644 index 0000000000..1e1d36d54a --- /dev/null +++ b/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "9165" ] || [ "$CI_BRANCH" = "recarg-cleanup" ]; then + + elpi_CI_REF=recarg-cleanup + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + + quickchick_CI_REF=recarg-cleanup + quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick + +fi diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 416253fad1..40c3c32e4f 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -83,6 +83,11 @@ Libobject * `Libobject.superglobal_object` * `Libobject.superglobal_object_nodischarge` +AST + +- Minor changes in the AST have been performed, for example + https://github.com/coq/coq/pull/9165 + Implicit Arguments - `Impargs.declare_manual_implicits` is restricted to only support declaration diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index 56f84d0ff0..b410833d25 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -194,14 +194,14 @@ Program Fixpoint The optional order annotation follows the grammar: .. productionlist:: orderannot - order : measure `term` (`term`)? | wf `term` `term` + order : measure `term` [ `term` ] | wf `term` `ident` - + :g:`measure f ( R )` where :g:`f` is a value of type :g:`X` computed on - any subset of the arguments and the optional (parenthesised) term - ``(R)`` is a relation on ``X``. By default ``X`` defaults to ``nat`` and ``R`` - to ``lt``. + + :g:`measure f R` where :g:`f` is a value of type :g:`X` computed on + any subset of the arguments and the optional term + :g:`R` is a relation on :g:`X`. :g:`X` defaults to :g:`nat` and :g:`R` + to :g:`lt`. - + :g:`wf R x` which is equivalent to :g:`measure x (R)`. + + :g:`wf R x` which is equivalent to :g:`measure x R`. The structural fixpoint operator behaves just like the one of |Coq| (see :cmd:`Fixpoint`), except it may also generate obligations. It works diff --git a/ide/macos_prehook.ml b/ide/macos_prehook.ml index d668788954..dc8fd0e85d 100644 --- a/ide/macos_prehook.ml +++ b/ide/macos_prehook.ml @@ -24,13 +24,13 @@ let () = Unix.putenv "GTK_DATA_PREFIX" resources_dir let () = Unix.putenv "GTK_EXE_PREFIX" resources_dir let () = Unix.putenv "GTK_PATH" resources_dir let () = - Unix.putenv "GTK2_RC_FILES" (Filename.concat etc_dir "gtk-2.0/gtkrc") + Unix.putenv "GTK3_RC_FILES" (Filename.concat etc_dir "gtk-3.0/gtkrc") let () = Unix.putenv "GTK_IM_MODULE_FILE" - (Filename.concat etc_dir "gtk-2.0/gtk-immodules.loaders") + (Filename.concat etc_dir "gtk-3.0/gtk-immodules.loaders") let () = Unix.putenv "GDK_PIXBUF_MODULE_FILE" - (Filename.concat etc_dir "gtk-2.0/gdk-pixbuf.loaders") + (Filename.concat etc_dir "gtk-3.0/gdk-pixbuf.loaders") let () = Unix.putenv "PANGO_LIBDIR" lib_dir let () = Unix.putenv "PANGO_SYSCONFIGDIR" etc_dir let () = Unix.putenv "CHARSETALIASDIR" lib_dir diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index 7a14a4e708..9f778d99e9 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -134,16 +134,17 @@ and branch_expr = (cases_pattern_expr list list * constr_expr) CAst.t and fix_expr = - lident * (lident option * recursion_order_expr) * + lident * recursion_order_expr option * local_binder_expr list * constr_expr * constr_expr and cofix_expr = lident * local_binder_expr list * constr_expr * constr_expr -and recursion_order_expr = - | CStructRec - | CWfRec of constr_expr - | CMeasureRec of constr_expr * constr_expr option (** measure, relation *) +and recursion_order_expr_r = + | CStructRec of lident + | CWfRec of lident * constr_expr + | CMeasureRec of lident option * constr_expr * constr_expr option (** argument, measure, relation *) +and recursion_order_expr = recursion_order_expr_r CAst.t (* Anonymous defs allowed ?? *) and local_binder_expr = diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 60610b92b8..443473d5b6 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -196,10 +196,9 @@ and branch_expr_eq {CAst.v=(p1, e1)} {CAst.v=(p2, e2)} = List.equal (List.equal cases_pattern_expr_eq) p1 p2 && constr_expr_eq e1 e2 -and fix_expr_eq (id1,(j1, r1),bl1,a1,b1) (id2,(j2, r2),bl2,a2,b2) = +and fix_expr_eq (id1,r1,bl1,a1,b1) (id2,r2,bl2,a2,b2) = (eq_ast Id.equal id1 id2) && - Option.equal (eq_ast Id.equal) j1 j2 && - recursion_order_expr_eq r1 r2 && + Option.equal recursion_order_expr_eq r1 r2 && List.equal local_binder_eq bl1 bl2 && constr_expr_eq a1 a2 && constr_expr_eq b1 b2 @@ -210,13 +209,17 @@ and cofix_expr_eq (id1,bl1,a1,b1) (id2,bl2,a2,b2) = constr_expr_eq a1 a2 && constr_expr_eq b1 b2 -and recursion_order_expr_eq r1 r2 = match r1, r2 with - | CStructRec, CStructRec -> true - | CWfRec e1, CWfRec e2 -> constr_expr_eq e1 e2 - | CMeasureRec (e1, o1), CMeasureRec (e2, o2) -> +and recursion_order_expr_eq_r r1 r2 = match r1, r2 with + | CStructRec i1, CStructRec i2 -> eq_ast Id.equal i1 i2 + | CWfRec (i1,e1), CWfRec (i2,e2) -> + constr_expr_eq e1 e2 + | CMeasureRec (i1, e1, o1), CMeasureRec (i2, e2, o2) -> + Option.equal (eq_ast Id.equal) i1 i2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq o1 o2 | _ -> false +and recursion_order_expr_eq r1 r2 = eq_ast recursion_order_expr_eq_r r1 r2 + and local_binder_eq l1 l2 = match l1, l2 with | CLocalDef (n1, e1, t1), CLocalDef (n2, e2, t2) -> eq_ast Name.equal n1 n2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq t1 t2 @@ -349,7 +352,7 @@ let fold_constr_expr_with_binders g f n acc = CAst.with_val (function (f (Option.fold_right (CAst.with_val (Name.fold_right g)) ona n)) acc po | CFix (_,l) -> let n' = List.fold_right (fun ( { CAst.v = id },_,_,_,_) -> g id) l n in - List.fold_right (fun (_,(_,o),lb,t,c) acc -> + List.fold_right (fun (_,ro,lb,t,c) acc -> fold_local_binders g f n' (fold_local_binders g f n acc t lb) c lb) l acc | CCoFix (_,_) -> diff --git a/interp/constrextern.ml b/interp/constrextern.ml index b89b6b5765..3b169edaab 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -938,13 +938,12 @@ let rec extern inctx (custom,scopes as allscopes) vars r = let (assums,ids,bl) = extern_local_binder scopes vars bl in let vars0 = List.fold_right (Name.fold_right Id.Set.add) ids vars in let vars1 = List.fold_right (Name.fold_right Id.Set.add) ids vars' in - let n = - match fst nv.(i) with - | None -> None - | Some x -> Some (CAst.make @@ Name.get_id (List.nth assums x)) - in - let ro = extern_recursion_order scopes vars (snd nv.(i)) in - ((CAst.make fi), (n, ro), bl, extern_typ scopes vars0 ty, + let n = + match nv.(i) with + | None -> None + | Some x -> Some (CAst.make @@ CStructRec (CAst.make @@ Name.get_id (List.nth assums x))) + in + ((CAst.make fi), n, bl, extern_typ scopes vars0 ty, extern false scopes vars1 def)) idv in CFix (CAst.(make ?loc idv.(n)), Array.to_list listdecl) @@ -1159,13 +1158,6 @@ and extern_notation (custom,scopes as allscopes) lonely_seen vars t = function let lonely_seen = add_lonely keyrule lonely_seen in extern_notation allscopes lonely_seen vars t rules -and extern_recursion_order scopes vars = function - GStructRec -> CStructRec - | GWfRec c -> CWfRec (extern true scopes vars c) - | GMeasureRec (m,r) -> CMeasureRec (extern true scopes vars m, - Option.map (extern true scopes vars) r) - - let extern_glob_constr vars c = extern false (InConstrEntrySomeLevel,(None,[])) vars c @@ -1294,7 +1286,7 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with let v = Array.map3 (fun c t i -> Detyping.share_pattern_names glob_of_pat (i+1) [] def_avoid def_env sigma c (Patternops.lift_pattern n t)) bl tl ln in - GRec(GFix (Array.map (fun i -> Some i, GStructRec) ln,i),Array.of_list (List.rev lfi), + GRec(GFix (Array.map (fun i -> Some i) ln,i),Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 3329ba2047..c0801067ce 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1845,51 +1845,44 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = in apply_impargs c env imp subscopes l loc - | CFix ({ CAst.loc = locid; v = iddef}, dl) -> + | CFix ({ CAst.loc = locid; v = iddef}, dl) -> let lf = List.map (fun ({CAst.v = id},_,_,_,_) -> id) dl in let dl = Array.of_list dl in - let n = - try List.index0 Id.equal iddef lf + let n = + try List.index0 Id.equal iddef lf with Not_found -> - raise (InternalizationError (locid,UnboundFixName (false,iddef))) - in - let idl_temp = Array.map - (fun (id,(n,order),bl,ty,_) -> - let intern_ro_arg f = - let before, after = split_at_annot bl n in - let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in - let ro = f (intern env') in - let n' = Option.map (fun _ -> List.count (fun c -> match DAst.get c with - | GLocalAssum _ -> true - | _ -> false (* remove let-ins *)) - rbefore) n in - n', ro, List.fold_left intern_local_binder (env',rbefore) after - in - let n, ro, (env',rbl) = - match order with - | CStructRec -> - intern_ro_arg (fun _ -> GStructRec) - | CWfRec c -> - intern_ro_arg (fun f -> GWfRec (f c)) - | CMeasureRec (m,r) -> - intern_ro_arg (fun f -> GMeasureRec (f m, Option.map f r)) - in - let bl = List.rev (List.map glob_local_binder_of_extended rbl) in - ((n, ro), bl, intern_type env' ty, env')) dl in + raise (InternalizationError (locid,UnboundFixName (false,iddef))) + in + let idl_temp = Array.map + (fun (id,recarg,bl,ty,_) -> + let recarg = Option.map (function { CAst.v = v } -> match v with + | CStructRec i -> i + | _ -> anomaly Pp.(str "Non-structural recursive argument in non-program fixpoint")) recarg + in + let before, after = split_at_annot bl recarg in + let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in + let n = Option.map (fun _ -> List.count (fun c -> match DAst.get c with + | GLocalAssum _ -> true + | _ -> false (* remove let-ins *)) + rbefore) recarg in + let (env',rbl) = List.fold_left intern_local_binder (env',rbefore) after in + let bl = List.rev (List.map glob_local_binder_of_extended rbl) in + (n, bl, intern_type env' ty, env')) dl in let idl = Array.map2 (fun (_,_,_,_,bd) (a,b,c,env') -> - let env'' = List.fold_left_i (fun i en name -> - let (_,bli,tyi,_) = idl_temp.(i) in - let fix_args = (List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli) in - push_name_env ntnvars (impls_type_list ~args:fix_args tyi) - en (CAst.make @@ Name name)) 0 env' lf in - (a,b,c,intern {env'' with tmp_scope = None} bd)) dl idl_temp in - DAst.make ?loc @@ - GRec (GFix - (Array.map (fun (ro,_,_,_) -> ro) idl,n), + let env'' = List.fold_left_i (fun i en name -> + let (_,bli,tyi,_) = idl_temp.(i) in + let fix_args = (List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli) in + push_name_env ntnvars (impls_type_list ~args:fix_args tyi) + en (CAst.make @@ Name name)) 0 env' lf in + (a,b,c,intern {env'' with tmp_scope = None} bd)) dl idl_temp in + DAst.make ?loc @@ + GRec (GFix + (Array.map (fun (ro,_,_,_) -> ro) idl,n), Array.of_list lf, Array.map (fun (_,bl,_,_) -> bl) idl, Array.map (fun (_,_,ty,_) -> ty) idl, Array.map (fun (_,_,_,bd) -> bd) idl) + | CCoFix ({ CAst.loc = locid; v = iddef }, dl) -> let lf = List.map (fun ({CAst.v = id},_,_,_) -> id) dl in let dl = Array.of_list dl in diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 9801e56ca1..7f084fffdd 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -957,7 +957,7 @@ let match_fix_kind fk1 fk2 = match (fk1,fk2) with | GCoFix n1, GCoFix n2 -> Int.equal n1 n2 | GFix (nl1,n1), GFix (nl2,n2) -> - let test (n1, _) (n2, _) = match n1, n2 with + let test n1 n2 = match n1, n2 with | _, None -> true | Some id1, Some id2 -> Int.equal id1 id2 | _ -> false diff --git a/interp/notation_term.ml b/interp/notation_term.ml index 6fe20486dc..5024f5c26f 100644 --- a/interp/notation_term.ml +++ b/interp/notation_term.ml @@ -38,7 +38,7 @@ type notation_constr = notation_constr * notation_constr | NIf of notation_constr * (Name.t * notation_constr option) * notation_constr * notation_constr - | NRec of fix_kind * Id.t array * + | NRec of glob_fix_kind * Id.t array * (Name.t * notation_constr option * notation_constr) list array * notation_constr array * notation_constr array | NSort of glob_sort diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 94ed288d2d..d7ec2ecf72 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -51,7 +51,6 @@ let fresh_lname n = (** Global names **) type gname = | Gind of string * inductive (* prefix, inductive name *) - | Gconstruct of string * constructor (* prefix, constructor name *) | Gconstant of string * Constant.t (* prefix, constant name *) | Gproj of string * inductive * int (* prefix, inductive, index (start from 0) *) | Gcase of Label.t option * int @@ -67,8 +66,6 @@ let eq_gname gn1 gn2 = match gn1, gn2 with | Gind (s1, ind1), Gind (s2, ind2) -> String.equal s1 s2 && eq_ind ind1 ind2 - | Gconstruct (s1, c1), Gconstruct (s2, c2) -> - String.equal s1 s2 && eq_constructor c1 c2 | Gconstant (s1, c1), Gconstant (s2, c2) -> String.equal s1 s2 && Constant.equal c1 c2 | Gproj (s1, ind1, i1), Gproj (s2, ind2, i2) -> @@ -88,7 +85,7 @@ let eq_gname gn1 gn2 = | Ginternal s1, Ginternal s2 -> String.equal s1 s2 | Grel i1, Grel i2 -> Int.equal i1 i2 | Gnamed id1, Gnamed id2 -> Id.equal id1 id2 - | (Gind _| Gconstruct _ | Gconstant _ | Gproj _ | Gcase _ | Gpred _ + | (Gind _| Gconstant _ | Gproj _ | Gcase _ | Gpred _ | Gfixtype _ | Gnorm _ | Gnormtbl _ | Ginternal _ | Grel _ | Gnamed _), _ -> false @@ -100,19 +97,17 @@ open Hashset.Combine let gname_hash gn = match gn with | Gind (s, ind) -> combinesmall 1 (combine (String.hash s) (ind_hash ind)) -| Gconstruct (s, c) -> - combinesmall 2 (combine (String.hash s) (constructor_hash c)) | Gconstant (s, c) -> - combinesmall 3 (combine (String.hash s) (Constant.hash c)) -| Gcase (l, i) -> combinesmall 4 (combine (Option.hash Label.hash l) (Int.hash i)) -| Gpred (l, i) -> combinesmall 5 (combine (Option.hash Label.hash l) (Int.hash i)) -| Gfixtype (l, i) -> combinesmall 6 (combine (Option.hash Label.hash l) (Int.hash i)) -| Gnorm (l, i) -> combinesmall 7 (combine (Option.hash Label.hash l) (Int.hash i)) -| Gnormtbl (l, i) -> combinesmall 8 (combine (Option.hash Label.hash l) (Int.hash i)) -| Ginternal s -> combinesmall 9 (String.hash s) -| Grel i -> combinesmall 10 (Int.hash i) -| Gnamed id -> combinesmall 11 (Id.hash id) -| Gproj (s, p, i) -> combinesmall 12 (combine (String.hash s) (combine (ind_hash p) i)) + combinesmall 2 (combine (String.hash s) (Constant.hash c)) +| Gcase (l, i) -> combinesmall 3 (combine (Option.hash Label.hash l) (Int.hash i)) +| Gpred (l, i) -> combinesmall 4 (combine (Option.hash Label.hash l) (Int.hash i)) +| Gfixtype (l, i) -> combinesmall 5 (combine (Option.hash Label.hash l) (Int.hash i)) +| Gnorm (l, i) -> combinesmall 6 (combine (Option.hash Label.hash l) (Int.hash i)) +| Gnormtbl (l, i) -> combinesmall 7 (combine (Option.hash Label.hash l) (Int.hash i)) +| Ginternal s -> combinesmall 8 (String.hash s) +| Grel i -> combinesmall 9 (Int.hash i) +| Gnamed id -> combinesmall 10 (Id.hash id) +| Gproj (s, p, i) -> combinesmall 11 (combine (String.hash s) (combine (ind_hash p) i)) let case_ctr = ref (-1) @@ -1280,9 +1275,6 @@ let ml_of_instance instance u = | Lmakeblock (prefix,(cn,_u),_,args) -> let args = Array.map (ml_of_lam env l) args in MLconstruct(prefix,cn,args) - | Lconstruct (prefix, (cn,u)) -> - let uargs = ml_of_instance env.env_univ u in - mkMLapp (MLglobal (Gconstruct (prefix, cn))) uargs | Luint i -> MLapp(MLprimitive Mk_uint, [|MLuint i|]) | Lval v -> let i = push_symbol (SymbValue v) in get_value_code i @@ -1533,8 +1525,6 @@ let string_of_gname g = match g with | Gind (prefix, (mind, i)) -> Format.sprintf "%sindaccu_%s_%i" prefix (string_of_mind mind) i - | Gconstruct (prefix, ((mind, i), j)) -> - Format.sprintf "%sconstruct_%s_%i_%i" prefix (string_of_mind mind) i (j-1) | Gconstant (prefix, c) -> Format.sprintf "%sconst_%s" prefix (string_of_con c) | Gproj (prefix, (mind, n), i) -> @@ -1932,16 +1922,6 @@ let compile_mind mb mind stack = Glet(name, MLapp (MLprimitive Mk_ind, args)) in let nparams = mb.mind_nparams in - let params = - Array.init nparams (fun i -> {lname = param_name; luid = i}) in - let add_construct j acc (_,arity) = - let args = Array.init arity (fun k -> {lname = arg_name; luid = k}) in - let c = ind, (j+1) in - Glet(Gconstruct ("", c), - mkMLlam (Array.append params args) - (MLconstruct("", c, Array.map (fun id -> MLlocal id) args)))::acc - in - let constructors = Array.fold_left_i add_construct [] ob.mind_reloc_tbl in let add_proj proj_arg acc _pb = let tbl = ob.mind_reloc_tbl in (* Building info *) @@ -1972,7 +1952,7 @@ let compile_mind mb mind stack = let _, _, _, pbs = info.(i) in Array.fold_left_i add_proj [] pbs in - projs @ constructors @ gtype :: accu :: stack + projs @ gtype :: accu :: stack in Array.fold_left_i f stack mb.mind_packets diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index baa290367f..d153f84e9c 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open CErrors open Names open Nativelib open Reduction @@ -152,19 +151,15 @@ let native_conv_gen pb sigma env univs t1 t2 = else let ml_filename, prefix = get_ml_filename () in let code, upds = mk_conv_code env sigma prefix t1 t2 in - match compile ml_filename code ~profile:false with - | (true, fn) -> - begin - if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); - let t0 = Sys.time () in - call_linker ~fatal:true prefix fn (Some upds); - let t1 = Sys.time () in - let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); - (* TODO change 0 when we can have de Bruijn *) - fst (conv_val env pb 0 !rt1 !rt2 univs) - end - | _ -> anomaly (Pp.str "Compilation failure.") + let fn = compile ml_filename code ~profile:false in + if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); + let t0 = Sys.time () in + call_linker ~fatal:true prefix fn (Some upds); + let t1 = Sys.time () in + let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in + if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + (* TODO change 0 when we can have de Bruijn *) + fst (conv_val env pb 0 !rt1 !rt2 univs) (* Wrapper for [native_conv] above *) let native_conv cv_pb sigma env t1 t2 = diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index ec3a7b893d..d88be94b39 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -42,8 +42,6 @@ type lambda = | Lmakeblock of prefix * pconstructor * int * lambda array (* prefix, constructor Name.t, constructor tag, arguments *) (* A fully applied constructor *) - | Lconstruct of prefix * pconstructor (* prefix, constructor Name.t *) - (* A partially applied constructor *) | Luint of Uint63.t | Lval of Nativevalues.t | Lsort of Sorts.t @@ -121,7 +119,7 @@ let get_const_prefix env c = let map_lam_with_binders g f n lam = match lam with | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Luint _ - | Lconstruct _ | Llazy | Lforce | Lmeta _ -> lam + | Llazy | Lforce | Lmeta _ -> lam | Lprod(dom,codom) -> let dom' = f n dom in let codom' = f n codom in @@ -222,7 +220,7 @@ let lam_subst_args subst args = let can_subst lam = match lam with | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Llam _ - | Lconstruct _ | Lmeta _ | Levar _ -> true + | Lmeta _ | Levar _ -> true | _ -> false let can_merge_if bt bf = @@ -337,9 +335,20 @@ let make_args start _end = Array.init (start - _end + 1) (fun i -> Lrel (Anonymous, start - i)) (* Translation of constructors *) +let expand_constructor prefix cstr tag nparams arity = + let anon = Context.make_annot Anonymous Sorts.Relevant in (* TODO relevance *) + let ids = Array.make (nparams + arity) anon in + let args = make_args arity 1 in + Llam(ids, Lmakeblock (prefix, cstr, tag, args)) -let makeblock env cn u tag args = - if Array.for_all is_value args && Array.length args > 0 then +(* [nparams] is the number of parameters still expected *) +let makeblock env cn u tag nparams arity args = + let nargs = Array.length args in + if nparams > 0 || nargs < arity then + let prefix = get_mind_prefix env (fst (fst cn)) in + mkLapp (expand_constructor prefix (cn,u) tag nparams arity) args + else + if Array.for_all is_value args && nargs > 0 then let args = Array.map get_value args in Lval (Nativevalues.mk_block tag args) else @@ -573,16 +582,12 @@ and lambda_of_app cache env sigma f args = mkLapp (Lconst (prefix, (kn,u))) (lambda_of_args cache env sigma 0 args) end | Construct (c,u) -> - let tag, nparams, arity = Cache.get_construct_info cache env c in - let expected = nparams + arity in - let nargs = Array.length args in - let prefix = get_mind_prefix env (fst (fst c)) in - if Int.equal nargs expected then - let args = lambda_of_args cache env sigma nparams args in - makeblock env c u tag args - else - let args = lambda_of_args cache env sigma 0 args in - mkLapp (Lconstruct (prefix, (c,u))) args + let tag, nparams, arity = Cache.get_construct_info cache env c in + let nargs = Array.length args in + if nparams < nargs then (* got all parameters *) + let args = lambda_of_args cache env sigma nparams args in + makeblock env c u tag 0 arity args + else makeblock env c u tag (nparams - nargs) arity empty_args | _ -> let f = lambda_of_constr cache env sigma f in let args = lambda_of_args cache env sigma 0 args in diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index b0de257a27..687789e82b 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -36,8 +36,6 @@ type lambda = | Lmakeblock of prefix * pconstructor * int * lambda array (* prefix, constructor Name.t, constructor tag, arguments *) (* A fully applied constructor *) - | Lconstruct of prefix * pconstructor (* prefix, constructor Name.t *) - (* A partially applied constructor *) | Luint of Uint63.t | Lval of Nativevalues.t | Lsort of Sorts.t diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 833e4082f0..43c9676f05 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -56,14 +56,15 @@ let write_ml_code fn ?(header=[]) code = List.iter (pp_global fmt) (header@code); close_out ch_out -let warn_native_compiler_failed = - let print = function +let error_native_compiler_failed e = + let msg = match e with + | Inl (Unix.WEXITED 127) -> Pp.(strbrk "The OCaml compiler was not found. Make sure it is installed, together with findlib.") | Inl (Unix.WEXITED n) -> Pp.(strbrk "Native compiler exited with status" ++ str" " ++ int n) | Inl (Unix.WSIGNALED n) -> Pp.(strbrk "Native compiler killed by signal" ++ str" " ++ int n) | Inl (Unix.WSTOPPED n) -> Pp.(strbrk "Native compiler stopped by signal" ++ str" " ++ int n) | Inr e -> Pp.(strbrk "Native compiler failed with error: " ++ strbrk (Unix.error_message e)) in - CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print + CErrors.user_err msg let call_compiler ?profile:(profile=false) ml_filename = let load_path = !get_load_paths () in @@ -100,15 +101,12 @@ let call_compiler ?profile:(profile=false) ml_filename = if !Flags.debug then Feedback.msg_debug (Pp.str (Envars.ocamlfind () ^ " " ^ (String.concat " " args))); try let res = CUnix.sys_command (Envars.ocamlfind ()) args in - let res = match res with - | Unix.WEXITED 0 -> true - | Unix.WEXITED _n | Unix.WSIGNALED _n | Unix.WSTOPPED _n -> - warn_native_compiler_failed (Inl res); false - in - res, link_filename + match res with + | Unix.WEXITED 0 -> link_filename + | Unix.WEXITED _n | Unix.WSIGNALED _n | Unix.WSTOPPED _n -> + error_native_compiler_failed (Inl res) with Unix.Unix_error (e,_,_) -> - warn_native_compiler_failed (Inr e); - false, link_filename + error_native_compiler_failed (Inr e) let compile fn code ~profile:profile = write_ml_code fn code; @@ -128,9 +126,8 @@ let compile_library dir code fn = in let fn = dirname / basename in write_ml_code fn ~header code; - let r = fst (call_compiler fn) in - if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn; - r + let _ = call_compiler fn in + if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn (* call_linker links dynamically the code for constants in environment or a *) (* conversion test. *) diff --git a/kernel/nativelib.mli b/kernel/nativelib.mli index 25adcf224b..e113350368 100644 --- a/kernel/nativelib.mli +++ b/kernel/nativelib.mli @@ -21,9 +21,14 @@ val load_obj : (string -> unit) ref val get_ml_filename : unit -> string * string -val compile : string -> global list -> profile:bool -> bool * string - -val compile_library : Names.DirPath.t -> global list -> string -> bool +(** [compile file code ~profile] will compile native [code] to [file], + and return the name of the object file; this name depends on + whether are in byte mode or not; file is expected to be .ml file *) +val compile : string -> global list -> profile:bool -> string + +(** [compile_library lib code file] is similar to [compile file code] + but will perform some extra tweaks to handle [code] as a Coq lib. *) +val compile_library : Names.DirPath.t -> global list -> string -> unit val call_linker : ?fatal:bool -> string -> string -> code_location_updates option -> unit diff --git a/library/library.ml b/library/library.ml index 37dadadb76..04e38296d9 100644 --- a/library/library.ml +++ b/library/library.ml @@ -718,8 +718,7 @@ let save_library_to ?todo ~output_native_objects dir f otab = (* Writing native code files *) if output_native_objects then let fn = Filename.dirname f'^"/"^Nativecode.mod_uid_of_dirpath dir in - if not (Nativelib.compile_library dir ast fn) then - user_err Pp.(str "Could not compile the library to native code.") + Nativelib.compile_library dir ast fn with reraise -> let reraise = CErrors.push reraise in let () = Feedback.msg_warning (str "Removed file " ++ str f') in diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 0586dda555..4a9190c10a 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -56,10 +56,10 @@ let mk_fixb (id,bl,ann,body,(loc,tyc)) : fix_expr = (id,ann,bl,ty,body) let mk_cofixb (id,bl,ann,body,(loc,tyc)) : cofix_expr = - let _ = Option.map (fun { CAst.loc = aloc } -> + Option.iter (fun { CAst.loc = aloc } -> CErrors.user_err ?loc:aloc ~hdr:"Constr:mk_cofixb" - (Pp.str"Annotation forbidden in cofix expression.")) (fst ann) in + (Pp.str"Annotation forbidden in cofix expression.")) ann; let ty = match tyc with Some ty -> ty | None -> CAst.make @@ CHole (None, IntroAnonymous, None) in @@ -440,10 +440,10 @@ GRAMMAR EXTEND Gram ] ] ; fixannot: - [ [ "{"; IDENT "struct"; id=identref; "}" -> { (Some id, CStructRec) } - | "{"; IDENT "wf"; rel=constr; id=OPT identref; "}" -> { (id, CWfRec rel) } + [ [ "{"; IDENT "struct"; id=identref; "}" -> { CAst.make ~loc @@ CStructRec id } + | "{"; IDENT "wf"; rel=constr; id=identref; "}" -> { CAst.make ~loc @@ CWfRec(id,rel) } | "{"; IDENT "measure"; m=constr; id=OPT identref; - rel=OPT constr; "}" -> { (id, CMeasureRec (m,rel)) } + rel=OPT constr; "}" -> { CAst.make ~loc @@ CMeasureRec (id,m,rel) } ] ] ; impl_name_head: @@ -452,9 +452,9 @@ GRAMMAR EXTEND Gram binders_fixannot: [ [ na = impl_name_head; assum = impl_ident_tail; bl = binders_fixannot -> { (assum na :: fst bl), snd bl } - | f = fixannot -> { [], f } + | f = fixannot -> { [], Some f } | b = binder; bl = binders_fixannot -> { b @ fst bl, snd bl } - | -> { [], (None, CStructRec) } + | -> { [], None } ] ] ; open_binders: diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 5d8897cb47..3a57c14a3b 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -191,7 +191,7 @@ module Constr : val binder : local_binder_expr list Entry.t (* closed_binder or variable *) val binders : local_binder_expr list Entry.t (* list of binder *) val open_binders : local_binder_expr list Entry.t - val binders_fixannot : (local_binder_expr list * (lident option * recursion_order_expr)) Entry.t + val binders_fixannot : (local_binder_expr list * recursion_order_expr option) Entry.t val typeclass_constraint : (lname * bool * constr_expr) Entry.t val record_declaration : constr_expr Entry.t val appl_arg : (constr_expr * explicitation CAst.t option) Entry.t diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 4e8cf80ed2..a3973732ad 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -179,8 +179,10 @@ let () = VERNAC COMMAND EXTEND Function | ![ proof ] ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] => { let hard = List.exists (function - | _,((_,(_,(CMeasureRec _|CWfRec _)),_,_,_),_) -> true - | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in + | _,((_,(Some { CAst.v = CMeasureRec _ } + | Some { CAst.v = CWfRec _}),_,_,_),_) -> true + | _,((_,Some { CAst.v = CStructRec _ },_,_,_),_) + | _,((_,None,_,_,_),_) -> false) recsl in match Vernac_classifier.classify_vernac (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index e582362e25..6494e90a03 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -469,11 +469,6 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas CAst.(with_val (fun x -> x)) (Constrexpr_ops.names_of_local_assums args) in - match wf_arg with - | None -> - if Int.equal (List.length names) 1 then 1 - else error "Recursive argument must be specified" - | Some wf_arg -> List.index Name.equal (Name wf_arg) names in let unbounded_eq = @@ -575,7 +570,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas in wf_rel_with_mes,false in - register_wf ~is_mes:is_mes fname rec_impls wf_rel_from_mes (Some wf_arg) + register_wf ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg using_lemmas args ret_type body let map_option f = function @@ -623,15 +618,15 @@ and rebuild_nal aux bk bl' nal typ = let rebuild_bl aux bl typ = rebuild_bl aux bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = - let fixl,ntns = ComFixpoint.extract_fixpoint_components false fixpoint_exprl in + let fixl,ntns = ComFixpoint.extract_fixpoint_components ~structonly:false fixpoint_exprl in let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl ntns in let constr_expr_typel = with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in let fixpoint_exprl_with_new_bl = - List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> + List.map2 (fun ((lna,rec_order_opt,bl,ret_typ,opt_body),notation_list) fix_typ -> let new_bl',new_ret_type = rebuild_bl [] bl fix_typ in - (((lna,(rec_arg_opt,rec_order),new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + (((lna,rec_order_opt,new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixpoint_exprl constr_expr_typel in @@ -643,7 +638,7 @@ let do_generate_principle ~pstate pconstants on_error register_built interactive List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; let pstate, _is_struct = match fixpoint_exprl with - | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> + | [((_,Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)},_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},pl),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e @@ -665,9 +660,9 @@ let do_generate_principle ~pstate pconstants on_error register_built interactive true in if register_built - then register_wf name rec_impls wf_rel (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, false + then register_wf name rec_impls wf_rel wf_x.CAst.v using_lemmas args types body pre_hook, false else pstate, false - |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> + |[((_,Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)},_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},_),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e @@ -692,9 +687,9 @@ let do_generate_principle ~pstate pconstants on_error register_built interactive then register_mes name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, true else pstate, true | _ -> - List.iter (function ((_na,(_,ord),_args,_body,_type),_not) -> + List.iter (function ((_na,ord,_args,_body,_type),_not) -> match ord with - | Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _ -> + | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> error ("Cannot use mutual definition with well-founded recursion or measure") | _ -> () @@ -869,38 +864,42 @@ let make_graph ~pstate (f_ref : GlobRef.t) = ) () in - let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b.CAst.v with - | Constrexpr.CFix(l_id,fixexprl) -> - let l = - List.map - (fun (id,(n,recexp),bl,t,b) -> - let { CAst.loc; v=rec_id } = Option.get n in - let new_args = - List.flatten - (List.map - (function - | Constrexpr.CLocalDef (na,_,_)-> [] - | Constrexpr.CLocalAssum (nal,_,_) -> - List.map - (fun {CAst.loc;v=n} -> CAst.make ?loc @@ - CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) - nal - | Constrexpr.CLocalPattern _ -> assert false - ) - nal_tas - ) - in - let b' = add_args id.CAst.v new_args b in - ((((id,None), ( Some CAst.(make rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) - ) - fixexprl - in - l + let (nal_tas,b,t) = get_args extern_body extern_type in + let expr_list = + match b.CAst.v with + | Constrexpr.CFix(l_id,fixexprl) -> + let l = + List.map + (fun (id,recexp,bl,t,b) -> + let { CAst.loc; v=rec_id } = match Option.get recexp with + | { CAst.v = CStructRec id } -> id + | { CAst.v = CWfRec (id,_) } -> id + | { CAst.v = CMeasureRec (oid,_,_) } -> Option.get oid + in + let new_args = + List.flatten + (List.map + (function + | Constrexpr.CLocalDef (na,_,_)-> [] + | Constrexpr.CLocalAssum (nal,_,_) -> + List.map + (fun {CAst.loc;v=n} -> CAst.make ?loc @@ + CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) + nal + | Constrexpr.CLocalPattern _ -> assert false + ) + nal_tas + ) + in + let b' = add_args id.CAst.v new_args b in + ((((id,None), ( Some (CAst.make (CStructRec (CAst.make rec_id)))),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + ) + fixexprl + in + l | _ -> let id = Label.to_id (Constant.label c) in - [((CAst.make id,None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] + [((CAst.make id,None),None,nal_tas,t,Some b),[]] in let mp = Constant.modpath c in let pstate = do_generate_principle ~pstate [c,Univ.Instance.empty] error_error false false expr_list in diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 7cd62f4ead..f44962f213 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -1200,7 +1200,7 @@ let rec format_constr_expr h0 c0 = let open CAst in match h0, c0 with | [BFcast], { v = CCast (c, Glob_term.CastConv t) } -> [Bcast t], c | BFrec (has_str, has_cast) :: h, - { v = CFix ( _, [_, (Some locn, CStructRec), bl, t, c]) } -> + { v = CFix ( _, [_, Some {CAst.v = CStructRec locn}, bl, t, c]) } -> let bs = format_local_binders h bl in let bstr = if has_str then [Bstruct (Name locn.CAst.v)] else [] in bs @ bstr @ (if has_cast then [Bcast t] else []), c @@ -1424,7 +1424,7 @@ ARGUMENT EXTEND ssrfixfwd TYPED AS (ident * ssrfwd) PRINTED BY { pr_ssrfixfwd } | [] -> CErrors.user_err (Pp.str "Bad structural argument") in loop (names_of_local_assums lb) in let h' = BFrec (has_struct, has_cast) :: binders_fmts bs in - let fix = CAst.make ~loc @@ CFix (lid, [lid, (Some i, CStructRec), lb, t', c']) in + let fix = CAst.make ~loc @@ CFix (lid, [lid, (Some (CAst.make (CStructRec i))), lb, t', c']) in id, ((fk, h'), { ac with body = fix }) } END diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index eaa5736336..062e3ca8b2 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -653,7 +653,7 @@ let detype_fix detype flags avoid env sigma (vn,_ as nvn) (names,tys,bodies) = let v = Array.map3 (fun c t i -> share_names detype flags (i+1) [] def_avoid def_env sigma c (lift n t)) bodies tys vn in - GRec(GFix (Array.map (fun i -> Some i, GStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi), + GRec(GFix (Array.map (fun i -> Some i) (fst nvn), snd nvn),Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 6da168711c..85b9faac77 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -106,19 +106,9 @@ let glob_decl_eq f (na1, bk1, c1, t1) (na2, bk2, c2, t2) = Name.equal na1 na2 && binding_kind_eq bk1 bk2 && Option.equal f c1 c2 && f t1 t2 -let fix_recursion_order_eq f o1 o2 = match o1, o2 with - | GStructRec, GStructRec -> true - | GWfRec c1, GWfRec c2 -> f c1 c2 - | GMeasureRec (c1, o1), GMeasureRec (c2, o2) -> - f c1 c2 && Option.equal f o1 o2 - | (GStructRec | GWfRec _ | GMeasureRec _), _ -> false - -let fix_kind_eq f k1 k2 = match k1, k2 with +let fix_kind_eq k1 k2 = match k1, k2 with | GFix (a1, i1), GFix (a2, i2) -> - let eq (i1, o1) (i2, o2) = - Option.equal Int.equal i1 i2 && fix_recursion_order_eq f o1 o2 - in - Int.equal i1 i2 && Array.equal eq a1 a2 + Int.equal i1 i2 && Array.equal (Option.equal Int.equal) a1 a2 | GCoFix i1, GCoFix i2 -> Int.equal i1 i2 | (GFix _ | GCoFix _), _ -> false @@ -150,7 +140,7 @@ let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with f m1 m2 && Name.equal pat1 pat2 && Option.equal f p1 p2 && f c1 c2 && f t1 t2 | GRec (kn1, id1, decl1, t1, c1), GRec (kn2, id2, decl2, t2, c2) -> - fix_kind_eq f kn1 kn2 && Array.equal Id.equal id1 id2 && + fix_kind_eq kn1 kn2 && Array.equal Id.equal id1 id2 && Array.equal (fun l1 l2 -> List.equal (glob_decl_eq f) l1 l2) decl1 decl2 && Array.equal f c1 c2 && Array.equal f t1 t2 | GSort s1, GSort s2 -> glob_sort_eq s1 s2 diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index c57cf88cc6..02cb294f6d 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -41,6 +41,12 @@ type glob_constraint = glob_level * Univ.constraint_type * glob_level type sort_info = (Libnames.qualid * int) option list type glob_sort = sort_info glob_sort_gen +type glob_recarg = int option + +and glob_fix_kind = + | GFix of (glob_recarg array * int) + | GCoFix of int + (** Casts *) type 'a cast_type = @@ -78,7 +84,7 @@ type 'a glob_constr_r = (** [GCases(style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in [MatchStyle]) *) | GLetTuple of Name.t list * (Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g | GIf of 'a glob_constr_g * (Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g - | GRec of 'a fix_kind_g * Id.t array * 'a glob_decl_g list array * + | GRec of glob_fix_kind * Id.t array * 'a glob_decl_g list array * 'a glob_constr_g array * 'a glob_constr_g array | GSort of glob_sort | GHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option @@ -88,15 +94,6 @@ and 'a glob_constr_g = ('a glob_constr_r, 'a) DAst.t and 'a glob_decl_g = Name.t * binding_kind * 'a glob_constr_g option * 'a glob_constr_g -and 'a fix_recursion_order_g = - | GStructRec - | GWfRec of 'a glob_constr_g - | GMeasureRec of 'a glob_constr_g * 'a glob_constr_g option - -and 'a fix_kind_g = - | GFix of ((int option * 'a fix_recursion_order_g) array * int) - | GCoFix of int - and 'a predicate_pattern_g = Name.t * (inductive * Name.t list) CAst.t option (** [(na,id)] = "as 'na' in 'id'" where if [id] is [Some(l,I,k,args)]. *) @@ -117,9 +114,7 @@ type tomatch_tuples = [ `any ] tomatch_tuples_g type cases_clause = [ `any ] cases_clause_g type cases_clauses = [ `any ] cases_clauses_g type glob_decl = [ `any ] glob_decl_g -type fix_kind = [ `any ] fix_kind_g type predicate_pattern = [ `any ] predicate_pattern_g -type fix_recursion_order = [ `any ] fix_recursion_order_g type any_glob_constr = AnyGlobConstr : 'r glob_constr_g -> any_glob_constr diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 0003fc7280..e694502231 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -492,25 +492,23 @@ let native_norm env sigma c ty = Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1); Format.eprintf "Numbers of free variables (rel): %i\n" (List.length vl2); *) - let ml_filename, prefix = Nativelib.get_ml_filename () in - let code, upd = mk_norm_code env (evars_of_evar_map sigma) prefix c in - let profile = get_profiling_enabled () in - match Nativelib.compile ml_filename code ~profile:profile with - | true, fn -> - if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ..."); - let profiler_pid = if profile then start_profiler () else None in - let t0 = Sys.time () in - Nativelib.call_linker ~fatal:true prefix fn (Some upd); - let t1 = Sys.time () in - if profile then stop_profiler profiler_pid; - let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); - let res = nf_val env sigma !Nativelib.rt1 ty in - let t2 = Sys.time () in - let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); - EConstr.of_constr res - | _ -> anomaly (Pp.str "Compilation failure.") + let ml_filename, prefix = Nativelib.get_ml_filename () in + let code, upd = mk_norm_code env (evars_of_evar_map sigma) prefix c in + let profile = get_profiling_enabled () in + let fn = Nativelib.compile ml_filename code ~profile:profile in + if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ..."); + let profiler_pid = if profile then start_profiler () else None in + let t0 = Sys.time () in + Nativelib.call_linker ~fatal:true prefix fn (Some upd); + let t1 = Sys.time () in + if profile then stop_profiler profiler_pid; + let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in + if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + let res = nf_val env sigma !Nativelib.rt1 ty in + let t2 = Sys.time () in + let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in + if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + EConstr.of_constr res let native_conv_generic pb sigma t = Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index b29afd1fd2..c788efda48 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -470,17 +470,19 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function PCase (info, pred, pat_of_raw metas vars c, brs) | GRec (GFix (ln,n), ids, decls, tl, cl) -> - if Array.exists (function (Some n, GStructRec) -> false | _ -> true) ln then - err ?loc (Pp.str "\"struct\" annotation is expected.") - else - let ln = Array.map (fst %> Option.get) ln in - let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls tl in - let tl = Array.map (fun (ctx,tl) -> it_mkPProd_or_LetIn tl ctx) ctxtl in - let vars = Array.fold_left (fun vars na -> Name na::vars) vars ids in - let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls cl in - let cl = Array.map (fun (ctx,cl) -> it_mkPLambda_or_LetIn cl ctx) ctxtl in - let names = Array.map (fun id -> Name id) ids in - PFix ((ln,n), (names, tl, cl)) + let get_struct_arg = function + | Some n -> n + | None -> err ?loc (Pp.str "\"struct\" annotation is expected.") + (* TODO why can't the annotation be omitted? *) + in + let ln = Array.map get_struct_arg ln in + let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls tl in + let tl = Array.map (fun (ctx,tl) -> it_mkPProd_or_LetIn tl ctx) ctxtl in + let vars = Array.fold_left (fun vars na -> Name na::vars) vars ids in + let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls cl in + let cl = Array.map (fun (ctx,cl) -> it_mkPLambda_or_LetIn cl ctx) ctxtl in + let names = Array.map (fun id -> Name id) ids in + PFix ((ln,n), (names, tl, cl)) | GRec (GCoFix n, ids, decls, tl, cl) -> let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls tl in diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 0f7676cd19..48d981082c 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -607,10 +607,10 @@ let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env fixpoints ?) *) let possible_indexes = Array.to_list (Array.mapi - (fun i (n,_) -> match n with + (fun i annot -> match annot with | Some n -> [n] | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) - vn) + vn) in let fixdecls = (names,ftys,fdefs) in let indexes = esearch_guard ?loc !!env sigma possible_indexes fixdecls in diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 71fbfe8716..1871609e18 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -53,7 +53,7 @@ type effect_name = string let constant_effect_table = Summary.ref ~name:"reduction-side-effect" Cmap.empty (* Table bindings function key to effective functions *) -let effect_table = Summary.ref ~name:"reduction-function-effect" String.Map.empty +let effect_table = ref String.Map.empty (** a test to know whether a constant is actually the effect function *) let reduction_effect_hook env sigma con c = diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 0ae3de7321..78733784a7 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -399,12 +399,12 @@ let tag_var = tag Tag.variable pr_opt_type_spc pr t ++ str " :=" ++ pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c - let pr_guard_annot pr_aux bl (n,ro) = - match n with + let pr_guard_annot pr_aux bl ro = + match ro with | None -> mt () - | Some {loc; v = id} -> - match (ro : Constrexpr.recursion_order_expr) with - | CStructRec -> + | Some {loc; v = ro} -> + match ro with + | CStructRec { v = id } -> let names_of_binder = function | CLocalAssum (nal,_,_) -> nal | CLocalDef (_,_,_) -> [] @@ -413,10 +413,11 @@ let tag_var = tag Tag.variable if List.length ids > 1 then spc() ++ str "{" ++ keyword "struct" ++ spc () ++ pr_id id ++ str"}" else mt() - | CWfRec c -> - spc() ++ str "{" ++ keyword "wf" ++ spc () ++ pr_aux c ++ spc() ++ pr_id id ++ str"}" - | CMeasureRec (m,r) -> - spc() ++ str "{" ++ keyword "measure" ++ spc () ++ pr_aux m ++ spc() ++ pr_id id++ + | CWfRec (id,c) -> + spc() ++ str "{" ++ keyword "wf" ++ spc () ++ pr_aux c ++ spc() ++ pr_lident id ++ str"}" + | CMeasureRec (id,m,r) -> + spc() ++ str "{" ++ keyword "measure" ++ spc () ++ pr_aux m ++ + match id with None -> mt() | Some id -> spc () ++ pr_lident id ++ (match r with None -> mt() | Some r -> str" on " ++ pr_aux r) ++ str"}" let pr_fixdecl pr prd dangling_with_for ({v=id},ro,bl,t,c) = diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index db1687a49b..1332cd0168 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -35,10 +35,11 @@ val pr_patvar : Pattern.patvar -> Pp.t val pr_glob_level : Glob_term.glob_level -> Pp.t val pr_glob_sort : Glob_term.glob_sort -> Pp.t -val pr_guard_annot : (constr_expr -> Pp.t) -> - local_binder_expr list -> - lident option * recursion_order_expr -> - Pp.t +val pr_guard_annot + : (constr_expr -> Pp.t) + -> local_binder_expr list + -> recursion_order_expr option + -> Pp.t val pr_record_body : (qualid * constr_expr) list -> Pp.t val pr_binders : Environ.env -> Evd.evar_map -> local_binder_expr list -> Pp.t diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index d042a1d650..f378a5d2dd 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -438,18 +438,18 @@ let match_goals ot nt = | _, _ -> raise (Diff_Failure "Unable to match goals between old and new proof states (2)") in let recursion_order_expr ogname exp exp2 = - match exp, exp2 with - | CStructRec, CStructRec -> () - | CWfRec c, CWfRec c2 -> + match exp.CAst.v, exp2.CAst.v with + | CStructRec _, CStructRec _ -> () + | CWfRec (_,c), CWfRec (_,c2) -> constr_expr ogname c c2 - | CMeasureRec (m,r), CMeasureRec (m2,r2) -> + | CMeasureRec (_,m,r), CMeasureRec (_,m2,r2) -> constr_expr ogname m m2; constr_expr_opt ogname r r2 | _, _ -> raise (Diff_Failure "Unable to match goals between old and new proof states (3)") in let fix_expr ogname exp exp2 = - let (l,(lo,ro),lb,ce1,ce2), (l2,(lo2,ro2),lb2,ce12,ce22) = exp,exp2 in - recursion_order_expr ogname ro ro2; + let (l,ro,lb,ce1,ce2), (l2,ro2,lb2,ce12,ce22) = exp,exp2 in + Option.iter2 (recursion_order_expr ogname) ro ro2; iter2 (local_binder_expr ogname) lb lb2; constr_expr ogname ce1 ce12; constr_expr ogname ce2 ce22 diff --git a/stm/stm.ml b/stm/stm.ml index d54a5fdf43..e1ab45163a 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2970,7 +2970,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) "Nested proofs are not allowed unless you turn option Nested Proofs Allowed on." |> Pp.str |> (fun s -> (UserError (None, s), Exninfo.null)) - |> State.exn_on ~valid:Stateid.dummy Stateid.dummy + |> State.exn_on ~valid:Stateid.dummy newtip |> Exninfo.iraise else @@ -3054,7 +3054,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) "Commands which may open proofs are not allowed in a proof unless you turn option Nested Proofs Allowed on." |> Pp.str |> (fun s -> (UserError (None, s), Exninfo.null)) - |> State.exn_on ~valid:Stateid.dummy Stateid.dummy + |> State.exn_on ~valid:Stateid.dummy newtip |> Exninfo.iraise else let id = VCS.new_node ~id:newtip proof_mode () in diff --git a/test-suite/success/ProgramWf.v b/test-suite/success/ProgramWf.v index 85d7a770fc..02adb012d9 100644 --- a/test-suite/success/ProgramWf.v +++ b/test-suite/success/ProgramWf.v @@ -13,7 +13,7 @@ Print sigT_rect. Obligation Tactic := program_simplify ; auto with *. About MR. -Program Fixpoint merge (n m : nat) {measure (n + m) (lt)} : nat := +Program Fixpoint merge (n m : nat) {measure (n + m) lt} : nat := match n with | 0 => 0 | S n' => merge n' m @@ -101,5 +101,5 @@ Next Obligation. simpl in *; intros. Qed. Program Fixpoint check_n' (n : nat) (m : {m:nat | m = n}) (p : nat) (q:{q : nat | q = p}) - {measure (p - n) p} : nat := + {measure (p - n)} : nat := _. diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 2aadbd224f..1912646ffd 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -329,16 +329,27 @@ let declare_cofixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,c List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; pstate -let extract_decreasing_argument limit = function - | (na,CStructRec) -> na - | (na,_) when not limit -> na +let extract_decreasing_argument ~structonly = function { CAst.v = v } -> match v with + | CStructRec na -> na + | (CWfRec (na,_) | CMeasureRec (Some na,_,_)) when not structonly -> na + | CMeasureRec (None,_,_) when not structonly -> + user_err Pp.(str "Decreasing argument must be specificed in measure clause.") | _ -> user_err Pp.(str - "Only structural decreasing is supported for a non-Program Fixpoint") + "Well-founded induction requires Program Fixpoint or Function.") -let extract_fixpoint_components limit l = +let extract_fixpoint_components ~structonly l = let fixl, ntnl = List.split l in let fixl = List.map (fun (({CAst.v=id},pl),ann,bl,typ,def) -> - let ann = extract_decreasing_argument limit ann in + (* This is a special case: if there's only one binder, we pick it as the + recursive argument if none is provided. *) + let ann = Option.map (fun ann -> match bl, ann with + | [CLocalAssum([{ CAst.v = Name x }],_,_)], { CAst.v = CMeasureRec(None, mes, rel); CAst.loc } -> + CAst.make ?loc @@ CMeasureRec(Some (CAst.make x), mes, rel) + | [CLocalDef({ CAst.v = Name x },_,_)], { CAst.v = CMeasureRec(None, mes, rel); CAst.loc } -> + CAst.make ?loc @@ CMeasureRec(Some (CAst.make x), mes, rel) + | _, x -> x) ann + in + let ann = Option.map (extract_decreasing_argument ~structonly) ann in {fix_name = id; fix_annot = ann; fix_univs = pl; fix_binders = bl; fix_body = def; fix_type = typ}) fixl in fixl, List.flatten ntnl @@ -356,7 +367,7 @@ let check_safe () = flags.check_universes && flags.check_guarded let do_fixpoint ~ontop local poly l = - let fixl, ntns = extract_fixpoint_components true l in + let fixl, ntns = extract_fixpoint_components ~structonly:true l in let (_, _, _, info as fix) = interp_fixpoint ~cofix:false fixl ntns in let possible_indexes = List.map compute_possible_guardness_evidences info in diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 15ff5f4498..5937842f17 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -62,7 +62,7 @@ val interp_recursive : (** Extracting the semantical components out of the raw syntax of (co)fixpoints declarations *) -val extract_fixpoint_components : bool -> +val extract_fixpoint_components : structonly:bool -> (fixpoint_expr * decl_notation list) list -> structured_fixpoint_expr list * decl_notation list diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 350b2d2945..20a2db7ca2 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -85,7 +85,7 @@ let rec telescope sigma l = let nf_evar_context sigma ctx = List.map (map_constr (fun c -> Evarutil.nf_evar sigma c)) ctx -let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = +let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let open EConstr in let open Vars in let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in @@ -304,22 +304,26 @@ let do_program_recursive local poly fixkind fixl ntns = let do_program_fixpoint local poly l = let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in match g, l with - | [(n, CWfRec r)], [((({CAst.v=id},pl),_,bl,typ,def),ntn)] -> - let recarg = - match n with - | Some n -> mkIdentC n.CAst.v - | None -> - user_err ~hdr:"do_program_fixpoint" - (str "Recursive argument required for well-founded fixpoints") - in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn + | [Some { CAst.v = CWfRec (n,r) }], [((({CAst.v=id},pl),_,bl,typ,def),ntn)] -> + let recarg = mkIdentC n.CAst.v in + build_wellfounded (id, pl, bl, typ, out_def def) poly r recarg ntn - | [(n, CMeasureRec (m, r))], [((({CAst.v=id},pl),_,bl,typ,def),ntn)] -> - build_wellfounded (id, pl, n, bl, typ, out_def def) poly + | [Some { CAst.v = CMeasureRec (n, m, r) }], [((({CAst.v=id},pl),_,bl,typ,def),ntn)] -> + (* We resolve here a clash between the syntax of Program Fixpoint and the one of funind *) + let r = match n, r with + | Some id, None -> + let loc = id.CAst.loc in + Some (CAst.make ?loc @@ CRef(qualid_of_ident ?loc id.CAst.v,None)) + | Some _, Some _ -> + user_err Pp.(str"Measure takes only two arguments in Program Fixpoint.") + | _, _ -> r + in + build_wellfounded (id, pl, bl, typ, out_def def) poly (Option.default (CAst.make @@ CRef (lt_ref,None)) r) m ntn - | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g -> - let fixl,ntns = extract_fixpoint_components true l in - let fixkind = Obligations.IsFixpoint g in + | _, _ when List.for_all (fun ro -> match ro with None | Some { CAst.v = CStructRec _} -> true | _ -> false) g -> + let fixl,ntns = extract_fixpoint_components ~structonly:true l in + let fixkind = Obligations.IsFixpoint (List.map (fun d -> d.fix_annot) fixl) in do_program_recursive local poly fixkind fixl ntns | _, _ -> diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 07194578c1..1b1c618dc7 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -295,7 +295,7 @@ type obligation = type obligations = (obligation array * int) type fixpoint_kind = - | IsFixpoint of (lident option * Constrexpr.recursion_order_expr) list + | IsFixpoint of lident option list | IsCoFixpoint type notations = (lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list @@ -486,7 +486,7 @@ let rec lam_index n t acc = lam_index n b (succ acc) | _ -> raise Not_found -let compute_possible_guardness_evidences (n,_) fixbody fixtype = +let compute_possible_guardness_evidences n fixbody fixtype = match n with | Some { CAst.loc; v = n } -> [lam_index n fixbody 0] | None -> diff --git a/vernac/obligations.mli b/vernac/obligations.mli index b1b7b1ec90..d25daeed9c 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -70,7 +70,7 @@ type notations = (lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list type fixpoint_kind = - | IsFixpoint of (lident option * Constrexpr.recursion_order_expr) list + | IsFixpoint of lident option list | IsCoFixpoint val add_mutual_definitions : diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index d5f4576ea2..d0dae1aa53 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -129,7 +129,7 @@ type definition_expr = * constr_expr option type fixpoint_expr = - ident_decl * (lident option * recursion_order_expr) * local_binder_expr list * constr_expr * constr_expr option + ident_decl * recursion_order_expr option * local_binder_expr list * constr_expr * constr_expr option type cofixpoint_expr = ident_decl * local_binder_expr list * constr_expr * constr_expr option |