diff options
Diffstat (limited to 'tests')
31 files changed, 4382 insertions, 18 deletions
diff --git a/tests/examplefiles/coq_RelationClasses b/tests/examplefiles/coq_RelationClasses new file mode 100644 index 00000000..94c51bf1 --- /dev/null +++ b/tests/examplefiles/coq_RelationClasses @@ -0,0 +1,447 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** * Typeclass-based relations, tactics and standard instances + + This is the basic theory needed to formalize morphisms and setoids. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - University Paris Sud +*) + +(* $Id: RelationClasses.v 14641 2011-11-06 11:59:10Z herbelin $ *) + +Require Export Coq.Classes.Init. +Require Import Coq.Program.Basics. +Require Import Coq.Program.Tactics. +Require Import Coq.Relations.Relation_Definitions. + +(** We allow to unfold the [relation] definition while doing morphism search. *) + +Notation inverse R := (flip (R:relation _) : relation _). + +Definition complement {A} (R : relation A) : relation A := fun x y => R x y -> False. + +(** Opaque for proof-search. *) +Typeclasses Opaque complement. + +(** These are convertible. *) + +Lemma complement_inverse : forall A (R : relation A), complement (inverse R) = inverse (complement R). +Proof. reflexivity. Qed. + +(** We rebind relations in separate classes to be able to overload each proof. *) + +Set Implicit Arguments. +Unset Strict Implicit. + +Class Reflexive {A} (R : relation A) := + reflexivity : forall x, R x x. + +Class Irreflexive {A} (R : relation A) := + irreflexivity : Reflexive (complement R). + +Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances. + +Class Symmetric {A} (R : relation A) := + symmetry : forall x y, R x y -> R y x. + +Class Asymmetric {A} (R : relation A) := + asymmetry : forall x y, R x y -> R y x -> False. + +Class Transitive {A} (R : relation A) := + transitivity : forall x y z, R x y -> R y z -> R x z. + +Hint Resolve @irreflexivity : ord. + +Unset Implicit Arguments. + +(** A HintDb for relations. *) + +Ltac solve_relation := + match goal with + | [ |- ?R ?x ?x ] => reflexivity + | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H + end. + +Hint Extern 4 => solve_relation : relations. + +(** We can already dualize all these properties. *) + +Generalizable Variables A B C D R S T U l eqA eqB eqC eqD. + +Lemma flip_Reflexive `{Reflexive A R} : Reflexive (flip R). +Proof. tauto. Qed. + +Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. + +Program Definition flip_Irreflexive `(Irreflexive A R) : Irreflexive (flip R) := + irreflexivity (R:=R). + +Program Definition flip_Symmetric `(Symmetric A R) : Symmetric (flip R) := + fun x y H => symmetry (R:=R) H. + +Program Definition flip_Asymmetric `(Asymmetric A R) : Asymmetric (flip R) := + fun x y H H' => asymmetry (R:=R) H H'. + +Program Definition flip_Transitive `(Transitive A R) : Transitive (flip R) := + fun x y z H H' => transitivity (R:=R) H' H. + +Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. +Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. +Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. +Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. + +Definition Reflexive_complement_Irreflexive `(Reflexive A (R : relation A)) + : Irreflexive (complement R). +Proof. firstorder. Qed. + +Definition complement_Symmetric `(Symmetric A (R : relation A)) : Symmetric (complement R). +Proof. firstorder. Qed. + +Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. +Hint Extern 3 (Irreflexive (complement _)) => class_apply Reflexive_complement_Irreflexive : typeclass_instances. + +(** * Standard instances. *) + +Ltac reduce_hyp H := + match type of H with + | context [ _ <-> _ ] => fail 1 + | _ => red in H ; try reduce_hyp H + end. + +Ltac reduce_goal := + match goal with + | [ |- _ <-> _ ] => fail 1 + | _ => red ; intros ; try reduce_goal + end. + +Tactic Notation "reduce" "in" hyp(Hid) := reduce_hyp Hid. + +Ltac reduce := reduce_goal. + +Tactic Notation "apply" "*" constr(t) := + first [ refine t | refine (t _) | refine (t _ _) | refine (t _ _ _) | refine (t _ _ _ _) | + refine (t _ _ _ _ _) | refine (t _ _ _ _ _ _) | refine (t _ _ _ _ _ _ _) ]. + +Ltac simpl_relation := + unfold flip, impl, arrow ; try reduce ; program_simpl ; + try ( solve [ intuition ]). + +Local Obligation Tactic := simpl_relation. + +(** Logical implication. *) + +Program Instance impl_Reflexive : Reflexive impl. +Program Instance impl_Transitive : Transitive impl. + +(** Logical equivalence. *) + +Program Instance iff_Reflexive : Reflexive iff. +Program Instance iff_Symmetric : Symmetric iff. +Program Instance iff_Transitive : Transitive iff. + +(** Leibniz equality. *) + +Instance eq_Reflexive {A} : Reflexive (@eq A) := @eq_refl A. +Instance eq_Symmetric {A} : Symmetric (@eq A) := @eq_sym A. +Instance eq_Transitive {A} : Transitive (@eq A) := @eq_trans A. + +(** Various combinations of reflexivity, symmetry and transitivity. *) + +(** A [PreOrder] is both Reflexive and Transitive. *) + +Class PreOrder {A} (R : relation A) : Prop := { + PreOrder_Reflexive :> Reflexive R ; + PreOrder_Transitive :> Transitive R }. + +(** A partial equivalence relation is Symmetric and Transitive. *) + +Class PER {A} (R : relation A) : Prop := { + PER_Symmetric :> Symmetric R ; + PER_Transitive :> Transitive R }. + +(** Equivalence relations. *) + +Class Equivalence {A} (R : relation A) : Prop := { + Equivalence_Reflexive :> Reflexive R ; + Equivalence_Symmetric :> Symmetric R ; + Equivalence_Transitive :> Transitive R }. + +(** An Equivalence is a PER plus reflexivity. *) + +Instance Equivalence_PER `(Equivalence A R) : PER R | 10 := + { PER_Symmetric := Equivalence_Symmetric ; + PER_Transitive := Equivalence_Transitive }. + +(** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *) + +Class Antisymmetric A eqA `{equ : Equivalence A eqA} (R : relation A) := + antisymmetry : forall {x y}, R x y -> R y x -> eqA x y. + +Program Definition flip_antiSymmetric `(Antisymmetric A eqA R) : + Antisymmetric A eqA (flip R). +Proof. firstorder. Qed. + +(** Leibinz equality [eq] is an equivalence relation. + The instance has low priority as it is always applicable + if only the type is constrained. *) + +Program Instance eq_equivalence : Equivalence (@eq A) | 10. + +(** Logical equivalence [iff] is an equivalence relation. *) + +Program Instance iff_equivalence : Equivalence iff. + +(** We now develop a generalization of results on relations for arbitrary predicates. + The resulting theory can be applied to homogeneous binary relations but also to + arbitrary n-ary predicates. *) + +Local Open Scope list_scope. + +(* Notation " [ ] " := nil : list_scope. *) +(* Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) (at level 1) : list_scope. *) + +(** A compact representation of non-dependent arities, with the codomain singled-out. *) + +Fixpoint arrows (l : list Type) (r : Type) : Type := + match l with + | nil => r + | A :: l' => A -> arrows l' r + end. + +(** We can define abbreviations for operation and relation types based on [arrows]. *) + +Definition unary_operation A := arrows (A::nil) A. +Definition binary_operation A := arrows (A::A::nil) A. +Definition ternary_operation A := arrows (A::A::A::nil) A. + +(** We define n-ary [predicate]s as functions into [Prop]. *) + +Notation predicate l := (arrows l Prop). + +(** Unary predicates, or sets. *) + +Definition unary_predicate A := predicate (A::nil). + +(** Homogeneous binary relations, equivalent to [relation A]. *) + +Definition binary_relation A := predicate (A::A::nil). + +(** We can close a predicate by universal or existential quantification. *) + +Fixpoint predicate_all (l : list Type) : predicate l -> Prop := + match l with + | nil => fun f => f + | A :: tl => fun f => forall x : A, predicate_all tl (f x) + end. + +Fixpoint predicate_exists (l : list Type) : predicate l -> Prop := + match l with + | nil => fun f => f + | A :: tl => fun f => exists x : A, predicate_exists tl (f x) + end. + +(** Pointwise extension of a binary operation on [T] to a binary operation + on functions whose codomain is [T]. + For an operator on [Prop] this lifts the operator to a binary operation. *) + +Fixpoint pointwise_extension {T : Type} (op : binary_operation T) + (l : list Type) : binary_operation (arrows l T) := + match l with + | nil => fun R R' => op R R' + | A :: tl => fun R R' => + fun x => pointwise_extension op tl (R x) (R' x) + end. + +(** Pointwise lifting, equivalent to doing [pointwise_extension] and closing using [predicate_all]. *) + +Fixpoint pointwise_lifting (op : binary_relation Prop) (l : list Type) : binary_relation (predicate l) := + match l with + | nil => fun R R' => op R R' + | A :: tl => fun R R' => + forall x, pointwise_lifting op tl (R x) (R' x) + end. + +(** The n-ary equivalence relation, defined by lifting the 0-ary [iff] relation. *) + +Definition predicate_equivalence {l : list Type} : binary_relation (predicate l) := + pointwise_lifting iff l. + +(** The n-ary implication relation, defined by lifting the 0-ary [impl] relation. *) + +Definition predicate_implication {l : list Type} := + pointwise_lifting impl l. + +(** Notations for pointwise equivalence and implication of predicates. *) + +Infix "<∙>" := predicate_equivalence (at level 95, no associativity) : predicate_scope. +Infix "-∙>" := predicate_implication (at level 70, right associativity) : predicate_scope. + +Open Local Scope predicate_scope. + +(** The pointwise liftings of conjunction and disjunctions. + Note that these are [binary_operation]s, building new relations out of old ones. *) + +Definition predicate_intersection := pointwise_extension and. +Definition predicate_union := pointwise_extension or. + +Infix "/∙\" := predicate_intersection (at level 80, right associativity) : predicate_scope. +Infix "\∙/" := predicate_union (at level 85, right associativity) : predicate_scope. + +(** The always [True] and always [False] predicates. *) + +Fixpoint true_predicate {l : list Type} : predicate l := + match l with + | nil => True + | A :: tl => fun _ => @true_predicate tl + end. + +Fixpoint false_predicate {l : list Type} : predicate l := + match l with + | nil => False + | A :: tl => fun _ => @false_predicate tl + end. + +Notation "∙⊤∙" := true_predicate : predicate_scope. +Notation "∙⊥∙" := false_predicate : predicate_scope. + +(** Predicate equivalence is an equivalence, and predicate implication defines a preorder. *) + +Program Instance predicate_equivalence_equivalence : Equivalence (@predicate_equivalence l). + Next Obligation. + induction l ; firstorder. + Qed. + Next Obligation. + induction l ; firstorder. + Qed. + Next Obligation. + fold pointwise_lifting. + induction l. firstorder. + intros. simpl in *. pose (IHl (x x0) (y x0) (z x0)). + firstorder. + Qed. + +Program Instance predicate_implication_preorder : + PreOrder (@predicate_implication l). + Next Obligation. + induction l ; firstorder. + Qed. + Next Obligation. + induction l. firstorder. + unfold predicate_implication in *. simpl in *. + intro. pose (IHl (x x0) (y x0) (z x0)). firstorder. + Qed. + +(** We define the various operations which define the algebra on binary relations, + from the general ones. *) + +Definition relation_equivalence {A : Type} : relation (relation A) := + @predicate_equivalence (_::_::nil). + +Class subrelation {A:Type} (R R' : relation A) : Prop := + is_subrelation : @predicate_implication (A::A::nil) R R'. + +Implicit Arguments subrelation [[A]]. + +Definition relation_conjunction {A} (R : relation A) (R' : relation A) : relation A := + @predicate_intersection (A::A::nil) R R'. + +Definition relation_disjunction {A} (R : relation A) (R' : relation A) : relation A := + @predicate_union (A::A::nil) R R'. + +(** Relation equivalence is an equivalence, and subrelation defines a partial order. *) + +Set Automatic Introduction. + +Instance relation_equivalence_equivalence (A : Type) : + Equivalence (@relation_equivalence A). +Proof. exact (@predicate_equivalence_equivalence (A::A::nil)). Qed. + +Instance relation_implication_preorder A : PreOrder (@subrelation A). +Proof. exact (@predicate_implication_preorder (A::A::nil)). Qed. + +(** *** Partial Order. + A partial order is a preorder which is additionally antisymmetric. + We give an equivalent definition, up-to an equivalence relation + on the carrier. *) + +Class PartialOrder {A} eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} := + partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (inverse R)). + +(** The equivalence proof is sufficient for proving that [R] must be a morphism + for equivalence (see Morphisms). + It is also sufficient to show that [R] is antisymmetric w.r.t. [eqA] *) + +Instance partial_order_antisym `(PartialOrder A eqA R) : ! Antisymmetric A eqA R. +Proof with auto. + reduce_goal. + pose proof partial_order_equivalence as poe. do 3 red in poe. + apply <- poe. firstorder. +Qed. + +(** The partial order defined by subrelation and relation equivalence. *) + +Program Instance subrelation_partial_order : + ! PartialOrder (relation A) relation_equivalence subrelation. + + Next Obligation. + Proof. + unfold relation_equivalence in *. firstorder. + Qed. + +Typeclasses Opaque arrows predicate_implication predicate_equivalence + relation_equivalence pointwise_lifting. + +(** Rewrite relation on a given support: declares a relation as a rewrite + relation for use by the generalized rewriting tactic. + It helps choosing if a rewrite should be handled + by the generalized or the regular rewriting tactic using leibniz equality. + Users can declare an [RewriteRelation A RA] anywhere to declare default + relations. This is also done automatically by the [Declare Relation A RA] + commands. *) + +Class RewriteRelation {A : Type} (RA : relation A). + +Instance: RewriteRelation impl. +Instance: RewriteRelation iff. +Instance: RewriteRelation (@relation_equivalence A). + +(** Any [Equivalence] declared in the context is automatically considered + a rewrite relation. *) + +Instance equivalence_rewrite_relation `(Equivalence A eqA) : RewriteRelation eqA. + +(** Strict Order *) + +Class StrictOrder {A : Type} (R : relation A) := { + StrictOrder_Irreflexive :> Irreflexive R ; + StrictOrder_Transitive :> Transitive R +}. + +Instance StrictOrder_Asymmetric `(StrictOrder A R) : Asymmetric R. +Proof. firstorder. Qed. + +(** Inversing a [StrictOrder] gives another [StrictOrder] *) + +Lemma StrictOrder_inverse `(StrictOrder A R) : StrictOrder (inverse R). +Proof. firstorder. Qed. + +(** Same for [PartialOrder]. *) + +Lemma PreOrder_inverse `(PreOrder A R) : PreOrder (inverse R). +Proof. firstorder. Qed. + +Hint Extern 3 (StrictOrder (inverse _)) => class_apply StrictOrder_inverse : typeclass_instances. +Hint Extern 3 (PreOrder (inverse _)) => class_apply PreOrder_inverse : typeclass_instances. + +Lemma PartialOrder_inverse `(PartialOrder A eqA R) : PartialOrder eqA (inverse R). +Proof. firstorder. Qed. + +Hint Extern 3 (PartialOrder (inverse _)) => class_apply PartialOrder_inverse : typeclass_instances. diff --git a/tests/examplefiles/example.cls b/tests/examplefiles/example.cls new file mode 100644 index 00000000..d36ad6f0 --- /dev/null +++ b/tests/examplefiles/example.cls @@ -0,0 +1,15 @@ +USING Progress.Lang.*. + +CLASS Test INHERITS Progress.Sucks: + + DEFINE PRIVATE VARIABLE cTest AS CHAR NO-UNDO. + + CONSTRUCTOR PUBLIC Test(): + SUPER(). + MESSAGE "Why are you punishing yourself by coding in this language?". + END CONSTRUCTOR. + + METHOD PUBLIC LOGICAL Blowup(INPUT iTime AS INT): + END. + +END CLASS. diff --git a/tests/examplefiles/example.moon b/tests/examplefiles/example.moon new file mode 100644 index 00000000..d4415e32 --- /dev/null +++ b/tests/examplefiles/example.moon @@ -0,0 +1,629 @@ +-- transform.moon +-- Leaf Corcoran (leafot@gmail.com) 2011 +-- +-- This is part of the MoonScript compiler. See <http://moonscript.org> +-- MoonScript is licensed under the MIT License +-- + +module "moonscript.transform", package.seeall + +types = require "moonscript.types" +util = require "moonscript.util" +data = require "moonscript.data" + +import reversed from util +import ntype, build, smart_node, is_slice from types +import insert from table + +export Statement, Value, NameProxy, LocalName, Run + +-- always declares as local +class LocalName + new: (@name) => self[1] = "temp_name" + get_name: => @name + +class NameProxy + new: (@prefix) => + self[1] = "temp_name" + + get_name: (scope) => + if not @name + @name = scope\free_name @prefix, true + @name + + chain: (...) => + items = {...} -- todo: fix ... propagation + items = for i in *items + if type(i) == "string" + {"dot", i} + else + i + + build.chain { + base: self + unpack items + } + + index: (key) => + build.chain { + base: self, {"index", key} + } + + __tostring: => + if @name + ("name<%s>")\format @name + else + ("name<prefix(%s)>")\format @prefix + +class Run + new: (@fn) => + self[1] = "run" + + call: (state) => + self.fn state + +-- transform the last stm is a list of stms +-- will puke on group +apply_to_last = (stms, fn) -> + -- find last (real) exp + last_exp_id = 0 + for i = #stms, 1, -1 + stm = stms[i] + if stm and util.moon.type(stm) != Run + last_exp_id = i + break + + return for i, stm in ipairs stms + if i == last_exp_id + fn stm + else + stm + +-- is a body a sindle expression/statement +is_singular = (body) -> + return false if #body != 1 + if "group" == ntype body + is_singular body[2] + else + true + +constructor_name = "new" + +class Transformer + new: (@transformers, @scope) => + @seen_nodes = {} + + transform: (scope, node, ...) => + -- print scope, node, ... + return node if @seen_nodes[node] + @seen_nodes[node] = true + while true + transformer = @transformers[ntype node] + res = if transformer + transformer(scope, node, ...) or node + else + node + return node if res == node + node = res + + __call: (node, ...) => + @transform @scope, node, ... + + instance: (scope) => + Transformer @transformers, scope + + can_transform: (node) => + @transformers[ntype node] != nil + +construct_comprehension = (inner, clauses) -> + current_stms = inner + for _, clause in reversed clauses + t = clause[1] + current_stms = if t == "for" + _, names, iter = unpack clause + {"foreach", names, iter, current_stms} + elseif t == "when" + _, cond = unpack clause + {"if", cond, current_stms} + else + error "Unknown comprehension clause: "..t + current_stms = {current_stms} + + current_stms[1] + +Statement = Transformer { + assign: (node) => + _, names, values = unpack node + -- bubble cascading assigns + if #values == 1 and types.cascading[ntype values[1]] + values[1] = @transform.statement values[1], (stm) -> + t = ntype stm + if types.is_value stm + {"assign", names, {stm}} + else + stm + + build.group { + {"declare", names} + values[1] + } + else + node + + export: (node) => + -- assign values if they are included + if #node > 2 + if node[2] == "class" + cls = smart_node node[3] + build.group { + {"export", {cls.name}} + cls + } + else + build.group { + node + build.assign { + names: node[2] + values: node[3] + } + } + else + nil + + update: (node) => + _, name, op, exp = unpack node + op_final = op\match "^(.+)=$" + error "Unknown op: "..op if not op_final + build.assign_one name, {"exp", name, op_final, exp} + + import: (node) => + _, names, source = unpack node + + stubs = for name in *names + if type(name) == "table" + name + else + {"dot", name} + + real_names = for name in *names + type(name) == "table" and name[2] or name + + if type(source) == "string" + build.assign { + names: real_names + values: [build.chain { base: source, stub} for stub in *stubs] + } + else + source_name = NameProxy "table" + build.group { + {"declare", real_names} + build["do"] { + build.assign_one source_name, source + build.assign { + names: real_names + values: [build.chain { base: source_name, stub} for stub in *stubs] + } + } + } + + comprehension: (node, action) => + _, exp, clauses = unpack node + + action = action or (exp) -> {exp} + construct_comprehension action(exp), clauses + + -- handle cascading return decorator + if: (node, ret) => + if ret + smart_node node + -- mutate all the bodies + node['then'] = apply_to_last node['then'], ret + for i = 4, #node + case = node[i] + body_idx = #node[i] + case[body_idx] = apply_to_last case[body_idx], ret + node + + with: (node, ret) => + _, exp, block = unpack node + scope_name = NameProxy "with" + build["do"] { + build.assign_one scope_name, exp + Run => @set "scope_var", scope_name + build.group block + if ret + ret scope_name + } + + foreach: (node) => + smart_node node + if ntype(node.iter) == "unpack" + list = node.iter[2] + + index_name = NameProxy "index" + list_name = NameProxy "list" + + slice_var = nil + bounds = if is_slice list + slice = list[#list] + table.remove list + table.remove slice, 1 + + slice[2] = if slice[2] and slice[2] != "" + max_tmp_name = NameProxy "max" + slice_var = build.assign_one max_tmp_name, slice[2] + {"exp", max_tmp_name, "<", 0 + "and", {"length", list_name}, "+", max_tmp_name + "or", max_tmp_name } + else + {"length", list_name} + + slice + else + {1, {"length", list_name}} + + build.group { + build.assign_one list_name, list + slice_var + build["for"] { + name: index_name + bounds: bounds + body: { + {"assign", node.names, {list_name\index index_name}} + build.group node.body + } + } + } + + switch: (node, ret) => + _, exp, conds = unpack node + exp_name = NameProxy "exp" + + -- convert switch conds into if statment conds + convert_cond = (cond) -> + t, case_exp, body = unpack cond + out = {} + insert out, t == "case" and "elseif" or "else" + if t != "else" + insert out, {"exp", case_exp, "==", exp_name} if t != "else" + else + body = case_exp + + if ret + body = apply_to_last body, ret + + insert out, body + + out + + first = true + if_stm = {"if"} + for cond in *conds + if_cond = convert_cond cond + if first + first = false + insert if_stm, if_cond[2] + insert if_stm, if_cond[3] + else + insert if_stm, if_cond + + build.group { + build.assign_one exp_name, exp + if_stm + } + + class: (node) => + _, name, parent_val, body = unpack node + + -- split apart properties and statements + statements = {} + properties = {} + for item in *body + switch item[1] + when "stm" + insert statements, item[2] + when "props" + for tuple in *item[2,] + insert properties, tuple + + -- find constructor + constructor = nil + properties = for tuple in *properties + if tuple[1] == constructor_name + constructor = tuple[2] + nil + else + tuple + + parent_cls_name = NameProxy "parent" + base_name = NameProxy "base" + self_name = NameProxy "self" + cls_name = NameProxy "class" + + if not constructor + constructor = build.fndef { + args: {{"..."}} + arrow: "fat" + body: { + build["if"] { + cond: parent_cls_name + then: { + build.chain { base: "super", {"call", {"..."}} } + } + } + } + } + else + smart_node constructor + constructor.arrow = "fat" + + cls = build.table { + {"__init", constructor} + {"__base", base_name} + {"__name", {"string", '"', name}} -- "quote the string" + {"__parent", parent_cls_name} + } + + -- look up a name in the class object + class_lookup = build["if"] { + cond: {"exp", "val", "==", "nil", "and", parent_cls_name} + then: { + parent_cls_name\index"name" + } + } + insert class_lookup, {"else", {"val"}} + + cls_mt = build.table { + {"__index", build.fndef { + args: {{"cls"}, {"name"}} + body: { + build.assign_one LocalName"val", build.chain { + base: "rawget", {"call", {base_name, "name"}} + } + class_lookup + } + }} + {"__call", build.fndef { + args: {{"cls"}, {"..."}} + body: { + build.assign_one self_name, build.chain { + base: "setmetatable" + {"call", {"{}", base_name}} + } + build.chain { + base: "cls.__init" + {"call", {self_name, "..."}} + } + self_name + } + }} + } + + cls = build.chain { + base: "setmetatable" + {"call", {cls, cls_mt}} + } + + value = nil + with build + value = .block_exp { + Run => + @set "super", (block, chain) -> + if chain + slice = [item for item in *chain[3,]] + new_chain = {"chain", parent_cls_name} + + head = slice[1] + + if head == nil + return parent_cls_name + + switch head[1] + -- calling super, inject calling name and self into chain + when "call" + calling_name = block\get"current_block" + slice[1] = {"call", {"self", unpack head[2]}} + act = if ntype(calling_name) != "value" then "index" else "dot" + insert new_chain, {act, calling_name} + + -- colon call on super, replace class with self as first arg + when "colon" + call = head[3] + insert new_chain, {"dot", head[2]} + slice[1] = { "call", { "self", unpack call[2] } } + + insert new_chain, item for item in *slice + + new_chain + else + parent_cls_name + + .assign_one parent_cls_name, parent_val == "" and "nil" or parent_val + .assign_one base_name, {"table", properties} + .assign_one base_name\chain"__index", base_name + + build["if"] { + cond: parent_cls_name + then: { + .chain { + base: "setmetatable" + {"call", { + base_name, + .chain { base: parent_cls_name, {"dot", "__base"}} + }} + } + } + } + + .assign_one cls_name, cls + .assign_one base_name\chain"__class", cls_name + + .group if #statements > 0 { + .assign_one LocalName"self", cls_name + .group statements + } else {} + + cls_name + } + + value = .group { + .declare names: {name} + .assign { + names: {name} + values: {value} + } + } + + value +} + +class Accumulator + body_idx: { for: 4, while: 3, foreach: 4 } + + new: => + @accum_name = NameProxy "accum" + @value_name = NameProxy "value" + @len_name = NameProxy "len" + + -- wraps node and mutates body + convert: (node) => + index = @body_idx[ntype node] + node[index] = @mutate_body node[index] + @wrap node + + -- wrap the node into a block_exp + wrap: (node) => + build.block_exp { + build.assign_one @accum_name, build.table! + build.assign_one @len_name, 0 + node + @accum_name + } + + -- mutates the body of a loop construct to save last value into accumulator + -- can optionally skip nil results + mutate_body: (body, skip_nil=true) => + val = if not skip_nil and is_singular body + with body[1] + body = {} + else + body = apply_to_last body, (n) -> + build.assign_one @value_name, n + @value_name + + update = { + {"update", @len_name, "+=", 1} + build.assign_one @accum_name\index(@len_name), val + } + + if skip_nil + table.insert body, build["if"] { + cond: {"exp", @value_name, "!=", "nil"} + then: update + } + else + table.insert body, build.group update + + body + +default_accumulator = (node) => + Accumulator!\convert node + + +implicitly_return = (scope) -> + fn = (stm) -> + t = ntype stm + if types.manual_return[t] or not types.is_value stm + stm + elseif types.cascading[t] + scope.transform.statement stm, fn + else + if t == "comprehension" and not types.comprehension_has_value stm + stm + else + {"return", stm} + + fn + +Value = Transformer { + for: default_accumulator + while: default_accumulator + foreach: default_accumulator + + comprehension: (node) => + a = Accumulator! + node = @transform.statement node, (exp) -> + a\mutate_body {exp}, false + a\wrap node + + tblcomprehension: (node) => + _, key_exp, value_exp, clauses = unpack node + + accum = NameProxy "tbl" + dest = build.chain { base: accum, {"index", key_exp} } + inner = build.assign_one dest, value_exp + + build.block_exp { + build.assign_one accum, build.table! + construct_comprehension {inner}, clauses + accum + } + + fndef: (node) => + smart_node node + node.body = apply_to_last node.body, implicitly_return self + node + + if: (node) => build.block_exp { node } + with: (node) => build.block_exp { node } + switch: (node) => + build.block_exp { node } + + -- pull out colon chain + chain: (node) => + stub = node[#node] + if type(stub) == "table" and stub[1] == "colon_stub" + table.remove node, #node + + base_name = NameProxy "base" + fn_name = NameProxy "fn" + + is_super = node[2] == "super" + @transform.value build.block_exp { + build.assign { + names: {base_name} + values: {node} + } + + build.assign { + names: {fn_name} + values: { + build.chain { base: base_name, {"dot", stub[2]} } + } + } + + build.fndef { + args: {{"..."}} + body: { + build.chain { + base: fn_name, {"call", {is_super and "self" or base_name, "..."}} + } + } + } + } + + block_exp: (node) => + _, body = unpack node + + fn = nil + arg_list = {} + + insert body, Run => + if @has_varargs + insert arg_list, "..." + insert fn.args, {"..."} + + fn = smart_node build.fndef body: body + build.chain { base: {"parens", fn}, {"call", arg_list} } +} + diff --git a/tests/examplefiles/example.p b/tests/examplefiles/example.p new file mode 100644 index 00000000..e8c17e33 --- /dev/null +++ b/tests/examplefiles/example.p @@ -0,0 +1,34 @@ +{include.i} +{nested.i {include.i}} + +&SCOPED-DEFINE MY_NAME "Abe" + +DEF VAR i AS INT NO-UNDO. +i = 0xABE + 1337 / (1 * 1.00) + +def var clowercasetest as char no-undo. +DEF VAR vardashtest AS DATETIME-TZ NO-UNDO. + +DEFINE TEMP-TABLE ttNames NO-UNDO + FIELD cName AS CHAR + INDEX IXPK_ttNames IS PRIMARY UNIQUE cName. + +/* One-line comment */ +/* Two-line + Comment */ +/* + Nested + /* + Multiline + /* + Comment + */ + */ +*/ + +CREATE ttNames. +ASSIGN ttNames.cName = {&MY_NAME}. + +FOR EACH ttNames: + MESSAGE "Hello, " + ttNames.cName + '!' VIEW-AS ALERT-BOX. +END. diff --git a/tests/examplefiles/example.snobol b/tests/examplefiles/example.snobol new file mode 100644 index 00000000..26ca5cf4 --- /dev/null +++ b/tests/examplefiles/example.snobol @@ -0,0 +1,15 @@ +-SOME RANDOM DIRECTIVE WOULD GO HERE +* +* SNOBOL4 example file for lexer +* + SOME.THING_OR_OTHER32 = 1 + 1.0 - 1E3 * 1E-3 ** 2.718284590E0 ++ :F(END)S(IN_LOOP) + PATTERN = LEN(3) ("GAR" | "BAR") +IN_LOOP THING = INPUT :F(END) + THING LEN(3) ("GAR" | "BAR") :S(OK) + OUTPUT = THING " : Failure!" :(IN_LOOP) +OK OUTPUT = THING ' : "Success"!' :(IN_LOOP) +END +FOOBAR +FOOGAR +THiNIg diff --git a/tests/examplefiles/example.u b/tests/examplefiles/example.u new file mode 100644 index 00000000..42c85902 --- /dev/null +++ b/tests/examplefiles/example.u @@ -0,0 +1,548 @@ + // This is a one line comment. + /* an inner comment */ + + /* nested /* comments */ */ + + /* + /* + Multi-line. + */ + */ + +// Binary blob escape. +//"some text \B(3)("\") ouhyeah" == "\"\\\""; +"some text \B(3)("\") ouhyeah" == "\"\\\""; +'some text \B(3)('\') ouhyeah' == '\'\\\''; + +//"\B(4)()"'()"; +"\B(4)()"'()"; +'\B(4)()'"()'; + +//blob size limits +"hey ! \B(0)() oh !" + +//blob format is wrong +"hey ! \B(2)(aaa) oh !" +"hey ! \B(100)(aaa) oh !" + +//multiple blob in a string +"hey ! \B(3)(aaa) hey ! \B(3)(aaa) oh !" + +// multiple digits blob size +"hey ! \B(10)(aaaaaaaaaa) !" +"hey ! \B(10)(aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa) !" +"hey ! \B(100)(a) !" + +// multiple digits blob size +"hey ! \B(007)(aaaaaaa) !" +"hey ! \B(007)(aa) !" +"hey ! \B(007)(aaaaaaaaaaaaaaaaaa) !" + +// deprecated and restricted keyworks +emit Event.new; +static int main(); + +loopn (2) {echo("a");}; + +foreach (var i : [1,2,3,4]) { + echo(i); +}; + +function() {}; + +var 'if'; +var this.'else'; + +var '%x'; +var '1 2 3'; +var this.'[]'; + +// angles +pi == 180deg; +pi == 200grad; + +// Dictionary +[ => ]; // The empty dictionary + +// duration +1d == 24h; +0.5d == 12h; +1h == 60min; +1min == 60s; +1s == 1000ms; + +1s == 1; +1s 2s 3s == 6; +1s 1ms == 1.001; +1ms 1s == 1.001; + + + 1 == 1; + 1 == 1.0; + 1.2 == 1.2000; + 1.234e6 == 1234000; + 1e+11 == 1E+11; + 1e10 == 10000000000; + 1e30 == 1e10 * 1e10 * 1e10; + + +0.000001; + +0.0000001; + +0.00000000001; + +1e+3; + +1E-5; + + +1.; +// [00004701:error] !!! syntax error: unexpected ; + + 0x2a == 42; + 0x2A == 42; + 0xabcdef == 11259375; + 0xABCDEF == 11259375; +0xFFFFFFFF == 4294967295; + + +//123foo; +//[00005658:error] !!! syntax error: invalid token: '123foo' +//12.3foo; +//[00018827:error] !!! syntax error: invalid token: '12.3foo' +0xabcdef; +//[00060432] 11259375 +//0xabcdefg; +//[00061848:error] !!! syntax error: invalid token: '0xabcdefg' + + +[]; // The empty list +[1, 2, 3]; + +// Special characters. +"\"" == "\""; +"\\" == "\\"; + +// ASCII characters. +"\a" == "\007"; "\a" == "\x07"; +"\b" == "\010"; "\b" == "\x08"; +"\f" == "\014"; "\f" == "\x0c"; +"\n" == "\012"; "\n" == "\x0a"; +"\r" == "\015"; "\r" == "\x0d"; +"\t" == "\011"; "\t" == "\x09"; +"\v" == "\013"; "\v" == "\x0b"; + +// Octal escapes. +"\0" == "\00"; "\0" == "\000"; +"\0000" == "\0""0"; +"\062\063" == "23"; + +// Hexadecimal escapes. +"\x00" == "\0"; +"\x32\x33" == "23"; + + + +"foo" "bar" "baz" == "foobarbaz"; + +// Tuples +(); +[00000000] () +(1,); +[00000000] (1,) +(1, 2); +[00000000] (1, 2) +(1, 2, 3, 4,); +[00000000] (1, 2, 3, 4) + +function Global.verboseId(var x) +{ + echo(x) | x +}|; +class verboseId(Global).math : verboseId(Math) +{ +}; + +{ + for (3) + { + sleep(1s); + echo("ping"); + }, + sleep(0.5s); + for (3) + { + sleep(1s); + echo("pong"); + }, +}; + + 1 + 1 == 2; + 1 - 2 == -1; + 2 * 3 == 6; + 10 / 2 == 5; + 2 ** 10 == 1024; + -(1 + 2) == -3; + 1 + 2 * 3 == 7; + (1 + 2) * 3 == 9; + -2 ** 2 == -4; + - - - - 1 == 1; + +a = b +a += b +a -= b +a *= b +a /= b +a %= b +a ^= b + + +var value = 0|; +var valueAlias = value|; +value += 10; +valueAlias; +var myList = []|; +var myList.specialFeature = 42|; +myList += [1, 2, 3]; +myList.specialFeature; +var myOtherList = myList + [4, 5]; +myOtherList.specialFeature; +var something = []|; +var somethingElse = something|; +something += [1, 2]; +somethingElse += [3, 4]; +something; + + +class Counter +{ + var count = 0; + function init (n) { var this.count = n }; + // Display the value, and the identity. + function asString() { "%s @ %s" % [count, uid ] }; + function '+'(var n) { new(count + n) }; + function '-'(var n) { new(count - n) }; +}|; + + +class ImmutableCounter : Counter +{ + function '+='(var n) { this + n }; + function '-='(var n) { this - n }; +}|; + +var ic1 = ImmutableCounter.new(0); +var ic2 = ic1; + +ic1 += 1; +ic1; +ic2; + + +a << b +a >> b +a ^ b + +4 << 2 == 16; +4 >> 2 == 1; + +!a +a && b +a || b + +true && true; +true || false; +!true == false; +true || (1 / 0); +(false && (1 / 0)) == false; + +a == b +a != b +a === b +a !== b +a ~= b +a =~= b +a < b +a <= b +a > b +a >= b + +assert{ + ! (0 < 0); + 0 <= 0; + 0 == 0; + 0 !== 0; +}; + +a in b +a not in b +a[args] +a[args] = v + +1 in [0, 1, 2]; +3 not in [0, 1, 2]; + +"one" in ["zero" => 0, "one" => 1, "two" => 2]; +"three" not in ["zero" => 0, "one" => 1, "two" => 2]; + +a.b +a.b(args) +a->b +a->b = v +a.&b + +var obj = Object.new|; +function obj.f() { 24 }|; + + +var f = function(a, b) { + echo(b + a); +}| +f(1, 0); + + +function g3() +{ + return; // Stop execution at this point and return void + echo(0); // This is not executed +}| + +Object.setProperty, to define/set a property. +Object.getProperty, to get a property. +Object.removeProperty, to delete a property. +Object.hasProperty, to test for the existence of a property. +Object.properties, to get all the properties of a slot. + +enum Suit +{ + hearts, + diamonds, + clubs, + spades, // Last comma is optional +}; + +for (var suit in Suit) + echo("%s the ace of %s." % [find_ace(suit), suit]); + +switch ( ("foo", [1, 2]) ) +{ + // The pattern does not match the values of the list. + case ("foo", [2, 1]): + echo("fail"); + + // The pattern does not match the tuple. + case ["foo", [1, 2]]: + echo("fail"); + + // The pattern matches and binds the variable "l" + // but the condition is not verified. + case ("foo", var l) if l.size == 0: + echo("fail"); + + // The pattern matches. + case ("foo", [var a, var b]): + echo("foo(%s, %s)" % [a, b]); +}; +//[00000000] *** foo(1, 2) + +{ + ["b" => var b, "a" => var a] = ["a" => 1, "b" => 2, "c" => 3]; + echo("a = %d, b = %d" % [a, b]); +}; +//[00000000] *** a = 1, b = 2 + + +switch (["speed" => 2, "time" => 6s]) +{ + case ["speed" => var s] if s > 3: + echo("Too fast"); + case ["speed" => var s, "time" => var t] if s * t > 10: + echo("Too far"); +}; +//[00000000] *** Too far + + +try +{ + throw ("message", 0) +} +catch (var e if e.isA(Exception)) +{ + echo(e.message) +} +catch ((var msg, var value) if value.isA(Float)) +{ + echo("%s: %d" % [msg, value]) +}; +//[00000000] *** message: 0 + + +{ + var e = Event.new; + at (e?(var msg, var value) if value % 2 == 0) + echo("%s: %d" % [msg, value]); + + // Does not trigger the "at" because the guard is not verified. + e!("message", 1); + + // Trigger the "at". + e!("message", 2); +}; +//[00000000] *** message: 2 + +for (var i = 0; i < 8; i++) +{ + if (i % 2 != 0) + continue; + echo(i); +}; + +do (1024) +{ + assert(this == 1024); + assert(sqrt == 32); + setSlot("y", 23); +}.y; + +{ + var n = 10|; + var res = []|; + loop;{ + n--; + res << n; + if (n == 0) + break + }; + res +} + + +{ + var n = 10|; + var res = []|; + loop|{ + n--; + res << n; + if (n == 0) + break + }; + res +} + + +var j = 3| +while (0 < j) +{ + echo(j); + j--; +}; + + +{ + var i = 4| + while| (true) + { + i -= 1; + echo ("in: " + i); + if (i == 1) + break + else if (i == 2) + continue; + echo ("out: " + i); + }; +}; + + + +function test(e) +{ + try + { throw e; } + catch (0) + { echo("zero") } + catch ([var x, var y]) + { echo(x + y) } +} | {}; + +try { echo("try") } +catch { echo("catch")} +else { echo("else")}; + + +try +{ + echo("inside"); +} +finally +{ + echo("finally"); +}; +//[00000001] *** inside +//[00000002] *** finally + +at (e?(var start) ~ 1s) + echo("in : %s" % (time - start).round) +onleave + echo("out: %s" % (time - start).round); + +// This emission is too short to trigger the at. +e!(time); + +// This one is long enough. +// The body triggers 1s after the emission started. +e!(time) ~ 2s; +//[00001000] *** in : 1 +//[00002000] *** out: 2 + + +timeout (2.1s) + every (1s) + echo("Are you still there?"); +//[00000000] *** Are you still there? +//[00001000] *** Are you still there? +//[00002000] *** Are you still there? + + every| (1s) + { + echo("aba"); + }; + +for, (var i = 3; 0 < i; i -= 1) +{ + echo (i); +}; + + +for& (var i: [0, 1, 2]) +{ + echo (i * i); +}; + +loop,{ +}; + + +waituntil (e?(1, var b)); + +whenever (e?("arg", var arg) if arg % 2) + echo("e (%s) on" % arg) +else + echo("e off"); + + + while, (i) + { + var j = i -= 1; + }| + + +var y = 0; +{ + sleep(0.5s); + y = 100 smooth:3s, +}, + + + + diff --git a/tests/examplefiles/http_request_example b/tests/examplefiles/http_request_example new file mode 100644 index 00000000..5d2a1d52 --- /dev/null +++ b/tests/examplefiles/http_request_example @@ -0,0 +1,14 @@ +POST /demo/submit/ HTTP/1.1
+Host: pygments.org
+Connection: keep-alivk
+Cache-Control: max-age=0
+Origin: http://pygments.org
+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10_7_2) AppleWebKit/535.7 (KHTML, like Gecko) Chrome/16.0.912.63 Safari/535.7
+Content-Type: application/x-www-form-urlencoded
+Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
+Referer: http://pygments.org/
+Accept-Encoding: gzip,deflate,sdch
+Accept-Language: en-US,en;q=0.8
+Accept-Charset: windows-949,utf-8;q=0.7,*;q=0.3
+
+name=test&lang=text&code=asdf&user= diff --git a/tests/examplefiles/http_response_example b/tests/examplefiles/http_response_example new file mode 100644 index 00000000..bf53d61d --- /dev/null +++ b/tests/examplefiles/http_response_example @@ -0,0 +1,27 @@ +HTTP/1.1 200 OK
+Date: Tue, 13 Dec 2011 00:11:44 GMT
+Status: 200 OK
+X-Transaction: 50b85fff78dab4a3
+X-RateLimit-Limit: 150
+ETag: "b31143be48ebfe7512b65fe64fe092f3"
+X-Frame-Options: SAMEORIGIN
+Last-Modified: Tue, 13 Dec 2011 00:11:44 GMT
+X-RateLimit-Remaining: 145
+X-Runtime: 0.01190
+X-Transaction-Mask: a6183ffa5f8ca943ff1b53b5644ef1145f6f285d
+Content-Type: application/json; charset=utf-8
+Content-Length: 2389
+Pragma: no-cache
+X-RateLimit-Class: api
+X-Revision: DEV
+Expires: Tue, 31 Mar 1981 05:00:00 GMT
+Cache-Control: no-cache, no-store, must-revalidate, pre-check=0, post-check=0
+X-MID: a55f21733bc52bb11d1fc58f9b51b4974fbb8f83
+X-RateLimit-Reset: 1323738416
+Set-Cookie: k=10.34.234.116.1323735104238974; path=/; expires=Tue, 20-Dec-11 00:11:44 GMT; domain=.twitter.com
+Set-Cookie: guest_id=v1%3A13237351042425496; domain=.twitter.com; path=/; expires=Thu, 12-Dec-2013 12:11:44 GMT
+Set-Cookie: _twitter_sess=BAh7CDoPY3JlYXRlZF9hdGwrCPS6wjQ0AToHaWQiJTFiMTlhY2E1ZjczYThk%250ANDUwMWQxNjMwZGU2YTQ1ODBhIgpmbGFzaElDOidBY3Rpb25Db250cm9sbGVy%250AOjpGbGFzaDo6Rmxhc2hIYXNoewAGOgpAdXNlZHsA--6b502f30a083e8a41a64f10930e142ea362b1561; domain=.twitter.com; path=/; HttpOnly
+Vary: Accept-Encoding
+Server: tfe
+
+[{"contributors_enabled":false,"profile_background_tile":true,"followers_count":644,"protected":false,"profile_image_url":"http:\/\/a0.twimg.com\/profile_images\/69064242\/gb_normal.jpg","screen_name":"birkenfeld","default_profile_image":false,"following":null,"friends_count":88,"profile_sidebar_fill_color":"7AC3EE","url":"http:\/\/pythonic.pocoo.org\/","name":"Georg Brandl","default_profile":false,"is_translator":false,"utc_offset":3600,"profile_sidebar_border_color":"65B0DA","description":"","profile_background_image_url_https":"https:\/\/si0.twimg.com\/images\/themes\/theme10\/bg.gif","favourites_count":0,"profile_use_background_image":true,"created_at":"Tue Dec 30 22:25:11 +0000 2008","status":{"retweet_count":10,"favorited":false,"geo":null,"possibly_sensitive":false,"coordinates":null,"in_reply_to_screen_name":null,"in_reply_to_status_id_str":null,"retweeted":false,"in_reply_to_status_id":null,"in_reply_to_user_id_str":null,"created_at":"Sat Jul 09 13:42:35 +0000 2011","truncated":false,"id_str":"89690914515206144","contributors":null,"place":null,"source":"web","in_reply_to_user_id":null,"id":89690914515206144,"retweeted_status":{"retweet_count":10,"favorited":false,"geo":null,"possibly_sensitive":false,"coordinates":null,"in_reply_to_screen_name":null,"in_reply_to_status_id_str":null,"retweeted":false,"in_reply_to_status_id":null,"in_reply_to_user_id_str":null,"created_at":"Sat Jul 09 13:07:04 +0000 2011","truncated":false,"id_str":"89681976755372032","contributors":null,"place":null,"source":"web","in_reply_to_user_id":null,"id":89681976755372032,"text":"Excellent Python posts from @mitsuhiko - http:\/\/t.co\/k1wt6e4 and @ncoghlan_dev - http:\/\/t.co\/eTxacgZ (links fixed)"},"text":"RT @jessenoller: Excellent Python posts from @mitsuhiko - http:\/\/t.co\/k1wt6e4 and @ncoghlan_dev - http:\/\/t.co\/eTxacgZ (links fixed)"},"follow_request_sent":null,"statuses_count":553,"geo_enabled":false,"notifications":null,"profile_text_color":"3D1957","id_str":"18490730","lang":"en","profile_background_image_url":"http:\/\/a1.twimg.com\/images\/themes\/theme10\/bg.gif","profile_image_url_https":"https:\/\/si0.twimg.com\/profile_images\/69064242\/gb_normal.jpg","show_all_inline_media":true,"listed_count":65,"profile_link_color":"FF0000","verified":false,"id":18490730,"time_zone":"Berlin","profile_background_color":"642D8B","location":"Bavaria, Germany"}] diff --git a/tests/examplefiles/irc.lsp b/tests/examplefiles/irc.lsp new file mode 100755 index 00000000..6f45976a --- /dev/null +++ b/tests/examplefiles/irc.lsp @@ -0,0 +1,214 @@ +#!/usr/bin/env newlisp + +;; @module IRC +;; @description a basic irc library +;; @version early alpha! 0.1 2011-10-31 14:21:26 +;; @author cormullion +;; Usage: +;; (IRC:init "newlithper") ; a username/nick (not that one obviously :-) +;; (IRC:connect "irc.freenode.net" 6667) ; irc/server +;; (IRC:join-channel {#newlisp}) ; join a room +;; either (IRC:read-irc-loop) ; loop - monitor only, no input +;; or (IRC:session) ; a command-line session, end with /QUIT + +(context 'IRC) + (define Inickname) + (define Ichannels) + (define Iserver) + (define Iconnected) + (define Icallbacks '()) + (define Idle-time 400) ; seconds + (define Itime-stamp) ; time since last message was processed + +(define (register-callback callback-name callback-function) + (println {registering callback for } callback-name { : } (sym (term callback-function) (prefix callback-function))) + (push (list callback-name (sym (term callback-function) (prefix callback-function))) Icallbacks)) + +(define (do-callback callback-name data) + (when (set 'func (lookup callback-name Icallbacks)) ; find first callback + (if-not (catch (apply func (list data)) 'error) + (println {error in callback } callback-name {: } error)))) + +(define (do-callbacks callback-name data) + (dolist (rf (ref-all callback-name Icallbacks)) + (set 'callback-entry (Icallbacks (first rf))) + (when (set 'func (last callback-entry)) + (if-not (catch (apply func (list data)) 'error) + (println {error in callback } callback-name {: } error))))) + +(define (init str) + (set 'Inickname str) + (set 'Iconnected nil) + (set 'Ichannels '()) + (set 'Itime-stamp (time-of-day))) + +(define (connect server port) + (set 'Iserver (net-connect server port)) + (net-send Iserver (format "USER %s %s %s :%s\r\n" Inickname Inickname Inickname Inickname)) + (net-send Iserver (format "NICK %s \r\n" Inickname)) + (set 'Iconnected true) + (do-callbacks "connect" (list (list "server" server) (list "port" port)))) + +(define (identify password) + (net-send Iserver (format "PRIVMSG nickserv :identify %s\r\n" password))) + +(define (join-channel channel) + (when (net-send Iserver (format "JOIN %s \r\n" channel)) + (push channel Ichannels) + (do-callbacks "join-channel" (list (list "channel" channel) (list "nickname" Inickname))))) + +(define (part chan) + (if-not (empty? chan) + ; leave specified + (begin + (net-send Iserver (format "PART %s\r\n" chan)) + (replace channel Ichannels) + (do-callbacks "part" (list (list "channel" channel)))) + ; leave all + (begin + (dolist (channel Ichannels) + (net-send Iserver (format "PART %s\r\n" channel)) + (replace channel Ichannels) + (do-callbacks "part" (list (list "channel" channel))))))) + +(define (do-quit message) + (do-callbacks "quit" '()) ; chance to do stuff before quit... + (net-send Iserver (format "QUIT :%s\r\n" message)) + (sleep 1000) + (set 'Ichannels '()) + (close Iserver) + (set 'Iconnected nil)) + +(define (privmsg user message) + (net-send Iserver (format "PRIVMSG %s :%s\r\n" user message))) + +(define (notice user message) + (net-send Iserver (format "NOTICE %s :%s\r\n" user message))) + +(define (send-to-server message (channel nil)) + (cond + ((starts-with message {/}) ; default command character + (set 'the-message (replace "^/" (copy message) {} 0)) ; keep original + (net-send Iserver (format "%s \r\n" the-message)) ; send it + ; do a quit + (if (starts-with (lower-case the-message) "quit") + (do-quit { enough}))) + (true + (if (nil? channel) + ; say to all channels + (dolist (c Ichannels) + (net-send Iserver (format "PRIVMSG %s :%s\r\n" c message))) + ; say to specified channel + (if (find channel Ichannels) + (net-send Iserver (format "PRIVMSG %s :%s\r\n" channel message)))))) + (do-callbacks "send-to-server" (list (list "channel" channel) (list "message" message)))) + +(define (process-command sender command text) + (cond + ((= sender "PING") + (net-send Iserver (format "PONG %s\r\n" command))) + ((or (= command "NOTICE") (= command "PRIVMSG")) + (process-message sender command text)) + ((= command "JOIN") + (set 'username (first (clean empty? (parse sender {!|:} 0)))) + (set 'channel (last (clean empty? (parse sender {!|:} 0)))) + (println {username } username { joined } channel) + (do-callbacks "join" (list (list "channel" channel) (list "username" username)))) + (true + nil))) + +(define (process-message sender command text) + (let ((username {} target {} message {})) + (set 'username (first (clean empty? (parse sender {!|:} 0)))) + (set 'target (trim (first (clean empty? (parse text {!|:} 0))))) + (set 'message (slice text (+ (find {:} text) 1))) + (cond + ((starts-with message "\001") + (process-ctcp username target message)) + ((find target Ichannels) + (cond + ((= command {PRIVMSG}) + (do-callbacks "channel-message" (list (list "channel" target) (list "username" username) (list "message" message)))) + ((= command {NOTICE}) + (do-callbacks "channel-notice" (list (list "channel" target) (list "username" username) (list "message" message)))))) + ((= target Inickname) + (cond + ((= command {PRIVMSG}) + (do-callbacks "private-message" (list (list "username" username) (list "message" message)))) + ((= command {NOTICE}) + (do-callbacks "private-notice" (list (list "username" username) (list "message" message)))))) + (true + nil)))) + +(define (process-ctcp username target message) + (cond + ((starts-with message "\001VERSION\001") + (net-send Iserver (format "NOTICE %s :\001VERSION %s\001\r\n" username version))) + ((starts-with message "\001PING") + (set 'data (first (rest (clean empty? (parse message { } 0))))) + (set 'data (trim data "\001" "\001")) + (net-send Iserver (format "NOTICE %s :\001PING %s\001\r\n" username data))) + ((starts-with message "\001ACTION") + (set 'data (first (rest (clean empty? (parse message { } 0))))) + (set 'data (join data { })) + (set 'data (trim data "\001" "\001")) + (if (find target Ichannels) + (do-callbacks "channel-action" (list (list "username" username) (list "message" message)))) + (if (= target Inickname) + (do-callbacks "private-action" (list (list "username" username) (list "message" message))))) + ((starts-with message "\001TIME\001") + (net-send Iserver (format "NOTICE %s:\001TIME :%s\001\r\n" username (date)))))) + +(define (parse-buffer raw-buffer) + (let ((messages (clean empty? (parse raw-buffer "\r\n" 0))) + (sender {} command {} text {})) + ; check for elapsed time since last activity + (when (> (sub (time-of-day) Itime-stamp) (mul Idle-time 1000)) + (do-callbacks "idle-event") + (set 'Itime-stamp (time-of-day))) + (dolist (message messages) + (set 'message-parts (parse message { })) + (unless (empty? message-parts) + (set 'sender (first message-parts)) + (catch (set 'command (first (rest message-parts))) 'error) + (catch (set 'text (join (rest (rest message-parts)) { })) 'error)) + (process-command sender command text)))) + +(define (read-irc) + (let ((buffer {})) + (when (!= (net-peek Iserver) 0) + (net-receive Iserver buffer 8192 "\n") + (unless (empty? buffer) + (parse-buffer buffer))))) + +(define (read-irc-loop) ; monitoring + (let ((buffer {})) + (while Iconnected + (read-irc) + (sleep 1000)))) + +(define (print-raw-message data) ; example of using a callback + (set 'raw-data (lookup "message" data)) + (set 'channel (lookup "channel" data)) + (set 'message-text raw-data) + (println (date (date-value) 0 {%H:%M:%S }) username {> } message-text)) + +(define (print-outgoing-message data) + (set 'raw-data (lookup "message" data)) + (set 'channel (lookup "channel" data)) + (set 'message-text raw-data) + (println (date (date-value) 0 {%H:%M:%S }) Inickname {> } message-text)) + +(define (session); interactive terminal + ; must add callbacks to display messages + (register-callback "channel-message" 'print-raw-message) + (register-callback "send-to-server" 'print-outgoing-message) + (while Iconnected + (while (zero? (peek 0)) + (read-irc)) + (send-to-server (string (read-line 0)))) + (println {finished session } (date)) + (exit)) + +; end of IRC code + diff --git a/tests/examplefiles/markdown.lsp b/tests/examplefiles/markdown.lsp new file mode 100755 index 00000000..8159082b --- /dev/null +++ b/tests/examplefiles/markdown.lsp @@ -0,0 +1,679 @@ +#!/usr/bin/env newlisp + +;; @module markdown +;; @author cormullion +;; @description a port of John Gruber's Markdown to newLISP +;; @location http://unbalanced-parentheses.nfshost.com/ +;; @version of date 2011-10-02 22:36:02 +;; version history: at the end +;; a port of John Gruber's Markdown.pl (http://daringfireball.net/markdown) script to newLISP... +;; see his original Perl script for explanations of the fearsome regexen and +;; byzantine logic, etc... +;; TODO: +;; the following Markdown tests fail: +;; Inline HTML (Advanced) ... FAILED +;; Links, reference style ... FAILED -- nested brackets +;; Links, shortcut references ... FAILED +;; Markdown Documentation - Syntax ... FAILED +;; Ordered and unordered lists ... FAILED -- a nested ordered list error +;; parens in url : .jpg) see (Images.text) +;; Add: email address scrambling + +(context 'Hash) +(define HashTable:HashTable) + +(define (build-escape-table) + (set '*escape-chars* [text]\`*_{}[]()>#+-.![/text]) + (dolist (c (explode *escape-chars*)) + (HashTable c (hash c)))) + +(define (init-hash txt) + ; finds a hash identifier that doesn't occur anywhere in the text + (set 'counter 0) + (set 'hash-prefix "HASH") + (set 'hash-id (string hash-prefix counter)) + (do-while (find hash-id txt) + (set 'hash-id (string hash-prefix (inc counter)))) + (Hash:build-escape-table)) + +(define (hash s) + (HashTable s (string hash-id (inc counter)))) + +(context 'markdown) + +(define (markdown:markdown txt) + (initialize) + (Hash:init-hash txt) + (unescape-special-chars + (block-transforms + (strip-link-definitions + (protect + (cleanup txt)))))) + +(define (initialize) + (set '*escape-pairs* '( + ({\\\\} {\}) + ({\\`} {`}) + ({\\\*} {*}) + ({\\_} {_}) + ([text]\\\{[/text] [text]{[/text]) + ([text]\\\}[/text] [text]}[/text]) + ({\\\[} {[}) + ({\\\]} {]}) + ({\\\(} {(}) + ({\\\)} {)}) + ({\\>} {>}) + ({\\\#} {#}) + ({\\\+} {+}) + ({\\\-} {-}) + ({\\\.} {.}) + ({\\!} {!}))) + (set '*hashed-html-blocks* '()) + (set '*list-level* 0)) + +(define (block-transforms txt) + (form-paragraphs + (protect + (block-quotes + (code-blocks + (lists + (horizontal-rules + (headers txt)))))))) + +(define (span-transforms txt) + (line-breaks + (emphasis + (amps-and-angles + (auto-links + (anchors + (images + (escape-special-chars + (escape-special-chars (code-spans txt) 'inside-attributes))))))))) + +(define (tokenize-html xhtml) +; return list of tag/text portions of xhtml text + (letn ( + (tag-match [text]((?s:<!(-- .*? -- \s*)+>)| +(?s:<\?.*?\?>)| +(?:<[a-z/!$](?:[^<>]| +(?:<[a-z/!$](?:[^<>]| +(?:<[a-z/!$](?:[^<>]| +(?:<[a-z/!$](?:[^<>]| +(?:<[a-z/!$](?:[^<>]| +(?:<[a-z/!$](?:[^<>])*>))*>))*>))*>))*>))*>))[/text]) ; yeah, well... + (str xhtml) + (len (length str)) + (pos 0) + (tokens '())) + (while (set 'tag-start (find tag-match str 8)) + (if (< pos tag-start) + (push (list 'text (slice str pos (- tag-start pos))) tokens -1)) + (push (list 'tag $0) tokens -1) + (set 'str (slice str (+ tag-start (length $0)))) + (set 'pos 0)) + ; leftovers + (if (< pos len) + (push (list 'text (slice str pos (- len pos))) tokens -1)) + tokens)) + +(define (escape-special-chars txt (within-tag-attributes nil)) + (let ((temp (tokenize-html txt)) + (new-text {})) + (dolist (pair temp) + (if (= (first pair) 'tag) + ; 'tag + (begin + (set 'new-text (replace {\\} (last pair) (HashTable {\\}) 0)) + (replace [text](?<=.)</?code>(?=.)[/text] new-text (HashTable {`}) 0) + (replace {\*} new-text (HashTable {*}) 0) + (replace {_} new-text (HashTable {_} ) 0)) + ; 'text + (if within-tag-attributes + (set 'new-text (last pair)) + (set 'new-text (encode-backslash-escapes (last pair))))) + (setf (temp $idx) (list (first pair) new-text))) + ; return as text + (join (map last temp)))) + +(define (encode-backslash-escapes t) + (dolist (pair *escape-pairs*) + (replace (first pair) t (HashTable (last pair)) 14))) + +(define (encode-code s) + ; encode/escape certain characters inside Markdown code runs + (replace {&} s "&" 0) + (replace {<} s "<" 0) + (replace {>} s ">" 0) + (replace {\*} s (HashTable {\\}) 0) + (replace {_} s (HashTable {_}) 0) + (replace "{" s (HashTable "{") 0) + (replace {\[} s (HashTable {[}) 0) + (replace {\]} s (HashTable {]}) 0) + (replace {\\} s (HashTable "\\") 0)) + +(define (code-spans s) + (replace + {(?<!\\)(`+)(.+?)(?<!`)\1(?!`)} + s + (string {<code>} (encode-code (trim $2)) {</code>}) + 2)) + +(define (encode-alt s) + (replace {&} s "&" 0) + (replace {"} s """ 0)) + +(define (images txt) + (let ((alt-text {}) + (url {}) + (title {}) + (ref-regex {(!\[(.*?)\][ ]?(?:\n[ ]*)?\[(.*?)\])}) + (inline-regex {(!\[(.*?)\]\([ \t]*<?(\S+?)>?[ \t]*((['"])(.*?)\5[ \t]*)?\))}) + (whole-match {}) + (result {}) + (id-ref {}) + (url {})) + ; reference links ![alt text][id] + (replace + ref-regex + txt + (begin + (set 'whole-match $1 'alt-text $2 'id-ref $3) + (if alt-text + (replace {"} alt-text {"} 0)) + (if (empty? id-ref) + (set 'id-ref (lower-case alt-text))) + (if (lookup id-ref *link-database*) + (set 'url (first (lookup id-ref *link-database*))) + (set 'url nil)) + (if url + (begin + (replace {\*} url (HashTable {*}) 0) + (replace {_} url (HashTable {_}) 0) + )) + (if (last (lookup id-ref *link-database*)) + ; title + (begin + (set 'title (last (lookup id-ref *link-database*))) + (replace {"} title {"} 0) + (replace {\*} title (HashTable {*}) 0) + (replace {_} title (HashTable {_}) 0)) + ; no title + (set 'title {}) + ) + (if url + (set 'result (string + {<img src="} + (trim url) + {" alt="} + alt-text {" } + (if (not (empty? title)) + (string { title="} title {"}) {}) + { />})) + (set 'result whole-match)) + ) + 0 + ) + ; inline image refs:  + (replace + inline-regex + txt + (begin + (set 'whole-match $1) + (set 'alt-text $2) + (set 'url $3) + (set 'title $6) + (if alt-text + (replace {"} alt-text {"} 0) + (set 'alt-text {})) + (if title + (begin + (replace {"} title {"} 0) + (replace {\*} title (HashTable {*}) 0) + (replace {_} title (HashTable {_}) 0)) + (set 'title {})) + (replace {\*} url (HashTable {*}) 0) + (replace {_} url (HashTable {_}) 0) + (string + {<img src="} + (trim url) + {" alt="} + alt-text {" } + (if title (string {title="} title {"}) {}) { />}) + ) + 0 + ) + ; empty ones are possible + (set '$1 {}) + (replace {!\[(.*?)\]\([ \t]*\)} + txt + (string {<img src="" alt="} $1 {" title="" />}) + 0))) + +(define (make-anchor link-text id-ref ) +; Link defs are in the form: ^[id]: url "optional title" +; stored in link db list as (id (url title)) +; params are text to be linked and the id of the link in the db +; eg bar 1 for [bar][1] + + (let ((title {}) + (id id-ref) + (url nil)) + (if link-text + (begin + (replace {"} link-text {"} 0) + (replace {\n} link-text { } 0) + (replace {[ ]?\n} link-text { } 0))) + (if (null? id ) (set 'id (lower-case link-text))) + (if (not (nil? (lookup id *link-database*))) + (begin + (set 'url (first (lookup id *link-database*))) + (replace {\*} url (HashTable {*}) 0) + (replace {_} url (HashTable {_}) 0) + (if (set 'title (last (lookup id *link-database*))) + (begin + (replace {"} title {"} 0) + (replace {\*} title (HashTable {*}) 0) + (replace {_} title (HashTable {_}) 0)) + (set 'title {}))) + (set 'url nil)) + (if url + (string {<a href="} (trim url) + {"} + (if (not (= title {})) (string { title="} (trim title) {"}) {}) + {>} link-text {</a>}) + (string {[} link-text {][} id-ref {]})))) + +(define (anchors txt) + (letn ((nested-brackets {(?>[^\[\]]+)*}) + (ref-link-regex (string {(\[(} nested-brackets {)\][ ]?(?:\n[ ]*)?\[(.*?)\])})) + (inline-regex {(\[(.*?)\]\([ ]*<?(.*?\)?)>?[ ]*((['"])(.*?)\5[ \t]*)?\))}) + (link-text {}) + (url {}) + (title {})) + ; reference-style links: [link text] [id] + (set '$1 {} '$2 {} '$3 {} '$4 {} '$5 {} '$6 {}) ; i still don't think I should have to do this... + + ; what about this regex instead? + (set 'ref-link-regex {(\[(.*?)\][ ]?\[(.*?)\])}) + + (replace ref-link-regex txt (make-anchor $2 $3) 8) ; $2 is link text, $3 is id + ; inline links: [link text](url "optional title") + (set '$1 {} '$2 {} '$3 {} '$4 {} '$5 {} '$6 {}) + (replace + inline-regex + txt + (begin + (set 'link-text $2) + (set 'url $3) + (set 'title $6) + (if link-text (replace {"} link-text {"} 0)) + (if title + (begin + (replace {"} title {"} 0) + (replace {\*} title (HashTable {*}) 0) + (replace {_} title (HashTable {_}) 0)) + (set 'title {})) + (replace {\*} url (HashTable {*}) 0) + (replace {_} url (HashTable {_}) 0) + (replace {^<(.*)>$} url $1 0) + (string + {<a href="} + (trim url) + {"} + (if (not (= title {})) + (string { title="} (trim title) {"}) + {}) + {>} link-text {</a>} + )) + 8 + ) ; replace + ) txt) + +(define (auto-links txt) + (replace + [text]<((https?|ftp):[^'">\s]+)>[/text] + txt + (string {<a href="} $1 {">} $1 {</a>}) + 0 + ) + ; to-do: email ... +) + +(define (amps-and-angles txt) +; Smart processing for ampersands and angle brackets + (replace + [text]&(?!\#?[xX]?(?:[0-9a-fA-F]+|\w+);)[/text] + txt + {&} + 10 + ) + (replace + [text]<(?![a-z/?\$!])[/text] + txt + {<} + 10)) + +(define (emphasis txt) + ; italics/bold: strong first + (replace + [text] (\*\*|__) (?=\S) (.+?[*_]*) (?<=\S) \1 [/text] + txt + (string {<strong>} $2 {</strong>}) + 8 + ) + (replace + [text] (\*|_) (?=\S) (.+?) (?<=\S) \1 [/text] + txt + (string {<em>} $2 {</em>}) + 8 + )) + +(define (line-breaks txt) + ; handles line break markers + (replace " {2,}\n" txt " <br/>\n" 0)) + +(define (hex-str-to-unicode-char strng) + ; given a five character string, assume it's "U" + 4 hex chars and convert + ; return the character... + (char (int (string "0x" (1 strng)) 0 16))) + +(define (ustring s) + ; any four digit string preceded by U + (replace "U[0-9a-f]{4,}" s (hex-str-to-unicode-char $0) 0)) + +(define (cleanup txt) + ; cleanup the text by normalizing some possible variations + (replace "\r\n|\r" txt "\n" 0) ; standardize line ends + (push "\n\n" txt -1) ; end with two returns + (set 'txt (detab txt)) ; convert tabs to spaces + + ; convert inline Unicode: + (set 'txt (ustring txt)) + (replace "\n[ \t]+\n" txt "\n\n" 0) ; lines with only spaces and tabs + ) + +(define (protect txt) + ; protect or "hash html blocks" + (letn ((nested-block-regex [text](^<(p|div|h[1-6]|blockquote|pre|table|dl|ol|ul|script|noscript|form|fieldset|iframe|math|ins|del)\b(.*\n)*?</\2>[ \t]*(?=\n+|\Z))[/text]) + (liberal-tag-regex [text](^<(p|div|h[1-6]|blockquote|pre|table|dl|ol|ul|script|noscript|form|fieldset|iframe|math)\b(.*\n)*?.*</\2>[ \t]*(?=\n+|\Z))[/text]) + (hr-regex [text](?:(?<=\n\n)|\A\n?)([ ]{0,3}<(hr)\b([^<>])*?/?>[ \t]*(?=\n{2,}|\Z))[/text]) + (html-comment-regex [text](?:(?<=\n\n)|\A\n?)([ ]{0,3}(?s:<!(--.*?--\s*)+>)[ \t]*(?=\n{2,}|\Z))[/text]) + (results '()) + (chunk-count (length (set 'chunks (parse txt "\n\n")))) + (chunk-size 500)) + + ; due to a limitation in PCRE, long sections have to be divided up otherwise we'll crash + ; so divide up long texts into chunks, then do the regex on each chunk + ; not an ideal solution, but it works ok :( + + (for (i 0 chunk-count chunk-size) + ; do a chunk + (set 'text-chunk (join (i (- (min chunk-count (- (+ i chunk-size) 1)) i) chunks) "\n\n")) + (dolist (rgx (list nested-block-regex liberal-tag-regex hr-regex html-comment-regex)) + (replace + rgx + text-chunk + (begin + (set 'key (Hash:hash $1)) + (push (list key $1 ) *hashed-html-blocks* -1) + (string "\n\n" key "\n\n")) + 2)) + ; save this partial result + (push text-chunk results -1) + ) ; for + ; return string result + (join results "\n\n"))) + +(define (unescape-special-chars t) + ; Swap back in all the special characters we've hidden. + (dolist (pair (HashTable)) + (replace (last pair) t (first pair) 10)) t) + +(define (strip-link-definitions txt) + ; strip link definitions from the text and store them + ; Link defs are in the form: ^[id]: url "optional title" + ; stored in link db list as (id (url title)) + (let ((link-db '()) + (url {}) + (id {}) + (title {})) + (replace + [text]^[ ]{0,3}\[(.+)\]:[ \t]*\n?[ \t]*<?(\S+?)>?[ \t]*\n?[ \t]*(?:(?<=\s)["(](.+?)[")][ \t]*)?(?:\n+|\Z)[/text] + txt + (begin + (set 'id (lower-case $1) 'url (amps-and-angles $2) 'title $3) + (if title (replace {"} title {"} 0)) + (push (list id (list url title)) link-db) + (set '$3 {}) ; necessary? + (string {}) ; remove from text + ) + 10) + (set '*link-database* link-db) + txt)) + +(define (horizontal-rules txt) + (replace + [text]^[ ]{0,2}([ ]?\*[ ]?){3,}[ \t]*$[/text] + txt + "\n<hr />" + 14) + (replace + [text]^[ ]{0,2}([ ]? -[ ]?){3,}[ \t]*$[/text] + txt + "\n<hr />" + 14) + (replace + [text]^[ ]{0,2}([ ]? _[ ]?){3,}[ \t]*$[/text] + txt + "\n<hr />" + 14)) + +(define (headers txt) + ; setext headers + (let ((level 1)) + (replace + [text]^(.+)[ \t]*\n=+[ \t]*\n+[/text] + txt + (string "<h1>" (span-transforms $1) "</h1>\n\n") + 2) + + (replace + [text]^(.+)[ \t]*\n-+[ \t]*\n+[/text] + txt + (string "<h2>" (span-transforms $1) "</h2>\n\n") + 2) + ; atx headers + (replace + [text]^(\#{1,6})\s*(.+?)[ ]*\#*(\n+)[/text] + txt + (begin + (set 'level (length $1)) + (string "<h" level ">" (span-transforms $2) "</h" level ">\n\n") + ) + 2))) + +(define (lists txt) + (letn ((marker-ul {[*+-]}) + (marker-ol {\d+[.]}) + (marker-any (string {(?:} marker-ul {|} marker-ol {)})) + (whole-list-regex (string [text](([ ]{0,3}([/text] marker-any [text])[ \t]+)(?s:.+?)(\z|\n{2,}(?=\S)(?![ \t]*[/text] marker-any [text][ \t]+)))[/text])) + (my-list {}) + (list-type {}) + (my-result {})) + (replace + (if (> *list-level* 0) + (string {^} whole-list-regex) + (string {(?:(?<=\n\n)|\A\n?)} whole-list-regex)) + txt + (begin + (set 'my-list $1) + (if (find $3 marker-ul) + (set 'list-type "ul" 'marker-type marker-ul) + (set 'list-type "ol" 'marker-type marker-ol)) + (replace [text]\n{2,}[/text] my-list "\n\n\n" 0) + (set 'my-result (process-list-items my-list marker-any)) + (replace {\s+$} my-result {} 0) + (string {<} list-type {>} "\n" my-result "\n" {</} list-type {>} "\n")) + 10 ; must be multiline + ))) + +(define (process-list-items list-text marker-any) + (let ((list-regex (string [text](\n)?(^[ \t]*)([/text] marker-any [text])[ \t]+((?s:.+?)(\n{1,2}))(?=\n*(\z|\2([/text] marker-any [text])[ \t]+))[/text])) + (item {}) + (leading-line {}) + (leading-space {}) + (result {})) + (inc *list-level*) + (replace [text]\n{2,}\z[/text] list-text "\n" 0) + (set '$1 {} '$2 {} '$3 {} '$4 {} '$5 {}) + (replace + list-regex + list-text + (begin + (set 'item $4) + (set 'leading-line $1) + (set 'leading-space $2) + (if (or (not (empty? leading-line)) (ends-with item "\n{2,}" 0)) + (set 'item (block-transforms (outdent item))) + ; recurse for sub lists + (begin + (set 'item (lists (outdent item))) + (set 'item (span-transforms (trim item "\n"))) + )) + (string {<li>} item {</li>} "\n")) + 10) + (dec *list-level*) + list-text)) + +(define (code-blocks txt) + (let ((code-block {}) + (token-list '())) + (replace + [text](?:\n\n|\A)((?:(?:[ ]{4}|\t).*\n+)+)((?=^[ ]{0,3}\S)|\Z)[/text] + txt + (begin + (set 'code-block $1) + ; format if Nestor module is loaded and it's not marked as plain + (if (and (not (starts-with code-block " ;plain\n")) (context? Nestor)) + ; format newlisp + (begin + ; remove flag if present + (replace "[ ]{4};newlisp\n" code-block {} 0) + (set 'code-block (protect (Nestor:nlx-to-html (Nestor:my-read (trim (detab (outdent code-block)) "\n"))))) + code-block) + ; don't format + (begin + ; trim leading and trailing newlines + (replace "[ ]{4};plain\n" code-block {} 0) + (set 'code-block (trim (detab (encode-code (outdent code-block))) "\n")) + (set '$1 {}) + (set 'code-block (string "\n\n<pre><code>" code-block "\n</code></pre>\n\n"))))) + 10))) + +(define (block-quotes txt) + (let ((block-quote {})) + (replace + [text]((^[ \t]*>[ \t]?.+\n(.+\n)*\n*)+)[/text] + txt + (begin + (set 'block-quote $1) + (replace {^[ ]*>[ ]?} block-quote {} 2) + (replace {^[ ]+$} block-quote {} 2) + (set 'block-quote (block-transforms block-quote)) ; recurse + ; remove leading spaces + (replace + {(\s*<pre>.+?</pre>)} + block-quote + (trim $1) + 2) + (string "<blockquote>\n" block-quote "\n</blockquote>\n\n")) + 2))) + +(define (outdent s) + (replace [text]^(\t|[ ]{1,4})[/text] s {} 2)) + +(define (detab s) + (replace [text](.*?)\t[/text] + s + (string $1 (dup { } (- 4 (% (length $1) 4)))) + 2)) + +(define (form-paragraphs txt) + (let ((grafs '()) + (original nil)) + (set 'txt (trim txt "\n")) ; strip blank lines before and after + (set 'grafs (parse txt "\n{2,}" 0)) ; split + (dolist (p grafs) + (if (set 'original (lookup p *hashed-html-blocks*)) + ; html blocks + (setf (grafs $idx) original) + ; wrap <p> tags round everything else + (setf (grafs $idx) (string {<p>} (replace {^[ ]*} (span-transforms p) {} (+ 4 8 16)) {</p>})))) + (join grafs "\n\n"))) + +[text] +; three command line arguments: let's hope last one is a file +(when (= 3 (length (main-args))) + (println (markdown (read-file (main-args 2)))) + (exit)) + +; hack for command-line and module loading +(set 'level (sys-info 3)) + +; if level is 2, then we're probably invoking markdown.lsp directly +; if level is > 3, then we're probably loading it into another script... + +(when (= level 2) + ; running on command line, read STDIN and execute: + (while (read-line) + (push (current-line) *stdin* -1)) + (println (markdown (join *stdin* "\n"))) + (exit)) +[/text] + +;; version 2011-09-16 16:31:29 +;; Changed to different hash routine. Profiling shows that hashing takes 40% of the execution time. +;; Unfortunately this new version is only very slightly faster. +;; Command-line arguments hack in previous version doesn't work. +;; +;; version 2011-08-18 15:04:40 +;; various fixes, and added hack for running this from the command-line: +;; echo "hi there" | newlisp markdown.lsp +;; echo "hello world" | markdown.lsp +;; cat file.text | newlisp markdown.lsp +;; +;; version 2010-11-14 17:34:52 +;; some problems in ustring. Probably remove it one day, as it's non standard... +;; +;; version 2010-10-14 18:41:38 +;; added code to work round PCRE crash in (protect ... +;; +;; version date 2010-07-10 22:20:25 +;; modified call to 'read' since lutz has changed it +;; +;; version date 2009-11-16 22:10:10 +;; fixed bug in tokenize.html +;; +;; version date 2008-10-08 18:44:46 +;; changed nth-set to setf to be version-10 ready. +;; This means that now this script will NOT work with +;; earlier versions of newLISP!!!!!!!!!!! +;; requires Nestor if you want source code colouring... +;; +;; version date 2008-08-08 16:54:56 +;; changed (unless to (if (not ... :( +;; +;; version date 2008-07-20 14:!2:29 +;; added hex-str-to-unicode-char ustring +;; +;; version date 2008-03-07 15:36:09 +;; fixed load error +;; +;; version date 2007-11-17 16:20:57 +;; added syntax colouring module +;; +;; version date 2007-11-14 09:19:42 +;; removed reliance on dostring for compatibility with 9.1 + + +; eof
\ No newline at end of file diff --git a/tests/examplefiles/nemerle_sample.n b/tests/examplefiles/nemerle_sample.n index 2c05033a..5236857d 100644 --- a/tests/examplefiles/nemerle_sample.n +++ b/tests/examplefiles/nemerle_sample.n @@ -13,13 +13,15 @@ namespace Demo.Ns public virtual someMethod(str : string) : list[double] { def x = "simple string"; - def x = $"simple $splice string $(spliceMethod())"; + def x = $"simple $splice string $(spliceMethod() + 1)"; def x = <# recursive <# string #> sample #>; def x = $<# recursive $splice <# string #> sample + ..$(lst; "; "; x => $"x * 2 = $(x * 2)") str #>; + def x = @"somestring \"; def localFunc(arg) { @@ -80,6 +82,6 @@ namespace Demo.Ns macro sampleMacro(expr) syntax ("write", expr) { - <[ WriteLine($expr) ]> + <[ WriteLine($(expr : dyn)) ]> } } diff --git a/tests/examplefiles/reversi.lsp b/tests/examplefiles/reversi.lsp new file mode 100644 index 00000000..fa9a333c --- /dev/null +++ b/tests/examplefiles/reversi.lsp @@ -0,0 +1,427 @@ +#!/usr/bin/env newlisp +;; @module reversi.lsp +;; @description a simple version of Reversi: you as white against newLISP as black +;; @version 0.1 alpha August 2007 +;; @author cormullion +;; +;; 2008-10-08 21:46:54 +;; updated for newLISP version 10. (changed nth-set to setf) +;; this now does not work with newLISP version 9! +;; +;; This is my first attempt at writing a simple application using newLISP-GS. +;; The game algorithms are basically by +;; Peter Norvig http://norvig.com/paip/othello.lisp +;; and all I've done is translate to newLISP and add the interface... +;; +;; To-Do: work out how to handle the end of the game properly... +;; To-Do: complete newlispdoc for the functions + +(constant 'empty 0) +(constant 'black 1) +(constant 'white 2) +(constant 'outer 3) ; squares outside the 8x8 board + +(set '*board* '()) ; the master board is a 100 element list +(set '*moves* '()) ; list of moves made + +; these are the 8 different directions from a square on the board + +(set 'all-directions '(-11 -10 -9 -1 1 9 10 11)) + +; return a list of all the playable squares (the 8 by 8 grid inside the 10by10 + +(define (all-squares) + (local (result) + (for (square 11 88) + (if (<= 1 (mod square 10) 8) + (push square result -1))) +result)) + +; make a board + +(define (make-board) + (set '*board* (dup outer 100)) + (dolist (s (all-squares)) + (setf (*board* s) empty))) + +; for testing and working at a terminal + +(define (print-board) + (print { }) + (for (c 1 8) + (print c)) + (set 'c 0) + (for (i 0 99) + (cond + ((= (*board* i) 0) (print {.})) + ((= (*board* i) 1) (print {b})) + ((= (*board* i) 2) (print {w}))) + (if (and (<= i 88) (= (mod (+ i 1) 10) 0)) ; newline + (print "\n" (inc c)))) + (println "\n")) + +; the initial starting pattern + +(define (initial-board) + (make-board) + (setf (*board* 44) white) + (setf (*board* 55) white) + (setf (*board* 45) black) + (setf (*board* 54) black)) + +(define (opponent player) + (if (= player black) white black)) + +(define (player-name player) + (if (= player white) "white" "black")) + +(define (valid-move? move) + (and + (integer? move) + (<= 11 move 88) + (<= 1 (mod move 10) 8))) + +(define (empty-square? square) + (and + (valid-move? square) + (= (*board* square) empty))) + +; test whether a move is legal. The square must be empty +; and it must flip at least one of the opponent's piece + +(define (legal-move? move player) + (and + (empty-square? move) + (exists (fn (dir) (would-flip? move player dir)) all-directions))) + +; would this move by player result in any flips in the given direction? +; if so, return the number of the 'opposite' (bracketing) piece's square + +(define (would-flip? move player dir) + (let + ((c (+ move dir))) + (and + (= (*board* c) (opponent player)) + (find-bracketing-piece (+ c dir) player dir)))) + +(define (find-bracketing-piece square player dir) + ; return the square of the bracketing piece, if any + (cond + ((= (*board* square) player) square) + ((= (*board* square) (opponent player)) + (find-bracketing-piece (+ square dir) player dir)) + (true nil))) + +(define (make-flips move player dir) + (let + ((bracketer (would-flip? move player dir)) + (c (+ move dir))) + (if bracketer + (do-until (= c bracketer) + (setf (*board* c) player) + (push c *flips* -1) + (inc c dir))))) + +; make the move on the master game board, not yet visually + +(define (make-move move player) + (setf (*board* move) player) + (push move *moves* -1) + (set '*flips* '()) ; we're going to keep a record of the flips made + (dolist (dir all-directions) + (make-flips move player dir))) + +(define (next-to-play previous-player) + (let ((opp (opponent previous-player))) + (cond + ((any-legal-move? opp) opp) + ((any-legal-move? previous-player) + (println (player-name opp) " has no moves") + previous-player) + (true nil)))) + +; are there any legal moves (returns first) for this player? +(define (any-legal-move? player) + (exists (fn (move) (legal-move? move player)) + (all-squares))) + +; a list of all legal moves might be useful +(define (legal-moves player) + (let ((result '())) + (dolist (move (all-squares)) + (if (legal-move? move player) + (push move result))) + (unique result))) + +; define any number of strategies that can be called on to calculate +; the next computer move. This is the only one I've done... - make +; any legal move at random! + +(define (random-strategy player) + (seed (date-value)) + (apply amb (legal-moves player))) + +; get the next move using a particular strategy + +(define (get-move strategy player) + (let ((move (apply strategy (list player)))) + (cond + ((and + (valid-move? move) + (legal-move? move player)) + (make-move move player)) + (true + (println "no valid or legal move for " (player-name player) ) + nil)) + move)) + +; that's about all the game algorithms for now +; now for the interface + +(if (= ostype "Win32") + (load (string (env "PROGRAMFILES") "/newlisp/guiserver.lsp")) + (load "/usr/share/newlisp/guiserver.lsp") +) + +(gs:init) +(map set '(screen-width screen-height) (gs:get-screen)) +(set 'board-width 540) +; center on screen +(gs:frame 'Reversi (- (/ screen-width 2) (/ board-width 2)) 60 board-width 660 "Reversi") +(gs:set-border-layout 'Reversi) + +(gs:canvas 'MyCanvas 'Reversi) + (gs:set-background 'MyCanvas '(.8 .9 .7 .8)) + (gs:mouse-released 'MyCanvas 'mouse-released-action true) + +(gs:panel 'Controls) + (gs:button 'Start 'start-game "Start") + +(gs:panel 'Lower) + (gs:label 'WhiteScore "") + (gs:label 'BlackScore "") + +(gs:add-to 'Controls 'Start ) +(gs:add-to 'Lower 'WhiteScore 'BlackScore) +(gs:add-to 'Reversi 'MyCanvas "center" 'Controls "north" 'Lower "south") + +(gs:set-anti-aliasing true) +(gs:set-visible 'Reversi true) + +; size of board square, and radius/width of counter +(set 'size 60 'width 30) + +; initialize the master board + +(define (initial-board) + (make-board) + (setf (*board* 44) white) + (setf (*board* 55) white) + (setf (*board* 45) black) + (setf (*board* 54) black) +) + +; draw a graphical repesentation of the board + +(define (draw-board) + (local (x y) + (dolist (i (all-squares)) + (map set '(x y) (square-to-xy i)) + (gs:draw-rect + (string x y) + (- (* y size) width ) ; !!!!!! + (- (* x size) width ) + (* width 2) + (* width 2) + gs:white)))) + +(define (draw-first-four-pieces) + (draw-piece 44 "white") + (draw-piece 55 "white") + (draw-piece 45 "black") + (draw-piece 54 "black")) + +; this next function can mark the legal moves available to a player + +(define (show-legal-moves player) + (local (legal-move-list x y) + (set 'legal-move-list (legal-moves player)) + (dolist (m (all-squares)) + (map set '(x y) (square-to-xy m)) + (gs:draw-rect + (string x y) + (- (* y size) width ) ; !!!!!! + (- (* x size) width ) + (* width 2) + (* width 2) + (if (find m legal-move-list) gs:blue gs:white) + ) + ) + ) +) + +; convert the number of a square on the master board to coordinates + +(define (square-to-xy square) + (list (/ square 10) (mod square 10))) + +; draw one of the pieces + +(define (draw-piece square colour) + (local (x y) + (map set '(x y) (square-to-xy square)) + (cond + ((= colour "white") + (gs:fill-circle + (string x y) + (* y size) ; !!!!!!! y first, cos y is x ;-) + (* x size) + width + gs:white)) + + ((= colour "black") + (gs:fill-circle + (string x y) + (* y size) + (* x size) + width + gs:black)) + + ((= colour "empty") + (gs:draw-rect + (string x y) + (- (* y size) width ) + (- (* x size) width ) + (* width 2) + (* width 2) + gs:white)) + ))) + +; animate the pieces flipping + +(define (flip-piece square player) +; flip by drawing thinner and fatter ellipses +; go from full disk in opposite colour to invisible +; then from invisible to full disk in true colour + (local (x y colour) + (map set '(x y) (square-to-xy square)) + ; delete original piece + (gs:delete-tag (string x y)) + (set 'colour (if (= player 2) gs:black gs:white )) + (for (i width 1 -3) + (gs:fill-ellipse + (string x y {flip} i) + (* y size) ; y first :-) !!! + (* x size) + i + width + colour) + (sleep 20) ; this might need adjusting... + (gs:delete-tag (string x y {flip} i)) + ) + (set 'colour (if (= player 2) gs:white gs:black)) + (for (i 1 width 3) + (gs:fill-ellipse + (string x y {flip} i) + (* y size) ; :-) !!! + (* x size) + i + width + colour) + (sleep 20) + (gs:delete-tag (string x y {flip} i)) + ) + ; draw the piece again + (gs:fill-circle + (string x y) + (* y size) + (* x size) + width + colour) + ) +) + +(define (do-move move player) + (cond + ; check if the move is good ... + ((and (!= player nil) + (valid-move? move) + (legal-move? move player)) + + ; ... play it + ; make move on board + (make-move move player) + ; and on screen + (draw-piece move (player-name player)) + (gs:update) + ; do flipping stuff + + ; wait for a while + (sleep 1000) + + ; then do flipping + (dolist (f *flips*) + (flip-piece f player)) + + (inc *move-number*) + (draw-piece move (player-name player)) + (gs:update) + + ; update scores + (gs:set-text 'WhiteScore + (string "White: " (first (count (list white) *board*)))) + (gs:set-text 'BlackScore + (string "Black: " (first (count (list black) *board*)))) + ) + ; or return nil + (true + nil))) + +; the game is driven by the mouse clicks of the user +; in reply, the computer plays a black piece +; premature clicking is possible and possibly a bad thing... + +(define (mouse-released-action x y button modifiers tags) + ; extract the tag of the clicked square + (set 'move (int (string (first tags)) 0 10)) + (if (do-move move player) + (begin + (set 'player (next-to-play player)) + ; there is a training mode - legal squares are highlighted + ; you can uncomment the next line... + ; (show-legal-moves player) + (gs:update) + + ; wait for black's reply + (gs:set-cursor 'Reversi "wait") + (gs:set-text 'Start "black's move - thinking...") + ; give the illusion of Deep Thought... + (sleep 2000) + ; black's reply + ; currently only the random strategy has been defined... + (set 'strategy random-strategy) + (set 'move (apply strategy (list player))) + (do-move move player) + (set 'player (next-to-play player)) + ; (show-legal-moves player) ; to see black's moves + (gs:set-text 'Start "your move") + (gs:set-cursor 'Reversi "default") + (gs:update)))) + +(define (start-game) + (gs:set-text 'Start "Click a square to place a piece!") + (gs:disable 'Start) + (set 'player white)) + +(define (start) + (gs:set-text 'Start "Start") + (gs:enable 'Start) + (set '*move-number* 1 + '*flips* '()) + (initial-board) + (draw-board) + (draw-first-four-pieces)) + +(start) + +(gs:listen)
\ No newline at end of file diff --git a/tests/examplefiles/test.bro b/tests/examplefiles/test.bro new file mode 100644 index 00000000..9a1b42de --- /dev/null +++ b/tests/examplefiles/test.bro @@ -0,0 +1,250 @@ +@load notice +@load utils/thresholds + +module SSH; + +export { + redef enum Log::ID += { SSH }; + + redef enum Notice::Type += { + Login, + Password_Guessing, + Login_By_Password_Guesser, + Login_From_Interesting_Hostname, + Bytecount_Inconsistency, + }; + + type Info: record { + ts: time &log; + uid: string &log; + id: conn_id &log; + status: string &log &optional; + direction: string &log &optional; + remote_location: geo_location &log &optional; + client: string &log &optional; + server: string &log &optional; + resp_size: count &log &default=0; + + ## Indicate if the SSH session is done being watched. + done: bool &default=F; + }; + + const password_guesses_limit = 30 &redef; + + # The size in bytes at which the SSH connection is presumed to be + # successful. + const authentication_data_size = 5500 &redef; + + # The amount of time to remember presumed non-successful logins to build + # model of a password guesser. + const guessing_timeout = 30 mins &redef; + + # The set of countries for which you'd like to throw notices upon successful login + # requires Bro compiled with libGeoIP support + const watched_countries: set[string] = {"RO"} &redef; + + # Strange/bad host names to originate successful SSH logins + const interesting_hostnames = + /^d?ns[0-9]*\./ | + /^smtp[0-9]*\./ | + /^mail[0-9]*\./ | + /^pop[0-9]*\./ | + /^imap[0-9]*\./ | + /^www[0-9]*\./ | + /^ftp[0-9]*\./ &redef; + + # This is a table with orig subnet as the key, and subnet as the value. + const ignore_guessers: table[subnet] of subnet &redef; + + # If true, we tell the event engine to not look at further data + # packets after the initial SSH handshake. Helps with performance + # (especially with large file transfers) but precludes some + # kinds of analyses (e.g., tracking connection size). + const skip_processing_after_detection = F &redef; + + # Keeps count of how many rejections a host has had + global password_rejections: table[addr] of TrackCount + &write_expire=guessing_timeout + &synchronized; + + # Keeps track of hosts identified as guessing passwords + # TODO: guessing_timeout doesn't work correctly here. If a user redefs + # the variable, it won't take effect. + global password_guessers: set[addr] &read_expire=guessing_timeout+1hr &synchronized; + + global log_ssh: event(rec: Info); +} + +# Configure DPD and the packet filter +redef capture_filters += { ["ssh"] = "tcp port 22" }; +redef dpd_config += { [ANALYZER_SSH] = [$ports = set(22/tcp)] }; + +redef record connection += { + ssh: Info &optional; +}; + +event bro_init() +{ + Log::create_stream(SSH, [$columns=Info, $ev=log_ssh]); +} + +function set_session(c: connection) + { + if ( ! c?$ssh ) + { + local info: Info; + info$ts=network_time(); + info$uid=c$uid; + info$id=c$id; + c$ssh = info; + } + } + +function check_ssh_connection(c: connection, done: bool) + { + # If done watching this connection, just return. + if ( c$ssh$done ) + return; + + # If this is still a live connection and the byte count has not + # crossed the threshold, just return and let the resheduled check happen later. + if ( !done && c$resp$size < authentication_data_size ) + return; + + # Make sure the server has sent back more than 50 bytes to filter out + # hosts that are just port scanning. Nothing is ever logged if the server + # doesn't send back at least 50 bytes. + if ( c$resp$size < 50 ) + return; + + local status = "failure"; + local direction = Site::is_local_addr(c$id$orig_h) ? "to" : "from"; + local location: geo_location; + location = (direction == "to") ? lookup_location(c$id$resp_h) : lookup_location(c$id$orig_h); + + if ( done && c$resp$size < authentication_data_size ) + { + # presumed failure + if ( c$id$orig_h !in password_rejections ) + password_rejections[c$id$orig_h] = new_track_count(); + + # Track the number of rejections + if ( !(c$id$orig_h in ignore_guessers && + c$id$resp_h in ignore_guessers[c$id$orig_h]) ) + ++password_rejections[c$id$orig_h]$n; + + if ( default_check_threshold(password_rejections[c$id$orig_h]) ) + { + add password_guessers[c$id$orig_h]; + NOTICE([$note=Password_Guessing, + $conn=c, + $msg=fmt("SSH password guessing by %s", c$id$orig_h), + $sub=fmt("%d failed logins", password_rejections[c$id$orig_h]$n), + $n=password_rejections[c$id$orig_h]$n]); + } + } + # TODO: This is to work around a quasi-bug in Bro which occasionally + # causes the byte count to be oversized. + # Watch for Gregors work that adds an actual counter of bytes transferred. + else if ( c$resp$size < 20000000 ) + { + # presumed successful login + status = "success"; + c$ssh$done = T; + + if ( c$id$orig_h in password_rejections && + password_rejections[c$id$orig_h]$n > password_guesses_limit && + c$id$orig_h !in password_guessers ) + { + add password_guessers[c$id$orig_h]; + NOTICE([$note=Login_By_Password_Guesser, + $conn=c, + $n=password_rejections[c$id$orig_h]$n, + $msg=fmt("Successful SSH login by password guesser %s", c$id$orig_h), + $sub=fmt("%d failed logins", password_rejections[c$id$orig_h]$n)]); + } + + local message = fmt("SSH login %s %s \"%s\" \"%s\" %f %f %s (triggered with %d bytes)", + direction, location$country_code, location$region, location$city, + location$latitude, location$longitude, + id_string(c$id), c$resp$size); + NOTICE([$note=Login, + $conn=c, + $msg=message, + $sub=location$country_code]); + + # Check to see if this login came from an interesting hostname + when ( local hostname = lookup_addr(c$id$orig_h) ) + { + if ( interesting_hostnames in hostname ) + { + NOTICE([$note=Login_From_Interesting_Hostname, + $conn=c, + $msg=fmt("Strange login from %s", hostname), + $sub=hostname]); + } + } + + if ( location$country_code in watched_countries ) + { + + } + + } + else if ( c$resp$size >= 200000000 ) + { + NOTICE([$note=Bytecount_Inconsistency, + $conn=c, + $msg="During byte counting in SSH analysis, an overly large value was seen.", + $sub=fmt("%d",c$resp$size)]); + } + + c$ssh$remote_location = location; + c$ssh$status = status; + c$ssh$direction = direction; + c$ssh$resp_size = c$resp$size; + + Log::write(SSH, c$ssh); + + # Set the "done" flag to prevent the watching event from rescheduling + # after detection is done. + c$ssh$done; + + # Stop watching this connection, we don't care about it anymore. + if ( skip_processing_after_detection ) + { + skip_further_processing(c$id); + set_record_packets(c$id, F); + } + } + +event connection_state_remove(c: connection) &priority=-5 + { + if ( c?$ssh ) + check_ssh_connection(c, T); + } + +event ssh_watcher(c: connection) + { + local id = c$id; + # don't go any further if this connection is gone already! + if ( !connection_exists(id) ) + return; + + check_ssh_connection(c, F); + if ( ! c$ssh$done ) + schedule +15secs { ssh_watcher(c) }; + } + +event ssh_server_version(c: connection, version: string) &priority=5 + { + set_session(c); + c$ssh$server = version; + } + +event ssh_client_version(c: connection, version: string) &priority=5 + { + set_session(c); + c$ssh$client = version; + schedule +15secs { ssh_watcher(c) }; + } diff --git a/tests/examplefiles/test.cs b/tests/examplefiles/test.cs index ffa9bfea..faab7e42 100644 --- a/tests/examplefiles/test.cs +++ b/tests/examplefiles/test.cs @@ -153,6 +153,29 @@ namespace Diva.Core { public OpenerTask (string fileName) { this.fileName = fileName; + var verbatimString = @"c:\test\"; + + var verbatimStringWithNewline = @"test \\ \n \t \r +a +b +c"; + var verbatimStringWithEscapedQuotes = @"He said +""she says \"" is not an escaped character in verbatimstrings"" +"; + + int[] numbers = { 5,6,4,2,4,6,8,9,7,0 }; + var linqExample = from n in numbers + where n > 5 + select n; + + var anotherlinqExample = from n in numbers + orderby n descending + select n; + + int[] someMoreNumbers = { 8,2,17,34,8,9,9,5,3,4,2,1,5 }; + var moreLinq = from n in numbers + join mn in moreNumbers on n equals mn + 2 + select new {n, mn}; } public override void Reset () diff --git a/tests/examplefiles/test.dart b/tests/examplefiles/test.dart new file mode 100644 index 00000000..aa1fb0ed --- /dev/null +++ b/tests/examplefiles/test.dart @@ -0,0 +1,23 @@ +// Greeter example from +// <http://www.dartlang.org/docs/getting-started/interface.html> +class Greeter implements Comparable { + String prefix = 'Hello,'; + Greeter() {} + Greeter.withPrefix(this.prefix); + greet(String name) => print('$prefix $name'); + + int compareTo(Greeter other) => prefix.compareTo(other.prefix); +} + +void main() { + Greeter greeter = new Greeter(); + Greeter greeter2 = new Greeter.withPrefix('Hi,'); + + num result = greeter2.compareTo(greeter); + if (result == 0) { + greeter2.greet('you are the same.'); + } else { + greeter2.greet('you are different.'); + } +} + diff --git a/tests/examplefiles/test.ecl b/tests/examplefiles/test.ecl new file mode 100644 index 00000000..b686492a --- /dev/null +++ b/tests/examplefiles/test.ecl @@ -0,0 +1,58 @@ +/*############################################################################## + + Copyright (C) 2011 HPCC Systems. + + All rights reserved. This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as + published by the Free Software Foundation, either version 3 of the + License, or (at your option) any later version. + + This program 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 Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see <http://www.gnu.org/licenses/>. +############################################################################## */ + +#option ('slidingJoins', true); + +namesRecord := + RECORD +string20 surname; +string10 forename; +integer2 age; +integer2 dadAge; +integer2 mumAge; + END; + +namesRecord2 := + record +string10 extra; +namesRecord; + end; + +namesTable := dataset('x',namesRecord,FLAT); +namesTable2 := dataset('y',namesRecord2,FLAT); + +integer2 aveAgeL(namesRecord l) := (l.dadAge+l.mumAge)/2; +integer2 aveAgeR(namesRecord2 r) := (r.dadAge+r.mumAge)/2; + +// Standard join on a function of left and right +output(join(namesTable, namesTable2, aveAgeL(left) = aveAgeR(right))); + +//Several simple examples of sliding join syntax +output(join(namesTable, namesTable2, left.age >= right.age - 10 and left.age <= right.age +10)); +output(join(namesTable, namesTable2, left.age between right.age - 10 and right.age +10)); +output(join(namesTable, namesTable2, left.age between right.age + 10 and right.age +30)); +output(join(namesTable, namesTable2, left.age between (right.age + 20) - 10 and (right.age +20) + 10)); +output(join(namesTable, namesTable2, aveAgeL(left) between aveAgeR(right)+10 and aveAgeR(right)+40)); + +//Same, but on strings. Also includes age to ensure sort is done by non-sliding before sliding. +output(join(namesTable, namesTable2, left.surname between right.surname[1..10]+'AAAAAAAAAA' and right.surname[1..10]+'ZZZZZZZZZZ' and left.age=right.age)); +output(join(namesTable, namesTable2, left.surname between right.surname[1..10]+'AAAAAAAAAA' and right.surname[1..10]+'ZZZZZZZZZZ' and left.age=right.age,all)); + +//This should not generate a self join +output(join(namesTable, namesTable, left.age between right.age - 10 and right.age +10)); + diff --git a/tests/examplefiles/test.fan b/tests/examplefiles/test.fan new file mode 100755 index 00000000..00e80b60 --- /dev/null +++ b/tests/examplefiles/test.fan @@ -0,0 +1,818 @@ +// +// Copyright (c) 2008, Brian Frank and Andy Frank +// Licensed under the Academic Free License version 3.0 +// +// History: +// 17 Nov 08 Brian Frank Creation +// + +using compiler + +** +** JavaBridge is the compiler plugin for bringing Java +** classes into the Fantom type system. +** +class JavaBridge : CBridge +{ + +////////////////////////////////////////////////////////////////////////// +// Constructor +////////////////////////////////////////////////////////////////////////// + + ** + ** Construct a JavaBridge for current environment + ** + new make(Compiler c, ClassPath cp := ClassPath.makeForCurrent) + : super(c) + { + this.cp = cp + } + +////////////////////////////////////////////////////////////////////////// +// Namespace +////////////////////////////////////////////////////////////////////////// + + ** + ** Map a FFI "podName" to a Java package. + ** + override CPod resolvePod(Str name, Loc? loc) + { + // the empty package is used to represent primitives + if (name == "") return primitives + + // look for package name in classpatch + classes := cp.classes[name] + if (classes == null) + throw CompilerErr("Java package '$name' not found", loc) + + // map package to JavaPod + return JavaPod(this, name, classes) + } + + ** + ** Map class meta-data and Java members to Fantom slots + ** for the specified JavaType. + ** + virtual Void loadType(JavaType type, Str:CSlot slots) + { + JavaReflect.loadType(type, slots) + } + +////////////////////////////////////////////////////////////////////////// +// Call Resolution +////////////////////////////////////////////////////////////////////////// + + ** + ** Resolve a construction call to a Java constructor. + ** + override Expr resolveConstruction(CallExpr call) + { + // if the last argument is an it-block, then we know + // right away that we will not be passing it thru to Java, + // so strip it off to be appended as call to Obj.with + itBlock := call.args.last as ClosureExpr + if (itBlock != null && itBlock.isItBlock) + call.args.removeAt(-1) + else + itBlock = null + + // if this is an interop array like IntArray/int[] use make + // factory otherwise look for Java constructor called <init> + JavaType base := call.target.ctype + if (base.isInteropArray) + call.method = base.method("make") + else + call.method = base.method("<init>") + + // call resolution to deal with overloading + call = resolveCall(call) + + // we need to create an implicit target for the Java runtime + // to perform the new opcode to ensure it is on the stack + // before the args (we don't do this for interop Array classes) + if (!base.isInteropArray) + { + loc := call.loc + call.target = CallExpr.makeWithMethod(loc, null, base.newMethod) { synthetic=true } + } + + // if we stripped an it-block argument, + // add it as trailing call to Obj.with + if (itBlock != null) return itBlock.toWith(call) + return call + } + + ** + ** Resolve a construction chain call where a Fantom constructor + ** calls the super-class constructor. Type check the arguments + ** and insert any conversions needed. + ** + override Expr resolveConstructorChain(CallExpr call) + { + // we don't allow chaining to a this ctor for Java FFI + if (call.target.id !== ExprId.superExpr) + throw err("Must use super constructor call in Java FFI", call.loc) + + // route to a superclass constructor + JavaType base := call.target.ctype.deref + call.method = base.method("<init>") + + // call resolution to deal with overloading + return resolveCall(call) + } + + ** + ** Given a dot operator slot access on the given foreign + ** base type, determine the appopriate slot to use based on + ** whether parens were used + ** base.name => noParens = true + ** base.name() => noParens = false + ** + ** In Java a given name could be bound to both a field and + ** a method. In this case we only resolve the field if + ** no parens are used. We also handle the special case of + ** Java annotations here because their element methods are + ** also mapped as Fantom fields (instance based mixin field). + ** + override CSlot? resolveSlotAccess(CType base, Str name, Bool noParens) + { + // first try to resolve as a field + field := base.field(name) + if (field != null) + { + // if no () we used and this isn't an annotation field + if (noParens && (field.isStatic || !base.isMixin)) + return field + + // if we did find a field, then make sure we use that + // field's parent type to resolve a method (becuase the + // base type might be a sub-class of a Java type in which + // case it is unware of field/method overloads) + return field.parent.method(name) + } + + // lookup method + return base.method(name) + } + + ** + ** Resolve a method call: try to find the best match + ** and apply any coercions needed. + ** + override CallExpr resolveCall(CallExpr call) + { + // try to match against all the overloaded methods + matches := CallMatch[,] + CMethod? m := call.method + while (m != null) + { + match := matchCall(call, m) + if (match != null) matches.add(match) + m = m is JavaMethod ? ((JavaMethod)m).next : null + } + + // if we have exactly one match use then use that one + if (matches.size == 1) return matches[0].apply(call) + + // if we have multiple matches; resolve to + // most specific match according to JLS rules + // TODO: this does not correct resolve when using Fantom implicit casting + if (matches.size > 1) + { + best := resolveMostSpecific(matches) + if (best != null) return best.apply(call) + } + + // zero or multiple ambiguous matches is a compiler error + s := StrBuf() + s.add(matches.isEmpty ? "Invalid args " : "Ambiguous call ") + s.add(call.name).add("(") + s.add(call.args.join(", ") |Expr arg->Str| { return arg.toTypeStr }) + s.add(")") + throw err(s.toStr, call.loc) + } + + ** + ** Check if the call matches the specified overload method. + ** If so return method and coerced args otherwise return null. + ** + internal CallMatch? matchCall(CallExpr call, CMethod m) + { + // first check if have matching numbers of args and params + args := call.args + if (m.params.size < args.size) return null + + // check if each argument is ok or can be coerced + isErr := false + newArgs := args.dup + m.params.each |CParam p, Int i| + { + if (i >= args.size) + { + // param has a default value, then that is ok + if (!p.hasDefault) isErr = true + } + else + { + // ensure arg fits parameter type (or auto-cast) + newArgs[i] = coerce(args[i], p.paramType) |->| { isErr = true } + } + } + if (isErr) return null + return CallMatch { it.method = m; it.args = newArgs } + } + + ** + ** Given a list of overloaed methods find the most specific method + ** according to Java Language Specification 15.11.2.2. The "informal + ** intuition" rule is that a method is more specific than another + ** if the first could be could be passed onto the second one. + ** + internal static CallMatch? resolveMostSpecific(CallMatch[] matches) + { + CallMatch? best := matches[0] + for (i:=1; i<matches.size; ++i) + { + x := matches[i] + if (isMoreSpecific(best, x)) { continue } + if (isMoreSpecific(x, best)) { best = x; continue } + return null + } + return best + } + + ** + ** Is 'a' more specific than 'b' such that 'a' could be used + ** passed to 'b' without a compile time error. + ** + internal static Bool isMoreSpecific(CallMatch a, CallMatch b) + { + return a.method.params.all |CParam ap, Int i->Bool| + { + bp := b.method.params[i] + return ap.paramType.fits(bp.paramType) + } + } + +////////////////////////////////////////////////////////////////////////// +// Overrides +////////////////////////////////////////////////////////////////////////// + + ** + ** Called during Inherit step when a Fantom slot overrides a FFI slot. + ** Log and throw compiler error if there is a problem. + ** + override Void checkOverride(TypeDef t, CSlot base, SlotDef def) + { + // we don't allow Fantom to override Java methods with multiple + // overloaded versions since the Fantom type system can't actually + // override all the overloaded versions + jslot := base as JavaSlot + if (jslot?.next != null) + throw err("Cannot override Java overloaded method: '$jslot.name'", def.loc) + + // route to method override checking + if (base is JavaMethod && def is MethodDef) + checkMethodOverride(t, base, def) + } + + ** + ** Called on method/method overrides in the checkOverride callback. + ** + private Void checkMethodOverride(TypeDef t, JavaMethod base, MethodDef def) + { + // bail early if we know things aren't going to work out + if (base.params.size != def.params.size) return + + // if the return type is primitive or Java array and the + // Fantom declaration matches how it is inferred into the Fan + // type system, then just change the return type - the compiler + // will impliclty do all the return coercions + if (isOverrideInferredType(base.returnType, def.returnType)) + { + def.ret = def.inheritedRet = base.returnType + } + + // if any of the parameters is a primitive or Java array + // and the Fantom declaration matches how it is inferred into + // the Fantom type type, then change the parameter type to + // the Java override type and make the Fantom type a local + // variable: + // Java: void foo(int a) { ... } + // Fantom: Void foo(Int a) { ... } + // Result: Void foo(int a_$J) { Int a := a_$J; ... } + // + base.params.eachr |CParam bp, Int i| + { + dp := def.paramDefs[i] + if (!isOverrideInferredType(bp.paramType, dp.paramType)) return + + // add local variable: Int bar := bar_$J + local := LocalDefStmt(def.loc) + local.ctype = dp.paramType + local.name = dp.name + local.init = UnknownVarExpr(def.loc, null, dp.name + "_\$J") + def.code.stmts.insert(0, local) + + // rename parameter Int bar -> int bar_$J + dp.name = dp.name + "_\$J" + dp.paramType = bp.paramType + } + } + + ** + ** When overriding a Java method check if the base type is + ** is a Java primitive or array and the override definition is + ** matches how the Java type is inferred in the Fantom type system. + ** If we have a match return true and we'll swizzle things in + ** checkMethodOverride. + ** + static private Bool isOverrideInferredType(CType base, CType def) + { + // check if base class slot is a JavaType + java := base.toNonNullable as JavaType + if (java != null) + { + // allow primitives is it matches the inferred type + if (java.isPrimitive) return java.inferredAs == def + + // allow arrays if mapped as Foo[] -> Foo?[]? + if (java.isArray) return java.inferredAs == def.toNonNullable && def.isNullable + } + return false + } + +////////////////////////////////////////////////////////////////////////// +// CheckErrors +////////////////////////////////////////////////////////////////////////// + + ** + ** Called during CheckErrors step for a type which extends + ** a FFI class or implements any FFI mixins. + ** + override Void checkType(TypeDef def) + { + // can't subclass a primitive array like ByteArray/byte[] + if (def.base.deref is JavaType && def.base.deref->isInteropArray) + { + err("Cannot subclass from Java interop array: $def.base", def.loc) + return + } + + // we don't allow deep inheritance of Java classes because + // the Fantom constructor and Java constructor model don't match + // up past one level of inheritance + // NOTE: that that when we remove this restriction we need to + // test how field initialization works because instance$init + // is almost certain to break with the current emit design + javaBase := def.base + while (javaBase != null && !javaBase.isForeign) javaBase = javaBase.base + if (javaBase != null && javaBase !== def.base) + { + err("Cannot subclass Java class more than one level: $javaBase", def.loc) + return + } + + // ensure that when we map Fantom constructors to Java + // constructors that we don't have duplicate signatures + ctors := def.ctorDefs + ctors.each |MethodDef a, Int i| + { + ctors.each |MethodDef b, Int j| + { + if (i > j && areParamsSame(a, b)) + err("Duplicate Java FFI constructor signatures: '$b.name' and '$a.name'", a.loc) + } + } + } + + ** + ** Do the two methods have the exact same parameter types. + ** + static Bool areParamsSame(CMethod a, CMethod b) + { + if (a.params.size != b.params.size) return false + for (i:=0; i<a.params.size; ++i) + { + if (a.params[i].paramType != b.params[i].paramType) + return false + } + return true + } + +////////////////////////////////////////////////////////////////////////// +// Coercion +////////////////////////////////////////////////////////////////////////// + + ** + ** Return if we can make the actual type fit the expected + ** type, potentially using a coercion. + ** + Bool fits(CType actual, CType expected) + { + // use dummy expression and route to coerce code + dummy := UnknownVarExpr(Loc("dummy"), null, "dummy") { ctype = actual } + fits := true + coerce(dummy, expected) |->| { fits=false } + return fits + } + + ** + ** Coerce expression to expected type. If not a type match + ** then run the onErr function. + ** + override Expr coerce(Expr expr, CType expected, |->| onErr) + { + // handle easy case + actual := expr.ctype + expected = expected.deref + if (actual == expected) return expr + + // handle null literal + if (expr.id === ExprId.nullLiteral && expected.isNullable) + return expr + + // handle Fantom to Java primitives + if (expected.pod == primitives) + return coerceToPrimitive(expr, expected, onErr) + + // handle Java primitives to Fan + if (actual.pod == primitives) + return coerceFromPrimitive(expr, expected, onErr) + + // handle Java array to Fantom list + if (actual.name[0] == '[') + return coerceFromArray(expr, expected, onErr) + + // handle Fantom list to Java array + if (expected.name[0] == '[') + return coerceToArray(expr, expected, onErr) + + // handle sys::Func -> Java interface + if (actual is FuncType && expected.isMixin && expected.toNonNullable is JavaType) + return coerceFuncToInterface(expr, expected.toNonNullable, onErr) + + // handle special classes and interfaces for built-in Fantom + // classes which actually map directly to Java built-in types + if (actual.isBool && boolTypes.contains(expected.toNonNullable.signature)) return box(expr) + if (actual.isInt && intTypes.contains(expected.toNonNullable.signature)) return box(expr) + if (actual.isFloat && floatTypes.contains(expected.toNonNullable.signature)) return box(expr) + if (actual.isDecimal && decimalTypes.contains(expected.toNonNullable.signature)) return expr + if (actual.isStr && strTypes.contains(expected.toNonNullable.signature)) return expr + + // use normal Fantom coercion behavior + return super.coerce(expr, expected, onErr) + } + + ** + ** Ensure value type is boxed. + ** + private Expr box(Expr expr) + { + if (expr.ctype.isVal) + return TypeCheckExpr.coerce(expr, expr.ctype.toNullable) + else + return expr + } + + ** + ** Coerce a fan expression to a Java primitive (other + ** than the ones we support natively) + ** + Expr coerceToPrimitive(Expr expr, JavaType expected, |->| onErr) + { + actual := expr.ctype + + // sys::Int (long) -> int, short, byte + if (actual.isInt && expected.isPrimitiveIntLike) + return TypeCheckExpr.coerce(expr, expected) + + // sys::Float (double) -> float + if (actual.isFloat && expected.isPrimitiveFloat) + return TypeCheckExpr.coerce(expr, expected) + + // no coercion - type error + onErr() + return expr + } + + ** + ** Coerce a Java primitive to a Fantom type. + ** + Expr coerceFromPrimitive(Expr expr, CType expected, |->| onErr) + { + actual := (JavaType)expr.ctype + + // int, short, byte -> sys::Int (long) + if (actual.isPrimitiveIntLike) + { + if (expected.isInt || expected.isObj) + return TypeCheckExpr.coerce(expr, expected) + } + + // float -> sys::Float (float) + if (actual.isPrimitiveFloat) + { + if (expected.isFloat || expected.isObj) + return TypeCheckExpr.coerce(expr, expected) + } + + // no coercion - type error + onErr() + return expr + } + + ** + ** Coerce a Java array to a Fantom list. + ** + Expr coerceFromArray(Expr expr, CType expected, |->| onErr) + { + actual := (JavaType)expr.ctype.toNonNullable + + // if expected is array type + if (expected is JavaType && ((JavaType)expected).isArray) + if (actual.arrayOf.fits(((JavaType)expected).arrayOf)) return expr + + // if expected is Obj + if (expected.isObj) return arrayToList(expr, actual.inferredArrayOf) + + // if expected is list type + if (expected.toNonNullable is ListType) + { + expectedOf := ((ListType)expected.toNonNullable).v + if (actual.inferredArrayOf.fits(expectedOf)) return arrayToList(expr, expectedOf) + } + + // no coercion available + onErr() + return expr + } + + ** + ** Generate List.make(of, expr) where expr is Object[] + ** + private Expr arrayToList(Expr expr, CType of) + { + loc := expr.loc + ofExpr := LiteralExpr(loc, ExprId.typeLiteral, ns.typeType, of) + call := CallExpr.makeWithMethod(loc, null, listMakeFromArray, [ofExpr, expr]) + call.synthetic = true + return call + } + + ** + ** Coerce a Fantom list to Java array. + ** + Expr coerceToArray(Expr expr, CType expected, |->| onErr) + { + loc := expr.loc + expectedOf := ((JavaType)expected.toNonNullable).inferredArrayOf + actual := expr.ctype + + // if actual is list type + if (actual.toNonNullable is ListType) + { + actualOf := ((ListType)actual.toNonNullable).v + if (actualOf.fits(expectedOf)) + { + // (Foo[])list.asArray(cls) + clsLiteral := CallExpr.makeWithMethod(loc, null, JavaType.classLiteral(this, expectedOf)) + asArray := CallExpr.makeWithMethod(loc, expr, listAsArray, [clsLiteral]) + return TypeCheckExpr.coerce(asArray, expected) + } + } + + // no coercion available + onErr() + return expr + } + + ** + ** Attempt to coerce a parameterized sys::Func expr to a Java + ** interface if the interface supports exactly one matching method. + ** + Expr coerceFuncToInterface(Expr expr, JavaType expected, |->| onErr) + { + // check if we have exactly one abstract method in the expected type + loc := expr.loc + abstracts := expected.methods.findAll |CMethod m->Bool| { return m.isAbstract } + if (abstracts.size != 1) { onErr(); return expr } + method := abstracts.first + + // check if we have a match + FuncType funcType := (FuncType)expr.ctype + if (!isFuncToInterfaceMatch(funcType, method)) { onErr(); return expr } + + // check if we've already generated a wrapper for this combo + key := "${funcType.signature}+${method.qname}" + ctor := funcWrappers[key] + if (ctor == null) + { + ctor = generateFuncToInterfaceWrapper(expr.loc, funcType, expected, method) + funcWrappers[key] = ctor + } + + // replace expr with FuncWrapperX(expr) + call := CallExpr.makeWithMethod(loc, null, ctor, [expr]) + call.synthetic = true + return call + } + + ** + ** Return if the specified function type can be used to implement + ** the specified interface method. + ** + Bool isFuncToInterfaceMatch(FuncType funcType, CMethod method) + { + // sanity check to map to callX method - can't handle more than 8 args + if (method.params.size > 8) return false + + // check if method is match for function; first check is that + // method must supply all the arguments required by the function + if (funcType.params.size > method.params.size) return false + + // check that func return type fits method return + retOk := method.returnType.isVoid || fits(funcType.ret, method.returnType) + if (!retOk) return false + + // check all the method parameters fit the function parameters + paramsOk := funcType.params.all |CType f, Int i->Bool| { return fits(f, method.params[i].paramType) } + if (!paramsOk) return false + + return true + } + + ** + ** Generate the wrapper which implements the specified expected interface + ** and overrides the specified method which calls the function. + ** + CMethod generateFuncToInterfaceWrapper(Loc loc, FuncType funcType, CType expected, CMethod method) + { + // Fantom: func typed as |Str| + // Java: interface Foo { void bar(String) } + // Result: FuncWrapperX(func) + // + // class FuncWrapperX : Foo + // { + // new make(Func f) { _func = f } + // override Void bar(Str a) { _func.call(a) } + // Func _func + // } + + // generate FuncWrapper class + name := "FuncWrapper" + funcWrappers.size + cls := TypeDef(ns, loc, compiler.types[0].unit, name, FConst.Internal + FConst.Synthetic) + cls.base = ns.objType + cls.mixins = [expected] + addTypeDef(cls) + + // generate FuncWrapper._func field + field := FieldDef(loc, cls) + ((SlotDef)field).name = "_func" + ((DefNode)field).flags = FConst.Private + FConst.Storage + FConst.Synthetic + field.fieldType = funcType + cls.addSlot(field) + + // generate FuncWrapper.make constructor + ctor := MethodDef(loc, cls, "make", FConst.Internal + FConst.Ctor + FConst.Synthetic) + ctor.ret = ns.voidType + ctor.paramDefs = [ParamDef(loc, funcType, "f")] + ctor.code = Block.make(loc) + ctor.code.stmts.add(BinaryExpr.makeAssign( + FieldExpr(loc, ThisExpr(loc), field), + UnknownVarExpr(loc, null, "f")).toStmt) + ctor.code.stmts.add(ReturnStmt.make(loc)) + cls.addSlot(ctor) + + // generate FuncWrapper override of abstract method + over := MethodDef(loc, cls, method.name, FConst.Public + FConst.Override + FConst.Synthetic) + over.ret = method.returnType + over.paramDefs = ParamDef[,] + over.code = Block.make(loc) + callArity := "call" + call := CallExpr.makeWithMethod(loc, FieldExpr(loc, ThisExpr(loc), field), funcType.method(callArity)) + method.params.each |CParam param, Int i| + { + paramName := "p$i" + over.params.add(ParamDef(loc, param.paramType, paramName)) + if (i < funcType.params.size) + call.args.add(UnknownVarExpr(loc, null, paramName)) + } + if (method.returnType.isVoid) + over.code.stmts.add(call.toStmt).add(ReturnStmt(loc)) + else + over.code.stmts.add(ReturnStmt(loc, call)) + cls.addSlot(over) + + // return the ctor which we use for coercion + return ctor + } + +////////////////////////////////////////////////////////////////////////// +// Reflection +////////////////////////////////////////////////////////////////////////// + + ** + ** Get a CMethod representation for 'List.make(Type, Object[])' + ** + once CMethod listMakeFromArray() + { + return JavaMethod( + this.ns.listType, + "make", + FConst.Public + FConst.Static, + this.ns.listType.toNullable, + [ + JavaParam("of", this.ns.typeType), + JavaParam("array", objectArrayType) + ]) + } + + ** + ** Get a CMethod representation for 'Object[] List.asArray()' + ** + once CMethod listAsArray() + { + return JavaMethod( + this.ns.listType, + "asArray", + FConst.Public, + objectArrayType, + [JavaParam("cls", classType)]) + } + + ** + ** Get a CType representation for 'java.lang.Class' + ** + once JavaType classType() + { + return ns.resolveType("[java]java.lang::Class") + } + + ** + ** Get a CType representation for 'java.lang.Object[]' + ** + once JavaType objectArrayType() + { + return ns.resolveType("[java]java.lang::[Object") + } + +////////////////////////////////////////////////////////////////////////// +// Fields +////////////////////////////////////////////////////////////////////////// + + const static Str[] boolTypes := Str[ + "[java]java.io::Serializable", + "[java]java.lang::Comparable", + ] + + const static Str[] intTypes := Str[ + "[java]java.lang::Number", + "[java]java.io::Serializable", + "[java]java.lang::Comparable", + ] + + const static Str[] floatTypes := Str[ + "[java]java.lang::Number", + "[java]java.io::Serializable", + "[java]java.lang::Comparable", + ] + + const static Str[] decimalTypes := Str[ + "[java]java.lang::Number", + "[java]java.io::Serializable", + "[java]java.lang::Comparable", + ] + + const static Str[] strTypes := Str[ + "[java]java.io::Serializable", + "[java]java.lang::CharSequence", + "[java]java.lang::Comparable", + ] + + JavaPrimitives primitives := JavaPrimitives(this) + ClassPath cp + + private Str:CMethod funcWrappers := Str:CMethod[:] // funcType+method:ctor + +} + +************************************************************************** +** CallMatch +************************************************************************** + +internal class CallMatch +{ + CallExpr apply(CallExpr call) + { + call.args = args + call.method = method + call.ctype = method.isCtor ? method.parent : method.returnType + return call + } + + override Str toStr() { return method.signature } + + CMethod? method // matched method + Expr[]? args // coerced arguments +}
\ No newline at end of file diff --git a/tests/examplefiles/test.ps1 b/tests/examplefiles/test.ps1 new file mode 100644 index 00000000..385fb6f4 --- /dev/null +++ b/tests/examplefiles/test.ps1 @@ -0,0 +1,108 @@ +<# +.SYNOPSIS +Runs a T-SQL Query and optional outputs results to a delimited file. +.DESCRIPTION +Invoke-Sql script will run a T-SQL query or stored procedure and optionally outputs a delimited file. +.EXAMPLE +PowerShell.exe -File "C:\Scripts\Invoke-Sql.ps1" -ServerInstance "Z003\sqlprod2" -Database orders -Query "EXEC usp_accounts '12445678'" +This example connects to Z003\sqlprod2.Orders and executes a stored procedure which does not return a result set +.EXAMPLE +PowerShell.exe -File "C:\Scripts\Invoke-Sql.ps1" -ServerInstance "Z003\sqlprod2" -Database orders -Query "SELECT * FROM dbo.accounts" -FilePath "C:\Scripts\accounts.txt" -Delimiter "," +This example connects to Z003\sqlprod2.Orders and selects the records from the accounts tables, the data is outputed to a CSV file +.NOTES +Version History +v1.0 - Chad Miller - 12/14/2010 - Initial release +IMPORTANT!!! The EventLog source which is set to the application needs to be registered with +the Event log: +New-EventLog -LogName Application -Source $Application +#> +param( +#ServerInstance is Mandatory! +[Parameter(Position=0, Mandatory=$false)] [string]$ServerInstance, +#Database is Mandatory! +[Parameter(Position=1, Mandatory=$false)] [string]$Database, +#Query is Mandatory! +[Parameter(Position=2, Mandatory=$false)] [string]$Query, +[Parameter(Position=3, Mandatory=$false)] [string]$Application="Invoke-Sql.ps1", +[Parameter(Position=4, Mandatory=$false)] [string]$FilePath, +[Parameter(Position=7, Mandatory=$false)] [string]$Delimiter="|", +#If UserName isn't supplied a trusted connection will be used +[Parameter(Position=5, Mandatory=$false)] [string]$UserName, +[Parameter(Position=6, Mandatory=$false)] [string]$Password, +[Parameter(Position=8, Mandatory=$false)] [Int32]$QueryTimeout=600, +[Parameter(Position=9, Mandatory=$false)] [Int32]$ConnectionTimeout=15 +) + + +#This must be run as administrator on Windows 2008 and higher! +New-EventLog -LogName Application -Source $Application -EA SilentlyContinue +$Error.Clear() + +####################### +function Invoke-SqlCmd2 +{ + param( + [Parameter(Position=0, Mandatory=$true)] [string]$ServerInstance, + [Parameter(Position=1, Mandatory=$true)] [string]$Database, + [Parameter(Position=2, Mandatory=$true)] [string]$Query, + [Parameter(Position=3, Mandatory=$false)] [string]$UserName, + [Parameter(Position=4, Mandatory=$false)] [string]$Password, + [Parameter(Position=5, Mandatory=$false)] [Int32]$QueryTimeout, + [Parameter(Position=6, Mandatory=$false)] [Int32]$ConnectionTimeout + ) + + try { + if ($Username) + { $ConnectionString = "Server={0};Database={1};User ID={2};Password={3};Trusted_Connection=False;Connect Timeout={4}" -f $ServerInstance,$Database,$Username,$Password,$ConnectionTimeout } + else + { $ConnectionString = "Server={0};Database={1};Integrated Security=True;Connect Timeout={2}" -f $ServerInstance,$Database,$ConnectionTimeout } + $conn=new-object System.Data.SqlClient.SQLConnection + $conn.ConnectionString=$ConnectionString + $conn.Open() + $cmd=new-object system.Data.SqlClient.SqlCommand($Query,$conn) + $cmd.CommandTimeout=$QueryTimeout + $ds=New-Object system.Data.DataSet + $da=New-Object system.Data.SqlClient.SqlDataAdapter($cmd) + [void]$da.fill($ds) + Write-Output ($ds.Tables[0]) + } + finally { + $conn.Dispose() + } + +} #Invoke-SqlCmd2 + +####################### +# MAIN # +####################### +if ($PSBoundParameters.Count -eq 0) +{ + get-help $myInvocation.MyCommand.Path -full + break +} + +try { + $msg = $null + $msg += "Application/Job Name: $Application`n" + $msg += "Query: $Query`n" + $msg += "ServerInstance: $ServerInstance`n" + $msg += "Database: $Database`n" + $msg += "FilePath: $FilePath`n" + + Write-EventLog -LogName Application -Source "$Application" -EntryType Information -EventId 12345 -Message "Starting`n$msg" + $dt = Invoke-SqlCmd2 -ServerInstance $ServerInstance -Database $Database -Query $Query -UserName $UserName -Password $Password -QueryTimeOut $QueryTimeOut -ConnectionTimeout $ConnectionTimeout + if ($FilePath) + { + if ($dt) + { $dt | export-csv -Delimiter $Delimiter -Path $FilePath -NoTypeInformation } + else #Query Returned No Output! + {Write-EventLog -LogName Application -Source "$Application" -EntryType Warning -EventId 12345 -Message "NoOutput`n$msg" } + } + + Write-EventLog -LogName Application -Source "$Application" -EntryType Information -EventId 12345 -Message "Completed`n$msg" +} +catch { + $Exception = "{0}, {1}" -f $_.Exception.GetType().FullName,$( $_.Exception.Message -replace "'" ) + Write-EventLog -LogName Application -Source "$Application" -EntryType Error -EventId 12345 -Message "Error`n$msg`n$Exception" + throw +} diff --git a/tests/old_run.py b/tests/old_run.py index ae410146..7929d743 100644 --- a/tests/old_run.py +++ b/tests/old_run.py @@ -8,7 +8,7 @@ python run.py [testfile ...] - :copyright: Copyright 2006-2011 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2012 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/run.py b/tests/run.py index c803e276..ef92fe09 100644 --- a/tests/run.py +++ b/tests/run.py @@ -8,7 +8,7 @@ python run.py [testfile ...] - :copyright: Copyright 2006-2011 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2012 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_basic_api.py b/tests/test_basic_api.py index 02261d24..e86f1579 100644 --- a/tests/test_basic_api.py +++ b/tests/test_basic_api.py @@ -3,7 +3,7 @@ Pygments basic API tests ~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2011 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2012 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ @@ -57,7 +57,7 @@ def test_lexer_classes(): assert 'root' in cls._tokens, \ '%s has no root state' % cls - if cls.name == 'XQuery': # XXX temporary + if cls.name in ['XQuery', 'Opa']: # XXX temporary return tokens = list(inst.get_tokens(test_content)) diff --git a/tests/test_clexer.py b/tests/test_clexer.py index 996f7038..08fb42cf 100644 --- a/tests/test_clexer.py +++ b/tests/test_clexer.py @@ -3,7 +3,7 @@ Basic CLexer Test ~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2011 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2012 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_cmdline.py b/tests/test_cmdline.py index 00baef3b..6a285fcc 100644 --- a/tests/test_cmdline.py +++ b/tests/test_cmdline.py @@ -3,7 +3,7 @@ Command line test ~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2011 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2012 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_examplefiles.py b/tests/test_examplefiles.py index e5dbcf4c..4ab2912e 100644 --- a/tests/test_examplefiles.py +++ b/tests/test_examplefiles.py @@ -3,7 +3,7 @@ Pygments tests with example files ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2011 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2012 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ @@ -60,8 +60,9 @@ def check_lexer(lx, absfn, outfn): tokens = [] for type, val in lx.get_tokens(text): ntext.append(val) - assert type != Error, 'lexer %s generated error token for %s' % \ - (lx, absfn) + assert type != Error, \ + 'lexer %s generated error token for %s: %r at position %d' % \ + (lx, absfn, val, len(u''.join(ntext))) tokens.append((type, val)) if u''.join(ntext) != text: print '\n'.join(difflib.unified_diff(u''.join(ntext).splitlines(), diff --git a/tests/test_html_formatter.py b/tests/test_html_formatter.py index 5a506755..b0b36c4d 100644 --- a/tests/test_html_formatter.py +++ b/tests/test_html_formatter.py @@ -3,7 +3,7 @@ Pygments HTML formatter tests ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2011 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2012 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ @@ -75,6 +75,38 @@ class HtmlFormatterTest(unittest.TestCase): fmt = HtmlFormatter(**optdict) fmt.format(tokensource, outfile) + def test_linenos(self): + optdict = dict(linenos=True) + outfile = StringIO.StringIO() + fmt = HtmlFormatter(**optdict) + fmt.format(tokensource, outfile) + html = outfile.getvalue() + self.assert_(re.search("<pre>\s+1\s+2\s+3", html)) + + def test_linenos_with_startnum(self): + optdict = dict(linenos=True, linenostart=5) + outfile = StringIO.StringIO() + fmt = HtmlFormatter(**optdict) + fmt.format(tokensource, outfile) + html = outfile.getvalue() + self.assert_(re.search("<pre>\s+5\s+6\s+7", html)) + + def test_lineanchors(self): + optdict = dict(lineanchors="foo") + outfile = StringIO.StringIO() + fmt = HtmlFormatter(**optdict) + fmt.format(tokensource, outfile) + html = outfile.getvalue() + self.assert_(re.search("<pre><a name=\"foo-1\">", html)) + + def test_lineanchors_with_startnum(self): + optdict = dict(lineanchors="foo", linenostart=5) + outfile = StringIO.StringIO() + fmt = HtmlFormatter(**optdict) + fmt.format(tokensource, outfile) + html = outfile.getvalue() + self.assert_(re.search("<pre><a name=\"foo-5\">", html)) + def test_valid_output(self): # test all available wrappers fmt = HtmlFormatter(full=True, linenos=True, noclasses=True, diff --git a/tests/test_latex_formatter.py b/tests/test_latex_formatter.py index 501eb198..0c9c9122 100644 --- a/tests/test_latex_formatter.py +++ b/tests/test_latex_formatter.py @@ -3,7 +3,7 @@ Pygments LaTeX formatter tests ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2011 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2012 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_perllexer.py b/tests/test_perllexer.py index 4f99af6b..b9c3cb74 100644 --- a/tests/test_perllexer.py +++ b/tests/test_perllexer.py @@ -3,7 +3,7 @@ Pygments regex lexer tests ~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2011 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2012 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_regexlexer.py b/tests/test_regexlexer.py index e0f167ab..fbb71ad6 100644 --- a/tests/test_regexlexer.py +++ b/tests/test_regexlexer.py @@ -3,7 +3,7 @@ Pygments regex lexer tests ~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2011 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2012 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_token.py b/tests/test_token.py index d7abd218..490c966c 100644 --- a/tests/test_token.py +++ b/tests/test_token.py @@ -3,7 +3,7 @@ Test suite for the token module ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2011 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2012 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_using_api.py b/tests/test_using_api.py index b1b6877d..e645a881 100644 --- a/tests/test_using_api.py +++ b/tests/test_using_api.py @@ -3,7 +3,7 @@ Pygments tests for using() ~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2011 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2012 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_util.py b/tests/test_util.py index af1f4e44..d994e5fa 100644 --- a/tests/test_util.py +++ b/tests/test_util.py @@ -3,7 +3,7 @@ Test suite for the util module ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2011 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2012 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ |