diff options
| author | Tim Hatch <tim@timhatch.com> | 2015-10-13 14:02:39 -0700 |
|---|---|---|
| committer | Tim Hatch <tim@timhatch.com> | 2015-10-13 14:02:39 -0700 |
| commit | 7e7b5f4e3ac21f68372ea44f01eb6caefe95e4a4 (patch) | |
| tree | 59901406f5095bedbd096600b2e131c4a1b52189 /tests | |
| parent | 4ed3436e685c1ce41706d0cb78d0a4c1b6ffa0ae (diff) | |
| parent | b95523e4d56ee3d409e31f377a9d4ff9f85149bd (diff) | |
| download | pygments-7e7b5f4e3ac21f68372ea44f01eb6caefe95e4a4.tar.gz | |
Merged bucaran/pygments-main (default branch, manually) (pull request #422)
Add FishShellLexer
Diffstat (limited to 'tests')
54 files changed, 7703 insertions, 268 deletions
diff --git a/tests/examplefiles/99_bottles_of_beer.chpl b/tests/examplefiles/99_bottles_of_beer.chpl index 47fcaaf6..3629028d 100644 --- a/tests/examplefiles/99_bottles_of_beer.chpl +++ b/tests/examplefiles/99_bottles_of_beer.chpl @@ -159,3 +159,16 @@ var wideOpen = 0o777, clique_y = 0O660, zeroOct = 0o0, minPosOct = 0O1; + +private module M3 { + private proc foo() { + + } + + private iter bar() { + + } + + private var x: int; + +}
\ No newline at end of file diff --git a/tests/examplefiles/Blink.ino b/tests/examplefiles/Blink.ino new file mode 100644 index 00000000..993bd743 --- /dev/null +++ b/tests/examplefiles/Blink.ino @@ -0,0 +1,24 @@ +/* + Blink + Turns on an LED on for one second, then off for one second, repeatedly. + + This example code is in the public domain. + */ + +// Pin 13 has an LED connected on most Arduino boards. +// give it a name: +int led = 13; + +// the setup routine runs once when you press reset: +void setup() { + // initialize the digital pin as an output. + pinMode(led, OUTPUT); +} + +// the loop routine runs over and over again forever: +void loop() { + digitalWrite(led, HIGH); // turn the LED on (HIGH is the voltage level) + delay(1000); // wait for a second + digitalWrite(led, LOW); // turn the LED off by making the voltage LOW + delay(1000); // wait for a second +} diff --git a/tests/examplefiles/ahcon.f b/tests/examplefiles/ahcon.f new file mode 100644 index 00000000..48ae920b --- /dev/null +++ b/tests/examplefiles/ahcon.f @@ -0,0 +1,340 @@ + SUBROUTINE AHCON (SIZE,N,M,A,B,OLEVR,OLEVI,CLEVR,CLEVI, TRUNCATED + & SCR1,SCR2,IPVT,JPVT,CON,WORK,ISEED,IERR) !Test inline comment +C +C FUNCTION: +CF +CF Determines whether the pair (A,B) is controllable and flags +CF the eigenvalues corresponding to uncontrollable modes. +CF this ad-hoc controllability calculation uses a random matrix F +CF and computes whether eigenvalues move from A to the controlled +CF system A+B*F. +CF +C USAGE: +CU +CU CALL AHCON (SIZE,N,M,A,B,OLEVR,OLEVI,CLEVR,CLEVI,SCR1,SCR2,IPVT, +CU JPVT,CON,WORK,ISEED,IERR) +CU +CU since AHCON generates different random F matrices for each +CU call, as long as iseed is not re-initialized by the main +CU program, and since this code has the potential to be fooled +CU by extremely ill-conditioned problems, the cautious user +CU may wish to call it multiple times and rely, perhaps, on +CU a 2-of-3 vote. We believe, but have not proved, that any +CU errors this routine may produce are conservative--i.e., that +CU it may flag a controllable mode as uncontrollable, but +CU not vice-versa. +CU +C INPUTS: +CI +CI SIZE integer - first dimension of all 2-d arrays. +CI +CI N integer - number of states. +CI +CI M integer - number of inputs. +CI +CI A double precision - SIZE by N array containing the +CI N by N system dynamics matrix A. +CI +CI B double precision - SIZE by M array containing the +CI N by M system input matrix B. +CI +CI ISEED initial seed for random number generator; if ISEED=0, +CI then AHCON will set ISEED to a legal value. +CI +C OUTPUTS: +CO +CO OLEVR double precision - N dimensional vector containing the +CO real parts of the eigenvalues of A. +CO +CO OLEVI double precision - N dimensional vector containing the +CO imaginary parts of the eigenvalues of A. +CO +CO CLEVR double precision - N dimensional vector work space +CO containing the real parts of the eigenvalues of A+B*F, +CO where F is the random matrix. +CO +CO CLEVI double precision - N dimensional vector work space +CO containing the imaginary parts of the eigenvalues of +CO A+B*F, where F is the random matrix. +CO +CO SCR1 double precision - N dimensional vector containing the +CO magnitudes of the corresponding eigenvalues of A. +CO +CO SCR2 double precision - N dimensional vector containing the +CO damping factors of the corresponding eigenvalues of A. +CO +CO IPVT integer - N dimensional vector; contains the row pivots +CO used in finding the nearest neighbor eigenvalues between +CO those of A and of A+B*F. The IPVT(1)th eigenvalue of +CO A and the JPVT(1)th eigenvalue of A+B*F are the closest +CO pair. +CO +CO JPVT integer - N dimensional vector; contains the column +CO pivots used in finding the nearest neighbor eigenvalues; +CO see IPVT. +CO +CO CON logical - N dimensional vector; flagging the uncontrollable +CO modes of the system. CON(I)=.TRUE. implies the +CO eigenvalue of A given by DCMPLX(OLEVR(IPVT(I)),OLEVI(IPVT(i))) +CO corresponds to a controllable mode; CON(I)=.FALSE. +CO implies an uncontrollable mode for that eigenvalue. +CO +CO WORK double precision - SIZE by N dimensional array containing +CO an N by N matrix. WORK(I,J) is the distance between +CO the open loop eigenvalue given by DCMPLX(OLEVR(I),OLEVI(I)) +CO and the closed loop eigenvalue of A+B*F given by +CO DCMPLX(CLEVR(J),CLEVI(J)). +CO +CO IERR integer - IERR=0 indicates normal return; a non-zero +CO value indicates trouble in the eigenvalue calculation. +CO see the EISPACK and EIGEN documentation for details. +CO +C ALGORITHM: +CA +CA Calculate eigenvalues of A and of A+B*F for a randomly +CA generated F, and see which ones change. Use a full pivot +CA search through a matrix of euclidean distance measures +CA between each pair of eigenvalues from (A,A+BF) to +CA determine the closest pairs. +CA +C MACHINE DEPENDENCIES: +CM +CM NONE +CM +C HISTORY: +CH +CH written by: Birdwell & Laub +CH date: May 18, 1985 +CH current version: 1.0 +CH modifications: made machine independent and modified for +CH f77:bb:8-86. +CH changed cmplx -> dcmplx: 7/27/88 jdb +CH +C ROUTINES CALLED: +CC +CC EIGEN,RAND +CC +C COMMON MEMORY USED: +CM +CM none +CM +C---------------------------------------------------------------------- +C written for: The CASCADE Project +C Oak Ridge National Laboratory +C U.S. Department of Energy +C contract number DE-AC05-840R21400 +C subcontract number 37B-7685 S13 +C organization: The University of Tennessee +C---------------------------------------------------------------------- +C THIS SOFTWARE IS IN THE PUBLIC DOMAIN +C NO RESTRICTIONS ON ITS USE ARE IMPLIED +C---------------------------------------------------------------------- +C +C--global variables: +C + INTEGER SIZE + INTEGER N + INTEGER M + INTEGER IPVT(1) + INTEGER JPVT(1) + INTEGER IERR +C + DOUBLE PRECISION A(SIZE,N) + DOUBLE PRECISION B(SIZE,M) + DOUBLE PRECISION WORK(SIZE,N) + DOUBLE PRECISION CLEVR(N) + DOUBLE PRECISION CLEVI(N) + DOUBLE PRECISION OLEVR(N) + DOUBLE PRECISION OLEVI(N) + DOUBLE PRECISION SCR1(N) + DOUBLE PRECISION SCR2(N) +C + LOGICAL CON(N) +C +C--local variables: +C + INTEGER ISEED + INTEGER ITEMP + INTEGER K1 + INTEGER K2 + INTEGER I + INTEGER J + INTEGER K + INTEGER IMAX + INTEGER JMAX +C + DOUBLE PRECISION VALUE + DOUBLE PRECISION EPS + DOUBLE PRECISION EPS1 + DOUBLE PRECISION TEMP + DOUBLE PRECISION CURR + DOUBLE PRECISION ANORM + DOUBLE PRECISION BNORM + DOUBLE PRECISION COLNRM + DOUBLE PRECISION RNDMNO +C + DOUBLE COMPLEX DCMPLX +C +C--compute machine epsilon +C + EPS = 1.D0 +100 CONTINUE + EPS = EPS / 2.D0 + EPS1 = 1.D0 + EPS + IF (EPS1 .NE. 1.D0) GO TO 100 + EPS = EPS * 2.D0 +C +C--compute the l-1 norm of a +C + ANORM = 0.0D0 + DO 120 J = 1, N + COLNRM = 0.D0 + DO 110 I = 1, N + COLNRM = COLNRM + ABS(A(I,J)) +110 CONTINUE + IF (COLNRM .GT. ANORM) ANORM = COLNRM +120 CONTINUE +C +C--compute the l-1 norm of b +C + BNORM = 0.0D0 + DO 140 J = 1, M + COLNRM = 0.D0 + DO 130 I = 1, N + COLNRM = COLNRM + ABS(B(I,J)) +130 CONTINUE + IF (COLNRM .GT. BNORM) BNORM = COLNRM +140 CONTINUE +C +C--compute a + b * f +C + DO 160 J = 1, N + DO 150 I = 1, N + WORK(I,J) = A(I,J) +150 CONTINUE +160 CONTINUE +C +C--the elements of f are random with uniform distribution +C--from -anorm/bnorm to +anorm/bnorm +C--note that f is not explicitly stored as a matrix +C--pathalogical floating point notes: the if (bnorm .gt. 0.d0) +C--test should actually be if (bnorm .gt. dsmall), where dsmall +C--is the smallest representable number whose reciprocal does +C--not generate an overflow or loss of precision. +C + IF (ISEED .EQ. 0) ISEED = 86345823 + IF (ANORM .EQ. 0.D0) ANORM = 1.D0 + IF (BNORM .GT. 0.D0) THEN + TEMP = 2.D0 * ANORM / BNORM + ELSE + TEMP = 2.D0 + END IF + DO 190 K = 1, M + DO 180 J = 1, N + CALL RAND(ISEED,ISEED,RNDMNO) + VALUE = (RNDMNO - 0.5D0) * TEMP + DO 170 I = 1, N + WORK(I,J) = WORK(I,J) + B(I,K)*VALUE +170 CONTINUE +180 CONTINUE +190 CONTINUE +C +C--compute the eigenvalues of a + b*f, and several other things +C + CALL EIGEN (0,SIZE,N,WORK,CLEVR,CLEVI,WORK,SCR1,SCR2,IERR) + IF (IERR .NE. 0) RETURN +C +C--copy a so it is not destroyed +C + DO 210 J = 1, N + DO 200 I = 1, N + WORK(I,J) = A(I,J) +200 CONTINUE +210 CONTINUE +C +C--compute the eigenvalues of a, and several other things +C + CALL EIGEN (0,SIZE,N,WORK,OLEVR,OLEVI,WORK,SCR1,SCR2,IERR) + IF (IERR .NE. 0) RETURN +C +C--form the matrix of distances between eigenvalues of a and +C--EIGENVALUES OF A+B*F +C + DO 230 J = 1, N + DO 220 I = 1, N + WORK(I,J) = + & ABS(DCMPLX(OLEVR(I),OLEVI(I))-DCMPLX(CLEVR(J),CLEVI(J))) +220 CONTINUE +230 CONTINUE +C +C--initialize row and column pivots +C + DO 240 I = 1, N + IPVT(I) = I + JPVT(I) = I +240 CONTINUE +C +C--a little bit messy to avoid swapping columns and +C--rows of work +C + DO 270 I = 1, N-1 +C +C--find the minimum element of each lower right square +C--submatrix of work, for submatrices of size n x n +C--through 2 x 2 +C + CURR = WORK(IPVT(I),JPVT(I)) + IMAX = I + JMAX = I + TEMP = CURR +C +C--find the minimum element +C + DO 260 K1 = I, N + DO 250 K2 = I, N + IF (WORK(IPVT(K1),JPVT(K2)) .LT. TEMP) THEN + TEMP = WORK(IPVT(K1),JPVT(K2)) + IMAX = K1 + JMAX = K2 + END IF +250 CONTINUE +260 CONTINUE +C +C--update row and column pivots for indirect addressing of work +C + ITEMP = IPVT(I) + IPVT(I) = IPVT(IMAX) + IPVT(IMAX) = ITEMP +C + ITEMP = JPVT(I) + JPVT(I) = JPVT(JMAX) + JPVT(JMAX) = ITEMP +C +C--do next submatrix +C +270 CONTINUE +C +C--this threshold for determining when an eigenvalue has +C--not moved, and is therefore uncontrollable, is critical, +C--and may require future changes with more experience. +C + EPS1 = SQRT(EPS) +C +C--for each eigenvalue pair, decide if it is controllable +C + DO 280 I = 1, N +C +C--note that we are working with the "pivoted" work matrix +C--and are looking at its diagonal elements +C + IF (WORK(IPVT(I),JPVT(I))/ANORM .LE. EPS1) THEN + CON(I) = .FALSE. + ELSE + CON(I) = .TRUE. + END IF +280 CONTINUE +C +C--finally! +C + RETURN + END diff --git a/tests/examplefiles/autoit_submit.au3 b/tests/examplefiles/autoit_submit.au3 index e5054dea..84fb7150 100644 --- a/tests/examplefiles/autoit_submit.au3 +++ b/tests/examplefiles/autoit_submit.au3 @@ -16,8 +16,10 @@ _IEFormElementOptionSelect ($oSelect, "S2", 1, "byText") ;options raido
_IEFormElementRadioSelect($oForm, "2nd", "type", 1, "byValue")
+#cs
ConsoleWrite(@Error)
Sleep(10000)
+#ce
_IEFormSubmit($oForm, 0)
_IELoadWait($oIE)
Sleep(60000)
diff --git a/tests/examplefiles/es6.js b/tests/examplefiles/es6.js new file mode 100644 index 00000000..79bfd3e6 --- /dev/null +++ b/tests/examplefiles/es6.js @@ -0,0 +1,46 @@ +// Most examples from https://github.com/rse/es6-features under MIT license +const PI = 3.141593; + +let callbacks = []; + +odds = evens.map(v => v + 1); + +nums.forEach(v => { + if (v % 5 === 0) + fives.push(v); +}) + +function f (x, y, ...a) { + return (x + y) * a.length; +} + +var params = [ "hello", true, 7 ]; +var other = [ 1, 2, ...params ]; // [ 1, 2, "hello", true, 7 ] +f(1, 2, ...params) === 9; + +var str = "foo"; +var chars = [ ...str ]; // [ "f", "o", "o" ] + +var customer = { name: "Foo" }; +var card = { amount: 7, product: "Bar", unitprice: 42 }; +message = `Hello ${customer.name}, +want to buy ${card.amount} ${card.product} for +a total of ${card.amount * card.unitprice} bucks?`; + +0b111110111 === 503; +0o767 === 503; + +for (let codepoint of "𠮷") console.log(codepoint); + +function* (); +*function(); +yield; + +export class Node { +} + +isFinite(); +isNaN(); +isSafeInteger(); +x = new Promise(...a); +x = new Proxy(...a); diff --git a/tests/examplefiles/eval.rs b/tests/examplefiles/eval.rs new file mode 100644 index 00000000..17e585a0 --- /dev/null +++ b/tests/examplefiles/eval.rs @@ -0,0 +1,606 @@ +// ------------------------------------------------------------------------------------------------- +// Rick, a Rust intercal compiler. Save your souls! +// +// Copyright (c) 2015 Georg Brandl +// +// This program is free software; you can redistribute it and/or modify it under the terms of the +// GNU General Public License as published by the Free Software Foundation; either version 2 of the +// License, or (at your option) any later version. +// +// 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 +// General Public License for more details. +// +// You should have received a copy of the GNU General Public License along with this program; +// if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +// ------------------------------------------------------------------------------------------------- + +/// Interprets INTERCAL source. +/// +/// The evaluator is used when rick is called with `-i`, or when the compiler generates +/// the output while compiling (in the constant-output case). + +use std::fmt::{ Debug, Display }; +use std::io::Write; +use std::u16; + +use err::{ Res, IE123, IE129, IE252, IE275, IE555, IE633, IE774, IE994 }; +use ast::{ self, Program, Stmt, StmtBody, ComeFrom, Expr, Var, VType }; +use stdops::{ Bind, Array, write_number, read_number, check_chance, check_ovf, pop_jumps, + get_random_seed, mingle, select, and_16, and_32, or_16, or_32, xor_16, xor_32 }; + + +/// Represents a value (either 16-bit or 32-bit) at runtime. +#[derive(Clone, PartialEq, Eq, Debug)] +pub enum Val { + I16(u16), + I32(u32), +} + +impl Val { + /// Cast as a 16-bit value; returns an error if 32-bit and too big. + pub fn as_u16(&self) -> Res<u16> { + match *self { + Val::I16(v) => Ok(v), + Val::I32(v) => { + if v > (u16::MAX as u32) { + return IE275.err(); + } + Ok(v as u16) + } + } + } + + /// Cast as a 32-bit value; always succeeds. + pub fn as_u32(&self) -> u32 { + match *self { + Val::I16(v) => v as u32, + Val::I32(v) => v + } + } + + /// Cast as an usize value; always succeeds. + pub fn as_usize(&self) -> usize { + self.as_u32() as usize + } + + /// Create from a 32-bit value; will select the smallest possible type. + pub fn from_u32(v: u32) -> Val { + if v & 0xFFFF == v { + Val::I16(v as u16) + } else { + Val::I32(v) + } + } +} + +/// The state of the interpreter's evaluator. +pub struct Eval<'a> { + /// Program to execute. + program: &'a Program, + /// Stream to use for printing output. + stdout: &'a mut Write, + /// Whether to print debugging output during execution. + debug: bool, + /// Variable bindings for the four types of variables. + spot: Vec<Bind<u16>>, + twospot: Vec<Bind<u32>>, + tail: Vec<Bind<Array<u16>>>, + hybrid: Vec<Bind<Array<u32>>>, + /// The infamous NEXT stack, capable of holding 80 elements. + jumps: Vec<ast::LogLine>, + /// Abstain counter for each statement. + abstain: Vec<u32>, + /// Binary I/O "tape" state. + last_in: u8, + last_out: u8, + /// Random number generator state. + rand_st: u32, + /// Counts the number of executed statements. + stmt_ctr: usize, +} + +/// Represents the control flow effect of an executed statement. +enum StmtRes { + /// normal execution, next statement + Next, + /// jump around, from DO ... NEXT + Jump(usize), + /// jump back, from RESUME + Back(usize), + /// start from the first statement, from TRY AGAIN + FromTop, + /// end the program, from GIVE UP + End, +} + +impl<'a> Eval<'a> { + /// Construct a new evaluator. + pub fn new(program: &'a Program, stdout: &'a mut Write, debug: bool, + random: bool) -> Eval<'a> { + let abs = program.stmts.iter().map(|stmt| stmt.props.disabled as u32).collect(); + let nvars = (program.var_info.0.len(), + program.var_info.1.len(), + program.var_info.2.len(), + program.var_info.3.len()); + Eval { + program: program, + stdout: stdout, + debug: debug, + spot: vec![Bind::new(0); nvars.0], + twospot: vec![Bind::new(0); nvars.1], + tail: vec![Bind::new(Array::empty()); nvars.2], + hybrid: vec![Bind::new(Array::empty()); nvars.3], + jumps: Vec::with_capacity(80), + rand_st: if random { get_random_seed() } else { 0 }, + abstain: abs, + last_in: 0, + last_out: 0, + stmt_ctr: 0, + } + } + + /// Interpret the program. Returns either the number of executed statements, + /// or an error (RtError). + pub fn eval(&mut self) -> Res<usize> { + let mut pctr = 0; // index of current statement + let program = self.program.clone(); + let nstmts = program.stmts.len(); + loop { + // check for falling off the end + if pctr >= nstmts { + // if the last statement was a TRY AGAIN, falling off the end is fine + if let StmtBody::TryAgain = program.stmts[program.stmts.len() - 1].body { + break; + } + return IE633.err(); + } + self.stmt_ctr += 1; + let stmt = &program.stmts[pctr]; + // execute statement if not abstained + if self.abstain[pctr] == 0 { + // check execution chance + let (passed, rand_st) = check_chance(stmt.props.chance, self.rand_st); + self.rand_st = rand_st; + if passed { + // try to eval this statement + let res = match self.eval_stmt(stmt) { + // on error, set the correct line number and bubble up + Err(mut err) => { + err.set_line(stmt.props.onthewayto); + // special treatment for NEXT + if let StmtBody::DoNext(n) = stmt.body { + if let Some(i) = program.labels.get(&n) { + err.set_line(program.stmts[*i as usize].props.srcline); + } + } + return Err(err); + } + Ok(res) => res + }; + // handle control flow effects + match res { + StmtRes::Next => { } + StmtRes::Jump(n) => { + self.jumps.push(pctr as u16); // push the line with the NEXT + pctr = n; + continue; // do not increment or check for COME FROMs + } + StmtRes::Back(n) => { + pctr = n; // will be incremented below after COME FROM check + } + StmtRes::FromTop => { + pctr = 0; // start from the beginning, do not push any stack + continue; + } + StmtRes::End => break, + } + } + } + // if we are on the line with the compiler bug, error out + if pctr == self.program.bugline as usize { + return IE774.err_with(None, stmt.props.onthewayto); + } + // try to determine if we have to go to a COME FROM statement + // (note: in general, program.stmts[pctr] != stmt) + // + // the static COME FROM is always a possibility + let mut maybe_next = program.stmts[pctr].comefrom; + // the complicated case: evaluate all computed-come-from expressions + let my_label = program.stmts[pctr].props.label; + if program.uses_complex_comefrom && my_label > 0 { + for (i, stmt) in program.stmts.iter().enumerate() { + if let StmtBody::ComeFrom(ComeFrom::Expr(ref e)) = stmt.body { + let v = try!(try!(self.eval_expr(e)).as_u16()); + if v == my_label { + // as soon as we have multiple candidates, we can bail out + if maybe_next.is_some() { + return IE555.err(); + } + maybe_next = Some(i as u16); + } + } + } + } + // check for COME FROMs from this line + if let Some(next) = maybe_next { + let next = next as usize; + // check for abstained COME FROM + if self.abstain[next] == 0 { + // the COME FROM can also have a % chance + let (passed, rand_st) = check_chance(program.stmts[next].props.chance, + self.rand_st); + self.rand_st = rand_st; + if passed { + pctr = next; + continue; + } + } + } + // no COME FROM, normal execution + pctr += 1; + } + Ok(self.stmt_ctr) + } + + /// Interpret a single statement. + fn eval_stmt(&mut self, stmt: &Stmt) -> Res<StmtRes> { + if self.debug { + println!("\nExecuting Stmt #{} (state before following)", self.stmt_ctr); + self.dump_state(); + println!("{}", stmt); + } + match stmt.body { + StmtBody::Calc(ref var, ref expr) => { + let val = try!(self.eval_expr(expr)); + try!(self.assign(var, val)); + Ok(StmtRes::Next) + } + StmtBody::Dim(ref var, ref exprs) => { + try!(self.array_dim(var, exprs)); + Ok(StmtRes::Next) + } + StmtBody::DoNext(n) => { + match self.program.labels.get(&n) { + // too many jumps on stack already? + Some(_) if self.jumps.len() >= 80 => IE123.err(), + Some(i) => Ok(StmtRes::Jump(*i as usize)), + None => IE129.err(), + } + } + StmtBody::ComeFrom(_) => { + // nothing to do here at runtime + Ok(StmtRes::Next) + } + StmtBody::Resume(ref expr) => { + let n = try!(self.eval_expr(expr)).as_u32(); + // this expect() is safe: if the third arg is true, there will + // be no Ok(None) returns + let next = try!(pop_jumps(&mut self.jumps, n, true, 0)) + .expect("https://xkcd.com/378/ ?!"); + Ok(StmtRes::Back(next as usize)) + } + StmtBody::Forget(ref expr) => { + let n = try!(self.eval_expr(expr)).as_u32(); + try!(pop_jumps(&mut self.jumps, n, false, 0)); + Ok(StmtRes::Next) + } + StmtBody::Ignore(ref vars) => { + for var in vars { + self.set_rw(var, false); + } + Ok(StmtRes::Next) + } + StmtBody::Remember(ref vars) => { + for var in vars { + self.set_rw(var, true); + } + Ok(StmtRes::Next) + } + StmtBody::Stash(ref vars) => { + for var in vars { + self.stash(var); + } + Ok(StmtRes::Next) + } + StmtBody::Retrieve(ref vars) => { + for var in vars { + try!(self.retrieve(var)); + } + Ok(StmtRes::Next) + } + StmtBody::Abstain(ref expr, ref whats) => { + let f: Box<Fn(u32) -> u32> = if let Some(ref e) = *expr { + let n = try!(self.eval_expr(e)).as_u32(); + box move |v: u32| v.saturating_add(n) + } else { + box |_| 1 + }; + for what in whats { + self.abstain(what, &*f); + } + Ok(StmtRes::Next) + } + StmtBody::Reinstate(ref whats) => { + for what in whats { + self.abstain(what, &|v: u32| v.saturating_sub(1)); + } + Ok(StmtRes::Next) + } + StmtBody::ReadOut(ref vars) => { + for var in vars { + match *var { + // read out whole array + Expr::Var(ref var) if var.is_dim() => { + try!(self.array_readout(var)); + } + // read out single var or array element + Expr::Var(ref var) => { + let varval = try!(self.lookup(var)); + try!(write_number(self.stdout, varval.as_u32(), 0)); + } + // read out constant + Expr::Num(_, v) => try!(write_number(self.stdout, v, 0)), + // others will not be generated + _ => return IE994.err(), + }; + } + Ok(StmtRes::Next) + } + StmtBody::WriteIn(ref vars) => { + for var in vars { + if var.is_dim() { + // write in whole array + try!(self.array_writein(var)); + } else { + // write in single var or array element + let n = try!(read_number(0)); + try!(self.assign(var, Val::from_u32(n))); + } + } + Ok(StmtRes::Next) + } + // this one is only generated by the constant-program optimizer + StmtBody::Print(ref s) => { + if let Err(_) = self.stdout.write(&s) { + return IE252.err(); + } + Ok(StmtRes::Next) + } + StmtBody::TryAgain => Ok(StmtRes::FromTop), + StmtBody::GiveUp => Ok(StmtRes::End), + StmtBody::Error(ref e) => Err((*e).clone()), + } + } + + /// Evaluate an expression to a value. + fn eval_expr(&self, expr: &Expr) -> Res<Val> { + match *expr { + Expr::Num(vtype, v) => match vtype { + VType::I16 => Ok(Val::I16(v as u16)), + VType::I32 => Ok(Val::I32(v)), + }, + Expr::Var(ref var) => self.lookup(var), + Expr::Mingle(ref vx, ref wx) => { + let v = try!(self.eval_expr(vx)).as_u32(); + let w = try!(self.eval_expr(wx)).as_u32(); + let v = try!(check_ovf(v, 0)); + let w = try!(check_ovf(w, 0)); + Ok(Val::I32(mingle(v, w))) + } + Expr::Select(vtype, ref vx, ref wx) => { + let v = try!(self.eval_expr(vx)); + let w = try!(self.eval_expr(wx)); + if vtype == VType::I16 { + Ok(Val::I16(select(v.as_u32(), try!(w.as_u16()) as u32) as u16)) + } else { + Ok(Val::I32(select(v.as_u32(), w.as_u32()))) + } + } + Expr::And(vtype, ref vx) => { + let v = try!(self.eval_expr(vx)); + match vtype { + VType::I16 => Ok(Val::I16(and_16(try!(v.as_u16()) as u32) as u16)), + VType::I32 => Ok(Val::I32(and_32(v.as_u32()))), + } + } + Expr::Or(vtype, ref vx) => { + let v = try!(self.eval_expr(vx)); + match vtype { + VType::I16 => Ok(Val::I16(or_16(try!(v.as_u16()) as u32) as u16)), + VType::I32 => Ok(Val::I32(or_32(v.as_u32()))), + } + } + Expr::Xor(vtype, ref vx) => { + let v = try!(self.eval_expr(vx)); + match vtype { + VType::I16 => Ok(Val::I16(xor_16(try!(v.as_u16()) as u32) as u16)), + VType::I32 => Ok(Val::I32(xor_32(v.as_u32()))), + } + } + Expr::RsNot(ref vx) => { + let v = try!(self.eval_expr(vx)); + Ok(Val::I32(!v.as_u32())) + } + Expr::RsAnd(ref vx, ref wx) => { + let v = try!(self.eval_expr(vx)); + let w = try!(self.eval_expr(wx)); + Ok(Val::I32(v.as_u32() & w.as_u32())) + } + Expr::RsOr(ref vx, ref wx) => { + let v = try!(self.eval_expr(vx)); + let w = try!(self.eval_expr(wx)); + Ok(Val::I32(v.as_u32() | w.as_u32())) + } + Expr::RsXor(ref vx, ref wx) => { + let v = try!(self.eval_expr(vx)); + let w = try!(self.eval_expr(wx)); + Ok(Val::I32(v.as_u32() ^ w.as_u32())) + } + Expr::RsRshift(ref vx, ref wx) => { + let v = try!(self.eval_expr(vx)); + let w = try!(self.eval_expr(wx)); + Ok(Val::I32(v.as_u32() >> w.as_u32())) + } + Expr::RsLshift(ref vx, ref wx) => { + let v = try!(self.eval_expr(vx)); + let w = try!(self.eval_expr(wx)); + Ok(Val::I32(v.as_u32() << w.as_u32())) + } + // Expr::RsEqual(ref vx, ref wx) => { + // let v = try!(self.eval_expr(vx)); + // let w = try!(self.eval_expr(wx)); + // Ok(Val::I32((v.as_u32() == w.as_u32()) as u32)) + // } + Expr::RsNotEqual(ref vx, ref wx) => { + let v = try!(self.eval_expr(vx)); + let w = try!(self.eval_expr(wx)); + Ok(Val::I32((v.as_u32() != w.as_u32()) as u32)) + } + Expr::RsPlus(ref vx, ref wx) => { + let v = try!(self.eval_expr(vx)); + let w = try!(self.eval_expr(wx)); + Ok(Val::I32(v.as_u32() + w.as_u32())) + } + Expr::RsMinus(ref vx, ref wx) => { + let v = try!(self.eval_expr(vx)); + let w = try!(self.eval_expr(wx)); + Ok(Val::I32(v.as_u32() - w.as_u32())) + } + } + } + + #[inline] + fn eval_subs(&self, subs: &Vec<Expr>) -> Res<Vec<usize>> { + subs.iter().map(|v| self.eval_expr(v).map(|w| w.as_usize())).collect() + } + + /// Dimension an array. + fn array_dim(&mut self, var: &Var, dims: &Vec<Expr>) -> Res<()> { + let dims = try!(self.eval_subs(dims)); + match *var { + Var::A16(n, _) => self.tail[n].dimension(dims, 0), + Var::A32(n, _) => self.hybrid[n].dimension(dims, 0), + _ => return IE994.err(), + } + } + + /// Assign to a variable. + fn assign(&mut self, var: &Var, val: Val) -> Res<()> { + match *var { + Var::I16(n) => Ok(self.spot[n].assign(try!(val.as_u16()))), + Var::I32(n) => Ok(self.twospot[n].assign(val.as_u32())), + Var::A16(n, ref subs) => { + let subs = try!(self.eval_subs(subs)); + self.tail[n].set_md(subs, try!(val.as_u16()), 0) + } + Var::A32(n, ref subs) => { + let subs = try!(self.eval_subs(subs)); + self.hybrid[n].set_md(subs, val.as_u32(), 0) + } + } + } + + /// Look up the value of a variable. + fn lookup(&self, var: &Var) -> Res<Val> { + match *var { + Var::I16(n) => Ok(Val::I16(self.spot[n].val)), + Var::I32(n) => Ok(Val::I32(self.twospot[n].val)), + Var::A16(n, ref subs) => { + let subs = try!(self.eval_subs(subs)); + self.tail[n].get_md(subs, 0).map(Val::I16) + } + Var::A32(n, ref subs) => { + let subs = try!(self.eval_subs(subs)); + self.hybrid[n].get_md(subs, 0).map(Val::I32) + } + } + } + + /// Process a STASH statement. + fn stash(&mut self, var: &Var) { + match *var { + Var::I16(n) => self.spot[n].stash(), + Var::I32(n) => self.twospot[n].stash(), + Var::A16(n, _) => self.tail[n].stash(), + Var::A32(n, _) => self.hybrid[n].stash(), + } + } + + /// Process a RETRIEVE statement. + fn retrieve(&mut self, var: &Var) -> Res<()> { + match *var { + Var::I16(n) => self.spot[n].retrieve(0), + Var::I32(n) => self.twospot[n].retrieve(0), + Var::A16(n, _) => self.tail[n].retrieve(0), + Var::A32(n, _) => self.hybrid[n].retrieve(0), + } + } + + /// Process an IGNORE or REMEMBER statement. Cannot fail. + fn set_rw(&mut self, var: &Var, rw: bool) { + match *var { + Var::I16(n) => self.spot[n].rw = rw, + Var::I32(n) => self.twospot[n].rw = rw, + Var::A16(n, _) => self.tail[n].rw = rw, + Var::A32(n, _) => self.hybrid[n].rw = rw, + } + } + + /// P()rocess an ABSTAIN or REINSTATE statement. Cannot fail. + fn abstain(&mut self, what: &ast::Abstain, f: &Fn(u32) -> u32) { + if let &ast::Abstain::Label(lbl) = what { + let idx = self.program.labels[&lbl] as usize; + if self.program.stmts[idx].body != StmtBody::GiveUp { + self.abstain[idx] = f(self.abstain[idx]); + } + } else { + for (i, stype) in self.program.stmt_types.iter().enumerate() { + if stype == what { + self.abstain[i] = f(self.abstain[i]); + } + } + } + } + + /// Array readout helper. + fn array_readout(&mut self, var: &Var) -> Res<()> { + let state = &mut self.last_out; + match *var { + Var::A16(n, _) => self.tail[n].readout(self.stdout, state, 0), + Var::A32(n, _) => self.hybrid[n].readout(self.stdout, state, 0), + _ => return IE994.err(), + } + } + + /// Array writein helper. + fn array_writein(&mut self, var: &Var) -> Res<()> { + let state = &mut self.last_in; + match *var { + Var::A16(n, _) => self.tail[n].writein(state, 0), + Var::A32(n, _) => self.hybrid[n].writein(state, 0), + _ => return IE994.err(), + } + } + + /// Debug helpers. + fn dump_state(&self) { + self.dump_state_one(&self.spot, "."); + self.dump_state_one(&self.twospot, ":"); + self.dump_state_one(&self.tail, ","); + self.dump_state_one(&self.hybrid, ";"); + if self.jumps.len() > 0 { + println!("Next stack: {:?}", self.jumps); + } + //println!("Abstained: {:?}", self.abstain); + } + + fn dump_state_one<T: Debug + Display>(&self, vec: &Vec<Bind<T>>, sigil: &str) { + if vec.len() > 0 { + for (i, v) in vec.iter().enumerate() { + print!("{}{} = {}, ", sigil, i, v); + } + println!(""); + } + } +} diff --git a/tests/examplefiles/example.ezt b/tests/examplefiles/example.ezt new file mode 100644 index 00000000..fec2aa4c --- /dev/null +++ b/tests/examplefiles/example.ezt @@ -0,0 +1,32 @@ +* Easytrieve Plus example programm. + +* Environtment section. +PARM DEBUG(FLOW FLDCHK) + +* Library Section. +FILE PERSNL FB(150 1800) + NAME 17 8 A + EMP# 9 5 N * Note: '#' is a valid character for names. + DEPT 98 3 N. GROSS 94 4 P 2 + * ^ 2 field definitions in 1 line. + +* Call macro in example.mac. +FILE EXAMPLE FB(80 200) +%EXAMPLE SOMEFILE SOME + +* Activity Section. +JOB INPUT PERSNL NAME FIRST-PROGRAM START AT-START FINISH AT_FINISH + PRINT PAY-RPT +REPORT PAY-RPT LINESIZE 80 + TITLE 01 'PERSONNEL REPORT EXAMPLE-1' + LINE 01 DEPT NAME EMP# GROSS + +* Procedure declarations. +AT-START. PROC + DISPLAY 'PROCESSING...' +END-PROC + +AT-FINISH +PROC + DISPLAY 'DONE.' +END-PROC diff --git a/tests/examplefiles/example.jcl b/tests/examplefiles/example.jcl new file mode 100644 index 00000000..18d4ae37 --- /dev/null +++ b/tests/examplefiles/example.jcl @@ -0,0 +1,31 @@ +//IS198CPY JOB (PYGM-TEST-001),'PYGMENTS TEST JOB', +// CLASS=L,MSGCLASS=X,TIME=(00,10) +//* Copy 'OLDFILE' to 'NEWFILE'. +//COPY01 EXEC PGM=IEBGENER +//SYSPRINT DD SYSOUT=* +//SYSUT1 DD DSN=OLDFILE,DISP=SHR +//SYSUT2 DD DSN=NEWFILE, +// DISP=(NEW,CATLG,DELETE), +// SPACE=(CYL,(40,5),RLSE), Some comment +// DCB=(LRECL=115,BLKSIZE=1150) +//SYSIN DD DUMMY +/* +//* Test line continuation in strings. +//CONT01 EXEC PGM=IEFBR14,PARM='THIS IS A LONG PARAMETER WITHIN APOST +// ROPHES, CONTINUED IN COLUMN 15 OF THE NEXT RECORD' +//* Sort a couple of lines and show the result in the job log. +//SORT01 EXEC PGM=IEFBR14 +//SORTIN DD * +spam +eggs +ham +/* +//SORTOUT DD SYSOUT=* +/* +//* Test line continuation with comment at end of line continued by a +//* character at column 72 (in this case 'X'). +//STP4 EXEC PROC=BILLING,COND.PAID=((20,LT),EVEN), +// COND.LATE=(60,GT,FIND), +// COND.BILL=((20,GE),(30,LT,CHGE)) THIS STATEMENT CALLS THE X +// BILLING PROCEDURE AND SPECIFIES RETURN CODE TESTS FOR THREEX +// PROCEDURE STEPS. diff --git a/tests/examplefiles/example.mac b/tests/examplefiles/example.mac new file mode 100644 index 00000000..1c3831d1 --- /dev/null +++ b/tests/examplefiles/example.mac @@ -0,0 +1,6 @@ +* Example Easytrieve macro declaration. For an example on calling this +* macro, see example.ezt. +MACRO FILENAME PREFIX +&FILENAME. +&PREFIX.-LINE 1 80 A +&PREFIX.-KEY 1 8 A diff --git a/tests/examplefiles/example.scd b/tests/examplefiles/example.scd new file mode 100644 index 00000000..a27247e9 --- /dev/null +++ b/tests/examplefiles/example.scd @@ -0,0 +1,76 @@ +Instr("cs.fm.BasicFM", { + arg freq = 440, + amp = 0.9, + gate = 0, + carrierFreqRatio = 1.0, + modulatorFreqRatio = 1.0, + // not sure if having these defaults here actually does anything. + modEnvShape = Env.adsr( + attackTime: 0.05, + decayTime: 0.1, + sustainLevel: 0.5 * amp, + releaseTime: 0.1, + peakLevel: amp, + curve: [4, -4, -2] + ), + carrierEnvShape = Env.adsr( + attackTime: 0.05, + decayTime: 0.1, + sustainLevel: 0.5 * amp, + releaseTime: 0.1, + peakLevel: amp, + curve: [4, -4, -2] + ); + + var carrier, + modulator, + carrierEnv, + modEnv, + out; + + modEnv = EnvGen.kr( + envelope: modEnvShape, + gate: gate + ); + + modulator = modEnv * SinOsc.ar(freq * modulatorFreqRatio); + + // carrier sustains until noteoff + carrierEnvShape.releaseNode = 2; + + carrierEnv = EnvGen.kr( + envelope: carrierEnvShape, + gate: gate + ); + + carrier = carrierEnv * SinOsc.ar( + (freq * carrierFreqRatio) + (modulator * freq) + ); + + // free synth when both carrier and modulator envelopes are done + FreeSelf.kr(Done.kr(carrierEnv) + Done.kr(modEnv) - 1); + + out = amp * carrier; +}, [ + \freq.asSpec(), + \amp.asSpec(), + \nil, + ControlSpec(0.1, 10), + ControlSpec(0.1, 10), + EnvSpec(Env.adsr( + attackTime: 0.05, + decayTime: 0.1, + sustainLevel: 0.8, + releaseTime: 0.1, + peakLevel: 1.0, + curve: [4, -4, -2] + )), + EnvSpec(Env.adsr( + attackTime: 0.05, + decayTime: 0.1, + sustainLevel: 0.8, + releaseTime: 0.1, + peakLevel: 1.0, + curve: [4, -4, -2] + )) +]); diff --git a/tests/examplefiles/example.tap b/tests/examplefiles/example.tap new file mode 100644 index 00000000..a70a239d --- /dev/null +++ b/tests/examplefiles/example.tap @@ -0,0 +1,37 @@ +TAP version 13 +1..42 +1..13 A plan only supports directives so this text is wrong. +ok 1 A normal test line includes a number. +ok But a test line may also omit a number. + +A random line that does not look like a test or diagnostic should be ignored. + No matter how it is spaced out. + +Or if it is a totally blank line. + +not ok 3 This is a failing test line. + +# Diagnostics are any lines... +# ... beginning with a hash character. + +not ok 4 There are a couple of directives. # TODO is one of those directives. +not ok 5 # TODO: is invalid because the directive must be followed by a space. +ok 6 - Another directive line # toDO is not case sensitive. + +ok 7 A line that is a # SKIP +ok 8 Tests can be # skipped as long as the directive has the "skip" stem. +ok 9 The TODO directive must be followed by a space, but # skip: is valid. +1..0 # Skipped directives can show on a plan line too. + +Bail out! is a special phrase emitted when a TAP file aborted. + +not ok 10 Having TAP version 13 in the middle of a line is not a TAP version. +not ok 11 Having Bail out! in the middle of a line is not a bail out. + +ok 12 Here is an empty directive. # + +# The most basic valid test lines. +ok +not ok + +ok 15 Only the test number should look different. Not another 42, for example. diff --git a/tests/examplefiles/example.tf b/tests/examplefiles/example.tf new file mode 100644 index 00000000..d3f02779 --- /dev/null +++ b/tests/examplefiles/example.tf @@ -0,0 +1,162 @@ +variable "key_name" { + description = "Name of the SSH keypair to use in AWS." +} + +variable "key_path" { + description = "Path to the private portion of the SSH key specified." +} + +variable "aws_region" { + description = "AWS region to launch servers." + default = "us-west-2" + somevar = true +} + +# Ubuntu Precise 12.04 LTS (x64) +variable "aws_amis" { + default = { + eu-west-1 = "ami-b1cf19c6" + us-east-1 = "ami-de7ab6b6" + us-west-1 = "ami-3f75767a" + us-west-2 = "ami-21f78e11" + } +} + + + + + + +provider "aws" { + access_key = "${myvar}" + secret_key = "your aws secret key" + region = "us-east-1" +} +/* multiline + + comment + +*/ + + +# Single line comment +resource "aws_instance" "example" { + ami = "ami-408c7f28" + instance_type = "t1.micro" + key_name = "your-aws-key-name" +} + +# Create our Heroku application. Heroku will +# automatically assign a name. +resource "heroku_app" "web" {} + +# Create our DNSimple record to point to the +# heroku application. +resource "dnsimple_record" "web" { + domain = "${var.dnsimple_domain}" + + + # heroku_hostname is a computed attribute on the heroku + # application we can use to determine the hostname + value = "${heroku_app.web.heroku_hostname}" + + type = "CNAME" + ttl = 3600 +} + +# The Heroku domain, which will be created and added +# to the heroku application after we have assigned the domain +# in DNSimple +resource "heroku_domain" "foobar" { + app = "${heroku_app.web.name}" + hostname = "${dnsimple_record.web.hostname}" +} + + +# Specify the provider and access details +provider "aws" { + region = "${var.aws_region}" + value = ${file("path.txt")} +} + +# Our default security group to access +# the instances over SSH and HTTP +resource "aws_security_group" "default" { + name = "terraform_example" + description = "Used in the terraform" + + # SSH access from anywhere + ingress { + from_port = 22 + to_port = 22 + protocol = "tcp" + cidr_blocks = ["0.0.0.0/0"] + } + + # HTTP access from anywhere + ingress { + from_port = 80 + to_port = 80 + protocol = "tcp" + cidr_blocks = ["0.0.0.0/0"] + } +} + + +resource "aws_elb" "web" { + name = "terraform-example-elb" + + # The same availability zone as our instance + availability_zones = ["${aws_instance.web.availability_zone}"] + + listener { + instance_port = 80 + instance_protocol = "http" + lb_port = 80 + lb_protocol = "http" + } + + # The instance is registered automatically + instances = ["${aws_instance.web.id}"] +} + + +resource "aws_instance" "web" { + # The connection block tells our provisioner how to + # communicate with the resource (instance) + connection { + # The default username for our AMI + user = "ubuntu" + + # The path to your keyfile + key_file = "${var.key_path}" + } + + instance_type = "m1.small" + + # Lookup the correct AMI based on the region + # we specified + ami = "${lookup(var.aws_amis, var.aws_region)}" + + # The name of our SSH keypair you've created and downloaded + # from the AWS console. + # + # https://console.aws.amazon.com/ec2/v2/home?region=us-west-2#KeyPairs: + # + key_name = "${var.key_name}" + + # Our Security group to allow HTTP and SSH access + security_groups = ["${aws_security_group.default.name}"] + + # We run a remote provisioner on the instance after creating it. + # In this case, we just install nginx and start it. By default, + # this should be on port 80 + provisioner "remote-exec" { + inline = [ + "sudo apt-get -y update", + "sudo apt-get -y install nginx", + "sudo service nginx start" + ] + } +} + diff --git a/tests/examplefiles/example.ttl b/tests/examplefiles/example.ttl new file mode 100644 index 00000000..e524d86c --- /dev/null +++ b/tests/examplefiles/example.ttl @@ -0,0 +1,43 @@ +@base <http://example.com> . +@prefix dcterms: <http://purl.org/dc/terms/>. @prefix xs: <http://www.w3.org/2001/XMLSchema> . +@prefix mads: <http://www.loc.gov/mads/rdf/v1#> . +@prefix skos: <http://www.w3.org/2004/02/skos/core#> . +@PREFIX dc: <http://purl.org/dc/elements/1.1/> # SPARQL-like syntax is OK +@prefix : <http://xmlns.com/foaf/0.1/> . # empty prefix is OK + +<http://example.org/#spiderman> <http://www.perceive.net/schemas/relationship/enemyOf> <http://example.org/#green-goblin> . + +<#doc1> a <#document> + dc:creator "Smith", "Jones"; + :knows <http://getopenid.com/jsmith> + dcterms:hasPart [ # A comment + dc:title "Some title", "Some other title"; + dc:creator "برشت، برتولد"@ar; + dc:date "2009"^^xs:date + ]; + dc:title "A sample title", 23.0; + dcterms:isPartOf [ + dc:title "another", "title" + ] ; + :exists true . + +<http://data.ub.uio.no/realfagstermer/006839> a mads:Topic, + skos:Concept ; + dcterms:created "2014-08-25"^^xsd:date ; + dcterms:modified "2014-11-12"^^xsd:date ; + dcterms:identifier "REAL006839" ; + skos:prefLabel "Flerbørstemarker"@nb, + "Polychaeta"@la ; + skos:altLabel "Flerbørsteormer"@nb, + "Mangebørstemark"@nb, + "Mangebørsteormer"@nb, + "Havbørsteormer"@nb, + "Havbørstemarker"@nb, + "Polycheter"@nb. + skos:inScheme <http://data.ub.uio.no/realfagstermer/> ; + skos:narrower <http://data.ub.uio.no/realfagstermer/018529>, + <http://data.ub.uio.no/realfagstermer/024538>, + <http://data.ub.uio.no/realfagstermer/026723> ; + skos:exactMatch <http://ntnu.no/ub/data/tekord#NTUB17114>, + <http://dewey.info/class/592.62/e23/>, + <http://aims.fao.org/aos/agrovoc/c_29110> . diff --git a/tests/examplefiles/example1.cadl b/tests/examplefiles/example1.cadl new file mode 100644 index 00000000..3350fa3b --- /dev/null +++ b/tests/examplefiles/example1.cadl @@ -0,0 +1,149 @@ + -- + -- Example fragment of an openEHR Archetype, written in cADL, a subsyntax of the Archetype Definition Language (ADL) + -- definition available here: http://www.openehr.org/releases/trunk/architecture/am/adl2.pdf + -- Author: Thomas Beale + -- + + EVALUATION[id1] matches { -- Adverse Reaction + data matches { + ITEM_TREE[id2] matches { + items cardinality matches {1..*; unordered} matches { + ELEMENT[id3] matches { -- Substance/Agent + value matches { + DV_TEXT[id51] + } + } + ELEMENT[id5] occurrences matches {0..1} matches { -- Absolute Contraindication? + value matches { + DV_BOOLEAN[id52] matches { + value matches {True} + } + } + } + ELEMENT[id50] occurrences matches {0..1} matches { -- Future Use + value matches { + DV_TEXT[id53] + } + } + ELEMENT[id7] occurrences matches {0..1} matches { -- Overall Comment + value matches { + DV_TEXT[id54] + } + } + CLUSTER[id10] matches { -- Reaction Event + items matches { + ELEMENT[id11] occurrences matches {0..1} matches { -- Specific Substance/Agent + value matches { + DV_TEXT[id55] + } + } + ELEMENT[id12] matches { -- Manifestation + value matches { + DV_TEXT[id56] + } + } + ELEMENT[id17] occurrences matches {0..1} matches { -- Reaction Type + value matches { + DV_TEXT[id57] + } + } + ELEMENT[id22] occurrences matches {0..1} matches { -- Certainty + value matches { + DV_CODED_TEXT[id58] matches { + defining_code matches {[ac1]} -- Certainty (synthesised) + } + } + } + ELEMENT[id13] occurrences matches {0..1} matches { -- Reaction Description + value matches { + DV_TEXT[id59] + } + } + ELEMENT[id28] occurrences matches {0..1} matches { -- Onset of Reaction + value matches { + DV_DATE_TIME[id60] + } + } + ELEMENT[id29] occurrences matches {0..1} matches { -- Duration of Reaction + value matches { + DV_DURATION[id61] + } + } + allow_archetype CLUSTER[id30] matches { -- Additional Reaction Detail + include + archetype_id/value matches {/openEHR-EHR-CLUSTER\.anatomical_location(-a-zA-Z0-9_]+)*\.v1/} + } + ELEMENT[id19] occurrences matches {0..1} matches { -- Exposure Description + value matches { + DV_TEXT[id62] + } + } + ELEMENT[id21] occurrences matches {0..1} matches { -- Earliest Exposure + value matches { + DV_DATE_TIME[id63] + } + } + ELEMENT[id26] occurrences matches {0..1} matches { -- Duration of Exposure + value matches { + DV_DURATION[id64] + } + } + allow_archetype CLUSTER[id20] matches { -- Additional Exposure Detail + include + archetype_id/value matches {/openEHR-EHR-CLUSTER\.amount(-a-zA-Z0-9_]+)*\.v1|openEHR-EHR-CLUSTER\.medication_admin(-a-zA-Z0-9_]+)*\.v1|openEHR-EHR-CLUSTER\.timing(-a-zA-Z0-9_]+)*\.v1/} + } + ELEMENT[id41] occurrences matches {0..1} matches { -- Clinical Management Description + value matches { + DV_TEXT[id65] + } + } + ELEMENT[id32] matches { -- Multimedia + value matches { + DV_MULTIMEDIA[id66] matches { + media_type + } + } + } + allow_archetype CLUSTER[id42] matches { -- Reporting Details + include + archetype_id/value matches {/.*/} + } + ELEMENT[id33] occurrences matches {0..1} matches { -- Reaction Comment + value matches { + DV_TEXT[id67] + } + } + } + } + } + } + } + protocol matches { + ITEM_TREE[id43] matches { + items matches { + ELEMENT[id45] occurrences matches {0..1} matches { -- Reaction Reported? + value matches { + DV_BOOLEAN[id68] matches { + value matches {True, False} + } + } + } + ELEMENT[id49] occurrences matches {0..1} matches { -- Report Comment + value matches { + DV_TEXT[id69] + } + } + ELEMENT[id46] matches { -- Adverse Reaction Report + value matches { + DV_URI[id70] + } + } + ELEMENT[id48] occurrences matches {0..1} matches { -- Supporting Clinical Record Information + value matches { + DV_EHR_URI[id71] + } + } + } + } + } + } diff --git a/tests/examplefiles/modula2_test_cases.def b/tests/examplefiles/modula2_test_cases.def new file mode 100644 index 00000000..ce86a55b --- /dev/null +++ b/tests/examplefiles/modula2_test_cases.def @@ -0,0 +1,354 @@ +(* Test Cases for Modula-2 Lexer *) + +(* Notes: + (1) Without dialect option nor embedded dialect tag, the lexer operates in + fallback mode, recognising the *combined* literals, punctuation symbols + and operators of all supported dialects, and the *combined* reserved + words and builtins of PIM Modula-2, ISO Modula-2 and Modula-2 R10. + (1) If multiple embedded dialect tags are present, the lexer will use the + first valid tag and ignore any subsequent dialect tags in the file. + (2) An embedded dialect tag overrides any command line dialect option. *) + + +(* Testing command line dialect option *) + +(* for PIM Modula-2 : pygmentize -O full,dialect=m2pim ... + for ISO Modula-2 : pygmentize -O full,dialect=m2iso ... + for Modula-2 R10 : pygmentize -O full,dialect=m2r10 ... + for Objective Modula-2 : pygmentize -O full,dialect=objm2 ... *) + +(* for Aglet extensions : pygmentize -O full,dialect=m2iso+aglet ... + for GNU extensions : pygmentize -O full,dialect=m2pim+gm2 ... + for p1 extensions : pygmentize -O full,dialect=m2iso+p1 ... + for XDS extensions : pygmentize -O full,dialect=m2iso+xds ... + + +(* Testing embedded dialect tags *) + +(* !m2pim*) (* <-- remove whitespace before ! for PIM Modula-2 *) +(* !m2iso*) (* <-- remove whitespace before ! for ISO Modula-2 *) +(* !m2r10*) (* <-- remove whitespace before ! for Modula-2 R10 *) +(* !objm2*) (* <-- remove whitespace before ! for Objective Modula-2 *) + +(* !m2iso+aglet*) (* <-- remove whitespace before ! for Aglet extensions *) +(* !m2pim+gm2*) (* <-- remove whitespace before ! for GNU extensions *) +(* !m2iso+p1*) (* <-- remove whitespace before ! for p1 extensions *) +(* !m2iso+xds*) (* <-- remove whitespace before ! for XDS extensions *) + + +(* Dialect Indicating Names *) + +(* recognised names should be highlighted *) + +QUALIFIED (* PIM and ISO *) + +PACKEDSET (* ISO only *) + +ARGLIST (* M2 R10 and ObjM2 *) + +BYCOPY (* ObjM2 only *) + +BITSET8 (* Aglet, GNU and M2 R10 *) + +__FILE__ (* GNU only *) + +BCD (* p1 and M2 R10 *) + +SEQ (* XDS only *) + + +(* Literal Tests *) + +(* recognised literals should be rendered as one unit + unrecognised literals should be rendered as error *) + +ch := 'a'; ch := "a"; (* all dialects *) +ch := 0u20; unich := 0u2038 (* M2 R10 *) + +s := 'The cat said "meow!".'; +s := "It is eight O'clock."; + + +n := 123; n = 1000000; (* all dialects *) +n := 123; n = 1'000'000; (* M2 R10 *) + +n := 0b0110; n:= 0b0110'1100'0111; (* M2 R10 *) +n := 0xFF00; n:= 0xDEAD'BEEF'0F00; (* M2 R10 *) + +r := 1.23; r := 1000000.000001; (* all dialects *) +r := 1.23; r := 1'000'000.000'001; (* M2 R10 *) + +r := 1.234E6; r:= 1.234E-6; r := 1.234567E1000; (* PIM + ISO *) +r := 1.234e6; r:= 1.234e-6; r := 1.234'567e1'000; (* M2 R10 *) + +ch := 0377C; n := 0377B; n := 07FF0H; (* ISO + PIM *) + + +(* Non-Alphabetic Operator Tests *) + +(* supported operators should be rendered as one unit + unsupported operators should be rendered as errors *) + +a := b + c - d * e / f; (* all dialects *) + +SetDiff := A \ B; (* M2 R10 *) + +dotProduct := v1 *. v2; catArray := array1 +> array2; (* M2 R10 *) + +bool := a = b; bool := a > b; bool := a < b; +bool := a # b; bool := a >= b; bool := a <= b; + +bool := a <> b; (* PIM + ISO *) + +bool := a == b; (* M2 R10 *) + +(*&*) IF a & b THEN ... END; (* PIM + ISO *) + +(*~*) IF ~ b THEN ... END; (* PIM + ISO *) + +(*::*) int := real :: INTEGER; (* M2 R10 *) + +(*++*) FOR i++ IN range DO ... END; (* M2 R10 *) +(*--*) FOR i-- IN range DO ... END; (* M2 R10 *) + +(*^*) next := this^.next; (* all dialects *) +(*@*) next := this@.next; (* ISO *) + +(*`*) str := `NSString alloc init; (* ObjM2 *) + + +(* Punctuation Tests *) + +(* supported punctuation should be rendered as one unit + unsupported punctuation should be rendered as an error *) + +(*.*) Foo.Bar.Baz; (*..*) TYPE Sign = [-1..1] OF INTEGER; + +(*|:*) CASE foo OF | 1 : bar | 2 : bam | 3 : boo END; +(*!:*) CASE foo OF 1 : bar ! 2 : bam ! 3 : boo END; (* ISO *) + +(*[]()*) array[n] := foo(); + +(*{}*) CONST Bar = { 1, 2, 3 }; + +(*?*) TPROPERTIES = isCollection, isIndexed | isRigid?; (* M2 R10 *) + +(*~*) CONST ~ isFoobar = Foo AND Bar; (* M2 R10 *) +(*->*) isFoobar -> PROCEDURE [ABS]; (* M2 R10 *) + +(*<<>>*) GENLIB Foo FROM Template FOR Bar = <<ARRAY OF CHAR>> END; (* M2 R10 *) + + +(* Single Line Comment Test *) + +(* should be rendered as comment if supported, as error if unsupported *) + +// This is a single line comment (M2 R10 + ObjM2) + + +(* Pragma Delimiter Tests *) + +(* PIM style pragma should be rendered as pragma in PIM dialects, + as multiline comment in all other dialects. *) + +(*$INLINE*) (* PIM *) + +(* ISO style pragma should be rendered as error in PIM dialects, + as pragma in all other dialects. *) + +<*INLINE*> (* all other dialects *) + + +(* Operator Substitution Test When in Algol mode *) + +IF foo # bar THEN ... END; (* # should be rendered as not equal symbol *) + +IF foo >= bar THEN ... END; (* >= should be rendered as not less symbol *) + +IF foo <= bar THEN ... END; (* <= should be rendered as not greater symbol *) + +IF foo == bar THEN ... END; (* == should be rendered as identity symbol *) + +dotProduct := v1 *. v2; (* *. should be rendered as dot product symbol *) + + +(* Reserved Words and Builtins Test *) + +(* supported reserved words and builtins should be highlighted *) + +(* reserved words common to all dialects *) + +AND ARRAY BEGIN BY CASE CONST DEFINITION DIV DO ELSE ELSIF END EXIT FOR FROM +IF IMPLEMENTATION IMPORT IN LOOP MOD MODULE NOT OF OR POINTER PROCEDURE +RECORD REPEAT RETURN SET THEN TO TYPE UNTIL VAR WHILE + +(* builtins common to all dialects *) + +ABS BOOLEAN CARDINAL CHAR CHR FALSE INTEGER LONGINT LONGREAL +MAX MIN NIL ODD ORD REAL TRUE + +(* pseudo builtins common to all dialects *) + +ADDRESS BYTE WORD ADR + + +(* additional reserved words for PIM *) + +EXPORT QUALIFIED WITH + +(* additional builtins for PIM *) + +BITSET CAP DEC DISPOSE EXCL FLOAT HALT HIGH INC INCL NEW NIL PROC SIZE TRUNC VAL + +(* additional pseudo-builtins for PIM *) + +SYSTEM PROCESS TSIZE NEWPROCESS TRANSFER + + +(* additional reserved words for ISO 10514-1 *) + +EXCEPT EXPORT FINALLY FORWARD PACKEDSET QUALIFIED REM RETRY WITH + +(* additional reserved words for ISO 10514-2 & ISO 10514-3 *) + +ABSTRACT AS CLASS GUARD INHERIT OVERRIDE READONLY REVEAL TRACED UNSAFEGUARDED + +(* additional builtins for ISO 10514-1 *) + +BITSET CAP CMPLX COMPLEX DEC DISPOSE EXCL FLOAT HALT HIGH IM INC INCL INT +INTERRUPTIBLE LENGTH LFLOAT LONGCOMPLEX NEW PROC PROTECTION RE SIZE TRUNC +UNINTERRUBTIBLE VAL + +(* additional builtins for ISO 10514-2 & ISO 10514-3 *) + +CREATE DESTROY EMPTY ISMEMBER SELF + + +(* additional pseudo-builtins for ISO *) + +(* SYSTEM *) +SYSTEM BITSPERLOC LOCSPERBYTE LOCSPERWORD LOC ADDADR SUBADR DIFADR MAKEADR +ADR ROTATE SHIFT CAST TSIZE + +(* COROUTINES *) +COROUTINES ATTACH COROUTINE CURRENT DETACH HANDLER INTERRUPTSOURCE IOTRANSFER +IsATTACHED LISTEN NEWCOROUTINE PROT TRANSFER + +(* EXCEPTIONS *) +EXCEPTIONS AllocateSource CurrentNumber ExceptionNumber ExceptionSource +GetMessage IsCurrentSource IsExceptionalExecution RAISE + +(* TERMINATION *) +TERMINATION IsTerminating HasHalted + +(* M2EXCEPTION *) +M2EXCEPTION M2Exceptions M2Exception IsM2Exception indexException rangeException +caseSelectException invalidLocation functionException wholeValueException +wholeDivException realValueException realDivException complexValueException +complexDivException protException sysException coException exException + + +(* additional reserved words for M2 R10 *) + +ALIAS ARGLIST BLUEPRINT COPY GENLIB INDETERMINATE NEW NONE OPAQUE REFERENTIAL +RELEASE RETAIN + +(* with symbolic assembler language extension *) +ASM REG + +(* additional builtins for M2 R10 *) + +CARDINAL COUNT EMPTY EXISTS INSERT LENGTH LONGCARD OCTET PTR PRED READ READNEW +REMOVE RETRIEVE SORT STORE SUBSET SUCC TLIMIT TMAX TMIN TRUE TSIZE UNICHAR +WRITE WRITEF + +(* additional pseudo-builtins for M2 R10 *) + +(* TPROPERTIES *) +TPROPERTIES PROPERTY LITERAL TPROPERTY TLITERAL TBUILTIN TDYN TREFC TNIL +TBASE TPRECISION TMAXEXP TMINEXP + +(* CONVERSION *) +CONVERSION TSXFSIZE SXF VAL + +(* UNSAFE *) +UNSAFE CAST INTRINSIC AVAIL ADD SUB ADDC SUBC FETCHADD FETCHSUB SHL SHR ASHR +ROTL ROTR ROTLC ROTRC BWNOT BWAND BWOR BWXOR BWNAND BWNOR SETBIT TESTBIT +LSBIT MSBIT CSBITS BAIL HALT TODO FFI ADDR VARGLIST VARGC + +(* ATOMIC *) +ATOMIC INTRINSIC AVAIL SWAP CAS INC DEC BWAND BWNAND BWOR BWXOR + +(* COMPILER *) +COMPILER DEBUG MODNAME PROCNAME LINENUM DEFAULT HASH + +(* ASSEMBLER *) +ASSEMBLER REGISTER SETREG GETREG CODE + + +(* standard library ADT identifiers for M2 R10 *) + +(* rendered as builtins when dialect is set to Modula-2 R10, + this can be turned off by option treat_stdlib_adts_as_builtins=off *) +BCD LONGBCD BITSET SHORTBITSET LONGBITSET LONGLONGBITSET COMPLEX LONGCOMPLEX +SHORTCARD LONGLONGCARD SHORTINT LONGLONGINT POSINT SHORTPOSINT LONGPOSINT +LONGLONGPOSINT BITSET8 BITSET16 BITSET32 BITSET64 BITSET128 BS8 BS16 BS32 +BS64 BS128 CARDINAL8 CARDINAL16 CARDINAL32 CARDINAL64 CARDINAL128 CARD8 +CARD16 CARD32 CARD64 CARD128 INTEGER8 INTEGER16 INTEGER32 INTEGER64 +INTEGER128 INT8 INT16 INT32 INT64 INT128 STRING UNISTRING + + +(* additional reserved words for ObjM2 *) + +(* Note: ObjM2 is a superset of M2 R10 *) + +BYCOPY BYREF CLASS CONTINUE CRITICAL INOUT METHOD ON OPTIONAL OUT PRIVATE +PROTECTED PROTOCOL PUBLIC SUPER TRY + +(* additional builtins for ObjM2 *) + +OBJECT NO YES + + +(* additional builtins for Aglet Extensions to ISO *) + +BITSET8 BITSET16 BITSET32 CARDINAL8 CARDINAL16 CARDINAL32 INTEGER8 INTEGER16 +INTEGER32 + + +(* additional reserved words for GNU Extensions to PIM *) + +ASM __ATTRIBUTE__ __BUILTIN__ __COLUMN__ __DATE__ __FILE__ __FUNCTION__ +__LINE__ __MODULE__ VOLATILE + +(* additional builtins for GNU Extensions to PIM *) + +BITSET8 BITSET16 BITSET32 CARDINAL8 CARDINAL16 CARDINAL32 CARDINAL64 COMPLEX32 +COMPLEX64 COMPLEX96 COMPLEX128 INTEGER8 INTEGER16 INTEGER32 INTEGER64 REAL8 +REAL16 REAL32 REAL96 REAL128 THROW + + +(* additional pseudo-builtins for p1 Extensions to ISO *) + +BCD + + +(* additional reserved words for XDS Extensions to ISO *) + +SEQ + +(* additional builtins for XDS Extensions to ISO *) + +ASH ASSERT DIFFADR_TYPE ENTIER INDEX LEN LONGCARD SHORTCARD SHORTINT + +(* additional pseudo-builtins for XDS Extensions to ISO *) + +(* SYSTEM *) +PROCESS NEWPROCESS BOOL8 BOOL16 BOOL32 CARD8 CARD16 CARD32 INT8 INT16 INT32 +REF MOVE FILL GET PUT CC int unsigned size_t void + +(* COMPILER *) +COMPILER OPTION EQUATION + + +(* end of file *)
\ No newline at end of file diff --git a/tests/examplefiles/robotframework_test.txt b/tests/examplefiles/robotframework_test.txt index 63ba63e6..0d8179c0 100644 --- a/tests/examplefiles/robotframework_test.txt +++ b/tests/examplefiles/robotframework_test.txt @@ -6,6 +6,7 @@ Test Setup Keyword argument argument with ${VARIABLE} *** Variables *** ${VARIABLE} Variable value @{LIST} List variable here +&{DICT} Key1=Value1 Key2=Value2 *** Test Cases *** Keyword-driven example diff --git a/tests/examplefiles/rust_example.rs b/tests/examplefiles/rust_example.rs deleted file mode 100644 index 8c44af1d..00000000 --- a/tests/examplefiles/rust_example.rs +++ /dev/null @@ -1,235 +0,0 @@ -// Copyright 2012 The Rust Project Developers. See the COPYRIGHT -// file at the top-level directory of this distribution and at -// http://rust-lang.org/COPYRIGHT. -// -// Licensed under the Apache License, Version 2.0 <LICENSE-APACHE or -// http://www.apache.org/licenses/LICENSE-2.0> or the MIT license -// <LICENSE-MIT or http://opensource.org/licenses/MIT>, at your -// option. This file may not be copied, modified, or distributed -// except according to those terms. - -// based on: -// http://shootout.alioth.debian.org/u32/benchmark.php?test=nbody&lang=java - -/* nest some /* comments */ */ - -extern mod std; - -use core::os; - -// Using sqrt from the standard library is way slower than using libc -// directly even though std just calls libc, I guess it must be -// because the the indirection through another dynamic linker -// stub. Kind of shocking. Might be able to make it faster still with -// an llvm intrinsic. -#[nolink] -extern mod libc { - #![legacy_exports]; - fn sqrt(n: float) -> float; -} - -fn main() { - let args = os::args(); - let args = if os::getenv(~"RUST_BENCH").is_some() { - ~[~"", ~"4000000"] - } else if args.len() <= 1u { - ~[~"", ~"100000"] - } else { - args - }; - let n = int::from_str(args[1]).get(); - let mut bodies: ~[Body::props] = NBodySystem::make(); - io::println(fmt!("%f", NBodySystem::energy(bodies))); - let mut i = 0; - while i < n { - NBodySystem::advance(bodies, 0.01); - i += 1; - } - io::println(fmt!("%f", NBodySystem::energy(bodies))); -} - -mod NBodySystem { - use Body; - - pub fn make() -> ~[Body::props] { - let mut bodies: ~[Body::props] = - ~[Body::sun(), - Body::jupiter(), - Body::saturn(), - Body::uranus(), - Body::neptune()]; - - let mut px = 0.0; - let mut py = 0.0; - let mut pz = 0.0; - - let mut i = 0; - while i < 5 { - px += bodies[i].vx * bodies[i].mass; - py += bodies[i].vy * bodies[i].mass; - pz += bodies[i].vz * bodies[i].mass; - - i += 1; - } - - // side-effecting - Body::offset_momentum(&mut bodies[0], px, py, pz); - - return bodies; - } - - pub fn advance(bodies: &mut [Body::props], dt: float) { - let mut i = 0; - while i < 5 { - let mut j = i + 1; - while j < 5 { - advance_one(&mut bodies[i], - &mut bodies[j], dt); - j += 1; - } - - i += 1; - } - - i = 0; - while i < 5 { - move_(&mut bodies[i], dt); - i += 1; - } - } - - pub fn advance_one(bi: &mut Body::props, - bj: &mut Body::props, - dt: float) unsafe { - let dx = bi.x - bj.x; - let dy = bi.y - bj.y; - let dz = bi.z - bj.z; - - let dSquared = dx * dx + dy * dy + dz * dz; - - let distance = ::libc::sqrt(dSquared); - let mag = dt / (dSquared * distance); - - bi.vx -= dx * bj.mass * mag; - bi.vy -= dy * bj.mass * mag; - bi.vz -= dz * bj.mass * mag; - - bj.vx += dx * bi.mass * mag; - bj.vy += dy * bi.mass * mag; - bj.vz += dz * bi.mass * mag; - } - - pub fn move_(b: &mut Body::props, dt: float) { - b.x += dt * b.vx; - b.y += dt * b.vy; - b.z += dt * b.vz; - } - - pub fn energy(bodies: &[Body::props]) -> float unsafe { - let mut dx; - let mut dy; - let mut dz; - let mut distance; - let mut e = 0.0; - - let mut i = 0; - while i < 5 { - e += - 0.5 * bodies[i].mass * - (bodies[i].vx * bodies[i].vx + bodies[i].vy * bodies[i].vy - + bodies[i].vz * bodies[i].vz); - - let mut j = i + 1; - while j < 5 { - dx = bodies[i].x - bodies[j].x; - dy = bodies[i].y - bodies[j].y; - dz = bodies[i].z - bodies[j].z; - - distance = ::libc::sqrt(dx * dx + dy * dy + dz * dz); - e -= bodies[i].mass * bodies[j].mass / distance; - - j += 1; - } - - i += 1; - } - return e; - - } -} - -mod Body { - use Body; - - pub const PI: float = 3.141592653589793; - pub const SOLAR_MASS: float = 39.478417604357432; - // was 4 * PI * PI originally - pub const DAYS_PER_YEAR: float = 365.24; - - pub type props = - {mut x: float, - mut y: float, - mut z: float, - mut vx: float, - mut vy: float, - mut vz: float, - mass: float}; - - pub fn jupiter() -> Body::props { - return {mut x: 4.84143144246472090e+00, - mut y: -1.16032004402742839e+00, - mut z: -1.03622044471123109e-01, - mut vx: 1.66007664274403694e-03 * DAYS_PER_YEAR, - mut vy: 7.69901118419740425e-03 * DAYS_PER_YEAR, - mut vz: -6.90460016972063023e-05 * DAYS_PER_YEAR, - mass: 9.54791938424326609e-04 * SOLAR_MASS}; - } - - pub fn saturn() -> Body::props { - return {mut x: 8.34336671824457987e+00, - mut y: 4.12479856412430479e+00, - mut z: -4.03523417114321381e-01, - mut vx: -2.76742510726862411e-03 * DAYS_PER_YEAR, - mut vy: 4.99852801234917238e-03 * DAYS_PER_YEAR, - mut vz: 2.30417297573763929e-05 * DAYS_PER_YEAR, - mass: 2.85885980666130812e-04 * SOLAR_MASS}; - } - - pub fn uranus() -> Body::props { - return {mut x: 1.28943695621391310e+01, - mut y: -1.51111514016986312e+01, - mut z: -2.23307578892655734e-01, - mut vx: 2.96460137564761618e-03 * DAYS_PER_YEAR, - mut vy: 2.37847173959480950e-03 * DAYS_PER_YEAR, - mut vz: -2.96589568540237556e-05 * DAYS_PER_YEAR, - mass: 4.36624404335156298e-05 * SOLAR_MASS}; - } - - pub fn neptune() -> Body::props { - return {mut x: 1.53796971148509165e+01, - mut y: -2.59193146099879641e+01, - mut z: 1.79258772950371181e-01, - mut vx: 2.68067772490389322e-03 * DAYS_PER_YEAR, - mut vy: 1.62824170038242295e-03 * DAYS_PER_YEAR, - mut vz: -9.51592254519715870e-05 * DAYS_PER_YEAR, - mass: 5.15138902046611451e-05 * SOLAR_MASS}; - } - - pub fn sun() -> Body::props { - return {mut x: 0.0, - mut y: 0.0, - mut z: 0.0, - mut vx: 0.0, - mut vy: 0.0, - mut vz: 0.0, - mass: SOLAR_MASS}; - } - - pub fn offset_momentum(props: &mut Body::props, - px: float, py: float, pz: float) { - props.vx = -px / SOLAR_MASS; - props.vy = -py / SOLAR_MASS; - props.vz = -pz / SOLAR_MASS; - } - -} diff --git a/tests/examplefiles/subr.el b/tests/examplefiles/subr.el new file mode 100644 index 00000000..deadca6e --- /dev/null +++ b/tests/examplefiles/subr.el @@ -0,0 +1,4868 @@ +;;; subr.el --- basic lisp subroutines for Emacs -*- coding: utf-8; lexical-binding:t -*- + +;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2015 Free Software +;; Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org +;; Keywords: internal +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +;; Beware: while this file has tag `utf-8', before it's compiled, it gets +;; loaded as "raw-text", so non-ASCII chars won't work right during bootstrap. + +(defmacro declare-function (_fn _file &optional _arglist _fileonly) + "Tell the byte-compiler that function FN is defined, in FILE. +Optional ARGLIST is the argument list used by the function. +The FILE argument is not used by the byte-compiler, but by the +`check-declare' package, which checks that FILE contains a +definition for FN. ARGLIST is used by both the byte-compiler +and `check-declare' to check for consistency. + +FILE can be either a Lisp file (in which case the \".el\" +extension is optional), or a C file. C files are expanded +relative to the Emacs \"src/\" directory. Lisp files are +searched for using `locate-library', and if that fails they are +expanded relative to the location of the file containing the +declaration. A FILE with an \"ext:\" prefix is an external file. +`check-declare' will check such files if they are found, and skip +them without error if they are not. + +FILEONLY non-nil means that `check-declare' will only check that +FILE exists, not that it defines FN. This is intended for +function-definitions that `check-declare' does not recognize, e.g. +`defstruct'. + +To specify a value for FILEONLY without passing an argument list, +set ARGLIST to t. This is necessary because nil means an +empty argument list, rather than an unspecified one. + +Note that for the purposes of `check-declare', this statement +must be the first non-whitespace on a line. + +For more information, see Info node `(elisp)Declaring Functions'." + ;; Does nothing - byte-compile-declare-function does the work. + nil) + + +;;;; Basic Lisp macros. + +(defalias 'not 'null) + +(defmacro noreturn (form) + "Evaluate FORM, expecting it not to return. +If FORM does return, signal an error." + (declare (debug t)) + `(prog1 ,form + (error "Form marked with `noreturn' did return"))) + +(defmacro 1value (form) + "Evaluate FORM, expecting a constant return value. +This is the global do-nothing version. There is also `testcover-1value' +that complains if FORM ever does return differing values." + (declare (debug t)) + form) + +(defmacro def-edebug-spec (symbol spec) + "Set the `edebug-form-spec' property of SYMBOL according to SPEC. +Both SYMBOL and SPEC are unevaluated. The SPEC can be: +0 (instrument no arguments); t (instrument all arguments); +a symbol (naming a function with an Edebug specification); or a list. +The elements of the list describe the argument types; see +Info node `(elisp)Specification List' for details." + `(put (quote ,symbol) 'edebug-form-spec (quote ,spec))) + +(defmacro lambda (&rest cdr) + "Return a lambda expression. +A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is +self-quoting; the result of evaluating the lambda expression is the +expression itself. The lambda expression may then be treated as a +function, i.e., stored as the function value of a symbol, passed to +`funcall' or `mapcar', etc. + +ARGS should take the same form as an argument list for a `defun'. +DOCSTRING is an optional documentation string. + If present, it should describe how to call the function. + But documentation strings are usually not useful in nameless functions. +INTERACTIVE should be a call to the function `interactive', which see. +It may also be omitted. +BODY should be a list of Lisp expressions. + +\(fn ARGS [DOCSTRING] [INTERACTIVE] BODY)" + (declare (doc-string 2) (indent defun) + (debug (&define lambda-list + [&optional stringp] + [&optional ("interactive" interactive)] + def-body))) + ;; Note that this definition should not use backquotes; subr.el should not + ;; depend on backquote.el. + (list 'function (cons 'lambda cdr))) + +(defmacro setq-local (var val) + "Set variable VAR to value VAL in current buffer." + ;; Can't use backquote here, it's too early in the bootstrap. + (list 'set (list 'make-local-variable (list 'quote var)) val)) + +(defmacro defvar-local (var val &optional docstring) + "Define VAR as a buffer-local variable with default value VAL. +Like `defvar' but additionally marks the variable as being automatically +buffer-local wherever it is set." + (declare (debug defvar) (doc-string 3)) + ;; Can't use backquote here, it's too early in the bootstrap. + (list 'progn (list 'defvar var val docstring) + (list 'make-variable-buffer-local (list 'quote var)))) + +(defun apply-partially (fun &rest args) + "Return a function that is a partial application of FUN to ARGS. +ARGS is a list of the first N arguments to pass to FUN. +The result is a new function which does the same as FUN, except that +the first N arguments are fixed at the values with which this function +was called." + (lambda (&rest args2) + (apply fun (append args args2)))) + +(defmacro push (newelt place) + "Add NEWELT to the list stored in the generalized variable PLACE. +This is morally equivalent to (setf PLACE (cons NEWELT PLACE)), +except that PLACE is only evaluated once (after NEWELT)." + (declare (debug (form gv-place))) + (if (symbolp place) + ;; Important special case, to avoid triggering GV too early in + ;; the bootstrap. + (list 'setq place + (list 'cons newelt place)) + (require 'macroexp) + (macroexp-let2 macroexp-copyable-p v newelt + (gv-letplace (getter setter) place + (funcall setter `(cons ,v ,getter)))))) + +(defmacro pop (place) + "Return the first element of PLACE's value, and remove it from the list. +PLACE must be a generalized variable whose value is a list. +If the value is nil, `pop' returns nil but does not actually +change the list." + (declare (debug (gv-place))) + ;; We use `car-safe' here instead of `car' because the behavior is the same + ;; (if it's not a cons cell, the `cdr' would have signaled an error already), + ;; but `car-safe' is total, so the byte-compiler can safely remove it if the + ;; result is not used. + `(car-safe + ,(if (symbolp place) + ;; So we can use `pop' in the bootstrap before `gv' can be used. + (list 'prog1 place (list 'setq place (list 'cdr place))) + (gv-letplace (getter setter) place + (macroexp-let2 macroexp-copyable-p x getter + `(prog1 ,x ,(funcall setter `(cdr ,x)))))))) + +(defmacro when (cond &rest body) + "If COND yields non-nil, do BODY, else return nil. +When COND yields non-nil, eval BODY forms sequentially and return +value of last one, or nil if there are none. + +\(fn COND BODY...)" + (declare (indent 1) (debug t)) + (list 'if cond (cons 'progn body))) + +(defmacro unless (cond &rest body) + "If COND yields nil, do BODY, else return nil. +When COND yields nil, eval BODY forms sequentially and return +value of last one, or nil if there are none. + +\(fn COND BODY...)" + (declare (indent 1) (debug t)) + (cons 'if (cons cond (cons nil body)))) + +(defmacro dolist (spec &rest body) + "Loop over a list. +Evaluate BODY with VAR bound to each car from LIST, in turn. +Then evaluate RESULT to get return value, default nil. + +\(fn (VAR LIST [RESULT]) BODY...)" + (declare (indent 1) (debug ((symbolp form &optional form) body))) + ;; It would be cleaner to create an uninterned symbol, + ;; but that uses a lot more space when many functions in many files + ;; use dolist. + ;; FIXME: This cost disappears in byte-compiled lexical-binding files. + (let ((temp '--dolist-tail--)) + ;; This is not a reliable test, but it does not matter because both + ;; semantics are acceptable, tho one is slightly faster with dynamic + ;; scoping and the other is slightly faster (and has cleaner semantics) + ;; with lexical scoping. + (if lexical-binding + `(let ((,temp ,(nth 1 spec))) + (while ,temp + (let ((,(car spec) (car ,temp))) + ,@body + (setq ,temp (cdr ,temp)))) + ,@(cdr (cdr spec))) + `(let ((,temp ,(nth 1 spec)) + ,(car spec)) + (while ,temp + (setq ,(car spec) (car ,temp)) + ,@body + (setq ,temp (cdr ,temp))) + ,@(if (cdr (cdr spec)) + `((setq ,(car spec) nil) ,@(cdr (cdr spec)))))))) + +(defmacro dotimes (spec &rest body) + "Loop a certain number of times. +Evaluate BODY with VAR bound to successive integers running from 0, +inclusive, to COUNT, exclusive. Then evaluate RESULT to get +the return value (nil if RESULT is omitted). + +\(fn (VAR COUNT [RESULT]) BODY...)" + (declare (indent 1) (debug dolist)) + ;; It would be cleaner to create an uninterned symbol, + ;; but that uses a lot more space when many functions in many files + ;; use dotimes. + ;; FIXME: This cost disappears in byte-compiled lexical-binding files. + (let ((temp '--dotimes-limit--) + (start 0) + (end (nth 1 spec))) + ;; This is not a reliable test, but it does not matter because both + ;; semantics are acceptable, tho one is slightly faster with dynamic + ;; scoping and the other has cleaner semantics. + (if lexical-binding + (let ((counter '--dotimes-counter--)) + `(let ((,temp ,end) + (,counter ,start)) + (while (< ,counter ,temp) + (let ((,(car spec) ,counter)) + ,@body) + (setq ,counter (1+ ,counter))) + ,@(if (cddr spec) + ;; FIXME: This let often leads to "unused var" warnings. + `((let ((,(car spec) ,counter)) ,@(cddr spec)))))) + `(let ((,temp ,end) + (,(car spec) ,start)) + (while (< ,(car spec) ,temp) + ,@body + (setq ,(car spec) (1+ ,(car spec)))) + ,@(cdr (cdr spec)))))) + +(defmacro declare (&rest _specs) + "Do not evaluate any arguments, and return nil. +If a `declare' form appears as the first form in the body of a +`defun' or `defmacro' form, SPECS specifies various additional +information about the function or macro; these go into effect +during the evaluation of the `defun' or `defmacro' form. + +The possible values of SPECS are specified by +`defun-declarations-alist' and `macro-declarations-alist'. + +For more information, see info node `(elisp)Declare Form'." + ;; FIXME: edebug spec should pay attention to defun-declarations-alist. + nil) + +(defmacro ignore-errors (&rest body) + "Execute BODY; if an error occurs, return nil. +Otherwise, return result of last form in BODY. +See also `with-demoted-errors' that does something similar +without silencing all errors." + (declare (debug t) (indent 0)) + `(condition-case nil (progn ,@body) (error nil))) + +;;;; Basic Lisp functions. + +(defun ignore (&rest _ignore) + "Do nothing and return nil. +This function accepts any number of arguments, but ignores them." + (interactive) + nil) + +;; Signal a compile-error if the first arg is missing. +(defun error (&rest args) + "Signal an error, making error message by passing all args to `format'. +In Emacs, the convention is that error messages start with a capital +letter but *do not* end with a period. Please follow this convention +for the sake of consistency." + (declare (advertised-calling-convention (string &rest args) "23.1")) + (signal 'error (list (apply 'format args)))) + +(defun user-error (format &rest args) + "Signal a pilot error, making error message by passing all args to `format'. +In Emacs, the convention is that error messages start with a capital +letter but *do not* end with a period. Please follow this convention +for the sake of consistency. +This is just like `error' except that `user-error's are expected to be the +result of an incorrect manipulation on the part of the user, rather than the +result of an actual problem." + (signal 'user-error (list (apply #'format format args)))) + +(defun define-error (name message &optional parent) + "Define NAME as a new error signal. +MESSAGE is a string that will be output to the echo area if such an error +is signaled without being caught by a `condition-case'. +PARENT is either a signal or a list of signals from which it inherits. +Defaults to `error'." + (unless parent (setq parent 'error)) + (let ((conditions + (if (consp parent) + (apply #'append + (mapcar (lambda (parent) + (cons parent + (or (get parent 'error-conditions) + (error "Unknown signal `%s'" parent)))) + parent)) + (cons parent (get parent 'error-conditions))))) + (put name 'error-conditions + (delete-dups (copy-sequence (cons name conditions)))) + (when message (put name 'error-message message)))) + +;; We put this here instead of in frame.el so that it's defined even on +;; systems where frame.el isn't loaded. +(defun frame-configuration-p (object) + "Return non-nil if OBJECT seems to be a frame configuration. +Any list whose car is `frame-configuration' is assumed to be a frame +configuration." + (and (consp object) + (eq (car object) 'frame-configuration))) + + +;;;; List functions. + +(defsubst caar (x) + "Return the car of the car of X." + (car (car x))) + +(defsubst cadr (x) + "Return the car of the cdr of X." + (car (cdr x))) + +(defsubst cdar (x) + "Return the cdr of the car of X." + (cdr (car x))) + +(defsubst cddr (x) + "Return the cdr of the cdr of X." + (cdr (cdr x))) + +(defun last (list &optional n) + "Return the last link of LIST. Its car is the last element. +If LIST is nil, return nil. +If N is non-nil, return the Nth-to-last link of LIST. +If N is bigger than the length of LIST, return LIST." + (if n + (and (>= n 0) + (let ((m (safe-length list))) + (if (< n m) (nthcdr (- m n) list) list))) + (and list + (nthcdr (1- (safe-length list)) list)))) + +(defun butlast (list &optional n) + "Return a copy of LIST with the last N elements removed. +If N is omitted or nil, the last element is removed from the +copy." + (if (and n (<= n 0)) list + (nbutlast (copy-sequence list) n))) + +(defun nbutlast (list &optional n) + "Modifies LIST to remove the last N elements. +If N is omitted or nil, remove the last element." + (let ((m (length list))) + (or n (setq n 1)) + (and (< n m) + (progn + (if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil)) + list)))) + +(defun zerop (number) + "Return t if NUMBER is zero." + ;; Used to be in C, but it's pointless since (= 0 n) is faster anyway because + ;; = has a byte-code. + (declare (compiler-macro (lambda (_) `(= 0 ,number)))) + (= 0 number)) + +(defun delete-dups (list) + "Destructively remove `equal' duplicates from LIST. +Store the result in LIST and return it. LIST must be a proper list. +Of several `equal' occurrences of an element in LIST, the first +one is kept." + (let ((tail list)) + (while tail + (setcdr tail (delete (car tail) (cdr tail))) + (setq tail (cdr tail)))) + list) + +;; See http://lists.gnu.org/archive/html/emacs-devel/2013-05/msg00204.html +(defun delete-consecutive-dups (list &optional circular) + "Destructively remove `equal' consecutive duplicates from LIST. +First and last elements are considered consecutive if CIRCULAR is +non-nil." + (let ((tail list) last) + (while (consp tail) + (if (equal (car tail) (cadr tail)) + (setcdr tail (cddr tail)) + (setq last (car tail) + tail (cdr tail)))) + (if (and circular + (cdr list) + (equal last (car list))) + (nbutlast list) + list))) + +(defun number-sequence (from &optional to inc) + "Return a sequence of numbers from FROM to TO (both inclusive) as a list. +INC is the increment used between numbers in the sequence and defaults to 1. +So, the Nth element of the list is (+ FROM (* N INC)) where N counts from +zero. TO is only included if there is an N for which TO = FROM + N * INC. +If TO is nil or numerically equal to FROM, return (FROM). +If INC is positive and TO is less than FROM, or INC is negative +and TO is larger than FROM, return nil. +If INC is zero and TO is neither nil nor numerically equal to +FROM, signal an error. + +This function is primarily designed for integer arguments. +Nevertheless, FROM, TO and INC can be integer or float. However, +floating point arithmetic is inexact. For instance, depending on +the machine, it may quite well happen that +\(number-sequence 0.4 0.6 0.2) returns the one element list (0.4), +whereas (number-sequence 0.4 0.8 0.2) returns a list with three +elements. Thus, if some of the arguments are floats and one wants +to make sure that TO is included, one may have to explicitly write +TO as (+ FROM (* N INC)) or use a variable whose value was +computed with this exact expression. Alternatively, you can, +of course, also replace TO with a slightly larger value +\(or a slightly more negative value if INC is negative)." + (if (or (not to) (= from to)) + (list from) + (or inc (setq inc 1)) + (when (zerop inc) (error "The increment can not be zero")) + (let (seq (n 0) (next from)) + (if (> inc 0) + (while (<= next to) + (setq seq (cons next seq) + n (1+ n) + next (+ from (* n inc)))) + (while (>= next to) + (setq seq (cons next seq) + n (1+ n) + next (+ from (* n inc))))) + (nreverse seq)))) + +(defun copy-tree (tree &optional vecp) + "Make a copy of TREE. +If TREE is a cons cell, this recursively copies both its car and its cdr. +Contrast to `copy-sequence', which copies only along the cdrs. With second +argument VECP, this copies vectors as well as conses." + (if (consp tree) + (let (result) + (while (consp tree) + (let ((newcar (car tree))) + (if (or (consp (car tree)) (and vecp (vectorp (car tree)))) + (setq newcar (copy-tree (car tree) vecp))) + (push newcar result)) + (setq tree (cdr tree))) + (nconc (nreverse result) tree)) + (if (and vecp (vectorp tree)) + (let ((i (length (setq tree (copy-sequence tree))))) + (while (>= (setq i (1- i)) 0) + (aset tree i (copy-tree (aref tree i) vecp))) + tree) + tree))) + +;;;; Various list-search functions. + +(defun assoc-default (key alist &optional test default) + "Find object KEY in a pseudo-alist ALIST. +ALIST is a list of conses or objects. Each element + (or the element's car, if it is a cons) is compared with KEY by + calling TEST, with two arguments: (i) the element or its car, + and (ii) KEY. +If that is non-nil, the element matches; then `assoc-default' + returns the element's cdr, if it is a cons, or DEFAULT if the + element is not a cons. + +If no element matches, the value is nil. +If TEST is omitted or nil, `equal' is used." + (let (found (tail alist) value) + (while (and tail (not found)) + (let ((elt (car tail))) + (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key) + (setq found t value (if (consp elt) (cdr elt) default)))) + (setq tail (cdr tail))) + value)) + +(defun assoc-ignore-case (key alist) + "Like `assoc', but ignores differences in case and text representation. +KEY must be a string. Upper-case and lower-case letters are treated as equal. +Unibyte strings are converted to multibyte for comparison." + (declare (obsolete assoc-string "22.1")) + (assoc-string key alist t)) + +(defun assoc-ignore-representation (key alist) + "Like `assoc', but ignores differences in text representation. +KEY must be a string. +Unibyte strings are converted to multibyte for comparison." + (declare (obsolete assoc-string "22.1")) + (assoc-string key alist nil)) + +(defun member-ignore-case (elt list) + "Like `member', but ignore differences in case and text representation. +ELT must be a string. Upper-case and lower-case letters are treated as equal. +Unibyte strings are converted to multibyte for comparison. +Non-strings in LIST are ignored." + (while (and list + (not (and (stringp (car list)) + (eq t (compare-strings elt 0 nil (car list) 0 nil t))))) + (setq list (cdr list))) + list) + +(defun assq-delete-all (key alist) + "Delete from ALIST all elements whose car is `eq' to KEY. +Return the modified alist. +Elements of ALIST that are not conses are ignored." + (while (and (consp (car alist)) + (eq (car (car alist)) key)) + (setq alist (cdr alist))) + (let ((tail alist) tail-cdr) + (while (setq tail-cdr (cdr tail)) + (if (and (consp (car tail-cdr)) + (eq (car (car tail-cdr)) key)) + (setcdr tail (cdr tail-cdr)) + (setq tail tail-cdr)))) + alist) + +(defun rassq-delete-all (value alist) + "Delete from ALIST all elements whose cdr is `eq' to VALUE. +Return the modified alist. +Elements of ALIST that are not conses are ignored." + (while (and (consp (car alist)) + (eq (cdr (car alist)) value)) + (setq alist (cdr alist))) + (let ((tail alist) tail-cdr) + (while (setq tail-cdr (cdr tail)) + (if (and (consp (car tail-cdr)) + (eq (cdr (car tail-cdr)) value)) + (setcdr tail (cdr tail-cdr)) + (setq tail tail-cdr)))) + alist) + +(defun alist-get (key alist &optional default remove) + "Get the value associated to KEY in ALIST. +DEFAULT is the value to return if KEY is not found in ALIST. +REMOVE, if non-nil, means that when setting this element, we should +remove the entry if the new value is `eql' to DEFAULT." + (ignore remove) ;;Silence byte-compiler. + (let ((x (assq key alist))) + (if x (cdr x) default))) + +(defun remove (elt seq) + "Return a copy of SEQ with all occurrences of ELT removed. +SEQ must be a list, vector, or string. The comparison is done with `equal'." + (if (nlistp seq) + ;; If SEQ isn't a list, there's no need to copy SEQ because + ;; `delete' will return a new object. + (delete elt seq) + (delete elt (copy-sequence seq)))) + +(defun remq (elt list) + "Return LIST with all occurrences of ELT removed. +The comparison is done with `eq'. Contrary to `delq', this does not use +side-effects, and the argument LIST is not modified." + (while (and (eq elt (car list)) (setq list (cdr list)))) + (if (memq elt list) + (delq elt (copy-sequence list)) + list)) + +;;;; Keymap support. + +(defun kbd (keys) + "Convert KEYS to the internal Emacs key representation. +KEYS should be a string constant in the format used for +saving keyboard macros (see `edmacro-mode')." + ;; Don't use a defalias, since the `pure' property is only true for + ;; the calling convention of `kbd'. + (read-kbd-macro keys)) +(put 'kbd 'pure t) + +(defun undefined () + "Beep to tell the user this binding is undefined." + (interactive) + (ding) + (message "%s is undefined" (key-description (this-single-command-keys))) + (setq defining-kbd-macro nil) + (force-mode-line-update) + ;; If this is a down-mouse event, don't reset prefix-arg; + ;; pass it to the command run by the up event. + (setq prefix-arg + (when (memq 'down (event-modifiers last-command-event)) + current-prefix-arg))) + +;; Prevent the \{...} documentation construct +;; from mentioning keys that run this command. +(put 'undefined 'suppress-keymap t) + +(defun suppress-keymap (map &optional nodigits) + "Make MAP override all normally self-inserting keys to be undefined. +Normally, as an exception, digits and minus-sign are set to make prefix args, +but optional second arg NODIGITS non-nil treats them like other chars." + (define-key map [remap self-insert-command] 'undefined) + (or nodigits + (let (loop) + (define-key map "-" 'negative-argument) + ;; Make plain numbers do numeric args. + (setq loop ?0) + (while (<= loop ?9) + (define-key map (char-to-string loop) 'digit-argument) + (setq loop (1+ loop)))))) + +(defun make-composed-keymap (maps &optional parent) + "Construct a new keymap composed of MAPS and inheriting from PARENT. +When looking up a key in the returned map, the key is looked in each +keymap of MAPS in turn until a binding is found. +If no binding is found in MAPS, the lookup continues in PARENT, if non-nil. +As always with keymap inheritance, a nil binding in MAPS overrides +any corresponding binding in PARENT, but it does not override corresponding +bindings in other keymaps of MAPS. +MAPS can be a list of keymaps or a single keymap. +PARENT if non-nil should be a keymap." + `(keymap + ,@(if (keymapp maps) (list maps) maps) + ,@parent)) + +(defun define-key-after (keymap key definition &optional after) + "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. +This is like `define-key' except that the binding for KEY is placed +just after the binding for the event AFTER, instead of at the beginning +of the map. Note that AFTER must be an event type (like KEY), NOT a command +\(like DEFINITION). + +If AFTER is t or omitted, the new binding goes at the end of the keymap. +AFTER should be a single event type--a symbol or a character, not a sequence. + +Bindings are always added before any inherited map. + +The order of bindings in a keymap only matters when it is used as +a menu, so this function is not useful for non-menu keymaps." + (unless after (setq after t)) + (or (keymapp keymap) + (signal 'wrong-type-argument (list 'keymapp keymap))) + (setq key + (if (<= (length key) 1) (aref key 0) + (setq keymap (lookup-key keymap + (apply 'vector + (butlast (mapcar 'identity key))))) + (aref key (1- (length key))))) + (let ((tail keymap) done inserted) + (while (and (not done) tail) + ;; Delete any earlier bindings for the same key. + (if (eq (car-safe (car (cdr tail))) key) + (setcdr tail (cdr (cdr tail)))) + ;; If we hit an included map, go down that one. + (if (keymapp (car tail)) (setq tail (car tail))) + ;; When we reach AFTER's binding, insert the new binding after. + ;; If we reach an inherited keymap, insert just before that. + ;; If we reach the end of this keymap, insert at the end. + (if (or (and (eq (car-safe (car tail)) after) + (not (eq after t))) + (eq (car (cdr tail)) 'keymap) + (null (cdr tail))) + (progn + ;; Stop the scan only if we find a parent keymap. + ;; Keep going past the inserted element + ;; so we can delete any duplications that come later. + (if (eq (car (cdr tail)) 'keymap) + (setq done t)) + ;; Don't insert more than once. + (or inserted + (setcdr tail (cons (cons key definition) (cdr tail)))) + (setq inserted t))) + (setq tail (cdr tail))))) + +(defun map-keymap-sorted (function keymap) + "Implement `map-keymap' with sorting. +Don't call this function; it is for internal use only." + (let (list) + (map-keymap (lambda (a b) (push (cons a b) list)) + keymap) + (setq list (sort list + (lambda (a b) + (setq a (car a) b (car b)) + (if (integerp a) + (if (integerp b) (< a b) + t) + (if (integerp b) t + ;; string< also accepts symbols. + (string< a b)))))) + (dolist (p list) + (funcall function (car p) (cdr p))))) + +(defun keymap--menu-item-binding (val) + "Return the binding part of a menu-item." + (cond + ((not (consp val)) val) ;Not a menu-item. + ((eq 'menu-item (car val)) + (let* ((binding (nth 2 val)) + (plist (nthcdr 3 val)) + (filter (plist-get plist :filter))) + (if filter (funcall filter binding) + binding))) + ((and (consp (cdr val)) (stringp (cadr val))) + (cddr val)) + ((stringp (car val)) + (cdr val)) + (t val))) ;Not a menu-item either. + +(defun keymap--menu-item-with-binding (item binding) + "Build a menu-item like ITEM but with its binding changed to BINDING." + (cond + ((not (consp item)) binding) ;Not a menu-item. + ((eq 'menu-item (car item)) + (setq item (copy-sequence item)) + (let ((tail (nthcdr 2 item))) + (setcar tail binding) + ;; Remove any potential filter. + (if (plist-get (cdr tail) :filter) + (setcdr tail (plist-put (cdr tail) :filter nil)))) + item) + ((and (consp (cdr item)) (stringp (cadr item))) + (cons (car item) (cons (cadr item) binding))) + (t (cons (car item) binding)))) + +(defun keymap--merge-bindings (val1 val2) + "Merge bindings VAL1 and VAL2." + (let ((map1 (keymap--menu-item-binding val1)) + (map2 (keymap--menu-item-binding val2))) + (if (not (and (keymapp map1) (keymapp map2))) + ;; There's nothing to merge: val1 takes precedence. + val1 + (let ((map (list 'keymap map1 map2)) + (item (if (keymapp val1) (if (keymapp val2) nil val2) val1))) + (keymap--menu-item-with-binding item map))))) + +(defun keymap-canonicalize (map) + "Return a simpler equivalent keymap. +This resolves inheritance and redefinitions. The returned keymap +should behave identically to a copy of KEYMAP w.r.t `lookup-key' +and use in active keymaps and menus. +Subkeymaps may be modified but are not canonicalized." + ;; FIXME: Problem with the difference between a nil binding + ;; that hides a binding in an inherited map and a nil binding that's ignored + ;; to let some further binding visible. Currently a nil binding hides all. + ;; FIXME: we may want to carefully (re)order elements in case they're + ;; menu-entries. + (let ((bindings ()) + (ranges ()) + (prompt (keymap-prompt map))) + (while (keymapp map) + (setq map (map-keymap ;; -internal + (lambda (key item) + (if (consp key) + ;; Treat char-ranges specially. + (push (cons key item) ranges) + (push (cons key item) bindings))) + map))) + ;; Create the new map. + (setq map (funcall (if ranges 'make-keymap 'make-sparse-keymap) prompt)) + (dolist (binding ranges) + ;; Treat char-ranges specially. FIXME: need to merge as well. + (define-key map (vector (car binding)) (cdr binding))) + ;; Process the bindings starting from the end. + (dolist (binding (prog1 bindings (setq bindings ()))) + (let* ((key (car binding)) + (oldbind (assq key bindings))) + (push (if (not oldbind) + ;; The normal case: no duplicate bindings. + binding + ;; This is the second binding for this key. + (setq bindings (delq oldbind bindings)) + (cons key (keymap--merge-bindings (cdr binding) + (cdr oldbind)))) + bindings))) + (nconc map bindings))) + +(put 'keyboard-translate-table 'char-table-extra-slots 0) + +(defun keyboard-translate (from to) + "Translate character FROM to TO on the current terminal. +This function creates a `keyboard-translate-table' if necessary +and then modifies one entry in it." + (or (char-table-p keyboard-translate-table) + (setq keyboard-translate-table + (make-char-table 'keyboard-translate-table nil))) + (aset keyboard-translate-table from to)) + +;;;; Key binding commands. + +(defun global-set-key (key command) + "Give KEY a global binding as COMMAND. +COMMAND is the command definition to use; usually it is +a symbol naming an interactively-callable function. +KEY is a key sequence; noninteractively, it is a string or vector +of characters or event types, and non-ASCII characters with codes +above 127 (such as ISO Latin-1) can be included if you use a vector. + +Note that if KEY has a local binding in the current buffer, +that local binding will continue to shadow any global binding +that you make with this function." + (interactive "KSet key globally: \nCSet key %s to command: ") + (or (vectorp key) (stringp key) + (signal 'wrong-type-argument (list 'arrayp key))) + (define-key (current-global-map) key command)) + +(defun local-set-key (key command) + "Give KEY a local binding as COMMAND. +COMMAND is the command definition to use; usually it is +a symbol naming an interactively-callable function. +KEY is a key sequence; noninteractively, it is a string or vector +of characters or event types, and non-ASCII characters with codes +above 127 (such as ISO Latin-1) can be included if you use a vector. + +The binding goes in the current buffer's local map, which in most +cases is shared with all other buffers in the same major mode." + (interactive "KSet key locally: \nCSet key %s locally to command: ") + (let ((map (current-local-map))) + (or map + (use-local-map (setq map (make-sparse-keymap)))) + (or (vectorp key) (stringp key) + (signal 'wrong-type-argument (list 'arrayp key))) + (define-key map key command))) + +(defun global-unset-key (key) + "Remove global binding of KEY. +KEY is a string or vector representing a sequence of keystrokes." + (interactive "kUnset key globally: ") + (global-set-key key nil)) + +(defun local-unset-key (key) + "Remove local binding of KEY. +KEY is a string or vector representing a sequence of keystrokes." + (interactive "kUnset key locally: ") + (if (current-local-map) + (local-set-key key nil)) + nil) + +;;;; substitute-key-definition and its subroutines. + +(defvar key-substitution-in-progress nil + "Used internally by `substitute-key-definition'.") + +(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix) + "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. +In other words, OLDDEF is replaced with NEWDEF where ever it appears. +Alternatively, if optional fourth argument OLDMAP is specified, we redefine +in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP. + +If you don't specify OLDMAP, you can usually get the same results +in a cleaner way with command remapping, like this: + (define-key KEYMAP [remap OLDDEF] NEWDEF) +\n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)" + ;; Don't document PREFIX in the doc string because we don't want to + ;; advertise it. It's meant for recursive calls only. Here's its + ;; meaning + + ;; If optional argument PREFIX is specified, it should be a key + ;; prefix, a string. Redefined bindings will then be bound to the + ;; original key, with PREFIX added at the front. + (or prefix (setq prefix "")) + (let* ((scan (or oldmap keymap)) + (prefix1 (vconcat prefix [nil])) + (key-substitution-in-progress + (cons scan key-substitution-in-progress))) + ;; Scan OLDMAP, finding each char or event-symbol that + ;; has any definition, and act on it with hack-key. + (map-keymap + (lambda (char defn) + (aset prefix1 (length prefix) char) + (substitute-key-definition-key defn olddef newdef prefix1 keymap)) + scan))) + +(defun substitute-key-definition-key (defn olddef newdef prefix keymap) + (let (inner-def skipped menu-item) + ;; Find the actual command name within the binding. + (if (eq (car-safe defn) 'menu-item) + (setq menu-item defn defn (nth 2 defn)) + ;; Skip past menu-prompt. + (while (stringp (car-safe defn)) + (push (pop defn) skipped)) + ;; Skip past cached key-equivalence data for menu items. + (if (consp (car-safe defn)) + (setq defn (cdr defn)))) + (if (or (eq defn olddef) + ;; Compare with equal if definition is a key sequence. + ;; That is useful for operating on function-key-map. + (and (or (stringp defn) (vectorp defn)) + (equal defn olddef))) + (define-key keymap prefix + (if menu-item + (let ((copy (copy-sequence menu-item))) + (setcar (nthcdr 2 copy) newdef) + copy) + (nconc (nreverse skipped) newdef))) + ;; Look past a symbol that names a keymap. + (setq inner-def + (or (indirect-function defn t) defn)) + ;; For nested keymaps, we use `inner-def' rather than `defn' so as to + ;; avoid autoloading a keymap. This is mostly done to preserve the + ;; original non-autoloading behavior of pre-map-keymap times. + (if (and (keymapp inner-def) + ;; Avoid recursively scanning + ;; where KEYMAP does not have a submap. + (let ((elt (lookup-key keymap prefix))) + (or (null elt) (natnump elt) (keymapp elt))) + ;; Avoid recursively rescanning keymap being scanned. + (not (memq inner-def key-substitution-in-progress))) + ;; If this one isn't being scanned already, scan it now. + (substitute-key-definition olddef newdef keymap inner-def prefix))))) + + +;;;; The global keymap tree. + +;; global-map, esc-map, and ctl-x-map have their values set up in +;; keymap.c; we just give them docstrings here. + +(defvar global-map nil + "Default global keymap mapping Emacs keyboard input into commands. +The value is a keymap which is usually (but not necessarily) Emacs's +global map.") + +(defvar esc-map nil + "Default keymap for ESC (meta) commands. +The normal global definition of the character ESC indirects to this keymap.") + +(defvar ctl-x-map nil + "Default keymap for C-x commands. +The normal global definition of the character C-x indirects to this keymap.") + +(defvar ctl-x-4-map (make-sparse-keymap) + "Keymap for subcommands of C-x 4.") +(defalias 'ctl-x-4-prefix ctl-x-4-map) +(define-key ctl-x-map "4" 'ctl-x-4-prefix) + +(defvar ctl-x-5-map (make-sparse-keymap) + "Keymap for frame commands.") +(defalias 'ctl-x-5-prefix ctl-x-5-map) +(define-key ctl-x-map "5" 'ctl-x-5-prefix) + + +;;;; Event manipulation functions. + +(defconst listify-key-sequence-1 (logior 128 ?\M-\C-@)) + +(defun listify-key-sequence (key) + "Convert a key sequence to a list of events." + (if (vectorp key) + (append key nil) + (mapcar (function (lambda (c) + (if (> c 127) + (logxor c listify-key-sequence-1) + c))) + key))) + +(defun eventp (obj) + "True if the argument is an event object." + (when obj + (or (integerp obj) + (and (symbolp obj) obj (not (keywordp obj))) + (and (consp obj) (symbolp (car obj)))))) + +(defun event-modifiers (event) + "Return a list of symbols representing the modifier keys in event EVENT. +The elements of the list may include `meta', `control', +`shift', `hyper', `super', `alt', `click', `double', `triple', `drag', +and `down'. +EVENT may be an event or an event type. If EVENT is a symbol +that has never been used in an event that has been read as input +in the current Emacs session, then this function may fail to include +the `click' modifier." + (let ((type event)) + (if (listp type) + (setq type (car type))) + (if (symbolp type) + ;; Don't read event-symbol-elements directly since we're not + ;; sure the symbol has already been parsed. + (cdr (internal-event-symbol-parse-modifiers type)) + (let ((list nil) + (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@ + ?\H-\^@ ?\s-\^@ ?\A-\^@))))) + (if (not (zerop (logand type ?\M-\^@))) + (push 'meta list)) + (if (or (not (zerop (logand type ?\C-\^@))) + (< char 32)) + (push 'control list)) + (if (or (not (zerop (logand type ?\S-\^@))) + (/= char (downcase char))) + (push 'shift list)) + (or (zerop (logand type ?\H-\^@)) + (push 'hyper list)) + (or (zerop (logand type ?\s-\^@)) + (push 'super list)) + (or (zerop (logand type ?\A-\^@)) + (push 'alt list)) + list)))) + +(defun event-basic-type (event) + "Return the basic type of the given event (all modifiers removed). +The value is a printing character (not upper case) or a symbol. +EVENT may be an event or an event type. If EVENT is a symbol +that has never been used in an event that has been read as input +in the current Emacs session, then this function may return nil." + (if (consp event) + (setq event (car event))) + (if (symbolp event) + (car (get event 'event-symbol-elements)) + (let* ((base (logand event (1- ?\A-\^@))) + (uncontrolled (if (< base 32) (logior base 64) base))) + ;; There are some numbers that are invalid characters and + ;; cause `downcase' to get an error. + (condition-case () + (downcase uncontrolled) + (error uncontrolled))))) + +(defsubst mouse-movement-p (object) + "Return non-nil if OBJECT is a mouse movement event." + (eq (car-safe object) 'mouse-movement)) + +(defun mouse-event-p (object) + "Return non-nil if OBJECT is a mouse click event." + ;; is this really correct? maybe remove mouse-movement? + (memq (event-basic-type object) '(mouse-1 mouse-2 mouse-3 mouse-movement))) + +(defun event-start (event) + "Return the starting position of EVENT. +EVENT should be a mouse click, drag, or key press event. If +EVENT is nil, the value of `posn-at-point' is used instead. + +The following accessor functions are used to access the elements +of the position: + +`posn-window': The window the event is in. +`posn-area': A symbol identifying the area the event occurred in, +or nil if the event occurred in the text area. +`posn-point': The buffer position of the event. +`posn-x-y': The pixel-based coordinates of the event. +`posn-col-row': The estimated column and row corresponding to the +position of the event. +`posn-actual-col-row': The actual column and row corresponding to the +position of the event. +`posn-string': The string object of the event, which is either +nil or (STRING . POSITION)'. +`posn-image': The image object of the event, if any. +`posn-object': The image or string object of the event, if any. +`posn-timestamp': The time the event occurred, in milliseconds. + +For more information, see Info node `(elisp)Click Events'." + (if (consp event) (nth 1 event) + (or (posn-at-point) + (list (selected-window) (point) '(0 . 0) 0)))) + +(defun event-end (event) + "Return the ending position of EVENT. +EVENT should be a click, drag, or key press event. + +See `event-start' for a description of the value returned." + (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event) + (or (posn-at-point) + (list (selected-window) (point) '(0 . 0) 0)))) + +(defsubst event-click-count (event) + "Return the multi-click count of EVENT, a click or drag event. +The return value is a positive integer." + (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1)) + +;;;; Extracting fields of the positions in an event. + +(defun posnp (obj) + "Return non-nil if OBJ appears to be a valid `posn' object specifying a window. +If OBJ is a valid `posn' object, but specifies a frame rather +than a window, return nil." + ;; FIXME: Correct the behavior of this function so that all valid + ;; `posn' objects are recognized, after updating other code that + ;; depends on its present behavior. + (and (windowp (car-safe obj)) + (atom (car-safe (setq obj (cdr obj)))) ;AREA-OR-POS. + (integerp (car-safe (car-safe (setq obj (cdr obj))))) ;XOFFSET. + (integerp (car-safe (cdr obj))))) ;TIMESTAMP. + +(defsubst posn-window (position) + "Return the window in POSITION. +POSITION should be a list of the form returned by the `event-start' +and `event-end' functions." + (nth 0 position)) + +(defsubst posn-area (position) + "Return the window area recorded in POSITION, or nil for the text area. +POSITION should be a list of the form returned by the `event-start' +and `event-end' functions." + (let ((area (if (consp (nth 1 position)) + (car (nth 1 position)) + (nth 1 position)))) + (and (symbolp area) area))) + +(defun posn-point (position) + "Return the buffer location in POSITION. +POSITION should be a list of the form returned by the `event-start' +and `event-end' functions. +Returns nil if POSITION does not correspond to any buffer location (e.g. +a click on a scroll bar)." + (or (nth 5 position) + (let ((pt (nth 1 position))) + (or (car-safe pt) + ;; Apparently this can also be `vertical-scroll-bar' (bug#13979). + (if (integerp pt) pt))))) + +(defun posn-set-point (position) + "Move point to POSITION. +Select the corresponding window as well." + (if (not (windowp (posn-window position))) + (error "Position not in text area of window")) + (select-window (posn-window position)) + (if (numberp (posn-point position)) + (goto-char (posn-point position)))) + +(defsubst posn-x-y (position) + "Return the x and y coordinates in POSITION. +The return value has the form (X . Y), where X and Y are given in +pixels. POSITION should be a list of the form returned by +`event-start' and `event-end'." + (nth 2 position)) + +(declare-function scroll-bar-scale "scroll-bar" (num-denom whole)) + +(defun posn-col-row (position) + "Return the nominal column and row in POSITION, measured in characters. +The column and row values are approximations calculated from the x +and y coordinates in POSITION and the frame's default character width +and default line height, including spacing. +For a scroll-bar event, the result column is 0, and the row +corresponds to the vertical position of the click in the scroll bar. +POSITION should be a list of the form returned by the `event-start' +and `event-end' functions." + (let* ((pair (posn-x-y position)) + (frame-or-window (posn-window position)) + (frame (if (framep frame-or-window) + frame-or-window + (window-frame frame-or-window))) + (window (when (windowp frame-or-window) frame-or-window)) + (area (posn-area position))) + (cond + ((null frame-or-window) + '(0 . 0)) + ((eq area 'vertical-scroll-bar) + (cons 0 (scroll-bar-scale pair (1- (window-height window))))) + ((eq area 'horizontal-scroll-bar) + (cons (scroll-bar-scale pair (window-width window)) 0)) + (t + ;; FIXME: This should take line-spacing properties on + ;; newlines into account. + (let* ((spacing (when (display-graphic-p frame) + (or (with-current-buffer + (window-buffer (frame-selected-window frame)) + line-spacing) + (frame-parameter frame 'line-spacing))))) + (cond ((floatp spacing) + (setq spacing (truncate (* spacing + (frame-char-height frame))))) + ((null spacing) + (setq spacing 0))) + (cons (/ (car pair) (frame-char-width frame)) + (/ (cdr pair) (+ (frame-char-height frame) spacing)))))))) + +(defun posn-actual-col-row (position) + "Return the window row number in POSITION and character number in that row. + +Return nil if POSITION does not contain the actual position; in that case +\`posn-col-row' can be used to get approximate values. +POSITION should be a list of the form returned by the `event-start' +and `event-end' functions. + +This function does not account for the width on display, like the +number of visual columns taken by a TAB or image. If you need +the coordinates of POSITION in character units, you should use +\`posn-col-row', not this function." + (nth 6 position)) + +(defsubst posn-timestamp (position) + "Return the timestamp of POSITION. +POSITION should be a list of the form returned by the `event-start' +and `event-end' functions." + (nth 3 position)) + +(defun posn-string (position) + "Return the string object of POSITION. +Value is a cons (STRING . STRING-POS), or nil if not a string. +POSITION should be a list of the form returned by the `event-start' +and `event-end' functions." + (let ((x (nth 4 position))) + ;; Apparently this can also be `handle' or `below-handle' (bug#13979). + (when (consp x) x))) + +(defsubst posn-image (position) + "Return the image object of POSITION. +Value is a list (image ...), or nil if not an image. +POSITION should be a list of the form returned by the `event-start' +and `event-end' functions." + (nth 7 position)) + +(defsubst posn-object (position) + "Return the object (image or string) of POSITION. +Value is a list (image ...) for an image object, a cons cell +\(STRING . STRING-POS) for a string object, and nil for a buffer position. +POSITION should be a list of the form returned by the `event-start' +and `event-end' functions." + (or (posn-image position) (posn-string position))) + +(defsubst posn-object-x-y (position) + "Return the x and y coordinates relative to the object of POSITION. +The return value has the form (DX . DY), where DX and DY are +given in pixels. POSITION should be a list of the form returned +by `event-start' and `event-end'." + (nth 8 position)) + +(defsubst posn-object-width-height (position) + "Return the pixel width and height of the object of POSITION. +The return value has the form (WIDTH . HEIGHT). POSITION should +be a list of the form returned by `event-start' and `event-end'." + (nth 9 position)) + + +;;;; Obsolescent names for functions. + +(define-obsolete-function-alias 'window-dot 'window-point "22.1") +(define-obsolete-function-alias 'set-window-dot 'set-window-point "22.1") +(define-obsolete-function-alias 'read-input 'read-string "22.1") +(define-obsolete-function-alias 'show-buffer 'set-window-buffer "22.1") +(define-obsolete-function-alias 'eval-current-buffer 'eval-buffer "22.1") +(define-obsolete-function-alias 'string-to-int 'string-to-number "22.1") + +(make-obsolete 'forward-point "use (+ (point) N) instead." "23.1") +(make-obsolete 'buffer-has-markers-at nil "24.3") + +(defun insert-string (&rest args) + "Mocklisp-compatibility insert function. +Like the function `insert' except that any argument that is a number +is converted into a string by expressing it in decimal." + (declare (obsolete insert "22.1")) + (dolist (el args) + (insert (if (integerp el) (number-to-string el) el)))) + +(defun makehash (&optional test) + (declare (obsolete make-hash-table "22.1")) + (make-hash-table :test (or test 'eql))) + +(defun log10 (x) + "Return (log X 10), the log base 10 of X." + (declare (obsolete log "24.4")) + (log x 10)) + +;; These are used by VM and some old programs +(defalias 'focus-frame 'ignore "") +(make-obsolete 'focus-frame "it does nothing." "22.1") +(defalias 'unfocus-frame 'ignore "") +(make-obsolete 'unfocus-frame "it does nothing." "22.1") +(make-obsolete 'make-variable-frame-local + "explicitly check for a frame-parameter instead." "22.2") +(set-advertised-calling-convention + 'all-completions '(string collection &optional predicate) "23.1") +(set-advertised-calling-convention 'unintern '(name obarray) "23.3") +(set-advertised-calling-convention 'indirect-function '(object) "25.1") +(set-advertised-calling-convention 'redirect-frame-focus '(frame focus-frame) "24.3") +(set-advertised-calling-convention 'decode-char '(ch charset) "21.4") +(set-advertised-calling-convention 'encode-char '(ch charset) "21.4") + +;;;; Obsolescence declarations for variables, and aliases. + +;; Special "default-FOO" variables which contain the default value of +;; the "FOO" variable are nasty. Their implementation is brittle, and +;; slows down several unrelated variable operations; furthermore, they +;; can lead to really odd behavior if you decide to make them +;; buffer-local. + +;; Not used at all in Emacs, last time I checked: +(make-obsolete-variable 'default-mode-line-format 'mode-line-format "23.2") +(make-obsolete-variable 'default-header-line-format 'header-line-format "23.2") +(make-obsolete-variable 'default-line-spacing 'line-spacing "23.2") +(make-obsolete-variable 'default-abbrev-mode 'abbrev-mode "23.2") +(make-obsolete-variable 'default-ctl-arrow 'ctl-arrow "23.2") +(make-obsolete-variable 'default-truncate-lines 'truncate-lines "23.2") +(make-obsolete-variable 'default-left-margin 'left-margin "23.2") +(make-obsolete-variable 'default-tab-width 'tab-width "23.2") +(make-obsolete-variable 'default-case-fold-search 'case-fold-search "23.2") +(make-obsolete-variable 'default-left-margin-width 'left-margin-width "23.2") +(make-obsolete-variable 'default-right-margin-width 'right-margin-width "23.2") +(make-obsolete-variable 'default-left-fringe-width 'left-fringe-width "23.2") +(make-obsolete-variable 'default-right-fringe-width 'right-fringe-width "23.2") +(make-obsolete-variable 'default-fringes-outside-margins 'fringes-outside-margins "23.2") +(make-obsolete-variable 'default-scroll-bar-width 'scroll-bar-width "23.2") +(make-obsolete-variable 'default-vertical-scroll-bar 'vertical-scroll-bar "23.2") +(make-obsolete-variable 'default-indicate-empty-lines 'indicate-empty-lines "23.2") +(make-obsolete-variable 'default-indicate-buffer-boundaries 'indicate-buffer-boundaries "23.2") +(make-obsolete-variable 'default-fringe-indicator-alist 'fringe-indicator-alist "23.2") +(make-obsolete-variable 'default-fringe-cursor-alist 'fringe-cursor-alist "23.2") +(make-obsolete-variable 'default-scroll-up-aggressively 'scroll-up-aggressively "23.2") +(make-obsolete-variable 'default-scroll-down-aggressively 'scroll-down-aggressively "23.2") +(make-obsolete-variable 'default-fill-column 'fill-column "23.2") +(make-obsolete-variable 'default-cursor-type 'cursor-type "23.2") +(make-obsolete-variable 'default-cursor-in-non-selected-windows 'cursor-in-non-selected-windows "23.2") +(make-obsolete-variable 'default-buffer-file-coding-system 'buffer-file-coding-system "23.2") +(make-obsolete-variable 'default-major-mode 'major-mode "23.2") +(make-obsolete-variable 'default-enable-multibyte-characters + "use enable-multibyte-characters or set-buffer-multibyte instead" "23.2") + +(make-obsolete-variable 'define-key-rebound-commands nil "23.2") +(make-obsolete-variable 'redisplay-end-trigger-functions 'jit-lock-register "23.1") +(make-obsolete-variable 'deferred-action-list 'post-command-hook "24.1") +(make-obsolete-variable 'deferred-action-function 'post-command-hook "24.1") +(make-obsolete-variable 'redisplay-dont-pause nil "24.5") +(make-obsolete 'window-redisplay-end-trigger nil "23.1") +(make-obsolete 'set-window-redisplay-end-trigger nil "23.1") + +(make-obsolete 'process-filter-multibyte-p nil "23.1") +(make-obsolete 'set-process-filter-multibyte nil "23.1") + +;; Lisp manual only updated in 22.1. +(define-obsolete-variable-alias 'executing-macro 'executing-kbd-macro + "before 19.34") + +(define-obsolete-variable-alias 'x-lost-selection-hooks + 'x-lost-selection-functions "22.1") +(define-obsolete-variable-alias 'x-sent-selection-hooks + 'x-sent-selection-functions "22.1") + +;; This was introduced in 21.4 for pre-unicode unification. That +;; usage was rendered obsolete in 23.1 which uses Unicode internally. +;; Other uses are possible, so this variable is not _really_ obsolete, +;; but Stefan insists to mark it so. +(make-obsolete-variable 'translation-table-for-input nil "23.1") + +(defvaralias 'messages-buffer-max-lines 'message-log-max) + +;;;; Alternate names for functions - these are not being phased out. + +(defalias 'send-string 'process-send-string) +(defalias 'send-region 'process-send-region) +(defalias 'string= 'string-equal) +(defalias 'string< 'string-lessp) +(defalias 'move-marker 'set-marker) +(defalias 'rplaca 'setcar) +(defalias 'rplacd 'setcdr) +(defalias 'beep 'ding) ;preserve lingual purity +(defalias 'indent-to-column 'indent-to) +(defalias 'backward-delete-char 'delete-backward-char) +(defalias 'search-forward-regexp (symbol-function 're-search-forward)) +(defalias 'search-backward-regexp (symbol-function 're-search-backward)) +(defalias 'int-to-string 'number-to-string) +(defalias 'store-match-data 'set-match-data) +(defalias 'chmod 'set-file-modes) +(defalias 'mkdir 'make-directory) +;; These are the XEmacs names: +(defalias 'point-at-eol 'line-end-position) +(defalias 'point-at-bol 'line-beginning-position) + +(defalias 'user-original-login-name 'user-login-name) + + +;;;; Hook manipulation functions. + +(defun add-hook (hook function &optional append local) + "Add to the value of HOOK the function FUNCTION. +FUNCTION is not added if already present. +FUNCTION is added (if necessary) at the beginning of the hook list +unless the optional argument APPEND is non-nil, in which case +FUNCTION is added at the end. + +The optional fourth argument, LOCAL, if non-nil, says to modify +the hook's buffer-local value rather than its global value. +This makes the hook buffer-local, and it makes t a member of the +buffer-local value. That acts as a flag to run the hook +functions of the global value as well as in the local value. + +HOOK should be a symbol, and FUNCTION may be any valid function. If +HOOK is void, it is first set to nil. If HOOK's value is a single +function, it is changed to a list of functions." + (or (boundp hook) (set hook nil)) + (or (default-boundp hook) (set-default hook nil)) + (if local (unless (local-variable-if-set-p hook) + (set (make-local-variable hook) (list t))) + ;; Detect the case where make-local-variable was used on a hook + ;; and do what we used to do. + (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook))) + (setq local t))) + (let ((hook-value (if local (symbol-value hook) (default-value hook)))) + ;; If the hook value is a single function, turn it into a list. + (when (or (not (listp hook-value)) (functionp hook-value)) + (setq hook-value (list hook-value))) + ;; Do the actual addition if necessary + (unless (member function hook-value) + (when (stringp function) + (setq function (purecopy function))) + (setq hook-value + (if append + (append hook-value (list function)) + (cons function hook-value)))) + ;; Set the actual variable + (if local + (progn + ;; If HOOK isn't a permanent local, + ;; but FUNCTION wants to survive a change of modes, + ;; mark HOOK as partially permanent. + (and (symbolp function) + (get function 'permanent-local-hook) + (not (get hook 'permanent-local)) + (put hook 'permanent-local 'permanent-local-hook)) + (set hook hook-value)) + (set-default hook hook-value)))) + +(defun remove-hook (hook function &optional local) + "Remove from the value of HOOK the function FUNCTION. +HOOK should be a symbol, and FUNCTION may be any valid function. If +FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the +list of hooks to run in HOOK, then nothing is done. See `add-hook'. + +The optional third argument, LOCAL, if non-nil, says to modify +the hook's buffer-local value rather than its default value." + (or (boundp hook) (set hook nil)) + (or (default-boundp hook) (set-default hook nil)) + ;; Do nothing if LOCAL is t but this hook has no local binding. + (unless (and local (not (local-variable-p hook))) + ;; Detect the case where make-local-variable was used on a hook + ;; and do what we used to do. + (when (and (local-variable-p hook) + (not (and (consp (symbol-value hook)) + (memq t (symbol-value hook))))) + (setq local t)) + (let ((hook-value (if local (symbol-value hook) (default-value hook)))) + ;; Remove the function, for both the list and the non-list cases. + (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda)) + (if (equal hook-value function) (setq hook-value nil)) + (setq hook-value (delete function (copy-sequence hook-value)))) + ;; If the function is on the global hook, we need to shadow it locally + ;;(when (and local (member function (default-value hook)) + ;; (not (member (cons 'not function) hook-value))) + ;; (push (cons 'not function) hook-value)) + ;; Set the actual variable + (if (not local) + (set-default hook hook-value) + (if (equal hook-value '(t)) + (kill-local-variable hook) + (set hook hook-value)))))) + +(defmacro letrec (binders &rest body) + "Bind variables according to BINDERS then eval BODY. +The value of the last form in BODY is returned. +Each element of BINDERS is a list (SYMBOL VALUEFORM) which binds +SYMBOL to the value of VALUEFORM. +All symbols are bound before the VALUEFORMs are evalled." + ;; Only useful in lexical-binding mode. + ;; As a special-form, we could implement it more efficiently (and cleanly, + ;; making the vars actually unbound during evaluation of the binders). + (declare (debug let) (indent 1)) + `(let ,(mapcar #'car binders) + ,@(mapcar (lambda (binder) `(setq ,@binder)) binders) + ,@body)) + +(defmacro with-wrapper-hook (hook args &rest body) + "Run BODY, using wrapper functions from HOOK with additional ARGS. +HOOK is an abnormal hook. Each hook function in HOOK \"wraps\" +around the preceding ones, like a set of nested `around' advices. + +Each hook function should accept an argument list consisting of a +function FUN, followed by the additional arguments in ARGS. + +The first hook function in HOOK is passed a FUN that, if it is called +with arguments ARGS, performs BODY (i.e., the default operation). +The FUN passed to each successive hook function is defined based +on the preceding hook functions; if called with arguments ARGS, +it does what the `with-wrapper-hook' call would do if the +preceding hook functions were the only ones present in HOOK. + +Each hook function may call its FUN argument as many times as it wishes, +including never. In that case, such a hook function acts to replace +the default definition altogether, and any preceding hook functions. +Of course, a subsequent hook function may do the same thing. + +Each hook function definition is used to construct the FUN passed +to the next hook function, if any. The last (or \"outermost\") +FUN is then called once." + (declare (indent 2) (debug (form sexp body)) + (obsolete "use a <foo>-function variable modified by `add-function'." + "24.4")) + ;; We need those two gensyms because CL's lexical scoping is not available + ;; for function arguments :-( + (let ((funs (make-symbol "funs")) + (global (make-symbol "global")) + (argssym (make-symbol "args")) + (runrestofhook (make-symbol "runrestofhook"))) + ;; Since the hook is a wrapper, the loop has to be done via + ;; recursion: a given hook function will call its parameter in order to + ;; continue looping. + `(letrec ((,runrestofhook + (lambda (,funs ,global ,argssym) + ;; `funs' holds the functions left on the hook and `global' + ;; holds the functions left on the global part of the hook + ;; (in case the hook is local). + (if (consp ,funs) + (if (eq t (car ,funs)) + (funcall ,runrestofhook + (append ,global (cdr ,funs)) nil ,argssym) + (apply (car ,funs) + (apply-partially + (lambda (,funs ,global &rest ,argssym) + (funcall ,runrestofhook ,funs ,global ,argssym)) + (cdr ,funs) ,global) + ,argssym)) + ;; Once there are no more functions on the hook, run + ;; the original body. + (apply (lambda ,args ,@body) ,argssym))))) + (funcall ,runrestofhook ,hook + ;; The global part of the hook, if any. + ,(if (symbolp hook) + `(if (local-variable-p ',hook) + (default-value ',hook))) + (list ,@args))))) + +(defun add-to-list (list-var element &optional append compare-fn) + "Add ELEMENT to the value of LIST-VAR if it isn't there yet. +The test for presence of ELEMENT is done with `equal', or with +COMPARE-FN if that's non-nil. +If ELEMENT is added, it is added at the beginning of the list, +unless the optional argument APPEND is non-nil, in which case +ELEMENT is added at the end. + +The return value is the new value of LIST-VAR. + +This is handy to add some elements to configuration variables, +but please do not abuse it in Elisp code, where you are usually +better off using `push' or `cl-pushnew'. + +If you want to use `add-to-list' on a variable that is not +defined until a certain package is loaded, you should put the +call to `add-to-list' into a hook function that will be run only +after loading the package. `eval-after-load' provides one way to +do this. In some cases other hooks, such as major mode hooks, +can do the job." + (declare + (compiler-macro + (lambda (exp) + ;; FIXME: Something like this could be used for `set' as well. + (if (or (not (eq 'quote (car-safe list-var))) + (special-variable-p (cadr list-var)) + (not (macroexp-const-p append))) + exp + (let* ((sym (cadr list-var)) + (append (eval append)) + (msg (format "`add-to-list' can't use lexical var `%s'; use `push' or `cl-pushnew'" + sym)) + ;; Big ugly hack so we only output a warning during + ;; byte-compilation, and so we can use + ;; byte-compile-not-lexical-var-p to silence the warning + ;; when a defvar has been seen but not yet executed. + (warnfun (lambda () + ;; FIXME: We should also emit a warning for let-bound + ;; variables with dynamic binding. + (when (assq sym byte-compile--lexical-environment) + (byte-compile-log-warning msg t :error)))) + (code + (macroexp-let2 macroexp-copyable-p x element + `(if ,(if compare-fn + (progn + (require 'cl-lib) + `(cl-member ,x ,sym :test ,compare-fn)) + ;; For bootstrapping reasons, don't rely on + ;; cl--compiler-macro-member for the base case. + `(member ,x ,sym)) + ,sym + ,(if append + `(setq ,sym (append ,sym (list ,x))) + `(push ,x ,sym)))))) + (if (not (macroexp--compiling-p)) + code + `(progn + (macroexp--funcall-if-compiled ',warnfun) + ,code))))))) + (if (cond + ((null compare-fn) + (member element (symbol-value list-var))) + ((eq compare-fn 'eq) + (memq element (symbol-value list-var))) + ((eq compare-fn 'eql) + (memql element (symbol-value list-var))) + (t + (let ((lst (symbol-value list-var))) + (while (and lst + (not (funcall compare-fn element (car lst)))) + (setq lst (cdr lst))) + lst))) + (symbol-value list-var) + (set list-var + (if append + (append (symbol-value list-var) (list element)) + (cons element (symbol-value list-var)))))) + + +(defun add-to-ordered-list (list-var element &optional order) + "Add ELEMENT to the value of LIST-VAR if it isn't there yet. +The test for presence of ELEMENT is done with `eq'. + +The resulting list is reordered so that the elements are in the +order given by each element's numeric list order. Elements +without a numeric list order are placed at the end of the list. + +If the third optional argument ORDER is a number (integer or +float), set the element's list order to the given value. If +ORDER is nil or omitted, do not change the numeric order of +ELEMENT. If ORDER has any other value, remove the numeric order +of ELEMENT if it has one. + +The list order for each element is stored in LIST-VAR's +`list-order' property. + +The return value is the new value of LIST-VAR." + (let ((ordering (get list-var 'list-order))) + (unless ordering + (put list-var 'list-order + (setq ordering (make-hash-table :weakness 'key :test 'eq)))) + (when order + (puthash element (and (numberp order) order) ordering)) + (unless (memq element (symbol-value list-var)) + (set list-var (cons element (symbol-value list-var)))) + (set list-var (sort (symbol-value list-var) + (lambda (a b) + (let ((oa (gethash a ordering)) + (ob (gethash b ordering))) + (if (and oa ob) + (< oa ob) + oa))))))) + +(defun add-to-history (history-var newelt &optional maxelt keep-all) + "Add NEWELT to the history list stored in the variable HISTORY-VAR. +Return the new history list. +If MAXELT is non-nil, it specifies the maximum length of the history. +Otherwise, the maximum history length is the value of the `history-length' +property on symbol HISTORY-VAR, if set, or the value of the `history-length' +variable. +Remove duplicates of NEWELT if `history-delete-duplicates' is non-nil. +If optional fourth arg KEEP-ALL is non-nil, add NEWELT to history even +if it is empty or a duplicate." + (unless maxelt + (setq maxelt (or (get history-var 'history-length) + history-length))) + (let ((history (symbol-value history-var)) + tail) + (when (and (listp history) + (or keep-all + (not (stringp newelt)) + (> (length newelt) 0)) + (or keep-all + (not (equal (car history) newelt)))) + (if history-delete-duplicates + (setq history (delete newelt history))) + (setq history (cons newelt history)) + (when (integerp maxelt) + (if (= 0 maxelt) + (setq history nil) + (setq tail (nthcdr (1- maxelt) history)) + (when (consp tail) + (setcdr tail nil))))) + (set history-var history))) + + +;;;; Mode hooks. + +(defvar delay-mode-hooks nil + "If non-nil, `run-mode-hooks' should delay running the hooks.") +(defvar delayed-mode-hooks nil + "List of delayed mode hooks waiting to be run.") +(make-variable-buffer-local 'delayed-mode-hooks) +(put 'delay-mode-hooks 'permanent-local t) + +(defvar change-major-mode-after-body-hook nil + "Normal hook run in major mode functions, before the mode hooks.") + +(defvar after-change-major-mode-hook nil + "Normal hook run at the very end of major mode functions.") + +(defun run-mode-hooks (&rest hooks) + "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS. +If the variable `delay-mode-hooks' is non-nil, does not run any hooks, +just adds the HOOKS to the list `delayed-mode-hooks'. +Otherwise, runs hooks in the sequence: `change-major-mode-after-body-hook', +`delayed-mode-hooks' (in reverse order), HOOKS, and finally +`after-change-major-mode-hook'. Major mode functions should use +this instead of `run-hooks' when running their FOO-mode-hook." + (if delay-mode-hooks + ;; Delaying case. + (dolist (hook hooks) + (push hook delayed-mode-hooks)) + ;; Normal case, just run the hook as before plus any delayed hooks. + (setq hooks (nconc (nreverse delayed-mode-hooks) hooks)) + (setq delayed-mode-hooks nil) + (apply 'run-hooks (cons 'change-major-mode-after-body-hook hooks)) + (run-hooks 'after-change-major-mode-hook))) + +(defmacro delay-mode-hooks (&rest body) + "Execute BODY, but delay any `run-mode-hooks'. +These hooks will be executed by the first following call to +`run-mode-hooks' that occurs outside any `delayed-mode-hooks' form. +Only affects hooks run in the current buffer." + (declare (debug t) (indent 0)) + `(progn + (make-local-variable 'delay-mode-hooks) + (let ((delay-mode-hooks t)) + ,@body))) + +;; PUBLIC: find if the current mode derives from another. + +(defun derived-mode-p (&rest modes) + "Non-nil if the current major mode is derived from one of MODES. +Uses the `derived-mode-parent' property of the symbol to trace backwards." + (let ((parent major-mode)) + (while (and (not (memq parent modes)) + (setq parent (get parent 'derived-mode-parent)))) + parent)) + +;;;; Minor modes. + +;; If a minor mode is not defined with define-minor-mode, +;; add it here explicitly. +;; isearch-mode is deliberately excluded, since you should +;; not call it yourself. +(defvar minor-mode-list '(auto-save-mode auto-fill-mode abbrev-mode + overwrite-mode view-mode + hs-minor-mode) + "List of all minor mode functions.") + +(defun add-minor-mode (toggle name &optional keymap after toggle-fun) + "Register a new minor mode. + +This is an XEmacs-compatibility function. Use `define-minor-mode' instead. + +TOGGLE is a symbol which is the name of a buffer-local variable that +is toggled on or off to say whether the minor mode is active or not. + +NAME specifies what will appear in the mode line when the minor mode +is active. NAME should be either a string starting with a space, or a +symbol whose value is such a string. + +Optional KEYMAP is the keymap for the minor mode that will be added +to `minor-mode-map-alist'. + +Optional AFTER specifies that TOGGLE should be added after AFTER +in `minor-mode-alist'. + +Optional TOGGLE-FUN is an interactive function to toggle the mode. +It defaults to (and should by convention be) TOGGLE. + +If TOGGLE has a non-nil `:included' property, an entry for the mode is +included in the mode-line minor mode menu. +If TOGGLE has a `:menu-tag', that is used for the menu item's label." + (unless (memq toggle minor-mode-list) + (push toggle minor-mode-list)) + + (unless toggle-fun (setq toggle-fun toggle)) + (unless (eq toggle-fun toggle) + (put toggle :minor-mode-function toggle-fun)) + ;; Add the name to the minor-mode-alist. + (when name + (let ((existing (assq toggle minor-mode-alist))) + (if existing + (setcdr existing (list name)) + (let ((tail minor-mode-alist) found) + (while (and tail (not found)) + (if (eq after (caar tail)) + (setq found tail) + (setq tail (cdr tail)))) + (if found + (let ((rest (cdr found))) + (setcdr found nil) + (nconc found (list (list toggle name)) rest)) + (push (list toggle name) minor-mode-alist)))))) + ;; Add the toggle to the minor-modes menu if requested. + (when (get toggle :included) + (define-key mode-line-mode-menu + (vector toggle) + (list 'menu-item + (concat + (or (get toggle :menu-tag) + (if (stringp name) name (symbol-name toggle))) + (let ((mode-name (if (symbolp name) (symbol-value name)))) + (if (and (stringp mode-name) (string-match "[^ ]+" mode-name)) + (concat " (" (match-string 0 mode-name) ")")))) + toggle-fun + :button (cons :toggle toggle)))) + + ;; Add the map to the minor-mode-map-alist. + (when keymap + (let ((existing (assq toggle minor-mode-map-alist))) + (if existing + (setcdr existing keymap) + (let ((tail minor-mode-map-alist) found) + (while (and tail (not found)) + (if (eq after (caar tail)) + (setq found tail) + (setq tail (cdr tail)))) + (if found + (let ((rest (cdr found))) + (setcdr found nil) + (nconc found (list (cons toggle keymap)) rest)) + (push (cons toggle keymap) minor-mode-map-alist))))))) + +;;;; Load history + +(defsubst autoloadp (object) + "Non-nil if OBJECT is an autoload." + (eq 'autoload (car-safe object))) + +;; (defun autoload-type (object) +;; "Returns the type of OBJECT or `function' or `command' if the type is nil. +;; OBJECT should be an autoload object." +;; (when (autoloadp object) +;; (let ((type (nth 3 object))) +;; (cond ((null type) (if (nth 2 object) 'command 'function)) +;; ((eq 'keymap t) 'macro) +;; (type))))) + +;; (defalias 'autoload-file #'cadr +;; "Return the name of the file from which AUTOLOAD will be loaded. +;; \n\(fn AUTOLOAD)") + +(defun symbol-file (symbol &optional type) + "Return the name of the file that defined SYMBOL. +The value is normally an absolute file name. It can also be nil, +if the definition is not associated with any file. If SYMBOL +specifies an autoloaded function, the value can be a relative +file name without extension. + +If TYPE is nil, then any kind of definition is acceptable. If +TYPE is `defun', `defvar', or `defface', that specifies function +definition, variable definition, or face definition only." + (if (and (or (null type) (eq type 'defun)) + (symbolp symbol) + (autoloadp (symbol-function symbol))) + (nth 1 (symbol-function symbol)) + (let ((files load-history) + file) + (while files + (if (if type + (if (eq type 'defvar) + ;; Variables are present just as their names. + (member symbol (cdr (car files))) + ;; Other types are represented as (TYPE . NAME). + (member (cons type symbol) (cdr (car files)))) + ;; We accept all types, so look for variable def + ;; and then for any other kind. + (or (member symbol (cdr (car files))) + (rassq symbol (cdr (car files))))) + (setq file (car (car files)) files nil)) + (setq files (cdr files))) + file))) + +(defun locate-library (library &optional nosuffix path interactive-call) + "Show the precise file name of Emacs library LIBRARY. +LIBRARY should be a relative file name of the library, a string. +It can omit the suffix (a.k.a. file-name extension) if NOSUFFIX is +nil (which is the default, see below). +This command searches the directories in `load-path' like `\\[load-library]' +to find the file that `\\[load-library] RET LIBRARY RET' would load. +Optional second arg NOSUFFIX non-nil means don't add suffixes `load-suffixes' +to the specified name LIBRARY. + +If the optional third arg PATH is specified, that list of directories +is used instead of `load-path'. + +When called from a program, the file name is normally returned as a +string. When run interactively, the argument INTERACTIVE-CALL is t, +and the file name is displayed in the echo area." + (interactive (list (completing-read "Locate library: " + (apply-partially + 'locate-file-completion-table + load-path (get-load-suffixes))) + nil nil + t)) + (let ((file (locate-file library + (or path load-path) + (append (unless nosuffix (get-load-suffixes)) + load-file-rep-suffixes)))) + (if interactive-call + (if file + (message "Library is file %s" (abbreviate-file-name file)) + (message "No library %s in search path" library))) + file)) + + +;;;; Process stuff. + +(defun process-lines (program &rest args) + "Execute PROGRAM with ARGS, returning its output as a list of lines. +Signal an error if the program returns with a non-zero exit status." + (with-temp-buffer + (let ((status (apply 'call-process program nil (current-buffer) nil args))) + (unless (eq status 0) + (error "%s exited with status %s" program status)) + (goto-char (point-min)) + (let (lines) + (while (not (eobp)) + (setq lines (cons (buffer-substring-no-properties + (line-beginning-position) + (line-end-position)) + lines)) + (forward-line 1)) + (nreverse lines))))) + +(defun process-live-p (process) + "Returns non-nil if PROCESS is alive. +A process is considered alive if its status is `run', `open', +`listen', `connect' or `stop'. Value is nil if PROCESS is not a +process." + (and (processp process) + (memq (process-status process) + '(run open listen connect stop)))) + +;; compatibility + +(make-obsolete + 'process-kill-without-query + "use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'." + "22.1") +(defun process-kill-without-query (process &optional _flag) + "Say no query needed if PROCESS is running when Emacs is exited. +Optional second argument if non-nil says to require a query. +Value is t if a query was formerly required." + (let ((old (process-query-on-exit-flag process))) + (set-process-query-on-exit-flag process nil) + old)) + +(defun process-kill-buffer-query-function () + "Ask before killing a buffer that has a running process." + (let ((process (get-buffer-process (current-buffer)))) + (or (not process) + (not (memq (process-status process) '(run stop open listen))) + (not (process-query-on-exit-flag process)) + (yes-or-no-p + (format "Buffer %S has a running process; kill it? " + (buffer-name (current-buffer))))))) + +(add-hook 'kill-buffer-query-functions 'process-kill-buffer-query-function) + +;; process plist management + +(defun process-get (process propname) + "Return the value of PROCESS' PROPNAME property. +This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'." + (plist-get (process-plist process) propname)) + +(defun process-put (process propname value) + "Change PROCESS' PROPNAME property to VALUE. +It can be retrieved with `(process-get PROCESS PROPNAME)'." + (set-process-plist process + (plist-put (process-plist process) propname value))) + + +;;;; Input and display facilities. + +(defconst read-key-empty-map (make-sparse-keymap)) + +(defvar read-key-delay 0.01) ;Fast enough for 100Hz repeat rate, hopefully. + +(defun read-key (&optional prompt) + "Read a key from the keyboard. +Contrary to `read-event' this will not return a raw event but instead will +obey the input decoding and translations usually done by `read-key-sequence'. +So escape sequences and keyboard encoding are taken into account. +When there's an ambiguity because the key looks like the prefix of +some sort of escape sequence, the ambiguity is resolved via `read-key-delay'." + ;; This overriding-terminal-local-map binding also happens to + ;; disable quail's input methods, so although read-key-sequence + ;; always inherits the input method, in practice read-key does not + ;; inherit the input method (at least not if it's based on quail). + (let ((overriding-terminal-local-map nil) + (overriding-local-map read-key-empty-map) + (echo-keystrokes 0) + (old-global-map (current-global-map)) + (timer (run-with-idle-timer + ;; Wait long enough that Emacs has the time to receive and + ;; process all the raw events associated with the single-key. + ;; But don't wait too long, or the user may find the delay + ;; annoying (or keep hitting more keys which may then get + ;; lost or misinterpreted). + ;; This is only relevant for keys which Emacs perceives as + ;; "prefixes", such as C-x (because of the C-x 8 map in + ;; key-translate-table and the C-x @ map in function-key-map) + ;; or ESC (because of terminal escape sequences in + ;; input-decode-map). + read-key-delay t + (lambda () + (let ((keys (this-command-keys-vector))) + (unless (zerop (length keys)) + ;; `keys' is non-empty, so the user has hit at least + ;; one key; there's no point waiting any longer, even + ;; though read-key-sequence thinks we should wait + ;; for more input to decide how to interpret the + ;; current input. + (throw 'read-key keys))))))) + (unwind-protect + (progn + (use-global-map + (let ((map (make-sparse-keymap))) + ;; Don't hide the menu-bar and tool-bar entries. + (define-key map [menu-bar] (lookup-key global-map [menu-bar])) + (define-key map [tool-bar] + ;; This hack avoids evaluating the :filter (Bug#9922). + (or (cdr (assq 'tool-bar global-map)) + (lookup-key global-map [tool-bar]))) + map)) + (let* ((keys + (catch 'read-key (read-key-sequence-vector prompt nil t))) + (key (aref keys 0))) + (if (and (> (length keys) 1) + (memq key '(mode-line header-line + left-fringe right-fringe))) + (aref keys 1) + key))) + (cancel-timer timer) + (use-global-map old-global-map)))) + +(defvar read-passwd-map + ;; BEWARE: `defconst' would purecopy it, breaking the sharing with + ;; minibuffer-local-map along the way! + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map "\C-u" #'delete-minibuffer-contents) ;bug#12570 + map) + "Keymap used while reading passwords.") + +(defun read-passwd (prompt &optional confirm default) + "Read a password, prompting with PROMPT, and return it. +If optional CONFIRM is non-nil, read the password twice to make sure. +Optional DEFAULT is a default password to use instead of empty input. + +This function echoes `.' for each character that the user types. +You could let-bind `read-hide-char' to another hiding character, though. + +Once the caller uses the password, it can erase the password +by doing (clear-string STRING)." + (if confirm + (let (success) + (while (not success) + (let ((first (read-passwd prompt nil default)) + (second (read-passwd "Confirm password: " nil default))) + (if (equal first second) + (progn + (and (arrayp second) (clear-string second)) + (setq success first)) + (and (arrayp first) (clear-string first)) + (and (arrayp second) (clear-string second)) + (message "Password not repeated accurately; please start over") + (sit-for 1)))) + success) + (let ((hide-chars-fun + (lambda (beg end _len) + (clear-this-command-keys) + (setq beg (min end (max (minibuffer-prompt-end) + beg))) + (dotimes (i (- end beg)) + (put-text-property (+ i beg) (+ 1 i beg) + 'display (string (or read-hide-char ?.)))))) + minibuf) + (minibuffer-with-setup-hook + (lambda () + (setq minibuf (current-buffer)) + ;; Turn off electricity. + (setq-local post-self-insert-hook nil) + (setq-local buffer-undo-list t) + (setq-local select-active-regions nil) + (use-local-map read-passwd-map) + (setq-local inhibit-modification-hooks nil) ;bug#15501. + (setq-local show-paren-mode nil) ;bug#16091. + (add-hook 'after-change-functions hide-chars-fun nil 'local)) + (unwind-protect + (let ((enable-recursive-minibuffers t) + (read-hide-char (or read-hide-char ?.))) + (read-string prompt nil t default)) ; t = "no history" + (when (buffer-live-p minibuf) + (with-current-buffer minibuf + ;; Not sure why but it seems that there might be cases where the + ;; minibuffer is not always properly reset later on, so undo + ;; whatever we've done here (bug#11392). + (remove-hook 'after-change-functions hide-chars-fun 'local) + (kill-local-variable 'post-self-insert-hook) + ;; And of course, don't keep the sensitive data around. + (erase-buffer)))))))) + +(defun read-number (prompt &optional default) + "Read a numeric value in the minibuffer, prompting with PROMPT. +DEFAULT specifies a default value to return if the user just types RET. +The value of DEFAULT is inserted into PROMPT. +This function is used by the `interactive' code letter `n'." + (let ((n nil) + (default1 (if (consp default) (car default) default))) + (when default1 + (setq prompt + (if (string-match "\\(\\):[ \t]*\\'" prompt) + (replace-match (format " (default %s)" default1) t t prompt 1) + (replace-regexp-in-string "[ \t]*\\'" + (format " (default %s) " default1) + prompt t t)))) + (while + (progn + (let ((str (read-from-minibuffer + prompt nil nil nil nil + (when default + (if (consp default) + (mapcar 'number-to-string (delq nil default)) + (number-to-string default)))))) + (condition-case nil + (setq n (cond + ((zerop (length str)) default1) + ((stringp str) (read str)))) + (error nil))) + (unless (numberp n) + (message "Please enter a number.") + (sit-for 1) + t))) + n)) + +(defun read-char-choice (prompt chars &optional inhibit-keyboard-quit) + "Read and return one of CHARS, prompting for PROMPT. +Any input that is not one of CHARS is ignored. + +If optional argument INHIBIT-KEYBOARD-QUIT is non-nil, ignore +keyboard-quit events while waiting for a valid input." + (unless (consp chars) + (error "Called `read-char-choice' without valid char choices")) + (let (char done show-help (helpbuf " *Char Help*")) + (let ((cursor-in-echo-area t) + (executing-kbd-macro executing-kbd-macro) + (esc-flag nil)) + (save-window-excursion ; in case we call help-form-show + (while (not done) + (unless (get-text-property 0 'face prompt) + (setq prompt (propertize prompt 'face 'minibuffer-prompt))) + (setq char (let ((inhibit-quit inhibit-keyboard-quit)) + (read-key prompt))) + (and show-help (buffer-live-p (get-buffer helpbuf)) + (kill-buffer helpbuf)) + (cond + ((not (numberp char))) + ;; If caller has set help-form, that's enough. + ;; They don't explicitly have to add help-char to chars. + ((and help-form + (eq char help-char) + (setq show-help t) + (help-form-show))) + ((memq char chars) + (setq done t)) + ((and executing-kbd-macro (= char -1)) + ;; read-event returns -1 if we are in a kbd macro and + ;; there are no more events in the macro. Attempt to + ;; get an event interactively. + (setq executing-kbd-macro nil)) + ((not inhibit-keyboard-quit) + (cond + ((and (null esc-flag) (eq char ?\e)) + (setq esc-flag t)) + ((memq char '(?\C-g ?\e)) + (keyboard-quit)))))))) + ;; Display the question with the answer. But without cursor-in-echo-area. + (message "%s%s" prompt (char-to-string char)) + char)) + +(defun sit-for (seconds &optional nodisp obsolete) + "Redisplay, then wait for SECONDS seconds. Stop when input is available. +SECONDS may be a floating-point value. +\(On operating systems that do not support waiting for fractions of a +second, floating-point values are rounded down to the nearest integer.) + +If optional arg NODISP is t, don't redisplay, just wait for input. +Redisplay does not happen if input is available before it starts. + +Value is t if waited the full time with no input arriving, and nil otherwise. + +An obsolete, but still supported form is +\(sit-for SECONDS &optional MILLISECONDS NODISP) +where the optional arg MILLISECONDS specifies an additional wait period, +in milliseconds; this was useful when Emacs was built without +floating point support." + (declare (advertised-calling-convention (seconds &optional nodisp) "22.1")) + ;; This used to be implemented in C until the following discussion: + ;; http://lists.gnu.org/archive/html/emacs-devel/2006-07/msg00401.html + ;; Then it was moved here using an implementation based on an idle timer, + ;; which was then replaced by the use of read-event. + (if (numberp nodisp) + (setq seconds (+ seconds (* 1e-3 nodisp)) + nodisp obsolete) + (if obsolete (setq nodisp obsolete))) + (cond + (noninteractive + (sleep-for seconds) + t) + ((input-pending-p t) + nil) + ((<= seconds 0) + (or nodisp (redisplay))) + (t + (or nodisp (redisplay)) + ;; FIXME: we should not read-event here at all, because it's much too + ;; difficult to reliably "undo" a read-event by pushing it onto + ;; unread-command-events. + ;; For bug#14782, we need read-event to do the keyboard-coding-system + ;; decoding (hence non-nil as second arg under POSIX ttys). + ;; For bug#15614, we need read-event not to inherit-input-method. + ;; So we temporarily suspend input-method-function. + (let ((read (let ((input-method-function nil)) + (read-event nil t seconds)))) + (or (null read) + (progn + ;; https://lists.gnu.org/archive/html/emacs-devel/2006-10/msg00394.html + ;; We want `read' appear in the next command's this-command-event + ;; but not in the current one. + ;; By pushing (cons t read), we indicate that `read' has not + ;; yet been recorded in this-command-keys, so it will be recorded + ;; next time it's read. + ;; And indeed the `seconds' argument to read-event correctly + ;; prevented recording this event in the current command's + ;; this-command-keys. + (push (cons t read) unread-command-events) + nil)))))) + +;; Behind display-popup-menus-p test. +(declare-function x-popup-dialog "menu.c" (position contents &optional header)) + +(defun y-or-n-p (prompt) + "Ask user a \"y or n\" question. Return t if answer is \"y\". +PROMPT is the string to display to ask the question. It should +end in a space; `y-or-n-p' adds \"(y or n) \" to it. + +No confirmation of the answer is requested; a single character is +enough. SPC also means yes, and DEL means no. + +To be precise, this function translates user input into responses +by consulting the bindings in `query-replace-map'; see the +documentation of that variable for more information. In this +case, the useful bindings are `act', `skip', `recenter', +`scroll-up', `scroll-down', and `quit'. +An `act' response means yes, and a `skip' response means no. +A `quit' response means to invoke `keyboard-quit'. +If the user enters `recenter', `scroll-up', or `scroll-down' +responses, perform the requested window recentering or scrolling +and ask again. + +Under a windowing system a dialog box will be used if `last-nonmenu-event' +is nil and `use-dialog-box' is non-nil." + ;; ¡Beware! when I tried to edebug this code, Emacs got into a weird state + ;; where all the keys were unbound (i.e. it somehow got triggered + ;; within read-key, apparently). I had to kill it. + (let ((answer 'recenter) + (padded (lambda (prompt &optional dialog) + (let ((l (length prompt))) + (concat prompt + (if (or (zerop l) (eq ?\s (aref prompt (1- l)))) + "" " ") + (if dialog "" "(y or n) ")))))) + (cond + (noninteractive + (setq prompt (funcall padded prompt)) + (let ((temp-prompt prompt)) + (while (not (memq answer '(act skip))) + (let ((str (read-string temp-prompt))) + (cond ((member str '("y" "Y")) (setq answer 'act)) + ((member str '("n" "N")) (setq answer 'skip)) + (t (setq temp-prompt (concat "Please answer y or n. " + prompt)))))))) + ((and (display-popup-menus-p) + (listp last-nonmenu-event) + use-dialog-box) + (setq prompt (funcall padded prompt t) + answer (x-popup-dialog t `(,prompt ("Yes" . act) ("No" . skip))))) + (t + (setq prompt (funcall padded prompt)) + (while + (let* ((scroll-actions '(recenter scroll-up scroll-down + scroll-other-window scroll-other-window-down)) + (key + (let ((cursor-in-echo-area t)) + (when minibuffer-auto-raise + (raise-frame (window-frame (minibuffer-window)))) + (read-key (propertize (if (memq answer scroll-actions) + prompt + (concat "Please answer y or n. " + prompt)) + 'face 'minibuffer-prompt))))) + (setq answer (lookup-key query-replace-map (vector key) t)) + (cond + ((memq answer '(skip act)) nil) + ((eq answer 'recenter) + (recenter) t) + ((eq answer 'scroll-up) + (ignore-errors (scroll-up-command)) t) + ((eq answer 'scroll-down) + (ignore-errors (scroll-down-command)) t) + ((eq answer 'scroll-other-window) + (ignore-errors (scroll-other-window)) t) + ((eq answer 'scroll-other-window-down) + (ignore-errors (scroll-other-window-down)) t) + ((or (memq answer '(exit-prefix quit)) (eq key ?\e)) + (signal 'quit nil) t) + (t t))) + (ding) + (discard-input)))) + (let ((ret (eq answer 'act))) + (unless noninteractive + (message "%s%c" prompt (if ret ?y ?n))) + ret))) + + +;;; Atomic change groups. + +(defmacro atomic-change-group (&rest body) + "Perform BODY as an atomic change group. +This means that if BODY exits abnormally, +all of its changes to the current buffer are undone. +This works regardless of whether undo is enabled in the buffer. + +This mechanism is transparent to ordinary use of undo; +if undo is enabled in the buffer and BODY succeeds, the +user can undo the change normally." + (declare (indent 0) (debug t)) + (let ((handle (make-symbol "--change-group-handle--")) + (success (make-symbol "--change-group-success--"))) + `(let ((,handle (prepare-change-group)) + ;; Don't truncate any undo data in the middle of this. + (undo-outer-limit nil) + (undo-limit most-positive-fixnum) + (undo-strong-limit most-positive-fixnum) + (,success nil)) + (unwind-protect + (progn + ;; This is inside the unwind-protect because + ;; it enables undo if that was disabled; we need + ;; to make sure that it gets disabled again. + (activate-change-group ,handle) + ,@body + (setq ,success t)) + ;; Either of these functions will disable undo + ;; if it was disabled before. + (if ,success + (accept-change-group ,handle) + (cancel-change-group ,handle)))))) + +(defun prepare-change-group (&optional buffer) + "Return a handle for the current buffer's state, for a change group. +If you specify BUFFER, make a handle for BUFFER's state instead. + +Pass the handle to `activate-change-group' afterward to initiate +the actual changes of the change group. + +To finish the change group, call either `accept-change-group' or +`cancel-change-group' passing the same handle as argument. Call +`accept-change-group' to accept the changes in the group as final; +call `cancel-change-group' to undo them all. You should use +`unwind-protect' to make sure the group is always finished. The call +to `activate-change-group' should be inside the `unwind-protect'. +Once you finish the group, don't use the handle again--don't try to +finish the same group twice. For a simple example of correct use, see +the source code of `atomic-change-group'. + +The handle records only the specified buffer. To make a multibuffer +change group, call this function once for each buffer you want to +cover, then use `nconc' to combine the returned values, like this: + + (nconc (prepare-change-group buffer-1) + (prepare-change-group buffer-2)) + +You can then activate that multibuffer change group with a single +call to `activate-change-group' and finish it with a single call +to `accept-change-group' or `cancel-change-group'." + + (if buffer + (list (cons buffer (with-current-buffer buffer buffer-undo-list))) + (list (cons (current-buffer) buffer-undo-list)))) + +(defun activate-change-group (handle) + "Activate a change group made with `prepare-change-group' (which see)." + (dolist (elt handle) + (with-current-buffer (car elt) + (if (eq buffer-undo-list t) + (setq buffer-undo-list nil))))) + +(defun accept-change-group (handle) + "Finish a change group made with `prepare-change-group' (which see). +This finishes the change group by accepting its changes as final." + (dolist (elt handle) + (with-current-buffer (car elt) + (if (eq (cdr elt) t) + (setq buffer-undo-list t))))) + +(defun cancel-change-group (handle) + "Finish a change group made with `prepare-change-group' (which see). +This finishes the change group by reverting all of its changes." + (dolist (elt handle) + (with-current-buffer (car elt) + (setq elt (cdr elt)) + (save-restriction + ;; Widen buffer temporarily so if the buffer was narrowed within + ;; the body of `atomic-change-group' all changes can be undone. + (widen) + (let ((old-car + (if (consp elt) (car elt))) + (old-cdr + (if (consp elt) (cdr elt)))) + ;; Temporarily truncate the undo log at ELT. + (when (consp elt) + (setcar elt nil) (setcdr elt nil)) + (unless (eq last-command 'undo) (undo-start)) + ;; Make sure there's no confusion. + (when (and (consp elt) (not (eq elt (last pending-undo-list)))) + (error "Undoing to some unrelated state")) + ;; Undo it all. + (save-excursion + (while (listp pending-undo-list) (undo-more 1))) + ;; Reset the modified cons cell ELT to its original content. + (when (consp elt) + (setcar elt old-car) + (setcdr elt old-cdr)) + ;; Revert the undo info to what it was when we grabbed the state. + (setq buffer-undo-list elt)))))) + +;;;; Display-related functions. + +;; For compatibility. +(define-obsolete-function-alias 'redraw-modeline + 'force-mode-line-update "24.3") + +(defun momentary-string-display (string pos &optional exit-char message) + "Momentarily display STRING in the buffer at POS. +Display remains until next event is input. +If POS is a marker, only its position is used; its buffer is ignored. +Optional third arg EXIT-CHAR can be a character, event or event +description list. EXIT-CHAR defaults to SPC. If the input is +EXIT-CHAR it is swallowed; otherwise it is then available as +input (as a command if nothing else). +Display MESSAGE (optional fourth arg) in the echo area. +If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there." + (or exit-char (setq exit-char ?\s)) + (let ((ol (make-overlay pos pos)) + (str (copy-sequence string))) + (unwind-protect + (progn + (save-excursion + (overlay-put ol 'after-string str) + (goto-char pos) + ;; To avoid trouble with out-of-bounds position + (setq pos (point)) + ;; If the string end is off screen, recenter now. + (if (<= (window-end nil t) pos) + (recenter (/ (window-height) 2)))) + (message (or message "Type %s to continue editing.") + (single-key-description exit-char)) + (let ((event (read-key))) + ;; `exit-char' can be an event, or an event description list. + (or (eq event exit-char) + (eq event (event-convert-list exit-char)) + (setq unread-command-events + (append (this-single-command-raw-keys)))))) + (delete-overlay ol)))) + + +;;;; Overlay operations + +(defun copy-overlay (o) + "Return a copy of overlay O." + (let ((o1 (if (overlay-buffer o) + (make-overlay (overlay-start o) (overlay-end o) + ;; FIXME: there's no easy way to find the + ;; insertion-type of the two markers. + (overlay-buffer o)) + (let ((o1 (make-overlay (point-min) (point-min)))) + (delete-overlay o1) + o1))) + (props (overlay-properties o))) + (while props + (overlay-put o1 (pop props) (pop props))) + o1)) + +(defun remove-overlays (&optional beg end name val) + "Clear BEG and END of overlays whose property NAME has value VAL. +Overlays might be moved and/or split. +BEG and END default respectively to the beginning and end of buffer." + ;; This speeds up the loops over overlays. + (unless beg (setq beg (point-min))) + (unless end (setq end (point-max))) + (overlay-recenter end) + (if (< end beg) + (setq beg (prog1 end (setq end beg)))) + (save-excursion + (dolist (o (overlays-in beg end)) + (when (eq (overlay-get o name) val) + ;; Either push this overlay outside beg...end + ;; or split it to exclude beg...end + ;; or delete it entirely (if it is contained in beg...end). + (if (< (overlay-start o) beg) + (if (> (overlay-end o) end) + (progn + (move-overlay (copy-overlay o) + (overlay-start o) beg) + (move-overlay o end (overlay-end o))) + (move-overlay o (overlay-start o) beg)) + (if (> (overlay-end o) end) + (move-overlay o end (overlay-end o)) + (delete-overlay o))))))) + +;;;; Miscellanea. + +(defvar suspend-hook nil + "Normal hook run by `suspend-emacs', before suspending.") + +(defvar suspend-resume-hook nil + "Normal hook run by `suspend-emacs', after Emacs is continued.") + +(defvar temp-buffer-show-hook nil + "Normal hook run by `with-output-to-temp-buffer' after displaying the buffer. +When the hook runs, the temporary buffer is current, and the window it +was displayed in is selected.") + +(defvar temp-buffer-setup-hook nil + "Normal hook run by `with-output-to-temp-buffer' at the start. +When the hook runs, the temporary buffer is current. +This hook is normally set up with a function to put the buffer in Help +mode.") + +(defconst user-emacs-directory + (if (eq system-type 'ms-dos) + ;; MS-DOS cannot have initial dot. + "~/_emacs.d/" + "~/.emacs.d/") + "Directory beneath which additional per-user Emacs-specific files are placed. +Various programs in Emacs store information in this directory. +Note that this should end with a directory separator. +See also `locate-user-emacs-file'.") + +;;;; Misc. useful functions. + +(defsubst buffer-narrowed-p () + "Return non-nil if the current buffer is narrowed." + (/= (- (point-max) (point-min)) (buffer-size))) + +(defun find-tag-default-bounds () + "Determine the boundaries of the default tag, based on text at point. +Return a cons cell with the beginning and end of the found tag. +If there is no plausible default, return nil." + (let (from to bound) + (when (or (progn + ;; Look at text around `point'. + (save-excursion + (skip-syntax-backward "w_") (setq from (point))) + (save-excursion + (skip-syntax-forward "w_") (setq to (point))) + (> to from)) + ;; Look between `line-beginning-position' and `point'. + (save-excursion + (and (setq bound (line-beginning-position)) + (skip-syntax-backward "^w_" bound) + (> (setq to (point)) bound) + (skip-syntax-backward "w_") + (setq from (point)))) + ;; Look between `point' and `line-end-position'. + (save-excursion + (and (setq bound (line-end-position)) + (skip-syntax-forward "^w_" bound) + (< (setq from (point)) bound) + (skip-syntax-forward "w_") + (setq to (point))))) + (cons from to)))) + +(defun find-tag-default () + "Determine default tag to search for, based on text at point. +If there is no plausible default, return nil." + (let ((bounds (find-tag-default-bounds))) + (when bounds + (buffer-substring-no-properties (car bounds) (cdr bounds))))) + +(defun find-tag-default-as-regexp () + "Return regexp that matches the default tag at point. +If there is no tag at point, return nil. + +When in a major mode that does not provide its own +`find-tag-default-function', return a regexp that matches the +symbol at point exactly." + (let ((tag (funcall (or find-tag-default-function + (get major-mode 'find-tag-default-function) + 'find-tag-default)))) + (if tag (regexp-quote tag)))) + +(defun find-tag-default-as-symbol-regexp () + "Return regexp that matches the default tag at point as symbol. +If there is no tag at point, return nil. + +When in a major mode that does not provide its own +`find-tag-default-function', return a regexp that matches the +symbol at point exactly." + (let ((tag-regexp (find-tag-default-as-regexp))) + (if (and tag-regexp + (eq (or find-tag-default-function + (get major-mode 'find-tag-default-function) + 'find-tag-default) + 'find-tag-default)) + (format "\\_<%s\\_>" tag-regexp) + tag-regexp))) + +(defun play-sound (sound) + "SOUND is a list of the form `(sound KEYWORD VALUE...)'. +The following keywords are recognized: + + :file FILE - read sound data from FILE. If FILE isn't an +absolute file name, it is searched in `data-directory'. + + :data DATA - read sound data from string DATA. + +Exactly one of :file or :data must be present. + + :volume VOL - set volume to VOL. VOL must an integer in the +range 0..100 or a float in the range 0..1.0. If not specified, +don't change the volume setting of the sound device. + + :device DEVICE - play sound on DEVICE. If not specified, +a system-dependent default device name is used. + +Note: :data and :device are currently not supported on Windows." + (if (fboundp 'play-sound-internal) + (play-sound-internal sound) + (error "This Emacs binary lacks sound support"))) + +(declare-function w32-shell-dos-semantics "w32-fns" nil) + +(defun shell-quote-argument (argument) + "Quote ARGUMENT for passing as argument to an inferior shell." + (cond + ((eq system-type 'ms-dos) + ;; Quote using double quotes, but escape any existing quotes in + ;; the argument with backslashes. + (let ((result "") + (start 0) + end) + (if (or (null (string-match "[^\"]" argument)) + (< (match-end 0) (length argument))) + (while (string-match "[\"]" argument start) + (setq end (match-beginning 0) + result (concat result (substring argument start end) + "\\" (substring argument end (1+ end))) + start (1+ end)))) + (concat "\"" result (substring argument start) "\""))) + + ((and (eq system-type 'windows-nt) (w32-shell-dos-semantics)) + + ;; First, quote argument so that CommandLineToArgvW will + ;; understand it. See + ;; http://msdn.microsoft.com/en-us/library/17w5ykft%28v=vs.85%29.aspx + ;; After we perform that level of quoting, escape shell + ;; metacharacters so that cmd won't mangle our argument. If the + ;; argument contains no double quote characters, we can just + ;; surround it with double quotes. Otherwise, we need to prefix + ;; each shell metacharacter with a caret. + + (setq argument + ;; escape backslashes at end of string + (replace-regexp-in-string + "\\(\\\\*\\)$" + "\\1\\1" + ;; escape backslashes and quotes in string body + (replace-regexp-in-string + "\\(\\\\*\\)\"" + "\\1\\1\\\\\"" + argument))) + + (if (string-match "[%!\"]" argument) + (concat + "^\"" + (replace-regexp-in-string + "\\([%!()\"<>&|^]\\)" + "^\\1" + argument) + "^\"") + (concat "\"" argument "\""))) + + (t + (if (equal argument "") + "''" + ;; Quote everything except POSIX filename characters. + ;; This should be safe enough even for really weird shells. + (replace-regexp-in-string + "\n" "'\n'" + (replace-regexp-in-string "[^-0-9a-zA-Z_./\n]" "\\\\\\&" argument)))) + )) + +(defun string-or-null-p (object) + "Return t if OBJECT is a string or nil. +Otherwise, return nil." + (or (stringp object) (null object))) + +(defun booleanp (object) + "Return t if OBJECT is one of the two canonical boolean values: t or nil. +Otherwise, return nil." + (and (memq object '(nil t)) t)) + +(defun special-form-p (object) + "Non-nil if and only if OBJECT is a special form." + (if (and (symbolp object) (fboundp object)) + (setq object (indirect-function object t))) + (and (subrp object) (eq (cdr (subr-arity object)) 'unevalled))) + +(defun macrop (object) + "Non-nil if and only if OBJECT is a macro." + (let ((def (indirect-function object t))) + (when (consp def) + (or (eq 'macro (car def)) + (and (autoloadp def) (memq (nth 4 def) '(macro t))))))) + +(defun field-at-pos (pos) + "Return the field at position POS, taking stickiness etc into account." + (let ((raw-field (get-char-property (field-beginning pos) 'field))) + (if (eq raw-field 'boundary) + (get-char-property (1- (field-end pos)) 'field) + raw-field))) + +(defun sha1 (object &optional start end binary) + "Return the SHA1 (Secure Hash Algorithm) of an OBJECT. +OBJECT is either a string or a buffer. Optional arguments START and +END are character positions specifying which portion of OBJECT for +computing the hash. If BINARY is non-nil, return a string in binary +form." + (secure-hash 'sha1 object start end binary)) + +(defun function-get (f prop &optional autoload) + "Return the value of property PROP of function F. +If AUTOLOAD is non-nil and F is autoloaded, try to autoload it +in the hope that it will set PROP. If AUTOLOAD is `macro', only do it +if it's an autoloaded macro." + (let ((val nil)) + (while (and (symbolp f) + (null (setq val (get f prop))) + (fboundp f)) + (let ((fundef (symbol-function f))) + (if (and autoload (autoloadp fundef) + (not (equal fundef + (autoload-do-load fundef f + (if (eq autoload 'macro) + 'macro))))) + nil ;Re-try `get' on the same `f'. + (setq f fundef)))) + val)) + +;;;; Support for yanking and text properties. +;; Why here in subr.el rather than in simple.el? --Stef + +(defvar yank-handled-properties) +(defvar yank-excluded-properties) + +(defun remove-yank-excluded-properties (start end) + "Process text properties between START and END, inserted for a `yank'. +Perform the handling specified by `yank-handled-properties', then +remove properties specified by `yank-excluded-properties'." + (let ((inhibit-read-only t)) + (dolist (handler yank-handled-properties) + (let ((prop (car handler)) + (fun (cdr handler)) + (run-start start)) + (while (< run-start end) + (let ((value (get-text-property run-start prop)) + (run-end (next-single-property-change + run-start prop nil end))) + (funcall fun value run-start run-end) + (setq run-start run-end))))) + (if (eq yank-excluded-properties t) + (set-text-properties start end nil) + (remove-list-of-text-properties start end yank-excluded-properties)))) + +(defvar yank-undo-function) + +(defun insert-for-yank (string) + "Call `insert-for-yank-1' repetitively for each `yank-handler' segment. + +See `insert-for-yank-1' for more details." + (let (to) + (while (setq to (next-single-property-change 0 'yank-handler string)) + (insert-for-yank-1 (substring string 0 to)) + (setq string (substring string to)))) + (insert-for-yank-1 string)) + +(defun insert-for-yank-1 (string) + "Insert STRING at point for the `yank' command. +This function is like `insert', except it honors the variables +`yank-handled-properties' and `yank-excluded-properties', and the +`yank-handler' text property. + +Properties listed in `yank-handled-properties' are processed, +then those listed in `yank-excluded-properties' are discarded. + +If STRING has a non-nil `yank-handler' property on its first +character, the normal insert behavior is altered. The value of +the `yank-handler' property must be a list of one to four +elements, of the form (FUNCTION PARAM NOEXCLUDE UNDO). +FUNCTION, if non-nil, should be a function of one argument, an + object to insert; it is called instead of `insert'. +PARAM, if present and non-nil, replaces STRING as the argument to + FUNCTION or `insert'; e.g. if FUNCTION is `yank-rectangle', PARAM + may be a list of strings to insert as a rectangle. +If NOEXCLUDE is present and non-nil, the normal removal of + `yank-excluded-properties' is not performed; instead FUNCTION is + responsible for the removal. This may be necessary if FUNCTION + adjusts point before or after inserting the object. +UNDO, if present and non-nil, should be a function to be called + by `yank-pop' to undo the insertion of the current object. It is + given two arguments, the start and end of the region. FUNCTION + may set `yank-undo-function' to override UNDO." + (let* ((handler (and (stringp string) + (get-text-property 0 'yank-handler string))) + (param (or (nth 1 handler) string)) + (opoint (point)) + (inhibit-read-only inhibit-read-only) + end) + + (setq yank-undo-function t) + (if (nth 0 handler) ; FUNCTION + (funcall (car handler) param) + (insert param)) + (setq end (point)) + + ;; Prevent read-only properties from interfering with the + ;; following text property changes. + (setq inhibit-read-only t) + + (unless (nth 2 handler) ; NOEXCLUDE + (remove-yank-excluded-properties opoint end)) + + ;; If last inserted char has properties, mark them as rear-nonsticky. + (if (and (> end opoint) + (text-properties-at (1- end))) + (put-text-property (1- end) end 'rear-nonsticky t)) + + (if (eq yank-undo-function t) ; not set by FUNCTION + (setq yank-undo-function (nth 3 handler))) ; UNDO + (if (nth 4 handler) ; COMMAND + (setq this-command (nth 4 handler))))) + +(defun insert-buffer-substring-no-properties (buffer &optional start end) + "Insert before point a substring of BUFFER, without text properties. +BUFFER may be a buffer or a buffer name. +Arguments START and END are character positions specifying the substring. +They default to the values of (point-min) and (point-max) in BUFFER." + (let ((opoint (point))) + (insert-buffer-substring buffer start end) + (let ((inhibit-read-only t)) + (set-text-properties opoint (point) nil)))) + +(defun insert-buffer-substring-as-yank (buffer &optional start end) + "Insert before point a part of BUFFER, stripping some text properties. +BUFFER may be a buffer or a buffer name. +Arguments START and END are character positions specifying the substring. +They default to the values of (point-min) and (point-max) in BUFFER. +Before insertion, process text properties according to +`yank-handled-properties' and `yank-excluded-properties'." + ;; Since the buffer text should not normally have yank-handler properties, + ;; there is no need to handle them here. + (let ((opoint (point))) + (insert-buffer-substring buffer start end) + (remove-yank-excluded-properties opoint (point)))) + +(defun yank-handle-font-lock-face-property (face start end) + "If `font-lock-defaults' is nil, apply FACE as a `face' property. +START and END denote the start and end of the text to act on. +Do nothing if FACE is nil." + (and face + (null font-lock-defaults) + (put-text-property start end 'face face))) + +;; This removes `mouse-face' properties in *Help* buffer buttons: +;; http://lists.gnu.org/archive/html/emacs-devel/2002-04/msg00648.html +(defun yank-handle-category-property (category start end) + "Apply property category CATEGORY's properties between START and END." + (when category + (let ((start2 start)) + (while (< start2 end) + (let ((end2 (next-property-change start2 nil end)) + (original (text-properties-at start2))) + (set-text-properties start2 end2 (symbol-plist category)) + (add-text-properties start2 end2 original) + (setq start2 end2)))))) + + +;;;; Synchronous shell commands. + +(defun start-process-shell-command (name buffer &rest args) + "Start a program in a subprocess. Return the process object for it. +NAME is name for process. It is modified if necessary to make it unique. +BUFFER is the buffer (or buffer name) to associate with the process. + Process output goes at end of that buffer, unless you specify + an output stream or filter function to handle the output. + BUFFER may be also nil, meaning that this process is not associated + with any buffer +COMMAND is the shell command to run. + +An old calling convention accepted any number of arguments after COMMAND, +which were just concatenated to COMMAND. This is still supported but strongly +discouraged." + (declare (advertised-calling-convention (name buffer command) "23.1")) + ;; We used to use `exec' to replace the shell with the command, + ;; but that failed to handle (...) and semicolon, etc. + (start-process name buffer shell-file-name shell-command-switch + (mapconcat 'identity args " "))) + +(defun start-file-process-shell-command (name buffer &rest args) + "Start a program in a subprocess. Return the process object for it. +Similar to `start-process-shell-command', but calls `start-file-process'." + (declare (advertised-calling-convention (name buffer command) "23.1")) + (start-file-process + name buffer + (if (file-remote-p default-directory) "/bin/sh" shell-file-name) + (if (file-remote-p default-directory) "-c" shell-command-switch) + (mapconcat 'identity args " "))) + +(defun call-process-shell-command (command &optional infile buffer display + &rest args) + "Execute the shell command COMMAND synchronously in separate process. +The remaining arguments are optional. +The program's input comes from file INFILE (nil means `/dev/null'). +Insert output in BUFFER before point; t means current buffer; + nil for BUFFER means discard it; 0 means discard and don't wait. +BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case, +REAL-BUFFER says what to do with standard output, as above, +while STDERR-FILE says what to do with standard error in the child. +STDERR-FILE may be nil (discard standard error output), +t (mix it with ordinary output), or a file name string. + +Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted. +Wildcards and redirection are handled as usual in the shell. + +If BUFFER is 0, `call-process-shell-command' returns immediately with value nil. +Otherwise it waits for COMMAND to terminate and returns a numeric exit +status or a signal description string. +If you quit, the process is killed with SIGINT, or SIGKILL if you quit again. + +An old calling convention accepted any number of arguments after DISPLAY, +which were just concatenated to COMMAND. This is still supported but strongly +discouraged." + (declare (advertised-calling-convention + (command &optional infile buffer display) "24.5")) + ;; We used to use `exec' to replace the shell with the command, + ;; but that failed to handle (...) and semicolon, etc. + (call-process shell-file-name + infile buffer display + shell-command-switch + (mapconcat 'identity (cons command args) " "))) + +(defun process-file-shell-command (command &optional infile buffer display + &rest args) + "Process files synchronously in a separate process. +Similar to `call-process-shell-command', but calls `process-file'." + (declare (advertised-calling-convention + (command &optional infile buffer display) "24.5")) + (process-file + (if (file-remote-p default-directory) "/bin/sh" shell-file-name) + infile buffer display + (if (file-remote-p default-directory) "-c" shell-command-switch) + (mapconcat 'identity (cons command args) " "))) + +;;;; Lisp macros to do various things temporarily. + +(defmacro track-mouse (&rest body) + "Evaluate BODY with mouse movement events enabled. +Within a `track-mouse' form, mouse motion generates input events that + you can read with `read-event'. +Normally, mouse motion is ignored." + (declare (debug t) (indent 0)) + `(internal--track-mouse (lambda () ,@body))) + +(defmacro with-current-buffer (buffer-or-name &rest body) + "Execute the forms in BODY with BUFFER-OR-NAME temporarily current. +BUFFER-OR-NAME must be a buffer or the name of an existing buffer. +The value returned is the value of the last form in BODY. See +also `with-temp-buffer'." + (declare (indent 1) (debug t)) + `(save-current-buffer + (set-buffer ,buffer-or-name) + ,@body)) + +(defun internal--before-with-selected-window (window) + (let ((other-frame (window-frame window))) + (list window (selected-window) + ;; Selecting a window on another frame also changes that + ;; frame's frame-selected-window. We must save&restore it. + (unless (eq (selected-frame) other-frame) + (frame-selected-window other-frame)) + ;; Also remember the top-frame if on ttys. + (unless (eq (selected-frame) other-frame) + (tty-top-frame other-frame))))) + +(defun internal--after-with-selected-window (state) + ;; First reset frame-selected-window. + (when (window-live-p (nth 2 state)) + ;; We don't use set-frame-selected-window because it does not + ;; pass the `norecord' argument to Fselect_window. + (select-window (nth 2 state) 'norecord) + (and (frame-live-p (nth 3 state)) + (not (eq (tty-top-frame) (nth 3 state))) + (select-frame (nth 3 state) 'norecord))) + ;; Then reset the actual selected-window. + (when (window-live-p (nth 1 state)) + (select-window (nth 1 state) 'norecord))) + +(defmacro with-selected-window (window &rest body) + "Execute the forms in BODY with WINDOW as the selected window. +The value returned is the value of the last form in BODY. + +This macro saves and restores the selected window, as well as the +selected window of each frame. It does not change the order of +recently selected windows. If the previously selected window of +some frame is no longer live at the end of BODY, that frame's +selected window is left alone. If the selected window is no +longer live, then whatever window is selected at the end of BODY +remains selected. + +This macro uses `save-current-buffer' to save and restore the +current buffer, since otherwise its normal operation could +potentially make a different buffer current. It does not alter +the buffer list ordering." + (declare (indent 1) (debug t)) + `(let ((save-selected-window--state + (internal--before-with-selected-window ,window))) + (save-current-buffer + (unwind-protect + (progn (select-window (car save-selected-window--state) 'norecord) + ,@body) + (internal--after-with-selected-window save-selected-window--state))))) + +(defmacro with-selected-frame (frame &rest body) + "Execute the forms in BODY with FRAME as the selected frame. +The value returned is the value of the last form in BODY. + +This macro saves and restores the selected frame, and changes the +order of neither the recently selected windows nor the buffers in +the buffer list." + (declare (indent 1) (debug t)) + (let ((old-frame (make-symbol "old-frame")) + (old-buffer (make-symbol "old-buffer"))) + `(let ((,old-frame (selected-frame)) + (,old-buffer (current-buffer))) + (unwind-protect + (progn (select-frame ,frame 'norecord) + ,@body) + (when (frame-live-p ,old-frame) + (select-frame ,old-frame 'norecord)) + (when (buffer-live-p ,old-buffer) + (set-buffer ,old-buffer)))))) + +(defmacro save-window-excursion (&rest body) + "Execute BODY, then restore previous window configuration. +This macro saves the window configuration on the selected frame, +executes BODY, then calls `set-window-configuration' to restore +the saved window configuration. The return value is the last +form in BODY. The window configuration is also restored if BODY +exits nonlocally. + +BEWARE: Most uses of this macro introduce bugs. +E.g. it should not be used to try and prevent some code from opening +a new window, since that window may sometimes appear in another frame, +in which case `save-window-excursion' cannot help." + (declare (indent 0) (debug t)) + (let ((c (make-symbol "wconfig"))) + `(let ((,c (current-window-configuration))) + (unwind-protect (progn ,@body) + (set-window-configuration ,c))))) + +(defun internal-temp-output-buffer-show (buffer) + "Internal function for `with-output-to-temp-buffer'." + (with-current-buffer buffer + (set-buffer-modified-p nil) + (goto-char (point-min))) + + (if temp-buffer-show-function + (funcall temp-buffer-show-function buffer) + (with-current-buffer buffer + (let* ((window + (let ((window-combination-limit + ;; When `window-combination-limit' equals + ;; `temp-buffer' or `temp-buffer-resize' and + ;; `temp-buffer-resize-mode' is enabled in this + ;; buffer bind it to t so resizing steals space + ;; preferably from the window that was split. + (if (or (eq window-combination-limit 'temp-buffer) + (and (eq window-combination-limit + 'temp-buffer-resize) + temp-buffer-resize-mode)) + t + window-combination-limit))) + (display-buffer buffer))) + (frame (and window (window-frame window)))) + (when window + (unless (eq frame (selected-frame)) + (make-frame-visible frame)) + (setq minibuffer-scroll-window window) + (set-window-hscroll window 0) + ;; Don't try this with NOFORCE non-nil! + (set-window-start window (point-min) t) + ;; This should not be necessary. + (set-window-point window (point-min)) + ;; Run `temp-buffer-show-hook', with the chosen window selected. + (with-selected-window window + (run-hooks 'temp-buffer-show-hook)))))) + ;; Return nil. + nil) + +;; Doc is very similar to with-temp-buffer-window. +(defmacro with-output-to-temp-buffer (bufname &rest body) + "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer. + +This construct makes buffer BUFNAME empty before running BODY. +It does not make the buffer current for BODY. +Instead it binds `standard-output' to that buffer, so that output +generated with `prin1' and similar functions in BODY goes into +the buffer. + +At the end of BODY, this marks buffer BUFNAME unmodified and displays +it in a window, but does not select it. The normal way to do this is +by calling `display-buffer', then running `temp-buffer-show-hook'. +However, if `temp-buffer-show-function' is non-nil, it calls that +function instead (and does not run `temp-buffer-show-hook'). The +function gets one argument, the buffer to display. + +The return value of `with-output-to-temp-buffer' is the value of the +last form in BODY. If BODY does not finish normally, the buffer +BUFNAME is not displayed. + +This runs the hook `temp-buffer-setup-hook' before BODY, +with the buffer BUFNAME temporarily current. It runs the hook +`temp-buffer-show-hook' after displaying buffer BUFNAME, with that +buffer temporarily current, and the window that was used to display it +temporarily selected. But it doesn't run `temp-buffer-show-hook' +if it uses `temp-buffer-show-function'. + +By default, the setup hook puts the buffer into Help mode before running BODY. +If BODY does not change the major mode, the show hook makes the buffer +read-only, and scans it for function and variable names to make them into +clickable cross-references. + +See the related form `with-temp-buffer-window'." + (declare (debug t)) + (let ((old-dir (make-symbol "old-dir")) + (buf (make-symbol "buf"))) + `(let* ((,old-dir default-directory) + (,buf + (with-current-buffer (get-buffer-create ,bufname) + (prog1 (current-buffer) + (kill-all-local-variables) + ;; FIXME: delete_all_overlays + (setq default-directory ,old-dir) + (setq buffer-read-only nil) + (setq buffer-file-name nil) + (setq buffer-undo-list t) + (let ((inhibit-read-only t) + (inhibit-modification-hooks t)) + (erase-buffer) + (run-hooks 'temp-buffer-setup-hook))))) + (standard-output ,buf)) + (prog1 (progn ,@body) + (internal-temp-output-buffer-show ,buf))))) + +(defmacro with-temp-file (file &rest body) + "Create a new buffer, evaluate BODY there, and write the buffer to FILE. +The value returned is the value of the last form in BODY. +See also `with-temp-buffer'." + (declare (indent 1) (debug t)) + (let ((temp-file (make-symbol "temp-file")) + (temp-buffer (make-symbol "temp-buffer"))) + `(let ((,temp-file ,file) + (,temp-buffer + (get-buffer-create (generate-new-buffer-name " *temp file*")))) + (unwind-protect + (prog1 + (with-current-buffer ,temp-buffer + ,@body) + (with-current-buffer ,temp-buffer + (write-region nil nil ,temp-file nil 0))) + (and (buffer-name ,temp-buffer) + (kill-buffer ,temp-buffer)))))) + +(defmacro with-temp-message (message &rest body) + "Display MESSAGE temporarily if non-nil while BODY is evaluated. +The original message is restored to the echo area after BODY has finished. +The value returned is the value of the last form in BODY. +MESSAGE is written to the message log buffer if `message-log-max' is non-nil. +If MESSAGE is nil, the echo area and message log buffer are unchanged. +Use a MESSAGE of \"\" to temporarily clear the echo area." + (declare (debug t) (indent 1)) + (let ((current-message (make-symbol "current-message")) + (temp-message (make-symbol "with-temp-message"))) + `(let ((,temp-message ,message) + (,current-message)) + (unwind-protect + (progn + (when ,temp-message + (setq ,current-message (current-message)) + (message "%s" ,temp-message)) + ,@body) + (and ,temp-message + (if ,current-message + (message "%s" ,current-message) + (message nil))))))) + +(defmacro with-temp-buffer (&rest body) + "Create a temporary buffer, and evaluate BODY there like `progn'. +See also `with-temp-file' and `with-output-to-string'." + (declare (indent 0) (debug t)) + (let ((temp-buffer (make-symbol "temp-buffer"))) + `(let ((,temp-buffer (generate-new-buffer " *temp*"))) + ;; FIXME: kill-buffer can change current-buffer in some odd cases. + (with-current-buffer ,temp-buffer + (unwind-protect + (progn ,@body) + (and (buffer-name ,temp-buffer) + (kill-buffer ,temp-buffer))))))) + +(defmacro with-silent-modifications (&rest body) + "Execute BODY, pretending it does not modify the buffer. +If BODY performs real modifications to the buffer's text, other +than cosmetic ones, undo data may become corrupted. + +This macro will run BODY normally, but doesn't count its buffer +modifications as being buffer modifications. This affects things +like `buffer-modified-p', checking whether the file is locked by +someone else, running buffer modification hooks, and other things +of that nature. + +Typically used around modifications of text-properties which do +not really affect the buffer's content." + (declare (debug t) (indent 0)) + (let ((modified (make-symbol "modified"))) + `(let* ((,modified (buffer-modified-p)) + (buffer-undo-list t) + (inhibit-read-only t) + (inhibit-modification-hooks t)) + (unwind-protect + (progn + ,@body) + (unless ,modified + (restore-buffer-modified-p nil)))))) + +(defmacro with-output-to-string (&rest body) + "Execute BODY, return the text it sent to `standard-output', as a string." + (declare (indent 0) (debug t)) + `(let ((standard-output + (get-buffer-create (generate-new-buffer-name " *string-output*")))) + (unwind-protect + (progn + (let ((standard-output standard-output)) + ,@body) + (with-current-buffer standard-output + (buffer-string))) + (kill-buffer standard-output)))) + +(defmacro with-local-quit (&rest body) + "Execute BODY, allowing quits to terminate BODY but not escape further. +When a quit terminates BODY, `with-local-quit' returns nil but +requests another quit. That quit will be processed as soon as quitting +is allowed once again. (Immediately, if `inhibit-quit' is nil.)" + (declare (debug t) (indent 0)) + `(condition-case nil + (let ((inhibit-quit nil)) + ,@body) + (quit (setq quit-flag t) + ;; This call is to give a chance to handle quit-flag + ;; in case inhibit-quit is nil. + ;; Without this, it will not be handled until the next function + ;; call, and that might allow it to exit thru a condition-case + ;; that intends to handle the quit signal next time. + (eval '(ignore nil))))) + +(defmacro while-no-input (&rest body) + "Execute BODY only as long as there's no pending input. +If input arrives, that ends the execution of BODY, +and `while-no-input' returns t. Quitting makes it return nil. +If BODY finishes, `while-no-input' returns whatever value BODY produced." + (declare (debug t) (indent 0)) + (let ((catch-sym (make-symbol "input"))) + `(with-local-quit + (catch ',catch-sym + (let ((throw-on-input ',catch-sym)) + (or (input-pending-p) + (progn ,@body))))))) + +(defmacro condition-case-unless-debug (var bodyform &rest handlers) + "Like `condition-case' except that it does not prevent debugging. +More specifically if `debug-on-error' is set then the debugger will be invoked +even if this catches the signal." + (declare (debug condition-case) (indent 2)) + `(condition-case ,var + ,bodyform + ,@(mapcar (lambda (handler) + `((debug ,@(if (listp (car handler)) (car handler) + (list (car handler)))) + ,@(cdr handler))) + handlers))) + +(define-obsolete-function-alias 'condition-case-no-debug + 'condition-case-unless-debug "24.1") + +(defmacro with-demoted-errors (format &rest body) + "Run BODY and demote any errors to simple messages. +FORMAT is a string passed to `message' to format any error message. +It should contain a single %-sequence; e.g., \"Error: %S\". + +If `debug-on-error' is non-nil, run BODY without catching its errors. +This is to be used around code which is not expected to signal an error +but which should be robust in the unexpected case that an error is signaled. + +For backward compatibility, if FORMAT is not a constant string, it +is assumed to be part of BODY, in which case the message format +used is \"Error: %S\"." + (declare (debug t) (indent 1)) + (let ((err (make-symbol "err")) + (format (if (and (stringp format) body) format + (prog1 "Error: %S" + (if format (push format body)))))) + `(condition-case-unless-debug ,err + ,(macroexp-progn body) + (error (message ,format ,err) nil)))) + +(defmacro combine-after-change-calls (&rest body) + "Execute BODY, but don't call the after-change functions till the end. +If BODY makes changes in the buffer, they are recorded +and the functions on `after-change-functions' are called several times +when BODY is finished. +The return value is the value of the last form in BODY. + +If `before-change-functions' is non-nil, then calls to the after-change +functions can't be deferred, so in that case this macro has no effect. + +Do not alter `after-change-functions' or `before-change-functions' +in BODY." + (declare (indent 0) (debug t)) + `(unwind-protect + (let ((combine-after-change-calls t)) + . ,body) + (combine-after-change-execute))) + +(defmacro with-case-table (table &rest body) + "Execute the forms in BODY with TABLE as the current case table. +The value returned is the value of the last form in BODY." + (declare (indent 1) (debug t)) + (let ((old-case-table (make-symbol "table")) + (old-buffer (make-symbol "buffer"))) + `(let ((,old-case-table (current-case-table)) + (,old-buffer (current-buffer))) + (unwind-protect + (progn (set-case-table ,table) + ,@body) + (with-current-buffer ,old-buffer + (set-case-table ,old-case-table)))))) + +(defmacro with-file-modes (modes &rest body) + "Execute BODY with default file permissions temporarily set to MODES. +MODES is as for `set-default-file-modes'." + (declare (indent 1) (debug t)) + (let ((umask (make-symbol "umask"))) + `(let ((,umask (default-file-modes))) + (unwind-protect + (progn + (set-default-file-modes ,modes) + ,@body) + (set-default-file-modes ,umask))))) + + +;;; Matching and match data. + +(defvar save-match-data-internal) + +;; We use save-match-data-internal as the local variable because +;; that works ok in practice (people should not use that variable elsewhere). +;; We used to use an uninterned symbol; the compiler handles that properly +;; now, but it generates slower code. +(defmacro save-match-data (&rest body) + "Execute the BODY forms, restoring the global value of the match data. +The value returned is the value of the last form in BODY." + ;; It is better not to use backquote here, + ;; because that makes a bootstrapping problem + ;; if you need to recompile all the Lisp files using interpreted code. + (declare (indent 0) (debug t)) + (list 'let + '((save-match-data-internal (match-data))) + (list 'unwind-protect + (cons 'progn body) + ;; It is safe to free (evaporate) markers immediately here, + ;; as Lisp programs should not copy from save-match-data-internal. + '(set-match-data save-match-data-internal 'evaporate)))) + +(defun match-string (num &optional string) + "Return string of text matched by last search. +NUM specifies which parenthesized expression in the last regexp. + Value is nil if NUMth pair didn't match, or there were less than NUM pairs. +Zero means the entire text matched by the whole regexp or whole string. +STRING should be given if the last search was by `string-match' on STRING. +If STRING is nil, the current buffer should be the same buffer +the search/match was performed in." + (if (match-beginning num) + (if string + (substring string (match-beginning num) (match-end num)) + (buffer-substring (match-beginning num) (match-end num))))) + +(defun match-string-no-properties (num &optional string) + "Return string of text matched by last search, without text properties. +NUM specifies which parenthesized expression in the last regexp. + Value is nil if NUMth pair didn't match, or there were less than NUM pairs. +Zero means the entire text matched by the whole regexp or whole string. +STRING should be given if the last search was by `string-match' on STRING. +If STRING is nil, the current buffer should be the same buffer +the search/match was performed in." + (if (match-beginning num) + (if string + (substring-no-properties string (match-beginning num) + (match-end num)) + (buffer-substring-no-properties (match-beginning num) + (match-end num))))) + + +(defun match-substitute-replacement (replacement + &optional fixedcase literal string subexp) + "Return REPLACEMENT as it will be inserted by `replace-match'. +In other words, all back-references in the form `\\&' and `\\N' +are substituted with actual strings matched by the last search. +Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same +meaning as for `replace-match'." + (let ((match (match-string 0 string))) + (save-match-data + (set-match-data (mapcar (lambda (x) + (if (numberp x) + (- x (match-beginning 0)) + x)) + (match-data t))) + (replace-match replacement fixedcase literal match subexp)))) + + +(defun looking-back (regexp &optional limit greedy) + "Return non-nil if text before point matches regular expression REGEXP. +Like `looking-at' except matches before point, and is slower. +LIMIT if non-nil speeds up the search by specifying a minimum +starting position, to avoid checking matches that would start +before LIMIT. + +If GREEDY is non-nil, extend the match backwards as far as +possible, stopping when a single additional previous character +cannot be part of a match for REGEXP. When the match is +extended, its starting position is allowed to occur before +LIMIT. + +As a general recommendation, try to avoid using `looking-back' +wherever possible, since it is slow." + (let ((start (point)) + (pos + (save-excursion + (and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t) + (point))))) + (if (and greedy pos) + (save-restriction + (narrow-to-region (point-min) start) + (while (and (> pos (point-min)) + (save-excursion + (goto-char pos) + (backward-char 1) + (looking-at (concat "\\(?:" regexp "\\)\\'")))) + (setq pos (1- pos))) + (save-excursion + (goto-char pos) + (looking-at (concat "\\(?:" regexp "\\)\\'"))))) + (not (null pos)))) + +(defsubst looking-at-p (regexp) + "\ +Same as `looking-at' except this function does not change the match data." + (let ((inhibit-changing-match-data t)) + (looking-at regexp))) + +(defsubst string-match-p (regexp string &optional start) + "\ +Same as `string-match' except this function does not change the match data." + (let ((inhibit-changing-match-data t)) + (string-match regexp string start))) + +(defun subregexp-context-p (regexp pos &optional start) + "Return non-nil if POS is in a normal subregexp context in REGEXP. +A subregexp context is one where a sub-regexp can appear. +A non-subregexp context is for example within brackets, or within a +repetition bounds operator `\\=\\{...\\}', or right after a `\\'. +If START is non-nil, it should be a position in REGEXP, smaller +than POS, and known to be in a subregexp context." + ;; Here's one possible implementation, with the great benefit that it + ;; reuses the regexp-matcher's own parser, so it understands all the + ;; details of the syntax. A disadvantage is that it needs to match the + ;; error string. + (condition-case err + (progn + (string-match (substring regexp (or start 0) pos) "") + t) + (invalid-regexp + (not (member (cadr err) '("Unmatched [ or [^" + "Unmatched \\{" + "Trailing backslash"))))) + ;; An alternative implementation: + ;; (defconst re-context-re + ;; (let* ((harmless-ch "[^\\[]") + ;; (harmless-esc "\\\\[^{]") + ;; (class-harmless-ch "[^][]") + ;; (class-lb-harmless "[^]:]") + ;; (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?") + ;; (class-lb (concat "\\[\\(" class-lb-harmless + ;; "\\|" class-lb-colon-maybe-charclass "\\)")) + ;; (class + ;; (concat "\\[^?]?" + ;; "\\(" class-harmless-ch + ;; "\\|" class-lb "\\)*" + ;; "\\[?]")) ; special handling for bare [ at end of re + ;; (braces "\\\\{[0-9,]+\\\\}")) + ;; (concat "\\`\\(" harmless-ch "\\|" harmless-esc + ;; "\\|" class "\\|" braces "\\)*\\'")) + ;; "Matches any prefix that corresponds to a normal subregexp context.") + ;; (string-match re-context-re (substring regexp (or start 0) pos)) + ) + +;;;; split-string + +(defconst split-string-default-separators "[ \f\t\n\r\v]+" + "The default value of separators for `split-string'. + +A regexp matching strings of whitespace. May be locale-dependent +\(as yet unimplemented). Should not match non-breaking spaces. + +Warning: binding this to a different value and using it as default is +likely to have undesired semantics.") + +;; The specification says that if both SEPARATORS and OMIT-NULLS are +;; defaulted, OMIT-NULLS should be treated as t. Simplifying the logical +;; expression leads to the equivalent implementation that if SEPARATORS +;; is defaulted, OMIT-NULLS is treated as t. +(defun split-string (string &optional separators omit-nulls trim) + "Split STRING into substrings bounded by matches for SEPARATORS. + +The beginning and end of STRING, and each match for SEPARATORS, are +splitting points. The substrings matching SEPARATORS are removed, and +the substrings between the splitting points are collected as a list, +which is returned. + +If SEPARATORS is non-nil, it should be a regular expression matching text +which separates, but is not part of, the substrings. If nil it defaults to +`split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and +OMIT-NULLS is forced to t. + +If OMIT-NULLS is t, zero-length substrings are omitted from the list (so +that for the default value of SEPARATORS leading and trailing whitespace +are effectively trimmed). If nil, all zero-length substrings are retained, +which correctly parses CSV format, for example. + +If TRIM is non-nil, it should be a regular expression to match +text to trim from the beginning and end of each substring. If trimming +makes the substring empty, it is treated as null. + +If you want to trim whitespace from the substrings, the reliably correct +way is using TRIM. Making SEPARATORS match that whitespace gives incorrect +results when there is whitespace at the start or end of STRING. If you +see such calls to `split-string', please fix them. + +Note that the effect of `(split-string STRING)' is the same as +`(split-string STRING split-string-default-separators t)'. In the rare +case that you wish to retain zero-length substrings when splitting on +whitespace, use `(split-string STRING split-string-default-separators)'. + +Modifies the match data; use `save-match-data' if necessary." + (let* ((keep-nulls (not (if separators omit-nulls t))) + (rexp (or separators split-string-default-separators)) + (start 0) + this-start this-end + notfirst + (list nil) + (push-one + ;; Push the substring in range THIS-START to THIS-END + ;; onto LIST, trimming it and perhaps discarding it. + (lambda () + (when trim + ;; Discard the trim from start of this substring. + (let ((tem (string-match trim string this-start))) + (and (eq tem this-start) + (setq this-start (match-end 0))))) + + (when (or keep-nulls (< this-start this-end)) + (let ((this (substring string this-start this-end))) + + ;; Discard the trim from end of this substring. + (when trim + (let ((tem (string-match (concat trim "\\'") this 0))) + (and tem (< tem (length this)) + (setq this (substring this 0 tem))))) + + ;; Trimming could make it empty; check again. + (when (or keep-nulls (> (length this) 0)) + (push this list))))))) + + (while (and (string-match rexp string + (if (and notfirst + (= start (match-beginning 0)) + (< start (length string))) + (1+ start) start)) + (< start (length string))) + (setq notfirst t) + (setq this-start start this-end (match-beginning 0) + start (match-end 0)) + + (funcall push-one)) + + ;; Handle the substring at the end of STRING. + (setq this-start start this-end (length string)) + (funcall push-one) + + (nreverse list))) + +(defun combine-and-quote-strings (strings &optional separator) + "Concatenate the STRINGS, adding the SEPARATOR (default \" \"). +This tries to quote the strings to avoid ambiguity such that + (split-string-and-unquote (combine-and-quote-strings strs)) == strs +Only some SEPARATORs will work properly." + (let* ((sep (or separator " ")) + (re (concat "[\\\"]" "\\|" (regexp-quote sep)))) + (mapconcat + (lambda (str) + (if (string-match re str) + (concat "\"" (replace-regexp-in-string "[\\\"]" "\\\\\\&" str) "\"") + str)) + strings sep))) + +(defun split-string-and-unquote (string &optional separator) + "Split the STRING into a list of strings. +It understands Emacs Lisp quoting within STRING, such that + (split-string-and-unquote (combine-and-quote-strings strs)) == strs +The SEPARATOR regexp defaults to \"\\s-+\"." + (let ((sep (or separator "\\s-+")) + (i (string-match "\"" string))) + (if (null i) + (split-string string sep t) ; no quoting: easy + (append (unless (eq i 0) (split-string (substring string 0 i) sep t)) + (let ((rfs (read-from-string string i))) + (cons (car rfs) + (split-string-and-unquote (substring string (cdr rfs)) + sep))))))) + + +;;;; Replacement in strings. + +(defun subst-char-in-string (fromchar tochar string &optional inplace) + "Replace FROMCHAR with TOCHAR in STRING each time it occurs. +Unless optional argument INPLACE is non-nil, return a new string." + (let ((i (length string)) + (newstr (if inplace string (copy-sequence string)))) + (while (> i 0) + (setq i (1- i)) + (if (eq (aref newstr i) fromchar) + (aset newstr i tochar))) + newstr)) + +(defun replace-regexp-in-string (regexp rep string &optional + fixedcase literal subexp start) + "Replace all matches for REGEXP with REP in STRING. + +Return a new string containing the replacements. + +Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the +arguments with the same names of function `replace-match'. If START +is non-nil, start replacements at that index in STRING. + +REP is either a string used as the NEWTEXT arg of `replace-match' or a +function. If it is a function, it is called with the actual text of each +match, and its value is used as the replacement text. When REP is called, +the match data are the result of matching REGEXP against a substring +of STRING. + +To replace only the first match (if any), make REGEXP match up to \\' +and replace a sub-expression, e.g. + (replace-regexp-in-string \"\\\\(foo\\\\).*\\\\'\" \"bar\" \" foo foo\" nil nil 1) + => \" bar foo\"" + + ;; To avoid excessive consing from multiple matches in long strings, + ;; don't just call `replace-match' continually. Walk down the + ;; string looking for matches of REGEXP and building up a (reversed) + ;; list MATCHES. This comprises segments of STRING which weren't + ;; matched interspersed with replacements for segments that were. + ;; [For a `large' number of replacements it's more efficient to + ;; operate in a temporary buffer; we can't tell from the function's + ;; args whether to choose the buffer-based implementation, though it + ;; might be reasonable to do so for long enough STRING.] + (let ((l (length string)) + (start (or start 0)) + matches str mb me) + (save-match-data + (while (and (< start l) (string-match regexp string start)) + (setq mb (match-beginning 0) + me (match-end 0)) + ;; If we matched the empty string, make sure we advance by one char + (when (= me mb) (setq me (min l (1+ mb)))) + ;; Generate a replacement for the matched substring. + ;; Operate only on the substring to minimize string consing. + ;; Set up match data for the substring for replacement; + ;; presumably this is likely to be faster than munging the + ;; match data directly in Lisp. + (string-match regexp (setq str (substring string mb me))) + (setq matches + (cons (replace-match (if (stringp rep) + rep + (funcall rep (match-string 0 str))) + fixedcase literal str subexp) + (cons (substring string start mb) ; unmatched prefix + matches))) + (setq start me)) + ;; Reconstruct a string from the pieces. + (setq matches (cons (substring string start l) matches)) ; leftover + (apply #'concat (nreverse matches))))) + +(defun string-prefix-p (prefix string &optional ignore-case) + "Return non-nil if PREFIX is a prefix of STRING. +If IGNORE-CASE is non-nil, the comparison is done without paying attention +to case differences." + (let ((prefix-length (length prefix))) + (if (> prefix-length (length string)) nil + (eq t (compare-strings prefix 0 prefix-length string + 0 prefix-length ignore-case))))) + +(defun string-suffix-p (suffix string &optional ignore-case) + "Return non-nil if SUFFIX is a suffix of STRING. +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences." + (let ((start-pos (- (length string) (length suffix)))) + (and (>= start-pos 0) + (eq t (compare-strings suffix nil nil + string start-pos nil ignore-case))))) + +(defun bidi-string-mark-left-to-right (str) + "Return a string that can be safely inserted in left-to-right text. + +Normally, inserting a string with right-to-left (RTL) script into +a buffer may cause some subsequent text to be displayed as part +of the RTL segment (usually this affects punctuation characters). +This function returns a string which displays as STR but forces +subsequent text to be displayed as left-to-right. + +If STR contains any RTL character, this function returns a string +consisting of STR followed by an invisible left-to-right mark +\(LRM) character. Otherwise, it returns STR." + (unless (stringp str) + (signal 'wrong-type-argument (list 'stringp str))) + (if (string-match "\\cR" str) + (concat str (propertize (string ?\x200e) 'invisible t)) + str)) + +;;;; Specifying things to do later. + +(defun load-history-regexp (file) + "Form a regexp to find FILE in `load-history'. +FILE, a string, is described in the function `eval-after-load'." + (if (file-name-absolute-p file) + (setq file (file-truename file))) + (concat (if (file-name-absolute-p file) "\\`" "\\(\\`\\|/\\)") + (regexp-quote file) + (if (file-name-extension file) + "" + ;; Note: regexp-opt can't be used here, since we need to call + ;; this before Emacs has been fully started. 2006-05-21 + (concat "\\(" (mapconcat 'regexp-quote load-suffixes "\\|") "\\)?")) + "\\(" (mapconcat 'regexp-quote jka-compr-load-suffixes "\\|") + "\\)?\\'")) + +(defun load-history-filename-element (file-regexp) + "Get the first elt of `load-history' whose car matches FILE-REGEXP. +Return nil if there isn't one." + (let* ((loads load-history) + (load-elt (and loads (car loads)))) + (save-match-data + (while (and loads + (or (null (car load-elt)) + (not (string-match file-regexp (car load-elt))))) + (setq loads (cdr loads) + load-elt (and loads (car loads))))) + load-elt)) + +(put 'eval-after-load 'lisp-indent-function 1) +(defun eval-after-load (file form) + "Arrange that if FILE is loaded, FORM will be run immediately afterwards. +If FILE is already loaded, evaluate FORM right now. +FORM can be an Elisp expression (in which case it's passed to `eval'), +or a function (in which case it's passed to `funcall' with no argument). + +If a matching file is loaded again, FORM will be evaluated again. + +If FILE is a string, it may be either an absolute or a relative file +name, and may have an extension (e.g. \".el\") or may lack one, and +additionally may or may not have an extension denoting a compressed +format (e.g. \".gz\"). + +When FILE is absolute, this first converts it to a true name by chasing +symbolic links. Only a file of this name (see next paragraph regarding +extensions) will trigger the evaluation of FORM. When FILE is relative, +a file whose absolute true name ends in FILE will trigger evaluation. + +When FILE lacks an extension, a file name with any extension will trigger +evaluation. Otherwise, its extension must match FILE's. A further +extension for a compressed format (e.g. \".gz\") on FILE will not affect +this name matching. + +Alternatively, FILE can be a feature (i.e. a symbol), in which case FORM +is evaluated at the end of any file that `provide's this feature. +If the feature is provided when evaluating code not associated with a +file, FORM is evaluated immediately after the provide statement. + +Usually FILE is just a library name like \"font-lock\" or a feature name +like 'font-lock. + +This function makes or adds to an entry on `after-load-alist'." + (declare (compiler-macro + (lambda (whole) + (if (eq 'quote (car-safe form)) + ;; Quote with lambda so the compiler can look inside. + `(eval-after-load ,file (lambda () ,(nth 1 form))) + whole)))) + ;; Add this FORM into after-load-alist (regardless of whether we'll be + ;; evaluating it now). + (let* ((regexp-or-feature + (if (stringp file) + (setq file (purecopy (load-history-regexp file))) + file)) + (elt (assoc regexp-or-feature after-load-alist)) + (func + (if (functionp form) form + ;; Try to use the "current" lexical/dynamic mode for `form'. + (eval `(lambda () ,form) lexical-binding)))) + (unless elt + (setq elt (list regexp-or-feature)) + (push elt after-load-alist)) + ;; Is there an already loaded file whose name (or `provide' name) + ;; matches FILE? + (prog1 (if (if (stringp file) + (load-history-filename-element regexp-or-feature) + (featurep file)) + (funcall func)) + (let ((delayed-func + (if (not (symbolp regexp-or-feature)) func + ;; For features, the after-load-alist elements get run when + ;; `provide' is called rather than at the end of the file. + ;; So add an indirection to make sure that `func' is really run + ;; "after-load" in case the provide call happens early. + (lambda () + (if (not load-file-name) + ;; Not being provided from a file, run func right now. + (funcall func) + (let ((lfn load-file-name) + ;; Don't use letrec, because equal (in + ;; add/remove-hook) would get trapped in a cycle. + (fun (make-symbol "eval-after-load-helper"))) + (fset fun (lambda (file) + (when (equal file lfn) + (remove-hook 'after-load-functions fun) + (funcall func)))) + (add-hook 'after-load-functions fun 'append))))))) + ;; Add FORM to the element unless it's already there. + (unless (member delayed-func (cdr elt)) + (nconc elt (list delayed-func))))))) + +(defmacro with-eval-after-load (file &rest body) + "Execute BODY after FILE is loaded. +FILE is normally a feature name, but it can also be a file name, +in case that file does not provide any feature." + (declare (indent 1) (debug t)) + `(eval-after-load ,file (lambda () ,@body))) + +(defvar after-load-functions nil + "Special hook run after loading a file. +Each function there is called with a single argument, the absolute +name of the file just loaded.") + +(defun do-after-load-evaluation (abs-file) + "Evaluate all `eval-after-load' forms, if any, for ABS-FILE. +ABS-FILE, a string, should be the absolute true name of a file just loaded. +This function is called directly from the C code." + ;; Run the relevant eval-after-load forms. + (dolist (a-l-element after-load-alist) + (when (and (stringp (car a-l-element)) + (string-match-p (car a-l-element) abs-file)) + ;; discard the file name regexp + (mapc #'funcall (cdr a-l-element)))) + ;; Complain when the user uses obsolete files. + (when (save-match-data + (and (string-match "/obsolete/\\([^/]*\\)\\'" abs-file) + (not (equal "loaddefs.el" (match-string 1 abs-file))))) + ;; Maybe we should just use display-warning? This seems yucky... + (let* ((file (file-name-nondirectory abs-file)) + (msg (format "Package %s is obsolete!" + (substring file 0 + (string-match "\\.elc?\\>" file))))) + ;; Cribbed from cl--compiling-file. + (if (and (boundp 'byte-compile--outbuffer) + (bufferp (symbol-value 'byte-compile--outbuffer)) + (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) + " *Compiler Output*")) + ;; Don't warn about obsolete files using other obsolete files. + (unless (and (stringp byte-compile-current-file) + (string-match-p "/obsolete/[^/]*\\'" + (expand-file-name + byte-compile-current-file + byte-compile-root-dir))) + (byte-compile-log-warning msg)) + (run-with-timer 0 nil + (lambda (msg) + (message "%s" msg)) + msg)))) + + ;; Finally, run any other hook. + (run-hook-with-args 'after-load-functions abs-file)) + +(defun eval-next-after-load (file) + "Read the following input sexp, and run it whenever FILE is loaded. +This makes or adds to an entry on `after-load-alist'. +FILE should be the name of a library, with no directory name." + (declare (obsolete eval-after-load "23.2")) + (eval-after-load file (read))) + + +(defun display-delayed-warnings () + "Display delayed warnings from `delayed-warnings-list'. +Used from `delayed-warnings-hook' (which see)." + (dolist (warning (nreverse delayed-warnings-list)) + (apply 'display-warning warning)) + (setq delayed-warnings-list nil)) + +(defun collapse-delayed-warnings () + "Remove duplicates from `delayed-warnings-list'. +Collapse identical adjacent warnings into one (plus count). +Used from `delayed-warnings-hook' (which see)." + (let ((count 1) + collapsed warning) + (while delayed-warnings-list + (setq warning (pop delayed-warnings-list)) + (if (equal warning (car delayed-warnings-list)) + (setq count (1+ count)) + (when (> count 1) + (setcdr warning (cons (format "%s [%d times]" (cadr warning) count) + (cddr warning))) + (setq count 1)) + (push warning collapsed))) + (setq delayed-warnings-list (nreverse collapsed)))) + +;; At present this is only used for Emacs internals. +;; Ref http://lists.gnu.org/archive/html/emacs-devel/2012-02/msg00085.html +(defvar delayed-warnings-hook '(collapse-delayed-warnings + display-delayed-warnings) + "Normal hook run to process and display delayed warnings. +By default, this hook contains functions to consolidate the +warnings listed in `delayed-warnings-list', display them, and set +`delayed-warnings-list' back to nil.") + +(defun delay-warning (type message &optional level buffer-name) + "Display a delayed warning. +Aside from going through `delayed-warnings-list', this is equivalent +to `display-warning'." + (push (list type message level buffer-name) delayed-warnings-list)) + + +;;;; invisibility specs + +(defun add-to-invisibility-spec (element) + "Add ELEMENT to `buffer-invisibility-spec'. +See documentation for `buffer-invisibility-spec' for the kind of elements +that can be added." + (if (eq buffer-invisibility-spec t) + (setq buffer-invisibility-spec (list t))) + (setq buffer-invisibility-spec + (cons element buffer-invisibility-spec))) + +(defun remove-from-invisibility-spec (element) + "Remove ELEMENT from `buffer-invisibility-spec'." + (if (consp buffer-invisibility-spec) + (setq buffer-invisibility-spec + (delete element buffer-invisibility-spec)))) + +;;;; Syntax tables. + +(defmacro with-syntax-table (table &rest body) + "Evaluate BODY with syntax table of current buffer set to TABLE. +The syntax table of the current buffer is saved, BODY is evaluated, and the +saved table is restored, even in case of an abnormal exit. +Value is what BODY returns." + (declare (debug t) (indent 1)) + (let ((old-table (make-symbol "table")) + (old-buffer (make-symbol "buffer"))) + `(let ((,old-table (syntax-table)) + (,old-buffer (current-buffer))) + (unwind-protect + (progn + (set-syntax-table ,table) + ,@body) + (save-current-buffer + (set-buffer ,old-buffer) + (set-syntax-table ,old-table)))))) + +(defun make-syntax-table (&optional oldtable) + "Return a new syntax table. +Create a syntax table which inherits from OLDTABLE (if non-nil) or +from `standard-syntax-table' otherwise." + (let ((table (make-char-table 'syntax-table nil))) + (set-char-table-parent table (or oldtable (standard-syntax-table))) + table)) + +(defun syntax-after (pos) + "Return the raw syntax descriptor for the char after POS. +If POS is outside the buffer's accessible portion, return nil." + (unless (or (< pos (point-min)) (>= pos (point-max))) + (let ((st (if parse-sexp-lookup-properties + (get-char-property pos 'syntax-table)))) + (if (consp st) st + (aref (or st (syntax-table)) (char-after pos)))))) + +(defun syntax-class (syntax) + "Return the code for the syntax class described by SYNTAX. + +SYNTAX should be a raw syntax descriptor; the return value is a +integer which encodes the corresponding syntax class. See Info +node `(elisp)Syntax Table Internals' for a list of codes. + +If SYNTAX is nil, return nil." + (and syntax (logand (car syntax) 65535))) + +;; Utility motion commands + +;; Whitespace + +(defun forward-whitespace (arg) + "Move point to the end of the next sequence of whitespace chars. +Each such sequence may be a single newline, or a sequence of +consecutive space and/or tab characters. +With prefix argument ARG, do it ARG times if positive, or move +backwards ARG times if negative." + (interactive "^p") + (if (natnump arg) + (re-search-forward "[ \t]+\\|\n" nil 'move arg) + (while (< arg 0) + (if (re-search-backward "[ \t]+\\|\n" nil 'move) + (or (eq (char-after (match-beginning 0)) ?\n) + (skip-chars-backward " \t"))) + (setq arg (1+ arg))))) + +;; Symbols + +(defun forward-symbol (arg) + "Move point to the next position that is the end of a symbol. +A symbol is any sequence of characters that are in either the +word constituent or symbol constituent syntax class. +With prefix argument ARG, do it ARG times if positive, or move +backwards ARG times if negative." + (interactive "^p") + (if (natnump arg) + (re-search-forward "\\(\\sw\\|\\s_\\)+" nil 'move arg) + (while (< arg 0) + (if (re-search-backward "\\(\\sw\\|\\s_\\)+" nil 'move) + (skip-syntax-backward "w_")) + (setq arg (1+ arg))))) + +;; Syntax blocks + +(defun forward-same-syntax (&optional arg) + "Move point past all characters with the same syntax class. +With prefix argument ARG, do it ARG times if positive, or move +backwards ARG times if negative." + (interactive "^p") + (or arg (setq arg 1)) + (while (< arg 0) + (skip-syntax-backward + (char-to-string (char-syntax (char-before)))) + (setq arg (1+ arg))) + (while (> arg 0) + (skip-syntax-forward (char-to-string (char-syntax (char-after)))) + (setq arg (1- arg)))) + + +;;;; Text clones + +(defvar text-clone--maintaining nil) + +(defun text-clone--maintain (ol1 after beg end &optional _len) + "Propagate the changes made under the overlay OL1 to the other clones. +This is used on the `modification-hooks' property of text clones." + (when (and after (not undo-in-progress) + (not text-clone--maintaining) + (overlay-start ol1)) + (let ((margin (if (overlay-get ol1 'text-clone-spreadp) 1 0))) + (setq beg (max beg (+ (overlay-start ol1) margin))) + (setq end (min end (- (overlay-end ol1) margin))) + (when (<= beg end) + (save-excursion + (when (overlay-get ol1 'text-clone-syntax) + ;; Check content of the clone's text. + (let ((cbeg (+ (overlay-start ol1) margin)) + (cend (- (overlay-end ol1) margin))) + (goto-char cbeg) + (save-match-data + (if (not (re-search-forward + (overlay-get ol1 'text-clone-syntax) cend t)) + ;; Mark the overlay for deletion. + (setq end cbeg) + (when (< (match-end 0) cend) + ;; Shrink the clone at its end. + (setq end (min end (match-end 0))) + (move-overlay ol1 (overlay-start ol1) + (+ (match-end 0) margin))) + (when (> (match-beginning 0) cbeg) + ;; Shrink the clone at its beginning. + (setq beg (max (match-beginning 0) beg)) + (move-overlay ol1 (- (match-beginning 0) margin) + (overlay-end ol1))))))) + ;; Now go ahead and update the clones. + (let ((head (- beg (overlay-start ol1))) + (tail (- (overlay-end ol1) end)) + (str (buffer-substring beg end)) + (nothing-left t) + (text-clone--maintaining t)) + (dolist (ol2 (overlay-get ol1 'text-clones)) + (let ((oe (overlay-end ol2))) + (unless (or (eq ol1 ol2) (null oe)) + (setq nothing-left nil) + (let ((mod-beg (+ (overlay-start ol2) head))) + ;;(overlay-put ol2 'modification-hooks nil) + (goto-char (- (overlay-end ol2) tail)) + (unless (> mod-beg (point)) + (save-excursion (insert str)) + (delete-region mod-beg (point))) + ;;(overlay-put ol2 'modification-hooks '(text-clone--maintain)) + )))) + (if nothing-left (delete-overlay ol1)))))))) + +(defun text-clone-create (start end &optional spreadp syntax) + "Create a text clone of START...END at point. +Text clones are chunks of text that are automatically kept identical: +changes done to one of the clones will be immediately propagated to the other. + +The buffer's content at point is assumed to be already identical to +the one between START and END. +If SYNTAX is provided it's a regexp that describes the possible text of +the clones; the clone will be shrunk or killed if necessary to ensure that +its text matches the regexp. +If SPREADP is non-nil it indicates that text inserted before/after the +clone should be incorporated in the clone." + ;; To deal with SPREADP we can either use an overlay with `nil t' along + ;; with insert-(behind|in-front-of)-hooks or use a slightly larger overlay + ;; (with a one-char margin at each end) with `t nil'. + ;; We opted for a larger overlay because it behaves better in the case + ;; where the clone is reduced to the empty string (we want the overlay to + ;; stay when the clone's content is the empty string and we want to use + ;; `evaporate' to make sure those overlays get deleted when needed). + ;; + (let* ((pt-end (+ (point) (- end start))) + (start-margin (if (or (not spreadp) (bobp) (<= start (point-min))) + 0 1)) + (end-margin (if (or (not spreadp) + (>= pt-end (point-max)) + (>= start (point-max))) + 0 1)) + ;; FIXME: Reuse overlays at point to extend dups! + (ol1 (make-overlay (- start start-margin) (+ end end-margin) nil t)) + (ol2 (make-overlay (- (point) start-margin) (+ pt-end end-margin) nil t)) + (dups (list ol1 ol2))) + (overlay-put ol1 'modification-hooks '(text-clone--maintain)) + (when spreadp (overlay-put ol1 'text-clone-spreadp t)) + (when syntax (overlay-put ol1 'text-clone-syntax syntax)) + ;;(overlay-put ol1 'face 'underline) + (overlay-put ol1 'evaporate t) + (overlay-put ol1 'text-clones dups) + ;; + (overlay-put ol2 'modification-hooks '(text-clone--maintain)) + (when spreadp (overlay-put ol2 'text-clone-spreadp t)) + (when syntax (overlay-put ol2 'text-clone-syntax syntax)) + ;;(overlay-put ol2 'face 'underline) + (overlay-put ol2 'evaporate t) + (overlay-put ol2 'text-clones dups))) + +;;;; Mail user agents. + +;; Here we include just enough for other packages to be able +;; to define them. + +(defun define-mail-user-agent (symbol composefunc sendfunc + &optional abortfunc hookvar) + "Define a symbol to identify a mail-sending package for `mail-user-agent'. + +SYMBOL can be any Lisp symbol. Its function definition and/or +value as a variable do not matter for this usage; we use only certain +properties on its property list, to encode the rest of the arguments. + +COMPOSEFUNC is program callable function that composes an outgoing +mail message buffer. This function should set up the basics of the +buffer without requiring user interaction. It should populate the +standard mail headers, leaving the `to:' and `subject:' headers blank +by default. + +COMPOSEFUNC should accept several optional arguments--the same +arguments that `compose-mail' takes. See that function's documentation. + +SENDFUNC is the command a user would run to send the message. + +Optional ABORTFUNC is the command a user would run to abort the +message. For mail packages that don't have a separate abort function, +this can be `kill-buffer' (the equivalent of omitting this argument). + +Optional HOOKVAR is a hook variable that gets run before the message +is actually sent. Callers that use the `mail-user-agent' may +install a hook function temporarily on this hook variable. +If HOOKVAR is nil, `mail-send-hook' is used. + +The properties used on SYMBOL are `composefunc', `sendfunc', +`abortfunc', and `hookvar'." + (put symbol 'composefunc composefunc) + (put symbol 'sendfunc sendfunc) + (put symbol 'abortfunc (or abortfunc 'kill-buffer)) + (put symbol 'hookvar (or hookvar 'mail-send-hook))) + +(defvar called-interactively-p-functions nil + "Special hook called to skip special frames in `called-interactively-p'. +The functions are called with 3 arguments: (I FRAME1 FRAME2), +where FRAME1 is a \"current frame\", FRAME2 is the next frame, +I is the index of the frame after FRAME2. It should return nil +if those frames don't seem special and otherwise, it should return +the number of frames to skip (minus 1).") + +(defconst internal--funcall-interactively + (symbol-function 'funcall-interactively)) + +(defun called-interactively-p (&optional kind) + "Return t if the containing function was called by `call-interactively'. +If KIND is `interactive', then only return t if the call was made +interactively by the user, i.e. not in `noninteractive' mode nor +when `executing-kbd-macro'. +If KIND is `any', on the other hand, it will return t for any kind of +interactive call, including being called as the binding of a key or +from a keyboard macro, even in `noninteractive' mode. + +This function is very brittle, it may fail to return the intended result when +the code is debugged, advised, or instrumented in some form. Some macros and +special forms (such as `condition-case') may also sometimes wrap their bodies +in a `lambda', so any call to `called-interactively-p' from those bodies will +indicate whether that lambda (rather than the surrounding function) was called +interactively. + +Instead of using this function, it is cleaner and more reliable to give your +function an extra optional argument whose `interactive' spec specifies +non-nil unconditionally (\"p\" is a good way to do this), or via +\(not (or executing-kbd-macro noninteractive)). + +The only known proper use of `interactive' for KIND is in deciding +whether to display a helpful message, or how to display it. If you're +thinking of using it for any other purpose, it is quite likely that +you're making a mistake. Think: what do you want to do when the +command is called from a keyboard macro?" + (declare (advertised-calling-convention (kind) "23.1")) + (when (not (and (eq kind 'interactive) + (or executing-kbd-macro noninteractive))) + (let* ((i 1) ;; 0 is the called-interactively-p frame. + frame nextframe + (get-next-frame + (lambda () + (setq frame nextframe) + (setq nextframe (backtrace-frame i 'called-interactively-p)) + ;; (message "Frame %d = %S" i nextframe) + (setq i (1+ i))))) + (funcall get-next-frame) ;; Get the first frame. + (while + ;; FIXME: The edebug and advice handling should be made modular and + ;; provided directly by edebug.el and nadvice.el. + (progn + ;; frame =(backtrace-frame i-2) + ;; nextframe=(backtrace-frame i-1) + (funcall get-next-frame) + ;; `pcase' would be a fairly good fit here, but it sometimes moves + ;; branches within local functions, which then messes up the + ;; `backtrace-frame' data we get, + (or + ;; Skip special forms (from non-compiled code). + (and frame (null (car frame))) + ;; Skip also `interactive-p' (because we don't want to know if + ;; interactive-p was called interactively but if it's caller was) + ;; and `byte-code' (idem; this appears in subexpressions of things + ;; like condition-case, which are wrapped in a separate bytecode + ;; chunk). + ;; FIXME: For lexical-binding code, this is much worse, + ;; because the frames look like "byte-code -> funcall -> #[...]", + ;; which is not a reliable signature. + (memq (nth 1 frame) '(interactive-p 'byte-code)) + ;; Skip package-specific stack-frames. + (let ((skip (run-hook-with-args-until-success + 'called-interactively-p-functions + i frame nextframe))) + (pcase skip + (`nil nil) + (`0 t) + (_ (setq i (+ i skip -1)) (funcall get-next-frame))))))) + ;; Now `frame' should be "the function from which we were called". + (pcase (cons frame nextframe) + ;; No subr calls `interactive-p', so we can rule that out. + (`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil) + ;; In case #<subr funcall-interactively> without going through the + ;; `funcall-interactively' symbol (bug#3984). + (`(,_ . (t ,(pred (lambda (f) + (eq internal--funcall-interactively + (indirect-function f)))) + . ,_)) + t))))) + +(defun interactive-p () + "Return t if the containing function was run directly by user input. +This means that the function was called with `call-interactively' +\(which includes being called as the binding of a key) +and input is currently coming from the keyboard (not a keyboard macro), +and Emacs is not running in batch mode (`noninteractive' is nil). + +The only known proper use of `interactive-p' is in deciding whether to +display a helpful message, or how to display it. If you're thinking +of using it for any other purpose, it is quite likely that you're +making a mistake. Think: what do you want to do when the command is +called from a keyboard macro or in batch mode? + +To test whether your function was called with `call-interactively', +either (i) add an extra optional argument and give it an `interactive' +spec that specifies non-nil unconditionally (such as \"p\"); or (ii) +use `called-interactively-p'." + (declare (obsolete called-interactively-p "23.2")) + (called-interactively-p 'interactive)) + +(defun internal-push-keymap (keymap symbol) + (let ((map (symbol-value symbol))) + (unless (memq keymap map) + (unless (memq 'add-keymap-witness (symbol-value symbol)) + (setq map (make-composed-keymap nil (symbol-value symbol))) + (push 'add-keymap-witness (cdr map)) + (set symbol map)) + (push keymap (cdr map))))) + +(defun internal-pop-keymap (keymap symbol) + (let ((map (symbol-value symbol))) + (when (memq keymap map) + (setf (cdr map) (delq keymap (cdr map)))) + (let ((tail (cddr map))) + (and (or (null tail) (keymapp tail)) + (eq 'add-keymap-witness (nth 1 map)) + (set symbol tail))))) + +(define-obsolete-function-alias + 'set-temporary-overlay-map 'set-transient-map "24.4") + +(defun set-transient-map (map &optional keep-pred on-exit) + "Set MAP as a temporary keymap taking precedence over other keymaps. +Normally, MAP is used only once, to look up the very next key. +However, if the optional argument KEEP-PRED is t, MAP stays +active if a key from MAP is used. KEEP-PRED can also be a +function of no arguments: it is called from `pre-command-hook' and +if it returns non-nil, then MAP stays active. + +Optional arg ON-EXIT, if non-nil, specifies a function that is +called, with no arguments, after MAP is deactivated. + +This uses `overriding-terminal-local-map' which takes precedence over all other +keymaps. As usual, if no match for a key is found in MAP, the normal key +lookup sequence then continues. + +This returns an \"exit function\", which can be called with no argument +to deactivate this transient map, regardless of KEEP-PRED." + (let* ((clearfun (make-symbol "clear-transient-map")) + (exitfun + (lambda () + (internal-pop-keymap map 'overriding-terminal-local-map) + (remove-hook 'pre-command-hook clearfun) + (when on-exit (funcall on-exit))))) + ;; Don't use letrec, because equal (in add/remove-hook) would get trapped + ;; in a cycle. + (fset clearfun + (lambda () + (with-demoted-errors "set-transient-map PCH: %S" + (unless (cond + ((null keep-pred) nil) + ((not (eq map (cadr overriding-terminal-local-map))) + ;; There's presumably some other transient-map in + ;; effect. Wait for that one to terminate before we + ;; remove ourselves. + ;; For example, if isearch and C-u both use transient + ;; maps, then the lifetime of the C-u should be nested + ;; within isearch's, so the pre-command-hook of + ;; isearch should be suspended during the C-u one so + ;; we don't exit isearch just because we hit 1 after + ;; C-u and that 1 exits isearch whereas it doesn't + ;; exit C-u. + t) + ((eq t keep-pred) + (eq this-command + (lookup-key map (this-command-keys-vector)))) + (t (funcall keep-pred))) + (funcall exitfun))))) + (add-hook 'pre-command-hook clearfun) + (internal-push-keymap map 'overriding-terminal-local-map) + exitfun)) + +;;;; Progress reporters. + +;; Progress reporter has the following structure: +;; +;; (NEXT-UPDATE-VALUE . [NEXT-UPDATE-TIME +;; MIN-VALUE +;; MAX-VALUE +;; MESSAGE +;; MIN-CHANGE +;; MIN-TIME]) +;; +;; This weirdness is for optimization reasons: we want +;; `progress-reporter-update' to be as fast as possible, so +;; `(car reporter)' is better than `(aref reporter 0)'. +;; +;; NEXT-UPDATE-TIME is a float. While `float-time' loses a couple +;; digits of precision, it doesn't really matter here. On the other +;; hand, it greatly simplifies the code. + +(defsubst progress-reporter-update (reporter &optional value) + "Report progress of an operation in the echo area. +REPORTER should be the result of a call to `make-progress-reporter'. + +If REPORTER is a numerical progress reporter---i.e. if it was + made using non-nil MIN-VALUE and MAX-VALUE arguments to + `make-progress-reporter'---then VALUE should be a number between + MIN-VALUE and MAX-VALUE. + +If REPORTER is a non-numerical reporter, VALUE should be nil. + +This function is relatively inexpensive. If the change since +last update is too small or insufficient time has passed, it does +nothing." + (when (or (not (numberp value)) ; For pulsing reporter + (>= value (car reporter))) ; For numerical reporter + (progress-reporter-do-update reporter value))) + +(defun make-progress-reporter (message &optional min-value max-value + current-value min-change min-time) + "Return progress reporter object for use with `progress-reporter-update'. + +MESSAGE is shown in the echo area, with a status indicator +appended to the end. When you call `progress-reporter-done', the +word \"done\" is printed after the MESSAGE. You can change the +MESSAGE of an existing progress reporter by calling +`progress-reporter-force-update'. + +MIN-VALUE and MAX-VALUE, if non-nil, are starting (0% complete) +and final (100% complete) states of operation; the latter should +be larger. In this case, the status message shows the percentage +progress. + +If MIN-VALUE and/or MAX-VALUE is omitted or nil, the status +message shows a \"spinning\", non-numeric indicator. + +Optional CURRENT-VALUE is the initial progress; the default is +MIN-VALUE. +Optional MIN-CHANGE is the minimal change in percents to report; +the default is 1%. +CURRENT-VALUE and MIN-CHANGE do not have any effect if MIN-VALUE +and/or MAX-VALUE are nil. + +Optional MIN-TIME specifies the minimum interval time between +echo area updates (default is 0.2 seconds.) If the function +`float-time' is not present, time is not tracked at all. If the +OS is not capable of measuring fractions of seconds, this +parameter is effectively rounded up." + (when (string-match "[[:alnum:]]\\'" message) + (setq message (concat message "..."))) + (unless min-time + (setq min-time 0.2)) + (let ((reporter + ;; Force a call to `message' now + (cons (or min-value 0) + (vector (if (and (fboundp 'float-time) + (>= min-time 0.02)) + (float-time) nil) + min-value + max-value + message + (if min-change (max (min min-change 50) 1) 1) + min-time)))) + (progress-reporter-update reporter (or current-value min-value)) + reporter)) + +(defun progress-reporter-force-update (reporter &optional value new-message) + "Report progress of an operation in the echo area unconditionally. + +The first two arguments are the same as in `progress-reporter-update'. +NEW-MESSAGE, if non-nil, sets a new message for the reporter." + (let ((parameters (cdr reporter))) + (when new-message + (aset parameters 3 new-message)) + (when (aref parameters 0) + (aset parameters 0 (float-time))) + (progress-reporter-do-update reporter value))) + +(defvar progress-reporter--pulse-characters ["-" "\\" "|" "/"] + "Characters to use for pulsing progress reporters.") + +(defun progress-reporter-do-update (reporter value) + (let* ((parameters (cdr reporter)) + (update-time (aref parameters 0)) + (min-value (aref parameters 1)) + (max-value (aref parameters 2)) + (text (aref parameters 3)) + (enough-time-passed + ;; See if enough time has passed since the last update. + (or (not update-time) + (when (>= (float-time) update-time) + ;; Calculate time for the next update + (aset parameters 0 (+ update-time (aref parameters 5))))))) + (cond ((and min-value max-value) + ;; Numerical indicator + (let* ((one-percent (/ (- max-value min-value) 100.0)) + (percentage (if (= max-value min-value) + 0 + (truncate (/ (- value min-value) + one-percent))))) + ;; Calculate NEXT-UPDATE-VALUE. If we are not printing + ;; message because not enough time has passed, use 1 + ;; instead of MIN-CHANGE. This makes delays between echo + ;; area updates closer to MIN-TIME. + (setcar reporter + (min (+ min-value (* (+ percentage + (if enough-time-passed + ;; MIN-CHANGE + (aref parameters 4) + 1)) + one-percent)) + max-value)) + (when (integerp value) + (setcar reporter (ceiling (car reporter)))) + ;; Only print message if enough time has passed + (when enough-time-passed + (if (> percentage 0) + (message "%s%d%%" text percentage) + (message "%s" text))))) + ;; Pulsing indicator + (enough-time-passed + (let ((index (mod (1+ (car reporter)) 4)) + (message-log-max nil)) + (setcar reporter index) + (message "%s %s" + text + (aref progress-reporter--pulse-characters + index))))))) + +(defun progress-reporter-done (reporter) + "Print reporter's message followed by word \"done\" in echo area." + (message "%sdone" (aref (cdr reporter) 3))) + +(defmacro dotimes-with-progress-reporter (spec message &rest body) + "Loop a certain number of times and report progress in the echo area. +Evaluate BODY with VAR bound to successive integers running from +0, inclusive, to COUNT, exclusive. Then evaluate RESULT to get +the return value (nil if RESULT is omitted). + +At each iteration MESSAGE followed by progress percentage is +printed in the echo area. After the loop is finished, MESSAGE +followed by word \"done\" is printed. This macro is a +convenience wrapper around `make-progress-reporter' and friends. + +\(fn (VAR COUNT [RESULT]) MESSAGE BODY...)" + (declare (indent 2) (debug ((symbolp form &optional form) form body))) + (let ((temp (make-symbol "--dotimes-temp--")) + (temp2 (make-symbol "--dotimes-temp2--")) + (start 0) + (end (nth 1 spec))) + `(let ((,temp ,end) + (,(car spec) ,start) + (,temp2 (make-progress-reporter ,message ,start ,end))) + (while (< ,(car spec) ,temp) + ,@body + (progress-reporter-update ,temp2 + (setq ,(car spec) (1+ ,(car spec))))) + (progress-reporter-done ,temp2) + nil ,@(cdr (cdr spec))))) + + +;;;; Comparing version strings. + +(defconst version-separator "." + "Specify the string used to separate the version elements. + +Usually the separator is \".\", but it can be any other string.") + + +(defconst version-regexp-alist + '(("^[-_+ ]?snapshot$" . -4) + ;; treat "1.2.3-20050920" and "1.2-3" as snapshot releases + ("^[-_+]$" . -4) + ;; treat "1.2.3-CVS" as snapshot release + ("^[-_+ ]?\\(cvs\\|git\\|bzr\\|svn\\|hg\\|darcs\\)$" . -4) + ("^[-_+ ]?alpha$" . -3) + ("^[-_+ ]?beta$" . -2) + ("^[-_+ ]?\\(pre\\|rc\\)$" . -1)) + "Specify association between non-numeric version and its priority. + +This association is used to handle version string like \"1.0pre2\", +\"0.9alpha1\", etc. It's used by `version-to-list' (which see) to convert the +non-numeric part of a version string to an integer. For example: + + String Version Integer List Version + \"0.9snapshot\" (0 9 -4) + \"1.0-git\" (1 0 -4) + \"1.0pre2\" (1 0 -1 2) + \"1.0PRE2\" (1 0 -1 2) + \"22.8beta3\" (22 8 -2 3) + \"22.8 Beta3\" (22 8 -2 3) + \"0.9alpha1\" (0 9 -3 1) + \"0.9AlphA1\" (0 9 -3 1) + \"0.9 alpha\" (0 9 -3) + +Each element has the following form: + + (REGEXP . PRIORITY) + +Where: + +REGEXP regexp used to match non-numeric part of a version string. + It should begin with the `^' anchor and end with a `$' to + prevent false hits. Letter-case is ignored while matching + REGEXP. + +PRIORITY a negative integer specifying non-numeric priority of REGEXP.") + + +(defun version-to-list (ver) + "Convert version string VER into a list of integers. + +The version syntax is given by the following EBNF: + + VERSION ::= NUMBER ( SEPARATOR NUMBER )*. + + NUMBER ::= (0|1|2|3|4|5|6|7|8|9)+. + + SEPARATOR ::= `version-separator' (which see) + | `version-regexp-alist' (which see). + +The NUMBER part is optional if SEPARATOR is a match for an element +in `version-regexp-alist'. + +Examples of valid version syntax: + + 1.0pre2 1.0.7.5 22.8beta3 0.9alpha1 6.9.30Beta + +Examples of invalid version syntax: + + 1.0prepre2 1.0..7.5 22.8X3 alpha3.2 .5 + +Examples of version conversion: + + Version String Version as a List of Integers + \"1.0.7.5\" (1 0 7 5) + \"1.0pre2\" (1 0 -1 2) + \"1.0PRE2\" (1 0 -1 2) + \"22.8beta3\" (22 8 -2 3) + \"22.8Beta3\" (22 8 -2 3) + \"0.9alpha1\" (0 9 -3 1) + \"0.9AlphA1\" (0 9 -3 1) + \"0.9alpha\" (0 9 -3) + \"0.9snapshot\" (0 9 -4) + \"1.0-git\" (1 0 -4) + +See documentation for `version-separator' and `version-regexp-alist'." + (or (and (stringp ver) (> (length ver) 0)) + (error "Invalid version string: '%s'" ver)) + ;; Change .x.y to 0.x.y + (if (and (>= (length ver) (length version-separator)) + (string-equal (substring ver 0 (length version-separator)) + version-separator)) + (setq ver (concat "0" ver))) + (save-match-data + (let ((i 0) + (case-fold-search t) ; ignore case in matching + lst s al) + (while (and (setq s (string-match "[0-9]+" ver i)) + (= s i)) + ;; handle numeric part + (setq lst (cons (string-to-number (substring ver i (match-end 0))) + lst) + i (match-end 0)) + ;; handle non-numeric part + (when (and (setq s (string-match "[^0-9]+" ver i)) + (= s i)) + (setq s (substring ver i (match-end 0)) + i (match-end 0)) + ;; handle alpha, beta, pre, etc. separator + (unless (string= s version-separator) + (setq al version-regexp-alist) + (while (and al (not (string-match (caar al) s))) + (setq al (cdr al))) + (cond (al + (push (cdar al) lst)) + ;; Convert 22.3a to 22.3.1, 22.3b to 22.3.2, etc. + ((string-match "^[-_+ ]?\\([a-zA-Z]\\)$" s) + (push (- (aref (downcase (match-string 1 s)) 0) ?a -1) + lst)) + (t (error "Invalid version syntax: '%s'" ver)))))) + (if (null lst) + (error "Invalid version syntax: '%s'" ver) + (nreverse lst))))) + + +(defun version-list-< (l1 l2) + "Return t if L1, a list specification of a version, is lower than L2. + +Note that a version specified by the list (1) is equal to (1 0), +\(1 0 0), (1 0 0 0), etc. That is, the trailing zeros are insignificant. +Also, a version given by the list (1) is higher than (1 -1), which in +turn is higher than (1 -2), which is higher than (1 -3)." + (while (and l1 l2 (= (car l1) (car l2))) + (setq l1 (cdr l1) + l2 (cdr l2))) + (cond + ;; l1 not null and l2 not null + ((and l1 l2) (< (car l1) (car l2))) + ;; l1 null and l2 null ==> l1 length = l2 length + ((and (null l1) (null l2)) nil) + ;; l1 not null and l2 null ==> l1 length > l2 length + (l1 (< (version-list-not-zero l1) 0)) + ;; l1 null and l2 not null ==> l2 length > l1 length + (t (< 0 (version-list-not-zero l2))))) + + +(defun version-list-= (l1 l2) + "Return t if L1, a list specification of a version, is equal to L2. + +Note that a version specified by the list (1) is equal to (1 0), +\(1 0 0), (1 0 0 0), etc. That is, the trailing zeros are insignificant. +Also, a version given by the list (1) is higher than (1 -1), which in +turn is higher than (1 -2), which is higher than (1 -3)." + (while (and l1 l2 (= (car l1) (car l2))) + (setq l1 (cdr l1) + l2 (cdr l2))) + (cond + ;; l1 not null and l2 not null + ((and l1 l2) nil) + ;; l1 null and l2 null ==> l1 length = l2 length + ((and (null l1) (null l2))) + ;; l1 not null and l2 null ==> l1 length > l2 length + (l1 (zerop (version-list-not-zero l1))) + ;; l1 null and l2 not null ==> l2 length > l1 length + (t (zerop (version-list-not-zero l2))))) + + +(defun version-list-<= (l1 l2) + "Return t if L1, a list specification of a version, is lower or equal to L2. + +Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0), +etc. That is, the trailing zeroes are insignificant. Also, integer +list (1) is greater than (1 -1) which is greater than (1 -2) +which is greater than (1 -3)." + (while (and l1 l2 (= (car l1) (car l2))) + (setq l1 (cdr l1) + l2 (cdr l2))) + (cond + ;; l1 not null and l2 not null + ((and l1 l2) (< (car l1) (car l2))) + ;; l1 null and l2 null ==> l1 length = l2 length + ((and (null l1) (null l2))) + ;; l1 not null and l2 null ==> l1 length > l2 length + (l1 (<= (version-list-not-zero l1) 0)) + ;; l1 null and l2 not null ==> l2 length > l1 length + (t (<= 0 (version-list-not-zero l2))))) + +(defun version-list-not-zero (lst) + "Return the first non-zero element of LST, which is a list of integers. + +If all LST elements are zeros or LST is nil, return zero." + (while (and lst (zerop (car lst))) + (setq lst (cdr lst))) + (if lst + (car lst) + ;; there is no element different of zero + 0)) + + +(defun version< (v1 v2) + "Return t if version V1 is lower (older) than V2. + +Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\", +etc. That is, the trailing \".0\"s are insignificant. Also, version +string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\", +which is higher than \"1alpha\", which is higher than \"1snapshot\". +Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions." + (version-list-< (version-to-list v1) (version-to-list v2))) + +(defun version<= (v1 v2) + "Return t if version V1 is lower (older) than or equal to V2. + +Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\", +etc. That is, the trailing \".0\"s are insignificant. Also, version +string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\", +which is higher than \"1alpha\", which is higher than \"1snapshot\". +Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions." + (version-list-<= (version-to-list v1) (version-to-list v2))) + +(defun version= (v1 v2) + "Return t if version V1 is equal to V2. + +Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\", +etc. That is, the trailing \".0\"s are insignificant. Also, version +string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\", +which is higher than \"1alpha\", which is higher than \"1snapshot\". +Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions." + (version-list-= (version-to-list v1) (version-to-list v2))) + +(defvar package--builtin-versions + ;; Mostly populated by loaddefs.el via autoload-builtin-package-versions. + (purecopy `((emacs . ,(version-to-list emacs-version)))) + "Alist giving the version of each versioned builtin package. +I.e. each element of the list is of the form (NAME . VERSION) where +NAME is the package name as a symbol, and VERSION is its version +as a list.") + +(defun package--description-file (dir) + (concat (let ((subdir (file-name-nondirectory + (directory-file-name dir)))) + (if (string-match "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)" subdir) + (match-string 1 subdir) subdir)) + "-pkg.el")) + + +;;; Misc. +(defconst menu-bar-separator '("--") + "Separator for menus.") + +;; The following statement ought to be in print.c, but `provide' can't +;; be used there. +;; http://lists.gnu.org/archive/html/emacs-devel/2009-08/msg00236.html +(when (hash-table-p (car (read-from-string + (prin1-to-string (make-hash-table))))) + (provide 'hashtable-print-readable)) + +;; This is used in lisp/Makefile.in and in leim/Makefile.in to +;; generate file names for autoloads, custom-deps, and finder-data. +(defun unmsys--file-name (file) + "Produce the canonical file name for FILE from its MSYS form. + +On systems other than MS-Windows, just returns FILE. +On MS-Windows, converts /d/foo/bar form of file names +passed by MSYS Make into d:/foo/bar that Emacs can grok. + +This function is called from lisp/Makefile and leim/Makefile." + (when (and (eq system-type 'windows-nt) + (string-match "\\`/[a-zA-Z]/" file)) + (setq file (concat (substring file 1 2) ":" (substring file 2)))) + file) + + +;;; subr.el ends here diff --git a/tests/examplefiles/test.adls b/tests/examplefiles/test.adls new file mode 100644 index 00000000..1cdb2daf --- /dev/null +++ b/tests/examplefiles/test.adls @@ -0,0 +1,313 @@ +-- +-- Example of an openEHR Archetype, written in the Archetype Definition Language (ADL) +-- Definition available here: http://www.openehr.org/releases/trunk/architecture/am/adl2.pdf +-- Author: derived from the openEHR-EHR-EVALUATION.adverse_reaction.v1 archetype at http://www.openEHR.org/ckm +-- + +archetype (adl_version=2.0.5; rm_release=1.0.2; generated) + openEHR-EHR-EVALUATION.adverse_reaction.v1.0.0 + +language + original_language = <[ISO_639-1::en]> + +description + lifecycle_state = <"unmanaged"> + original_author = < + ["name"] = <"Heather Leslie"> + ["organisation"] = <"Ocean Informatics"> + ["email"] = <"heather.leslie@oceaninformatics.com"> + ["date"] = <"2010-11-08"> + > + copyright = <"© openEHR Foundation"> + details = < + ["en"] = < + language = <[ISO_639-1::en]> + purpose = <"To record information about any harmful..."> + use = <"Use to record all information about the presence ..."> + keywords = <"reaction", "allergy", "allergic", "adverse"> + misuse = <"Not to be used for recording the absence (or ..."> + > + > + other_contributors = <"Jane Doe, Australia"> + other_details = < + ["references"] = <"Adverse Reaction, draft archetype, ..."> + ["MD5-CAM-1.0.1"] = <"260699D2EFDE4F7C7BC3C6C501A51A61"> + > + +definition + EVALUATION[id1] matches { -- Adverse Reaction + data matches { + ITEM_TREE[id2] matches { + items cardinality matches {1..*; unordered} matches { + ELEMENT[id3] matches { -- Substance/Agent + value matches { + DV_TEXT[id51] + } + } + ELEMENT[id5] occurrences matches {0..1} matches { -- Absolute Contraindication? + value matches { + DV_BOOLEAN[id52] matches { + value matches {True} + } + } + } + ELEMENT[id50] occurrences matches {0..1} matches { -- Future Use + value matches { + DV_TEXT[id53] + } + } + ELEMENT[id7] occurrences matches {0..1} matches { -- Overall Comment + value matches { + DV_TEXT[id54] + } + } + CLUSTER[id10] matches { -- Reaction Event + items matches { + ELEMENT[id11] occurrences matches {0..1} matches { -- Specific Substance/Agent + value matches { + DV_TEXT[id55] + } + } + ELEMENT[id12] matches { -- Manifestation + value matches { + DV_TEXT[id56] + } + } + ELEMENT[id17] occurrences matches {0..1} matches { -- Reaction Type + value matches { + DV_TEXT[id57] + } + } + ELEMENT[id22] occurrences matches {0..1} matches { -- Certainty + value matches { + DV_CODED_TEXT[id58] matches { + defining_code matches {[ac1]} -- Certainty (synthesised) + } + } + } + ELEMENT[id13] occurrences matches {0..1} matches { -- Reaction Description + value matches { + DV_TEXT[id59] + } + } + ELEMENT[id28] occurrences matches {0..1} matches { -- Onset of Reaction + value matches { + DV_DATE_TIME[id60] + } + } + ELEMENT[id29] occurrences matches {0..1} matches { -- Duration of Reaction + value matches { + DV_DURATION[id61] + } + } + allow_archetype CLUSTER[id30] matches { -- Additional Reaction Detail + include + archetype_id/value matches {/openEHR-EHR-CLUSTER\.anatomical_location(-a-zA-Z0-9_]+)*\.v1/} + } + ELEMENT[id19] occurrences matches {0..1} matches { -- Exposure Description + value matches { + DV_TEXT[id62] + } + } + ELEMENT[id21] occurrences matches {0..1} matches { -- Earliest Exposure + value matches { + DV_DATE_TIME[id63] + } + } + ELEMENT[id26] occurrences matches {0..1} matches { -- Duration of Exposure + value matches { + DV_DURATION[id64] + } + } + allow_archetype CLUSTER[id20] matches { -- Additional Exposure Detail + include + archetype_id/value matches {/openEHR-EHR-CLUSTER\.amount(-a-zA-Z0-9_]+)*\.v1|openEHR-EHR-CLUSTER\.medication_admin(-a-zA-Z0-9_]+)*\.v1|openEHR-EHR-CLUSTER\.timing(-a-zA-Z0-9_]+)*\.v1/} + } + ELEMENT[id41] occurrences matches {0..1} matches { -- Clinical Management Description + value matches { + DV_TEXT[id65] + } + } + ELEMENT[id32] matches { -- Multimedia + value matches { + DV_MULTIMEDIA[id66] matches { + media_type + } + } + } + allow_archetype CLUSTER[id42] matches { -- Reporting Details + include + archetype_id/value matches {/.*/} + } + ELEMENT[id33] occurrences matches {0..1} matches { -- Reaction Comment + value matches { + DV_TEXT[id67] + } + } + } + } + } + } + } + protocol matches { + ITEM_TREE[id43] matches { + items matches { + ELEMENT[id45] occurrences matches {0..1} matches { -- Reaction Reported? + value matches { + DV_BOOLEAN[id68] matches { + value matches {True, False} + } + } + } + ELEMENT[id49] occurrences matches {0..1} matches { -- Report Comment + value matches { + DV_TEXT[id69] + } + } + ELEMENT[id46] matches { -- Adverse Reaction Report + value matches { + DV_URI[id70] + } + } + ELEMENT[id48] occurrences matches {0..1} matches { -- Supporting Clinical Record Information + value matches { + DV_EHR_URI[id71] + } + } + } + } + } + } + +terminology + term_definitions = < + ["en"] = < + ["id1"] = < + text = <"Adverse Reaction"> + description = <"A harmful or undesirable, unexpected effect associated with exposure to any substance or agent, including food, plants, animals, venom from animal stings, or a medication at therapeutic or sub-therapeutic doses."> + > + ["id3"] = < + text = <"Substance/Agent"> + description = <"Identification of a substance, agent, or a class of substance, that is considered to be responsible for the Adverse Reaction."> + > + ["id5"] = < + text = <"Absolute Contraindication?"> + description = <"Is administration of this Substance/Agent absolutely contraindicated in this individual?"> + > + ["id7"] = < + text = <"Overall Comment"> + description = <"Additional narrative about the Adverse Reaction as a whole, not captured in other fields."> + > + ["id10"] = < + text = <"Reaction Event"> + description = <"Details about each Adverse Reaction Event."> + > + ["id11"] = < + text = <"Specific Substance/Agent"> + description = <"Specific identification of the actual Substance/Agent considered to be responsible for the Adverse Reaction event."> + > + ["id12"] = < + text = <"Manifestation"> + description = <"Clinical manifestation of the Adverse Reaction expressed as a single word, phrase or brief description, e.g. nausea or rash."> + > + ["id13"] = < + text = <"Reaction Description"> + description = <"Narrative description of the Adverse Reaction."> + > + ["id17"] = < + text = <"Reaction Type"> + description = <"The type of Adverse Reaction as determined by the clinician."> + > + ["id19"] = < + text = <"Exposure Description"> + description = <"Description about exposure to the Substance/Agent."> + > + ["id20"] = < + text = <"Additional Exposure Detail"> + description = <"Additional detail about exposure/s for this Adverse Reaction event, including structured medication amount/frequency/route information."> + > + ["id21"] = < + text = <"Earliest Exposure"> + description = <"Record of the date and/or time of the earliest or initial exposure to the Substance/Agent."> + > + ["id22"] = < + text = <"Certainty"> + description = <"Degree of certainty, as assessed by a clinician, that the specific Substance/Agent was the cause of the Adverse Reaction."> + > + ["at23"] = < + text = <"Suspected"> + description = <"Possibly the causative agent."> + > + ["at24"] = < + text = <"Probable"> + description = <"Likely to be the causative agent, but not confirmed by testing or rechallenge."> + > + ["at25"] = < + text = <"Confirmed"> + description = <"Confirmed as the causative agent, by testing or rechallenge."> + > + ["id26"] = < + text = <"Duration of Exposure"> + description = <"The amount of time of exposure to the Substance/Agent."> + > + ["id28"] = < + text = <"Onset of Reaction"> + description = <"Record of the date and/or time of the onset of the Adverse Reaction."> + > + ["id29"] = < + text = <"Duration of Reaction"> + description = <"The amount of time that the Adverse Reaction was present."> + > + ["id30"] = < + text = <"Additional Reaction Detail"> + description = <"Additional detail about the Adverse Reaction, including anatomical location."> + > + ["id32"] = < + text = <"Multimedia"> + description = <"Inclusion of any multimedia file to support the recording of the Adverse Reaction event."> + > + ["id33"] = < + text = <"Reaction Comment"> + description = <"Additional narrative about the Adverse Reaction event not captured in other fields."> + > + ["id41"] = < + text = <"Clinical Management Description"> + description = <"Narrative description of the clinical management provided."> + > + ["id42"] = < + text = <"Reporting Details"> + description = <"Further details required for reporting to regulatory bodies."> + > + ["id45"] = < + text = <"Reaction Reported?"> + description = <"Was the Adverse Reaction reported to a regulatory body?"> + > + ["id46"] = < + text = <"Adverse Reaction Report"> + description = <"Link to an Adverse Reaction Report sent to a regulatory body."> + > + ["id48"] = < + text = <"Supporting Clinical Record Information"> + description = <"Link to further information about the presentation and findings that exist elsewhere in the health record, including allergy test reports."> + > + ["id49"] = < + text = <"Report Comment"> + description = <"Additional narrative about the Adverse Reaction Report, including the reason for non-reporting, if required."> + > + ["id50"] = < + text = <"Future Use"> + description = <"Narrative description of clinician instructions or advice related to future exposure to, or administration of, the Substance/Agent."> + > + ["ac1"] = < + text = <"Certainty (synthesised)"> + description = <"Degree of certainty, as assessed by a clinician, that the specific Substance/Agent was the cause of the Adverse Reaction. (synthesised)"> + > + > + > + value_sets = < + ["ac1"] = < + id = <"ac1"> + members = <"at23", "at24", "at25"> + > + > + diff --git a/tests/examplefiles/test.bpl b/tests/examplefiles/test.bpl new file mode 100644 index 00000000..add25e1a --- /dev/null +++ b/tests/examplefiles/test.bpl @@ -0,0 +1,140 @@ +/* + * Test Boogie rendering +*/ + +const N: int; +axiom 0 <= N; + +procedure foo() { + break; +} +// array to sort as global array, because partition & quicksort have to +var a: [int] int; +var original: [int] int; +var perm: [int] int; + +// Is array a of length N sorted? +function is_sorted(a: [int] int, l: int, r: int): bool +{ + (forall j, k: int :: l <= j && j < k && k <= r ==> a[j] <= a[k]) +} + +// is range a[l:r] unchanged? +function is_unchanged(a: [int] int, b: [int] int, l: int, r: int): bool { + (forall i: int :: l <= i && i <= r ==> a[i] == b[i]) +} + +function is_permutation(a: [int] int, original: [int] int, perm: [int] int, N: int): bool +{ + (forall k: int :: 0 <= k && k < N ==> 0 <= perm[k] && perm[k] < N) && + (forall k, j: int :: 0 <= k && k < j && j < N ==> perm[k] != perm[j]) && + (forall k: int :: 0 <= k && k < N ==> a[k] == original[perm[k]]) +} + +function count(a: [int] int, x: int, N: int) returns (int) +{ if N == 0 then 0 else if a[N-1] == x then count(a, x, N - 1) + 1 else count(a, x, N-1) } + + +/* +function count(a: [int] int, x: int, N: int) returns (int) +{ if N == 0 then 0 else if a[N-1] == x then count(a, x, N - 1) + 1 else count(a, x, N-1) } + +function is_permutation(a: [int] int, b: [int] int, l: int, r: int): bool { + (forall i: int :: l <= i && i <= r ==> count(a, a[i], r+1) == count(b, a[i], r+1)) +} +*/ + +procedure partition(l: int, r: int, N: int) returns (p: int) + modifies a, perm; + requires N > 0; + requires l >= 0 && l < r && r < N; + requires ((r+1) < N) ==> (forall k: int :: (k >= l && k <= r) ==> a[k] <= a[r+1]); + requires ((l-1) >= 0) ==> (forall k: int :: (k >= l && k <= r) ==> a[k] > a[l-1]); + + /* a is a permutation of the original array original */ + requires is_permutation(a, original, perm, N); + + ensures (forall k: int :: (k >= l && k <= p ) ==> a[k] <= a[p]); + ensures (forall k: int :: (k > p && k <= r ) ==> a[k] > a[p]); + ensures p >= l && p <= r; + ensures is_unchanged(a, old(a), 0, l-1); + ensures is_unchanged(a, old(a), r+1, N); + ensures ((r+1) < N) ==> (forall k: int :: (k >= l && k <= r) ==> a[k] <= a[r+1]); + ensures ((l-1) >= 0) ==> (forall k: int :: (k >= l && k <= r) ==> a[k] > a[l-1]); + + /* a is a permutation of the original array original */ + ensures is_permutation(a, original, perm, N); +{ + var i: int; + var sv: int; + var pivot: int; + var tmp: int; + + i := l; + sv := l; + pivot := a[r]; + + while (i < r) + invariant i <= r && i >= l; + invariant sv <= i && sv >= l; + invariant pivot == a[r]; + invariant (forall k: int :: (k >= l && k < sv) ==> a[k] <= old(a[r])); + invariant (forall k: int :: (k >= sv && k < i) ==> a[k] > old(a[r])); + + /* a is a permutation of the original array original */ + invariant is_permutation(a, original, perm, N); + + invariant is_unchanged(a, old(a), 0, l-1); + invariant is_unchanged(a, old(a), r+1, N); + invariant ((r+1) < N) ==> (forall k: int :: (k >= l && k <= r) ==> a[k] <= a[r+1]); + invariant ((l-1) >= 0) ==> (forall k: int :: (k >= l && k <= r) ==> a[k] > a[l-1]); + { + if ( a[i] <= pivot) { + tmp := a[i]; a[i] := a[sv]; a[sv] := tmp; + tmp := perm[i]; perm[i] := perm[sv]; perm[sv] := tmp; + sv := sv +1; + } + i := i + 1; + } + + //swap + tmp := a[i]; a[i] := a[sv]; a[sv] := tmp; + tmp := perm[i]; perm[i] := perm[sv]; perm[sv] := tmp; + + p := sv; +} + + +procedure quicksort(l: int, r: int, N: int) + modifies a, perm; + + requires N > 0; + requires l >= 0 && l < r && r < N; + requires ((r+1) < N) ==> (forall k: int :: (k >= l && k <= r) ==> a[k] <= a[r+1]); + requires ((l-1) >= 0) ==> (forall k: int :: (k >= l && k <= r) ==> a[k] > a[l-1]); + + /* a is a permutation of the original array original */ + requires is_permutation(a, original, perm, N); + + ensures ((r+1) < N) ==> (forall k: int :: (k >= l && k <= r) ==> a[k] <= a[r+1]); + ensures ((l-1) >= 0) ==> (forall k: int :: (k >= l && k <= r) ==> a[k] > a[l-1]); + + ensures is_unchanged(a, old(a), 0, l-1); + ensures is_unchanged(a, old(a), r+1, N); + ensures is_sorted(a, l, r); + + /* a is a permutation of the original array original */ + ensures is_permutation(a, original, perm, N); +{ + var p: int; + + call p := partition(l, r, N); + + if ((p-1) > l) { + call quicksort(l, p-1, N); + } + + if ((p+1) < r) { + call quicksort(p+1, r, N); + } +} diff --git a/tests/examplefiles/test.cadl b/tests/examplefiles/test.cadl new file mode 100644 index 00000000..5c3f4881 --- /dev/null +++ b/tests/examplefiles/test.cadl @@ -0,0 +1,32 @@ + -- + -- Example fragment of an openEHR Archetype, written in cADL, a subsyntax of the Archetype Definition Language (ADL) + -- definition available here: http://www.openehr.org/releases/trunk/architecture/am/adl2.pdf + -- Author: Thomas Beale + -- + + EVALUATION[id1] matches { -- Adverse Reaction + data matches { + ITEM_TREE[id2] matches { + items cardinality matches {1..*; unordered} matches { + ELEMENT[id3] matches { -- Substance/Agent + value matches { + DV_TEXT[id51] + } + } + ELEMENT[id50] occurrences matches {0..1} matches { -- Future Use + value matches { + DV_TEXT[id53] + } + } + CLUSTER[id10] matches { -- Reaction Event + items matches { + allow_archetype CLUSTER[id30] matches { -- Additional Reaction Detail + include + archetype_id/value matches {/openEHR-EHR-CLUSTER\.anatomical_location(-a-zA-Z0-9_]+)*\.v1/} + } + } + } + } + } + } + } diff --git a/tests/examplefiles/test.gradle b/tests/examplefiles/test.gradle new file mode 100644 index 00000000..0bc834c1 --- /dev/null +++ b/tests/examplefiles/test.gradle @@ -0,0 +1,20 @@ +apply plugin: 'java' + +repositories { + mavenCentral() +} + +dependencies { + testCompile 'junit:junit:4.12' +} + +task sayHello << { + def x = SomeClass.worldString + println "Hello ${x}" +} + +private class SomeClass { + public static String getWorldString() { + return "world" + } +} diff --git a/tests/examplefiles/test.odin b/tests/examplefiles/test.odin new file mode 100644 index 00000000..05b01d22 --- /dev/null +++ b/tests/examplefiles/test.odin @@ -0,0 +1,43 @@ +-- +-- Example of a fragment of an openEHR Archetype, written in the Object Data Instance Notation (ODIN) +-- Definition available here: https://github.com/openEHR/odin +-- Author: Thomas Beale +-- + + original_author = < + ["name"] = <"Dr J Joyce"> + ["organisation"] = <"NT Health Service"> + ["date"] = <2003-08-03> + > + term_bindings = < + ["umls"] = < + ["id1"] = <http://umls.nlm.edu/id/C124305> -- apgar result + ["id2"] = <http://umls.nlm.edu/id/0000000> -- 1-minute event + > + > + lifecycle_state = <"initial"> + resource_package_uri = <"http://www.aihw.org.au/data_sets/diabetic_archetypes.html"> + + details = < + ["en"] = < + language = <[iso_639-1::en]> + purpose = <"archetype for diabetic patient review"> + use = <"used for all hospital or clinic-based diabetic reviews, + including first time. Optional sections are removed according to the particular review" + > + misuse = <"not appropriate for pre-diagnosis use"> + original_resource_uri = <"http://www.healthdata.org.au/data_sets/diabetic_review_data_set_1.html"> + > + ["de"] = < + language = <[iso_639-1::de]> + purpose = <"Archetyp für die Untersuchung von Patienten mit Diabetes"> + use = <"wird benutzt für alle Diabetes-Untersuchungen im + Krankenhaus, inklusive der ersten Vorstellung. Optionale + Abschnitte werden in Abhängigkeit von der speziellen + Vorstellung entfernt." + > + misuse = <"nicht geeignet für Benutzung vor Diagnosestellung"> + original_resource_uri = <"http://www.healthdata.org.au/data_sets/diabetic_review_data_set_1.html"> + > + > + diff --git a/tests/examplefiles/test.psl b/tests/examplefiles/test.psl new file mode 100644 index 00000000..3ac99498 --- /dev/null +++ b/tests/examplefiles/test.psl @@ -0,0 +1,182 @@ +// This is a comment + +// 1. Basics + +// Functions +func Add(X : Univ_Integer; Y : Univ_Integer) -> Univ_Integer is + return X + Y; +end func Add; +// End of line semi-colons are optional +// +, +=, -, -=, *, *=, /, /= +// all do what you'd expect (/ is integer division) + +// If you find Univ_Integer to be too verbose you can import Short_Names +// which defines aliases like Int for Univ_Integer and String for Univ_String +import PSL::Short_Names::*, * + +func Greetings() is + const S : String := "Hello, World!" + Println(S) +end func Greetings +// All declarations are 'const', 'var', or 'ref' +// Assignment is :=, equality checks are ==, and != is not equals + +func Boolean_Examples(B : Bool) is + const And := B and #true // Parallel execution of operands + const And_Then := B and then #true // Short-Circuit + const Or := B or #false // Parallel execution of operands + const Or_Else := B or else #false // Short-Cirtuit + const Xor := B xor #true + var Result : Bool := #true; + Result and= #false; + Result or= #true; + Result xor= #false; +end func Boolean_Examples +// Booleans are a special type of enumeration +// All enumerations are preceded by a sharp '#' + +func Fib(N : Int) {N >= 0} -> Int is + if N <= 1 then + return N + else + // Left and right side of '+' are computed in Parallel here + return Fib(N - 1) + Fib(N - 2) + end if +end func Fib +// '{N >= 0}' is a precondition to this function +// Preconditions are built in to the language and checked by the compiler + +// ParaSail does not have mutable global variables +// Instead, use 'var' parameters +func Increment_All(var Nums : Vector<Int>) is + for each Elem of Nums concurrent loop + Elem += 1 + end loop +end func Increment_All +// The 'concurrent' keyword in the loop header tells the compiler that +// iterations of the loop can happen in any order. +// It will choose the most optimal number of threads to use. +// Other options are 'forward' and 'reverse'. + +func Sum_Of_Squares(N : Int) -> Int is + // The type of Sum is inferred + var Sum := 0 + for I in 1 .. N forward loop + Sum += I ** 2 // ** is exponentiation + end loop +end func Sum_Of_Squares + +func Sum_Of(N : Int; Map : func (Int) -> Int) -> Int is + return (for I in 1 .. N => <0> + Map(I)) +end func Sum_Of +// It has functional aspects as well +// Here, we're taking an (Int) -> Int function as a parameter +// and using the inherently parallel map-reduce. +// Initial value is enclosed with angle brackets + +func main(Args : Basic_Array<String>) is + Greetings() // Hello World + Println(Fib(5)) // 5 + // Container Comprehension + var Vec : Vector<Int> := [for I in 0 .. 10 {I mod 2 == 0} => I ** 2] + // Vec = [0, 4, 16, 36, 64, 100] + Increment_All(Vec) + // Vec = [1, 5, 17, 37, 65, 101] + // '|' is an overloaded operator. + // It's usually used for concatenation or adding to a container + Println("First: " | Vec[1] | ", Last: " | Vec[Length(Vec)]); + // Vectors are 1 indexed, 0 indexed ZVectors are also available + + Println(Sum_Of_Squares(3)) + + // Sum of fibs! + Println(Sum_Of(10, Fib)) +end func main + +// Preceding a type with 'optional' allows it to take the value 'null' +func Divide(A, B, C : Real) -> optional Real is + // Real is the floating point type + const Epsilon := 1.0e-6; + if B in -Epsilon .. Epsilon then + return null + elsif C in -Epsilon .. Epsilon then + return null + else + return A / B + A / C + end if +end func Divide + +// 2. Modules +// Modules are composed of an interface and a class +// ParaSail has object orientation features + +// modules can be defined as 'concurrent' +// which allows 'locked' and 'queued' parameters +concurrent interface Locked_Box<Content_Type is Assignable<>> is + // Create a box with the given content + func Create(C : optional Content_Type) -> Locked_Box; + + // Put something into the box + func Put(locked var B : Locked_Box; C : Content_Type); + + // Get a copy of current content + func Content(locked B : Locked_Box) -> optional Content_Type; + + // Remove current content, leaving it null + func Remove(locked var B : Locked_Box) -> optional Content_Type; + + // Wait until content is non-null, then return it, leaving it null. + func Get(queued var B : Locked_Box) -> Content_Type; +end interface Locked_Box; + +concurrent class Locked_Box is + var Content : optional Content_Type; +exports + func Create(C : optional Content_Type) -> Locked_Box is + return (Content => C); + end func Create; + + func Put(locked var B : Locked_Box; C : Content_Type) is + B.Content := C; + end func Put; + + func Content(locked B : Locked_Box) -> optional Content_Type is + return B.Content; + end func Content; + + func Remove(locked var B : Locked_Box) -> Result : optional Content_Type is + // '<==' is the move operator + // It moves the right operand into the left operand, + // leaving the right null. + Result <== B.Content; + end func Remove; + + func Get(queued var B : Locked_Box) -> Result : Content_Type is + queued until B.Content not null then + Result <== B.Content; + end func Get; +end class Locked_Box; + +func Use_Box(Seed : Univ_Integer) is + var U_Box : Locked_Box<Univ_Integer> := Create(null); + // The type of 'Ran' can be left out because + // it is inferred from the return type of Random::Start + var Ran := Random::Start(Seed); + + Println("Starting 100 pico-threads trying to put something in the box"); + Println(" or take something out."); + for I in 1..100 concurrent loop + if I < 30 then + Println("Getting out " | Get(U_Box)); + else + Println("Putting in " | I); + U_Box.Put(I); + + // The first parameter can be moved to the front with a dot + // X.Foo(Y) is equivalent to Foo(X, Y) + end if; + end loop; + + Println("And the winner is: " | Remove(U_Box)); + Println("And the box is now " | Content(U_Box)); +end func Use_Box; diff --git a/tests/examplefiles/test2.odin b/tests/examplefiles/test2.odin new file mode 100644 index 00000000..2a6b4517 --- /dev/null +++ b/tests/examplefiles/test2.odin @@ -0,0 +1,30 @@ +school_schedule = < + lesson_times = <08:30:00, 09:30:00, 10:30:00, ...> + + locations = < + [1] = <"under the big plane tree"> + [2] = <"under the north arch"> + [3] = <"in a garden"> + > + + subjects = < + ["philosophy:plato"] = < -- note construction of key + name = <"philosophy"> + teacher = <"plato"> + topics = <"meta-physics", "natural science"> + weighting = <76%> + > + ["philosophy:kant"] = < + name = <"philosophy"> + teacher = <"kant"> + topics = <"meaning and reason", "meta-physics", "ethics"> + weighting = <80%> + > + ["art"] = < + name = <"art"> + teacher = <"goya"> + topics = <"technique", "portraiture", "satire"> + weighting = <78%> + > + > +> diff --git a/tests/examplefiles/test_basic.adls b/tests/examplefiles/test_basic.adls new file mode 100644 index 00000000..df5aa743 --- /dev/null +++ b/tests/examplefiles/test_basic.adls @@ -0,0 +1,28 @@ +-- +-- Example of an openEHR Archetype, written in the Archetype Definition Language (ADL) +-- Definition available here: http://www.openehr.org/releases/trunk/architecture/am/adl2.pdf +-- Author: derived from the openEHR-EHR-EVALUATION.adverse_reaction.v1 archetype at http://www.openEHR.org/ckm +-- + +archetype (adl_version=2.0.5; rm_release=1.0.2; generated) + openEHR-EHR-EVALUATION.adverse_reaction.v1.0.0 + +language + original_language = <[ISO_639-1::en]> + +description + lifecycle_state = <"unmanaged"> + +definition + EVALUATION[id1] + +terminology + term_definitions = < + ["en"] = < + ["id1"] = < + text = <"Adverse Reaction"> + description = <"xxx"> + > + > + > + diff --git a/tests/run.py b/tests/run.py index c54e0bfa..8167b911 100644 --- a/tests/run.py +++ b/tests/run.py @@ -8,7 +8,7 @@ python run.py [testfile ...] - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/string_asserts.py b/tests/string_asserts.py index 3aa50420..11f5c7f0 100644 --- a/tests/string_asserts.py +++ b/tests/string_asserts.py @@ -3,7 +3,7 @@ Pygments string assert utility ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 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 84dd49bb..be74c1bf 100644 --- a/tests/test_basic_api.py +++ b/tests/test_basic_api.py @@ -3,7 +3,7 @@ Pygments basic API tests ~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_cfm.py b/tests/test_cfm.py index 2ff25bd6..2585489a 100644 --- a/tests/test_cfm.py +++ b/tests/test_cfm.py @@ -1,9 +1,9 @@ # -*- coding: utf-8 -*- """ Basic ColdfusionHtmlLexer Test - ~~~~~~~~~~~~~~~~~ + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_clexer.py b/tests/test_clexer.py index 4aac6d39..6a3dcbce 100644 --- a/tests/test_clexer.py +++ b/tests/test_clexer.py @@ -3,7 +3,7 @@ Basic CLexer Test ~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 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 da6b2bec..5883fb5c 100644 --- a/tests/test_cmdline.py +++ b/tests/test_cmdline.py @@ -3,7 +3,7 @@ Command line test ~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ @@ -151,7 +151,7 @@ class CmdLineTest(unittest.TestCase): o = self.check_success('-Fhighlight:tokentype=Name.Blubb,' 'names=TESTFILE filename', '-fhtml', filename) - self.assertTrue('<span class="n-Blubb' in o) + self.assertTrue('<span class="n n-Blubb' in o) def test_H_opt(self): o = self.check_success('-H', 'formatter', 'html') diff --git a/tests/test_examplefiles.py b/tests/test_examplefiles.py index faa200fe..924e1184 100644 --- a/tests/test_examplefiles.py +++ b/tests/test_examplefiles.py @@ -3,7 +3,7 @@ Pygments tests with example files ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_html_formatter.py b/tests/test_html_formatter.py index 92a0415b..a82aaaf7 100644 --- a/tests/test_html_formatter.py +++ b/tests/test_html_formatter.py @@ -3,7 +3,7 @@ Pygments HTML formatter tests ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_inherit.py b/tests/test_inherit.py index 0bccb91a..34033a08 100644 --- a/tests/test_inherit.py +++ b/tests/test_inherit.py @@ -3,7 +3,7 @@ Tests for inheritance in RegexLexer ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_java.py b/tests/test_java.py index 9cf96373..33a64e99 100644 --- a/tests/test_java.py +++ b/tests/test_java.py @@ -3,7 +3,7 @@ Basic JavaLexer Test ~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_latex_formatter.py b/tests/test_latex_formatter.py index 0a433c85..56b5db2e 100644 --- a/tests/test_latex_formatter.py +++ b/tests/test_latex_formatter.py @@ -3,7 +3,7 @@ Pygments LaTeX formatter tests ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_lexers_other.py b/tests/test_lexers_other.py index e3625a2b..bb667c05 100644 --- a/tests/test_lexers_other.py +++ b/tests/test_lexers_other.py @@ -3,17 +3,15 @@ Tests for other lexers ~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ - import glob import os import unittest from pygments.lexers import guess_lexer -from pygments.lexers.scripting import RexxLexer - +from pygments.lexers.scripting import EasytrieveLexer, JclLexer, RexxLexer def _exampleFilePath(filename): return os.path.join(os.path.dirname(__file__), 'examplefiles', filename) @@ -36,7 +34,24 @@ class AnalyseTextTest(unittest.TestCase): self.assertEqual(guessedLexer.name, lexer.name) def testCanRecognizeAndGuessExampleFiles(self): - self._testCanRecognizeAndGuessExampleFiles(RexxLexer) + LEXERS_TO_TEST = [ + EasytrieveLexer, + JclLexer, + RexxLexer, + ] + for lexerToTest in LEXERS_TO_TEST: + self._testCanRecognizeAndGuessExampleFiles(lexerToTest) + + +class EasyTrieveLexerTest(unittest.TestCase): + def testCanGuessFromText(self): + self.assertLess(0, EasytrieveLexer.analyse_text('MACRO')) + self.assertLess(0, EasytrieveLexer.analyse_text('\nMACRO')) + self.assertLess(0, EasytrieveLexer.analyse_text(' \nMACRO')) + self.assertLess(0, EasytrieveLexer.analyse_text(' \n MACRO')) + self.assertLess(0, EasytrieveLexer.analyse_text('*\nMACRO')) + self.assertLess(0, EasytrieveLexer.analyse_text( + '*\n *\n\n \n*\n MACRO')) class RexxLexerTest(unittest.TestCase): diff --git a/tests/test_objectiveclexer.py b/tests/test_objectiveclexer.py index 7339f6f7..90bd680f 100644 --- a/tests/test_objectiveclexer.py +++ b/tests/test_objectiveclexer.py @@ -3,7 +3,7 @@ Basic CLexer Test ~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 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 e37539f2..26b2d0a7 100644 --- a/tests/test_perllexer.py +++ b/tests/test_perllexer.py @@ -3,7 +3,7 @@ Pygments regex lexer tests ~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_qbasiclexer.py b/tests/test_qbasiclexer.py index 0290b7a1..8b790cee 100644 --- a/tests/test_qbasiclexer.py +++ b/tests/test_qbasiclexer.py @@ -3,7 +3,7 @@ Tests for QBasic ~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 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 546dfcae..eb25be61 100644 --- a/tests/test_regexlexer.py +++ b/tests/test_regexlexer.py @@ -3,7 +3,7 @@ Pygments regex lexer tests ~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_regexopt.py b/tests/test_regexopt.py index 02a8f56c..dd56a446 100644 --- a/tests/test_regexopt.py +++ b/tests/test_regexopt.py @@ -3,7 +3,7 @@ Tests for pygments.regexopt ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_rtf_formatter.py b/tests/test_rtf_formatter.py index 30b136fd..25784743 100644 --- a/tests/test_rtf_formatter.py +++ b/tests/test_rtf_formatter.py @@ -3,7 +3,7 @@ Pygments RTF formatter tests ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_ruby.py b/tests/test_ruby.py index 89991f74..ab210bad 100644 --- a/tests/test_ruby.py +++ b/tests/test_ruby.py @@ -3,7 +3,7 @@ Basic RubyLexer Test ~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_shell.py b/tests/test_shell.py index eb09e8d1..4eb5a15a 100644 --- a/tests/test_shell.py +++ b/tests/test_shell.py @@ -3,7 +3,7 @@ Basic Shell Tests ~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ @@ -61,3 +61,29 @@ class BashTest(unittest.TestCase): ] self.assertEqual(tokens, list(self.lexer.get_tokens(fragment))) + def testShortVariableNames(self): + fragment = u'x="$"\ny="$_"\nz="$abc"\n' + tokens = [ + # single lone $ + (Token.Name.Variable, u'x'), + (Token.Operator, u'='), + (Token.Literal.String.Double, u'"'), + (Token.Text, u'$'), + (Token.Literal.String.Double, u'"'), + (Token.Text, u'\n'), + # single letter shell var + (Token.Name.Variable, u'y'), + (Token.Operator, u'='), + (Token.Literal.String.Double, u'"'), + (Token.Name.Variable, u'$_'), + (Token.Literal.String.Double, u'"'), + (Token.Text, u'\n'), + # multi-letter user var + (Token.Name.Variable, u'z'), + (Token.Operator, u'='), + (Token.Literal.String.Double, u'"'), + (Token.Name.Variable, u'$abc'), + (Token.Literal.String.Double, u'"'), + (Token.Text, u'\n'), + ] + self.assertEqual(tokens, list(self.lexer.get_tokens(fragment))) diff --git a/tests/test_smarty.py b/tests/test_smarty.py index 20346afd..450e4e6b 100644 --- a/tests/test_smarty.py +++ b/tests/test_smarty.py @@ -3,7 +3,7 @@ Basic SmartyLexer Test ~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_string_asserts.py b/tests/test_string_asserts.py index 90d81d67..ba7b37fa 100644 --- a/tests/test_string_asserts.py +++ b/tests/test_string_asserts.py @@ -3,7 +3,7 @@ Pygments string assert utility tests ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_terminal_formatter.py b/tests/test_terminal_formatter.py new file mode 100644 index 00000000..07337cd5 --- /dev/null +++ b/tests/test_terminal_formatter.py @@ -0,0 +1,51 @@ +# -*- coding: utf-8 -*- +""" + Pygments terminal formatter tests + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. + :license: BSD, see LICENSE for details. +""" + +from __future__ import print_function + +import unittest +import re + +from pygments.util import StringIO +from pygments.lexers.sql import PlPgsqlLexer +from pygments.formatters import TerminalFormatter + +DEMO_TEXT = '''\ +-- comment +select +* from bar; +''' +DEMO_LEXER = PlPgsqlLexer +DEMO_TOKENS = list(DEMO_LEXER().get_tokens(DEMO_TEXT)) + +ANSI_RE = re.compile(r'\x1b[\w\W]*?m') + +def strip_ansi(x): + return ANSI_RE.sub('', x) + +class TerminalFormatterTest(unittest.TestCase): + def test_reasonable_output(self): + out = StringIO() + TerminalFormatter().format(DEMO_TOKENS, out) + plain = strip_ansi(out.getvalue()) + self.assertEqual(DEMO_TEXT.count('\n'), plain.count('\n')) + print(repr(plain)) + + for a, b in zip(DEMO_TEXT.splitlines(), plain.splitlines()): + self.assertEqual(a, b) + + def test_reasonable_output_lineno(self): + out = StringIO() + TerminalFormatter(linenos=True).format(DEMO_TOKENS, out) + plain = strip_ansi(out.getvalue()) + self.assertEqual(DEMO_TEXT.count('\n') + 1, plain.count('\n')) + print(repr(plain)) + + for a, b in zip(DEMO_TEXT.splitlines(), plain.splitlines()): + self.assertTrue(a in b) diff --git a/tests/test_textfmts.py b/tests/test_textfmts.py index de94545a..d355ab68 100644 --- a/tests/test_textfmts.py +++ b/tests/test_textfmts.py @@ -3,7 +3,7 @@ Basic Tests for textfmts ~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 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 c5cc4990..c96bd9ef 100644 --- a/tests/test_token.py +++ b/tests/test_token.py @@ -3,7 +3,7 @@ Test suite for the token module ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ diff --git a/tests/test_unistring.py b/tests/test_unistring.py index 217b2bbf..a414347c 100644 --- a/tests/test_unistring.py +++ b/tests/test_unistring.py @@ -3,7 +3,7 @@ Test suite for the unistring module ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 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 9e53c206..16d865e6 100644 --- a/tests/test_using_api.py +++ b/tests/test_using_api.py @@ -3,7 +3,7 @@ Pygments tests for using() ~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 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 695fb7d2..720b384a 100644 --- a/tests/test_util.py +++ b/tests/test_util.py @@ -3,7 +3,7 @@ Test suite for the util module ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - :copyright: Copyright 2006-2014 by the Pygments team, see AUTHORS. + :copyright: Copyright 2006-2015 by the Pygments team, see AUTHORS. :license: BSD, see LICENSE for details. """ |